Skip to content
Browse files

clean:fix

  • Loading branch information...
1 parent 6de1025 commit 6dcc827bf81a36db59e96511633456a1140ec271 @bobzhang committed
View
16 cold/FanGrammar.ml
@@ -11,10 +11,12 @@ type styp =
| STtok of loc
| STtyp of Ast.ctyp
+type attr = string
+
type entry = {
- name:name;
- pos:Ast.expr option;
- levels:level list}
+ name:name;
+ pos:Ast.expr option;
+ levels:level list}
and level = {label:string option; assoc:Ast.expr option; rules:rule list}
and rule = {prod:symbol list; action:Ast.expr option}
and symbol = {used:string list; text:text; styp:styp; pattern:Ast.patt option}
@@ -28,9 +30,9 @@ and text =
| TXrules of loc * (text list * Ast.expr) list
| TXself of loc
| TXkwd of loc * string
- | TXtok of loc * Ast.expr * string
+ | TXtok of loc * Ast.expr * attr * string
type used =
- Unused
- | UsedScanned
- | UsedNotScanned
+ Unused
+ | UsedScanned
+ | UsedNotScanned
View
26 cold/FanGrammarTools.ml
@@ -89,7 +89,7 @@ let string_of_patt =
let check_not_tok =
fun s ->
(match s with
- | {text = TXtok (_loc, _, _); _ } ->
+ | {text = TXtok (_loc, _, _, _); _ } ->
(FanLoc.raise _loc (
(Stream.Error
("Deprecated syntax, use a sub rule. " ^
@@ -436,7 +436,7 @@ let text_of_action =
( (Ast.ExId (_loc, ( (Ast.IdLid (_loc, s)) ))) ))) )))
), act)) ), i)
| {pattern = Some (p);
- text = TXtok (_, _, _); _ } ->
+ text = TXtok (_, _, _, _); _ } ->
let id = (prefix ^ ( (string_of_int i) )) in
((
(Some
@@ -805,7 +805,8 @@ let rec make_expr =
( (Ast.ExStr (_loc, kwd))
)))
| TXtok
- (_loc, match_fun, descr) ->
+ (_loc, match_fun, attr,
+ descr) ->
(Ast.ExApp
(_loc, (
(Ast.ExVrn
@@ -814,10 +815,19 @@ let rec make_expr =
(_loc, (
(Ast.ExCom
(_loc, match_fun, (
- (Ast.ExStr
+ (Ast.ExTup
(_loc, (
- (Ast.safe_string_escaped
- descr) ))) )))
+ (Ast.ExCom
+ (_loc, (
+ (Ast.ExVrn
+ (_loc,
+ attr)) ),
+ (
+ (Ast.ExStr
+ (_loc, (
+ (Ast.safe_string_escaped
+ descr) )))
+ ))) ))) )))
))) )))
and make_expr_rules =
fun _loc ->
@@ -1211,7 +1221,7 @@ let mk_tok =
let text =
(TXtok
(_loc, match_fun,
- descr)) in
+ "Normal", descr)) in
{used = [] ;
text = text;
styp = t;
@@ -1258,7 +1268,7 @@ let mk_tok =
let text =
(TXtok
(_loc, match_fun,
- descr)) in
+ "Antiquot", descr)) in
{used = [] ;
text = text;
styp = t;
View
32,977 cold/FanParsers.ml
32,977 additions, 0 deletions not shown because the diff is too large. Please use a local Git client to view these changes.
View
2 cold/FanTop.ml
@@ -149,7 +149,7 @@ let _ = (
let _ = let open
- Camlp4Parsers in
+ FanParsers in
(
(pa_r (module P))
);
View
3 cold/Gram.ml
@@ -171,7 +171,8 @@ let eoi_entry =
[((
[`Snterm ((obj ( (entry : 'entry t) )));
`Stoken
- ((( function | `EOI -> (true) | _ -> (false) ), "`EOI"))] ), (
+ ((( function | `EOI -> (true) | _ -> (false) ),
+ (`Normal, "`EOI")))] ), (
(mk_action (
fun __camlp4_0 ->
fun (x :
View
458 cold/Grammar/Failed.ml
@@ -2,189 +2,297 @@ open Structure
open Format
-let name_of_symbol =
- fun entry ->
- function
- | (`Snterm e) ->
- ("[" ^ ( (( e.ename ) ^ "]") ))
- | (`Snterml (e, l)) ->
- ("[" ^ (
- (( e.ename ) ^ (
- (" level " ^ ( (l ^ "]") )) )) ))
- | (`Sself | `Snext) ->
- ("[" ^ ( (( entry.ename ) ^ "]") ))
- | (`Stoken (_, descr)) -> descr
- | (`Skeyword kwd) -> ("\"" ^ ( (kwd ^ "\"") ))
- | _ -> "???"
+let name_of_descr =
+ function
+ | (`Antiquot, s) -> ("$" ^ s)
+ | (_, s) -> s
-let rec name_of_symbol_failed =
- fun entry ->
- function
- | ((((((`Slist0 s)
- | (`Slist0sep (s, _)))
- | (`Slist1 s))
- | (`Slist1sep (s, _)))
- | (`Sopt s)) | (`Stry s)) ->
- (name_of_symbol_failed
- entry s)
- | (`Stree t) ->
- (name_of_tree_failed entry
- t)
- | s ->
- (name_of_symbol entry s)
- and name_of_tree_failed =
+let name_of_symbol =
fun entry ->
function
- | Node ({node = s;
- brother = bro; son = son}) ->
- let tokl =
- (match s with
- | ((`Stoken _)
- | (`Skeyword _)) ->
- (Tools.get_token_list
- entry [] s son)
- | _ -> (None)) in
- (match tokl with
- | None ->
- let txt =
- (name_of_symbol_failed
- entry s) in
- let txt =
- (match (s, son) with
- | ((`Sopt _),
- Node (_)) ->
- (txt ^ (
- (" or " ^ (
- (name_of_tree_failed
- entry son)
- )) ))
- | _ -> txt) in
- let txt =
- (match bro with
- | (DeadEnd
- | LocAct (_, _)) ->
- txt
- | Node (_) ->
- (txt ^ (
- (" or " ^ (
- (name_of_tree_failed
- entry bro)
- )) ))) in
- txt
- | Some (tokl, _, _) ->
- (List.fold_left (
- fun s ->
- fun tok ->
- ((
- if (s = "") then
- ""
- else
- (s ^ " then ") )
- ^ (
- (match tok with
- | (`Stoken
- (_, descr)) ->
- descr
- | (`Skeyword
- kwd) ->
- kwd
- | _ ->
- assert false)
- )) ) "" tokl))
- | (DeadEnd | LocAct (_, _)) ->
- "???"
+ | (`Snterm e) ->
+ ("[" ^ (
+ (( e.ename ) ^ "]") ))
+ | (`Snterml (e, l)) ->
+ ("[" ^ (
+ (( e.ename ) ^ (
+ (" level " ^ (
+ (l ^ "]") )) )) ))
+ | (`Sself | `Snext) ->
+ ("[" ^ (
+ (( entry.ename ) ^ "]")
+ ))
+ | (`Stoken (_, descr)) ->
+ (name_of_descr descr)
+ | (`Skeyword kwd) ->
+ ("\"" ^ ( (kwd ^ "\"") ))
+ | _ -> "???"
-let magic =
- fun _s ->
- fun x ->
- (Obj.magic x)
+let rec name_of_symbol_failed =
+ fun entry ->
+ function
+ | ((((((`Slist0
+ s)
+ | (`Slist0sep
+ (s, _)))
+ |
+ (`Slist1
+ s))
+ |
+ (`Slist1sep
+ (s, _)))
+ |
+ (`Sopt s))
+ | (`Stry s)) ->
+ (name_of_symbol_failed
+ entry s)
+ | (`Stree t) ->
+ (name_of_tree_failed
+ entry t)
+ | s ->
+ (name_of_symbol
+ entry s)
+ and name_of_tree_failed =
+ fun entry ->
+ function
+ | Node
+ ({node = s;
+ brother =
+ bro;
+ son = son}) ->
+ let tokl =
+ (match
+ s with
+ | ((`Stoken
+ _)
+ | (`Skeyword
+ _)) ->
+ (Tools.get_token_list
+ entry []
+ s son)
+ |
+ _ ->
+ (None)) in
+ (match
+ tokl with
+ | None ->
+ let txt =
+ (name_of_symbol_failed
+ entry s) in
+ let txt =
+ (match
+ (s, son) with
+ | ((`Sopt
+ _),
+ Node (_)) ->
+ (txt ^ (
+ (" or " ^
+ (
+ (name_of_tree_failed
+ entry
+ son) ))
+ ))
+ |
+ _ ->
+ txt) in
+ let txt =
+ (match
+ bro with
+ | (DeadEnd
+ | LocAct
+ (_, _)) ->
+ txt
+ |
+ Node (_) ->
+ (txt ^ (
+ (" or " ^
+ (
+ (name_of_tree_failed
+ entry
+ bro) ))
+ ))) in
+ txt
+ |
+ Some
+ (tokl, _,
+ _) ->
+ (List.fold_left
+ (
+ fun s ->
+ fun tok ->
+ ((
+ if
+ (s = "") then
+ ""
+ else
+ (s ^
+ " then ")
+ ) ^ (
+ (match
+ tok with
+ | (`Stoken
+ (_, descr)) ->
+ (name_of_descr
+ descr)
+ | (`Skeyword
+ kwd) ->
+ kwd
+ |
+ _ ->
+ assert false)
+ )) ) ""
+ tokl))
+ | (DeadEnd
+ | LocAct
+ (_, _)) ->
+ "???"
+let magic = fun _s -> fun x -> (Obj.magic x)
+
let tree_failed =
+ fun entry ->
+ fun prev_symb_result ->
+ fun prev_symb ->
+ fun tree ->
+ let txt =
+ (name_of_tree_failed
+ entry tree) in
+ let txt =
+ (match prev_symb with
+ | (`Slist0 s) ->
+ let txt1 =
+ (name_of_symbol_failed
+ entry s) in
+ (txt1 ^ (
+ (" or " ^ (
+ (txt ^
+ " expected") ))
+ ))
+ | (`Slist1 s) ->
+ let txt1 =
+ (name_of_symbol_failed
+ entry s) in
+ (txt1 ^ (
+ (" or " ^ (
+ (txt ^
+ " expected") ))
+ ))
+ | (`Slist0sep (s, sep)) ->
+ (match
+ (magic
+ "tree_failed: 'a -> list 'b"
+ prev_symb_result) with
+ | [] ->
+ let txt1 =
+ (name_of_symbol_failed
+ entry s) in
+ (txt1 ^ (
+ (" or " ^ (
+ (txt ^
+ " expected")
+ )) ))
+ | _ ->
+ let txt1 =
+ (name_of_symbol_failed
+ entry sep) in
+ (txt1 ^ (
+ (" or " ^ (
+ (txt ^
+ " expected")
+ )) )))
+ | (`Slist1sep (s, sep)) ->
+ (match
+ (magic
+ "tree_failed: 'a -> list 'b"
+ prev_symb_result) with
+ | [] ->
+ let txt1 =
+ (name_of_symbol_failed
+ entry s) in
+ (txt1 ^ (
+ (" or " ^ (
+ (txt ^
+ " expected")
+ )) ))
+ | _ ->
+ let txt1 =
+ (name_of_symbol_failed
+ entry sep) in
+ (txt1 ^ (
+ (" or " ^ (
+ (txt ^
+ " expected")
+ )) )))
+ | (((`Stry _)
+ | (`Sopt _))
+ | (`Stree _)) ->
+ (txt ^ " expected")
+ | _ ->
+ (txt ^ (
+ (" expected after "
+ ^ (
+ (name_of_symbol
+ entry
+ prev_symb) ))
+ ))) in
+ (
+ if ((entry.egram).error_verbose).contents then
+ (
+ let tree =
+ (Search.tree_in_entry
+ prev_symb tree (
+ entry.edesc )) in
+ let ppf = err_formatter in
+ (
+ (fprintf ppf "@[<v 0>@,")
+ );
+ (
+ (fprintf ppf
+ "----------------------------------@,")
+ );
+ (
+ (fprintf ppf
+ "Parse error in entry [%s], rule:@;<0 2>"
+ ( entry.ename ))
+ );
+ (
+ (fprintf ppf "@[")
+ );
+ (
+ (Print.text#level ppf
+ pp_force_newline (
+ (Print.flatten_tree
+ tree) ))
+ );
+ (
+ (fprintf ppf "@]@,")
+ );
+ (
+ (fprintf ppf
+ "----------------------------------@,")
+ );
+ (fprintf ppf "@]@.")
+ )
+ else ()
+ );
+ (txt ^ (
+ (" (in [" ^ (
+ (( entry.ename ) ^
+ "])") )) ))
+
+
+let symb_failed =
fun entry ->
fun prev_symb_result ->
fun prev_symb ->
- fun tree ->
- let txt = (name_of_tree_failed entry tree) in
- let txt =
- (match prev_symb with
- | (`Slist0 s) ->
- let txt1 = (name_of_symbol_failed entry s) in
- (txt1 ^ ( (" or " ^ ( (txt ^ " expected") )) ))
- | (`Slist1 s) ->
- let txt1 = (name_of_symbol_failed entry s) in
- (txt1 ^ ( (" or " ^ ( (txt ^ " expected") )) ))
- | (`Slist0sep (s, sep)) ->
- (match (magic "tree_failed: 'a -> list 'b" prev_symb_result) with
- | [] ->
- let txt1 = (name_of_symbol_failed entry s) in
- (txt1 ^ ( (" or " ^ ( (txt ^ " expected") )) ))
- | _ ->
- let txt1 = (name_of_symbol_failed entry sep) in
- (txt1 ^ ( (" or " ^ ( (txt ^ " expected") )) )))
- | (`Slist1sep (s, sep)) ->
- (match (magic "tree_failed: 'a -> list 'b" prev_symb_result) with
- | [] ->
- let txt1 = (name_of_symbol_failed entry s) in
- (txt1 ^ ( (" or " ^ ( (txt ^ " expected") )) ))
- | _ ->
- let txt1 = (name_of_symbol_failed entry sep) in
- (txt1 ^ ( (" or " ^ ( (txt ^ " expected") )) )))
- | (((`Stry _) | (`Sopt _)) | (`Stree _)) -> (txt ^ " expected")
- | _ ->
- (txt ^ (
- (" expected after " ^ ( (name_of_symbol entry prev_symb) )) ))) in
- (
- if ((entry.egram).error_verbose).contents then
- (
- let tree = (Search.tree_in_entry prev_symb tree ( entry.edesc )) in
- let ppf = err_formatter in
- (
- (fprintf ppf "@[<v 0>@,")
- );
- (
- (fprintf ppf "----------------------------------@,")
- );
- (
- (fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" ( entry.ename ))
- );
- (
- (fprintf ppf "@[")
- );
- (
- (Print.text#level ppf pp_force_newline ( (Print.flatten_tree tree) ))
- );
- (
- (fprintf ppf "@]@,")
- );
- (
- (fprintf ppf "----------------------------------@,")
- );
- (fprintf ppf "@]@.")
- )
- else ()
- );
- (txt ^ ( (" (in [" ^ ( (( entry.ename ) ^ "])") )) ))
-
-let symb_failed =
- fun entry ->
- fun prev_symb_result ->
- fun prev_symb ->
- fun symb ->
- let tree =
- (Node
- (
- {node =
- symb;
- brother =
- DeadEnd ;
- son =
- DeadEnd })) in
- (tree_failed
- entry
- prev_symb_result
- prev_symb
- tree)
-
+ fun symb ->
+ let tree = (Node ({node = symb; brother = DeadEnd ; son = DeadEnd })) in
+ (tree_failed entry prev_symb_result prev_symb tree)
-let symb_failed_txt = fun e -> fun s1 -> fun s2 -> (symb_failed e 0 s1 s2)
+let symb_failed_txt =
+ fun e ->
+ fun s1 ->
+ fun s2 ->
+ (symb_failed e
+ 0 s1 s2)
View
12 cold/Grammar/Print.ml
@@ -50,6 +50,11 @@ class text_grammar =
| (`Stree _)) | (`Stoken _))
| (`Skeyword _)) as s) ->
(self#symbol1 ppf s)
+ method description =
+ fun ppf ->
+ function
+ | `Normal -> ()
+ | `Antiquot -> (fprintf ppf "$")
method symbol1 =
fun ppf ->
function
@@ -57,8 +62,11 @@ class text_grammar =
(pp_print_string ppf ( e.ename ))
| `Sself -> (pp_print_string ppf "SELF")
| `Snext -> (pp_print_string ppf "NEXT")
- | (`Stoken (_, descr)) ->
- (pp_print_string ppf descr)
+ | (`Stoken (_, (description, content))) ->
+ (
+ (self#description ppf description)
+ );
+ (pp_print_string ppf content)
| (`Skeyword s) -> (fprintf ppf "%S" s)
| (`Stree t) -> (self#tree ppf t)
| (((((((((`Smeta (_, _, _))
View
38 cold/Grammar/Structure.ml
@@ -50,19 +50,33 @@ type efun =
(token_stream ->
Action.t)
+type description =
+ [ `Normal |
+ `Antiquot ]
+
+
+type descr = (description * string)
+
type token_pattern =
- ((token ->
- bool) *
- string)
-
-
-type internal_entry = {
- egram:gram;
- ename:string;
- mutable estart:(int -> efun);
- mutable econtinue:(int ->
- (FanLoc.t -> (Action.t -> efun)));
- mutable edesc:desc}
+ ((token -> bool) * descr)
+
+type internal_entry =
+ {
+ egram:gram;
+ ename:
+ string;
+ mutable estart:
+ (int ->
+ efun);
+ mutable econtinue:
+ (int ->
+ (FanLoc.t
+ ->
+ (Action.t
+ ->
+ efun)));
+ mutable edesc:
+ desc}
and desc = Dlevels of level list | Dparser of (token_stream -> Action.t)
and level = {assoc:assoc; lname:string option; lsuffix:tree; lprefix:tree}
and symbol =
View
276 cold/Grammar/Tools.ml
@@ -98,172 +98,120 @@ let rec get_token_list =
else (Some (( (List.rev ( ( last_tok ) :: tokl )) ), last_tok, tree))
-let is_antiquot =
- fun s ->
- let len = (String.length s) in
- (( (len > 1) ) && ( (( (String.get s 0) ) = '$') ))
-
let eq_Stoken_ids =
- fun s1 ->
- fun s2 ->
- ((
- (not (
- (is_antiquot
- s1) )) ) && (
- ((
- (not (
- (is_antiquot
- s2) )) ) &&
- ( (s1 = s2) ))
- ))
+ fun s1 ->
+ fun s2 ->
+ (match (s1, s2) with
+ | ((`Antiquot, _), _) -> (false)
+ | (_, (`Antiquot, _)) -> (false)
+ | ((_, s1), (_, s2)) -> (s1 = s2))
let logically_eq_symbols =
- fun entry ->
- let rec eq_symbols =
- fun s1 ->
- fun 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 =
- fun t1 ->
- fun 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
-
+ fun entry ->
+ let rec eq_symbols =
+ fun s1 ->
+ fun 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 =
+ fun t1 ->
+ fun 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
let rec eq_symbol =
- fun s1 ->
- fun 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))
+ fun s1 ->
+ fun 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))
View
78 cold/MakeCamlp4Bin.ml
@@ -1,4 +1,4 @@
-open Camlp4Parsers
+open FanParsers
open Camlp4Filters
@@ -7,26 +7,26 @@ open Format
open LibUtil
module Camlp4Bin =
- functor (PreCast : Sig.PRECAST) ->
- struct
- let printers =
+ functor (PreCast : Sig.PRECAST) ->
+ struct
+ let printers =
((Hashtbl.create
30) :
(string,
(module Sig.PRECAST_PLUGIN
)) Hashtbl.t)
- let rcall_callback =
+ let rcall_callback =
(ref (
fun ()
->
() ))
- let loaded_modules =
+ let loaded_modules =
(ref
SSet.empty)
- let add_to_loaded_modules =
+ let add_to_loaded_modules =
fun name ->
(loaded_modules
:= (
@@ -35,8 +35,8 @@ module Camlp4Bin =
loaded_modules.contents
)) ))
- let _ =
- (Printexc.register_printer
+ let _ =
+ (Printexc.register_printer
(
function
| FanLoc.Exc_located
@@ -54,12 +54,12 @@ module Camlp4Bin =
_ ->
(None) ))
- module DynLoader =
+ module DynLoader =
(DynLoader.Make)
(struct
end)
- let
+ let
(objext,
libext) =
if DynLoader.is_native then
@@ -69,7 +69,7 @@ module Camlp4Bin =
(".cmo",
".cma")
- let rewrite_and_load =
+ let rewrite_and_load =
fun n ->
fun x ->
let dyn_loader =
@@ -332,12 +332,12 @@ module Camlp4Bin =
((rcall_callback.contents)
() )
- let print_warning =
+ let print_warning =
(eprintf
"%a:\n%s@."
FanLoc.print)
- let rec parse_file =
+ let rec parse_file =
fun dyn_loader ->
fun name ->
fun pa ->
@@ -448,11 +448,11 @@ module Camlp4Bin =
);
phr
- let output_file =
+ let output_file =
(ref None
)
- let process =
+ let process =
fun dyn_loader ->
fun name ->
fun pa ->
@@ -485,7 +485,7 @@ module Camlp4Bin =
output_file.contents
)) ))
- let gind =
+ let gind =
function
| Ast.SgDir
(loc, n,
@@ -499,7 +499,7 @@ module Camlp4Bin =
_ ->
(None)
- let gimd =
+ let gimd =
function
| Ast.StDir
(loc, n,
@@ -513,7 +513,7 @@ module Camlp4Bin =
_ ->
(None)
- let process_intf =
+ let process_intf =
fun dyn_loader ->
fun name ->
(process
@@ -530,7 +530,7 @@ module Camlp4Bin =
PreCast.Syntax.AstFilters.fold_interf_filters
gind)
- let process_impl =
+ let process_impl =
fun dyn_loader ->
fun name ->
(process
@@ -547,7 +547,7 @@ module Camlp4Bin =
PreCast.Syntax.AstFilters.fold_implem_filters
gimd)
- let just_print_the_version =
+ let just_print_the_version =
fun ()
->
(
@@ -557,7 +557,7 @@ module Camlp4Bin =
);
(exit 0)
- let print_version =
+ let print_version =
fun ()
->
(
@@ -567,7 +567,7 @@ module Camlp4Bin =
);
(exit 0)
- let print_stdlib =
+ let print_stdlib =
fun ()
->
(
@@ -577,7 +577,7 @@ module Camlp4Bin =
);
(exit 0)
- let usage =
+ let usage =
fun ini_sl ->
fun ext_sl ->
(
@@ -609,13 +609,13 @@ module Camlp4Bin =
else
()
- let warn_noassert =
+ let warn_noassert =
fun ()
->
(eprintf
"camlp4 warning: option -noassert is obsolete\nYou should give the -noassert option to the ocaml compiler instead.@.")
- type file_kind =
+ type file_kind =
Intf of
string
@@ -634,15 +634,15 @@ module Camlp4Bin =
of
string
- let search_stdlib =
+ let search_stdlib =
(ref true
)
- let print_loaded_modules =
+ let print_loaded_modules =
(ref
false )
- let
+ let
(task,
do_task) =
let t =
@@ -684,7 +684,7 @@ module Camlp4Bin =
(task,
do_task)
- let input_file =
+ let input_file =
fun x ->
let dyn_loader =
((DynLoader.instance.contents)
@@ -752,7 +752,7 @@ module Camlp4Bin =
((rcall_callback.contents)
() )
- let initial_spec_list =
+ let initial_spec_list =
[("-I", (
(Arg.String
(fun x ->
@@ -881,7 +881,7 @@ module Camlp4Bin =
(rewrite_and_load
"Parsers"))
),
- "<name> Load the parser Camlp4Parsers/<name>.cm(o|a|xs)");
+ "<name> Load the parser FanParsers/<name>.cm(o|a|xs)");
("-printer",
(
(Arg.String
@@ -908,11 +908,11 @@ module Camlp4Bin =
),
"Deprecated, does nothing")]
- let _ =
- (FanUtil.Options.init
+ let _ =
+ (FanUtil.Options.init
initial_spec_list)
- let anon_fun =
+ let anon_fun =
fun name ->
(input_file
(
@@ -958,7 +958,7 @@ module Camlp4Bin =
^ name))
)) ))
- let main =
+ let main =
fun argv ->
let usage =
fun ()
@@ -1087,8 +1087,8 @@ module Camlp4Bin =
);
(exit 2))
- let _ =
- (main
+ let _ =
+ (main
Sys.argv)
- end
+ end
View
2 cold/OCamlInitSyntax.ml
@@ -369,7 +369,7 @@ module Make =
[((
[`Stoken
((( function | `EOI -> (true) | _ -> (false) ),
- "`EOI"))] ), (
+ (`Normal, "`EOI")))] ), (
(Gram.mk_action (
fun __camlp4_0 ->
fun (_loc :
View
1 src/DynLoader.ml
@@ -36,7 +36,6 @@ module Make (U:sig end) : S= struct
if ocaml_stdlib then include_dir q FanConfig.ocaml_standard_library else ();
if camlp4_stdlib then do {
include_dir q FanConfig.camlp4_standard_library;
- (* include_dir q (Filename.concat FanConfig.camlp4_standard_library "Camlp4Parsers"); *)
include_dir q (Filename.concat FanConfig.camlp4_standard_library "Camlp4Printers");
include_dir q (Filename.concat FanConfig.camlp4_standard_library "Camlp4Filters");
} else ();
View
5 src/FanGrammar.ml
@@ -12,8 +12,11 @@ type styp =
+(* Normal, Antiquot, etc. translated to
+ `Normal `Antiquot
+ *)
+type attr = string;
-type attr = string (* Normal, Antiquot, etc.*);
type entry = {
name : name ;
pos : option Ast.expr;
View
12 src/FanGrammarTools.ml
@@ -33,7 +33,7 @@ let string_of_patt patt =
*)
let check_not_tok s = (* ('a, 'b) symbol -> unit *)
match s with
- [ {text = TXtok _loc _ _ ;_} ->
+ [ {text = TXtok _loc _ _ _ ;_} ->
FanLoc.raise _loc (Stream.Error
("Deprecated syntax, use a sub rule. "^
"LIST0 STRING becomes LIST0 [ x = STRING -> x ]"))
@@ -178,7 +178,7 @@ let text_of_action _loc (psl) (rtvar:string) (act:option Ast.expr) (tvar:string
(tok_match_pl,
<:expr< let $lid:s = $(id:gm()).string_of_token $lid:s
in $act >>, i) (* FIXME should be removed later *)
- | { pattern = Some p; text=TXtok _ _ _ ; _ } ->
+ | { pattern = Some p; text=TXtok _ _ _ _ ; _ } ->
let id = prefix ^ string_of_int i in
(Some (match (tok_match_pl) with
[ None -> (<:expr< $lid:id >>, p)
@@ -288,9 +288,9 @@ let rec make_expr entry tvar = fun
<:expr< `Sself>>
| TXkwd _loc kwd -> (* <:expr< $(id:gm()).Skeyword $str:kwd >> *)
<:expr< `Skeyword $str:kwd >>
- | TXtok _loc match_fun descr ->
+ | TXtok _loc match_fun attr descr ->
(* <:expr< $(id:gm()).Stoken ($match_fun, $`str:descr) >> *)
- <:expr< `Stoken ($match_fun, $`str:descr) >>
+ <:expr< `Stoken ($match_fun, (`$uid:attr, $`str:descr)) >>
]
and make_expr_rules _loc n rl tvar =
(* loc ->expr name ->
@@ -409,14 +409,14 @@ let mk_tok _loc ?restrict p t =
<:expr< fun [ $pat:p' -> True ] >>
else <:expr< fun [$pat:p' -> True | _ -> False ] >> in
let descr = string_of_patt p' in
- let text = TXtok _loc match_fun descr in
+ let text = TXtok _loc match_fun "Normal" descr in
{used = []; text = text; styp = t; pattern = Some p }
| Some restrict ->
let p'= Camlp4Ast.wildcarder#patt p in
let match_fun =
<:expr< fun [$pat:p when $restrict -> True | _ -> False ] >> in
let descr = string_of_patt p in
- let text = TXtok _loc match_fun descr in
+ let text = TXtok _loc match_fun "Antiquot" descr in
{used=[]; text; styp=t; pattern = Some p'} ] ;
let sfold _loc n foldfun f e s =
let styp = STquo _loc (new_type_var ()) in
View
2,574 src/FanParsers.ml
2,574 additions, 0 deletions not shown because the diff is too large. Please use a local Git client to view these changes.
View
2 src/FanTop.ml
@@ -73,7 +73,7 @@ let _ = begin
iter_and_take_callbacks (fun (_, f) -> f ());
end;
-let open Camlp4Parsers in begin
+let open FanParsers in begin
pa_r (module P);
pa_rp (module P);
(* pa_qb; *)
View
35 src/Grammar/Delete.ml
@@ -1,12 +1,3 @@
-(****************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* INRIA Rocquencourt *)
-
-(* module Make (Structure : Structure.S) = struct *)
- (* module Tools = Tools.Make Structure; *)
- (* module Parser = Parser.Make Structure; *)
open Structure;
(* Deleting a rule *)
@@ -126,26 +117,22 @@ let delete_rule_in_level_list entry symbols levs =
[ [`Sself :: symbols] -> delete_rule_in_suffix entry symbols levs
| [`Snterm e :: symbols] when e == entry ->
delete_rule_in_suffix entry symbols levs
- | _ -> delete_rule_in_prefix entry symbols levs ]
-;
+ | _ -> delete_rule_in_prefix entry symbols levs ];
+
-let delete_rule entry sl =
- match entry.edesc with
+let delete_rule entry sl = match entry.edesc with
[ Dlevels levs ->
- let levs = delete_rule_in_level_list entry sl levs in
- do {
+ let levs = delete_rule_in_level_list entry sl levs in begin
entry.edesc <- Dlevels levs;
- entry.estart <-
- fun lev strm ->
- let f = Parser.start_parser_of_entry entry in
- do { entry.estart <- f; f lev strm };
+ entry.estart <- fun lev strm ->
+ let f = Parser.start_parser_of_entry entry in begin
+ entry.estart <- f; f lev strm end;
entry.econtinue <-
fun lev bp a strm ->
let f = Parser.continue_parser_of_entry entry in
- do { entry.econtinue <- f; f lev bp a strm }
- }
- | Dparser _ -> () ]
-;
+ begin entry.econtinue <- f; f lev bp a strm end
+ end
+ | Dparser _ -> () ];
+
-(* end; *)
View
2 src/Grammar/Structure.ml
@@ -73,7 +73,7 @@ and symbol =
| `Stoken of token_pattern
| `Skeyword of string
| `Stree of tree ]
-and tree =
+and tree = (* internal struccture *)
[ Node of node
| LocAct of Action.t and list Action.t
| DeadEnd ]
View
27 src/Grammar/Tools.ml
@@ -1,13 +1,9 @@
open LibUtil;
-(* PR#5090: don't do lookahead on get_prev_loc. *)
-(* let get_prev_loc_only = ref False; *)
-
open Structure;
let empty_entry ename _ =
raise (Stream.Error ("entry [" ^ ename ^ "] is empty"));
-
let keep_prev_loc strm = match Stream.peek strm with
[ None -> [< >]
| Some (_tok0,init_loc) ->
@@ -44,21 +40,6 @@ let rec get_token_list entry tokl last_tok = fun
if tokl = [] then None
else Some (List.rev [last_tok :: tokl], last_tok, tree) ];
-(* BUG here we alternate the grammar
- {[
- | x = UIDENT; `ANTIQUOT "" s ->
- let e = AntiquotSyntax.parse_expr _loc s in
- let match_fun = <:expr< fun [ $uid:x$ camlp4_x when camlp4_x = $e$ -> True | _ -> False ] >> in
- let descr = "$" ^ x ^ " " ^ s in
- let text = TXtok _loc match_fun descr in
- let p = <:patt< $uid:x$ ($tup:<:patt< _ >>$) >> in
- {used = []; text = text; styp = STtok _loc; pattern = Some p }
-
- ]}
- *)
-let is_antiquot s =
- let len = String.length s in
- len > 1 && s.[0] = '$';
let eq_Stoken_ids s1 s2 = match (s1,s2) with
[ ((`Antiquot,_),_) -> False
@@ -86,11 +67,9 @@ and eq_trees t1 t2 = match (t1, t2) with
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;
+ | _ -> False ] in eq_symbols;
- let rec eq_symbol s1 s2 =
- match (s1, s2) with
+let 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) |
@@ -103,4 +82,4 @@ and eq_trees t1 t2 = match (t1, t2) with
| (`Stree _, `Stree _) -> False
| (`Stoken (_, s1), `Stoken (_, s2)) -> eq_Stoken_ids s1 s2
| _ -> s1 = s2 ];
-(* end; *)
+
View
4 src/MakeCamlp4Bin.ml
@@ -1,4 +1,4 @@
-open Camlp4Parsers;
+open FanParsers;
(* open FanParsers; *)
open Camlp4Filters;
open Format;
@@ -318,7 +318,7 @@ module Camlp4Bin
"Don't parse quotations, allowing to use, e.g. \"<:>\" as token.");
("-loaded-modules", Arg.Set print_loaded_modules, "Print the list of loaded modules.");
("-parser", Arg.String (rewrite_and_load "Parsers"),
- "<name> Load the parser Camlp4Parsers/<name>.cm(o|a|xs)");
+ "<name> Load the parser FanParsers/<name>.cm(o|a|xs)");
("-printer", Arg.String (rewrite_and_load "Printers"),
"<name> Load the printer Camlp4Printers/<name>.cm(o|a|xs)");
("-filter", Arg.String (rewrite_and_load "Filters"),

0 comments on commit 6dcc827

Please sign in to comment.
Something went wrong with that request. Please try again.