diff options
Diffstat (limited to 'ocaml-binary-annot/camlp4/Camlp4/Struct/Loc.ml')
| -rw-r--r-- | ocaml-binary-annot/camlp4/Camlp4/Struct/Loc.ml | 307 |
1 files changed, 307 insertions, 0 deletions
diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Loc.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/Loc.ml new file mode 100644 index 0000000000..ac42d4b1c4 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Loc.ml @@ -0,0 +1,307 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +(* camlp4r *) + +open Format; + +(* FIXME + Study these 2 others implementations which change the ghost + handling: + + type pos = ... the same ... + + 1/ + + type loc = { + file_name : string; + start : pos; + stop : pos + }; + + type t = + [ Nowhere + | Ghost of loc (* the closest non ghost loc *) + | Concrete of loc ]; + + 2/ + + type loc = { + file_name : string; + start : pos; + stop : pos + }; + + type t = option loc; + + 3/ + + type t = { + file_name : option string; + start : pos; + stop : pos + }; + +*) + +type pos = { + line : int; + bol : int; + off : int +}; + +type t = { + file_name : string; + start : pos; + stop : pos; + ghost : bool +}; + +(* Debug section *) +value dump_sel f x = + let s = + match x with + [ `start -> "`start" + | `stop -> "`stop" + | `both -> "`both" + | _ -> "<not-printable>" ] + in pp_print_string f s; +value dump_pos f x = + fprintf f "@[<hov 2>{ line = %d ;@ bol = %d ;@ off = %d } : pos@]" + x.line x.bol x.off; +value dump_long f x = + fprintf f + "@[<hov 2>{ file_name = %s ;@ start = %a (%d-%d);@ stop = %a (%d);@ ghost = %b@ } : Loc.t@]" + x.file_name dump_pos x.start (x.start.off - x.start.bol) + (x.stop.off - x.start.bol) dump_pos x.stop + (x.stop.off - x.stop.bol) x.ghost; +value dump f x = + fprintf f "[%S: %d:%d-%d %d:%d%t]" + x.file_name x.start.line (x.start.off - x.start.bol) + (x.stop.off - x.start.bol) x.stop.line (x.stop.off - x.stop.bol) + (fun o -> if x.ghost then fprintf o " (ghost)" else ()); + +value start_pos = { line = 1 ; bol = 0 ; off = 0 }; + +value ghost = + { file_name = "ghost-location"; + start = start_pos; + stop = start_pos; + ghost = True }; + +value mk file_name = + debug loc "mk %s@\n" file_name in + { file_name = file_name; + start = start_pos; + stop = start_pos; + ghost = False }; + +value of_tuple (file_name, start_line, start_bol, start_off, + stop_line, stop_bol, stop_off, ghost) = + { file_name = file_name; + start = { line = start_line ; bol = start_bol ; off = start_off }; + stop = { line = stop_line ; bol = stop_bol ; off = stop_off }; + ghost = ghost }; + +value to_tuple + { file_name = file_name; + start = { line = start_line ; bol = start_bol ; off = start_off }; + stop = { line = stop_line ; bol = stop_bol ; off = stop_off }; + ghost = ghost } = + (file_name, start_line, start_bol, start_off, + stop_line, stop_bol, stop_off, ghost); + +value pos_of_lexing_position p = + let pos = + { line = p.Lexing.pos_lnum ; + bol = p.Lexing.pos_bol ; + off = p.Lexing.pos_cnum } in + debug loc "pos_of_lexing_position: %a@\n" dump_pos pos in + pos; + +value pos_to_lexing_position p file_name = + (* debug loc "pos_to_lexing_position: %a@\n" dump_pos p in *) + { Lexing. + pos_fname = file_name; + pos_lnum = p.line ; + pos_bol = p.bol ; + pos_cnum = p.off }; + +value better_file_name a b = + match (a, b) with + [ ("", "") -> a + | ("", x) -> x + | (x, "") -> x + | ("-", x) -> x + | (x, "-") -> x + | (x, _) -> x ]; + +value of_lexbuf lb = + let start = Lexing.lexeme_start_p lb + and stop = Lexing.lexeme_end_p lb in + let loc = + { file_name = better_file_name start.Lexing.pos_fname stop.Lexing.pos_fname; + start = pos_of_lexing_position start; + stop = pos_of_lexing_position stop; + ghost = False } in + debug loc "of_lexbuf: %a@\n" dump loc in + loc; + +value of_lexing_position pos = + let loc = + { file_name = pos.Lexing.pos_fname; + start = pos_of_lexing_position pos; + stop = pos_of_lexing_position pos; + ghost = False } in + debug loc "of_lexing_position: %a@\n" dump loc in + loc; + +value to_ocaml_location x = + debug loc "to_ocaml_location: %a@\n" dump x in + { Camlp4_import.Location. + loc_start = pos_to_lexing_position x.start x.file_name; + loc_end = pos_to_lexing_position x.stop x.file_name; + loc_ghost = x.ghost }; + +value of_ocaml_location { Camlp4_import.Location.loc_start = a; loc_end = b; loc_ghost = g } = + let res = + { file_name = better_file_name a.Lexing.pos_fname b.Lexing.pos_fname; + start = pos_of_lexing_position a; + stop = pos_of_lexing_position b; + ghost = g } in + debug loc "of_ocaml_location: %a@\n" dump res in + res; + +value start_pos x = pos_to_lexing_position x.start x.file_name; +value stop_pos x = pos_to_lexing_position x.stop x.file_name; + +value merge a b = + if a == b then + debug loc "trivial merge@\n" in + a + else + let r = + match (a.ghost, b.ghost) with + [ (False, False) -> + (* FIXME if a.file_name <> b.file_name then + raise (Invalid_argument + (sprintf "Loc.merge: Filenames must be equal: %s <> %s" + a.file_name b.file_name)) *) + (* else *) + { (a) with stop = b.stop } + | (True, True) -> { (a) with stop = b.stop } + | (True, _) -> { (a) with stop = b.stop } + | (_, True) -> { (b) with start = a.start } ] + in debug loc "@[<hov 6>merge %a@ %a@ %a@]@\n" dump a dump b dump r in r; + +value join x = { (x) with stop = x.start }; + +value map f start_stop_both x = + match start_stop_both with + [ `start -> { (x) with start = f x.start } + | `stop -> { (x) with stop = f x.stop } + | `both -> { (x) with start = f x.start; stop = f x.stop } ]; + +value move_pos chars x = { (x) with off = x.off + chars }; + +value move s chars x = + debug loc "move %a %d %a@\n" dump_sel s chars dump x in + map (move_pos chars) s x; + +value move_line lines x = + debug loc "move_line %d %a@\n" lines dump x in + let move_line_pos x = + { (x) with line = x.line + lines ; bol = x.off } + in map move_line_pos `both x; + +value shift width x = + { (x) with start = x.stop ; stop = move_pos width x.stop }; + +value file_name x = x.file_name; +value start_line x = x.start.line; +value stop_line x = x.stop.line; +value start_bol x = x.start.bol; +value stop_bol x = x.stop.bol; +value start_off x = x.start.off; +value stop_off x = x.stop.off; +value is_ghost x = x.ghost; + +value set_file_name s x = + debug loc "set_file_name: %a@\n" dump x in + { (x) with file_name = s }; + +value ghostify x = + debug loc "ghostify: %a@\n" dump x in + { (x) with ghost = True }; + +value make_absolute x = + debug loc "make_absolute: %a@\n" dump x in + let pwd = Sys.getcwd () in + if Filename.is_relative x.file_name then + { (x) with file_name = Filename.concat pwd x.file_name } + else x; + +value strictly_before x y = + let b = x.stop.off < y.start.off && x.file_name = y.file_name in + debug loc "%a [strictly_before] %a => %b@\n" dump x dump y b in + b; + +value to_string x = do { + let (a, b) = (x.start, x.stop) in + let res = sprintf "File \"%s\", line %d, characters %d-%d" + x.file_name a.line (a.off - a.bol) (b.off - a.bol) in + if x.start.line <> x.stop.line then + sprintf "%s (end at line %d, character %d)" + res x.stop.line (b.off - b.bol) + else res +}; + +value print out x = pp_print_string out (to_string x); + +value check x msg = + if ((start_line x) > (stop_line x) || + (start_bol x) > (stop_bol x) || + (start_off x) > (stop_off x) || + (start_line x) < 0 || (stop_line x) < 0 || + (start_bol x) < 0 || (stop_bol x) < 0 || + (start_off x) < 0 || (stop_off x) < 0) + (* Here, we don't check + (start_off x) < (start_bol x) || (stop_off x) < (start_bol x) + since the lexer is called on antiquotations, with off=0, but line and bolpos + have "correct" values *) + then do { + eprintf "*** Warning: (%s) strange positions ***\n%a@\n" msg print x; + False + } + else True; + +exception Exc_located of t and exn; + +ErrorHandler.register + (fun ppf -> + fun [ Exc_located loc exn -> + fprintf ppf "%a:@\n%a" print loc ErrorHandler.print exn + | exn -> raise exn ]); + +value name = ref "_loc"; + +value raise loc exc = + match exc with + [ Exc_located _ _ -> raise exc + | _ -> raise (Exc_located loc exc) ] +; |