2115 lines
70 KiB
OCaml
2115 lines
70 KiB
OCaml
(* camlp4r pa_extend.cmo q_MLast.cmo *)
|
|
(***********************************************************************)
|
|
(* *)
|
|
(* Camlp4 *)
|
|
(* *)
|
|
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 2002 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 loc = Lexing.position * Lexing.position;;
|
|
|
|
type 'e name = { expr : 'e; tvar : string; loc : loc };;
|
|
|
|
type styp =
|
|
STlid of loc * string
|
|
| STapp of loc * styp * styp
|
|
| STquo of loc * string
|
|
| STself of loc * string
|
|
| STtyp of MLast.ctyp
|
|
;;
|
|
|
|
type 'e text =
|
|
TXmeta of loc * string * 'e text list * 'e * styp
|
|
| TXlist of loc * bool * 'e text * 'e text option
|
|
| TXnext of loc
|
|
| TXnterm of loc * 'e name * string option
|
|
| TXopt of loc * 'e text
|
|
| TXrules of loc * ('e text list * 'e) list
|
|
| TXself of loc
|
|
| TXtok of loc * string * 'e
|
|
;;
|
|
|
|
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 : string list; text : 'e text; styp : styp }
|
|
;;
|
|
|
|
type used =
|
|
Unused
|
|
| UsedScanned
|
|
| UsedNotScanned
|
|
;;
|
|
|
|
let mark_used modif ht n =
|
|
try
|
|
let rll = Hashtbl.find_all ht n 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 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 =
|
|
let nowhere =
|
|
{(Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0}
|
|
in
|
|
nowhere, nowhere
|
|
;;
|
|
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.ExLet
|
|
(loc, false,
|
|
[MLast.PaLid (loc, "nowhere"),
|
|
MLast.ExRec
|
|
(loc,
|
|
[MLast.PaAcc
|
|
(loc, MLast.PaUid (loc, "Lexing"),
|
|
MLast.PaLid (loc, "pos_lnum")),
|
|
MLast.ExInt (loc, "1");
|
|
MLast.PaAcc
|
|
(loc, MLast.PaUid (loc, "Lexing"),
|
|
MLast.PaLid (loc, "pos_cnum")),
|
|
MLast.ExInt (loc, "0")],
|
|
Some
|
|
(MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Lexing"),
|
|
MLast.ExLid (loc, "dummy_pos"))))],
|
|
MLast.ExTup
|
|
(loc,
|
|
[MLast.ExLid (loc, "nowhere"); MLast.ExLid (loc, "nowhere")]))
|
|
;;
|
|
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 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 expr_fa al =
|
|
function
|
|
MLast.ExApp (_, f, a) -> expr_fa (a :: al) f
|
|
| f -> f, al
|
|
;;
|
|
|
|
let rec quot_expr e =
|
|
let loc = MLast.loc_of_expr e in
|
|
match e with
|
|
MLast.ExUid (_, "None") ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Option")),
|
|
MLast.ExUid (loc, "None"))
|
|
| MLast.ExApp (_, MLast.ExUid (_, "Some"), e) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Option")),
|
|
MLast.ExApp (loc, MLast.ExUid (loc, "Some"), quot_expr e))
|
|
| MLast.ExUid (_, "False") ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Bool")),
|
|
MLast.ExUid (loc, "False"))
|
|
| MLast.ExUid (_, "True") ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Bool")),
|
|
MLast.ExUid (loc, "True"))
|
|
| MLast.ExUid (_, "()") -> e
|
|
| MLast.ExApp
|
|
(_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "List")),
|
|
_) ->
|
|
e
|
|
| MLast.ExApp
|
|
(_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "Option")),
|
|
_) ->
|
|
e
|
|
| MLast.ExApp
|
|
(_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "Str")),
|
|
_) ->
|
|
e
|
|
| MLast.ExUid (_, "[]") ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "List")),
|
|
MLast.ExUid (loc, "[]"))
|
|
| MLast.ExApp
|
|
(_, MLast.ExApp (_, MLast.ExUid (_, "::"), e), MLast.ExUid (_, "[]")) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "List")),
|
|
MLast.ExApp
|
|
(loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), quot_expr e),
|
|
MLast.ExUid (loc, "[]")))
|
|
| MLast.ExApp (_, MLast.ExApp (_, MLast.ExUid (_, "::"), e1), e2) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Cons")),
|
|
quot_expr e1),
|
|
quot_expr e2)
|
|
| MLast.ExApp (_, _, _) ->
|
|
let (f, al) = expr_fa [] e in
|
|
begin match f with
|
|
MLast.ExUid (_, c) ->
|
|
let al = List.map quot_expr al in
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
|
|
MLast.ExStr (loc, c)),
|
|
mklistexp loc al)
|
|
| MLast.ExAcc (_, MLast.ExUid (_, "MLast"), MLast.ExUid (_, c)) ->
|
|
let al = List.map quot_expr al in
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
|
|
MLast.ExStr (loc, c)),
|
|
mklistexp loc al)
|
|
| MLast.ExAcc (_, MLast.ExUid (_, m), MLast.ExUid (_, c)) ->
|
|
let al = List.map quot_expr al in
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
|
|
MLast.ExStr (loc, (m ^ "." ^ c))),
|
|
mklistexp loc al)
|
|
| MLast.ExLid (_, f) ->
|
|
let al = List.map quot_expr al in
|
|
List.fold_left (fun f e -> MLast.ExApp (loc, f, e))
|
|
(MLast.ExLid (loc, f)) al
|
|
| _ -> e
|
|
end
|
|
| MLast.ExRec (_, pel, None) ->
|
|
begin try
|
|
let lel =
|
|
List.map
|
|
(fun (p, e) ->
|
|
let lab =
|
|
match p with
|
|
MLast.PaLid (_, c) -> MLast.ExStr (loc, c)
|
|
| MLast.PaAcc (_, _, MLast.PaLid (_, c)) ->
|
|
MLast.ExStr (loc, c)
|
|
| _ -> raise Not_found
|
|
in
|
|
MLast.ExTup (loc, [lab; quot_expr e]))
|
|
pel
|
|
in
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Record")),
|
|
mklistexp loc lel)
|
|
with
|
|
Not_found -> e
|
|
end
|
|
| MLast.ExLid (_, s) ->
|
|
if s = !(Stdpp.loc_name) then
|
|
MLast.ExAcc (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Loc"))
|
|
else e
|
|
| MLast.ExAcc (_, MLast.ExUid (_, "MLast"), MLast.ExUid (_, s)) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
|
|
MLast.ExStr (loc, s)),
|
|
MLast.ExUid (loc, "[]"))
|
|
| MLast.ExAcc (_, MLast.ExUid (_, m), MLast.ExUid (_, s)) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
|
|
MLast.ExStr (loc, (m ^ "." ^ s))),
|
|
MLast.ExUid (loc, "[]"))
|
|
| MLast.ExUid (_, s) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
|
|
MLast.ExStr (loc, s)),
|
|
MLast.ExUid (loc, "[]"))
|
|
| MLast.ExStr (_, s) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Str")),
|
|
MLast.ExStr (loc, s))
|
|
| MLast.ExTup (_, el) ->
|
|
let el = List.map quot_expr el in
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Tuple")),
|
|
mklistexp loc el)
|
|
| MLast.ExLet (_, r, pel, e) ->
|
|
let pel = List.map (fun (p, e) -> p, quot_expr e) pel in
|
|
MLast.ExLet (loc, r, pel, quot_expr e)
|
|
| _ -> 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_expr act in
|
|
List.fold_left
|
|
(fun e ps ->
|
|
match ps.pattern with
|
|
Some (MLast.PaTup (_, pl)) ->
|
|
let loc =
|
|
let nowhere =
|
|
{(Lexing.dummy_pos) with Lexing.pos_lnum = 1;
|
|
Lexing.pos_cnum = 0}
|
|
in
|
|
nowhere, nowhere
|
|
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.PaAcc
|
|
(loc, MLast.PaUid (loc, "Qast"),
|
|
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 rec make_ctyp styp tvar =
|
|
match styp with
|
|
STlid (loc, s) -> MLast.TyLid (loc, s)
|
|
| STapp (loc, t1, t2) ->
|
|
MLast.TyApp (loc, make_ctyp t1 tvar, make_ctyp t2 tvar)
|
|
| STquo (loc, s) -> MLast.TyQuo (loc, s)
|
|
| STself (loc, x) ->
|
|
if tvar = "" then
|
|
Stdpp.raise_with_loc loc
|
|
(Stream.Error ("'" ^ x ^ "' illegal in anonymous entry level"))
|
|
else MLast.TyQuo (loc, tvar)
|
|
| STtyp t -> t
|
|
;;
|
|
|
|
let rec make_expr gmod tvar =
|
|
function
|
|
TXmeta (loc, n, tl, e, t) ->
|
|
let el =
|
|
List.fold_right
|
|
(fun t el ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc, MLast.ExUid (loc, "::"), make_expr gmod "" t),
|
|
el))
|
|
tl (MLast.ExUid (loc, "[]"))
|
|
in
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"),
|
|
MLast.ExUid (loc, "Smeta")),
|
|
MLast.ExStr (loc, n)),
|
|
el),
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Obj"), MLast.ExLid (loc, "repr")),
|
|
MLast.ExTyc (loc, e, make_ctyp t tvar)))
|
|
| TXlist (loc, min, t, ts) ->
|
|
let txt = make_expr gmod "" t in
|
|
begin match min, ts 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 = make_expr gmod tvar s 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 = make_expr gmod tvar s in
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"),
|
|
MLast.ExUid (loc, "Slist1sep")),
|
|
txt),
|
|
x)
|
|
end
|
|
| TXnext loc ->
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Snext"))
|
|
| TXnterm (loc, n, lev) ->
|
|
begin 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
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Sself"))
|
|
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)))))
|
|
end
|
|
| TXopt (loc, t) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Sopt")),
|
|
make_expr gmod "" t)
|
|
| TXrules (loc, rl) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"), MLast.ExLid (loc, "srules")),
|
|
make_expr_rules loc gmod rl "")
|
|
| TXself loc ->
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Sself"))
|
|
| TXtok (loc, s, e) ->
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Stoken")),
|
|
MLast.ExTup (loc, [MLast.ExStr (loc, s); e]))
|
|
and make_expr_rules loc gmod rl tvar =
|
|
List.fold_left
|
|
(fun txt (sl, ac) ->
|
|
let sl =
|
|
List.fold_right
|
|
(fun t txt ->
|
|
let x = make_expr gmod tvar t in
|
|
MLast.ExApp
|
|
(loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), x), txt))
|
|
sl (MLast.ExUid (loc, "[]"))
|
|
in
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc, MLast.ExUid (loc, "::"), MLast.ExTup (loc, [sl; ac])),
|
|
txt))
|
|
(MLast.ExUid (loc, "[]")) rl
|
|
;;
|
|
|
|
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.TyAcc
|
|
(loc, MLast.TyUid (loc, "Lexing"),
|
|
MLast.TyLid (loc, "position"));
|
|
MLast.TyAcc
|
|
(loc, MLast.TyUid (loc, "Lexing"),
|
|
MLast.TyLid (loc, "position"))])),
|
|
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 = make_ctyp 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 srules loc t rl tvar =
|
|
List.map
|
|
(fun r ->
|
|
let sl = List.map (fun ps -> ps.symbol.text) r.prod in
|
|
let ac = text_of_action loc r.prod t r.action tvar in sl, ac)
|
|
rl
|
|
;;
|
|
|
|
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, "::"), make_expr gmod "" s.text),
|
|
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 slist loc min sep symb =
|
|
let t =
|
|
match sep with
|
|
Some s -> Some s.text
|
|
| None -> None
|
|
in
|
|
TXlist (loc, min, symb.text, t)
|
|
;;
|
|
|
|
let sstoken loc s =
|
|
let n = mk_name loc (MLast.ExLid (loc, ("a_" ^ s))) in
|
|
TXnterm (loc, n, None)
|
|
;;
|
|
|
|
let mk_psymbol p s t =
|
|
let symb = {used = []; text = s; styp = t} in
|
|
{pattern = Some p; symbol = symb}
|
|
;;
|
|
|
|
let sslist loc min sep s =
|
|
let rl =
|
|
let r1 =
|
|
let prod =
|
|
let n = mk_name loc (MLast.ExLid (loc, "a_list")) in
|
|
[mk_psymbol (MLast.PaLid (loc, "a")) (TXnterm (loc, n, None))
|
|
(STquo (loc, "a_list"))]
|
|
in
|
|
let act = MLast.ExLid (loc, "a") in {prod = prod; action = Some act}
|
|
in
|
|
let r2 =
|
|
let prod =
|
|
[mk_psymbol (MLast.PaLid (loc, "a")) (slist loc min sep s)
|
|
(STapp (loc, STlid (loc, "list"), s.styp))]
|
|
in
|
|
let act =
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "List")),
|
|
MLast.ExLid (loc, "a"))
|
|
in
|
|
{prod = prod; action = Some act}
|
|
in
|
|
[r1; r2]
|
|
in
|
|
let used =
|
|
match sep with
|
|
Some symb -> symb.used @ s.used
|
|
| None -> s.used
|
|
in
|
|
let used = "a_list" :: used in
|
|
let text = TXrules (loc, srules loc "a_list" rl "") in
|
|
let styp = STquo (loc, "a_list") in {used = used; text = text; styp = styp}
|
|
;;
|
|
|
|
let ssopt loc s =
|
|
let rl =
|
|
let r1 =
|
|
let prod =
|
|
let n = mk_name loc (MLast.ExLid (loc, "a_opt")) in
|
|
[mk_psymbol (MLast.PaLid (loc, "a")) (TXnterm (loc, n, None))
|
|
(STquo (loc, "a_opt"))]
|
|
in
|
|
let act = MLast.ExLid (loc, "a") in {prod = prod; action = Some act}
|
|
in
|
|
let r2 =
|
|
let s =
|
|
match s.text with
|
|
TXtok (loc, "", MLast.ExStr (_, _)) ->
|
|
let rl =
|
|
[{prod =
|
|
[{pattern = Some (MLast.PaLid (loc, "x")); symbol = s}];
|
|
action =
|
|
Some
|
|
(MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"),
|
|
MLast.ExUid (loc, "Str")),
|
|
MLast.ExLid (loc, "x")))}]
|
|
in
|
|
let t = new_type_var () in
|
|
{used = []; text = TXrules (loc, srules loc t rl "");
|
|
styp = STquo (loc, t)}
|
|
| _ -> s
|
|
in
|
|
let prod =
|
|
[mk_psymbol (MLast.PaLid (loc, "a")) (TXopt (loc, s.text))
|
|
(STapp (loc, STlid (loc, "option"), s.styp))]
|
|
in
|
|
let act =
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Option")),
|
|
MLast.ExLid (loc, "a"))
|
|
in
|
|
{prod = prod; action = Some act}
|
|
in
|
|
[r1; r2]
|
|
in
|
|
let used = "a_opt" :: s.used in
|
|
let text = TXrules (loc, srules loc "a_opt" rl "") in
|
|
let styp = STquo (loc, "a_opt") in {used = used; text = text; styp = styp}
|
|
;;
|
|
|
|
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 = srules loc e.name.tvar level.rules e.name.tvar in
|
|
let e = make_expr_rules loc gmod rl e.name.tvar in
|
|
MLast.ExApp
|
|
(loc,
|
|
MLast.ExApp
|
|
(loc, MLast.ExUid (loc, "::"),
|
|
MLast.ExTup (loc, [lab; ass; e])),
|
|
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 =
|
|
let same_tvar e n = e.name.tvar = n.tvar in
|
|
List.fold_right
|
|
(fun e ll ->
|
|
match e.name.expr with
|
|
MLast.ExLid (_, _) ->
|
|
if List.exists (same_tvar e) nl then ll
|
|
else if List.exists (same_tvar e) ll 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 zero_loc = {(Lexing.dummy_pos) with Lexing.pos_cnum = 0};;
|
|
|
|
open Pcaml;;
|
|
let symbol = Grammar.Entry.create gram "symbol";;
|
|
let semi_sep =
|
|
if !syntax_name = "Scheme" then
|
|
Grammar.Entry.of_parser gram "'/'"
|
|
(fun (strm__ : _ Stream.t) ->
|
|
match Stream.peek strm__ with
|
|
Some ("", "/") -> Stream.junk strm__; ()
|
|
| _ -> raise Stream.Failure)
|
|
else
|
|
Grammar.Entry.of_parser gram "';'"
|
|
(fun (strm__ : _ Stream.t) ->
|
|
match Stream.peek strm__ with
|
|
Some ("", ";") -> Stream.junk strm__; ()
|
|
| _ -> raise Stream.Failure)
|
|
;;
|
|
|
|
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 : Lexing.position * Lexing.position) ->
|
|
(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 : Lexing.position * Lexing.position) ->
|
|
(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 : Lexing.position * Lexing.position) ->
|
|
(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 : Lexing.position * Lexing.position) ->
|
|
(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.Snterm
|
|
(Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun _ (e : 'entry)
|
|
(loc : Lexing.position * Lexing.position) ->
|
|
(e : 'e__1))])],
|
|
Gramext.action
|
|
(fun (el : 'e__1 list) (sl : 'global option) (f : 'efunction)
|
|
(loc : Lexing.position * Lexing.position) ->
|
|
(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.Snterm
|
|
(Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun _ (e : 'entry)
|
|
(loc : Lexing.position * Lexing.position) ->
|
|
(e : 'e__2))])],
|
|
Gramext.action
|
|
(fun (el : 'e__2 list) (sl : 'global option) (g : string)
|
|
(loc : Lexing.position * Lexing.position) ->
|
|
(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.Snterm
|
|
(Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))],
|
|
Gramext.action
|
|
(fun (sl : 'symbol list) _ (n : 'name)
|
|
(loc : Lexing.position * Lexing.position) ->
|
|
(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.Snterm
|
|
(Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))],
|
|
Gramext.action
|
|
(fun (sl : 'symbol list) _ (n : 'name) (g : string)
|
|
(loc : Lexing.position * Lexing.position) ->
|
|
(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 : Lexing.position * Lexing.position) ->
|
|
(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.Snterm
|
|
(Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun _ (f : 'qualid) _ _ (loc : Lexing.position * Lexing.position) ->
|
|
(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.Snterm
|
|
(Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun _ (sl : 'name list) _ _
|
|
(loc : Lexing.position * Lexing.position) ->
|
|
(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 : Lexing.position * Lexing.position) ->
|
|
({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 : Lexing.position * Lexing.position) ->
|
|
(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 : Lexing.position * Lexing.position) ->
|
|
(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 : Lexing.position * Lexing.position) ->
|
|
(MLast.ExApp
|
|
(loc,
|
|
MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"),
|
|
MLast.ExUid (loc, "Before")),
|
|
n) :
|
|
'position));
|
|
[Gramext.Stoken ("UIDENT", "LAST")],
|
|
Gramext.action
|
|
(fun _ (loc : Lexing.position * Lexing.position) ->
|
|
(MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Last")) :
|
|
'position));
|
|
[Gramext.Stoken ("UIDENT", "FIRST")],
|
|
Gramext.action
|
|
(fun _ (loc : Lexing.position * Lexing.position) ->
|
|
(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 : Lexing.position * Lexing.position) ->
|
|
(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 : Lexing.position * Lexing.position) ->
|
|
({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 : Lexing.position * Lexing.position) ->
|
|
(MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "NonA")) :
|
|
'assoc));
|
|
[Gramext.Stoken ("UIDENT", "RIGHTA")],
|
|
Gramext.action
|
|
(fun _ (loc : Lexing.position * Lexing.position) ->
|
|
(MLast.ExAcc
|
|
(loc, MLast.ExUid (loc, "Gramext"),
|
|
MLast.ExUid (loc, "RightA")) :
|
|
'assoc));
|
|
[Gramext.Stoken ("UIDENT", "LEFTA")],
|
|
Gramext.action
|
|
(fun _ (loc : Lexing.position * Lexing.position) ->
|
|
(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 : Lexing.position * Lexing.position) ->
|
|
(retype_rule_list_without_patterns loc rules : 'rule_list));
|
|
[Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")],
|
|
Gramext.action
|
|
(fun _ _ (loc : Lexing.position * Lexing.position) ->
|
|
([] : '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.Snterm
|
|
(Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))],
|
|
Gramext.action
|
|
(fun (psl : 'psymbol list)
|
|
(loc : Lexing.position * Lexing.position) ->
|
|
({prod = psl; action = None} : 'rule));
|
|
[Gramext.Slist0sep
|
|
(Gramext.Snterm
|
|
(Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e)),
|
|
Gramext.Snterm
|
|
(Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)));
|
|
Gramext.Stoken ("", "->");
|
|
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun (act : 'expr) _ (psl : 'psymbol list)
|
|
(loc : Lexing.position * Lexing.position) ->
|
|
({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 : Lexing.position * Lexing.position) ->
|
|
({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 : Lexing.position * Lexing.position) ->
|
|
({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 : Lexing.position * Lexing.position) ->
|
|
(s : 'e__3))])],
|
|
Gramext.action
|
|
(fun (lev : 'e__3 option) (i : string)
|
|
(loc : Lexing.position * Lexing.position) ->
|
|
(let name = mk_name loc (MLast.ExLid (loc, i)) in
|
|
let text = TXnterm (loc, name, lev) in
|
|
let styp = STquo (loc, i) in
|
|
let symb = {used = [i]; 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 : Lexing.position * Lexing.position) ->
|
|
({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 : Lexing.position * Lexing.position) ->
|
|
(if !quotify then ssopt loc s
|
|
else
|
|
let styp = STapp (loc, STlid (loc, "option"), s.styp) in
|
|
let text = TXopt (loc, s.text) 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 : Lexing.position * Lexing.position) ->
|
|
(t : 'e__5))])],
|
|
Gramext.action
|
|
(fun (sep : 'e__5 option) (s : 'symbol) _
|
|
(loc : Lexing.position * Lexing.position) ->
|
|
(if !quotify then sslist loc true sep s
|
|
else
|
|
let used =
|
|
match sep with
|
|
Some symb -> symb.used @ s.used
|
|
| None -> s.used
|
|
in
|
|
let styp = STapp (loc, STlid (loc, "list"), s.styp) in
|
|
let text = 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 : Lexing.position * Lexing.position) ->
|
|
(t : 'e__4))])],
|
|
Gramext.action
|
|
(fun (sep : 'e__4 option) (s : 'symbol) _
|
|
(loc : Lexing.position * Lexing.position) ->
|
|
(if !quotify then sslist loc false sep s
|
|
else
|
|
let used =
|
|
match sep with
|
|
Some symb -> symb.used @ s.used
|
|
| None -> s.used
|
|
in
|
|
let styp = STapp (loc, STlid (loc, "list"), s.styp) in
|
|
let text = 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 : Lexing.position * Lexing.position) ->
|
|
(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 : Lexing.position * Lexing.position) ->
|
|
(s : 'e__7))])],
|
|
Gramext.action
|
|
(fun (lev : 'e__7 option) (n : 'name)
|
|
(loc : Lexing.position * Lexing.position) ->
|
|
({used = [n.tvar]; text = TXnterm (loc, n, lev);
|
|
styp = STquo (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 : Lexing.position * Lexing.position) ->
|
|
(s : 'e__6))])],
|
|
Gramext.action
|
|
(fun (lev : 'e__6 option) (e : 'qualid) _ (i : string)
|
|
(loc : Lexing.position * Lexing.position) ->
|
|
(let n =
|
|
mk_name loc (MLast.ExAcc (loc, MLast.ExUid (loc, i), e))
|
|
in
|
|
{used = [n.tvar]; text = TXnterm (loc, n, lev);
|
|
styp = STquo (loc, n.tvar)} :
|
|
'symbol));
|
|
[Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun (e : 'string) (loc : Lexing.position * Lexing.position) ->
|
|
(let text = TXtok (loc, "", e) in
|
|
{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 : Lexing.position * Lexing.position) ->
|
|
(let text = TXtok (loc, x, e) in
|
|
{used = []; text = text; styp = STlid (loc, "string")} :
|
|
'symbol));
|
|
[Gramext.Stoken ("UIDENT", "")],
|
|
Gramext.action
|
|
(fun (x : string) (loc : Lexing.position * Lexing.position) ->
|
|
(let text =
|
|
if !quotify then sstoken loc x
|
|
else TXtok (loc, x, MLast.ExStr (loc, ""))
|
|
in
|
|
{used = []; text = text; styp = STlid (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 : Lexing.position * Lexing.position) ->
|
|
(let rl = retype_rule_list_without_patterns loc rl in
|
|
let t = new_type_var () in
|
|
{used = used_of_rule_list rl;
|
|
text = TXrules (loc, srules loc t rl "");
|
|
styp = STquo (loc, t)} :
|
|
'symbol));
|
|
[Gramext.Stoken ("UIDENT", "NEXT")],
|
|
Gramext.action
|
|
(fun _ (loc : Lexing.position * Lexing.position) ->
|
|
({used = []; text = TXnext loc; styp = STself (loc, "NEXT")} :
|
|
'symbol));
|
|
[Gramext.Stoken ("UIDENT", "SELF")],
|
|
Gramext.action
|
|
(fun _ (loc : Lexing.position * Lexing.position) ->
|
|
({used = []; text = TXself loc; styp = STself (loc, "SELF")} :
|
|
'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 : Lexing.position * Lexing.position) ->
|
|
(MLast.PaTup (loc, (p :: pl)) : 'pattern));
|
|
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
|
|
Gramext.action
|
|
(fun _ (p : 'pattern) _ (loc : Lexing.position * Lexing.position) ->
|
|
(p : 'pattern));
|
|
[Gramext.Stoken ("", "_")],
|
|
Gramext.action
|
|
(fun _ (loc : Lexing.position * Lexing.position) ->
|
|
(MLast.PaAny loc : 'pattern));
|
|
[Gramext.Stoken ("LIDENT", "")],
|
|
Gramext.action
|
|
(fun (i : string) (loc : Lexing.position * Lexing.position) ->
|
|
(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 : Lexing.position * Lexing.position) ->
|
|
(pl @ [p] : 'patterns_comma))];
|
|
None, None,
|
|
[[Gramext.Snterm
|
|
(Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e))],
|
|
Gramext.action
|
|
(fun (p : 'pattern) (loc : Lexing.position * Lexing.position) ->
|
|
([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 : Lexing.position * Lexing.position) ->
|
|
(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 : Lexing.position * Lexing.position) ->
|
|
(MLast.ExAcc (loc, e1, e2) : 'qualid))];
|
|
None, None,
|
|
[[Gramext.Stoken ("LIDENT", "")],
|
|
Gramext.action
|
|
(fun (i : string) (loc : Lexing.position * Lexing.position) ->
|
|
(MLast.ExLid (loc, i) : 'qualid));
|
|
[Gramext.Stoken ("UIDENT", "")],
|
|
Gramext.action
|
|
(fun (i : string) (loc : Lexing.position * Lexing.position) ->
|
|
(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 : Lexing.position * Lexing.position) ->
|
|
(let shift = Reloc.shift_pos (String.length "$") (fst loc) in
|
|
let e =
|
|
try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string i) with
|
|
Exc_located ((bp, ep), exc) ->
|
|
raise_with_loc (Reloc.adjust_loc shift (bp, ep)) exc
|
|
in
|
|
Pcaml.expr_reloc (fun (bp, ep) -> Reloc.adjust_loc shift (bp, ep))
|
|
zero_loc e :
|
|
'string));
|
|
[Gramext.Stoken ("STRING", "")],
|
|
Gramext.action
|
|
(fun (s : string) (loc : Lexing.position * Lexing.position) ->
|
|
(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";;
|