diff options
Diffstat (limited to 'gramlib/ploc.ml')
| -rw-r--r-- | gramlib/ploc.ml | 217 |
1 files changed, 217 insertions, 0 deletions
diff --git a/gramlib/ploc.ml b/gramlib/ploc.ml new file mode 100644 index 0000000000..30ae4eaa21 --- /dev/null +++ b/gramlib/ploc.ml @@ -0,0 +1,217 @@ +(* camlp5r *) +(* ploc.ml,v *) +(* Copyright (c) INRIA 2007-2017 *) + +#load "pa_macro.cmo"; + +type t = + { fname : string; + line_nb : int; + bol_pos : int; + line_nb_last : int; + bol_pos_last : int; + bp : int; + ep : int; + comm : string; + ecomm : string } +; + +value make_loc fname line_nb bol_pos (bp, ep) comm = + {fname = fname; line_nb = line_nb; bol_pos = bol_pos; + line_nb_last = line_nb; bol_pos_last = bol_pos; + bp = bp; ep = ep; comm = comm; ecomm = ""} +; + +value make_unlined (bp, ep) = + {fname = ""; line_nb = 1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; + bp = bp; ep = ep; comm = ""; ecomm = ""} +; + +value dummy = + {fname = ""; line_nb = 1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; + bp = 0; ep = 0; comm = ""; ecomm = ""} +; + +value file_name loc = loc.fname; +value first_pos loc = loc.bp; +value last_pos loc = loc.ep; +value line_nb loc = loc.line_nb; +value bol_pos loc = loc.bol_pos; +value line_nb_last loc = loc.line_nb_last; +value bol_pos_last loc = loc.bol_pos_last; +value comment loc = loc.comm; +value comment_last loc = loc.ecomm; + +IFDEF OCAML_VERSION <= OCAML_1_07 OR COMPATIBLE_WITH_OLD_OCAML THEN + value with_bp_ep l bp ep = + {fname = l.fname; line_nb = l.line_nb; bol_pos = l.bol_pos; + line_nb_last = l.line_nb_last; bol_pos_last = l.bol_pos_last; bp = bp; + ep = ep; comm = l.comm; ecomm = l.ecomm} + ; + value with_comm l comm = + {fname = l.fname; line_nb = l.line_nb; bol_pos = l.bol_pos; + line_nb_last = l.line_nb_last; bol_pos_last = l.bol_pos_last; bp = l.bp; + ep = l.ep; comm = comm; ecomm = l.ecomm} + ; +END; + +value encl loc1 loc2 = + if loc1.bp < loc2.bp then + if loc1.ep < loc2.ep then + {fname = loc1.fname; line_nb = loc1.line_nb; bol_pos = loc1.bol_pos; + line_nb_last = loc2.line_nb_last; bol_pos_last = loc2.bol_pos_last; + bp = loc1.bp; ep = loc2.ep; comm = loc1.comm; ecomm = loc2.comm} + else + loc1 + else + if loc2.ep < loc1.ep then + {fname = loc2.fname; line_nb = loc2.line_nb; bol_pos = loc2.bol_pos; + line_nb_last = loc1.line_nb_last; bol_pos_last = loc1.bol_pos_last; + bp = loc2.bp; ep = loc1.ep; comm = loc2.comm; ecomm = loc1.comm} + else + loc2 +; +value shift sh loc = {(loc) with bp = sh + loc.bp; ep = sh + loc.ep}; +value sub loc sh len = {(loc) with bp = loc.bp + sh; ep = loc.bp + sh + len}; +value after loc sh len = + {(loc) with bp = loc.ep + sh; ep = loc.ep + sh + len} +; +value with_comment loc comm = {(loc) with comm = comm}; + +value name = ref "loc"; + +value from_file fname loc = + let (bp, ep) = (first_pos loc, last_pos loc) in + try + let ic = open_in_bin fname in + let strm = Stream.of_channel ic in + let rec loop fname lin = + let rec not_a_line_dir col = + parser cnt + [ [: `c; s :] -> + if cnt < bp then + if c = '\n' then loop fname (lin + 1) + else not_a_line_dir (col + 1) s + else + let col = col - (cnt - bp) in + (fname, lin, col, col + ep - bp) + | [: :] -> + (fname, lin, col, col + 1) ] + in + let rec a_line_dir str n col = + parser + [ [: `'\n' :] -> loop str n + | [: `_; s :] -> a_line_dir str n (col + 1) s ] + in + let rec spaces col = + parser + [ [: `' '; s :] -> spaces (col + 1) s + | [: :] -> col ] + in + let rec check_string str n col = + parser + [ [: `'"'; col = spaces (col + 1); s :] -> a_line_dir str n col s + | [: `c when c <> '\n'; s :] -> + check_string (str ^ String.make 1 c) n (col + 1) s + | [: a = not_a_line_dir col :] -> a ] + in + let check_quote n col = + parser + [ [: `'"'; s :] -> check_string "" n (col + 1) s + | [: a = not_a_line_dir col :] -> a ] + in + let rec check_num n col = + parser + [ [: `('0'..'9' as c); s :] -> + check_num (10 * n + Char.code c - Char.code '0') (col + 1) s + | [: col = spaces col; s :] -> check_quote n col s ] + in + let begin_line = + parser + [ [: `'#'; col = spaces 1; s :] -> check_num 0 col s + | [: a = not_a_line_dir 0 :] -> a ] + in + begin_line strm + in + let r = + try loop fname 1 with + [ Stream.Failure -> + let bol = bol_pos loc in + (fname, line_nb loc, bp - bol, ep - bol) ] + in + do { close_in ic; r } + with + [ Sys_error _ -> (fname, 1, bp, ep) ] +; + +value second_line fname ep0 (line, bp) ep = do { + let ic = open_in fname in + seek_in ic bp; + loop line bp bp where rec loop line bol p = + if p = ep then do { + close_in ic; + if bol = bp then (line, ep0) + else (line, ep - bol) + } + else do { + let (line, bol) = + match input_char ic with + [ '\n' -> (line + 1, p + 1) + | _ -> (line, bol) ] + in + loop line bol (p + 1) + } +}; + +value get loc = do { + if loc.fname = "" || loc.fname = "-" then do { + (loc.line_nb, loc.bp - loc.bol_pos, loc.line_nb, loc.ep - loc.bol_pos, + loc.ep - loc.bp) + } + else do { + let (bl, bc, ec) = + (loc.line_nb, loc.bp - loc.bol_pos, loc.ep - loc.bol_pos) + in + let (el, eep) = second_line loc.fname ec (bl, loc.bp) loc.ep in + (bl, bc, el, eep, ec - bc) + } +}; + +value call_with r v f a = + let saved = r.val in + try do { + r.val := v; + let b = f a in + r.val := saved; + b + } + with e -> do { r.val := saved; raise e } +; + +exception Exc of t and exn; + +value raise loc exc = + match exc with + [ Exc _ _ -> raise exc + | _ -> raise (Exc loc exc) ] +; + +type vala 'a = + [ VaAnt of string + | VaVal of 'a ] +; + +value warned = ref True; +value warning_deprecated_since_6_00 name = + if not warned.val then do { + Printf.eprintf "<W> %s deprecated since version 6.00" name; + warned.val := True + } + else () +; + +value make line_nb bol_pos (bp, ep) = + let _ = warning_deprecated_since_6_00 "Ploc.make" in + {fname = ""; line_nb = line_nb; bol_pos = bol_pos; line_nb_last = line_nb; + bol_pos_last = bol_pos; bp = bp; ep = ep; comm = ""; ecomm = ""} +; |