Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@4297 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Daniel de Rauglaudre 2002-01-22 04:14:35 +00:00
parent f30db5ed9b
commit fb41429561
5 changed files with 109 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
camlp4/meta/pa_extend.ml
View File

@ -22,16 +22,25 @@ Pcaml.add_option "-split_ext" (Arg.Set split_ext)
Pcaml.add_option "-split_gext" (Arg.Set split_ext)
" Old name for the option -split_ext.";
type name = { expr : MLast.expr; tvar : string; loc : (int * int) };
type loc = (int * int);
type entry 'e 'p 't =
{ name : name; pos : option 'e; levels : list (level 'e 'p 't) }
and level 'e 'p 't =
{ label : option string; assoc : option 'e; rules : list (rule 'e 'p 't) }
and rule 'e 'p 't = { prod : list (psymbol 'e 'p 't); action : option 'e }
and psymbol 'e 'p 't = { pattern : option 'p; symbol : symbol 'e 'p 't }
and symbol 'e 'p 't =
{ used : list name; text : string -> string -> 'e; styp : string -> 't }
type styp =
[ STlid of loc and string
| STapp of loc and string and styp
| STquo of loc and string
| STprm of loc and string ]
;
type name 'e = { expr : 'e; tvar : string; loc : (int * int) };
type entry 'e 'p =
{ name : name 'e; pos : option 'e; levels : list (level 'e 'p) }
and level 'e 'p =
{ label : option string; assoc : option 'e; rules : list (rule 'e 'p) }
and rule 'e 'p = { prod : list (psymbol 'e 'p); action : option 'e }
and psymbol 'e 'p = { pattern : option 'p; symbol : symbol 'e 'p }
and symbol 'e 'p =
{ used : list (name 'e); text : string -> string -> 'e; styp : styp }
;
type used = [ Unused | UsedScanned | UsedNotScanned ];
@ -346,6 +355,18 @@ value quotify_action psl act =
e psl
;
value rec make_ctyp styp tvar =
match styp with
[ STlid loc s -> <:ctyp< $lid:s$ >>
| STapp loc s t -> <:ctyp< $lid:s$ $make_ctyp t tvar$ >>
| STquo loc s -> <:ctyp< '$s$ >>
| STprm loc x ->
if tvar = "" then
Stdpp.raise_with_loc loc
(Stream.Error ("'" ^ x ^ "' illegal in anonymous entry level"))
else <:ctyp< '$tvar$ >> ]
;
value text_of_action loc psl rtvar act tvar =
let locid = <:patt< $lid:Stdpp.loc_name.val$ >> in
let act =
@ -360,7 +381,7 @@ value text_of_action loc psl rtvar act tvar =
match ps.pattern with
[ None -> <:expr< fun _ -> $txt$ >>
| Some p ->
let t = ps.symbol.styp tvar in
let t = make_ctyp ps.symbol.styp tvar in
let p =
match p with
[ <:patt< ($list:pl$) >> when quotify.val ->
@ -448,7 +469,7 @@ value sstoken loc s =
value ssopt loc symb =
let psymbol p s t =
let symb = {used = []; text = s; styp = fun _ -> t} in
let symb = {used = []; text = s; styp = t} in
{pattern = Some p; symbol = symb}
in
let rl =
@ -471,7 +492,7 @@ value ssopt loc symb =
let r1 =
let prod =
let text = stoken loc "ANTIQUOT" <:expr< $str:anti_n$ >> in
[psymbol <:patt< a >> text <:ctyp< string >>]
[psymbol <:patt< a >> text (STlid loc "string")]
in
let act = <:expr< antiquot $str:anti_n$ loc a >> in
{prod = prod; action = Some act}
@ -486,14 +507,14 @@ value ssopt loc symb =
{prod = [psymbol]; action = action}
in
let text = srules loc "ast" [rule] in
let styp _ = <:ctyp< ast >> in
let styp = STlid loc "ast" in
{used = []; text = text; styp = styp}
| _ -> symb ]
in
let psymb =
let symb =
{used = []; text = sopt loc symb;
styp = fun n -> <:ctyp< option $symb.styp n$ >>}
styp = STapp loc "option" symb.styp}
in
let patt = <:patt< o >> in
{pattern = Some patt; symbol = symb}
@ -508,14 +529,14 @@ value ssopt loc symb =
value sslist_aux loc min sep s =
let psymbol p s t =
let symb = {used = []; text = s; styp = fun _ -> t} in
let symb = {used = []; text = s; styp = t} in
{pattern = Some p; symbol = symb}
in
let rl =
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) (STquo loc "anti_list")]
in
let act = <:expr< a >> in
{prod = prod; action = Some act}
@ -524,7 +545,7 @@ value sslist_aux loc min sep s =
let psymb =
let symb =
{used = []; text = slist loc min sep s;
styp = fun n -> <:ctyp< list $s.styp n$ >>}
styp = STapp loc "list" s.styp}
in
let patt = <:patt< l >> in
{pattern = Some patt; symbol = symb}
@ -573,7 +594,7 @@ value text_of_entry loc gmod gl e =
let n = "a_" ^ e.name.tvar in
let e = mk_name loc <:expr< $lid:n$ >> in
{used = []; text = snterm loc e None;
styp _ = <:ctyp< ast >>}
styp = STlid loc "ast"}
in
{pattern = Some <:patt< a >>; symbol = s}
in
@ -779,7 +800,7 @@ EXTEND
| i = LIDENT; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] ->
let name = mk_name loc <:expr< $lid:i$ >> in
let text = snterm loc name lev in
let styp _ = <:ctyp< '$i$ >> in
let styp = STquo loc i in
let symb = {used = [name]; text = text; styp = styp} in
{pattern = None; symbol = symb}
| p = pattern; "="; s = symbol -> {pattern = Some p; symbol = s}
@ -794,7 +815,7 @@ EXTEND
[ Some symb -> symb.used @ s.used
| None -> s.used ]
in
let styp n = let t = s.styp n in <:ctyp< list $t$ >> in
let styp = STapp loc "list" s.styp in
let text =
if quotify.val then sslist loc False sep s
else slist loc False sep s
@ -807,60 +828,46 @@ EXTEND
[ Some symb -> symb.used @ s.used
| None -> s.used ]
in
let styp n = let t = s.styp n in <:ctyp< list $t$ >> in
let styp = STapp loc "list" s.styp 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
let styp = STapp loc "option" s.styp in
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
Stdpp.raise_with_loc loc
(Stream.Error "'SELF' illegal in anonymous entry level")
else <:ctyp< '$n$ >>
in
{used = []; text = sself loc; styp = styp}
{used = []; text = sself loc; styp = STprm loc "SELF"}
| UIDENT "NEXT" ->
let styp n =
if n = "" then
Stdpp.raise_with_loc loc
(Stream.Error "'NEXT' illegal in anonymous entry level")
else <:ctyp< '$n$ >>
in
{used = []; text = snext loc; styp = styp}
{used = []; text = snext loc; styp = STprm loc "NEXT"}
| "["; rl = LIST0 rule SEP "|"; "]" ->
let rl = retype_rule_list_without_patterns loc rl in
let t = new_type_var () in
{used = used_of_rule_list rl; text = srules loc t rl;
styp = fun _ -> <:ctyp< '$t$ >>}
styp = STquo loc t}
| x = UIDENT ->
let text =
if quotify.val then sstoken loc x
else stoken loc x <:expr< "" >>
in
{used = []; text = text; styp = fun _ -> <:ctyp< string >>}
{used = []; text = text; styp = STlid loc "string"}
| x = UIDENT; e = string ->
let text = stoken loc x e in
{used = []; text = text; styp = fun _ -> <:ctyp< string >>}
{used = []; text = text; styp = STlid loc "string"}
| e = string ->
let text = stoken loc "" e in
{used = []; text = text; styp = fun _ -> <:ctyp< string >>}
{used = []; text = text; styp = STlid loc "string"}
| i = UIDENT; "."; e = qualid;
lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] ->
let n = mk_name loc <:expr< $uid:i$ . $e$ >> in
{used = [n]; text = snterm loc n lev;
styp = fun _ -> <:ctyp< '$n.tvar$ >>}
{used = [n]; text = snterm loc n lev; styp = STquo loc n.tvar}
| n = name; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] ->
{used = [n]; text = snterm loc n lev;
styp = fun _ -> <:ctyp< '$n.tvar$ >>}
{used = [n]; text = snterm loc n lev; styp = STquo loc n.tvar}
| "("; s_t = SELF; ")" -> s_t ] ]
;
pattern:

4
camlp4/meta/pa_extend_m.ml
View File

@ -24,8 +24,8 @@ EXTEND
[ Some symb -> [mk_name loc <:expr< anti >> :: symb.used @ s.used]
| None -> s.used ]
in
{used = used; text = sslist loc min sep s; styp _ = <:ctyp< ast >>}
{used = used; text = sslist loc min sep s; styp = STlid loc "ast"}
| "SOPT"; s = SELF ->
{used = s.used; text = ssopt loc s; styp _ = <:ctyp< ast >>} ] ]
{used = s.used; text = ssopt loc s; styp = STlid loc "ast"} ] ]
;
END;

111
camlp4/ocaml_src/meta/pa_extend.ml
View File

@ -22,18 +22,25 @@ Pcaml.add_option "-split_ext" (Arg.Set split_ext)
Pcaml.add_option "-split_gext" (Arg.Set split_ext)
" Old name for the option -split_ext.";;
type name = { expr : MLast.expr; tvar : string; loc : int * int };;
type loc = int * int;;
type ('e, 'p, 't) entry =
{ name : name; pos : 'e option; levels : ('e, 'p, 't) level list }
and ('e, 'p, 't) level =
{ label : string option; assoc : 'e option; rules : ('e, 'p, 't) rule list }
and ('e, 'p, 't) rule =
{ prod : ('e, 'p, 't) psymbol list; action : 'e option }
and ('e, 'p, 't) psymbol =
{ pattern : 'p option; symbol : ('e, 'p, 't) symbol }
and ('e, 'p, 't) symbol =
{ used : name list; text : string -> string -> 'e; styp : string -> 't }
type styp =
STlid of loc * string
| STapp of loc * string * styp
| STquo of loc * string
| STprm of loc * string
;;
type 'e name = { expr : 'e; tvar : string; loc : int * int };;
type ('e, 'p) entry =
{ name : 'e name; pos : 'e option; levels : ('e, 'p) level list }
and ('e, 'p) level =
{ label : string option; assoc : 'e option; rules : ('e, 'p) rule list }
and ('e, 'p) rule = { prod : ('e, 'p) psymbol list; action : 'e option }
and ('e, 'p) psymbol = { pattern : 'p option; symbol : ('e, 'p) symbol }
and ('e, 'p) symbol =
{ used : 'e name list; text : string -> string -> 'e; styp : styp }
;;
type used = Unused | UsedScanned | UsedNotScanned;;
@ -724,6 +731,19 @@ let quotify_action psl act =
e psl
;;
let rec make_ctyp styp tvar =
match styp with
STlid (loc, s) -> MLast.TyLid (loc, s)
| STapp (loc, s, t) ->
MLast.TyApp (loc, MLast.TyLid (loc, s), make_ctyp t tvar)
| STquo (loc, s) -> MLast.TyQuo (loc, s)
| STprm (loc, x) ->
if tvar = "" then
Stdpp.raise_with_loc loc
(Stream.Error ("'" ^ x ^ "' illegal in anonymous entry level"))
else MLast.TyQuo (loc, tvar)
;;
let text_of_action loc psl rtvar act tvar =
let locid = MLast.PaLid (loc, !(Stdpp.loc_name)) in
let act =
@ -746,7 +766,7 @@ let text_of_action loc psl rtvar act tvar =
match ps.pattern with
None -> MLast.ExFun (loc, [MLast.PaAny loc, None, txt])
| Some p ->
let t = ps.symbol.styp tvar in
let t = make_ctyp ps.symbol.styp tvar in
let p =
match p with
MLast.PaTup (_, pl) when !quotify ->
@ -937,7 +957,7 @@ let sstoken loc s =
let ssopt loc symb =
let psymbol p s t =
let symb = {used = []; text = s; styp = fun _ -> t} in
let symb = {used = []; text = s; styp = t} in
{pattern = Some p; symbol = symb}
in
let rl =
@ -988,7 +1008,7 @@ let ssopt loc symb =
let r1 =
let prod =
let text = stoken loc "ANTIQUOT" (MLast.ExStr (loc, anti_n)) in
[psymbol (MLast.PaLid (loc, "a")) text (MLast.TyLid (loc, "string"))]
[psymbol (MLast.PaLid (loc, "a")) text (STlid (loc, "string"))]
in
let act =
MLast.ExApp
@ -1023,16 +1043,14 @@ let ssopt loc symb =
{prod = [psymbol]; action = action}
in
let text = srules loc "ast" [rule] in
let styp _ = MLast.TyLid (loc, "ast") in
let styp = STlid (loc, "ast") in
{used = []; text = text; styp = styp}
| _ -> symb
in
let psymb =
let symb =
{used = []; text = sopt loc symb;
styp =
fun n ->
MLast.TyApp (loc, MLast.TyLid (loc, "option"), symb.styp n)}
styp = STapp (loc, "option", symb.styp)}
in
let patt = MLast.PaLid (loc, "o") in
{pattern = Some patt; symbol = symb}
@ -1049,7 +1067,7 @@ let ssopt loc symb =
let sslist_aux loc min sep s =
let psymbol p s t =
let symb = {used = []; text = s; styp = fun _ -> t} in
let symb = {used = []; text = s; styp = t} in
{pattern = Some p; symbol = symb}
in
let rl =
@ -1057,7 +1075,7 @@ let sslist_aux loc min sep s =
let prod =
let n = mk_name loc (MLast.ExLid (loc, "anti_list")) in
[psymbol (MLast.PaLid (loc, "a")) (snterm loc n None)
(MLast.TyQuo (loc, "anti_list"))]
(STquo (loc, "anti_list"))]
in
let act = MLast.ExLid (loc, "a") in {prod = prod; action = Some act}
in
@ -1065,8 +1083,7 @@ let sslist_aux loc min sep s =
let psymb =
let symb =
{used = []; text = slist loc min sep s;
styp =
fun n -> MLast.TyApp (loc, MLast.TyLid (loc, "list"), s.styp n)}
styp = STapp (loc, "list", s.styp)}
in
let patt = MLast.PaLid (loc, "l") in
{pattern = Some patt; symbol = symb}
@ -1128,7 +1145,7 @@ let text_of_entry loc gmod gl e =
let n = "a_" ^ e.name.tvar in
let e = mk_name loc (MLast.ExLid (loc, n)) in
{used = []; text = snterm loc e None;
styp = fun _ -> MLast.TyLid (loc, "ast")}
styp = STlid (loc, "ast")}
in
{pattern = Some (MLast.PaLid (loc, "a")); symbol = s}
in
@ -1695,7 +1712,7 @@ Grammar.extend
(fun (lev : 'e__3 option) (i : string) (loc : int * int) ->
(let name = mk_name loc (MLast.ExLid (loc, i)) in
let text = snterm loc name lev in
let styp _ = MLast.TyQuo (loc, i) in
let styp = STquo (loc, i) in
let symb = {used = [name]; text = text; styp = styp} in
{pattern = None; symbol = symb} :
'psymbol));
@ -1710,10 +1727,7 @@ Grammar.extend
[[Gramext.Stoken ("UIDENT", "OPT"); Gramext.Sself],
Gramext.action
(fun (s : 'symbol) _ (loc : int * int) ->
(let styp n =
let t = s.styp n in
MLast.TyApp (loc, MLast.TyLid (loc, "option"), t)
in
(let styp = STapp (loc, "option", s.styp) in
let text = if !quotify then ssopt loc s else sopt loc s in
{used = s.used; text = text; styp = styp} :
'symbol));
@ -1732,10 +1746,7 @@ Grammar.extend
Some symb -> symb.used @ s.used
| None -> s.used
in
let styp n =
let t = s.styp n in
MLast.TyApp (loc, MLast.TyLid (loc, "list"), t)
in
let styp = STapp (loc, "list", s.styp) in
let text =
if !quotify then sslist loc true sep s else slist loc true sep s
in
@ -1756,10 +1767,7 @@ Grammar.extend
Some symb -> symb.used @ s.used
| None -> s.used
in
let styp n =
let t = s.styp n in
MLast.TyApp (loc, MLast.TyLid (loc, "list"), t)
in
let styp = STapp (loc, "list", s.styp) in
let text =
if !quotify then sslist loc false sep s
else slist loc false sep s
@ -1780,7 +1788,7 @@ Grammar.extend
Gramext.action
(fun (lev : 'e__7 option) (n : 'name) (loc : int * int) ->
({used = [n]; text = snterm loc n lev;
styp = fun _ -> MLast.TyQuo (loc, n.tvar)} :
styp = STquo (loc, n.tvar)} :
'symbol));
[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ".");
Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e));
@ -1797,22 +1805,20 @@ Grammar.extend
mk_name loc (MLast.ExAcc (loc, MLast.ExUid (loc, i), e))
in
{used = [n]; text = snterm loc n lev;
styp = fun _ -> MLast.TyQuo (loc, n.tvar)} :
styp = STquo (loc, n.tvar)} :
'symbol));
[Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))],
Gramext.action
(fun (e : 'string) (loc : int * int) ->
(let text = stoken loc "" e in
{used = []; text = text;
styp = fun _ -> MLast.TyLid (loc, "string")} :
{used = []; text = text; styp = STlid (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) ->
(let text = stoken loc x e in
{used = []; text = text;
styp = fun _ -> MLast.TyLid (loc, "string")} :
{used = []; text = text; styp = STlid (loc, "string")} :
'symbol));
[Gramext.Stoken ("UIDENT", "")],
Gramext.action
@ -1821,8 +1827,7 @@ Grammar.extend
if !quotify then sstoken loc x
else stoken loc x (MLast.ExStr (loc, ""))
in
{used = []; text = text;
styp = fun _ -> MLast.TyLid (loc, "string")} :
{used = []; text = text; styp = STlid (loc, "string")} :
'symbol));
[Gramext.Stoken ("", "[");
Gramext.Slist0sep
@ -1834,29 +1839,17 @@ Grammar.extend
(let rl = retype_rule_list_without_patterns loc rl in
let t = new_type_var () in
{used = used_of_rule_list rl; text = srules loc t rl;
styp = fun _ -> MLast.TyQuo (loc, t)} :
styp = STquo (loc, t)} :
'symbol));
[Gramext.Stoken ("UIDENT", "NEXT")],
Gramext.action
(fun _ (loc : int * int) ->
(let styp n =
if n = "" then
Stdpp.raise_with_loc loc
(Stream.Error "'NEXT' illegal in anonymous entry level")
else MLast.TyQuo (loc, n)
in
{used = []; text = snext loc; styp = styp} :
({used = []; text = snext loc; styp = STprm (loc, "NEXT")} :
'symbol));
[Gramext.Stoken ("UIDENT", "SELF")],
Gramext.action
(fun _ (loc : int * int) ->
(let styp n =
if n = "" then
Stdpp.raise_with_loc loc
(Stream.Error "'SELF' illegal in anonymous entry level")
else MLast.TyQuo (loc, n)
in
{used = []; text = sself loc; styp = styp} :
({used = []; text = sself loc; styp = STprm (loc, "SELF")} :
'symbol))]];
Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e), None,
[None, None,

5
camlp4/ocaml_src/meta/pa_extend_m.ml
View File

@ -21,8 +21,7 @@ Grammar.extend
[[Gramext.Stoken ("", "SOPT"); Gramext.Sself],
Gramext.action
(fun (s : 'symbol) _ (loc : int * int) ->
({used = s.used; text = ssopt loc s;
styp = fun _ -> MLast.TyLid (loc, "ast")} :
({used = s.used; text = ssopt loc s; styp = STlid (loc, "ast")} :
'symbol));
[Gramext.srules
[[Gramext.Stoken ("UIDENT", "SLIST1")],
@ -48,5 +47,5 @@ Grammar.extend
| None -> s.used
in
{used = used; text = sslist loc min sep s;
styp = fun _ -> MLast.TyLid (loc, "ast")} :
styp = STlid (loc, "ast")} :
'symbol))]]];;

4
camlp4/ocaml_src/meta/q_MLast.ml
View File

@ -483,7 +483,7 @@ Grammar.extend
Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3
| _ ->
match () with
_ -> raise (Match_failure ("q_MLast.ml", 5896, 5912))
_ -> raise (Match_failure ("q_MLast.ml", 5892, 5908))
in
Node ("StExc", [Loc; c; tl; b]) :
'str_item));
@ -718,7 +718,7 @@ Grammar.extend
Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3
| _ ->
match () with
_ -> raise (Match_failure ("q_MLast.ml", 7959, 7975))
_ -> raise (Match_failure ("q_MLast.ml", 7955, 7971))
in
Node ("SgExc", [Loc; c; tl]) :
'sig_item));