(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* 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 Camlp4 *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
(* PR#5090: don't do lookahead on get_prev_loc. *)
value get_prev_loc_only = ref False;
module Make (Structure : Structure.S) = struct
open Structure;
value empty_entry ename _ =
raise (Stream.Error ("entry [" ^ ename ^ "] is empty"));
value rec stream_map f = parser
[ [: ` x; strm :] -> [: ` (f x); stream_map f strm :]
| [: :] -> [: :] ];
value keep_prev_loc strm =
match Stream.peek strm with
[ None -> [: :]
| Some (tok0,init_loc) ->
let rec go prev_loc strm1 =
if get_prev_loc_only.val then
[: `(tok0, {prev_loc; cur_loc = prev_loc; prev_loc_only = True});
go prev_loc strm1 :]
else
match strm1 with parser
[ [: `(tok,cur_loc); strm :] ->
[: `(tok, {prev_loc; cur_loc; prev_loc_only = False});
go cur_loc strm :]
| [: :] -> [: :] ]
in go init_loc strm ];
value drop_prev_loc strm = stream_map (fun (tok,r) -> (tok,r.cur_loc)) strm;
value get_cur_loc strm =
match Stream.peek strm with
[ Some (_,r) -> r.cur_loc
| None -> Loc.ghost ];
value get_prev_loc strm =
begin
get_prev_loc_only.val := True;
let result = match Stream.peek strm with
[ Some (_, {prev_loc; prev_loc_only = True}) ->
begin Stream.junk strm; prev_loc end
| Some (_, {prev_loc; prev_loc_only = False}) -> prev_loc
| None -> Loc.ghost ];
get_prev_loc_only.val := False;
result
end;
value is_level_labelled n lev =
match lev.lname with
[ Some n1 -> n = n1
| None -> False ];
value warning_verbose = ref True;
value rec get_token_list entry tokl last_tok tree =
match tree with
[ Node {node = (Stoken _ | Skeyword _ as tok); son = son; brother = DeadEnd} ->
get_token_list entry [last_tok :: tokl] tok son
| _ ->
if tokl = [] then None
else Some (List.rev [last_tok :: tokl], last_tok, tree) ];
value is_antiquot s =
let len = String.length s in
len > 1 && s.[0] = '$';
value eq_Stoken_ids s1 s2 =
not (is_antiquot s1) && not (is_antiquot s2) && s1 = s2;
value logically_eq_symbols entry =
let rec eq_symbols s1 s2 =
match (s1, s2) with
[ (Snterm e1, Snterm e2) -> e1.ename = e2.ename
| (Snterm e1, Sself) -> e1.ename = entry.ename
| (Sself, Snterm e2) -> entry.ename = e2.ename
| (Snterml e1 l1, Snterml e2 l2) -> e1.ename = e2.ename && l1 = l2
| (Slist0 s1, Slist0 s2) |
(Slist1 s1, Slist1 s2) |
(Sopt s1, Sopt s2) |
(Stry s1, Stry s2) -> eq_symbols s1 s2
| (Slist0sep s1 sep1, Slist0sep s2 sep2) |
(Slist1sep s1 sep1, Slist1sep s2 sep2) ->
eq_symbols s1 s2 && eq_symbols sep1 sep2
| (Stree t1, Stree t2) -> eq_trees t1 t2
| (Stoken (_, s1), Stoken (_, s2)) -> eq_Stoken_ids s1 s2
| _ -> s1 = s2 ]
and eq_trees t1 t2 =
match (t1, t2) with
[ (Node n1, Node n2) ->
eq_symbols n1.node n2.node && eq_trees n1.son n2.son &&
eq_trees n1.brother n2.brother
| (LocAct _ _ | DeadEnd, LocAct _ _ | DeadEnd) -> True
| _ -> False ]
in
eq_symbols;
value rec eq_symbol s1 s2 =
match (s1, s2) with
[ (Snterm e1, Snterm e2) -> e1 == e2
| (Snterml e1 l1, Snterml e2 l2) -> e1 == e2 && l1 = l2
| (Slist0 s1, Slist0 s2) |
(Slist1 s1, Slist1 s2) |
(Sopt s1, Sopt s2) |
(Stry s1, Stry s2) -> eq_symbol s1 s2
| (Slist0sep s1 sep1, Slist0sep s2 sep2) |
(Slist1sep s1 sep1, Slist1sep s2 sep2) ->
eq_symbol s1 s2 && eq_symbol sep1 sep2
| (Stree _, Stree _) -> False
| (Stoken (_, s1), Stoken (_, s2)) -> eq_Stoken_ids s1 s2
| _ -> s1 = s2 ]
;
end;