1805 lines
59 KiB
OCaml
1805 lines
59 KiB
OCaml
(* camlp4r pa_extend.cmo q_MLast.cmo *)
|
|
(***********************************************************************)
|
|
(* *)
|
|
(* Camlp4 *)
|
|
(* *)
|
|
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 2001 Institut National de Recherche en Informatique et *)
|
|
(* Automatique. Distributed only by permission. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* This file has been generated by program: do not edit! *)
|
|
|
|
open Stdpp;;
|
|
|
|
let split_ext = ref false;;
|
|
|
|
Pcaml.add_option "-split_ext" (Arg.Set split_ext)
|
|
" Split EXTEND by functions to turn around a PowerPC problem.";;
|
|
|
|
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 ('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 used = Unused | UsedScanned | UsedNotScanned;;
|
|
|
|
let mark_used modif ht n =
|
|
try
|
|
let rll = Hashtbl.find_all ht n.tvar in
|
|
List.iter
|
|
(fun (r, _) ->
|
|
if !r == Unused then begin r := UsedNotScanned; modif := true end)
|
|
rll
|
|
with
|
|
Not_found -> ()
|
|
;;
|
|
|
|
let rec mark_symbol modif ht symb =
|
|
List.iter (fun e -> mark_used modif ht e) symb.used
|
|
;;
|
|
|
|
let check_use nl el =
|
|
let ht = Hashtbl.create 301 in
|
|
let modif = ref false in
|
|
List.iter
|
|
(fun e ->
|
|
let u =
|
|
match e.name.expr with
|
|
MLast.ExLid (_, _) -> Unused
|
|
| _ -> UsedNotScanned
|
|
in
|
|
Hashtbl.add ht e.name.tvar (ref u, e))
|
|
el;
|
|
List.iter
|
|
(fun n ->
|
|
try
|
|
let rll = Hashtbl.find_all ht n.tvar in
|
|
List.iter (fun (r, _) -> r := UsedNotScanned) rll
|
|
with
|
|
_ -> ())
|
|
nl;
|
|
modif := true;
|
|
while !modif do
|
|
modif := false;
|
|
Hashtbl.iter
|
|
(fun s (r, e) ->
|
|
if !r = UsedNotScanned then
|
|
begin
|
|
r := UsedScanned;
|
|
List.iter
|
|
(fun level ->
|
|
let rules = level.rules in
|
|
List.iter
|
|
(fun rule ->
|
|
List.iter (fun ps -> mark_symbol modif ht ps.symbol)
|
|
rule.prod)
|
|
rules)
|
|
e.levels
|
|
end)
|
|
ht
|
|
done;
|
|
Hashtbl.iter
|
|
(fun s (r, e) ->
|
|
if !r = Unused then
|
|
!(Pcaml.warning) e.name.loc ("Unused local entry \"" ^ s ^ "\""))
|
|
ht
|
|
;;
|
|
|
|
let locate n = let loc = n.loc in n.expr;;
|
|
|
|
let new_type_var =
|
|
let i = ref 0 in fun () -> incr i; "e__" ^ string_of_int !i
|
|
;;
|
|
|
|
let used_of_rule_list rl =
|
|
List.fold_left
|
|
(fun nl r -> List.fold_left (fun nl s -> s.symbol.used @ nl) nl r.prod) []
|
|
rl
|
|
;;
|
|
|
|
let retype_rule_list_without_patterns loc rl =
|
|
try
|
|
List.map
|
|
(function
|
|
{prod = [{pattern = None; symbol = s}]; action = None} ->
|
|
{prod = [{pattern = Some (MLast.PaLid (loc, "x")); symbol = s}];
|
|
action = Some (MLast.ExLid (loc, "x"))}
|
|
| {prod = []; action = Some _} as r -> r
|
|
| _ -> raise Exit)
|
|
rl
|
|
with
|
|
Exit -> rl
|
|
;;
|
|
|
|
let text_of_psymbol_list loc gmod psl tvar =
|
|
List.fold_right
|
|
(fun ps txt ->
|
|
let x = ps.symbol.text gmod tvar in
|
|
MLast.ExApp (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), x), txt))
|
|
psl (MLast.ExUid (loc, "[]"))
|
|
;;
|
|
|
|
let quotify = ref false;;
|
|
let meta_action = ref false;;
|
|
|
|
module MetaAction =
|
|
struct
|
|
let not_impl f x =
|
|
let desc =
|
|
if Obj.is_block (Obj.repr x) then
|
|
"tag = " ^ string_of_int (Obj.tag (Obj.repr x))
|
|
else "int_val = " ^ string_of_int (Obj.magic x)
|
|
in
|
|
failwith (f ^ ", not impl: " ^ desc)
|
|
;;
|
|
let loc = 0, 0;;
|
|
let rec mlist mf =
|
|
function
|
|
[] -> MLast.ExUid (loc, "[]")
|
|
| x :: l ->
|
|
MLast.ExApp
|
|
(loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), mf x),
|
|
mlist mf l)
|
|
;;
|
|
let moption mf =
|
|
function
|
|
None -> MLast.ExUid (loc, "None")
|
|
| Some x -> MLast.ExApp (loc, MLast.ExUid (loc, "Some"), mf x)
|
|
;;
|
|
let mbool =
|
|
function
|
|
false -> MLast.ExUid (loc, "False")
|
|
| true -> MLast.ExUid (loc, "True")
|
|
;;
|
|
let mloc =
|
|
MLast.ExTup (loc, [MLast.ExInt (loc, "0"); MLast.ExInt (loc, "0")])
|
|
;;
|
|
let rec mexpr =
|
|
function
|
|
MLast.ExAcc (loc, e1, e2) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "ExAcc")),
|
|
mloc),
|
|
mexpr e1),
|
|
mexpr e2)
|
|
| MLast.ExApp (loc, e1, e2) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "ExApp")),
|
|
mloc),
|
|
mexpr e1),
|
|
mexpr e2)
|
|
| MLast.ExChr (loc, s) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "ExChr")),
|
|
mloc),
|
|
MLast.ExStr (loc, s))
|
|
| MLast.ExFun (loc, pwel) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "ExFun")),
|
|
mloc),
|
|
mlist mpwe pwel)
|
|
| MLast.ExIfe (loc, e1, e2, e3) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "ExIfe")),
|
|
mloc),
|
|
mexpr e1),
|
|
mexpr e2),
|
|
mexpr e3)
|
|
| MLast.ExInt (loc, s) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "ExInt")),
|
|
mloc),
|
|
MLast.ExStr (loc, s))
|
|
| MLast.ExFlo (loc, s) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "ExFlo")),
|
|
mloc),
|
|
MLast.ExStr (loc, s))
|
|
| MLast.ExLet (loc, rf, pel, e) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "ExLet")),
|
|
mloc),
|
|
mbool rf),
|
|
mlist mpe pel),
|
|
mexpr e)
|
|
| MLast.ExLid (loc, s) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "ExLid")),
|
|
mloc),
|
|
MLast.ExStr (loc, s))
|
|
| MLast.ExMat (loc, e, pwel) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "ExMat")),
|
|
mloc),
|
|
mexpr e),
|
|
mlist mpwe pwel)
|
|
| MLast.ExRec (loc, pel, eo) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "ExRec")),
|
|
mloc),
|
|
mlist mpe pel),
|
|
moption mexpr eo)
|
|
| MLast.ExSeq (loc, el) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "ExSeq")),
|
|
mloc),
|
|
mlist mexpr el)
|
|
| MLast.ExSte (loc, e1, e2) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "ExSte")),
|
|
mloc),
|
|
mexpr e1),
|
|
mexpr e2)
|
|
| MLast.ExStr (loc, s) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "ExStr")),
|
|
mloc),
|
|
MLast.ExStr (loc, String.escaped s))
|
|
| MLast.ExTry (loc, e, pwel) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "ExTry")),
|
|
mloc),
|
|
mexpr e),
|
|
mlist mpwe pwel)
|
|
| MLast.ExTup (loc, el) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "ExTup")),
|
|
mloc),
|
|
mlist mexpr el)
|
|
| MLast.ExTyc (loc, e, t) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "ExTyc")),
|
|
mloc),
|
|
mexpr e),
|
|
mctyp t)
|
|
| MLast.ExUid (loc, s) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "ExUid")),
|
|
mloc),
|
|
MLast.ExStr (loc, s))
|
|
| x -> not_impl "mexpr" x
|
|
and mpatt =
|
|
function
|
|
MLast.PaAcc (loc, p1, p2) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "PaAcc")),
|
|
mloc),
|
|
mpatt p1),
|
|
mpatt p2)
|
|
| MLast.PaAny loc ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"), MLast.ExUid (loc, "PaAny")),
|
|
mloc)
|
|
| MLast.PaApp (loc, p1, p2) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "PaApp")),
|
|
mloc),
|
|
mpatt p1),
|
|
mpatt p2)
|
|
| MLast.PaInt (loc, s) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "PaInt")),
|
|
mloc),
|
|
MLast.ExStr (loc, s))
|
|
| MLast.PaLid (loc, s) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "PaLid")),
|
|
mloc),
|
|
MLast.ExStr (loc, s))
|
|
| MLast.PaOrp (loc, p1, p2) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "PaOrp")),
|
|
mloc),
|
|
mpatt p1),
|
|
mpatt p2)
|
|
| MLast.PaStr (loc, s) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "PaStr")),
|
|
mloc),
|
|
MLast.ExStr (loc, String.escaped s))
|
|
| MLast.PaTup (loc, pl) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "PaTup")),
|
|
mloc),
|
|
mlist mpatt pl)
|
|
| MLast.PaTyc (loc, p, t) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "PaTyc")),
|
|
mloc),
|
|
mpatt p),
|
|
mctyp t)
|
|
| MLast.PaUid (loc, s) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "PaUid")),
|
|
mloc),
|
|
MLast.ExStr (loc, s))
|
|
| x -> not_impl "mpatt" x
|
|
and mctyp =
|
|
function
|
|
MLast.TyAcc (loc, t1, t2) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "TyAcc")),
|
|
mloc),
|
|
mctyp t1),
|
|
mctyp t2)
|
|
| MLast.TyApp (loc, t1, t2) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "TyApp")),
|
|
mloc),
|
|
mctyp t1),
|
|
mctyp t2)
|
|
| MLast.TyLid (loc, s) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "TyLid")),
|
|
mloc),
|
|
MLast.ExStr (loc, s))
|
|
| MLast.TyQuo (loc, s) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "TyQuo")),
|
|
mloc),
|
|
MLast.ExStr (loc, s))
|
|
| MLast.TyTup (loc, tl) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "TyTup")),
|
|
mloc),
|
|
mlist mctyp tl)
|
|
| MLast.TyUid (loc, s) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "MLast"),
|
|
MLast.ExUid (loc, "TyUid")),
|
|
mloc),
|
|
MLast.ExStr (loc, s))
|
|
| x -> not_impl "mctyp" x
|
|
and mpe (p, e) = MLast.ExTup (loc, [mpatt p; mexpr e])
|
|
and mpwe (p, w, e) =
|
|
MLast.ExTup (loc, [mpatt p; moption mexpr w; mexpr e])
|
|
;;
|
|
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 -> if !quotify then quotify_action psl act else act
|
|
| None -> MLast.ExUid (loc, "()")
|
|
in
|
|
let e =
|
|
MLast.ExFun
|
|
(loc,
|
|
[MLast.PaTyc
|
|
(loc, locid,
|
|
MLast.TyTup
|
|
(loc, [MLast.TyLid (loc, "int"); MLast.TyLid (loc, "int")])),
|
|
None, MLast.ExTyc (loc, act, MLast.TyQuo (loc, rtvar))])
|
|
in
|
|
let txt =
|
|
List.fold_left
|
|
(fun txt ps ->
|
|
match ps.pattern with
|
|
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
|
|
let txt =
|
|
if !meta_action then
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Obj"), MLast.ExLid (loc, "magic")),
|
|
MetaAction.mexpr txt)
|
|
else txt
|
|
in
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"), MLast.ExLid (loc, "action")),
|
|
txt)
|
|
;;
|
|
|
|
let text_of_rule_list loc gmod rtvar rl tvar =
|
|
List.fold_left
|
|
(fun txt r ->
|
|
let sl = text_of_psymbol_list loc gmod r.prod tvar in
|
|
let ac = text_of_action loc r.prod rtvar r.action tvar in
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc, MLast.ExUid (loc, "::"), MLast.ExTup (loc, [sl; ac])),
|
|
txt))
|
|
(MLast.ExUid (loc, "[]")) rl
|
|
;;
|
|
|
|
let text_of_entry loc gmod e =
|
|
let ent =
|
|
let x = e.name in
|
|
let loc = e.name.loc in
|
|
MLast.ExTyc
|
|
(loc, x.expr,
|
|
MLast.TyApp
|
|
(loc,
|
|
MLast.TyAcc
|
|
(loc,
|
|
MLast.TyAcc
|
|
(loc, MLast.TyUid (loc, gmod), MLast.TyUid (loc, "Entry")),
|
|
MLast.TyLid (loc, "e")),
|
|
MLast.TyQuo (loc, x.tvar)))
|
|
in
|
|
let pos =
|
|
match e.pos with
|
|
Some pos -> MLast.ExApp (loc, MLast.ExUid (loc, "Some"), pos)
|
|
| None -> MLast.ExUid (loc, "None")
|
|
in
|
|
let txt =
|
|
List.fold_right
|
|
(fun level txt ->
|
|
let lab =
|
|
match level.label with
|
|
Some lab ->
|
|
MLast.ExApp
|
|
(loc, MLast.ExUid (loc, "Some"), MLast.ExStr (loc, lab))
|
|
| None -> MLast.ExUid (loc, "None")
|
|
in
|
|
let ass =
|
|
match level.assoc with
|
|
Some ass -> MLast.ExApp (loc, MLast.ExUid (loc, "Some"), ass)
|
|
| None -> MLast.ExUid (loc, "None")
|
|
in
|
|
let txt =
|
|
let rl =
|
|
text_of_rule_list loc gmod e.name.tvar level.rules e.name.tvar
|
|
in
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc, MLast.ExUid (loc, "::"),
|
|
MLast.ExTup (loc, [lab; ass; rl])),
|
|
txt)
|
|
in
|
|
txt)
|
|
e.levels (MLast.ExUid (loc, "[]"))
|
|
in
|
|
ent, pos, txt
|
|
;;
|
|
|
|
let let_in_of_extend loc gmod functor_version gl el args =
|
|
match gl with
|
|
Some (n1 :: _ as nl) ->
|
|
check_use nl el;
|
|
let ll =
|
|
List.fold_right
|
|
(fun e ll ->
|
|
match e.name.expr with
|
|
MLast.ExLid (_, _) ->
|
|
if List.exists (fun n -> e.name.tvar = n.tvar) nl then ll
|
|
else e.name :: ll
|
|
| _ -> ll)
|
|
el []
|
|
in
|
|
let globals =
|
|
List.map
|
|
(fun {expr = e; tvar = x; loc = loc} ->
|
|
MLast.PaAny loc,
|
|
MLast.ExTyc
|
|
(loc, e,
|
|
MLast.TyApp
|
|
(loc,
|
|
MLast.TyAcc
|
|
(loc,
|
|
MLast.TyAcc
|
|
(loc, MLast.TyUid (loc, gmod),
|
|
MLast.TyUid (loc, "Entry")),
|
|
MLast.TyLid (loc, "e")),
|
|
MLast.TyQuo (loc, x))))
|
|
nl
|
|
in
|
|
let locals =
|
|
List.map
|
|
(fun {expr = e; tvar = x; loc = loc} ->
|
|
let i =
|
|
match e with
|
|
MLast.ExLid (_, i) -> i
|
|
| _ -> failwith "internal error in pa_extend"
|
|
in
|
|
MLast.PaLid (loc, i),
|
|
MLast.ExTyc
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc, MLast.ExLid (loc, "grammar_entry_create"),
|
|
MLast.ExStr (loc, i)),
|
|
MLast.TyApp
|
|
(loc,
|
|
MLast.TyAcc
|
|
(loc,
|
|
MLast.TyAcc
|
|
(loc, MLast.TyUid (loc, gmod),
|
|
MLast.TyUid (loc, "Entry")),
|
|
MLast.TyLid (loc, "e")),
|
|
MLast.TyQuo (loc, x))))
|
|
ll
|
|
in
|
|
let e =
|
|
if ll = [] then args
|
|
else if functor_version then
|
|
MLast.ExLet
|
|
(loc, false,
|
|
[MLast.PaLid (loc, "grammar_entry_create"),
|
|
MLast.ExAcc
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, gmod), MLast.ExUid (loc, "Entry")),
|
|
MLast.ExLid (loc, "create"))],
|
|
MLast.ExLet (loc, false, locals, args))
|
|
else
|
|
MLast.ExLet
|
|
(loc, false,
|
|
[MLast.PaLid (loc, "grammar_entry_create"),
|
|
MLast.ExFun
|
|
(loc,
|
|
[MLast.PaLid (loc, "s"), None,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, gmod),
|
|
MLast.ExUid (loc, "Entry")),
|
|
MLast.ExLid (loc, "create")),
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, gmod),
|
|
MLast.ExLid (loc, "of_entry")),
|
|
locate n1)),
|
|
MLast.ExLid (loc, "s"))])],
|
|
MLast.ExLet (loc, false, locals, args))
|
|
in
|
|
MLast.ExLet (loc, false, globals, e)
|
|
| _ -> args
|
|
;;
|
|
|
|
let text_of_extend loc gmod gl el f =
|
|
if !split_ext then
|
|
let args =
|
|
List.map
|
|
(fun e ->
|
|
let (ent, pos, txt) = text_of_entry e.name.loc gmod e in
|
|
let ent =
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, gmod),
|
|
MLast.ExUid (loc, "Entry")),
|
|
MLast.ExLid (loc, "obj")),
|
|
ent)
|
|
in
|
|
let e = MLast.ExTup (loc, [ent; pos; txt]) in
|
|
MLast.ExLet
|
|
(loc, false,
|
|
[MLast.PaLid (loc, "aux"),
|
|
MLast.ExFun
|
|
(loc,
|
|
[MLast.PaUid (loc, "()"), None,
|
|
MLast.ExApp
|
|
(loc, f,
|
|
MLast.ExApp
|
|
(loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e),
|
|
MLast.ExUid (loc, "[]")))])],
|
|
MLast.ExApp
|
|
(loc, MLast.ExLid (loc, "aux"), MLast.ExUid (loc, "()"))))
|
|
el
|
|
in
|
|
let args = MLast.ExSeq (loc, args) in
|
|
let_in_of_extend loc gmod false gl el args
|
|
else
|
|
let args =
|
|
List.fold_right
|
|
(fun e el ->
|
|
let (ent, pos, txt) = text_of_entry e.name.loc gmod e in
|
|
let ent =
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, gmod),
|
|
MLast.ExUid (loc, "Entry")),
|
|
MLast.ExLid (loc, "obj")),
|
|
ent)
|
|
in
|
|
let e = MLast.ExTup (loc, [ent; pos; txt]) in
|
|
MLast.ExApp
|
|
(loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e), el))
|
|
el (MLast.ExUid (loc, "[]"))
|
|
in
|
|
let args = let_in_of_extend loc gmod false gl el args in
|
|
MLast.ExApp (loc, f, args)
|
|
;;
|
|
|
|
let text_of_functorial_extend loc gmod gl el =
|
|
let args =
|
|
let el =
|
|
List.map
|
|
(fun e ->
|
|
let (ent, pos, txt) = text_of_entry e.name.loc gmod e in
|
|
let e =
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, gmod),
|
|
MLast.ExLid (loc, "extend")),
|
|
ent),
|
|
pos),
|
|
txt)
|
|
in
|
|
if !split_ext then
|
|
MLast.ExLet
|
|
(loc, false,
|
|
[MLast.PaLid (loc, "aux"),
|
|
MLast.ExFun (loc, [MLast.PaUid (loc, "()"), None, e])],
|
|
MLast.ExApp
|
|
(loc, MLast.ExLid (loc, "aux"), MLast.ExUid (loc, "()")))
|
|
else e)
|
|
el
|
|
in
|
|
MLast.ExSeq (loc, el)
|
|
in
|
|
let_in_of_extend loc gmod true gl el args
|
|
;;
|
|
|
|
let expr_of_delete_rule loc gmod n sl =
|
|
let sl =
|
|
List.fold_right
|
|
(fun s e ->
|
|
MLast.ExApp
|
|
(loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), s.text gmod ""),
|
|
e))
|
|
sl (MLast.ExUid (loc, "[]"))
|
|
in
|
|
n.expr, sl
|
|
;;
|
|
|
|
let rec ident_of_expr =
|
|
function
|
|
MLast.ExLid (_, s) -> s
|
|
| MLast.ExUid (_, s) -> s
|
|
| MLast.ExAcc (_, e1, e2) -> ident_of_expr e1 ^ "__" ^ ident_of_expr e2
|
|
| _ -> failwith "internal error in pa_extend"
|
|
;;
|
|
|
|
let mk_name loc e = {expr = e; tvar = ident_of_expr e; loc = loc};;
|
|
|
|
let sself loc gmod n =
|
|
MLast.ExAcc (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Sself"))
|
|
;;
|
|
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 ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"),
|
|
MLast.ExUid (loc, "Snterml")),
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, gmod),
|
|
MLast.ExUid (loc, "Entry")),
|
|
MLast.ExLid (loc, "obj")),
|
|
MLast.ExTyc
|
|
(loc, n.expr,
|
|
MLast.TyApp
|
|
(loc,
|
|
MLast.TyAcc
|
|
(loc,
|
|
MLast.TyAcc
|
|
(loc, MLast.TyUid (loc, gmod),
|
|
MLast.TyUid (loc, "Entry")),
|
|
MLast.TyLid (loc, "e")),
|
|
MLast.TyQuo (loc, n.tvar))))),
|
|
MLast.ExStr (loc, lab))
|
|
| None ->
|
|
if n.tvar = tvar then sself loc gmod tvar
|
|
else
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Snterm")),
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, gmod), MLast.ExUid (loc, "Entry")),
|
|
MLast.ExLid (loc, "obj")),
|
|
MLast.ExTyc
|
|
(loc, n.expr,
|
|
MLast.TyApp
|
|
(loc,
|
|
MLast.TyAcc
|
|
(loc,
|
|
MLast.TyAcc
|
|
(loc, MLast.TyUid (loc, gmod),
|
|
MLast.TyUid (loc, "Entry")),
|
|
MLast.TyLid (loc, "e")),
|
|
MLast.TyQuo (loc, n.tvar)))))
|
|
;;
|
|
let slist loc min sep symb gmod n =
|
|
let txt = symb.text gmod "" in
|
|
match min, sep with
|
|
false, None ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Slist0")),
|
|
txt)
|
|
| true, None ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Slist1")),
|
|
txt)
|
|
| false, Some s ->
|
|
let x = s.text gmod n in
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"),
|
|
MLast.ExUid (loc, "Slist0sep")),
|
|
txt),
|
|
x)
|
|
| true, Some s ->
|
|
let x = s.text gmod n in
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"),
|
|
MLast.ExUid (loc, "Slist1sep")),
|
|
txt),
|
|
x)
|
|
;;
|
|
let sopt loc symb gmod n =
|
|
let txt = symb.text gmod "" in
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Sopt")),
|
|
txt)
|
|
;;
|
|
let srules loc t rl gmod tvar =
|
|
let e = text_of_rule_list loc gmod t rl "" in
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"), MLast.ExLid (loc, "srules")),
|
|
e)
|
|
;;
|
|
|
|
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 "anti" 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}
|
|
in
|
|
let rl =
|
|
let r1 =
|
|
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"))]
|
|
in
|
|
let act = MLast.ExLid (loc, "a") in {prod = prod; action = Some act}
|
|
in
|
|
let r2 =
|
|
let psymb =
|
|
let symb =
|
|
{used = []; text = slist loc min sep s;
|
|
styp =
|
|
fun n -> MLast.TyApp (loc, MLast.TyLid (loc, "list"), s.styp n)}
|
|
in
|
|
let patt = MLast.PaLid (loc, "l") in
|
|
{pattern = Some patt; symbol = symb}
|
|
in
|
|
let act =
|
|
MLast.ExApp (loc, MLast.ExLid (loc, "list"), MLast.ExLid (loc, "l"))
|
|
in
|
|
{prod = [psymb]; action = Some act}
|
|
in
|
|
[r1; r2]
|
|
in
|
|
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;;
|
|
let symbol = Grammar.Entry.create gram "symbol";;
|
|
|
|
Grammar.extend
|
|
(let _ = (expr : 'expr Grammar.Entry.e)
|
|
and _ = (symbol : 'symbol Grammar.Entry.e) in
|
|
let grammar_entry_create s =
|
|
Grammar.Entry.create (Grammar.of_entry expr) s
|
|
in
|
|
let extend_body : 'extend_body Grammar.Entry.e =
|
|
grammar_entry_create "extend_body"
|
|
and gextend_body : 'gextend_body Grammar.Entry.e =
|
|
grammar_entry_create "gextend_body"
|
|
and delete_rule_body : 'delete_rule_body Grammar.Entry.e =
|
|
grammar_entry_create "delete_rule_body"
|
|
and gdelete_rule_body : 'gdelete_rule_body Grammar.Entry.e =
|
|
grammar_entry_create "gdelete_rule_body"
|
|
and efunction : 'efunction Grammar.Entry.e =
|
|
grammar_entry_create "efunction"
|
|
and global : 'global Grammar.Entry.e = grammar_entry_create "global"
|
|
and entry : 'entry Grammar.Entry.e = grammar_entry_create "entry"
|
|
and position : 'position Grammar.Entry.e = grammar_entry_create "position"
|
|
and level_list : 'level_list Grammar.Entry.e =
|
|
grammar_entry_create "level_list"
|
|
and level : 'level Grammar.Entry.e = grammar_entry_create "level"
|
|
and assoc : 'assoc Grammar.Entry.e = grammar_entry_create "assoc"
|
|
and rule_list : 'rule_list Grammar.Entry.e =
|
|
grammar_entry_create "rule_list"
|
|
and rule : 'rule Grammar.Entry.e = grammar_entry_create "rule"
|
|
and psymbol : 'psymbol Grammar.Entry.e = grammar_entry_create "psymbol"
|
|
and pattern : 'pattern Grammar.Entry.e = grammar_entry_create "pattern"
|
|
and patterns_comma : 'patterns_comma Grammar.Entry.e =
|
|
grammar_entry_create "patterns_comma"
|
|
and name : 'name Grammar.Entry.e = grammar_entry_create "name"
|
|
and qualid : 'qualid Grammar.Entry.e = grammar_entry_create "qualid"
|
|
and string : 'string Grammar.Entry.e = grammar_entry_create "string" in
|
|
[Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
|
|
Some (Gramext.After "top"),
|
|
[None, None,
|
|
[[Gramext.Stoken ("", "GDELETE_RULE");
|
|
Gramext.Snterm
|
|
(Grammar.Entry.obj
|
|
(gdelete_rule_body : 'gdelete_rule_body Grammar.Entry.e));
|
|
Gramext.Stoken ("", "END")],
|
|
Gramext.action
|
|
(fun _ (e : 'gdelete_rule_body) _ (loc : int * int) -> (e : 'expr));
|
|
[Gramext.Stoken ("", "DELETE_RULE");
|
|
Gramext.Snterm
|
|
(Grammar.Entry.obj
|
|
(delete_rule_body : 'delete_rule_body Grammar.Entry.e));
|
|
Gramext.Stoken ("", "END")],
|
|
Gramext.action
|
|
(fun _ (e : 'delete_rule_body) _ (loc : int * int) -> (e : 'expr));
|
|
[Gramext.Stoken ("", "GEXTEND");
|
|
Gramext.Snterm
|
|
(Grammar.Entry.obj (gextend_body : 'gextend_body Grammar.Entry.e));
|
|
Gramext.Stoken ("", "END")],
|
|
Gramext.action
|
|
(fun _ (e : 'gextend_body) _ (loc : int * int) -> (e : 'expr));
|
|
[Gramext.Stoken ("", "EXTEND");
|
|
Gramext.Snterm
|
|
(Grammar.Entry.obj (extend_body : 'extend_body Grammar.Entry.e));
|
|
Gramext.Stoken ("", "END")],
|
|
Gramext.action
|
|
(fun _ (e : 'extend_body) _ (loc : int * int) -> (e : 'expr))]];
|
|
Grammar.Entry.obj (extend_body : 'extend_body Grammar.Entry.e), None,
|
|
[None, None,
|
|
[[Gramext.Snterm
|
|
(Grammar.Entry.obj (efunction : 'efunction Grammar.Entry.e));
|
|
Gramext.Sopt
|
|
(Gramext.Snterm
|
|
(Grammar.Entry.obj (global : 'global Grammar.Entry.e)));
|
|
Gramext.Slist1
|
|
(Gramext.srules
|
|
[[Gramext.Snterm
|
|
(Grammar.Entry.obj (entry : 'entry Grammar.Entry.e));
|
|
Gramext.Stoken ("", ";")],
|
|
Gramext.action
|
|
(fun _ (e : 'entry) (loc : int * int) -> (e : 'e__1))])],
|
|
Gramext.action
|
|
(fun (el : 'e__1 list) (sl : 'global option) (f : 'efunction)
|
|
(loc : int * int) ->
|
|
(text_of_extend loc "Grammar" sl el f : 'extend_body))]];
|
|
Grammar.Entry.obj (gextend_body : 'gextend_body Grammar.Entry.e), None,
|
|
[None, None,
|
|
[[Gramext.Stoken ("UIDENT", "");
|
|
Gramext.Sopt
|
|
(Gramext.Snterm
|
|
(Grammar.Entry.obj (global : 'global Grammar.Entry.e)));
|
|
Gramext.Slist1
|
|
(Gramext.srules
|
|
[[Gramext.Snterm
|
|
(Grammar.Entry.obj (entry : 'entry Grammar.Entry.e));
|
|
Gramext.Stoken ("", ";")],
|
|
Gramext.action
|
|
(fun _ (e : 'entry) (loc : int * int) -> (e : 'e__2))])],
|
|
Gramext.action
|
|
(fun (el : 'e__2 list) (sl : 'global option) (g : string)
|
|
(loc : int * int) ->
|
|
(text_of_functorial_extend loc g sl el : 'gextend_body))]];
|
|
Grammar.Entry.obj (delete_rule_body : 'delete_rule_body Grammar.Entry.e),
|
|
None,
|
|
[None, None,
|
|
[[Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e));
|
|
Gramext.Stoken ("", ":");
|
|
Gramext.Slist1sep
|
|
(Gramext.Snterm
|
|
(Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e)),
|
|
Gramext.Stoken ("", ";"))],
|
|
Gramext.action
|
|
(fun (sl : 'symbol list) _ (n : 'name) (loc : int * int) ->
|
|
(let (e, b) = expr_of_delete_rule loc "Grammar" n sl in
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Grammar"),
|
|
MLast.ExLid (loc, "delete_rule")),
|
|
e),
|
|
b) :
|
|
'delete_rule_body))]];
|
|
Grammar.Entry.obj
|
|
(gdelete_rule_body : 'gdelete_rule_body Grammar.Entry.e),
|
|
None,
|
|
[None, None,
|
|
[[Gramext.Stoken ("UIDENT", "");
|
|
Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e));
|
|
Gramext.Stoken ("", ":");
|
|
Gramext.Slist1sep
|
|
(Gramext.Snterm
|
|
(Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e)),
|
|
Gramext.Stoken ("", ";"))],
|
|
Gramext.action
|
|
(fun (sl : 'symbol list) _ (n : 'name) (g : string)
|
|
(loc : int * int) ->
|
|
(let (e, b) = expr_of_delete_rule loc g n sl in
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, g),
|
|
MLast.ExLid (loc, "delete_rule")),
|
|
e),
|
|
b) :
|
|
'gdelete_rule_body))]];
|
|
Grammar.Entry.obj (efunction : 'efunction Grammar.Entry.e), None,
|
|
[None, None,
|
|
[[],
|
|
Gramext.action
|
|
(fun (loc : int * int) ->
|
|
(MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Grammar"),
|
|
MLast.ExLid (loc, "extend")) :
|
|
'efunction));
|
|
[Gramext.Stoken ("UIDENT", "FUNCTION"); Gramext.Stoken ("", ":");
|
|
Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e));
|
|
Gramext.Stoken ("", ";")],
|
|
Gramext.action
|
|
(fun _ (f : 'qualid) _ _ (loc : int * int) -> (f : 'efunction))]];
|
|
Grammar.Entry.obj (global : 'global Grammar.Entry.e), None,
|
|
[None, None,
|
|
[[Gramext.Stoken ("UIDENT", "GLOBAL"); Gramext.Stoken ("", ":");
|
|
Gramext.Slist1
|
|
(Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e)));
|
|
Gramext.Stoken ("", ";")],
|
|
Gramext.action
|
|
(fun _ (sl : 'name list) _ _ (loc : int * int) -> (sl : 'global))]];
|
|
Grammar.Entry.obj (entry : 'entry Grammar.Entry.e), None,
|
|
[None, None,
|
|
[[Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e));
|
|
Gramext.Stoken ("", ":");
|
|
Gramext.Sopt
|
|
(Gramext.Snterm
|
|
(Grammar.Entry.obj (position : 'position Grammar.Entry.e)));
|
|
Gramext.Snterm
|
|
(Grammar.Entry.obj (level_list : 'level_list Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun (ll : 'level_list) (pos : 'position option) _ (n : 'name)
|
|
(loc : int * int) ->
|
|
({name = n; pos = pos; levels = ll} : 'entry))]];
|
|
Grammar.Entry.obj (position : 'position Grammar.Entry.e), None,
|
|
[None, None,
|
|
[[Gramext.Stoken ("UIDENT", "LEVEL");
|
|
Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun (n : 'string) _ (loc : int * int) ->
|
|
(MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"),
|
|
MLast.ExUid (loc, "Level")),
|
|
n) :
|
|
'position));
|
|
[Gramext.Stoken ("UIDENT", "AFTER");
|
|
Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun (n : 'string) _ (loc : int * int) ->
|
|
(MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"),
|
|
MLast.ExUid (loc, "After")),
|
|
n) :
|
|
'position));
|
|
[Gramext.Stoken ("UIDENT", "BEFORE");
|
|
Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun (n : 'string) _ (loc : int * int) ->
|
|
(MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"),
|
|
MLast.ExUid (loc, "Before")),
|
|
n) :
|
|
'position));
|
|
[Gramext.Stoken ("UIDENT", "LAST")],
|
|
Gramext.action
|
|
(fun _ (loc : int * int) ->
|
|
(MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Last")) :
|
|
'position));
|
|
[Gramext.Stoken ("UIDENT", "FIRST")],
|
|
Gramext.action
|
|
(fun _ (loc : int * int) ->
|
|
(MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"),
|
|
MLast.ExUid (loc, "First")) :
|
|
'position))]];
|
|
Grammar.Entry.obj (level_list : 'level_list Grammar.Entry.e), None,
|
|
[None, None,
|
|
[[Gramext.Stoken ("", "[");
|
|
Gramext.Slist0sep
|
|
(Gramext.Snterm (Grammar.Entry.obj (level : 'level Grammar.Entry.e)),
|
|
Gramext.Stoken ("", "|"));
|
|
Gramext.Stoken ("", "]")],
|
|
Gramext.action
|
|
(fun _ (ll : 'level list) _ (loc : int * int) ->
|
|
(ll : 'level_list))]];
|
|
Grammar.Entry.obj (level : 'level Grammar.Entry.e), None,
|
|
[None, None,
|
|
[[Gramext.Sopt (Gramext.Stoken ("STRING", ""));
|
|
Gramext.Sopt
|
|
(Gramext.Snterm
|
|
(Grammar.Entry.obj (assoc : 'assoc Grammar.Entry.e)));
|
|
Gramext.Snterm
|
|
(Grammar.Entry.obj (rule_list : 'rule_list Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun (rules : 'rule_list) (ass : 'assoc option) (lab : string option)
|
|
(loc : int * int) ->
|
|
({label = lab; assoc = ass; rules = rules} : 'level))]];
|
|
Grammar.Entry.obj (assoc : 'assoc Grammar.Entry.e), None,
|
|
[None, None,
|
|
[[Gramext.Stoken ("UIDENT", "NONA")],
|
|
Gramext.action
|
|
(fun _ (loc : int * int) ->
|
|
(MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "NonA")) :
|
|
'assoc));
|
|
[Gramext.Stoken ("UIDENT", "RIGHTA")],
|
|
Gramext.action
|
|
(fun _ (loc : int * int) ->
|
|
(MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"),
|
|
MLast.ExUid (loc, "RightA")) :
|
|
'assoc));
|
|
[Gramext.Stoken ("UIDENT", "LEFTA")],
|
|
Gramext.action
|
|
(fun _ (loc : int * int) ->
|
|
(MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"),
|
|
MLast.ExUid (loc, "LeftA")) :
|
|
'assoc))]];
|
|
Grammar.Entry.obj (rule_list : 'rule_list Grammar.Entry.e), None,
|
|
[None, None,
|
|
[[Gramext.Stoken ("", "[");
|
|
Gramext.Slist1sep
|
|
(Gramext.Snterm (Grammar.Entry.obj (rule : 'rule Grammar.Entry.e)),
|
|
Gramext.Stoken ("", "|"));
|
|
Gramext.Stoken ("", "]")],
|
|
Gramext.action
|
|
(fun _ (rules : 'rule list) _ (loc : int * int) ->
|
|
(retype_rule_list_without_patterns loc rules : 'rule_list));
|
|
[Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")],
|
|
Gramext.action (fun _ _ (loc : int * int) -> ([] : 'rule_list))]];
|
|
Grammar.Entry.obj (rule : 'rule Grammar.Entry.e), None,
|
|
[None, None,
|
|
[[Gramext.Slist0sep
|
|
(Gramext.Snterm
|
|
(Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e)),
|
|
Gramext.Stoken ("", ";"))],
|
|
Gramext.action
|
|
(fun (psl : 'psymbol list) (loc : int * int) ->
|
|
({prod = psl; action = None} : 'rule));
|
|
[Gramext.Slist0sep
|
|
(Gramext.Snterm
|
|
(Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e)),
|
|
Gramext.Stoken ("", ";"));
|
|
Gramext.Stoken ("", "->");
|
|
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun (act : 'expr) _ (psl : 'psymbol list) (loc : int * int) ->
|
|
({prod = psl; action = Some act} : 'rule))]];
|
|
Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e), None,
|
|
[None, None,
|
|
[[Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun (s : 'symbol) (loc : int * int) ->
|
|
({pattern = None; symbol = s} : 'psymbol));
|
|
[Gramext.Snterm
|
|
(Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e));
|
|
Gramext.Stoken ("", "=");
|
|
Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun (s : 'symbol) _ (p : 'pattern) (loc : int * int) ->
|
|
({pattern = Some p; symbol = s} : 'psymbol));
|
|
[Gramext.Stoken ("LIDENT", "");
|
|
Gramext.Sopt
|
|
(Gramext.srules
|
|
[[Gramext.Stoken ("UIDENT", "LEVEL");
|
|
Gramext.Stoken ("STRING", "")],
|
|
Gramext.action
|
|
(fun (s : string) _ (loc : int * int) -> (s : 'e__3))])],
|
|
Gramext.action
|
|
(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 symb = {used = [name]; text = text; styp = styp} in
|
|
{pattern = None; symbol = symb} :
|
|
'psymbol));
|
|
[Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", "=");
|
|
Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun (s : 'symbol) _ (p : string) (loc : int * int) ->
|
|
({pattern = Some (MLast.PaLid (loc, p)); symbol = s} :
|
|
'psymbol))]];
|
|
Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e), None,
|
|
[Some "top", Some Gramext.NonA,
|
|
[[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 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
|
|
(Gramext.srules
|
|
[[Gramext.Stoken ("UIDENT", "SEP");
|
|
Gramext.Snterm
|
|
(Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun (t : 'symbol) _ (loc : int * int) -> (t : 'e__5))])],
|
|
Gramext.action
|
|
(fun (sep : 'e__5 option) (s : 'symbol) _ (loc : int * int) ->
|
|
(let used =
|
|
match sep with
|
|
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 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;
|
|
Gramext.Sopt
|
|
(Gramext.srules
|
|
[[Gramext.Stoken ("UIDENT", "SEP");
|
|
Gramext.Snterm
|
|
(Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun (t : 'symbol) _ (loc : int * int) -> (t : 'e__4))])],
|
|
Gramext.action
|
|
(fun (sep : 'e__4 option) (s : 'symbol) _ (loc : int * int) ->
|
|
(let used =
|
|
match sep with
|
|
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 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,
|
|
[[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
|
|
Gramext.action
|
|
(fun _ (s_t : 'symbol) _ (loc : int * int) -> (s_t : 'symbol));
|
|
[Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e));
|
|
Gramext.Sopt
|
|
(Gramext.srules
|
|
[[Gramext.Stoken ("UIDENT", "LEVEL");
|
|
Gramext.Stoken ("STRING", "")],
|
|
Gramext.action
|
|
(fun (s : string) _ (loc : int * int) -> (s : 'e__7))])],
|
|
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)} :
|
|
'symbol));
|
|
[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ".");
|
|
Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e));
|
|
Gramext.Sopt
|
|
(Gramext.srules
|
|
[[Gramext.Stoken ("UIDENT", "LEVEL");
|
|
Gramext.Stoken ("STRING", "")],
|
|
Gramext.action
|
|
(fun (s : string) _ (loc : int * int) -> (s : 'e__6))])],
|
|
Gramext.action
|
|
(fun (lev : 'e__6 option) (e : 'qualid) _ (i : string)
|
|
(loc : int * int) ->
|
|
(let n =
|
|
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)} :
|
|
'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")} :
|
|
'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")} :
|
|
'symbol));
|
|
[Gramext.Stoken ("UIDENT", "")],
|
|
Gramext.action
|
|
(fun (x : string) (loc : int * int) ->
|
|
(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 ("", "[");
|
|
Gramext.Slist0sep
|
|
(Gramext.Snterm (Grammar.Entry.obj (rule : 'rule Grammar.Entry.e)),
|
|
Gramext.Stoken ("", "|"));
|
|
Gramext.Stoken ("", "]")],
|
|
Gramext.action
|
|
(fun _ (rl : 'rule list) _ (loc : int * int) ->
|
|
(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)} :
|
|
'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} :
|
|
'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} :
|
|
'symbol))]];
|
|
Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e), None,
|
|
[None, None,
|
|
[[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ",");
|
|
Gramext.Snterm
|
|
(Grammar.Entry.obj
|
|
(patterns_comma : 'patterns_comma Grammar.Entry.e));
|
|
Gramext.Stoken ("", ")")],
|
|
Gramext.action
|
|
(fun _ (pl : 'patterns_comma) _ (p : 'pattern) _ (loc : int * int) ->
|
|
(MLast.PaTup (loc, (p :: pl)) : 'pattern));
|
|
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
|
|
Gramext.action
|
|
(fun _ (p : 'pattern) _ (loc : int * int) -> (p : 'pattern));
|
|
[Gramext.Stoken ("", "_")],
|
|
Gramext.action
|
|
(fun _ (loc : int * int) -> (MLast.PaAny loc : 'pattern));
|
|
[Gramext.Stoken ("LIDENT", "")],
|
|
Gramext.action
|
|
(fun (i : string) (loc : int * int) ->
|
|
(MLast.PaLid (loc, i) : 'pattern))]];
|
|
Grammar.Entry.obj (patterns_comma : 'patterns_comma Grammar.Entry.e),
|
|
None,
|
|
[None, None,
|
|
[[Gramext.Sself; Gramext.Stoken ("", ",");
|
|
Gramext.Snterm
|
|
(Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun (p : 'pattern) _ (pl : 'patterns_comma) (loc : int * int) ->
|
|
(pl @ [p] : 'patterns_comma))];
|
|
None, None,
|
|
[[Gramext.Snterm
|
|
(Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun (p : 'pattern) (loc : int * int) -> ([p] : 'patterns_comma))]];
|
|
Grammar.Entry.obj (name : 'name Grammar.Entry.e), None,
|
|
[None, None,
|
|
[[Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun (e : 'qualid) (loc : int * int) -> (mk_name loc e : 'name))]];
|
|
Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e), None,
|
|
[None, None,
|
|
[[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
|
|
Gramext.action
|
|
(fun (e2 : 'qualid) _ (e1 : 'qualid) (loc : int * int) ->
|
|
(MLast.ExAcc (loc, e1, e2) : 'qualid))];
|
|
None, None,
|
|
[[Gramext.Stoken ("LIDENT", "")],
|
|
Gramext.action
|
|
(fun (i : string) (loc : int * int) ->
|
|
(MLast.ExLid (loc, i) : 'qualid));
|
|
[Gramext.Stoken ("UIDENT", "")],
|
|
Gramext.action
|
|
(fun (i : string) (loc : int * int) ->
|
|
(MLast.ExUid (loc, i) : 'qualid))]];
|
|
Grammar.Entry.obj (string : 'string Grammar.Entry.e), None,
|
|
[None, None,
|
|
[[Gramext.Stoken ("ANTIQUOT", "")],
|
|
Gramext.action
|
|
(fun (i : string) (loc : int * int) ->
|
|
(let shift = fst loc + String.length "$" in
|
|
let e =
|
|
try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string i) with
|
|
Exc_located ((bp, ep), exc) ->
|
|
raise_with_loc (shift + bp, shift + ep) exc
|
|
in
|
|
Pcaml.expr_reloc (fun (bp, ep) -> shift + bp, shift + ep) 0 e :
|
|
'string));
|
|
[Gramext.Stoken ("STRING", "")],
|
|
Gramext.action
|
|
(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";;
|