From 99159966cae021c54a76c825c8a2ad9d96844e54 Mon Sep 17 00:00:00 2001 From: Daniel de Rauglaudre Date: Fri, 18 Jan 2002 04:32:41 +0000 Subject: [PATCH] - git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@4260 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- camlp4/etc/pr_extend.ml | 10 +- camlp4/meta/pa_extend.ml | 193 +++++++++++++++++++--- camlp4/meta/q_MLast.ml | 37 +++-- camlp4/ocaml_src/meta/pa_extend.ml | 249 +++++++++++++++++++++++++---- 4 files changed, 418 insertions(+), 71 deletions(-) diff --git a/camlp4/etc/pr_extend.ml b/camlp4/etc/pr_extend.ml index 6713eb91b..c18c40b14 100644 --- a/camlp4/etc/pr_extend.ml +++ b/camlp4/etc/pr_extend.ml @@ -5,7 +5,7 @@ (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) @@ -15,6 +15,8 @@ open Pcaml; open Spretty; +value no_slist = ref False; + value expr e dg k = pr_expr.pr_fun "top" e dg k; value patt e dg k = pr_patt.pr_fun "top" e dg k; @@ -296,12 +298,12 @@ value rec symbol s k = | Sself -> HVbox [: `S LR "SELF"; k :] | Snext -> HVbox [: `S LR "NEXT"; k :] | Stoken tok -> token tok k -(**) | Srules [([(Some <:patt< a >>, Snterm <:expr< anti_list >>)], Some <:expr< a >>); ([(Some <:patt< l >>, ((Slist0 _ | Slist1 _ | Slist0sep _ _ | Slist1sep _ _) as s))], Some <:expr< list l >>)] + when not no_slist.val -> match s with [ Slist0 s -> HVbox [: `S LR "SLIST0"; `simple_symbol s k :] @@ -315,7 +317,6 @@ value rec symbol s k = [: `S LR "SLIST1"; `simple_symbol s [: :]; `S LR "SEP"; `simple_symbol sep k :] | _ -> assert False ] -(**) | Srules rl -> let rl = simplify_rules rl in HVbox [: `HVbox [: :]; rule_list rl k :] ] @@ -435,3 +436,6 @@ lev.pr_rules := extfun lev.pr_rules with [ <:expr< Grammar.extend $_$ >> as e -> fun curr next _ k -> [: `extend e "" k :] ]; + +Pcaml.add_option "-no_slist" (Arg.Set no_slist) + " Don't reconstruct SLIST"; diff --git a/camlp4/meta/pa_extend.ml b/camlp4/meta/pa_extend.ml index 9c357d1f2..a4d0627b0 100644 --- a/camlp4/meta/pa_extend.ml +++ b/camlp4/meta/pa_extend.ml @@ -137,6 +137,7 @@ value text_of_psymbol_list loc gmod psl tvar = psl <:expr< [] >> ; +value quotify = ref False; value meta_action = ref False; module MetaAction = @@ -232,11 +233,104 @@ module MetaAction = end ; +value rec expr_fa al = + fun + [ <:expr< $f$ $a$ >> -> expr_fa [a :: al] f + | f -> (f, al) ] +; + +value mklistexp loc = + loop True where rec loop top = + fun + [ [] -> <:expr< [] >> + | [e1 :: el] -> + let loc = + if top then loc else (fst (MLast.loc_of_expr e1), snd loc) + in + <:expr< [$e1$ :: $loop False el$] >> ] +; + +value mklistpat loc = + loop True where rec loop top = + fun + [ [] -> <:patt< [] >> + | [p1 :: pl] -> + let loc = + if top then loc else (fst (MLast.loc_of_patt p1), snd loc) + in + <:patt< [$p1$ :: $loop False pl$] >> ] +; + +value rec quot_act e = + let loc = MLast.loc_of_expr e in + match e with + [ <:expr< None >> -> <:expr< Option None >> + | <:expr< Some $e$ >> -> <:expr< Option (Some $quot_act e$) >> + | <:expr< False >> -> <:expr< Bool False >> + | <:expr< True >> -> <:expr< Bool True >> + | <:expr< [] >> -> <:expr< List [] >> + | <:expr< [$e$] >> -> <:expr< List [$quot_act e$] >> + | <:expr< [$e1$ :: $e2$] >> -> <:expr< Cons $quot_act e1$ $quot_act e2$ >> + | <:expr< $_$ $_$ >> -> + let (f, al) = expr_fa [] e in + let al = List.map quot_act al in + match f with + [ <:expr< $uid:c$ >> -> <:expr< Node $str:c$ $mklistexp loc al$ >> + | <:expr< $_$.$uid:c$ >> -> <:expr< Node $str:c$ $mklistexp loc al$ >> + | _ -> e ] + | <:expr< $lid:s$ >> -> if s = Stdpp.loc_name.val then <:expr< Loc >> else e + | <:expr< $str:s$ >> -> <:expr< Str $str:s$ >> + | <:expr< ($list:el$) >> -> + let el = List.map quot_act el in + <:expr< Tuple $mklistexp loc el$ >> + | _ -> e ] +; + +value symgen = "xx"; + +value pname_of_ptuple pl = + List.fold_left + (fun pname p -> + match p with + [ <:patt< $lid:s$ >> -> pname ^ s + | _ -> pname ]) + "" pl +; + +value quotify_action psl act = + let e = quot_act act in + List.fold_left + (fun e ps -> + match ps.pattern with + [ Some <:patt< ($list:pl$) >> -> + let loc = (0, 0) in + let pname = pname_of_ptuple pl in + let (pl1, el1) = + let (l, _) = + List.fold_left + (fun (l, cnt) _ -> + ([symgen ^ string_of_int cnt :: l], cnt + 1)) + ([], 1) pl + in + let l = List.rev l in + (List.map (fun s -> <:patt< $lid:s$ >>) l, + List.map (fun s -> <:expr< $lid:s$ >>) l) + in + <:expr< + let ($list:pl$) = + match $lid:pname$ with + [ Tuple $mklistpat loc pl1$ -> ($list:el1$) + | _ -> match () with [] ] + in $e$ >> + | _ -> e ]) + e psl +; + value text_of_action loc psl rtvar act tvar = let locid = <:patt< $lid:Stdpp.loc_name.val$ >> in let act = match act with - [ Some act -> act + [ Some act -> if quotify.val then quotify_action psl act else act | None -> <:expr< () >> ] in let e = <:expr< fun [ ($locid$ : (int * int)) -> ($act$ : '$rtvar$) ] >> in @@ -247,7 +341,13 @@ value text_of_action loc psl rtvar act tvar = [ None -> <:expr< fun _ -> $txt$ >> | Some p -> let t = ps.symbol.styp tvar in - <:expr< fun [ ($p$ : $t$) -> $txt$ ] >> ]) + let p = + match p with + [ <:patt< ($list:pl$) >> when quotify.val -> + <:patt< $lid:pname_of_ptuple pl$ >> + | _ -> p ] + in + <:expr< fun ($p$ : $t$) -> $txt$ >> ]) e psl in let txt = @@ -416,6 +516,7 @@ value mk_name loc e = {expr = e; tvar = ident_of_expr e; loc = loc}; value sself loc gmod n = <:expr< Gramext.Sself >>; value snext loc gmod n = <:expr< Gramext.Snext >>; +value stoken loc s e gmod n = <:expr< Gramext.Stoken ($str:s$, $e$) >>; value snterm loc n lev gmod tvar = match lev with [ Some lab -> @@ -449,7 +550,43 @@ value srules loc t rl gmod tvar = <:expr< Gramext.srules $e$ >> ; -value sslist loc min sep s gmod n = +value sstoken loc s = + let n = mk_name loc <:expr< $lid:"anti_" ^ s$ >> in + snterm loc n None +; + +value ssopt loc symb = + let psymbol p s t = + let symb = {used = []; text = s; styp = fun _ -> t} in + {pattern = Some p; symbol = symb} + in + let rl = + let r1 = + let prod = + let n = mk_name loc <:expr< anti_opt >> in + [psymbol <:patt< a >> (snterm loc n None) <:ctyp< 'anti_opt >>] + in + let act = <:expr< a >> in + {prod = prod; action = Some act} + in + let r2 = + let psymb = + let symb = + {used = []; text = sopt loc symb; + styp = fun n -> <:ctyp< option $symb.styp n$ >>} + in + let patt = <:patt< o >> in + {pattern = Some patt; symbol = symb} + in + let act = <:expr< option o >> in + {prod = [psymb]; action = Some act} + in + [r1; r2] + in + srules loc "pouet" rl +; + +value sslist_aux loc min sep s = let psymbol p s t = let symb = {used = []; text = s; styp = fun _ -> t} in {pattern = Some p; symbol = symb} @@ -458,10 +595,10 @@ value sslist loc min sep s gmod n = let r1 = let prod = let n = mk_name loc <:expr< anti_list >> in - [psymbol <:patt< a >> (snterm loc n None) - <:ctyp< 'anti_list >>] + [psymbol <:patt< a >> (snterm loc n None) <:ctyp< 'anti_list >>] in - let act = <:expr< a >> in {prod = prod; action = Some act} + let act = <:expr< a >> in + {prod = prod; action = Some act} in let r2 = let psymb = @@ -477,7 +614,13 @@ value sslist loc min sep s gmod n = in [r1; r2] in - srules loc "anti" rl gmod n + srules loc "anti" rl +; + +value sslist loc min sep s = + match s.text "" "" with + [ <:expr< Gramext.$uid:"Sself" | "Snext"$ >> -> slist loc min sep s + | _ -> sslist_aux loc min sep s ] ; open Pcaml; @@ -572,7 +715,10 @@ EXTEND | None -> s.used ] in let styp n = let t = s.styp n in <:ctyp< list $t$ >> in - let text = slist loc False sep s in + let text = + if quotify.val then sslist loc False sep s + else slist loc False sep s + in {used = used; text = text; styp = styp} | UIDENT "LIST1"; s = SELF; sep = OPT [ UIDENT "SEP"; t = symbol -> t ] -> @@ -582,11 +728,18 @@ EXTEND | None -> s.used ] in let styp n = let t = s.styp n in <:ctyp< list $t$ >> in - let text = slist loc True sep s in + let text = + if quotify.val then sslist loc True sep s + else slist loc True sep s + in {used = used; text = text; styp = styp} | UIDENT "OPT"; s = SELF -> let styp n = let t = s.styp n in <:ctyp< option $t$ >> in - {used = s.used; text = sopt loc s; styp = styp} ] + let text = + if quotify.val then ssopt loc s + else sopt loc s + in + {used = s.used; text = text; styp = styp} ] | [ UIDENT "SELF" -> let styp n = if n = "" then @@ -609,16 +762,17 @@ EXTEND {used = used_of_rule_list rl; text = srules loc t rl; styp = fun _ -> <:ctyp< '$t$ >>} | x = UIDENT -> - {used = []; - text = fun _ _ -> <:expr< Gramext.Stoken ($str:x$, "") >>; - styp = fun _ -> <:ctyp< string >>} + let text = + if quotify.val then sstoken loc x + else stoken loc x <:expr< "" >> + in + {used = []; text = text; styp = fun _ -> <:ctyp< string >>} | x = UIDENT; e = string -> - {used = []; - text = fun _ _ -> <:expr< Gramext.Stoken ($str:x$, $e$) >>; - styp = fun _ -> <:ctyp< string >>} + let text = stoken loc x e in + {used = []; text = text; styp = fun _ -> <:ctyp< string >>} | e = string -> - {used = []; text = fun _ _ -> <:expr< Gramext.Stoken ("", $e$) >>; - styp = fun _ -> <:ctyp< string >>} + let text = stoken loc "" e in + {used = []; text = text; styp = fun _ -> <:ctyp< string >>} | i = UIDENT; "."; e = qualid; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] -> let n = mk_name loc <:expr< $uid:i$ . $e$ >> in @@ -661,5 +815,8 @@ EXTEND ; END; +Pcaml.add_option "-quotify" (Arg.Set quotify) + " Generate code for quotations"; + Pcaml.add_option "-meta_action" (Arg.Set meta_action) " Undocumented"; diff --git a/camlp4/meta/q_MLast.ml b/camlp4/meta/q_MLast.ml index 4d07c3265..66535716a 100644 --- a/camlp4/meta/q_MLast.ml +++ b/camlp4/meta/q_MLast.ml @@ -107,7 +107,7 @@ EXTEND GLOBAL: sig_item str_item ctyp patt expr directive module_type module_expr class_type class_expr class_sig_item class_str_item; module_expr: - [ [ "functor"; "("; i = uident; ":"; t = module_type; ")"; "->"; + [ [ "functor"; "("; i = anti_UIDENT; ":"; t = module_type; ")"; "->"; me = SELF -> Node "MeFun" [i; t; me] | "struct"; st = SLIST0 [ s = str_item; ";" -> s ]; "end" -> @@ -125,14 +125,17 @@ EXTEND Node "StDcl" [st] | "#"; n = lident; dp = dir_param -> Node "StDir" [n; dp] | "exception"; ctl = constructor_declaration; b = rebind_exn -> - match ctl with - [ Tuple [Loc; c; tl] -> Node "StExc" [c; tl; b] - | _ -> match () with [] ] + let (_, c, tl) = + match ctl with + [ Tuple [x1; x2; x3] -> (x1, x2, x3) + | _ -> match () with [] ] + in + Node "StExc" [c; tl; b] | "external"; i = lident; ":"; t = ctyp; "="; p = SLIST1 string -> Node "StExt" [i; t; p] | "include"; me = module_expr -> Node "StInc" [me] - | "module"; i = uident; mb = module_binding -> Node "StMod" [i; mb] - | "module"; "type"; i = uident; "="; mt = module_type -> + | "module"; i = anti_UIDENT; mb = module_binding -> Node "StMod" [i; mb] + | "module"; "type"; i = anti_UIDENT; "="; mt = module_type -> Node "StMty" [i; mt] | "open"; m = mod_ident -> Node "StOpn" [m] | "type"; l = SLIST1 type_declaration SEP "and" -> Node "StTyp" [l] @@ -148,13 +151,13 @@ EXTEND ; module_binding: [ RIGHTA - [ "("; m = uident; ":"; mt = module_type; ")"; mb = SELF -> + [ "("; m = anti_UIDENT; ":"; mt = module_type; ")"; mb = SELF -> Node "MeFun" [m; mt; mb] | ":"; mt = module_type; "="; me = module_expr -> Node "MeTyc" [me; mt] | "="; me = module_expr -> me ] ] ; module_type: - [ [ "functor"; "("; i = uident; ":"; t = SELF; ")"; "->"; mt = SELF -> + [ [ "functor"; "("; i = anti_UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF -> Node "MtFun" [i; t; mt] ] | [ mt = SELF; "with"; wcl = SLIST1 with_constr SEP "and" -> Node "MtWit" [mt; wcl] ] @@ -180,8 +183,9 @@ EXTEND | "external"; i = lident; ":"; t = ctyp; "="; p = SLIST1 string -> Node "SgExt" [i; t; p] | "include"; mt = module_type -> Node "SgInc" [mt] - | "module"; i = uident; mt = module_declaration -> Node "SgMod" [i; mt] - | "module"; "type"; i = uident; "="; mt = module_type -> + | "module"; i = anti_UIDENT; mt = module_declaration -> + Node "SgMod" [i; mt] + | "module"; "type"; i = anti_UIDENT; "="; mt = module_type -> Node "SgMty" [i; mt] | "open"; m = mod_ident -> Node "SgOpn" [m] | "type"; l = SLIST1 type_declaration SEP "and" -> Node "SgTyp" [l] @@ -191,7 +195,7 @@ EXTEND module_declaration: [ RIGHTA [ ":"; mt = module_type -> mt - | "("; i = uident; ":"; t = module_type; ")"; mt = SELF -> + | "("; i = anti_UIDENT; ":"; t = module_type; ")"; mt = SELF -> Node "MtFun" [i; t; mt] ] ] ; with_constr: @@ -210,7 +214,8 @@ EXTEND [ "let"; r = rec_flag; l = SLIST1 let_binding SEP "and"; "in"; x = SELF -> Node "ExLet" [r; l; x] - | "let"; "module"; m = uident; mb = module_binding; "in"; x = SELF -> + | "let"; "module"; m = anti_UIDENT; mb = module_binding; "in"; + x = SELF -> Node "ExLmd" [m; mb; x] | "fun"; "["; l = SLIST0 match_case SEP "|"; "]" -> Node "ExFun" [l] | "fun"; p = ipatt; e = fun_def -> @@ -532,9 +537,9 @@ EXTEND | -> List [] ] ] ; constructor_declaration: - [ [ ci = uident; "of"; cal = SLIST1 ctyp SEP "and" -> + [ [ ci = anti_UIDENT; "of"; cal = SLIST1 ctyp SEP "and" -> Tuple [Loc; ci; cal] - | ci = uident -> Tuple [Loc; ci; List []] ] ] + | ci = anti_UIDENT -> Tuple [Loc; ci; List []] ] ] ; label_declaration: [ [ i = lident; ":"; mf = mutable_flag; t = ctyp -> @@ -549,7 +554,7 @@ EXTEND [ [ i = LIDENT -> Str i | a = anti_ -> a ] ] ; - uident: + anti_UIDENT: [ [ i = UIDENT -> Str i | a = anti_ -> a ] ] ; @@ -825,7 +830,7 @@ EXTEND (* Identifiers *) longid: - [ [ m = uident; "."; l = SELF -> [m :: l] + [ [ m = anti_UIDENT; "."; l = SELF -> [m :: l] | i = lident -> [i] ] ] ; clty_longident: diff --git a/camlp4/ocaml_src/meta/pa_extend.ml b/camlp4/ocaml_src/meta/pa_extend.ml index c01404eff..7dcaaeaae 100644 --- a/camlp4/ocaml_src/meta/pa_extend.ml +++ b/camlp4/ocaml_src/meta/pa_extend.ml @@ -134,6 +134,7 @@ let text_of_psymbol_list loc gmod psl tvar = psl (MLast.ExUid (loc, "[]")) ;; +let quotify = ref false;; let meta_action = ref false;; module MetaAction = @@ -571,11 +572,141 @@ module MetaAction = end ;; +let rec expr_fa al = + function + MLast.ExApp (_, f, a) -> expr_fa (a :: al) f + | f -> f, al +;; + +let mklistexp loc = + let rec loop top = + function + [] -> MLast.ExUid (loc, "[]") + | e1 :: el -> + let loc = if top then loc else fst (MLast.loc_of_expr e1), snd loc in + MLast.ExApp + (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e1), loop false el) + in + loop true +;; + +let mklistpat loc = + let rec loop top = + function + [] -> MLast.PaUid (loc, "[]") + | p1 :: pl -> + let loc = if top then loc else fst (MLast.loc_of_patt p1), snd loc in + MLast.PaApp + (loc, MLast.PaApp (loc, MLast.PaUid (loc, "::"), p1), loop false pl) + in + loop true +;; + +let rec quot_act e = + let loc = MLast.loc_of_expr e in + match e with + MLast.ExUid (_, "None") -> + MLast.ExApp + (loc, MLast.ExUid (loc, "Option"), MLast.ExUid (loc, "None")) + | MLast.ExApp (_, MLast.ExUid (_, "Some"), e) -> + MLast.ExApp + (loc, MLast.ExUid (loc, "Option"), + MLast.ExApp (loc, MLast.ExUid (loc, "Some"), quot_act e)) + | MLast.ExUid (_, "False") -> + MLast.ExApp (loc, MLast.ExUid (loc, "Bool"), MLast.ExUid (loc, "False")) + | MLast.ExUid (_, "True") -> + MLast.ExApp (loc, MLast.ExUid (loc, "Bool"), MLast.ExUid (loc, "True")) + | MLast.ExUid (_, "[]") -> + MLast.ExApp (loc, MLast.ExUid (loc, "List"), MLast.ExUid (loc, "[]")) + | MLast.ExApp + (_, MLast.ExApp (_, MLast.ExUid (_, "::"), e), MLast.ExUid (_, "[]")) -> + MLast.ExApp + (loc, MLast.ExUid (loc, "List"), + MLast.ExApp + (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), quot_act e), + MLast.ExUid (loc, "[]"))) + | MLast.ExApp (_, MLast.ExApp (_, MLast.ExUid (_, "::"), e1), e2) -> + MLast.ExApp + (loc, MLast.ExApp (loc, MLast.ExUid (loc, "Cons"), quot_act e1), + quot_act e2) + | MLast.ExApp (_, _, _) -> + let (f, al) = expr_fa [] e in + let al = List.map quot_act al in + begin match f with + MLast.ExUid (_, c) -> + MLast.ExApp + (loc, + MLast.ExApp + (loc, MLast.ExUid (loc, "Node"), MLast.ExStr (loc, c)), + mklistexp loc al) + | MLast.ExAcc (_, _, MLast.ExUid (_, c)) -> + MLast.ExApp + (loc, + MLast.ExApp + (loc, MLast.ExUid (loc, "Node"), MLast.ExStr (loc, c)), + mklistexp loc al) + | _ -> e + end + | MLast.ExLid (_, s) -> + if s = !(Stdpp.loc_name) then MLast.ExUid (loc, "Loc") else e + | MLast.ExStr (_, s) -> + MLast.ExApp (loc, MLast.ExUid (loc, "Str"), MLast.ExStr (loc, s)) + | MLast.ExTup (_, el) -> + let el = List.map quot_act el in + MLast.ExApp (loc, MLast.ExUid (loc, "Tuple"), mklistexp loc el) + | _ -> e +;; + +let symgen = "xx";; + +let pname_of_ptuple pl = + List.fold_left + (fun pname p -> + match p with + MLast.PaLid (_, s) -> pname ^ s + | _ -> pname) + "" pl +;; + +let quotify_action psl act = + let e = quot_act act in + List.fold_left + (fun e ps -> + match ps.pattern with + Some (MLast.PaTup (_, pl)) -> + let loc = 0, 0 in + let pname = pname_of_ptuple pl in + let (pl1, el1) = + let (l, _) = + List.fold_left + (fun (l, cnt) _ -> + (symgen ^ string_of_int cnt) :: l, cnt + 1) + ([], 1) pl + in + let l = List.rev l in + List.map (fun s -> MLast.PaLid (loc, s)) l, + List.map (fun s -> MLast.ExLid (loc, s)) l + in + MLast.ExLet + (loc, false, + [MLast.PaTup (loc, pl), + MLast.ExMat + (loc, MLast.ExLid (loc, pname), + [MLast.PaApp + (loc, MLast.PaUid (loc, "Tuple"), mklistpat loc pl1), + None, MLast.ExTup (loc, el1); + MLast.PaAny loc, None, + MLast.ExMat (loc, MLast.ExUid (loc, "()"), [])])], + e) + | _ -> e) + e psl +;; + let text_of_action loc psl rtvar act tvar = let locid = MLast.PaLid (loc, !(Stdpp.loc_name)) in let act = match act with - Some act -> act + Some act -> if !quotify then quotify_action psl act else act | None -> MLast.ExUid (loc, "()") in let e = @@ -594,6 +725,12 @@ let text_of_action loc psl rtvar act tvar = None -> MLast.ExFun (loc, [MLast.PaAny loc, None, txt]) | Some p -> let t = ps.symbol.styp tvar in + let p = + match p with + MLast.PaTup (_, pl) when !quotify -> + MLast.PaLid (loc, pname_of_ptuple pl) + | _ -> p + in MLast.ExFun (loc, [MLast.PaTyc (loc, p, t), None, txt])) e psl in @@ -899,6 +1036,13 @@ let sself loc gmod n = let snext loc gmod n = MLast.ExAcc (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Snext")) ;; +let stoken loc s e gmod n = + MLast.ExApp + (loc, + MLast.ExAcc + (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Stoken")), + MLast.ExTup (loc, [MLast.ExStr (loc, s); e])) +;; let snterm loc n lev gmod tvar = match lev with Some lab -> @@ -1010,7 +1154,46 @@ let srules loc t rl gmod tvar = e) ;; -let sslist loc min sep s gmod n = +let sstoken loc s = + let n = mk_name loc (MLast.ExLid (loc, ("anti_" ^ s))) in snterm loc n None +;; + +let ssopt loc symb = + let psymbol p s t = + let symb = {used = []; text = s; styp = fun _ -> t} in + {pattern = Some p; symbol = symb} + in + let rl = + let r1 = + let prod = + let n = mk_name loc (MLast.ExLid (loc, "anti_opt")) in + [psymbol (MLast.PaLid (loc, "a")) (snterm loc n None) + (MLast.TyQuo (loc, "anti_opt"))] + in + let act = MLast.ExLid (loc, "a") in {prod = prod; action = Some act} + in + let r2 = + let psymb = + let symb = + {used = []; text = sopt loc symb; + styp = + fun n -> + MLast.TyApp (loc, MLast.TyLid (loc, "option"), symb.styp n)} + in + let patt = MLast.PaLid (loc, "o") in + {pattern = Some patt; symbol = symb} + in + let act = + MLast.ExApp (loc, MLast.ExLid (loc, "option"), MLast.ExLid (loc, "o")) + in + {prod = [psymb]; action = Some act} + in + [r1; r2] + in + srules loc "pouet" rl +;; + +let sslist_aux loc min sep s = let psymbol p s t = let symb = {used = []; text = s; styp = fun _ -> t} in {pattern = Some p; symbol = symb} @@ -1041,7 +1224,15 @@ let sslist loc min sep s gmod n = in [r1; r2] in - srules loc "anti" rl gmod n + srules loc "anti" rl +;; + +let sslist loc min sep s = + match s.text "" "" with + MLast.ExAcc + (_, MLast.ExUid (_, "Gramext"), MLast.ExUid (_, ("Sself" | "Snext"))) -> + slist loc min sep s + | _ -> sslist_aux loc min sep s ;; open Pcaml;; @@ -1391,7 +1582,8 @@ Grammar.extend let t = s.styp n in MLast.TyApp (loc, MLast.TyLid (loc, "option"), t) in - {used = s.used; text = sopt loc s; styp = styp} : + let text = if !quotify then ssopt loc s else sopt loc s in + {used = s.used; text = text; styp = styp} : 'symbol)); [Gramext.Stoken ("UIDENT", "LIST1"); Gramext.Sself; Gramext.Sopt @@ -1412,7 +1604,9 @@ Grammar.extend let t = s.styp n in MLast.TyApp (loc, MLast.TyLid (loc, "list"), t) in - let text = slist loc true sep s in + let text = + if !quotify then sslist loc true sep s else slist loc true sep s + in {used = used; text = text; styp = styp} : 'symbol)); [Gramext.Stoken ("UIDENT", "LIST0"); Gramext.Sself; @@ -1434,7 +1628,10 @@ Grammar.extend let t = s.styp n in MLast.TyApp (loc, MLast.TyLid (loc, "list"), t) in - let text = slist loc false sep s in + let text = + if !quotify then sslist loc false sep s + else slist loc false sep s + in {used = used; text = text; styp = styp} : 'symbol))]; None, None, @@ -1473,45 +1670,26 @@ Grammar.extend [Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], Gramext.action (fun (e : 'string) (loc : int * int) -> - ({used = []; - text = - (fun _ _ -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Stoken")), - MLast.ExTup (loc, [MLast.ExStr (loc, ""); e]))); + (let text = stoken loc "" e in + {used = []; text = text; styp = fun _ -> MLast.TyLid (loc, "string")} : 'symbol)); [Gramext.Stoken ("UIDENT", ""); Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], Gramext.action (fun (e : 'string) (x : string) (loc : int * int) -> - ({used = []; - text = - (fun _ _ -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Stoken")), - MLast.ExTup (loc, [MLast.ExStr (loc, x); e]))); + (let text = stoken loc x e in + {used = []; text = text; styp = fun _ -> MLast.TyLid (loc, "string")} : 'symbol)); [Gramext.Stoken ("UIDENT", "")], Gramext.action (fun (x : string) (loc : int * int) -> - ({used = []; - text = - (fun _ _ -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Stoken")), - MLast.ExTup - (loc, [MLast.ExStr (loc, x); MLast.ExStr (loc, "")]))); + (let text = + if !quotify then sstoken loc x + else stoken loc x (MLast.ExStr (loc, "")) + in + {used = []; text = text; styp = fun _ -> MLast.TyLid (loc, "string")} : 'symbol)); [Gramext.Stoken ("", "["); @@ -1620,4 +1798,7 @@ Grammar.extend (fun (s : string) (loc : int * int) -> (MLast.ExStr (loc, s) : 'string))]]]);; +Pcaml.add_option "-quotify" (Arg.Set quotify) + " Generate code for quotations";; + Pcaml.add_option "-meta_action" (Arg.Set meta_action) " Undocumented";;