git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@4260 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
Daniel de Rauglaudre
parent
8942b4492f
commit
99159966ca
|
|
@ -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";
|
||||
|
|
|
|||
|
|
@ -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";
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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";;
|
||||
|
|
|
|||
Loading…
Reference in New Issue