summaryrefslogtreecommitdiff
path: root/camlp4/meta
diff options
context:
space:
mode:
Diffstat (limited to 'camlp4/meta')
-rw-r--r--camlp4/meta/.cvsignore3
-rw-r--r--camlp4/meta/.depend16
-rw-r--r--camlp4/meta/Makefile59
-rw-r--r--camlp4/meta/Makefile.Mac50
-rw-r--r--camlp4/meta/Makefile.Mac.depend12
-rwxr-xr-xcamlp4/meta/mk_q_MLast.sh12
-rw-r--r--camlp4/meta/pa_extend.ml916
-rw-r--r--camlp4/meta/pa_extend_m.ml26
-rw-r--r--camlp4/meta/pa_ifdef.ml85
-rw-r--r--camlp4/meta/pa_macro.ml251
-rw-r--r--camlp4/meta/pa_r.ml943
-rw-r--r--camlp4/meta/pa_rp.ml318
-rw-r--r--camlp4/meta/pr_dump.ml52
-rw-r--r--camlp4/meta/q_MLast.ml1501
14 files changed, 0 insertions, 4244 deletions
diff --git a/camlp4/meta/.cvsignore b/camlp4/meta/.cvsignore
deleted file mode 100644
index 460c5a60df..0000000000
--- a/camlp4/meta/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-*.cm[oia]
-camlp4r
-camlp4r.opt
diff --git a/camlp4/meta/.depend b/camlp4/meta/.depend
deleted file mode 100644
index 737ea5ec6b..0000000000
--- a/camlp4/meta/.depend
+++ /dev/null
@@ -1,16 +0,0 @@
-pa_extend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_extend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_extend_m.cmo: pa_extend.cmo
-pa_extend_m.cmx: pa_extend.cmx
-pa_ifdef.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_ifdef.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_macro.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_macro.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_r.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_r.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_rp.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_rp.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pr_dump.cmo: ../camlp4/ast2pt.cmi $(OTOP)/utils/config.cmi ../camlp4/pcaml.cmi
-pr_dump.cmx: ../camlp4/ast2pt.cmx $(OTOP)/utils/config.cmx ../camlp4/pcaml.cmx
-q_MLast.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/quotation.cmi
-q_MLast.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/quotation.cmx
diff --git a/camlp4/meta/Makefile b/camlp4/meta/Makefile
deleted file mode 100644
index ba1481bed7..0000000000
--- a/camlp4/meta/Makefile
+++ /dev/null
@@ -1,59 +0,0 @@
-# $Id$
-
-include ../config/Makefile
-
-INCLUDES=-I ../camlp4 -I ../boot -I $(OTOP)/utils
-OCAMLCFLAGS=-warn-error A $(INCLUDES)
-OBJS=q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo pa_macro.cmo pr_dump.cmo
-OBJSX=$(OBJS:.cmo=.cmx)
-CAMLP4RM=pa_r.cmo pa_rp.cmo pr_dump.cmo
-CAMLP4RMX=$(CAMLP4RM:.cmo=.cmx)
-SHELL=/bin/sh
-COUT=$(OBJS) camlp4r$(EXE)
-COPT=$(OBJSX) camlp4r.opt
-
-all: $(COUT)
-opt: $(COPT)
-
-camlp4r$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4RM)
- rm -f camlp4r$(EXE)
- cd ../camlp4; $(MAKE) OTOP=$(OTOP) CAMLP4=../meta/camlp4r$(EXE) CAMLP4M="-I ../meta $(CAMLP4RM)"
-
-camlp4r.opt: $(CAMLP4RMX)
- rm -f camlp4r.opt
- cd ../camlp4; $(MAKE) optp4 OTOP=$(OTOP) CAMLP4OPT=../meta/camlp4r.opt CAMLP4M="-I ../meta $(CAMLP4RMX)"
-
-clean::
- rm -f *.cm* *.pp[io] *.o *.bak .*.bak $(COUT) $(COPT)
-
-depend:
- cp .depend .depend.bak
- > .depend
- @for i in *.mli *.ml; do \
- ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \
- sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \
- done
-
-promote:
- cp $(COUT) pa_extend.cmi ../boot/.
-
-compare:
- @for j in $(COUT); do \
- if cmp $$j ../boot/$$j; then :; else exit 1; fi; \
- done
-
-install:
- -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)"
- cp $(OBJS) "$(LIBDIR)/camlp4/."
- cp pa_macro.cmi pa_extend.cmi "$(LIBDIR)/camlp4/."
- cp camlp4r$(EXE) "$(BINDIR)/."
- if test -f camlp4r.opt; then \
- cp camlp4r.opt "$(BINDIR)/camlp4r.opt$(EXE)" ;\
- for target in $(OBJSX) $(OBJSX:.cmx=.$(O)) ; do \
- if test -f $$target; then \
- cp $$target "$(LIBDIR)/camlp4/."; \
- fi; \
- done; \
- fi
-
-include .depend
diff --git a/camlp4/meta/Makefile.Mac b/camlp4/meta/Makefile.Mac
deleted file mode 100644
index 9451d5222c..0000000000
--- a/camlp4/meta/Makefile.Mac
+++ /dev/null
@@ -1,50 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# $Id$
-
-INCLUDES = -I ::camlp4: -I ::boot: -I "{OTOP}utils:"
-OCAMLCFLAGS = {INCLUDES}
-OBJS = q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo ¶
- pa_ifdef.cmo pr_dump.cmo
-CAMLP4RM = pa_r.cmo pa_rp.cmo pr_dump.cmo
-OUT = {OBJS} camlp4r
-
-all Ä {OUT}
-
-camlp4r Ä ::camlp4:camlp4 {CAMLP4RM}
- delete -i camlp4r
- directory ::camlp4:
- domake -d CAMLP4=::meta:camlp4r -d CAMLP4M="-I ::meta {CAMLP4RM}"
- directory ::meta:
-
-clean ÄÄ
- delete -i {OUT}
-
-{dependrule}
-
-promote Ä
- duplicate -y {OUT} pa_extend.cmi ::boot:
-
-compare Ä
- for i in {OUT}
- equal -s {i} ::boot:{i} || exit 1
- end
-
-install Ä
- (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null
- (newfolder "{BINDIR}" || set status 0) ³ dev:null
- duplicate -y {OBJS} "{P4LIBDIR}"
- duplicate -y camlp4r "{BINDIR}"
-
-{defrules}
-
-pr_dump.cmo Ä ::camlp4:ast2pt.cmo "{OTOP}utils:config.cmi" ::camlp4:pcaml.cmi
diff --git a/camlp4/meta/Makefile.Mac.depend b/camlp4/meta/Makefile.Mac.depend
deleted file mode 100644
index 29675238e9..0000000000
--- a/camlp4/meta/Makefile.Mac.depend
+++ /dev/null
@@ -1,12 +0,0 @@
-pa_extend.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_extend.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_extend_m.cmoÄ ::camlp4:mLast.cmi pa_extend.cmo
-pa_extend_m.cmxÄ ::camlp4:mLast.cmi pa_extend.cmx
-pa_macro.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_macro.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_r.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_r.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_rp.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_rp.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-q_MLast.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:quotation.cmi
-q_MLast.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:quotation.cmx
diff --git a/camlp4/meta/mk_q_MLast.sh b/camlp4/meta/mk_q_MLast.sh
deleted file mode 100755
index c678f350ad..0000000000
--- a/camlp4/meta/mk_q_MLast.sh
+++ /dev/null
@@ -1,12 +0,0 @@
-#!/bin/sh
-# $Id$
-
-IFILE=pa_r.ml
-OFILE=q_MLast.ml
-(
-sed -e '/^EXTEND$/,$d' $OFILE
-echo EXTEND
-../../boot/ocamlrun ./camlp4r -I . -I ../etc q_MLast.cmo pa_extend.cmo pr_r.cmo pr_extend.cmo -cip -quotify $IFILE | sed -e '1,/^EXTEND$/d' -e '/^END;$/,$d'
-echo ' (* Antiquotations for local entries *)'
-sed -e '1,/Antiquotations for local entries/d' $OFILE
-)
diff --git a/camlp4/meta/pa_extend.ml b/camlp4/meta/pa_extend.ml
deleted file mode 100644
index e8fed87b62..0000000000
--- a/camlp4/meta/pa_extend.ml
+++ /dev/null
@@ -1,916 +0,0 @@
-(* 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. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Stdpp;
-
-value 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 = (int * int);
-
-type name 'e = { expr : 'e; tvar : string; loc : (int * int) };
-
-type styp =
- [ STlid of loc and string
- | STapp of loc and styp and styp
- | STquo of loc and string
- | STself of loc and string
- | STtyp of MLast.ctyp ]
-;
-
-type text 'e =
- [ TXmeta of loc and string and list (text 'e) and 'e and styp
- | TXlist of loc and bool and text 'e and option (text 'e)
- | TXnext of loc
- | TXnterm of loc and name 'e and option string
- | TXopt of loc and text 'e
- | TXrules of loc and list (list (text 'e) * 'e)
- | TXself of loc
- | TXtok of loc and string and 'e ]
-;
-
-type entry 'e 'p =
- { name : name 'e; pos : option 'e; levels : list (level 'e 'p) }
-and level 'e 'p =
- { label : option string; assoc : option 'e; rules : list (rule 'e 'p) }
-and rule 'e 'p = { prod : list (psymbol 'e 'p); action : option 'e }
-and psymbol 'e 'p = { pattern : option 'p; symbol : symbol 'e 'p }
-and symbol 'e 'p = { used : list string; text : text 'e; styp : styp }
-;
-
-type used = [ Unused | UsedScanned | UsedNotScanned ];
-
-value mark_used modif ht n =
- try
- let rll = Hashtbl.find_all ht n in
- List.iter
- (fun (r, _) ->
- if r.val == Unused then do {
- r.val := UsedNotScanned; modif.val := True;
- }
- else ())
- rll
- with
- [ Not_found -> () ]
-;
-
-value rec mark_symbol modif ht symb =
- List.iter (fun e -> mark_used modif ht e) symb.used
-;
-
-value check_use nl el =
- let ht = Hashtbl.create 301 in
- let modif = ref False in
- do {
- List.iter
- (fun e ->
- let u =
- match e.name.expr with
- [ <:expr< $lid:_$ >> -> 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.val := UsedNotScanned) rll
- with _ ->
- ())
- nl;
- modif.val := True;
- while modif.val do {
- modif.val := False;
- Hashtbl.iter
- (fun s (r, e) ->
- if r.val = UsedNotScanned then do {
- r.val := 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
- }
- else ())
- ht
- };
- Hashtbl.iter
- (fun s (r, e) ->
- if r.val = Unused then
- Pcaml.warning.val e.name.loc ("Unused local entry \"" ^ s ^ "\"")
- else ())
- ht;
- }
-;
-
-value locate n = let loc = n.loc in <:expr< $n.expr$ >>;
-
-value new_type_var =
- let i = ref 0 in fun () -> do { incr i; "e__" ^ string_of_int i.val }
-;
-
-value 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
-;
-
-value retype_rule_list_without_patterns loc rl =
- try
- List.map
- (fun
- [ {prod = [{pattern = None; symbol = s}]; action = None} ->
- {prod = [{pattern = Some <:patt< x >>; symbol = s}];
- action = Some <:expr< x >>}
- | {prod = []; action = Some _} as r -> r
- | _ -> raise Exit ])
- rl
- with
- [ Exit -> rl ]
-;
-
-value quotify = ref False;
-value meta_action = ref False;
-
-module MetaAction =
- struct
- value 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)
- ;
- value loc = (0, 0);
- value rec mlist mf =
- fun
- [ [] -> <:expr< [] >>
- | [x :: l] -> <:expr< [ $mf x$ :: $mlist mf l$ ] >> ]
- ;
- value moption mf =
- fun
- [ None -> <:expr< None >>
- | Some x -> <:expr< Some $mf x$ >> ]
- ;
- value mbool =
- fun
- [ False -> <:expr< False >>
- | True -> <:expr< True >> ]
- ;
- value mloc = <:expr< (0, 0) >>;
- value rec mexpr =
- fun
- [ MLast.ExAcc loc e1 e2 ->
- <:expr< MLast.ExAcc $mloc$ $mexpr e1$ $mexpr e2$ >>
- | MLast.ExApp loc e1 e2 ->
- <:expr< MLast.ExApp $mloc$ $mexpr e1$ $mexpr e2$ >>
- | MLast.ExChr loc s -> <:expr< MLast.ExChr $mloc$ $str:s$ >>
- | MLast.ExFun loc pwel -> <:expr< MLast.ExFun $mloc$ $mlist mpwe pwel$ >>
- | MLast.ExIfe loc e1 e2 e3 ->
- <:expr< MLast.ExIfe $mloc$ $mexpr e1$ $mexpr e2$ $mexpr e3$ >>
- | MLast.ExInt loc s -> <:expr< MLast.ExInt $mloc$ $str:s$ >>
- | MLast.ExFlo loc s -> <:expr< MLast.ExFlo $mloc$ $str:s$ >>
- | MLast.ExLet loc rf pel e ->
- <:expr< MLast.ExLet $mloc$ $mbool rf$ $mlist mpe pel$ $mexpr e$ >>
- | MLast.ExLid loc s -> <:expr< MLast.ExLid $mloc$ $str:s$ >>
- | MLast.ExMat loc e pwel ->
- <:expr< MLast.ExMat $mloc$ $mexpr e$ $mlist mpwe pwel$ >>
- | MLast.ExRec loc pel eo ->
- <:expr< MLast.ExRec $mloc$ $mlist mpe pel$ $moption mexpr eo$ >>
- | MLast.ExSeq loc el -> <:expr< MLast.ExSeq $mloc$ $mlist mexpr el$ >>
- | MLast.ExSte loc e1 e2 ->
- <:expr< MLast.ExSte $mloc$ $mexpr e1$ $mexpr e2$ >>
- | MLast.ExStr loc s ->
- <:expr< MLast.ExStr $mloc$ $str:String.escaped s$ >>
- | MLast.ExTry loc e pwel ->
- <:expr< MLast.ExTry $mloc$ $mexpr e$ $mlist mpwe pwel$ >>
- | MLast.ExTup loc el -> <:expr< MLast.ExTup $mloc$ $mlist mexpr el$ >>
- | MLast.ExTyc loc e t ->
- <:expr< MLast.ExTyc $mloc$ $mexpr e$ $mctyp t$ >>
- | MLast.ExUid loc s -> <:expr< MLast.ExUid $mloc$ $str:s$ >>
- | x -> not_impl "mexpr" x ]
- and mpatt =
- fun
- [ MLast.PaAcc loc p1 p2 ->
- <:expr< MLast.PaAcc $mloc$ $mpatt p1$ $mpatt p2$ >>
- | MLast.PaAny loc -> <:expr< MLast.PaAny $mloc$ >>
- | MLast.PaApp loc p1 p2 ->
- <:expr< MLast.PaApp $mloc$ $mpatt p1$ $mpatt p2$ >>
- | MLast.PaInt loc s -> <:expr< MLast.PaInt $mloc$ $str:s$ >>
- | MLast.PaLid loc s -> <:expr< MLast.PaLid $mloc$ $str:s$ >>
- | MLast.PaOrp loc p1 p2 ->
- <:expr< MLast.PaOrp $mloc$ $mpatt p1$ $mpatt p2$ >>
- | MLast.PaStr loc s ->
- <:expr< MLast.PaStr $mloc$ $str:String.escaped s$ >>
- | MLast.PaTup loc pl -> <:expr< MLast.PaTup $mloc$ $mlist mpatt pl$ >>
- | MLast.PaTyc loc p t ->
- <:expr< MLast.PaTyc $mloc$ $mpatt p$ $mctyp t$ >>
- | MLast.PaUid loc s -> <:expr< MLast.PaUid $mloc$ $str:s$ >>
- | x -> not_impl "mpatt" x ]
- and mctyp =
- fun
- [ MLast.TyAcc loc t1 t2 ->
- <:expr< MLast.TyAcc $mloc$ $mctyp t1$ $mctyp t2$ >>
- | MLast.TyApp loc t1 t2 ->
- <:expr< MLast.TyApp $mloc$ $mctyp t1$ $mctyp t2$ >>
- | MLast.TyLid loc s -> <:expr< MLast.TyLid $mloc$ $str:s$ >>
- | MLast.TyQuo loc s -> <:expr< MLast.TyQuo $mloc$ $str:s$ >>
- | MLast.TyTup loc tl -> <:expr< MLast.TyTup $mloc$ $mlist mctyp tl$ >>
- | MLast.TyUid loc s -> <:expr< MLast.TyUid $mloc$ $str:s$ >>
- | x -> not_impl "mctyp" x ]
- and mpe (p, e) = <:expr< ($mpatt p$, $mexpr e$) >>
- and mpwe (p, w, e) = <:expr< ($mpatt p$, $moption mexpr w$, $mexpr e$) >>
- ;
- end
-;
-
-value mklistexp loc =
- loop True where rec loop top =
- fun
- [ [] -> <:expr< [] >>
- | [e1 :: el] ->
- let loc =
- if top then loc else (fst (MLast.loc_of_expr e1), snd loc)
- in
- <:expr< [$e1$ :: $loop False el$] >> ]
-;
-
-value mklistpat loc =
- loop True where rec loop top =
- fun
- [ [] -> <:patt< [] >>
- | [p1 :: pl] ->
- let loc =
- if top then loc else (fst (MLast.loc_of_patt p1), snd loc)
- in
- <:patt< [$p1$ :: $loop False pl$] >> ]
-;
-
-value rec expr_fa al =
- fun
- [ <:expr< $f$ $a$ >> -> expr_fa [a :: al] f
- | f -> (f, al) ]
-;
-
-value rec quot_expr e =
- let loc = MLast.loc_of_expr e in
- match e with
- [ <:expr< None >> -> <:expr< Qast.Option None >>
- | <:expr< Some $e$ >> -> <:expr< Qast.Option (Some $quot_expr e$) >>
- | <:expr< False >> -> <:expr< Qast.Bool False >>
- | <:expr< True >> -> <:expr< Qast.Bool True >>
- | <:expr< () >> -> e
- | <:expr< Qast.List $_$ >> -> e
- | <:expr< Qast.Option $_$ >> -> e
- | <:expr< Qast.Str $_$ >> -> e
- | <:expr< [] >> -> <:expr< Qast.List [] >>
- | <:expr< [$e$] >> -> <:expr< Qast.List [$quot_expr e$] >>
- | <:expr< [$e1$ :: $e2$] >> ->
- <:expr< Qast.Cons $quot_expr e1$ $quot_expr e2$ >>
- | <:expr< $_$ $_$ >> ->
- let (f, al) = expr_fa [] e in
- match f with
- [ <:expr< $uid:c$ >> ->
- let al = List.map quot_expr al in
- <:expr< Qast.Node $str:c$ $mklistexp loc al$ >>
- | <:expr< MLast.$uid:c$ >> ->
- let al = List.map quot_expr al in
- <:expr< Qast.Node $str:c$ $mklistexp loc al$ >>
- | <:expr< $uid:m$.$uid:c$ >> ->
- let al = List.map quot_expr al in
- <:expr< Qast.Node $str:m ^ "." ^ c$ $mklistexp loc al$ >>
- | <:expr< $lid:f$ >> ->
- let al = List.map quot_expr al in
- List.fold_left (fun f e -> <:expr< $f$ $e$ >>)
- <:expr< $lid:f$ >> al
- | _ -> e ]
- | <:expr< {$list:pel$} >> ->
- try
- let lel =
- List.map
- (fun (p, e) ->
- let lab =
- match p with
- [ <:patt< $lid:c$ >> -> <:expr< $str:c$ >>
- | <:patt< $_$.$lid:c$ >> -> <:expr< $str:c$ >>
- | _ -> raise Not_found ]
- in
- <:expr< ($lab$, $quot_expr e$) >>)
- pel
- in
- <:expr< Qast.Record $mklistexp loc lel$>>
- with
- [ Not_found -> e ]
- | <:expr< $lid:s$ >> ->
- if s = Stdpp.loc_name.val then <:expr< Qast.Loc >> else e
- | <:expr< MLast.$uid:s$ >> -> <:expr< Qast.Node $str:s$ [] >>
- | <:expr< $uid:m$.$uid:s$ >> -> <:expr< Qast.Node $str:m ^ "." ^ s$ [] >>
- | <:expr< $uid:s$ >> -> <:expr< Qast.Node $str:s$ [] >>
- | <:expr< $str:s$ >> -> <:expr< Qast.Str $str:s$ >>
- | <:expr< ($list:el$) >> ->
- let el = List.map quot_expr el in
- <:expr< Qast.Tuple $mklistexp loc el$ >>
- | <:expr< let $opt:r$ $list:pel$ in $e$ >> ->
- let pel = List.map (fun (p, e) -> (p, quot_expr e)) pel in
- <:expr< let $opt:r$ $list:pel$ in $quot_expr e$ >>
- | _ -> e ]
-;
-
-value symgen = "xx";
-
-value pname_of_ptuple pl =
- List.fold_left
- (fun pname p ->
- match p with
- [ <:patt< $lid:s$ >> -> pname ^ s
- | _ -> pname ])
- "" pl
-;
-
-value quotify_action psl act =
- let e = quot_expr act in
- List.fold_left
- (fun e ps ->
- match ps.pattern with
- [ Some <:patt< ($list:pl$) >> ->
- let loc = (0, 0) in
- let pname = pname_of_ptuple pl in
- let (pl1, el1) =
- let (l, _) =
- List.fold_left
- (fun (l, cnt) _ ->
- ([symgen ^ string_of_int cnt :: l], cnt + 1))
- ([], 1) pl
- in
- let l = List.rev l in
- (List.map (fun s -> <:patt< $lid:s$ >>) l,
- List.map (fun s -> <:expr< $lid:s$ >>) l)
- in
- <:expr<
- let ($list:pl$) =
- match $lid:pname$ with
- [ Qast.Tuple $mklistpat loc pl1$ -> ($list:el1$)
- | _ -> match () with [] ]
- in $e$ >>
- | _ -> e ])
- e psl
-;
-
-value rec make_ctyp styp tvar =
- match styp with
- [ STlid loc s -> <:ctyp< $lid:s$ >>
- | STapp loc t1 t2 -> <:ctyp< $make_ctyp t1 tvar$ $make_ctyp t2 tvar$ >>
- | STquo loc s -> <:ctyp< '$s$ >>
- | STself loc x ->
- if tvar = "" then
- Stdpp.raise_with_loc loc
- (Stream.Error ("'" ^ x ^ "' illegal in anonymous entry level"))
- else <:ctyp< '$tvar$ >>
- | STtyp t -> t ]
-;
-
-value rec make_expr gmod tvar =
- fun
- [ TXmeta loc n tl e t ->
- let el =
- List.fold_right
- (fun t el -> <:expr< [$make_expr gmod "" t$ :: $el$] >>)
- tl <:expr< [] >>
- in
- <:expr<
- Gramext.Smeta $str:n$ $el$ (Obj.repr ($e$ : $make_ctyp t tvar$)) >>
- | TXlist loc min t ts ->
- let txt = make_expr gmod "" t in
- match (min, ts) with
- [ (False, None) -> <:expr< Gramext.Slist0 $txt$ >>
- | (True, None) -> <:expr< Gramext.Slist1 $txt$ >>
- | (False, Some s) ->
- let x = make_expr gmod tvar s in
- <:expr< Gramext.Slist0sep $txt$ $x$ >>
- | (True, Some s) ->
- let x = make_expr gmod tvar s in
- <:expr< Gramext.Slist1sep $txt$ $x$ >> ]
- | TXnext loc -> <:expr< Gramext.Snext >>
- | TXnterm loc n lev ->
- match lev with
- [ Some lab ->
- <:expr<
- Gramext.Snterml
- ($uid:gmod$.Entry.obj ($n.expr$ : $uid:gmod$.Entry.e '$n.tvar$))
- $str:lab$ >>
- | None ->
- if n.tvar = tvar then <:expr< Gramext.Sself >>
- else
- <:expr<
- Gramext.Snterm
- ($uid:gmod$.Entry.obj
- ($n.expr$ : $uid:gmod$.Entry.e '$n.tvar$)) >> ]
- | TXopt loc t -> <:expr< Gramext.Sopt $make_expr gmod "" t$ >>
- | TXrules loc rl ->
- <:expr< Gramext.srules $make_expr_rules loc gmod rl ""$ >>
- | TXself loc -> <:expr< Gramext.Sself >>
- | TXtok loc s e -> <:expr< Gramext.Stoken ($str: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
- <:expr< [$x$ :: $txt$] >>)
- sl <:expr< [] >>
- in
- <:expr< [($sl$, $ac$) :: $txt$] >>)
- <:expr< [] >> rl
-;
-
-value text_of_action loc psl rtvar act tvar =
- let locid = <:patt< $lid:Stdpp.loc_name.val$ >> in
- let act =
- match act with
- [ Some act -> if quotify.val then quotify_action psl act else act
- | None -> <:expr< () >> ]
- in
- let e = <:expr< fun [ ($locid$ : (int * int)) -> ($act$ : '$rtvar$) ] >> in
- let txt =
- List.fold_left
- (fun txt ps ->
- match ps.pattern with
- [ None -> <:expr< fun _ -> $txt$ >>
- | Some p ->
- let t = make_ctyp ps.symbol.styp tvar in
- let p =
- match p with
- [ <:patt< ($list:pl$) >> when quotify.val ->
- <:patt< $lid:pname_of_ptuple pl$ >>
- | _ -> p ]
- in
- <:expr< fun ($p$ : $t$) -> $txt$ >> ])
- e psl
- in
- let txt =
- if meta_action.val then
- <:expr< Obj.magic $MetaAction.mexpr txt$ >>
- else txt
- in
- <:expr< Gramext.action $txt$ >>
-;
-
-value 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
-;
-
-value expr_of_delete_rule loc gmod n sl =
- let sl =
- List.fold_right
- (fun s e -> <:expr< [$make_expr gmod "" s.text$ :: $e$] >>) sl
- <:expr< [] >>
- in
- (<:expr< $n.expr$ >>, sl)
-;
-
-value rec ident_of_expr =
- fun
- [ <:expr< $lid:s$ >> -> s
- | <:expr< $uid:s$ >> -> s
- | <:expr< $e1$ . $e2$ >> -> ident_of_expr e1 ^ "__" ^ ident_of_expr e2
- | _ -> failwith "internal error in pa_extend" ]
-;
-
-value mk_name loc e = {expr = e; tvar = ident_of_expr e; loc = loc};
-
-value slist loc min sep symb =
- let t =
- match sep with
- [ Some s -> Some s.text
- | None -> None ]
- in
- TXlist loc min symb.text t
-;
-
-value sstoken loc s =
- let n = mk_name loc <:expr< $lid:"a_" ^ s$ >> in
- TXnterm loc n None
-;
-
-value mk_psymbol p s t =
- let symb = {used = []; text = s; styp = t} in
- {pattern = Some p; symbol = symb}
-;
-
-value sslist loc min sep s =
- let rl =
- let r1 =
- let prod =
- let n = mk_name loc <:expr< a_list >> in
- [mk_psymbol <:patt< a >> (TXnterm loc n None) (STquo loc "a_list")]
- in
- let act = <:expr< a >> in
- {prod = prod; action = Some act}
- in
- let r2 =
- let prod =
- [mk_psymbol <:patt< a >> (slist loc min sep s)
- (STapp loc (STlid loc "list") s.styp)]
- in
- let act = <:expr< Qast.List 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}
-;
-
-value ssopt loc s =
- let rl =
- let r1 =
- let prod =
- let n = mk_name loc <:expr< a_opt >> in
- [mk_psymbol <:patt< a >> (TXnterm loc n None) (STquo loc "a_opt")]
- in
- let act = <:expr< a >> in
- {prod = prod; action = Some act}
- in
- let r2 =
- let s =
- match s.text with
- [ TXtok loc "" <:expr< $str:_$ >> ->
- let rl =
- [{prod = [{pattern = Some <:patt< x >>; symbol = s}];
- action = Some <:expr< Qast.Str 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 <:patt< a >> (TXopt loc s.text)
- (STapp loc (STlid loc "option") s.styp)]
- in
- let act = <:expr< Qast.Option 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}
-;
-
-value text_of_entry loc gmod e =
- let ent =
- let x = e.name in
- let loc = e.name.loc in
- <:expr< ($x.expr$ : $uid:gmod$.Entry.e '$x.tvar$) >>
- in
- let pos =
- match e.pos with
- [ Some pos -> <:expr< Some $pos$ >>
- | None -> <:expr< None >> ]
- in
- let txt =
- List.fold_right
- (fun level txt ->
- let lab =
- match level.label with
- [ Some lab -> <:expr< Some $str:lab$ >>
- | None -> <:expr< None >> ]
- in
- let ass =
- match level.assoc with
- [ Some ass -> <:expr< Some $ass$ >>
- | None -> <:expr< 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
- <:expr< [($lab$, $ass$, $e$) :: $txt$] >>
- in
- txt)
- e.levels <:expr< [] >>
- in
- (ent, pos, txt)
-;
-
-value let_in_of_extend loc gmod functor_version gl el args =
- match gl with
- [ Some ([n1 :: _] as nl) ->
- do {
- 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
- [ <:expr< $lid:_$ >> ->
- 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} ->
- (<:patt< _ >>, <:expr< ($e$ : $uid:gmod$.Entry.e '$x$) >>))
- nl
- in
- let locals =
- List.map
- (fun {expr = e; tvar = x; loc = loc} ->
- let i =
- match e with
- [ <:expr< $lid:i$ >> -> i
- | _ -> failwith "internal error in pa_extend" ]
- in
- (<:patt< $lid:i$ >>, <:expr<
- (grammar_entry_create $str:i$ : $uid:gmod$.Entry.e '$x$) >>))
- ll
- in
- let e =
- if ll = [] then args
- else if functor_version then
- <:expr<
- let grammar_entry_create = $uid:gmod$.Entry.create in
- let $list:locals$ in $args$ >>
- else
- <:expr<
- let grammar_entry_create s =
- $uid:gmod$.Entry.create ($uid:gmod$.of_entry $locate n1$) s
- in
- let $list:locals$ in $args$ >>
- in
- <:expr< let $list:globals$ in $e$ >>
- }
- | _ -> args ]
-;
-
-value text_of_extend loc gmod gl el f =
- if split_ext.val then
- let args =
- List.map
- (fun e ->
- let (ent, pos, txt) = text_of_entry e.name.loc gmod e in
- let ent = <:expr< $uid:gmod$.Entry.obj $ent$ >> in
- let e = <:expr< ($ent$, $pos$, $txt$) >> in
- <:expr< let aux () = $f$ [$e$] in aux () >>)
- el
- in
- let args = <:expr< do { $list: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 = <:expr< $uid:gmod$.Entry.obj $ent$ >> in
- let e = <:expr< ($ent$, $pos$, $txt$) >> in
- <:expr< [$e$ :: $el$] >>)
- el <:expr< [] >>
- in
- let args = let_in_of_extend loc gmod False gl el args in
- <:expr< $f$ $args$ >>
-;
-
-value 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 = <:expr< $uid:gmod$.extend $ent$ $pos$ $txt$ >> in
- if split_ext.val then <:expr< let aux () = $e$ in aux () >> else e)
- el
- in
- <:expr< do { $list:el$ } >>
- in
- let_in_of_extend loc gmod True gl el args
-;
-
-open Pcaml;
-value symbol = Grammar.Entry.create gram "symbol";
-value semi_sep =
- if syntax_name.val = "Scheme" then
- Grammar.Entry.of_parser gram "'/'" (parser [: `("", "/") :] -> ())
- else
- Grammar.Entry.of_parser gram "';'" (parser [: `("", ";") :] -> ())
-;
-
-EXTEND
- GLOBAL: expr symbol;
- expr: AFTER "top"
- [ [ "EXTEND"; e = extend_body; "END" -> e
- | "GEXTEND"; e = gextend_body; "END" -> e
- | "DELETE_RULE"; e = delete_rule_body; "END" -> e
- | "GDELETE_RULE"; e = gdelete_rule_body; "END" -> e ] ]
- ;
- extend_body:
- [ [ f = efunction; sl = OPT global;
- el = LIST1 [ e = entry; semi_sep -> e ] ->
- text_of_extend loc "Grammar" sl el f ] ]
- ;
- gextend_body:
- [ [ g = UIDENT; sl = OPT global; el = LIST1 [ e = entry; semi_sep -> e ] ->
- text_of_functorial_extend loc g sl el ] ]
- ;
- delete_rule_body:
- [ [ n = name; ":"; sl = LIST1 symbol SEP semi_sep ->
- let (e, b) = expr_of_delete_rule loc "Grammar" n sl in
- <:expr< Grammar.delete_rule $e$ $b$ >> ] ]
- ;
- gdelete_rule_body:
- [ [ g = UIDENT; n = name; ":"; sl = LIST1 symbol SEP semi_sep ->
- let (e, b) = expr_of_delete_rule loc g n sl in
- <:expr< $uid:g$.delete_rule $e$ $b$ >> ] ]
- ;
- efunction:
- [ [ UIDENT "FUNCTION"; ":"; f = qualid; semi_sep -> f
- | -> <:expr< Grammar.extend >> ] ]
- ;
- global:
- [ [ UIDENT "GLOBAL"; ":"; sl = LIST1 name; semi_sep -> sl ] ]
- ;
- entry:
- [ [ n = name; ":"; pos = OPT position; ll = level_list ->
- {name = n; pos = pos; levels = ll} ] ]
- ;
- position:
- [ [ UIDENT "FIRST" -> <:expr< Gramext.First >>
- | UIDENT "LAST" -> <:expr< Gramext.Last >>
- | UIDENT "BEFORE"; n = string -> <:expr< Gramext.Before $n$ >>
- | UIDENT "AFTER"; n = string -> <:expr< Gramext.After $n$ >>
- | UIDENT "LEVEL"; n = string -> <:expr< Gramext.Level $n$ >> ] ]
- ;
- level_list:
- [ [ "["; ll = LIST0 level SEP "|"; "]" -> ll ] ]
- ;
- level:
- [ [ lab = OPT STRING; ass = OPT assoc; rules = rule_list ->
- {label = lab; assoc = ass; rules = rules} ] ]
- ;
- assoc:
- [ [ UIDENT "LEFTA" -> <:expr< Gramext.LeftA >>
- | UIDENT "RIGHTA" -> <:expr< Gramext.RightA >>
- | UIDENT "NONA" -> <:expr< Gramext.NonA >> ] ]
- ;
- rule_list:
- [ [ "["; "]" -> []
- | "["; rules = LIST1 rule SEP "|"; "]" ->
- retype_rule_list_without_patterns loc rules ] ]
- ;
- rule:
- [ [ psl = LIST0 psymbol SEP semi_sep; "->"; act = expr ->
- {prod = psl; action = Some act}
- | psl = LIST0 psymbol SEP semi_sep ->
- {prod = psl; action = None} ] ]
- ;
- psymbol:
- [ [ p = LIDENT; "="; s = symbol ->
- {pattern = Some <:patt< $lid:p$ >>; symbol = s}
- | i = LIDENT; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] ->
- let name = mk_name loc <:expr< $lid: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}
- | p = pattern; "="; s = symbol -> {pattern = Some p; symbol = s}
- | s = symbol -> {pattern = None; symbol = s} ] ]
- ;
- symbol:
- [ "top" NONA
- [ UIDENT "LIST0"; s = SELF;
- sep = OPT [ UIDENT "SEP"; t = symbol -> t ] ->
- if quotify.val 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}
- | UIDENT "LIST1"; s = SELF;
- sep = OPT [ UIDENT "SEP"; t = symbol -> t ] ->
- if quotify.val 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}
- | UIDENT "OPT"; s = SELF ->
- if quotify.val 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} ]
- | [ UIDENT "SELF" ->
- {used = []; text = TXself loc; styp = STself loc "SELF"}
- | UIDENT "NEXT" ->
- {used = []; text = TXnext loc; styp = STself loc "NEXT"}
- | "["; rl = LIST0 rule SEP "|"; "]" ->
- let rl = retype_rule_list_without_patterns loc rl in
- let t = new_type_var () in
- {used = used_of_rule_list rl;
- text = TXrules loc (srules loc t rl "");
- styp = STquo loc t}
- | x = UIDENT ->
- let text =
- if quotify.val then sstoken loc x
- else TXtok loc x <:expr< "" >>
- in
- {used = []; text = text; styp = STlid loc "string"}
- | x = UIDENT; e = string ->
- let text = TXtok loc x e in
- {used = []; text = text; styp = STlid loc "string"}
- | e = string ->
- let text = TXtok loc "" e in
- {used = []; text = text; styp = STlid loc "string"}
- | i = UIDENT; "."; e = qualid;
- lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] ->
- let n = mk_name loc <:expr< $uid:i$ . $e$ >> in
- {used = [n.tvar]; text = TXnterm loc n lev;
- styp = STquo loc n.tvar}
- | n = name; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] ->
- {used = [n.tvar]; text = TXnterm loc n lev;
- styp = STquo loc n.tvar}
- | "("; s_t = SELF; ")" -> s_t ] ]
- ;
- pattern:
- [ [ i = LIDENT -> <:patt< $lid:i$ >>
- | "_" -> <:patt< _ >>
- | "("; p = SELF; ")" -> <:patt< $p$ >>
- | "("; p = SELF; ","; pl = patterns_comma; ")" ->
- <:patt< ( $list:[p :: pl]$ ) >> ] ]
- ;
- patterns_comma:
- [ [ pl = SELF; ","; p = pattern -> pl @ [p] ]
- | [ p = pattern -> [p] ] ]
- ;
- name:
- [ [ e = qualid -> mk_name loc e ] ]
- ;
- qualid:
- [ [ e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ]
- | [ i = UIDENT -> <:expr< $uid:i$ >>
- | i = LIDENT -> <:expr< $lid:i$ >> ] ]
- ;
- string:
- [ [ s = STRING -> <:expr< $str:s$ >>
- | i = ANTIQUOT ->
- 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 ] ]
- ;
-END;
-
-Pcaml.add_option "-quotify" (Arg.Set quotify)
- "Generate code for quotations";
-
-Pcaml.add_option "-meta_action" (Arg.Set meta_action)
- "Undocumented";
diff --git a/camlp4/meta/pa_extend_m.ml b/camlp4/meta/pa_extend_m.ml
deleted file mode 100644
index 7e000dd7b4..0000000000
--- a/camlp4/meta/pa_extend_m.ml
+++ /dev/null
@@ -1,26 +0,0 @@
-(* 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. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Pa_extend;
-
-EXTEND
- symbol: LEVEL "top"
- [ NONA
- [ min = [ UIDENT "SLIST0" -> False | UIDENT "SLIST1" -> True ];
- s = SELF; sep = OPT [ UIDENT "SEP"; t = symbol -> t ] ->
- sslist loc min sep s
- | UIDENT "SOPT"; s = SELF ->
- ssopt loc s ] ]
- ;
-END;
diff --git a/camlp4/meta/pa_ifdef.ml b/camlp4/meta/pa_ifdef.ml
deleted file mode 100644
index 59d448ef1b..0000000000
--- a/camlp4/meta/pa_ifdef.ml
+++ /dev/null
@@ -1,85 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(* $Id$ *)
-
-type item_or_def 'a =
- [ SdStr of 'a | SdDef of string | SdUnd of string | SdNop ]
-;
-
-value list_remove x l =
- List.fold_right (fun e l -> if e = x then l else [e :: l]) l []
-;
-
-value defined = ref ["OCAML_305"; "CAMLP4_300"; "NEWSEQ"];
-value define x = defined.val := [x :: defined.val];
-value undef x = defined.val := list_remove x defined.val;
-
-EXTEND
- GLOBAL: Pcaml.expr Pcaml.str_item Pcaml.sig_item;
- Pcaml.expr: LEVEL "top"
- [ [ "ifdef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else";
- e2 = Pcaml.expr ->
- if List.mem c defined.val then e1 else e2
- | "ifndef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else";
- e2 = Pcaml.expr ->
- if List.mem c defined.val then e2 else e1 ] ]
- ;
- Pcaml.str_item: FIRST
- [ [ x = def_undef_str ->
- match x with
- [ SdStr si -> si
- | SdDef x -> do { define x; <:str_item< declare end >> }
- | SdUnd x -> do { undef x; <:str_item< declare end >> }
- | SdNop -> <:str_item< declare end >> ] ] ]
- ;
- def_undef_str:
- [ [ "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef;
- "else"; e2 = str_item_def_undef ->
- if List.mem c defined.val then e1 else e2
- | "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef ->
- if List.mem c defined.val then e1 else SdNop
- | "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef;
- "else"; e2 = str_item_def_undef ->
- if List.mem c defined.val then e2 else e1
- | "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef ->
- if List.mem c defined.val then SdNop else e1
- | "define"; c = UIDENT -> SdDef c
- | "undef"; c = UIDENT -> SdUnd c ] ]
- ;
- str_item_def_undef:
- [ [ d = def_undef_str -> d
- | si = Pcaml.str_item -> SdStr si ] ]
- ;
- Pcaml.sig_item: FIRST
- [ [ x = def_undef_sig ->
- match x with
- [ SdStr si -> si
- | SdDef x -> do { define x; <:sig_item< declare end >> }
- | SdUnd x -> do { undef x; <:sig_item< declare end >> }
- | SdNop -> <:sig_item< declare end >> ] ] ]
- ;
- def_undef_sig:
- [ [ "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef;
- "else"; e2 = sig_item_def_undef ->
- if List.mem c defined.val then e1 else e2
- | "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef ->
- if List.mem c defined.val then e1 else SdNop
- | "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef;
- "else"; e2 = sig_item_def_undef ->
- if List.mem c defined.val then e2 else e1
- | "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef ->
- if List.mem c defined.val then SdNop else e1
- | "define"; c = UIDENT -> SdDef c
- | "undef"; c = UIDENT -> SdUnd c ] ]
- ;
- sig_item_def_undef:
- [ [ d = def_undef_sig -> d
- | si = Pcaml.sig_item -> SdStr si ] ]
- ;
-END;
-
-Pcaml.add_option "-D" (Arg.String define)
- "<string> Define for ifdef instruction."
-;
-Pcaml.add_option "-U" (Arg.String undef)
- "<string> Undefine for ifdef instruction."
-;
diff --git a/camlp4/meta/pa_macro.ml b/camlp4/meta/pa_macro.ml
deleted file mode 100644
index 406a3bd622..0000000000
--- a/camlp4/meta/pa_macro.ml
+++ /dev/null
@@ -1,251 +0,0 @@
-(* camlp4r *)
-(* $Id$ *)
-
-(*
-Added statements:
-
- At toplevel (structure item):
-
- DEFINE <uident>
- DEFINE <uident> = <expression>
- DEFINE <uident> (<parameters>) = <expression>
- IFDEF <uident> THEN <structure_items> END
- IFDEF <uident> THEN <structure_items> ELSE <structure_items> END
- IFNDEF <uident> THEN <structure_items> END
- IFNDEF <uident> THEN <structure_items> ELSE <structure_items> END
-
- In expressions:
-
- IFDEF <uident> THEN <expression> ELSE <expression> END
- IFNDEF <uident> THEN <expression> ELSE <expression> END
- __FILE__
- __LOCATION__
-
- In patterns:
-
- IFDEF <uident> THEN <pattern> ELSE <pattern> END
- IFNDEF <uident> THEN <pattern> ELSE <pattern> END
-
- As Camlp4 options:
-
- -D<uident>
- -U<uident>
-
- After having used a DEFINE <uident> followed by "= <expression>", you
- can use it in expressions *and* in patterns. If the expression defining
- the macro cannot be used as a pattern, there is an error message if
- it is used in a pattern.
-
- The expression __FILE__ returns the current compiled file name.
- The expression __LOCATION__ returns the current location of itself.
-
-*)
-
-#load "pa_extend.cmo";
-#load "q_MLast.cmo";
-
-open Pcaml;
-
-type item_or_def 'a =
- [ SdStr of 'a
- | SdDef of string and option (list string * MLast.expr)
- | SdUnd of string
- | SdNop ]
-;
-
-value rec list_remove x =
- fun
- [ [(y, _) :: l] when y = x -> l
- | [d :: l] -> [d :: list_remove x l]
- | [] -> [] ]
-;
-
-value defined = ref [];
-
-value is_defined i = List.mem_assoc i defined.val;
-
-value loc = (0, 0);
-
-value subst mloc env =
- loop where rec loop =
- fun
- [ <:expr< let $opt:rf$ $list:pel$ in $e$ >> ->
- let pel = List.map (fun (p, e) -> (p, loop e)) pel in
- <:expr< let $opt:rf$ $list:pel$ in $loop e$ >>
- | <:expr< if $e1$ then $e2$ else $e3$ >> ->
- <:expr< if $loop e1$ then $loop e2$ else $loop e3$ >>
- | <:expr< $e1$ $e2$ >> -> <:expr< $loop e1$ $loop e2$ >>
- | <:expr< $lid:x$ >> | <:expr< $uid:x$ >> as e ->
- try <:expr< $anti:List.assoc x env$ >> with
- [ Not_found -> e ]
- | <:expr< ($list:x$) >> -> <:expr< ($list:List.map loop x$) >>
- | <:expr< { $list:pel$ } >> ->
- let pel = List.map (fun (p, e) -> (p, loop e)) pel in
- <:expr< { $list:pel$ } >>
- | e -> e ]
-;
-
-value substp mloc env =
- loop where rec loop =
- fun
- [ <:expr< $e1$ $e2$ >> -> <:patt< $loop e1$ $loop e2$ >>
- | <:expr< $lid:x$ >> ->
- try <:patt< $anti:List.assoc x env$ >> with
- [ Not_found -> <:patt< $lid:x$ >> ]
- | <:expr< $uid:x$ >> ->
- try <:patt< $anti:List.assoc x env$ >> with
- [ Not_found -> <:patt< $uid:x$ >> ]
- | <:expr< $int:x$ >> -> <:patt< $int:x$ >>
- | <:expr< ($list:x$) >> -> <:patt< ($list:List.map loop x$) >>
- | <:expr< { $list:pel$ } >> ->
- let ppl = List.map (fun (p, e) -> (p, loop e)) pel in
- <:patt< { $list:ppl$ } >>
- | x ->
- Stdpp.raise_with_loc mloc
- (Failure
- "this macro cannot be used in a pattern (see its definition)") ]
-;
-
-value incorrect_number loc l1 l2 =
- Stdpp.raise_with_loc loc
- (Failure
- (Printf.sprintf "expected %d parameters; found %d"
- (List.length l2) (List.length l1)))
-;
-
-value define eo x =
- do {
- match eo with
- [ Some ([], e) ->
- EXTEND
- expr: LEVEL "simple"
- [ [ UIDENT $x$ -> Pcaml.expr_reloc (fun _ -> loc) 0 e ] ]
- ;
- patt: LEVEL "simple"
- [ [ UIDENT $x$ ->
- let p = substp loc [] e in
- Pcaml.patt_reloc (fun _ -> loc) 0 p ] ]
- ;
- END
- | Some (sl, e) ->
- EXTEND
- expr: LEVEL "apply"
- [ [ UIDENT $x$; param = SELF ->
- let el =
- match param with
- [ <:expr< ($list:el$) >> -> el
- | e -> [e] ]
- in
- if List.length el = List.length sl then
- let env = List.combine sl el in
- let e = subst loc env e in
- Pcaml.expr_reloc (fun _ -> loc) 0 e
- else
- incorrect_number loc el sl ] ]
- ;
- patt: LEVEL "simple"
- [ [ UIDENT $x$; param = SELF ->
- let pl =
- match param with
- [ <:patt< ($list:pl$) >> -> pl
- | p -> [p] ]
- in
- if List.length pl = List.length sl then
- let env = List.combine sl pl in
- let p = substp loc env e in
- Pcaml.patt_reloc (fun _ -> loc) 0 p
- else
- incorrect_number loc pl sl ] ]
- ;
- END
- | None -> () ];
- defined.val := [(x, eo) :: defined.val];
- }
-;
-
-value undef x =
- try
- do {
- let eo = List.assoc x defined.val in
- match eo with
- [ Some ([], _) ->
- do {
- DELETE_RULE expr: UIDENT $x$ END;
- DELETE_RULE patt: UIDENT $x$ END;
- }
- | Some (_, _) ->
- do {
- DELETE_RULE expr: UIDENT $x$; SELF END;
- DELETE_RULE patt: UIDENT $x$; SELF END;
- }
- | None -> () ];
- defined.val := list_remove x defined.val;
- }
- with
- [ Not_found -> () ]
-;
-
-EXTEND
- GLOBAL: expr patt str_item sig_item;
- str_item: FIRST
- [ [ x = macro_def ->
- match x with
- [ SdStr [si] -> si
- | SdStr sil -> <:str_item< declare $list:sil$ end >>
- | SdDef x eo -> do { define eo x; <:str_item< declare end >> }
- | SdUnd x -> do { undef x; <:str_item< declare end >> }
- | SdNop -> <:str_item< declare end >> ] ] ]
- ;
- macro_def:
- [ [ "DEFINE"; i = uident; def = opt_macro_value -> SdDef i def
- | "UNDEF"; i = uident -> SdUnd i
- | "IFDEF"; i = uident; "THEN"; d = str_item_or_macro; "END" ->
- if is_defined i then d else SdNop
- | "IFDEF"; i = uident; "THEN"; d1 = str_item_or_macro; "ELSE";
- d2 = str_item_or_macro; "END" ->
- if is_defined i then d1 else d2
- | "IFNDEF"; i = uident; "THEN"; d = str_item_or_macro; "END" ->
- if is_defined i then SdNop else d
- | "IFNDEF"; i = uident; "THEN"; d1 = str_item_or_macro; "ELSE";
- d2 = str_item_or_macro; "END" ->
- if is_defined i then d2 else d1 ] ]
- ;
- str_item_or_macro:
- [ [ d = macro_def -> d
- | si = LIST1 str_item -> SdStr si ] ]
- ;
- opt_macro_value:
- [ [ "("; pl = LIST1 LIDENT SEP ","; ")"; "="; e = expr -> Some (pl, e)
- | "="; e = expr -> Some ([], e)
- | -> None ] ]
- ;
- expr: LEVEL "top"
- [ [ "IFDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" ->
- if is_defined i then e1 else e2
- | "IFNDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" ->
- if is_defined i then e2 else e1 ] ]
- ;
- expr: LEVEL "simple"
- [ [ LIDENT "__FILE__" -> <:expr< $str:Pcaml.input_file.val$ >>
- | LIDENT "__LOCATION__" ->
- let bp = string_of_int (fst loc) in
- let ep = string_of_int (snd loc) in
- <:expr< ($int:bp$, $int:ep$) >> ] ]
- ;
- patt:
- [ [ "IFDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; "END" ->
- if is_defined i then p1 else p2
- | "IFNDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; "END" ->
- if is_defined i then p2 else p1 ] ]
- ;
- uident:
- [ [ i = UIDENT -> i ] ]
- ;
-END;
-
-Pcaml.add_option "-D" (Arg.String (define None))
- "<string> Define for IFDEF instruction."
-;
-Pcaml.add_option "-U" (Arg.String undef)
- "<string> Undefine for IFDEF instruction."
-;
diff --git a/camlp4/meta/pa_r.ml b/camlp4/meta/pa_r.ml
deleted file mode 100644
index dd6b499ac5..0000000000
--- a/camlp4/meta/pa_r.ml
+++ /dev/null
@@ -1,943 +0,0 @@
-(* 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. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Stdpp;
-open Pcaml;
-
-Pcaml.no_constructors_arity.val := False;
-
-value help_sequences () =
- do {
- Printf.eprintf "\
-New syntax:
- do {e1; e2; ... ; en}
- while e do {e1; e2; ... ; en}
- for v = v1 to/downto v2 do {e1; e2; ... ; en}
-Old (discouraged) syntax:
- do e1; e2; ... ; en-1; return en
- while e do e1; e2; ... ; en; done
- for v = v1 to/downto v2 do e1; e2; ... ; en; done
-To avoid compilation warning use the new syntax.
-";
- flush stderr;
- exit 1
- }
-;
-Pcaml.add_option "-help_seq" (Arg.Unit help_sequences)
- "Print explanations about new sequences and exit.";
-
-do {
- let odfa = Plexer.dollar_for_antiquotation.val in
- Plexer.dollar_for_antiquotation.val := False;
- Grammar.Unsafe.gram_reinit gram (Plexer.gmake ());
- Plexer.dollar_for_antiquotation.val := odfa;
- Grammar.Unsafe.clear_entry interf;
- Grammar.Unsafe.clear_entry implem;
- Grammar.Unsafe.clear_entry top_phrase;
- Grammar.Unsafe.clear_entry use_file;
- Grammar.Unsafe.clear_entry module_type;
- Grammar.Unsafe.clear_entry module_expr;
- Grammar.Unsafe.clear_entry sig_item;
- Grammar.Unsafe.clear_entry str_item;
- Grammar.Unsafe.clear_entry expr;
- Grammar.Unsafe.clear_entry patt;
- Grammar.Unsafe.clear_entry ctyp;
- Grammar.Unsafe.clear_entry let_binding;
- Grammar.Unsafe.clear_entry type_declaration;
- Grammar.Unsafe.clear_entry class_type;
- Grammar.Unsafe.clear_entry class_expr;
- Grammar.Unsafe.clear_entry class_sig_item;
- Grammar.Unsafe.clear_entry class_str_item
-};
-
-Pcaml.parse_interf.val := Grammar.Entry.parse interf;
-Pcaml.parse_implem.val := Grammar.Entry.parse implem;
-
-value o2b =
- fun
- [ Some _ -> True
- | None -> False ]
-;
-
-value mksequence loc =
- fun
- [ [e] -> e
- | el -> <:expr< do { $list:el$ } >> ]
-;
-
-value mkmatchcase loc p aso w e =
- let p =
- match aso with
- [ Some p2 -> <:patt< ($p$ as $p2$) >>
- | _ -> p ]
- in
- (p, w, e)
-;
-
-value neg_string n =
- let len = String.length n in
- if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1)
- else "-" ^ n
-;
-
-value mkumin loc f arg =
- match arg with
- [ <:expr< $int:n$ >> -> <:expr< $int:neg_string n$ >>
- | MLast.ExInt32 loc n -> MLast.ExInt32 loc (neg_string n)
- | MLast.ExInt64 loc n -> MLast.ExInt64 loc (neg_string n)
- | MLast.ExNativeInt loc n -> MLast.ExNativeInt loc (neg_string n)
- | <:expr< $flo:n$ >> -> <:expr< $flo:neg_string n$ >>
- | _ ->
- let f = "~" ^ f in
- <:expr< $lid:f$ $arg$ >> ]
-;
-
-value mklistexp loc last =
- loop True where rec loop top =
- fun
- [ [] ->
- match last with
- [ Some e -> e
- | None -> <:expr< [] >> ]
- | [e1 :: el] ->
- let loc =
- if top then loc else (fst (MLast.loc_of_expr e1), snd loc)
- in
- <:expr< [$e1$ :: $loop False el$] >> ]
-;
-
-value mklistpat loc last =
- loop True where rec loop top =
- fun
- [ [] ->
- match last with
- [ Some p -> p
- | None -> <:patt< [] >> ]
- | [p1 :: pl] ->
- let loc =
- if top then loc else (fst (MLast.loc_of_patt p1), snd loc)
- in
- <:patt< [$p1$ :: $loop False pl$] >> ]
-;
-
-value mkexprident loc i j =
- let rec loop m =
- fun
- [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y
- | e -> <:expr< $m$ . $e$ >> ]
- in
- loop <:expr< $uid:i$ >> j
-;
-
-value mkassert loc e =
- match e with
- [ <:expr< False >> -> MLast.ExAsf loc
- | _ -> MLast.ExAsr loc e ]
-;
-
-value append_elem el e = el @ [e];
-
-(* ...suppose to flush the input in case of syntax error to avoid multiple
- errors in case of cut-and-paste in the xterm, but work bad: for example
- the input "for x = 1;" waits for another line before displaying the
- error...
-value rec sync cs =
- match cs with parser
- [ [: `';' :] -> sync_semi cs
- | [: `_ :] -> sync cs ]
-and sync_semi cs =
- match Stream.peek cs with
- [ Some ('\010' | '\013') -> ()
- | _ -> sync cs ]
-;
-Pcaml.sync.val := sync;
-*)
-
-value ipatt = Grammar.Entry.create gram "ipatt";
-value with_constr = Grammar.Entry.create gram "with_constr";
-value row_field = Grammar.Entry.create gram "row_field";
-
-value not_yet_warned_variant = ref True;
-value warn_variant loc =
- if not_yet_warned_variant.val then do {
- not_yet_warned_variant.val := False;
- Pcaml.warning.val loc
- (Printf.sprintf
- "use of syntax of variants types deprecated since version 3.05");
- }
- else ()
-;
-
-value not_yet_warned = ref True;
-value warn_sequence loc =
- if not_yet_warned.val then do {
- not_yet_warned.val := False;
- Pcaml.warning.val loc
- ("use of syntax of sequences deprecated since version 3.01.1");
- }
- else ()
-;
-Pcaml.add_option "-no_warn_seq" (Arg.Clear not_yet_warned)
- "No warning when using old syntax for sequences.";
-
-EXTEND
- GLOBAL: sig_item str_item ctyp patt expr module_type module_expr class_type
- class_expr class_sig_item class_str_item let_binding type_declaration
- ipatt with_constr row_field;
- module_expr:
- [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->";
- me = SELF ->
- <:module_expr< functor ( $i$ : $t$ ) -> $me$ >>
- | "struct"; st = LIST0 [ s = str_item; ";" -> s ]; "end" ->
- <:module_expr< struct $list:st$ end >> ]
- | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ]
- | [ me1 = SELF; "."; me2 = SELF -> <:module_expr< $me1$ . $me2$ >> ]
- | "simple"
- [ i = UIDENT -> <:module_expr< $uid:i$ >>
- | "("; me = SELF; ":"; mt = module_type; ")" ->
- <:module_expr< ( $me$ : $mt$ ) >>
- | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ]
- ;
- str_item:
- [ "top"
- [ "declare"; st = LIST0 [ s = str_item; ";" -> s ]; "end" ->
- <:str_item< declare $list:st$ end >>
- | "exception"; (_, c, tl) = constructor_declaration; b = rebind_exn ->
- <:str_item< exception $c$ of $list:tl$ = $b$ >>
- | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING ->
- <:str_item< external $i$ : $t$ = $list:pd$ >>
- | "include"; me = module_expr -> <:str_item< include $me$ >>
- | "module"; i = UIDENT; mb = module_binding ->
- <:str_item< module $i$ = $mb$ >>
- | "module"; "rec"; nmtmes = LIST1 module_rec_binding SEP "and" ->
- MLast.StRecMod loc nmtmes
- | "module"; "type"; i = UIDENT; "="; mt = module_type ->
- <:str_item< module type $i$ = $mt$ >>
- | "open"; i = mod_ident -> <:str_item< open $i$ >>
- | "type"; tdl = LIST1 type_declaration SEP "and" ->
- <:str_item< type $list:tdl$ >>
- | "value"; r = OPT "rec"; l = LIST1 let_binding SEP "and" ->
- <:str_item< value $opt:o2b r$ $list:l$ >>
- | e = expr -> <:str_item< $exp:e$ >> ] ]
- ;
- rebind_exn:
- [ [ "="; sl = mod_ident -> sl
- | -> [] ] ]
- ;
- module_binding:
- [ RIGHTA
- [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF ->
- <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >>
- | ":"; mt = module_type; "="; me = module_expr ->
- <:module_expr< ( $me$ : $mt$ ) >>
- | "="; me = module_expr -> <:module_expr< $me$ >> ] ]
- ;
- module_rec_binding:
- [ [ m = UIDENT; ":"; mt = module_type; "="; me = module_expr ->
- (m, mt, me) ] ]
- ;
- module_type:
- [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF ->
- <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ]
- | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" ->
- <:module_type< $mt$ with $list:wcl$ >> ]
- | [ "sig"; sg = LIST0 [ s = sig_item; ";" -> s ]; "end" ->
- <:module_type< sig $list:sg$ end >> ]
- | [ m1 = SELF; m2 = SELF -> <:module_type< $m1$ $m2$ >> ]
- | [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >> ]
- | "simple"
- [ i = UIDENT -> <:module_type< $uid:i$ >>
- | i = LIDENT -> <:module_type< $lid:i$ >>
- | "'"; i = ident -> <:module_type< ' $i$ >>
- | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ]
- ;
- sig_item:
- [ "top"
- [ "declare"; st = LIST0 [ s = sig_item; ";" -> s ]; "end" ->
- <:sig_item< declare $list:st$ end >>
- | "exception"; (_, c, tl) = constructor_declaration ->
- <:sig_item< exception $c$ of $list:tl$ >>
- | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING ->
- <:sig_item< external $i$ : $t$ = $list:pd$ >>
- | "include"; mt = module_type -> <:sig_item< include $mt$ >>
- | "module"; i = UIDENT; mt = module_declaration ->
- <:sig_item< module $i$ : $mt$ >>
- | "module"; "rec"; mds = LIST1 module_rec_declaration SEP "and" ->
- MLast.SgRecMod loc mds
- | "module"; "type"; i = UIDENT; "="; mt = module_type ->
- <:sig_item< module type $i$ = $mt$ >>
- | "open"; i = mod_ident -> <:sig_item< open $i$ >>
- | "type"; tdl = LIST1 type_declaration SEP "and" ->
- <:sig_item< type $list:tdl$ >>
- | "value"; i = LIDENT; ":"; t = ctyp ->
- <:sig_item< value $i$ : $t$ >> ] ]
- ;
- module_declaration:
- [ RIGHTA
- [ ":"; mt = module_type -> <:module_type< $mt$ >>
- | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF ->
- <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ]
- ;
- module_rec_declaration:
- [ [ m = UIDENT; ":"; mt = module_type -> (m, mt)] ]
- ;
- with_constr:
- [ [ "type"; i = mod_ident; tpl = LIST0 type_parameter; "="; t = ctyp ->
- <:with_constr< type $i$ $list:tpl$ = $t$ >>
- | "module"; i = mod_ident; "="; me = module_expr ->
- <:with_constr< module $i$ = $me$ >> ] ]
- ;
- expr:
- [ "top" RIGHTA
- [ "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in";
- x = SELF ->
- <:expr< let $opt:o2b r$ $list:l$ in $x$ >>
- | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = SELF ->
- <:expr< let module $m$ = $mb$ in $e$ >>
- | "fun"; "["; l = LIST0 match_case SEP "|"; "]" ->
- <:expr< fun [ $list:l$ ] >>
- | "fun"; p = ipatt; e = fun_def -> <:expr< fun $p$ -> $e$ >>
- | "match"; e = SELF; "with"; "["; l = LIST0 match_case SEP "|"; "]" ->
- <:expr< match $e$ with [ $list:l$ ] >>
- | "match"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF ->
- <:expr< match $e$ with $p1$ -> $e1$ >>
- | "try"; e = SELF; "with"; "["; l = LIST0 match_case SEP "|"; "]" ->
- <:expr< try $e$ with [ $list:l$ ] >>
- | "try"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF ->
- <:expr< try $e$ with $p1$ -> $e1$ >>
- | "if"; e1 = SELF; "then"; e2 = SELF; "else"; e3 = SELF ->
- <:expr< if $e1$ then $e2$ else $e3$ >>
- | "do"; "{"; seq = sequence; "}" -> mksequence loc seq
- | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF;
- "do"; "{"; seq = sequence; "}" ->
- <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:seq$ } >>
- | "while"; e = SELF; "do"; "{"; seq = sequence; "}" ->
- <:expr< while $e$ do { $list:seq$ } >> ]
- | "where"
- [ e = SELF; "where"; rf = OPT "rec"; lb = let_binding ->
- <:expr< let $opt:o2b rf$ $list:[lb]$ in $e$ >> ]
- | ":=" NONA
- [ e1 = SELF; ":="; e2 = SELF; dummy -> <:expr< $e1$ := $e2$ >> ]
- | "||" RIGHTA
- [ e1 = SELF; "||"; e2 = SELF -> <:expr< $e1$ || $e2$ >> ]
- | "&&" RIGHTA
- [ e1 = SELF; "&&"; e2 = SELF -> <:expr< $e1$ && $e2$ >> ]
- | "<" LEFTA
- [ e1 = SELF; "<"; e2 = SELF -> <:expr< $e1$ < $e2$ >>
- | e1 = SELF; ">"; e2 = SELF -> <:expr< $e1$ > $e2$ >>
- | e1 = SELF; "<="; e2 = SELF -> <:expr< $e1$ <= $e2$ >>
- | e1 = SELF; ">="; e2 = SELF -> <:expr< $e1$ >= $e2$ >>
- | e1 = SELF; "="; e2 = SELF -> <:expr< $e1$ = $e2$ >>
- | e1 = SELF; "<>"; e2 = SELF -> <:expr< $e1$ <> $e2$ >>
- | e1 = SELF; "=="; e2 = SELF -> <:expr< $e1$ == $e2$ >>
- | e1 = SELF; "!="; e2 = SELF -> <:expr< $e1$ != $e2$ >> ]
- | "^" RIGHTA
- [ e1 = SELF; "^"; e2 = SELF -> <:expr< $e1$ ^ $e2$ >>
- | e1 = SELF; "@"; e2 = SELF -> <:expr< $e1$ @ $e2$ >> ]
- | "+" LEFTA
- [ e1 = SELF; "+"; e2 = SELF -> <:expr< $e1$ + $e2$ >>
- | e1 = SELF; "-"; e2 = SELF -> <:expr< $e1$ - $e2$ >>
- | e1 = SELF; "+."; e2 = SELF -> <:expr< $e1$ +. $e2$ >>
- | e1 = SELF; "-."; e2 = SELF -> <:expr< $e1$ -. $e2$ >> ]
- | "*" LEFTA
- [ e1 = SELF; "*"; e2 = SELF -> <:expr< $e1$ * $e2$ >>
- | e1 = SELF; "/"; e2 = SELF -> <:expr< $e1$ / $e2$ >>
- | e1 = SELF; "*."; e2 = SELF -> <:expr< $e1$ *. $e2$ >>
- | e1 = SELF; "/."; e2 = SELF -> <:expr< $e1$ /. $e2$ >>
- | e1 = SELF; "land"; e2 = SELF -> <:expr< $e1$ land $e2$ >>
- | e1 = SELF; "lor"; e2 = SELF -> <:expr< $e1$ lor $e2$ >>
- | e1 = SELF; "lxor"; e2 = SELF -> <:expr< $e1$ lxor $e2$ >>
- | e1 = SELF; "mod"; e2 = SELF -> <:expr< $e1$ mod $e2$ >> ]
- | "**" RIGHTA
- [ e1 = SELF; "**"; e2 = SELF -> <:expr< $e1$ ** $e2$ >>
- | e1 = SELF; "asr"; e2 = SELF -> <:expr< $e1$ asr $e2$ >>
- | e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >>
- | e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >> ]
- | "unary minus" NONA
- [ "-"; e = SELF -> mkumin loc "-" e
- | "-."; e = SELF -> mkumin loc "-." e ]
- | "apply" LEFTA
- [ e1 = SELF; e2 = SELF -> <:expr< $e1$ $e2$ >>
- | "assert"; e = SELF -> mkassert loc e
- | "lazy"; e = SELF -> <:expr< lazy ($e$) >> ]
- | "." LEFTA
- [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >>
- | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >>
- | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ]
- | "~-" NONA
- [ "~-"; e = SELF -> <:expr< ~- $e$ >>
- | "~-."; e = SELF -> <:expr< ~-. $e$ >> ]
- | "simple"
- [ s = INT -> <:expr< $int:s$ >>
- | s = INT32 -> MLast.ExInt32 loc s
- | s = INT64 -> MLast.ExInt64 loc s
- | s = NATIVEINT -> MLast.ExNativeInt loc s
- | s = FLOAT -> <:expr< $flo:s$ >>
- | s = STRING -> <:expr< $str:s$ >>
- | s = CHAR -> <:expr< $chr:s$ >>
- | i = expr_ident -> i
- | "["; "]" -> <:expr< [] >>
- | "["; el = LIST1 expr SEP ";"; last = cons_expr_opt; "]" ->
- mklistexp loc last el
- | "[|"; el = LIST0 expr SEP ";"; "|]" -> <:expr< [| $list:el$ |] >>
- | "{"; lel = LIST1 label_expr SEP ";"; "}" -> <:expr< { $list:lel$ } >>
- | "{"; "("; e = SELF; ")"; "with"; lel = LIST1 label_expr SEP ";";
- "}" ->
- <:expr< { ($e$) with $list:lel$ } >>
- | "("; ")" -> <:expr< () >>
- | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >>
- | "("; e = SELF; ","; el = LIST1 expr SEP ","; ")" ->
- <:expr< ( $list:[e::el]$) >>
- | "("; e = SELF; ")" -> <:expr< $e$ >> ] ]
- ;
- cons_expr_opt:
- [ [ "::"; e = expr -> Some e
- | -> None ] ]
- ;
- dummy:
- [ [ -> () ] ]
- ;
- sequence:
- [ [ "let"; rf = OPT "rec"; l = LIST1 let_binding SEP "and"; [ "in" | ";" ];
- el = SELF ->
- [<:expr< let $opt:o2b rf$ $list:l$ in $mksequence loc el$ >>]
- | e = expr; ";"; el = SELF -> [e :: el]
- | e = expr; ";" -> [e]
- | e = expr -> [e] ] ]
- ;
- let_binding:
- [ [ p = ipatt; e = fun_binding -> (p, e) ] ]
- ;
- fun_binding:
- [ RIGHTA
- [ p = ipatt; e = SELF -> <:expr< fun $p$ -> $e$ >>
- | "="; e = expr -> <:expr< $e$ >>
- | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ]
- ;
- match_case:
- [ [ p = patt; aso = as_patt_opt; w = when_expr_opt; "->"; e = expr ->
- mkmatchcase loc p aso w e ] ]
- ;
- as_patt_opt:
- [ [ "as"; p = patt -> Some p
- | -> None ] ]
- ;
- when_expr_opt:
- [ [ "when"; e = expr -> Some e
- | -> None ] ]
- ;
- label_expr:
- [ [ i = patt_label_ident; e = fun_binding -> (i, e) ] ]
- ;
- expr_ident:
- [ RIGHTA
- [ i = LIDENT -> <:expr< $lid:i$ >>
- | i = UIDENT -> <:expr< $uid:i$ >>
- | i = UIDENT; "."; j = SELF -> mkexprident loc i j ] ]
- ;
- fun_def:
- [ RIGHTA
- [ p = ipatt; e = SELF -> <:expr< fun $p$ -> $e$ >>
- | "->"; e = expr -> e ] ]
- ;
- patt:
- [ LEFTA
- [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ]
- | NONA
- [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ]
- | LEFTA
- [ p1 = SELF; p2 = SELF -> <:patt< $p1$ $p2$ >> ]
- | LEFTA
- [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
- | "simple"
- [ s = LIDENT -> <:patt< $lid:s$ >>
- | s = UIDENT -> <:patt< $uid:s$ >>
- | s = INT -> <:patt< $int:s$ >>
- | s = INT32 -> MLast.PaInt32 loc s
- | s = INT64 -> MLast.PaInt64 loc s
- | s = NATIVEINT -> MLast.PaNativeInt loc s
- | s = FLOAT -> <:patt< $flo:s$ >>
- | s = STRING -> <:patt< $str:s$ >>
- | s = CHAR -> <:patt< $chr:s$ >>
- | "-"; s = INT -> MLast.PaInt loc (neg_string s)
- | "-"; s = INT32 -> MLast.PaInt32 loc (neg_string s)
- | "-"; s = INT64 -> MLast.PaInt64 loc (neg_string s)
- | "-"; s = NATIVEINT -> MLast.PaNativeInt loc (neg_string s)
- | "-"; s = FLOAT -> <:patt< $flo:neg_string s$ >>
- | "["; "]" -> <:patt< [] >>
- | "["; pl = LIST1 patt SEP ";"; last = cons_patt_opt; "]" ->
- mklistpat loc last pl
- | "[|"; pl = LIST0 patt SEP ";"; "|]" -> <:patt< [| $list:pl$ |] >>
- | "{"; lpl = LIST1 label_patt SEP ";"; "}" -> <:patt< { $list:lpl$ } >>
- | "("; ")" -> <:patt< () >>
- | "("; p = SELF; ")" -> <:patt< $p$ >>
- | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
- | "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >>
- | "("; p = SELF; ","; pl = LIST1 patt SEP ","; ")" ->
- <:patt< ( $list:[p::pl]$) >>
- | "_" -> <:patt< _ >> ] ]
- ;
- cons_patt_opt:
- [ [ "::"; p = patt -> Some p
- | -> None ] ]
- ;
- label_patt:
- [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ]
- ;
- patt_label_ident:
- [ LEFTA
- [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
- | "simple" RIGHTA
- [ i = UIDENT -> <:patt< $uid:i$ >>
- | i = LIDENT -> <:patt< $lid:i$ >> ] ]
- ;
- ipatt:
- [ [ "{"; lpl = LIST1 label_ipatt SEP ";"; "}" -> <:patt< { $list:lpl$ } >>
- | "("; ")" -> <:patt< () >>
- | "("; p = SELF; ")" -> <:patt< $p$ >>
- | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
- | "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >>
- | "("; p = SELF; ","; pl = LIST1 ipatt SEP ","; ")" ->
- <:patt< ( $list:[p::pl]$) >>
- | s = LIDENT -> <:patt< $lid:s$ >>
- | "_" -> <:patt< _ >> ] ]
- ;
- label_ipatt:
- [ [ i = patt_label_ident; "="; p = ipatt -> (i, p) ] ]
- ;
- type_declaration:
- [ [ n = type_patt; tpl = LIST0 type_parameter; "="; tk = ctyp;
- cl = LIST0 constrain ->
- (n, tpl, tk, cl) ] ]
- ;
- type_patt:
- [ [ n = LIDENT -> (loc, n) ] ]
- ;
- constrain:
- [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ]
- ;
- type_parameter:
- [ [ "'"; i = ident -> (i, (False, False))
- | "+"; "'"; i = ident -> (i, (True, False))
- | "-"; "'"; i = ident -> (i, (False, True)) ] ]
- ;
- ctyp:
- [ LEFTA
- [ t1 = SELF; "=="; t2 = SELF -> <:ctyp< $t1$ == $t2$ >> ]
- | LEFTA
- [ t1 = SELF; "as"; t2 = SELF -> <:ctyp< $t1$ as $t2$ >> ]
- | LEFTA
- [ "!"; pl = LIST1 typevar; "."; t = ctyp ->
- <:ctyp< ! $list:pl$ . $t$ >> ]
- | "arrow" RIGHTA
- [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ]
- | "label" NONA
- [ i = TILDEIDENT; ":"; t = SELF -> <:ctyp< ~ $i$ : $t$ >>
- | i = LABEL; t = SELF -> <:ctyp< ~ $i$ : $t$ >>
- | i = QUESTIONIDENT; ":"; t = SELF -> <:ctyp< ? $i$ : $t$ >>
- | i = OPTLABEL; t = SELF -> <:ctyp< ? $i$ : $t$ >> ]
- | LEFTA
- [ t1 = SELF; t2 = SELF -> <:ctyp< $t1$ $t2$ >> ]
- | LEFTA
- [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >> ]
- | "simple"
- [ "'"; i = ident -> <:ctyp< '$i$ >>
- | "_" -> <:ctyp< _ >>
- | i = LIDENT -> <:ctyp< $lid:i$ >>
- | i = UIDENT -> <:ctyp< $uid:i$ >>
- | "("; t = SELF; "*"; tl = LIST1 ctyp SEP "*"; ")" ->
- <:ctyp< ( $list:[t::tl]$ ) >>
- | "("; t = SELF; ")" -> <:ctyp< $t$ >>
- | "private"; "["; cdl = LIST0 constructor_declaration SEP "|"; "]" ->
- <:ctyp< private [ $list:cdl$ ] >>
- | "private"; "{"; ldl = LIST1 label_declaration SEP ";"; "}" ->
- <:ctyp< private { $list:ldl$ } >>
- | "["; cdl = LIST0 constructor_declaration SEP "|"; "]" ->
- <:ctyp< [ $list:cdl$ ] >>
- | "{"; ldl = LIST1 label_declaration SEP ";"; "}" ->
- <:ctyp< { $list:ldl$ } >> ] ]
- ;
- constructor_declaration:
- [ [ ci = UIDENT; "of"; cal = LIST1 ctyp SEP "and" -> (loc, ci, cal)
- | ci = UIDENT -> (loc, ci, []) ] ]
- ;
- label_declaration:
- [ [ i = LIDENT; ":"; mf = OPT "mutable"; t = ctyp ->
- (loc, i, o2b mf, t) ] ]
- ;
- ident:
- [ [ i = LIDENT -> i
- | i = UIDENT -> i ] ]
- ;
- mod_ident:
- [ RIGHTA
- [ i = UIDENT -> [i]
- | i = LIDENT -> [i]
- | i = UIDENT; "."; j = SELF -> [i :: j] ] ]
- ;
- (* Objects and Classes *)
- str_item:
- [ [ "class"; cd = LIST1 class_declaration SEP "and" ->
- <:str_item< class $list:cd$ >>
- | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" ->
- <:str_item< class type $list:ctd$ >> ] ]
- ;
- sig_item:
- [ [ "class"; cd = LIST1 class_description SEP "and" ->
- <:sig_item< class $list:cd$ >>
- | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" ->
- <:sig_item< class type $list:ctd$ >> ] ]
- ;
- class_declaration:
- [ [ vf = OPT "virtual"; i = LIDENT; ctp = class_type_parameters;
- cfb = class_fun_binding ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
- MLast.ciNam = i; MLast.ciExp = cfb} ] ]
- ;
- class_fun_binding:
- [ [ "="; ce = class_expr -> ce
- | ":"; ct = class_type; "="; ce = class_expr ->
- <:class_expr< ($ce$ : $ct$) >>
- | p = ipatt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ]
- ;
- class_type_parameters:
- [ [ -> (loc, [])
- | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ]
- ;
- class_fun_def:
- [ [ p = ipatt; ce = SELF -> <:class_expr< fun $p$ -> $ce$ >>
- | "->"; ce = class_expr -> ce ] ]
- ;
- class_expr:
- [ "top"
- [ "fun"; p = ipatt; ce = class_fun_def ->
- <:class_expr< fun $p$ -> $ce$ >>
- | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in";
- ce = SELF ->
- <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ]
- | "apply" NONA
- [ ce = SELF; e = expr LEVEL "label" ->
- <:class_expr< $ce$ $e$ >> ]
- | "simple"
- [ ci = class_longident; "["; ctcl = LIST0 ctyp SEP ","; "]" ->
- <:class_expr< $list:ci$ [ $list:ctcl$ ] >>
- | ci = class_longident -> <:class_expr< $list:ci$ >>
- | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" ->
- <:class_expr< object $opt:cspo$ $list:cf$ end >>
- | "("; ce = SELF; ":"; ct = class_type; ")" ->
- <:class_expr< ($ce$ : $ct$) >>
- | "("; ce = SELF; ")" -> ce ] ]
- ;
- class_structure:
- [ [ cf = LIST0 [ cf = class_str_item; ";" -> cf ] -> cf ] ]
- ;
- class_self_patt:
- [ [ "("; p = patt; ")" -> p
- | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ]
- ;
- class_str_item:
- [ [ "declare"; st = LIST0 [ s= class_str_item; ";" -> s ]; "end" ->
- <:class_str_item< declare $list:st$ end >>
- | "inherit"; ce = class_expr; pb = OPT as_lident ->
- <:class_str_item< inherit $ce$ $opt:pb$ >>
- | "value"; mf = OPT "mutable"; lab = label; e = cvalue_binding ->
- <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
- | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp ->
- <:class_str_item< method virtual $opt:o2b pf$ $l$ : $t$ >>
- | "method"; pf = OPT "private"; l = label; topt = OPT polyt;
- e = fun_binding ->
- <:class_str_item< method $opt:o2b pf$ $l$ $opt:topt$ = $e$ >>
- | "type"; t1 = ctyp; "="; t2 = ctyp ->
- <:class_str_item< type $t1$ = $t2$ >>
- | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ]
- ;
- as_lident:
- [ [ "as"; i = LIDENT -> i ] ]
- ;
- polyt:
- [ [ ":"; t = ctyp -> t ] ]
- ;
- cvalue_binding:
- [ [ "="; e = expr -> e
- | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >>
- | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr ->
- <:expr< ($e$ : $t$ :> $t2$) >>
- | ":>"; t = ctyp; "="; e = expr -> <:expr< ($e$ :> $t$) >> ] ]
- ;
- label:
- [ [ i = LIDENT -> i ] ]
- ;
- class_type:
- [ [ "["; t = ctyp; "]"; "->"; ct = SELF ->
- <:class_type< [ $t$ ] -> $ct$ >>
- | id = clty_longident; "["; tl = LIST1 ctyp SEP ","; "]" ->
- <:class_type< $list:id$ [ $list:tl$ ] >>
- | id = clty_longident -> <:class_type< $list:id$ >>
- | "object"; cst = OPT class_self_type;
- csf = LIST0 [ csf = class_sig_item; ";" -> csf ]; "end" ->
- <:class_type< object $opt:cst$ $list:csf$ end >> ] ]
- ;
- class_self_type:
- [ [ "("; t = ctyp; ")" -> t ] ]
- ;
- class_sig_item:
- [ [ "declare"; st = LIST0 [ s = class_sig_item; ";" -> s ]; "end" ->
- <:class_sig_item< declare $list:st$ end >>
- | "inherit"; cs = class_type -> <:class_sig_item< inherit $cs$ >>
- | "value"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
- <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
- | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp ->
- <:class_sig_item< method virtual $opt:o2b pf$ $l$ : $t$ >>
- | "method"; pf = OPT "private"; l = label; ":"; t = ctyp ->
- <:class_sig_item< method $opt:o2b pf$ $l$ : $t$ >>
- | "type"; t1 = ctyp; "="; t2 = ctyp ->
- <:class_sig_item< type $t1$ = $t2$ >> ] ]
- ;
- class_description:
- [ [ vf = OPT "virtual"; n = LIDENT; ctp = class_type_parameters; ":";
- ct = class_type ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
- MLast.ciNam = n; MLast.ciExp = ct} ] ]
- ;
- class_type_declaration:
- [ [ vf = OPT "virtual"; n = LIDENT; ctp = class_type_parameters; "=";
- cs = class_type ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
- MLast.ciNam = n; MLast.ciExp = cs} ] ]
- ;
- expr: LEVEL "apply"
- [ LEFTA
- [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ]
- ;
- expr: LEVEL "."
- [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ]
- ;
- expr: LEVEL "simple"
- [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" ->
- <:expr< ($e$ : $t$ :> $t2$ ) >>
- | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >>
- | "{<"; fel = LIST0 field_expr SEP ";"; ">}" ->
- <:expr< {< $list:fel$ >} >> ] ]
- ;
- field_expr:
- [ [ l = label; "="; e = expr -> (l, e) ] ]
- ;
- ctyp: LEVEL "simple"
- [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >>
- | "<"; ml = LIST0 field SEP ";"; v = OPT ".."; ">" ->
- <:ctyp< < $list:ml$ $opt:o2b v$ > >> ] ]
- ;
- field:
- [ [ lab = LIDENT; ":"; t = ctyp -> (lab, t) ] ]
- ;
- typevar:
- [ [ "'"; i = ident -> i ] ]
- ;
- clty_longident:
- [ [ m = UIDENT; "."; l = SELF -> [m :: l]
- | i = LIDENT -> [i] ] ]
- ;
- class_longident:
- [ [ m = UIDENT; "."; l = SELF -> [m :: l]
- | i = LIDENT -> [i] ] ]
- ;
- ctyp: LEVEL "simple"
- [ [ "["; "="; rfl = row_field_list; "]" ->
- <:ctyp< [ = $list:rfl$ ] >>
- | "["; ">"; rfl = row_field_list; "]" ->
- <:ctyp< [ > $list:rfl$ ] >>
- | "["; "<"; rfl = row_field_list; "]" ->
- <:ctyp< [ < $list:rfl$ ] >>
- | "["; "<"; rfl = row_field_list; ">"; ntl = LIST1 name_tag; "]" ->
- <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ]
- ;
- row_field_list:
- [ [ rfl = LIST0 row_field SEP "|" -> rfl ] ]
- ;
- row_field:
- [ [ "`"; i = ident -> <:row_field< ` $i$ >>
- | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" ->
- <:row_field< ` $i$ of $opt:o2b ao$ $list:l$ >>
- | t = ctyp -> <:row_field< $t$ >> ] ]
- ;
- name_tag:
- [ [ "`"; i = ident -> i ] ]
- ;
- patt: LEVEL "simple"
- [ [ "`"; s = ident -> <:patt< ` $s$ >>
- | "#"; sl = mod_ident -> <:patt< # $list:sl$ >>
- | i = TILDEIDENT; ":"; p = SELF -> <:patt< ~ $i$ : $p$ >>
- | i = LABEL; p = SELF -> <:patt< ~ $i$ : $p$ >>
- | i = TILDEIDENT -> <:patt< ~ $i$ >>
- | i = QUESTIONIDENT; ":"; "("; p = patt_tcon; eo = OPT eq_expr; ")" ->
- <:patt< ? $i$ : ($p$ $opt:eo$) >>
- | i = OPTLABEL; "("; p = patt_tcon; eo = OPT eq_expr; ")" ->
- <:patt< ? $i$ : ($p$ $opt:eo$) >>
- | i = QUESTIONIDENT ->
- <:patt< ? $i$ >>
- | "?"; "("; p = patt_tcon; eo = OPT eq_expr; ")" ->
- <:patt< ? ($p$ $opt:eo$) >> ] ]
- ;
- patt_tcon:
- [ [ p = patt; ":"; t = ctyp -> <:patt< ($p$ : $t$) >>
- | p = patt -> p ] ]
- ;
- ipatt:
- [ [ i = TILDEIDENT; ":"; p = SELF -> <:patt< ~ $i$ : $p$ >>
- | i = LABEL; p = SELF -> <:patt< ~ $i$ : $p$ >>
- | i = TILDEIDENT -> <:patt< ~ $i$ >>
- | i = QUESTIONIDENT; ":"; "("; p = ipatt_tcon; eo = OPT eq_expr; ")" ->
- <:patt< ? $i$ : ($p$ $opt:eo$) >>
- | i = OPTLABEL; "("; p = ipatt_tcon; eo = OPT eq_expr; ")" ->
- <:patt< ? $i$ : ($p$ $opt:eo$) >>
- | i = QUESTIONIDENT ->
- <:patt< ? $i$ >>
- | "?"; "("; p = ipatt_tcon; eo = OPT eq_expr; ")" ->
- <:patt< ? ($p$ $opt:eo$) >> ] ]
- ;
- ipatt_tcon:
- [ [ p = ipatt; ":"; t = ctyp -> <:patt< ($p$ : $t$) >>
- | p = ipatt -> p ] ]
- ;
- eq_expr:
- [ [ "="; e = expr -> e ] ]
- ;
- expr: AFTER "apply"
- [ "label" NONA
- [ i = TILDEIDENT; ":"; e = SELF -> <:expr< ~ $i$ : $e$ >>
- | i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >>
- | i = TILDEIDENT -> <:expr< ~ $i$ >>
- | i = QUESTIONIDENT; ":"; e = SELF -> <:expr< ? $i$ : $e$ >>
- | i = OPTLABEL; e = SELF -> <:expr< ? $i$ : $e$ >>
- | i = QUESTIONIDENT -> <:expr< ? $i$ >> ] ]
- ;
- expr: LEVEL "simple"
- [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ]
- ;
- direction_flag:
- [ [ "to" -> True
- | "downto" -> False ] ]
- ;
- (* Compatibility old syntax of variant types definitions *)
- ctyp: LEVEL "simple"
- [ [ "[|"; warning_variant; rfl = row_field_list; "|]" ->
- <:ctyp< [ = $list:rfl$ ] >>
- | "[|"; warning_variant; ">"; rfl = row_field_list; "|]" ->
- <:ctyp< [ > $list:rfl$ ] >>
- | "[|"; warning_variant; "<"; rfl = row_field_list; "|]" ->
- <:ctyp< [ < $list:rfl$ ] >>
- | "[|"; warning_variant; "<"; rfl = row_field_list; ">";
- ntl = LIST1 name_tag; "|]" ->
- <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ]
- ;
- warning_variant:
- [ [ -> warn_variant loc ] ]
- ;
- (* Compatibility old syntax of sequences *)
- expr: LEVEL "top"
- [ [ "do"; seq = LIST0 [ e = expr; ";" -> e ]; "return"; warning_sequence;
- e = SELF ->
- <:expr< do { $list:append_elem seq e$ } >>
- | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF;
- "do"; seq = LIST0 [ e = expr; ";" -> e ]; warning_sequence; "done" ->
- <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:seq$ } >>
- | "while"; e = SELF; "do"; seq = LIST0 [ e = expr; ";" -> e ];
- warning_sequence; "done" ->
- <:expr< while $e$ do { $list:seq$ } >> ] ]
- ;
- warning_sequence:
- [ [ -> warn_sequence loc ] ]
- ;
-END;
-
-EXTEND
- GLOBAL: interf implem use_file top_phrase expr patt;
- interf:
- [ [ "#"; n = LIDENT; dp = OPT expr; ";" ->
- ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True)
- | si = sig_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
- | EOI -> ([], False) ] ]
- ;
- sig_item_semi:
- [ [ si = sig_item; ";" -> (si, loc) ] ]
- ;
- implem:
- [ [ "#"; n = LIDENT; dp = OPT expr; ";" ->
- ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True)
- | si = str_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
- | EOI -> ([], False) ] ]
- ;
- str_item_semi:
- [ [ si = str_item; ";" -> (si, loc) ] ]
- ;
- top_phrase:
- [ [ ph = phrase -> Some ph
- | EOI -> None ] ]
- ;
- use_file:
- [ [ "#"; n = LIDENT; dp = OPT expr; ";" ->
- ([<:str_item< # $n$ $opt:dp$ >>], True)
- | si = str_item; ";"; (sil, stopped) = SELF -> ([si :: sil], stopped)
- | EOI -> ([], False) ] ]
- ;
- phrase:
- [ [ "#"; n = LIDENT; dp = OPT expr; ";" ->
- <:str_item< # $n$ $opt:dp$ >>
- | sti = str_item; ";" -> sti ] ]
- ;
- expr: LEVEL "simple"
- [ [ x = LOCATE ->
- let x =
- try
- let i = String.index x ':' in
- (int_of_string (String.sub x 0 i),
- String.sub x (i + 1) (String.length x - i - 1))
- with
- [ Not_found | Failure _ -> (0, x) ]
- in
- Pcaml.handle_expr_locate loc x
- | x = QUOTATION ->
- let x =
- try
- let i = String.index x ':' in
- (String.sub x 0 i,
- String.sub x (i + 1) (String.length x - i - 1))
- with
- [ Not_found -> ("", x) ]
- in
- Pcaml.handle_expr_quotation loc x ] ]
- ;
- patt: LEVEL "simple"
- [ [ x = LOCATE ->
- let x =
- try
- let i = String.index x ':' in
- (int_of_string (String.sub x 0 i),
- String.sub x (i + 1) (String.length x - i - 1))
- with
- [ Not_found | Failure _ -> (0, x) ]
- in
- Pcaml.handle_patt_locate loc x
- | x = QUOTATION ->
- let x =
- try
- let i = String.index x ':' in
- (String.sub x 0 i,
- String.sub x (i + 1) (String.length x - i - 1))
- with
- [ Not_found -> ("", x) ]
- in
- Pcaml.handle_patt_quotation loc x ] ]
- ;
-END;
diff --git a/camlp4/meta/pa_rp.ml b/camlp4/meta/pa_rp.ml
deleted file mode 100644
index cb3566cd3e..0000000000
--- a/camlp4/meta/pa_rp.ml
+++ /dev/null
@@ -1,318 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Pcaml;
-
-type spat_comp =
- [ SpTrm of MLast.loc and MLast.patt and option MLast.expr
- | SpNtr of MLast.loc and MLast.patt and MLast.expr
- | SpStr of MLast.loc and MLast.patt ]
-;
-type sexp_comp =
- [ SeTrm of MLast.loc and MLast.expr | SeNtr of MLast.loc and MLast.expr ]
-;
-
-value strm_n = "strm__";
-value peek_fun loc = <:expr< Stream.peek >>;
-value junk_fun loc = <:expr< Stream.junk >>;
-
-(* Parsers. *)
-(* In syntax generated, many cases are optimisations. *)
-
-value rec pattern_eq_expression p e =
- match (p, e) with
- [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b
- | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b
- | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) ->
- pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2
- | _ -> False ]
-;
-
-value is_raise e =
- match e with
- [ <:expr< raise $_$ >> -> True
- | _ -> False ]
-;
-
-value is_raise_failure e =
- match e with
- [ <:expr< raise Stream.Failure >> -> True
- | _ -> False ]
-;
-
-value rec handle_failure e =
- match e with
- [ <:expr< try $te$ with [ Stream.Failure -> $e$] >> -> handle_failure e
- | <:expr< match $me$ with [ $list:pel$ ] >> ->
- handle_failure me &&
- List.for_all
- (fun
- [ (_, None, e) -> handle_failure e
- | _ -> False ])
- pel
- | <:expr< let $list:pel$ in $e$ >> ->
- List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e
- | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> |
- <:expr< $chr:_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< $uid:_$ >> ->
- True
- | <:expr< raise $e$ >> ->
- match e with
- [ <:expr< Stream.Failure >> -> False
- | _ -> True ]
- | <:expr< $f$ $x$ >> ->
- is_constr_apply f && handle_failure f && handle_failure x
- | _ -> False ]
-and is_constr_apply =
- fun
- [ <:expr< $uid:_$ >> -> True
- | <:expr< $lid:_$ >> -> False
- | <:expr< $x$ $_$ >> -> is_constr_apply x
- | _ -> False ]
-;
-
-value rec subst v e =
- let loc = MLast.loc_of_expr e in
- match e with
- [ <:expr< $lid:x$ >> ->
- let x = if x = v then strm_n else x in <:expr< $lid:x$ >>
- | <:expr< $uid:_$ >> -> e
- | <:expr< $int:_$ >> -> e
- | <:expr< $chr:_$ >> -> e
- | <:expr< $str:_$ >> -> e
- | <:expr< $_$.$_$ >> -> e
- | <:expr< let $opt:rf$ $list:pel$ in $e$ >> ->
- <:expr< let $opt:rf$ $list:List.map (subst_pe v) pel$ in $subst v e$ >>
- | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >>
- | <:expr< ( $list:el$ ) >> -> <:expr< ( $list:List.map (subst v) el$ ) >>
- | _ -> raise Not_found ]
-and subst_pe v (p, e) =
- match p with
- [ <:patt< $lid:v'$ >> when v <> v' -> (p, subst v e)
- | _ -> raise Not_found ]
-;
-
-value stream_pattern_component skont ckont =
- fun
- [ SpTrm loc p wo ->
- <:expr< match $peek_fun loc$ $lid:strm_n$ with
- [ Some $p$ $when:wo$ ->
- do { $junk_fun loc$ $lid:strm_n$; $skont$ }
- | _ -> $ckont$ ] >>
- | SpNtr loc p e ->
- let e =
- match e with
- [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> e
- | _ -> <:expr< $e$ $lid:strm_n$ >> ]
- in
- if pattern_eq_expression p skont then
- if is_raise_failure ckont then e
- else if handle_failure e then e
- else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >>
- else if is_raise_failure ckont then <:expr< let $p$ = $e$ in $skont$ >>
- else if pattern_eq_expression <:patt< Some $p$ >> skont then
- <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >>
- else if is_raise ckont then
- let tst =
- if handle_failure e then e
- else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >>
- in
- <:expr< let $p$ = $tst$ in $skont$ >>
- else
- <:expr< match try Some $e$ with [ Stream.Failure -> None ] with
- [ Some $p$ -> $skont$
- | _ -> $ckont$ ] >>
- | SpStr loc p ->
- try
- match p with
- [ <:patt< $lid:v$ >> -> subst v skont
- | _ -> raise Not_found ]
- with
- [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ]
-;
-
-value rec stream_pattern loc epo e ekont =
- fun
- [ [] ->
- match epo with
- [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >>
- | _ -> e ]
- | [(spc, err) :: spcl] ->
- let skont =
- let ekont err =
- let str =
- match err with
- [ Some estr -> estr
- | _ -> <:expr< "" >> ]
- in
- <:expr< raise (Stream.Error $str$) >>
- in
- stream_pattern loc epo e ekont spcl
- in
- let ckont = ekont err in stream_pattern_component skont ckont spc ]
-;
-
-value stream_patterns_term loc ekont tspel =
- let pel =
- List.map
- (fun (p, w, loc, spcl, epo, e) ->
- let p = <:patt< Some $p$ >> in
- let e =
- let ekont err =
- let str =
- match err with
- [ Some estr -> estr
- | _ -> <:expr< "" >> ]
- in
- <:expr< raise (Stream.Error $str$) >>
- in
- let skont = stream_pattern loc epo e ekont spcl in
- <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >>
- in
- (p, w, e))
- tspel
- in
- let pel = pel @ [(<:patt< _ >>, None, ekont ())] in
- <:expr< match $peek_fun loc$ $lid:strm_n$ with [ $list:pel$ ] >>
-;
-
-value rec group_terms =
- fun
- [ [([(SpTrm loc p w, None) :: spcl], epo, e) :: spel] ->
- let (tspel, spel) = group_terms spel in
- ([(p, w, loc, spcl, epo, e) :: tspel], spel)
- | spel -> ([], spel) ]
-;
-
-value rec parser_cases loc =
- fun
- [ [] -> <:expr< raise Stream.Failure >>
- | spel ->
- match group_terms spel with
- [ ([], [(spcl, epo, e) :: spel]) ->
- stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl
- | (tspel, spel) ->
- stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel ] ]
-;
-
-value cparser loc bpo pc =
- let e = parser_cases loc pc in
- let e =
- match bpo with
- [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >>
- | None -> e ]
- in
- let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in <:expr< fun $p$ -> $e$ >>
-;
-
-value cparser_match loc me bpo pc =
- let pc = parser_cases loc pc in
- let e =
- match bpo with
- [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
- | None -> pc ]
- in
- match me with
- [ <:expr< $lid:x$ >> when x = strm_n -> e
- | _ -> <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> ]
-;
-
-(* streams *)
-
-value rec not_computing =
- fun
- [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> |
- <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> ->
- True
- | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y
- | _ -> False ]
-and is_cons_apply_not_computing =
- fun
- [ <:expr< $uid:_$ >> -> True
- | <:expr< $lid:_$ >> -> False
- | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y
- | _ -> False ]
-;
-
-value slazy loc e =
- match e with
- [ <:expr< $f$ () >> ->
- match f with
- [ <:expr< $lid:_$ >> -> f
- | _ -> <:expr< fun _ -> $e$ >> ]
- | _ -> <:expr< fun _ -> $e$ >> ]
-;
-
-value rec cstream gloc =
- fun
- [ [] -> let loc = gloc in <:expr< Stream.sempty >>
- | [SeTrm loc e] ->
- if not_computing e then <:expr< Stream.ising $e$ >>
- else <:expr< Stream.lsing $slazy loc e$ >>
- | [SeTrm loc e :: secl] ->
- if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >>
- else <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >>
- | [SeNtr loc e] ->
- if not_computing e then e else <:expr< Stream.slazy $slazy loc e$ >>
- | [SeNtr loc e :: secl] ->
- if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >>
- else <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ]
-;
-
-(* Syntax extensions in Revised Syntax grammar *)
-
-EXTEND
- GLOBAL: expr;
- expr: LEVEL "top"
- [ [ "parser"; po = OPT ipatt; "["; pcl = LIST0 parser_case SEP "|"; "]" ->
- <:expr< $cparser loc po pcl$ >>
- | "parser"; po = OPT ipatt; pc = parser_case ->
- <:expr< $cparser loc po [pc]$ >>
- | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; "[";
- pcl = LIST0 parser_case SEP "|"; "]" ->
- <:expr< $cparser_match loc e po pcl$ >>
- | "match"; e = SELF; "with"; "parser"; po = OPT ipatt;
- pc = parser_case ->
- <:expr< $cparser_match loc e po [pc]$ >> ] ]
- ;
- parser_case:
- [ [ "[:"; sp = stream_patt; ":]"; po = OPT ipatt; "->"; e = expr ->
- (sp, po, e) ] ]
- ;
- stream_patt:
- [ [ spc = stream_patt_comp -> [(spc, None)]
- | spc = stream_patt_comp; ";";
- sp = LIST1 stream_patt_comp_err SEP ";" ->
- [(spc, None) :: sp]
- | -> [] ] ]
- ;
- stream_patt_comp_err:
- [ [ spc = stream_patt_comp; eo = OPT [ "?"; e = expr -> e ] ->
- (spc, eo) ] ]
- ;
- stream_patt_comp:
- [ [ "`"; p = patt; eo = OPT [ "when"; e = expr -> e ] -> SpTrm loc p eo
- | p = patt; "="; e = expr -> SpNtr loc p e
- | p = patt -> SpStr loc p ] ]
- ;
- ipatt:
- [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ]
- ;
- expr: LEVEL "simple"
- [ [ "[:"; se = LIST0 stream_expr_comp SEP ";"; ":]" ->
- <:expr< $cstream loc se$ >> ] ]
- ;
- stream_expr_comp:
- [ [ "`"; e = expr -> SeTrm loc e | e = expr -> SeNtr loc e ] ]
- ;
-END;
diff --git a/camlp4/meta/pr_dump.ml b/camlp4/meta/pr_dump.ml
deleted file mode 100644
index 2558c5fa93..0000000000
--- a/camlp4/meta/pr_dump.ml
+++ /dev/null
@@ -1,52 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-value open_out_file () =
- match Pcaml.output_file.val with
- [ Some f -> open_out_bin f
- | None -> do { set_binary_mode_out stdout True; stdout } ]
-;
-
-value interf ast =
- let pt = Ast2pt.interf (List.map fst ast) in
- let oc = open_out_file () in
- let fname = Pcaml.input_file.val in
- do {
- output_string oc Config.ast_intf_magic_number;
- output_value oc (if fname = "-" then "" else fname);
- output_value oc pt;
- flush oc;
- match Pcaml.output_file.val with
- [ Some _ -> close_out oc
- | None -> () ]
- }
-;
-
-value implem ast =
- let pt = Ast2pt.implem (List.map fst ast) in
- let oc = open_out_file () in
- let fname = Pcaml.input_file.val in
- do {
- output_string oc Config.ast_impl_magic_number;
- output_value oc (if fname = "-" then "" else fname);
- output_value oc pt;
- flush oc;
- match Pcaml.output_file.val with
- [ Some _ -> close_out oc
- | None -> () ]
- }
-;
-
-Pcaml.print_interf.val := interf;
-Pcaml.print_implem.val := implem;
diff --git a/camlp4/meta/q_MLast.ml b/camlp4/meta/q_MLast.ml
deleted file mode 100644
index c10ad7980c..0000000000
--- a/camlp4/meta/q_MLast.ml
+++ /dev/null
@@ -1,1501 +0,0 @@
-(* camlp4r pa_extend.cmo pa_extend_m.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. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-value gram = Grammar.gcreate (Plexer.gmake ());
-
-module Qast =
- struct
- type t =
- [ Node of string and list t
- | List of list t
- | Tuple of list t
- | Option of option t
- | Int of string
- | Str of string
- | Bool of bool
- | Cons of t and t
- | Apply of string and list t
- | Record of list (string * t)
- | Loc
- | Antiquot of MLast.loc and string ]
- ;
- value loc = (0, 0);
- value rec to_expr =
- fun
- [ Node n al ->
- List.fold_left (fun e a -> <:expr< $e$ $to_expr a$ >>)
- <:expr< MLast.$uid:n$ >> al
- | List al ->
- List.fold_right (fun a e -> <:expr< [$to_expr a$ :: $e$] >>) al
- <:expr< [] >>
- | Tuple al -> <:expr< ($list:List.map to_expr al$) >>
- | Option None -> <:expr< None >>
- | Option (Some a) -> <:expr< Some $to_expr a$ >>
- | Int s -> <:expr< $int:s$ >>
- | Str s -> <:expr< $str:s$ >>
- | Bool True -> <:expr< True >>
- | Bool False -> <:expr< False >>
- | Cons a1 a2 -> <:expr< [$to_expr a1$ :: $to_expr a2$] >>
- | Apply f al ->
- List.fold_left (fun e a -> <:expr< $e$ $to_expr a$ >>)
- <:expr< $lid:f$ >> al
- | Record lal -> <:expr< {$list:List.map to_expr_label lal$} >>
- | Loc -> <:expr< $lid:Stdpp.loc_name.val$ >>
- | Antiquot loc s ->
- let e =
- try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string s) with
- [ Stdpp.Exc_located (bp, ep) exc ->
- raise (Stdpp.Exc_located (fst loc + bp, fst loc + ep) exc) ]
- in
- <:expr< $anti:e$ >> ]
- and to_expr_label (l, a) = (<:patt< MLast.$lid:l$ >>, to_expr a);
- value rec to_patt =
- fun
- [ Node n al ->
- List.fold_left (fun e a -> <:patt< $e$ $to_patt a$ >>)
- <:patt< MLast.$uid:n$ >> al
- | List al ->
- List.fold_right (fun a p -> <:patt< [$to_patt a$ :: $p$] >>) al
- <:patt< [] >>
- | Tuple al -> <:patt< ($list:List.map to_patt al$) >>
- | Option None -> <:patt< None >>
- | Option (Some a) -> <:patt< Some $to_patt a$ >>
- | Int s -> <:patt< $int:s$ >>
- | Str s -> <:patt< $str:s$ >>
- | Bool True -> <:patt< True >>
- | Bool False -> <:patt< False >>
- | Cons a1 a2 -> <:patt< [$to_patt a1$ :: $to_patt a2$] >>
- | Apply _ _ -> failwith "bad pattern"
- | Record lal -> <:patt< {$list:List.map to_patt_label lal$} >>
- | Loc -> <:patt< _ >>
- | Antiquot loc s ->
- let p =
- try Grammar.Entry.parse Pcaml.patt_eoi (Stream.of_string s) with
- [ Stdpp.Exc_located (bp, ep) exc ->
- raise (Stdpp.Exc_located (fst loc + bp, fst loc + ep) exc) ]
- in
- <:patt< $anti:p$ >> ]
- and to_patt_label (l, a) = (<:patt< MLast.$lid:l$ >>, to_patt a);
- end
-;
-
-value antiquot k (bp, ep) x =
- let shift =
- if k = "" then String.length "$"
- else String.length "$" + String.length k + String.length ":"
- in
- Qast.Antiquot (shift + bp, shift + ep) x
-;
-
-value sig_item = Grammar.Entry.create gram "signature item";
-value str_item = Grammar.Entry.create gram "structure item";
-value ctyp = Grammar.Entry.create gram "type";
-value patt = Grammar.Entry.create gram "pattern";
-value expr = Grammar.Entry.create gram "expression";
-
-value module_type = Grammar.Entry.create gram "module type";
-value module_expr = Grammar.Entry.create gram "module expression";
-
-value class_type = Grammar.Entry.create gram "class type";
-value class_expr = Grammar.Entry.create gram "class expr";
-value class_sig_item = Grammar.Entry.create gram "class signature item";
-value class_str_item = Grammar.Entry.create gram "class structure item";
-
-value ipatt = Grammar.Entry.create gram "ipatt";
-value let_binding = Grammar.Entry.create gram "let_binding";
-value type_declaration = Grammar.Entry.create gram "type_declaration";
-value with_constr = Grammar.Entry.create gram "with_constr";
-value row_field = Grammar.Entry.create gram "row_field";
-
-value a_list = Grammar.Entry.create gram "a_list";
-value a_opt = Grammar.Entry.create gram "a_opt";
-value a_UIDENT = Grammar.Entry.create gram "a_UIDENT";
-value a_LIDENT = Grammar.Entry.create gram "a_LIDENT";
-value a_INT = Grammar.Entry.create gram "a_INT";
-value a_FLOAT = Grammar.Entry.create gram "a_FLOAT";
-value a_STRING = Grammar.Entry.create gram "a_STRING";
-value a_CHAR = Grammar.Entry.create gram "a_CHAR";
-value a_TILDEIDENT = Grammar.Entry.create gram "a_TILDEIDENT";
-value a_LABEL = Grammar.Entry.create gram "a_LABEL";
-value a_QUESTIONIDENT = Grammar.Entry.create gram "a_QUESTIONIDENT";
-value a_OPTLABEL = Grammar.Entry.create gram "a_OPTLABEL";
-
-value o2b =
- fun
- [ Qast.Option (Some _) -> Qast.Bool True
- | Qast.Option None -> Qast.Bool False
- | x -> x ]
-;
-
-value mksequence _ =
- fun
- [ Qast.List [e] -> e
- | el -> Qast.Node "ExSeq" [Qast.Loc; el] ]
-;
-
-value mkmatchcase _ p aso w e =
- let p =
- match aso with
- [ Qast.Option (Some p2) -> Qast.Node "PaAli" [Qast.Loc; p; p2]
- | Qast.Option None -> p
- | _ -> Qast.Node "PaAli" [Qast.Loc; p; aso] ]
- in
- Qast.Tuple [p; w; e]
-;
-
-value neg_string n =
- let len = String.length n in
- if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1)
- else "-" ^ n
-;
-
-value mkumin _ f arg =
- match arg with
- [ Qast.Node "ExInt" [Qast.Loc; Qast.Str n] when int_of_string n > 0 ->
- let n = neg_string n in
- Qast.Node "ExInt" [Qast.Loc; Qast.Str n]
- | Qast.Node "ExFlo" [Qast.Loc; Qast.Str n] when float_of_string n > 0.0 ->
- let n = neg_string n in
- Qast.Node "ExFlo" [Qast.Loc; Qast.Str n]
- | _ ->
- match f with
- [ Qast.Str f ->
- let f = "~" ^ f in
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str f]; arg]
- | _ -> assert False ] ]
-;
-
-value mkuminpat _ f is_int s =
- let s =
- match s with
- [ Qast.Str s -> Qast.Str (neg_string s)
- | s -> failwith "bad unary minus" ]
- in
- match is_int with
- [ Qast.Bool True -> Qast.Node "PaInt" [Qast.Loc; s]
- | Qast.Bool False -> Qast.Node "PaFlo" [Qast.Loc; s]
- | _ -> assert False ]
-;
-
-value mklistexp _ last =
- loop True where rec loop top =
- fun
- [ Qast.List [] ->
- match last with
- [ Qast.Option (Some e) -> e
- | Qast.Option None -> Qast.Node "ExUid" [Qast.Loc; Qast.Str "[]"]
- | a -> a ]
- | Qast.List [e1 :: el] ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExUid" [Qast.Loc; Qast.Str "::"]; e1];
- loop False (Qast.List el)]
- | a -> a ]
-;
-
-value mklistpat _ last =
- loop True where rec loop top =
- fun
- [ Qast.List [] ->
- match last with
- [ Qast.Option (Some p) -> p
- | Qast.Option None -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "[]"]
- | a -> a ]
- | Qast.List [p1 :: pl] ->
- Qast.Node "PaApp"
- [Qast.Loc;
- Qast.Node "PaApp"
- [Qast.Loc; Qast.Node "PaUid" [Qast.Loc; Qast.Str "::"]; p1];
- loop False (Qast.List pl)]
- | a -> a ]
-;
-
-value mkexprident loc i j =
- loop (Qast.Node "ExUid" [Qast.Loc; i]) j where rec loop m =
- fun
- [ Qast.Node "ExAcc" [_; x; y] ->
- loop (Qast.Node "ExAcc" [Qast.Loc; m; x]) y
- | e -> Qast.Node "ExAcc" [Qast.Loc; m; e] ]
-;
-
-value mkassert _ e =
- match e with
- [ Qast.Node "ExUid" [_; Qast.Str "False"] -> Qast.Node "ExAsf" [Qast.Loc]
- | _ -> Qast.Node "ExAsr" [Qast.Loc; e] ]
-;
-
-value append_elem el e = Qast.Apply "@" [el; Qast.List [e]];
-
-value not_yet_warned_antiq = ref True;
-value warn_antiq loc vers =
- if not_yet_warned_antiq.val then do {
- not_yet_warned_antiq.val := False;
- Pcaml.warning.val loc
- (Printf.sprintf
- "use of antiquotation syntax deprecated since version %s" vers);
- }
- else ()
-;
-
-value not_yet_warned_variant = ref True;
-value warn_variant _ =
- if not_yet_warned_variant.val then do {
- not_yet_warned_variant.val := False;
- Pcaml.warning.val (0, 1)
- (Printf.sprintf
- "use of syntax of variants types deprecated since version 3.05");
- }
- else ()
-;
-
-value not_yet_warned_seq = ref True;
-value warn_sequence _ =
- if not_yet_warned_seq.val then do {
- not_yet_warned_seq.val := False;
- Pcaml.warning.val (0, 1)
- (Printf.sprintf
- "use of syntax of sequences deprecated since version 3.01.1");
- }
- else ()
-;
-
-EXTEND
- GLOBAL: sig_item str_item ctyp patt expr module_type module_expr class_type
- class_expr class_sig_item class_str_item let_binding type_declaration
- ipatt with_constr row_field;
- module_expr:
- [ [ "functor"; "("; i = a_UIDENT; ":"; t = module_type; ")"; "->";
- me = SELF ->
- Qast.Node "MeFun" [Qast.Loc; i; t; me]
- | "struct"; st = SLIST0 [ s = str_item; ";" -> s ]; "end" ->
- Qast.Node "MeStr" [Qast.Loc; st] ]
- | [ me1 = SELF; me2 = SELF -> Qast.Node "MeApp" [Qast.Loc; me1; me2] ]
- | [ me1 = SELF; "."; me2 = SELF ->
- Qast.Node "MeAcc" [Qast.Loc; me1; me2] ]
- | "simple"
- [ i = a_UIDENT -> Qast.Node "MeUid" [Qast.Loc; i]
- | "("; me = SELF; ":"; mt = module_type; ")" ->
- Qast.Node "MeTyc" [Qast.Loc; me; mt]
- | "("; me = SELF; ")" -> me ] ]
- ;
- str_item:
- [ "top"
- [ "declare"; st = SLIST0 [ s = str_item; ";" -> s ]; "end" ->
- Qast.Node "StDcl" [Qast.Loc; st]
- | "exception"; ctl = constructor_declaration; b = rebind_exn ->
- let (_, c, tl) =
- match ctl with
- [ Qast.Tuple [xx1; xx2; xx3] -> (xx1, xx2, xx3)
- | _ -> match () with [] ]
- in
- Qast.Node "StExc" [Qast.Loc; c; tl; b]
- | "external"; i = a_LIDENT; ":"; t = ctyp; "="; pd = SLIST1 a_STRING ->
- Qast.Node "StExt" [Qast.Loc; i; t; pd]
- | "include"; me = module_expr -> Qast.Node "StInc" [Qast.Loc; me]
- | "module"; i = a_UIDENT; mb = module_binding ->
- Qast.Node "StMod" [Qast.Loc; i; mb]
- | "module"; "rec"; nmtmes = SLIST1 module_rec_binding SEP "and" ->
- Qast.Node "StRecMod" [Qast.Loc; nmtmes]
- | "module"; "type"; i = a_UIDENT; "="; mt = module_type ->
- Qast.Node "StMty" [Qast.Loc; i; mt]
- | "open"; i = mod_ident -> Qast.Node "StOpn" [Qast.Loc; i]
- | "type"; tdl = SLIST1 type_declaration SEP "and" ->
- Qast.Node "StTyp" [Qast.Loc; tdl]
- | "value"; r = SOPT "rec"; l = SLIST1 let_binding SEP "and" ->
- Qast.Node "StVal" [Qast.Loc; o2b r; l]
- | e = expr -> Qast.Node "StExp" [Qast.Loc; e] ] ]
- ;
- rebind_exn:
- [ [ "="; sl = mod_ident -> sl
- | -> Qast.List [] ] ]
- ;
- module_binding:
- [ RIGHTA
- [ "("; m = a_UIDENT; ":"; mt = module_type; ")"; mb = SELF ->
- Qast.Node "MeFun" [Qast.Loc; m; mt; mb]
- | ":"; mt = module_type; "="; me = module_expr ->
- Qast.Node "MeTyc" [Qast.Loc; me; mt]
- | "="; me = module_expr -> me ] ]
- ;
- module_rec_binding:
- [ [ m = a_UIDENT; ":"; mt = module_type; "="; me = module_expr ->
- Qast.Tuple [m; me; mt] ] ]
- ;
- module_type:
- [ [ "functor"; "("; i = a_UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF ->
- Qast.Node "MtFun" [Qast.Loc; i; t; mt] ]
- | [ mt = SELF; "with"; wcl = SLIST1 with_constr SEP "and" ->
- Qast.Node "MtWit" [Qast.Loc; mt; wcl] ]
- | [ "sig"; sg = SLIST0 [ s = sig_item; ";" -> s ]; "end" ->
- Qast.Node "MtSig" [Qast.Loc; sg] ]
- | [ m1 = SELF; m2 = SELF -> Qast.Node "MtApp" [Qast.Loc; m1; m2] ]
- | [ m1 = SELF; "."; m2 = SELF -> Qast.Node "MtAcc" [Qast.Loc; m1; m2] ]
- | "simple"
- [ i = a_UIDENT -> Qast.Node "MtUid" [Qast.Loc; i]
- | i = a_LIDENT -> Qast.Node "MtLid" [Qast.Loc; i]
- | "'"; i = ident -> Qast.Node "MtQuo" [Qast.Loc; i]
- | "("; mt = SELF; ")" -> mt ] ]
- ;
- sig_item:
- [ "top"
- [ "declare"; st = SLIST0 [ s = sig_item; ";" -> s ]; "end" ->
- Qast.Node "SgDcl" [Qast.Loc; st]
- | "exception"; ctl = constructor_declaration ->
- let (_, c, tl) =
- match ctl with
- [ Qast.Tuple [xx1; xx2; xx3] -> (xx1, xx2, xx3)
- | _ -> match () with [] ]
- in
- Qast.Node "SgExc" [Qast.Loc; c; tl]
- | "external"; i = a_LIDENT; ":"; t = ctyp; "="; pd = SLIST1 a_STRING ->
- Qast.Node "SgExt" [Qast.Loc; i; t; pd]
- | "include"; mt = module_type -> Qast.Node "SgInc" [Qast.Loc; mt]
- | "module"; i = a_UIDENT; mt = module_declaration ->
- Qast.Node "SgMod" [Qast.Loc; i; mt]
- | "module"; "type"; i = a_UIDENT; "="; mt = module_type ->
- Qast.Node "SgMty" [Qast.Loc; i; mt]
- | "module"; "rec"; mds = SLIST1 module_rec_declaration SEP "and" ->
- Qast.Node "SgRecMod" [Qast.Loc; mds]
- | "open"; i = mod_ident -> Qast.Node "SgOpn" [Qast.Loc; i]
- | "type"; tdl = SLIST1 type_declaration SEP "and" ->
- Qast.Node "SgTyp" [Qast.Loc; tdl]
- | "value"; i = a_LIDENT; ":"; t = ctyp ->
- Qast.Node "SgVal" [Qast.Loc; i; t] ] ]
- ;
- module_declaration:
- [ RIGHTA
- [ ":"; mt = module_type -> mt
- | "("; i = a_UIDENT; ":"; t = module_type; ")"; mt = SELF ->
- Qast.Node "MtFun" [Qast.Loc; i; t; mt] ] ]
- ;
- module_rec_declaration:
- [ [ m = a_UIDENT; ":"; mt = module_type -> Qast.Tuple [m; mt] ] ]
- ;
- with_constr:
- [ [ "type"; i = mod_ident; tpl = SLIST0 type_parameter; "="; t = ctyp ->
- Qast.Node "WcTyp" [Qast.Loc; i; tpl; t]
- | "module"; i = mod_ident; "="; me = module_expr ->
- Qast.Node "WcMod" [Qast.Loc; i; me] ] ]
- ;
- expr:
- [ "top" RIGHTA
- [ "let"; r = SOPT "rec"; l = SLIST1 let_binding SEP "and"; "in";
- x = SELF ->
- Qast.Node "ExLet" [Qast.Loc; o2b r; l; x]
- | "let"; "module"; m = a_UIDENT; mb = module_binding; "in"; e = SELF ->
- Qast.Node "ExLmd" [Qast.Loc; m; mb; e]
- | "fun"; "["; l = SLIST0 match_case SEP "|"; "]" ->
- Qast.Node "ExFun" [Qast.Loc; l]
- | "fun"; p = ipatt; e = fun_def ->
- Qast.Node "ExFun"
- [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]
- | "match"; e = SELF; "with"; "["; l = SLIST0 match_case SEP "|"; "]" ->
- Qast.Node "ExMat" [Qast.Loc; e; l]
- | "match"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF ->
- Qast.Node "ExMat"
- [Qast.Loc; e; Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]]
- | "try"; e = SELF; "with"; "["; l = SLIST0 match_case SEP "|"; "]" ->
- Qast.Node "ExTry" [Qast.Loc; e; l]
- | "try"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF ->
- Qast.Node "ExTry"
- [Qast.Loc; e; Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]]
- | "if"; e1 = SELF; "then"; e2 = SELF; "else"; e3 = SELF ->
- Qast.Node "ExIfe" [Qast.Loc; e1; e2; e3]
- | "do"; "{"; seq = sequence; "}" -> mksequence Qast.Loc seq
- | "for"; i = a_LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF;
- "do"; "{"; seq = sequence; "}" ->
- Qast.Node "ExFor" [Qast.Loc; i; e1; e2; df; seq]
- | "while"; e = SELF; "do"; "{"; seq = sequence; "}" ->
- Qast.Node "ExWhi" [Qast.Loc; e; seq] ]
- | "where"
- [ e = SELF; "where"; rf = SOPT "rec"; lb = let_binding ->
- Qast.Node "ExLet" [Qast.Loc; o2b rf; Qast.List [lb]; e] ]
- | ":=" NONA
- [ e1 = SELF; ":="; e2 = SELF; dummy ->
- Qast.Node "ExAss" [Qast.Loc; e1; e2] ]
- | "||" RIGHTA
- [ e1 = SELF; "||"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "||"]; e1];
- e2] ]
- | "&&" RIGHTA
- [ e1 = SELF; "&&"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "&&"]; e1];
- e2] ]
- | "<" LEFTA
- [ e1 = SELF; "<"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "<"]; e1];
- e2]
- | e1 = SELF; ">"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str ">"]; e1];
- e2]
- | e1 = SELF; "<="; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "<="]; e1];
- e2]
- | e1 = SELF; ">="; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str ">="]; e1];
- e2]
- | e1 = SELF; "="; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "="]; e1];
- e2]
- | e1 = SELF; "<>"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "<>"]; e1];
- e2]
- | e1 = SELF; "=="; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "=="]; e1];
- e2]
- | e1 = SELF; "!="; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "!="]; e1];
- e2] ]
- | "^" RIGHTA
- [ e1 = SELF; "^"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "^"]; e1];
- e2]
- | e1 = SELF; "@"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "@"]; e1];
- e2] ]
- | "+" LEFTA
- [ e1 = SELF; "+"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "+"]; e1];
- e2]
- | e1 = SELF; "-"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "-"]; e1];
- e2]
- | e1 = SELF; "+."; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "+."]; e1];
- e2]
- | e1 = SELF; "-."; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "-."]; e1];
- e2] ]
- | "*" LEFTA
- [ e1 = SELF; "*"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "*"]; e1];
- e2]
- | e1 = SELF; "/"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "/"]; e1];
- e2]
- | e1 = SELF; "*."; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "*."]; e1];
- e2]
- | e1 = SELF; "/."; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "/."]; e1];
- e2]
- | e1 = SELF; "land"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "land"]; e1];
- e2]
- | e1 = SELF; "lor"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lor"]; e1];
- e2]
- | e1 = SELF; "lxor"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lxor"]; e1];
- e2]
- | e1 = SELF; "mod"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "mod"]; e1];
- e2] ]
- | "**" RIGHTA
- [ e1 = SELF; "**"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "**"]; e1];
- e2]
- | e1 = SELF; "asr"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "asr"]; e1];
- e2]
- | e1 = SELF; "lsl"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lsl"]; e1];
- e2]
- | e1 = SELF; "lsr"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lsr"]; e1];
- e2] ]
- | "unary minus" NONA
- [ "-"; e = SELF -> mkumin Qast.Loc (Qast.Str "-") e
- | "-."; e = SELF -> mkumin Qast.Loc (Qast.Str "-.") e ]
- | "apply" LEFTA
- [ e1 = SELF; e2 = SELF -> Qast.Node "ExApp" [Qast.Loc; e1; e2]
- | "assert"; e = SELF -> mkassert Qast.Loc e
- | "lazy"; e = SELF -> Qast.Node "ExLaz" [Qast.Loc; e] ]
- | "." LEFTA
- [ e1 = SELF; "."; "("; e2 = SELF; ")" ->
- Qast.Node "ExAre" [Qast.Loc; e1; e2]
- | e1 = SELF; "."; "["; e2 = SELF; "]" ->
- Qast.Node "ExSte" [Qast.Loc; e1; e2]
- | e1 = SELF; "."; e2 = SELF -> Qast.Node "ExAcc" [Qast.Loc; e1; e2] ]
- | "~-" NONA
- [ "~-"; e = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "~-"]; e]
- | "~-."; e = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "~-."]; e] ]
- | "simple"
- [ s = a_INT -> Qast.Node "ExInt" [Qast.Loc; s]
- | s = a_FLOAT -> Qast.Node "ExFlo" [Qast.Loc; s]
- | s = a_STRING -> Qast.Node "ExStr" [Qast.Loc; s]
- | s = a_CHAR -> Qast.Node "ExChr" [Qast.Loc; s]
- | i = expr_ident -> i
- | "["; "]" -> Qast.Node "ExUid" [Qast.Loc; Qast.Str "[]"]
- | "["; el = SLIST1 expr SEP ";"; last = cons_expr_opt; "]" ->
- mklistexp Qast.Loc last el
- | "[|"; el = SLIST0 expr SEP ";"; "|]" ->
- Qast.Node "ExArr" [Qast.Loc; el]
- | "{"; lel = SLIST1 label_expr SEP ";"; "}" ->
- Qast.Node "ExRec" [Qast.Loc; lel; Qast.Option None]
- | "{"; "("; e = SELF; ")"; "with"; lel = SLIST1 label_expr SEP ";";
- "}" ->
- Qast.Node "ExRec" [Qast.Loc; lel; Qast.Option (Some e)]
- | "("; ")" -> Qast.Node "ExUid" [Qast.Loc; Qast.Str "()"]
- | "("; e = SELF; ":"; t = ctyp; ")" ->
- Qast.Node "ExTyc" [Qast.Loc; e; t]
- | "("; e = SELF; ","; el = SLIST1 expr SEP ","; ")" ->
- Qast.Node "ExTup" [Qast.Loc; Qast.Cons e el]
- | "("; e = SELF; ")" -> e ] ]
- ;
- cons_expr_opt:
- [ [ "::"; e = expr -> Qast.Option (Some e)
- | -> Qast.Option None ] ]
- ;
- dummy:
- [ [ -> () ] ]
- ;
- sequence:
- [ [ "let"; rf = SOPT "rec"; l = SLIST1 let_binding SEP "and";
- [ "in" | ";" ]; el = SELF ->
- Qast.List
- [Qast.Node "ExLet" [Qast.Loc; o2b rf; l; mksequence Qast.Loc el]]
- | e = expr; ";"; el = SELF -> Qast.Cons e el
- | e = expr; ";" -> Qast.List [e]
- | e = expr -> Qast.List [e] ] ]
- ;
- let_binding:
- [ [ p = ipatt; e = fun_binding -> Qast.Tuple [p; e] ] ]
- ;
- fun_binding:
- [ RIGHTA
- [ p = ipatt; e = SELF ->
- Qast.Node "ExFun"
- [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]
- | "="; e = expr -> e
- | ":"; t = ctyp; "="; e = expr -> Qast.Node "ExTyc" [Qast.Loc; e; t] ] ]
- ;
- match_case:
- [ [ p = patt; aso = as_patt_opt; w = when_expr_opt; "->"; e = expr ->
- mkmatchcase Qast.Loc p aso w e ] ]
- ;
- as_patt_opt:
- [ [ "as"; p = patt -> Qast.Option (Some p)
- | -> Qast.Option None ] ]
- ;
- when_expr_opt:
- [ [ "when"; e = expr -> Qast.Option (Some e)
- | -> Qast.Option None ] ]
- ;
- label_expr:
- [ [ i = patt_label_ident; e = fun_binding -> Qast.Tuple [i; e] ] ]
- ;
- expr_ident:
- [ RIGHTA
- [ i = a_LIDENT -> Qast.Node "ExLid" [Qast.Loc; i]
- | i = a_UIDENT -> Qast.Node "ExUid" [Qast.Loc; i]
- | i = a_UIDENT; "."; j = SELF -> mkexprident Qast.Loc i j ] ]
- ;
- fun_def:
- [ RIGHTA
- [ p = ipatt; e = SELF ->
- Qast.Node "ExFun"
- [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]
- | "->"; e = expr -> e ] ]
- ;
- patt:
- [ LEFTA
- [ p1 = SELF; "|"; p2 = SELF -> Qast.Node "PaOrp" [Qast.Loc; p1; p2] ]
- | NONA
- [ p1 = SELF; ".."; p2 = SELF -> Qast.Node "PaRng" [Qast.Loc; p1; p2] ]
- | LEFTA
- [ p1 = SELF; p2 = SELF -> Qast.Node "PaApp" [Qast.Loc; p1; p2] ]
- | LEFTA
- [ p1 = SELF; "."; p2 = SELF -> Qast.Node "PaAcc" [Qast.Loc; p1; p2] ]
- | "simple"
- [ s = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; s]
- | s = a_UIDENT -> Qast.Node "PaUid" [Qast.Loc; s]
- | s = a_INT -> Qast.Node "PaInt" [Qast.Loc; s]
- | s = a_FLOAT -> Qast.Node "PaFlo" [Qast.Loc; s]
- | s = a_STRING -> Qast.Node "PaStr" [Qast.Loc; s]
- | s = a_CHAR -> Qast.Node "PaChr" [Qast.Loc; s]
- | "-"; s = a_INT -> mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool True) s
- | "-"; s = a_FLOAT ->
- mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool False) s
- | "["; "]" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "[]"]
- | "["; pl = SLIST1 patt SEP ";"; last = cons_patt_opt; "]" ->
- mklistpat Qast.Loc last pl
- | "[|"; pl = SLIST0 patt SEP ";"; "|]" ->
- Qast.Node "PaArr" [Qast.Loc; pl]
- | "{"; lpl = SLIST1 label_patt SEP ";"; "}" ->
- Qast.Node "PaRec" [Qast.Loc; lpl]
- | "("; ")" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "()"]
- | "("; p = SELF; ")" -> p
- | "("; p = SELF; ":"; t = ctyp; ")" ->
- Qast.Node "PaTyc" [Qast.Loc; p; t]
- | "("; p = SELF; "as"; p2 = SELF; ")" ->
- Qast.Node "PaAli" [Qast.Loc; p; p2]
- | "("; p = SELF; ","; pl = SLIST1 patt SEP ","; ")" ->
- Qast.Node "PaTup" [Qast.Loc; Qast.Cons p pl]
- | "_" -> Qast.Node "PaAny" [Qast.Loc] ] ]
- ;
- cons_patt_opt:
- [ [ "::"; p = patt -> Qast.Option (Some p)
- | -> Qast.Option None ] ]
- ;
- label_patt:
- [ [ i = patt_label_ident; "="; p = patt -> Qast.Tuple [i; p] ] ]
- ;
- patt_label_ident:
- [ LEFTA
- [ p1 = SELF; "."; p2 = SELF -> Qast.Node "PaAcc" [Qast.Loc; p1; p2] ]
- | "simple" RIGHTA
- [ i = a_UIDENT -> Qast.Node "PaUid" [Qast.Loc; i]
- | i = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; i] ] ]
- ;
- ipatt:
- [ [ "{"; lpl = SLIST1 label_ipatt SEP ";"; "}" ->
- Qast.Node "PaRec" [Qast.Loc; lpl]
- | "("; ")" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "()"]
- | "("; p = SELF; ")" -> p
- | "("; p = SELF; ":"; t = ctyp; ")" ->
- Qast.Node "PaTyc" [Qast.Loc; p; t]
- | "("; p = SELF; "as"; p2 = SELF; ")" ->
- Qast.Node "PaAli" [Qast.Loc; p; p2]
- | "("; p = SELF; ","; pl = SLIST1 ipatt SEP ","; ")" ->
- Qast.Node "PaTup" [Qast.Loc; Qast.Cons p pl]
- | s = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; s]
- | "_" -> Qast.Node "PaAny" [Qast.Loc] ] ]
- ;
- label_ipatt:
- [ [ i = patt_label_ident; "="; p = ipatt -> Qast.Tuple [i; p] ] ]
- ;
- type_declaration:
- [ [ n = type_patt; tpl = SLIST0 type_parameter; "="; tk = ctyp;
- cl = SLIST0 constrain ->
- Qast.Tuple [n; tpl; tk; cl] ] ]
- ;
- type_patt:
- [ [ n = a_LIDENT -> Qast.Tuple [Qast.Loc; n] ] ]
- ;
- constrain:
- [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> Qast.Tuple [t1; t2] ] ]
- ;
- type_parameter:
- [ [ "'"; i = ident ->
- Qast.Tuple [i; Qast.Tuple [Qast.Bool False; Qast.Bool False]]
- | "+"; "'"; i = ident ->
- Qast.Tuple [i; Qast.Tuple [Qast.Bool True; Qast.Bool False]]
- | "-"; "'"; i = ident ->
- Qast.Tuple [i; Qast.Tuple [Qast.Bool False; Qast.Bool True]] ] ]
- ;
- ctyp:
- [ LEFTA
- [ t1 = SELF; "=="; t2 = SELF -> Qast.Node "TyMan" [Qast.Loc; t1; t2] ]
- | LEFTA
- [ t1 = SELF; "as"; t2 = SELF -> Qast.Node "TyAli" [Qast.Loc; t1; t2] ]
- | LEFTA
- [ "!"; pl = SLIST1 typevar; "."; t = SELF ->
- Qast.Node "TyPol" [Qast.Loc; pl; t] ]
- | "arrow" RIGHTA
- [ t1 = SELF; "->"; t2 = SELF -> Qast.Node "TyArr" [Qast.Loc; t1; t2] ]
- | "label" NONA
- [ i = a_TILDEIDENT; ":"; t = SELF -> Qast.Node "TyLab" [Qast.Loc; i; t]
- | i = a_LABEL; t = SELF -> Qast.Node "TyLab" [Qast.Loc; i; t]
- | i = a_QUESTIONIDENT; ":"; t = SELF ->
- Qast.Node "TyOlb" [Qast.Loc; i; t]
- | i = a_OPTLABEL; t = SELF ->
- Qast.Node "TyOlb" [Qast.Loc; i; t] ]
- | LEFTA
- [ t1 = SELF; t2 = SELF -> Qast.Node "TyApp" [Qast.Loc; t1; t2] ]
- | LEFTA
- [ t1 = SELF; "."; t2 = SELF -> Qast.Node "TyAcc" [Qast.Loc; t1; t2] ]
- | "simple"
- [ "'"; i = ident -> Qast.Node "TyQuo" [Qast.Loc; i]
- | "_" -> Qast.Node "TyAny" [Qast.Loc]
- | i = a_LIDENT -> Qast.Node "TyLid" [Qast.Loc; i]
- | i = a_UIDENT -> Qast.Node "TyUid" [Qast.Loc; i]
- | "("; t = SELF; "*"; tl = SLIST1 ctyp SEP "*"; ")" ->
- Qast.Node "TyTup" [Qast.Loc; Qast.Cons t tl]
- | "("; t = SELF; ")" -> t
- | "private"; "["; cdl = SLIST0 constructor_declaration SEP "|"; "]" ->
- Qast.Node "TySum" [Qast.Loc; Qast.Bool True; cdl]
- | "private"; "{"; ldl = SLIST1 label_declaration SEP ";"; "}" ->
- Qast.Node "TyRec" [Qast.Loc; Qast.Bool True; ldl]
- | "["; cdl = SLIST0 constructor_declaration SEP "|"; "]" ->
- Qast.Node "TySum" [Qast.Loc; Qast.Bool False; cdl]
- | "{"; ldl = SLIST1 label_declaration SEP ";"; "}" ->
- Qast.Node "TyRec" [Qast.Loc; Qast.Bool False; ldl] ] ]
- ;
- constructor_declaration:
- [ [ ci = a_UIDENT; "of"; cal = SLIST1 ctyp SEP "and" ->
- Qast.Tuple [Qast.Loc; ci; cal]
- | ci = a_UIDENT -> Qast.Tuple [Qast.Loc; ci; Qast.List []] ] ]
- ;
- label_declaration:
- [ [ i = a_LIDENT; ":"; mf = SOPT "mutable"; t = ctyp ->
- Qast.Tuple [Qast.Loc; i; o2b mf; t] ] ]
- ;
- ident:
- [ [ i = a_LIDENT -> i
- | i = a_UIDENT -> i ] ]
- ;
- mod_ident:
- [ RIGHTA
- [ i = a_UIDENT -> Qast.List [i]
- | i = a_LIDENT -> Qast.List [i]
- | i = a_UIDENT; "."; j = SELF -> Qast.Cons i j ] ]
- ;
- (* Objects and Classes *)
- str_item:
- [ [ "class"; cd = SLIST1 class_declaration SEP "and" ->
- Qast.Node "StCls" [Qast.Loc; cd]
- | "class"; "type"; ctd = SLIST1 class_type_declaration SEP "and" ->
- Qast.Node "StClt" [Qast.Loc; ctd] ] ]
- ;
- sig_item:
- [ [ "class"; cd = SLIST1 class_description SEP "and" ->
- Qast.Node "SgCls" [Qast.Loc; cd]
- | "class"; "type"; ctd = SLIST1 class_type_declaration SEP "and" ->
- Qast.Node "SgClt" [Qast.Loc; ctd] ] ]
- ;
- class_declaration:
- [ [ vf = SOPT "virtual"; i = a_LIDENT; ctp = class_type_parameters;
- cfb = class_fun_binding ->
- Qast.Record
- [("ciLoc", Qast.Loc); ("ciVir", o2b vf); ("ciPrm", ctp);
- ("ciNam", i); ("ciExp", cfb)] ] ]
- ;
- class_fun_binding:
- [ [ "="; ce = class_expr -> ce
- | ":"; ct = class_type; "="; ce = class_expr ->
- Qast.Node "CeTyc" [Qast.Loc; ce; ct]
- | p = ipatt; cfb = SELF -> Qast.Node "CeFun" [Qast.Loc; p; cfb] ] ]
- ;
- class_type_parameters:
- [ [ -> Qast.Tuple [Qast.Loc; Qast.List []]
- | "["; tpl = SLIST1 type_parameter SEP ","; "]" ->
- Qast.Tuple [Qast.Loc; tpl] ] ]
- ;
- class_fun_def:
- [ [ p = ipatt; ce = SELF -> Qast.Node "CeFun" [Qast.Loc; p; ce]
- | "->"; ce = class_expr -> ce ] ]
- ;
- class_expr:
- [ "top"
- [ "fun"; p = ipatt; ce = class_fun_def ->
- Qast.Node "CeFun" [Qast.Loc; p; ce]
- | "let"; rf = SOPT "rec"; lb = SLIST1 let_binding SEP "and"; "in";
- ce = SELF ->
- Qast.Node "CeLet" [Qast.Loc; o2b rf; lb; ce] ]
- | "apply" NONA
- [ ce = SELF; e = expr LEVEL "label" ->
- Qast.Node "CeApp" [Qast.Loc; ce; e] ]
- | "simple"
- [ ci = class_longident; "["; ctcl = SLIST0 ctyp SEP ","; "]" ->
- Qast.Node "CeCon" [Qast.Loc; ci; ctcl]
- | ci = class_longident -> Qast.Node "CeCon" [Qast.Loc; ci; Qast.List []]
- | "object"; cspo = SOPT class_self_patt; cf = class_structure; "end" ->
- Qast.Node "CeStr" [Qast.Loc; cspo; cf]
- | "("; ce = SELF; ":"; ct = class_type; ")" ->
- Qast.Node "CeTyc" [Qast.Loc; ce; ct]
- | "("; ce = SELF; ")" -> ce ] ]
- ;
- class_structure:
- [ [ cf = SLIST0 [ cf = class_str_item; ";" -> cf ] -> cf ] ]
- ;
- class_self_patt:
- [ [ "("; p = patt; ")" -> p
- | "("; p = patt; ":"; t = ctyp; ")" ->
- Qast.Node "PaTyc" [Qast.Loc; p; t] ] ]
- ;
- class_str_item:
- [ [ "declare"; st = SLIST0 [ s = class_str_item; ";" -> s ]; "end" ->
- Qast.Node "CrDcl" [Qast.Loc; st]
- | "inherit"; ce = class_expr; pb = SOPT as_lident ->
- Qast.Node "CrInh" [Qast.Loc; ce; pb]
- | "value"; mf = SOPT "mutable"; lab = label; e = cvalue_binding ->
- Qast.Node "CrVal" [Qast.Loc; lab; o2b mf; e]
- | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
- Qast.Node "CrVir" [Qast.Loc; l; o2b pf; t]
- | "method"; pf = SOPT "private"; l = label; topt = SOPT polyt;
- e = fun_binding ->
- Qast.Node "CrMth" [Qast.Loc; l; o2b pf; e; topt]
- | "type"; t1 = ctyp; "="; t2 = ctyp ->
- Qast.Node "CrCtr" [Qast.Loc; t1; t2]
- | "initializer"; se = expr -> Qast.Node "CrIni" [Qast.Loc; se] ] ]
- ;
- as_lident:
- [ [ "as"; i = a_LIDENT -> i ] ]
- ;
- polyt:
- [ [ ":"; t = ctyp -> t ] ]
- ;
- cvalue_binding:
- [ [ "="; e = expr -> e
- | ":"; t = ctyp; "="; e = expr -> Qast.Node "ExTyc" [Qast.Loc; e; t]
- | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr ->
- Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option (Some t); t2]
- | ":>"; t = ctyp; "="; e = expr ->
- Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option None; t] ] ]
- ;
- label:
- [ [ i = a_LIDENT -> i ] ]
- ;
- class_type:
- [ [ "["; t = ctyp; "]"; "->"; ct = SELF ->
- Qast.Node "CtFun" [Qast.Loc; t; ct]
- | id = clty_longident; "["; tl = SLIST1 ctyp SEP ","; "]" ->
- Qast.Node "CtCon" [Qast.Loc; id; tl]
- | id = clty_longident -> Qast.Node "CtCon" [Qast.Loc; id; Qast.List []]
- | "object"; cst = SOPT class_self_type;
- csf = SLIST0 [ csf = class_sig_item; ";" -> csf ]; "end" ->
- Qast.Node "CtSig" [Qast.Loc; cst; csf] ] ]
- ;
- class_self_type:
- [ [ "("; t = ctyp; ")" -> t ] ]
- ;
- class_sig_item:
- [ [ "declare"; st = SLIST0 [ s = class_sig_item; ";" -> s ]; "end" ->
- Qast.Node "CgDcl" [Qast.Loc; st]
- | "inherit"; cs = class_type -> Qast.Node "CgInh" [Qast.Loc; cs]
- | "value"; mf = SOPT "mutable"; l = label; ":"; t = ctyp ->
- Qast.Node "CgVal" [Qast.Loc; l; o2b mf; t]
- | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
- Qast.Node "CgVir" [Qast.Loc; l; o2b pf; t]
- | "method"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
- Qast.Node "CgMth" [Qast.Loc; l; o2b pf; t]
- | "type"; t1 = ctyp; "="; t2 = ctyp ->
- Qast.Node "CgCtr" [Qast.Loc; t1; t2] ] ]
- ;
- class_description:
- [ [ vf = SOPT "virtual"; n = a_LIDENT; ctp = class_type_parameters; ":";
- ct = class_type ->
- Qast.Record
- [("ciLoc", Qast.Loc); ("ciVir", o2b vf); ("ciPrm", ctp);
- ("ciNam", n); ("ciExp", ct)] ] ]
- ;
- class_type_declaration:
- [ [ vf = SOPT "virtual"; n = a_LIDENT; ctp = class_type_parameters; "=";
- cs = class_type ->
- Qast.Record
- [("ciLoc", Qast.Loc); ("ciVir", o2b vf); ("ciPrm", ctp);
- ("ciNam", n); ("ciExp", cs)] ] ]
- ;
- expr: LEVEL "apply"
- [ LEFTA
- [ "new"; i = class_longident -> Qast.Node "ExNew" [Qast.Loc; i] ] ]
- ;
- expr: LEVEL "."
- [ [ e = SELF; "#"; lab = label -> Qast.Node "ExSnd" [Qast.Loc; e; lab] ] ]
- ;
- expr: LEVEL "simple"
- [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" ->
- Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option (Some t); t2]
- | "("; e = SELF; ":>"; t = ctyp; ")" ->
- Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option None; t]
- | "{<"; fel = SLIST0 field_expr SEP ";"; ">}" ->
- Qast.Node "ExOvr" [Qast.Loc; fel] ] ]
- ;
- field_expr:
- [ [ l = label; "="; e = expr -> Qast.Tuple [l; e] ] ]
- ;
- ctyp: LEVEL "simple"
- [ [ "#"; id = class_longident -> Qast.Node "TyCls" [Qast.Loc; id]
- | "<"; ml = SLIST0 field SEP ";"; v = SOPT ".."; ">" ->
- Qast.Node "TyObj" [Qast.Loc; ml; o2b v] ] ]
- ;
- field:
- [ [ lab = a_LIDENT; ":"; t = ctyp -> Qast.Tuple [lab; t] ] ]
- ;
- typevar:
- [ [ "'"; i = ident -> i ] ]
- ;
- clty_longident:
- [ [ m = a_UIDENT; "."; l = SELF -> Qast.Cons m l
- | i = a_LIDENT -> Qast.List [i] ] ]
- ;
- class_longident:
- [ [ m = a_UIDENT; "."; l = SELF -> Qast.Cons m l
- | i = a_LIDENT -> Qast.List [i] ] ]
- ;
- ctyp: LEVEL "simple"
- [ [ "["; "="; rfl = row_field_list; "]" ->
- Qast.Node "TyVrn" [Qast.Loc; rfl; Qast.Option None]
- | "["; ">"; rfl = row_field_list; "]" ->
- Qast.Node "TyVrn"
- [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))]
- | "["; "<"; rfl = row_field_list; "]" ->
- Qast.Node "TyVrn"
- [Qast.Loc; rfl;
- Qast.Option (Some (Qast.Option (Some (Qast.List []))))]
- | "["; "<"; rfl = row_field_list; ">"; ntl = SLIST1 name_tag; "]" ->
- Qast.Node "TyVrn"
- [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))] ] ]
- ;
- row_field_list:
- [ [ rfl = SLIST0 row_field SEP "|" -> rfl ] ]
- ;
- row_field:
- [ [ "`"; i = ident -> Qast.Node "RfTag" [i; Qast.Bool True; Qast.List []]
- | "`"; i = ident; "of"; ao = SOPT "&"; l = SLIST1 ctyp SEP "&" ->
- Qast.Node "RfTag" [i; o2b ao; l]
- | t = ctyp -> Qast.Node "RfInh" [t] ] ]
- ;
- name_tag:
- [ [ "`"; i = ident -> i ] ]
- ;
- patt: LEVEL "simple"
- [ [ "`"; s = ident -> Qast.Node "PaVrn" [Qast.Loc; s]
- | "#"; sl = mod_ident -> Qast.Node "PaTyp" [Qast.Loc; sl]
- | i = a_TILDEIDENT; ":"; p = SELF ->
- Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)]
- | i = a_LABEL; p = SELF ->
- Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)]
- | i = a_TILDEIDENT -> Qast.Node "PaLab" [Qast.Loc; i; Qast.Option None]
- | i = a_QUESTIONIDENT; ":"; "("; p = patt_tcon; eo = SOPT eq_expr;
- ")" ->
- Qast.Node "PaOlb"
- [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]
- | i = a_OPTLABEL; "("; p = patt_tcon; eo = SOPT eq_expr; ")" ->
- Qast.Node "PaOlb"
- [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]
- | i = a_QUESTIONIDENT ->
- Qast.Node "PaOlb" [Qast.Loc; i; Qast.Option None]
- | "?"; "("; p = patt_tcon; eo = SOPT eq_expr; ")" ->
- Qast.Node "PaOlb"
- [Qast.Loc; Qast.Str "";
- Qast.Option (Some (Qast.Tuple [p; eo]))] ] ]
- ;
- patt_tcon:
- [ [ p = patt; ":"; t = ctyp -> Qast.Node "PaTyc" [Qast.Loc; p; t]
- | p = patt -> p ] ]
- ;
- ipatt:
- [ [ i = a_TILDEIDENT; ":"; p = SELF ->
- Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)]
- | i = a_LABEL; p = SELF ->
- Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)]
- | i = a_TILDEIDENT -> Qast.Node "PaLab" [Qast.Loc; i; Qast.Option None]
- | i = a_QUESTIONIDENT; ":"; "("; p = ipatt_tcon; eo = SOPT eq_expr;
- ")" ->
- Qast.Node "PaOlb"
- [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]
- | i = a_OPTLABEL; "("; p = ipatt_tcon; eo = SOPT eq_expr; ")" ->
- Qast.Node "PaOlb"
- [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]
- | i = a_QUESTIONIDENT ->
- Qast.Node "PaOlb" [Qast.Loc; i; Qast.Option None]
- | "?"; "("; p = ipatt_tcon; eo = SOPT eq_expr; ")" ->
- Qast.Node "PaOlb"
- [Qast.Loc; Qast.Str "";
- Qast.Option (Some (Qast.Tuple [p; eo]))] ] ]
- ;
- ipatt_tcon:
- [ [ p = ipatt; ":"; t = ctyp -> Qast.Node "PaTyc" [Qast.Loc; p; t]
- | p = ipatt -> p ] ]
- ;
- eq_expr:
- [ [ "="; e = expr -> e ] ]
- ;
- expr: AFTER "apply"
- [ "label" NONA
- [ i = a_TILDEIDENT; ":"; e = SELF ->
- Qast.Node "ExLab" [Qast.Loc; i; Qast.Option (Some e)]
- | i = a_LABEL; e = SELF ->
- Qast.Node "ExLab" [Qast.Loc; i; Qast.Option (Some e)]
- | i = a_TILDEIDENT -> Qast.Node "ExLab" [Qast.Loc; i; Qast.Option None]
- | i = a_QUESTIONIDENT; ":"; e = SELF ->
- Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option (Some e)]
- | i = a_OPTLABEL; e = SELF ->
- Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option (Some e)]
- | i = a_QUESTIONIDENT ->
- Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option None] ] ]
- ;
- expr: LEVEL "simple"
- [ [ "`"; s = ident -> Qast.Node "ExVrn" [Qast.Loc; s] ] ]
- ;
- direction_flag:
- [ [ "to" -> Qast.Bool True
- | "downto" -> Qast.Bool False ] ]
- ;
- (* Compatibility old syntax of variant types definitions *)
- ctyp: LEVEL "simple"
- [ [ "[|"; warning_variant; rfl = row_field_list; "|]" ->
- Qast.Node "TyVrn" [Qast.Loc; rfl; Qast.Option None]
- | "[|"; warning_variant; ">"; rfl = row_field_list; "|]" ->
- Qast.Node "TyVrn"
- [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))]
- | "[|"; warning_variant; "<"; rfl = row_field_list; "|]" ->
- Qast.Node "TyVrn"
- [Qast.Loc; rfl;
- Qast.Option (Some (Qast.Option (Some (Qast.List []))))]
- | "[|"; warning_variant; "<"; rfl = row_field_list; ">";
- ntl = SLIST1 name_tag; "|]" ->
- Qast.Node "TyVrn"
- [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))] ] ]
- ;
- warning_variant:
- [ [ -> warn_variant Qast.Loc ] ]
- ;
- (* Compatibility old syntax of sequences *)
- expr: LEVEL "top"
- [ [ "do"; seq = SLIST0 [ e = expr; ";" -> e ]; "return"; warning_sequence;
- e = SELF ->
- Qast.Node "ExSeq" [Qast.Loc; append_elem seq e]
- | "for"; i = a_LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF;
- "do"; seq = SLIST0 [ e = expr; ";" -> e ]; warning_sequence; "done" ->
- Qast.Node "ExFor" [Qast.Loc; i; e1; e2; df; seq]
- | "while"; e = SELF; "do"; seq = SLIST0 [ e = expr; ";" -> e ];
- warning_sequence; "done" ->
- Qast.Node "ExWhi" [Qast.Loc; e; seq] ] ]
- ;
- warning_sequence:
- [ [ -> warn_sequence Qast.Loc ] ]
- ;
- (* Antiquotations for local entries *)
- sequence:
- [ [ a = ANTIQUOT "list" -> antiquot "list" loc a ] ]
- ;
- expr_ident:
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- patt_label_ident: LEVEL "simple"
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- when_expr_opt:
- [ [ a = ANTIQUOT "when" -> antiquot "when" loc a ] ]
- ;
- mod_ident:
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- clty_longident:
- [ [ a = a_list -> a ] ]
- ;
- class_longident:
- [ [ a = a_list -> a ] ]
- ;
- direction_flag:
- [ [ a = ANTIQUOT "to" -> antiquot "to" loc a ] ]
- ;
- (* deprecated since version 3.05; code for compatibility *)
- class_expr: LEVEL "simple"
- [ [ "object"; x = ANTIQUOT; cf = class_structure; "end" ->
- let _ = warn_antiq loc "3.05" in
- Qast.Node "CeStr" [Qast.Loc; antiquot "" loc x; cf]
- | "object"; x = ANTIQUOT; ";";
- csl = SLIST0 [ cf = class_str_item; ";" -> cf ] ; "end" ->
- let _ = warn_antiq loc "3.05" in
- Qast.Node "CeStr"
- [Qast.Loc; Qast.Option None;
- Qast.Cons (antiquot "" loc x) csl] ] ]
- ;
- class_type:
- [ [ "object"; x = ANTIQUOT;
- csf = SLIST0 [ csf = class_sig_item; ";" -> csf ]; "end" ->
- let _ = warn_antiq loc "3.05" in
- Qast.Node "CtSig" [Qast.Loc; antiquot "" loc x; csf]
- | "object"; x = ANTIQUOT; ";";
- csf = SLIST0 [ csf = class_sig_item; ";" -> csf ]; "end" ->
- let _ = warn_antiq loc "3.05" in
- Qast.Node "CtSig"
- [Qast.Loc; Qast.Option None;
- Qast.Cons (antiquot "" loc x) csf] ] ]
- ;
- (* deprecated since version 3.06+18; code for compatibility *)
- expr: LEVEL "top"
- [ [ "let"; r = ANTIQUOT "rec"; l = SLIST1 let_binding SEP "and"; "in";
- x = SELF ->
- let _ = warn_antiq loc "3.06+18" in
- Qast.Node "ExLet" [Qast.Loc; antiquot "rec" loc r; l; x] ] ]
- ;
- str_item: LEVEL "top"
- [ [ "value"; r = ANTIQUOT "rec"; l = SLIST1 let_binding SEP "and" ->
- let _ = warn_antiq loc "3.06+18" in
- Qast.Node "StVal" [Qast.Loc; antiquot "rec" loc r; l] ] ]
- ;
- class_expr: LEVEL "top"
- [ [ "let"; r = ANTIQUOT "rec"; lb = SLIST1 let_binding SEP "and"; "in";
- ce = SELF ->
- let _ = warn_antiq loc "3.06+18" in
- Qast.Node "CeLet" [Qast.Loc; antiquot "rec" loc r; lb; ce] ] ]
- ;
- class_str_item:
- [ [ "inherit"; ce = class_expr; pb = ANTIQUOT "as" ->
- let _ = warn_antiq loc "3.06+18" in
- Qast.Node "CrInh" [Qast.Loc; ce; antiquot "as" loc pb]
- | "value"; mf = ANTIQUOT "mut"; lab = label; e = cvalue_binding ->
- let _ = warn_antiq loc "3.06+18" in
- Qast.Node "CrVal" [Qast.Loc; lab; antiquot "mut" loc mf; e] ] ]
- ;
- class_sig_item:
- [ [ "value"; mf = ANTIQUOT "mut"; l = label; ":"; t = ctyp ->
- let _ = warn_antiq loc "3.06+18" in
- Qast.Node "CgVal" [Qast.Loc; l; antiquot "mut" loc mf; t] ] ]
- ;
-END;
-
-EXTEND
- GLOBAL: str_item sig_item;
- str_item:
- [ [ "#"; n = a_LIDENT; dp = dir_param ->
- Qast.Node "StDir" [Qast.Loc; n; dp] ] ]
- ;
- sig_item:
- [ [ "#"; n = a_LIDENT; dp = dir_param ->
- Qast.Node "SgDir" [Qast.Loc; n; dp] ] ]
- ;
- dir_param:
- [ [ a = ANTIQUOT "opt" -> antiquot "opt" loc a
- | e = expr -> Qast.Option (Some e)
- | -> Qast.Option None ] ]
- ;
-END;
-
-(* Antiquotations *)
-
-EXTEND
- module_expr: LEVEL "simple"
- [ [ a = ANTIQUOT "mexp" -> antiquot "mexp" loc a
- | a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- str_item: LEVEL "top"
- [ [ a = ANTIQUOT "stri" -> antiquot "stri" loc a
- | a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- module_type: LEVEL "simple"
- [ [ a = ANTIQUOT "mtyp" -> antiquot "mtyp" loc a
- | a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- sig_item: LEVEL "top"
- [ [ a = ANTIQUOT "sigi" -> antiquot "sigi" loc a
- | a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- expr: LEVEL "simple"
- [ [ a = ANTIQUOT "exp" -> antiquot "exp" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | a = ANTIQUOT "anti" ->
- Qast.Node "ExAnt" [Qast.Loc; antiquot "anti" loc a]
- | "("; el = a_list; ")" -> Qast.Node "ExTup" [Qast.Loc; el] ] ]
- ;
- patt: LEVEL "simple"
- [ [ a = ANTIQUOT "pat" -> antiquot "pat" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | a = ANTIQUOT "anti" ->
- Qast.Node "PaAnt" [Qast.Loc; antiquot "anti" loc a]
- | "("; pl = a_list; ")" -> Qast.Node "PaTup" [Qast.Loc; pl] ] ]
- ;
- ipatt:
- [ [ a = ANTIQUOT "pat" -> antiquot "pat" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | a = ANTIQUOT "anti" ->
- Qast.Node "PaAnt" [Qast.Loc; antiquot "anti" loc a]
- | "("; pl = a_list; ")" -> Qast.Node "PaTup" [Qast.Loc; pl] ] ]
- ;
- ctyp: LEVEL "simple"
- [ [ a = ANTIQUOT "typ" -> antiquot "typ" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | "("; tl = a_list; ")" -> Qast.Node "TyTup" [Qast.Loc; tl] ] ]
- ;
- class_expr: LEVEL "simple"
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- class_str_item:
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- class_sig_item:
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- class_type:
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- expr: LEVEL "simple"
- [ [ "{<"; fel = a_list; ">}" -> Qast.Node "ExOvr" [Qast.Loc; fel] ] ]
- ;
- patt: LEVEL "simple"
- [ [ "#"; a = a_list -> Qast.Node "PaTyp" [Qast.Loc; a] ] ]
- ;
- a_list:
- [ [ a = ANTIQUOT "list" -> antiquot "list" loc a ] ]
- ;
- a_opt:
- [ [ a = ANTIQUOT "opt" -> antiquot "opt" loc a ] ]
- ;
- a_UIDENT:
- [ [ a = ANTIQUOT "uid" -> antiquot "uid" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | i = UIDENT -> Qast.Str i ] ]
- ;
- a_LIDENT:
- [ [ a = ANTIQUOT "lid" -> antiquot "lid" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | i = LIDENT -> Qast.Str i ] ]
- ;
- a_INT:
- [ [ a = ANTIQUOT "int" -> antiquot "int" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | s = INT -> Qast.Str s ] ]
- ;
- a_FLOAT:
- [ [ a = ANTIQUOT "flo" -> antiquot "flo" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | s = FLOAT -> Qast.Str s ] ]
- ;
- a_STRING:
- [ [ a = ANTIQUOT "str" -> antiquot "str" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | s = STRING -> Qast.Str s ] ]
- ;
- a_CHAR:
- [ [ a = ANTIQUOT "chr" -> antiquot "chr" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | s = CHAR -> Qast.Str s ] ]
- ;
- a_TILDEIDENT:
- [ [ "~"; a = ANTIQUOT -> antiquot "" loc a
- | s = TILDEIDENT -> Qast.Str s ] ]
- ;
- a_LABEL:
- [ [ s = LABEL -> Qast.Str s ] ]
- ;
- a_QUESTIONIDENT:
- [ [ "?"; a = ANTIQUOT -> antiquot "" loc a
- | s = QUESTIONIDENT -> Qast.Str s ] ]
- ;
- a_OPTLABEL:
- [ [ s = OPTLABEL -> Qast.Str s ] ]
- ;
-END;
-
-value apply_entry e =
- let f s = Grammar.Entry.parse e (Stream.of_string s) in
- let expr s = Qast.to_expr (f s) in
- let patt s = Qast.to_patt (f s) in
- Quotation.ExAst (expr, patt)
-;
-
-let sig_item_eoi = Grammar.Entry.create gram "signature item" in
-do {
- EXTEND
- sig_item_eoi:
- [ [ x = sig_item; EOI -> x ] ]
- ;
- END;
- Quotation.add "sig_item" (apply_entry sig_item_eoi)
-};
-
-let str_item_eoi = Grammar.Entry.create gram "structure item" in
-do {
- EXTEND
- str_item_eoi:
- [ [ x = str_item; EOI -> x ] ]
- ;
- END;
- Quotation.add "str_item" (apply_entry str_item_eoi)
-};
-
-let ctyp_eoi = Grammar.Entry.create gram "type" in
-do {
- EXTEND
- ctyp_eoi:
- [ [ x = ctyp; EOI -> x ] ]
- ;
- END;
- Quotation.add "ctyp" (apply_entry ctyp_eoi)
-};
-
-let patt_eoi = Grammar.Entry.create gram "pattern" in
-do {
- EXTEND
- patt_eoi:
- [ [ x = patt; EOI -> x ] ]
- ;
- END;
- Quotation.add "patt" (apply_entry patt_eoi)
-};
-
-let expr_eoi = Grammar.Entry.create gram "expression" in
-do {
- EXTEND
- expr_eoi:
- [ [ x = expr; EOI -> x ] ]
- ;
- END;
- Quotation.add "expr" (apply_entry expr_eoi)
-};
-
-let module_type_eoi = Grammar.Entry.create gram "module type" in
-do {
- EXTEND
- module_type_eoi:
- [ [ x = module_type; EOI -> x ] ]
- ;
- END;
- Quotation.add "module_type" (apply_entry module_type_eoi)
-};
-
-let module_expr_eoi = Grammar.Entry.create gram "module expression" in
-do {
- EXTEND
- module_expr_eoi:
- [ [ x = module_expr; EOI -> x ] ]
- ;
- END;
- Quotation.add "module_expr" (apply_entry module_expr_eoi)
-};
-
-let class_type_eoi = Grammar.Entry.create gram "class_type" in
-do {
- EXTEND
- class_type_eoi:
- [ [ x = class_type; EOI -> x ] ]
- ;
- END;
- Quotation.add "class_type" (apply_entry class_type_eoi)
-};
-
-let class_expr_eoi = Grammar.Entry.create gram "class_expr" in
-do {
- EXTEND
- class_expr_eoi:
- [ [ x = class_expr; EOI -> x ] ]
- ;
- END;
- Quotation.add "class_expr" (apply_entry class_expr_eoi)
-};
-
-let class_sig_item_eoi = Grammar.Entry.create gram "class_sig_item" in
-do {
- EXTEND
- class_sig_item_eoi:
- [ [ x = class_sig_item; EOI -> x ] ]
- ;
- END;
- Quotation.add "class_sig_item" (apply_entry class_sig_item_eoi)
-};
-
-let class_str_item_eoi = Grammar.Entry.create gram "class_str_item" in
-do {
- EXTEND
- class_str_item_eoi:
- [ [ x = class_str_item; EOI -> x ] ]
- ;
- END;
- Quotation.add "class_str_item" (apply_entry class_str_item_eoi)
-};
-
-let with_constr_eoi = Grammar.Entry.create gram "with constr" in
-do {
- EXTEND
- with_constr_eoi:
- [ [ x = with_constr; EOI -> x ] ]
- ;
- END;
- Quotation.add "with_constr" (apply_entry with_constr_eoi)
-};
-
-let row_field_eoi = Grammar.Entry.create gram "row_field" in
-do {
- EXTEND
- row_field_eoi:
- [ [ x = row_field; EOI -> x ] ]
- ;
- END;
- Quotation.add "row_field" (apply_entry row_field_eoi)
-};
View Lorry Controller Status