diff options
93 files changed, 8600 insertions, 2573 deletions
diff --git a/camlp4/camlp4/.cvsignore b/camlp4/camlp4/.cvsignore index a6f41a921..38b5e0906 100644 --- a/camlp4/camlp4/.cvsignore +++ b/camlp4/camlp4/.cvsignore @@ -1,5 +1,6 @@ *.cm[oia] camlp4 +*.lib crc.ml extract_crc phony diff --git a/camlp4/camlp4/Makefile b/camlp4/camlp4/Makefile index 30644288e..ef7d2589d 100644 --- a/camlp4/camlp4/Makefile +++ b/camlp4/camlp4/Makefile @@ -5,7 +5,7 @@ include ../config/Makefile SHELL=/bin/sh INCLUDES=-I ../odyl -I ../boot -I $(OTOP)/utils -I $(OTOP)/parsing -I $(OTOP)/otherlibs/dynlink -OCAMLCFLAGS= $(INCLUDES) -warn-error A +OCAMLCFLAGS= $(INCLUDES) -warn-error A $(INCLUDES) LINKFLAGS=$(INCLUDES) INTERFACES=-I $(OLIBDIR) Arg Array ArrayLabels Buffer Callback CamlinternalOO Char Complex Digest Filename Format Gc Genlex Hashtbl Int32 Int64 Lazy Lexing List ListLabels Map Marshal MoreLabels Nativeint Obj Oo Parsing Pervasives Printexc Printf Queue Random Scanf Set Sort Stack StdLabels Stream String StringLabels Sys Weak -I ../boot Extfold Extfun Fstream Gramext Grammar Plexer Stdpp Token -I $(OTOP)/utils Config Warnings -I $(OTOP)/parsing Asttypes Location Longident Parsetree -I . Ast2pt MLast Pcaml Quotation Spretty CAMLP4_INTF=$(OTOP)/utils/config.cmi $(OTOP)/utils/warnings.cmi $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmi $(OTOP)/parsing/longident.cmi $(OTOP)/parsing/parsetree.cmi ast2pt.cmi mLast.cmi pcaml.cmi spretty.cmi quotation.cmi @@ -36,14 +36,9 @@ camlp4.cma: $(CAMLP4_OBJS) camlp4.cmxa: $(CAMLP4_XOBJS) $(OCAMLOPT) $(LINKFLAGS) $(CAMLP4_XOBJS) -a -o camlp4.cmxa -crc.cmo: $(CAMLP4_INTF) - @OTOP=$(OTOP) EXE=$(EXE) ../tools/extract_crc.sh $(INTERFACES) > crc.ml - echo "let _ = Dynlink.add_available_units crc_unit_list" >> crc.ml - $(OCAMLC) $(OCAMLCFLAGS) -c crc.ml - clean:: rm -f *.cm* *.pp[io] *.o *.bak .*.bak *.out *.opt - rm -f $(CAMLP4) crc.ml + rm -f $(CAMLP4) depend: cp .depend .depend.bak @@ -62,11 +57,11 @@ compare: done install: - -$(MKDIR) $(BINDIR) - -$(MKDIR) $(LIBDIR)/camlp4 - cp $(CAMLP4) $(BINDIR)/. - cp mLast.mli quotation.mli ast2pt.mli pcaml.mli spretty.mli $(LIBDIR)/camlp4/. - cp mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi $(LIBDIR)/camlp4/. + -$(MKDIR) "$(BINDIR)" + -$(MKDIR) "$(LIBDIR)/camlp4" + cp $(CAMLP4) "$(BINDIR)/." + cp mLast.mli quotation.mli ast2pt.mli pcaml.mli spretty.mli "$(LIBDIR)/camlp4/." + cp mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi "$(LIBDIR)/camlp4/." cp camlp4.cma $(LIBDIR)/camlp4/. if [ -f camlp4.cmxa ]; \ then cp camlp4.cmxa camlp4.a $(LIBDIR)/camlp4/.; \ diff --git a/camlp4/camlp4/Makefile.Mac b/camlp4/camlp4/Makefile.Mac index 8ff854fb8..63a0e6bed 100644 --- a/camlp4/camlp4/Makefile.Mac +++ b/camlp4/camlp4/Makefile.Mac @@ -45,13 +45,8 @@ all Ä {CAMLP4} camlp4.cma Ä {CAMLP4_OBJS} {OCAMLC} {LINKFLAGS} {CAMLP4_OBJS} -a -o camlp4.cma -crc.cmo Ä {CAMLP4_INTF} - ::tools:extract_crc.mpw {INTERFACES} > crc.ml - echo "let _ = Dynlink.add_available_units crc_unit_list" >> crc.ml - {OCAMLC} {OCAMLCFLAGS} -c crc.ml - clean ÄÄ - delete -i {CAMLP4} crc.ml extract_crc + delete -i {CAMLP4} {dependrule} diff --git a/camlp4/camlp4/argl.ml b/camlp4/camlp4/argl.ml index 1ed4bcd06..8880f07fd 100644 --- a/camlp4/camlp4/argl.ml +++ b/camlp4/camlp4/argl.ml @@ -121,7 +121,7 @@ value loc_fmt = value print_location loc = if Pcaml.input_file.val <> "-" then - let (line, bp, ep) = Stdpp.line_of_loc Pcaml.input_file.val loc in + let (fname, line, bp, ep) = Stdpp.line_of_loc Pcaml.input_file.val loc in eprintf loc_fmt Pcaml.input_file.val line bp ep else eprintf "At location %d-%d\n" (fst loc) (snd loc) ; @@ -130,7 +130,7 @@ value print_warning loc s = do { print_location loc; eprintf "%s\n" s } ; -value process pa pr getdir = +value rec parse_file pa getdir useast = let name = Pcaml.input_file.val in do { Pcaml.warning.val := print_warning; @@ -141,28 +141,50 @@ value process pa pr getdir = try loop () where rec loop () = let (pl, stopped_at_directive) = pa cs in - if stopped_at_directive then do { - match getdir (List.rev pl) with - [ Some x -> - match x with - [ (loc, "load", Some <:expr< $str:s$ >>) -> - Odyl_main.loadfile s - | (loc, "directory", Some <:expr< $str:s$ >>) -> - Odyl_main.directory s - | (loc, _, _) -> - Stdpp.raise_with_loc loc (Stream.Error "bad directive") ] - | None -> () ]; + if stopped_at_directive then + let pl = + let rpl = List.rev pl in + match getdir rpl with + [ Some x -> + match x with + [ (loc, "load", Some <:expr< $str:s$ >>) -> + do { Odyl_main.loadfile s; pl } + | (loc, "directory", Some <:expr< $str:s$ >>) -> + do { Odyl_main.directory s; pl } + | (loc, "use", Some <:expr< $str:s$ >>) -> + List.rev_append rpl + [(useast loc s (use_file pa getdir useast s), loc)] + | (loc, _, _) -> + Stdpp.raise_with_loc loc (Stream.Error "bad directive") ] + | None -> pl ] + in pl @ loop () - } else pl with x -> do { clear (); raise x } in clear (); - pr phr + phr + } +and use_file pa getdir useast s = + let clear = + let v_input_file = Pcaml.input_file.val in + fun () -> Pcaml.input_file.val := v_input_file + in + do { + Pcaml.input_file.val := s; + try + let r = parse_file pa getdir useast in + do { clear (); r } + with e -> + do { clear (); raise e } } ; +value process pa pr getdir useast = + pr (parse_file pa getdir useast); + + value gind = fun [ [(MLast.SgDir loc n dp, _) :: _] -> Some (loc, n, dp) @@ -175,10 +197,13 @@ value gimd = | _ -> None ] ; +value usesig loc fname ast = MLast.SgUse loc fname ast; +value usestr loc fname ast = MLast.StUse loc fname ast; + value process_intf () = - process Pcaml.parse_interf.val Pcaml.print_interf.val gind; + process Pcaml.parse_interf.val Pcaml.print_interf.val gind usesig; value process_impl () = - process Pcaml.parse_implem.val Pcaml.print_implem.val gimd; + process Pcaml.parse_implem.val Pcaml.print_implem.val gimd usestr; type file_kind = [ Intf @@ -243,6 +268,24 @@ value print_usage_list l = l ; +value make_symlist l = + match l with + [ [] -> "<none>" + | [h :: t] -> (List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t) ^ "}" ] +; + +value print_usage_list l = + List.iter + (fun (key, spec, doc) -> + match spec with + [ Arg.Symbol symbs _ -> + let s = make_symlist symbs in + let synt = key ^ " " ^ s in + eprintf " %s %s\n" synt (align_doc synt doc) + | _ -> eprintf " %s %s\n" key (align_doc key doc) ] ) + l +; + value usage ini_sl ext_sl = do { eprintf "\ diff --git a/camlp4/camlp4/ast2pt.ml b/camlp4/camlp4/ast2pt.ml index 4690d83c7..484b8fca3 100644 --- a/camlp4/camlp4/ast2pt.ml +++ b/camlp4/camlp4/ast2pt.ml @@ -35,17 +35,19 @@ value string_of_string_token loc s = try Token.eval_string s with [ Failure _ as exn -> raise_with_loc loc exn ] ; +value glob_fname = ref ""; + value mkloc (bp, ep) = let loc_at n = { - Lexing.pos_fname = ""; - Lexing.pos_lnum = 1; + Lexing.pos_fname = glob_fname.val; + Lexing.pos_lnum = 1; (* ddr met -1 ici ??? *) Lexing.pos_bol = 0; Lexing.pos_cnum = n } in {Location.loc_start = loc_at bp; Location.loc_end = loc_at ep; - Location.loc_ghost = False} + Location.loc_ghost = False} (* ddr met: bp = 0 && ep = 0 *) ; value mkghloc (bp, ep) = @@ -245,6 +247,33 @@ value option f = | None -> None ] ; +value expr_of_lab loc lab = + fun + [ Some e -> e + | None -> ExLid loc lab ] +; + +value patt_of_lab loc lab = + fun + [ Some p -> p + | None -> PaLid loc lab ] +; + +value paolab loc lab peoo = + let lab = + match (lab, peoo) with + [ ("", Some (PaLid _ i | PaTyc _ (PaLid _ i) _, _)) -> i + | ("", _) -> error loc "bad ast" + | _ -> lab ] + in + let (p, eo) = + match peoo with + [ Some peo -> peo + | None -> (PaLid loc lab, None) ] + in + (lab, p, eo) +; + value rec same_type_expr ct ce = match (ct, ce) with [ (TyLid _ s1, ExLid _ s2) -> s1 = s2 @@ -398,7 +427,7 @@ value rec patt = | PaFlo loc s -> mkpat loc (Ppat_constant (Const_float s)) | PaLab loc _ _ -> error loc "labeled pattern not allowed here" | PaLid loc s -> mkpat loc (Ppat_var s) - | PaOlb loc _ _ _ -> error loc "labeled pattern not allowed here" + | PaOlb loc _ _ -> error loc "labeled pattern not allowed here" | PaOrp loc p1 p2 -> mkpat loc (Ppat_or (patt p1) (patt p2)) | PaRng loc p1 p2 -> match (p1, p2) with @@ -457,6 +486,18 @@ value class_info class_expr ci = pci_variance = variance} ; +value apply_with_var v x f = + let vx = v.val in + try + do { + v.val := x; + let r = f (); + v.val := vx; + r + } + with e -> do { v.val := vx; raise e } +; + value rec expr = fun [ ExAcc loc x (ExLid _ "val") -> @@ -547,9 +588,12 @@ value rec expr = let e3 = ExSeq loc el in let df = if df then Upto else Downto in mkexp loc (Pexp_for i (expr e1) (expr e2) df (expr e3)) - | ExFun loc [(PaLab _ lab p, w, e)] -> - mkexp loc (Pexp_function lab None [(patt p, when_expr e w)]) - | ExFun loc [(PaOlb _ lab p eo, w, e)] -> + | ExFun loc [(PaLab _ lab po, w, e)] -> + mkexp loc + (Pexp_function lab None + [(patt (patt_of_lab loc lab po), when_expr e w)]) + | ExFun loc [(PaOlb _ lab peoo, w, e)] -> + let (lab, p, eo) = paolab loc lab peoo in mkexp loc (Pexp_function ("?" ^ lab) (option expr eo) [(patt p, when_expr e w)]) | ExFun loc pel -> mkexp loc (Pexp_function "" None (List.map mkpwe pel)) @@ -567,12 +611,14 @@ value rec expr = | ExOlb loc _ _ -> error loc "labeled expression not allowed here" | ExOvr loc iel -> mkexp loc (Pexp_override (List.map mkideexp iel)) | ExRec loc lel eo -> - let eo = - match eo with - [ Some e -> Some (expr e) - | None -> None ] - in - mkexp loc (Pexp_record (List.map mklabexp lel) eo) + if lel = [] then error loc "empty record" + else + let eo = + match eo with + [ Some e -> Some (expr e) + | None -> None ] + in + mkexp loc (Pexp_record (List.map mklabexp lel) eo) | ExSeq loc el -> let rec loop = fun @@ -602,8 +648,8 @@ value rec expr = mkexp loc (Pexp_while (expr e1) (expr e2)) ] and label_expr = fun - [ ExLab loc lab e -> (lab, expr e) - | ExOlb loc lab e -> ("?" ^ lab, expr e) + [ ExLab loc lab eo -> (lab, expr (expr_of_lab loc lab eo)) + | ExOlb loc lab eo -> ("?" ^ lab, expr (expr_of_lab loc lab eo)) | e -> ("", expr e) ] and mkpe (p, e) = (patt p, expr e) and mkpwe (p, w, e) = (patt p, when_expr e w) @@ -658,6 +704,9 @@ and sig_item s l = | SgOpn loc id -> [mksig loc (Psig_open (long_id_of_string_list loc id)) :: l] | SgTyp loc tdl -> [mksig loc (Psig_type (List.map mktype_decl tdl)) :: l] + | SgUse loc fn sl -> + apply_with_var glob_fname fn + (fun () -> List.fold_right (fun (si, _) -> sig_item si) sl l) | SgVal loc n t -> [mksig loc (Psig_value n (mkvalue_desc t [])) :: l] ] and module_expr = fun @@ -696,6 +745,9 @@ and str_item s l = | StOpn loc id -> [mkstr loc (Pstr_open (long_id_of_string_list loc id)) :: l] | StTyp loc tdl -> [mkstr loc (Pstr_type (List.map mktype_decl tdl)) :: l] + | StUse loc fn sl -> + apply_with_var glob_fname fn + (fun () -> List.fold_right (fun (si, _) -> str_item si) sl l) | StVal loc rf pel -> [mkstr loc (Pstr_value (mkrf rf) (List.map mkpe pel)) :: l] ] and class_type = @@ -737,15 +789,13 @@ and class_expr = | CeCon loc id tl -> mkpcl loc (Pcl_constr (long_id_of_string_list loc id) (List.map ctyp tl)) - | CeFun loc (PaLab _ lab p) ce -> - mkpcl loc (Pcl_fun lab None (patt p) (class_expr ce)) - | CeFun loc (PaOlb _ lab p eo) ce -> - let eo = - match eo with - [ Some e -> Some (expr e) - | None -> None ] - in - mkpcl loc (Pcl_fun ("?" ^ lab) eo (patt p) (class_expr ce)) + | CeFun loc (PaLab _ lab po) ce -> + mkpcl loc + (Pcl_fun lab None (patt (patt_of_lab loc lab po)) (class_expr ce)) + | CeFun loc (PaOlb _ lab peoo) ce -> + let (lab, p, eo) = paolab loc lab peoo in + mkpcl loc + (Pcl_fun ("?" ^ lab) (option expr eo) (patt p) (class_expr ce)) | CeFun loc p ce -> mkpcl loc (Pcl_fun "" None (patt p) (class_expr ce)) | CeLet loc rf pel ce -> mkpcl loc (Pcl_let (mkrf rf) (List.map mkpe pel) (class_expr ce)) diff --git a/camlp4/camlp4/mLast.mli b/camlp4/camlp4/mLast.mli index f3f7fd80a..bde2e10a3 100644 --- a/camlp4/camlp4/mLast.mli +++ b/camlp4/camlp4/mLast.mli @@ -5,14 +5,19 @@ (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) (* $Id$ *) -(* Module [MLast]: abstract syntax tree *) +(* Module [MLast]: abstract syntax tree + + This is undocumented because the AST is not supposed to be used + directly; the good usage is to use the quotations representing + these values in concrete syntax (see the Camlp4 documentation). + See also the file q_MLast.ml in Camlp4 sources. *) type loc = (int * int); @@ -58,9 +63,9 @@ type patt = | PaChr of loc and string | PaInt of loc and string | PaFlo of loc and string - | PaLab of loc and string and patt + | PaLab of loc and string and option patt | PaLid of loc and string - | PaOlb of loc and string and patt and option expr + | PaOlb of loc and string and option (patt * option expr) | PaOrp of loc and patt and patt | PaRng of loc and patt and patt | PaRec of loc and list (patt * patt) @@ -86,14 +91,14 @@ and expr = | ExFun of loc and list (patt * option expr * expr) | ExIfe of loc and expr and expr and expr | ExInt of loc and string - | ExLab of loc and string and expr + | ExLab of loc and string and option expr | ExLaz of loc and expr | ExLet of loc and bool and list (patt * expr) and expr | ExLid of loc and string | ExLmd of loc and string and module_expr and expr | ExMat of loc and expr and list (patt * option expr * expr) | ExNew of loc and list string - | ExOlb of loc and string and expr + | ExOlb of loc and string and option expr | ExOvr of loc and list (string * expr) | ExRec of loc and list (patt * expr) and option expr | ExSeq of loc and list expr @@ -127,6 +132,7 @@ and sig_item = | SgMty of loc and string and module_type | SgOpn of loc and list string | SgTyp of loc and list type_decl + | SgUse of loc and string and list (sig_item * loc) | SgVal of loc and string and ctyp ] and with_constr = [ WcTyp of loc and list string and list (string * (bool * bool)) and ctyp @@ -151,6 +157,7 @@ and str_item = | StMty of loc and string and module_type | StOpn of loc and list string | StTyp of loc and list type_decl + | StUse of loc and string and list (str_item * loc) | StVal of loc and bool and list (patt * expr) ] and type_decl = ((loc * string) * list (string * (bool * bool)) * ctyp * list (ctyp * ctyp)) diff --git a/camlp4/camlp4/pcaml.ml b/camlp4/camlp4/pcaml.ml index a96451930..63c083ceb 100644 --- a/camlp4/camlp4/pcaml.ml +++ b/camlp4/camlp4/pcaml.ml @@ -14,11 +14,14 @@ value version = Sys.ocaml_version; +value syntax_name = ref ""; + value gram = Grammar.gcreate {Token.tok_func _ = failwith "no loaded parsing module"; Token.tok_using _ = (); Token.tok_removing _ = (); - Token.tok_match = fun []; Token.tok_text _ = ""} + Token.tok_match = fun []; Token.tok_text _ = ""; + Token.tok_comm = None} ; value interf = Grammar.Entry.create gram "interf"; @@ -33,6 +36,7 @@ value expr = Grammar.Entry.create gram "expr"; value patt = Grammar.Entry.create gram "patt"; value ctyp = Grammar.Entry.create gram "type"; value let_binding = Grammar.Entry.create gram "let_binding"; +value type_declaration = Grammar.Entry.create gram "type_declaration"; value class_sig_item = Grammar.Entry.create gram "class_sig_item"; value class_str_item = Grammar.Entry.create gram "class_str_item"; @@ -53,6 +57,24 @@ value sync = ref skip_to_eol; value input_file = ref ""; value output_file = ref None; +value warning_default_function (bp, ep) txt = + do { Printf.eprintf "<W> loc %d %d: %s\n" bp ep txt; flush stderr } +; + +value warning = ref warning_default_function; + +value apply_with_var v x f = + let vx = v.val in + try + do { + v.val := x; + let r = f (); + v.val := vx; + r + } + with e -> do { v.val := vx; raise e } +; + List.iter (fun (n, f) -> Quotation.add n f) [("id", Quotation.ExStr (fun _ s -> "$0:" ^ s ^ "$")); ("string", Quotation.ExStr (fun _ s -> "\"" ^ String.escaped s ^ "\""))]; @@ -65,13 +87,19 @@ type err_ctx = exception Qerror of string and err_ctx and exn; value expand_quotation loc expander shift name str = - try expander str with - [ Stdpp.Exc_located (p1, p2) exc -> - let exc1 = Qerror name Expanding exc in - raise (Stdpp.Exc_located (shift + p1, shift + p2) exc1) - | exc -> - let exc1 = Qerror name Expanding exc in - raise (Stdpp.Exc_located loc exc1) ] + let new_warning = + let warn = warning.val in + fun (bp, ep) txt -> warn (shift + bp, shift + ep) txt + in + apply_with_var warning new_warning + (fun () -> + try expander str with + [ Stdpp.Exc_located (p1, p2) exc -> + let exc1 = Qerror name Expanding exc in + raise (Stdpp.Exc_located (shift + p1, shift + p2) exc1) + | exc -> + let exc1 = Qerror name Expanding exc in + raise (Stdpp.Exc_located loc exc1) ]) ; value parse_quotation_result entry loc shift name str = @@ -159,6 +187,8 @@ value handle_patt_locate loc x = handle_locate loc patt_eoi patt_anti x; value expr_reloc = Reloc.expr; value patt_reloc = Reloc.patt; +value rename_id = ref (fun x -> x); + value find_line (bp, ep) str = find 0 1 0 where rec find i line col = if i == String.length str then (line, 0, col) @@ -251,17 +281,29 @@ value print_format str = do { Format.open_box 2; loop 0 0; Format.close_box () } ; +value print_file_failed file line char = + do { + Format.print_string ", file \""; + Format.print_string file; + Format.print_string "\", line "; + Format.print_int line; + Format.print_string ", char "; + Format.print_int char + } +; + value print_exn = fun [ Out_of_memory -> Format.print_string "Out of memory\n" + | Assert_failure (file, line, char) -> + do { + Format.print_string "Assertion failed"; + print_file_failed file line char; + } | Match_failure (file, line, char) -> do { - Format.print_string "Pattern matching failed, file "; - Format.print_string file; - Format.print_string ", line "; - Format.print_int line; - Format.print_string ", char "; - Format.print_int char + Format.print_string "Pattern matching failed"; + print_file_failed file line char; } | Stream.Error str -> print_format ("Parse error: " ^ str) | Stream.Failure -> Format.print_string "Parse failure" @@ -285,7 +327,7 @@ value print_exn = let arg = Obj.field (Obj.repr x) i in if not (Obj.is_block arg) then Format.print_int (Obj.magic arg : int) - else if Obj.tag arg = 252 then do { + else if Obj.tag arg = Obj.tag (Obj.repr "a") then do { Format.print_char '"'; Format.print_string (Obj.magic arg : string); Format.print_char '"' @@ -313,12 +355,6 @@ value report_error exn = | e -> print_exn exn ] ; -value warning_default_function (bp, ep) txt = - do { Printf.eprintf "<W> loc %d %d: %s\n" bp ep txt; flush stderr } -; - -value warning = ref warning_default_function; - value no_constructors_arity = Ast2pt.no_constructors_arity; (*value no_assert = ref False;*) @@ -348,25 +384,21 @@ and kont = Stream.t pretty value pr_str_item = {pr_fun = fun []; pr_levels = []}; value pr_sig_item = {pr_fun = fun []; pr_levels = []}; +value pr_module_type = {pr_fun = fun []; pr_levels = []}; +value pr_module_expr = {pr_fun = fun []; pr_levels = []}; value pr_expr = {pr_fun = fun []; pr_levels = []}; value pr_patt = {pr_fun = fun []; pr_levels = []}; value pr_ctyp = {pr_fun = fun []; pr_levels = []}; +value pr_class_sig_item = {pr_fun = fun []; pr_levels = []}; value pr_class_str_item = {pr_fun = fun []; pr_levels = []}; +value pr_class_type = {pr_fun = fun []; pr_levels = []}; +value pr_class_expr = {pr_fun = fun []; pr_levels = []}; value pr_expr_fun_args = ref Extfun.empty; -value not_impl name 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 - HVbox [: `S NO ("<pr_fun: not impl: " ^ name ^ "; " ^ desc ^ ">") :] -; - value pr_fun name pr lab = loop False pr.pr_levels where rec loop app = fun - [ [] -> fun x dg k -> not_impl name x + [ [] -> fun x dg k -> failwith ("unable to print " ^ name) | [lev :: levl] -> if app || lev.pr_label = lab then let next = loop True levl in @@ -377,10 +409,15 @@ value pr_fun name pr lab = pr_str_item.pr_fun := pr_fun "str_item" pr_str_item; pr_sig_item.pr_fun := pr_fun "sig_item" pr_sig_item; +pr_module_type.pr_fun := pr_fun "module_type" pr_module_type; +pr_module_expr.pr_fun := pr_fun "module_expr" pr_module_expr; pr_expr.pr_fun := pr_fun "expr" pr_expr; pr_patt.pr_fun := pr_fun "patt" pr_patt; pr_ctyp.pr_fun := pr_fun "ctyp" pr_ctyp; +pr_class_sig_item.pr_fun := pr_fun "class_sig_item" pr_class_sig_item; pr_class_str_item.pr_fun := pr_fun "class_str_item" pr_class_str_item; +pr_class_type.pr_fun := pr_fun "class_type" pr_class_type; +pr_class_expr.pr_fun := pr_fun "class_expr" pr_class_expr; value rec find_pr_level lab = fun @@ -403,4 +440,18 @@ value top_printer pr x = } ; +value buff = Buffer.create 73; +value buffer_char = Buffer.add_char buff; +value buffer_string = Buffer.add_string buff; +value buffer_newline () = Buffer.add_char buff '\n'; + +value string_of pr x = + do { + Buffer.clear buff; + Spretty.print_pretty buffer_char buffer_string buffer_newline "" "" 78 + (fun _ _ -> ("", 0, 0, 0)) 0 (pr.pr_fun "top" x "" [: :]); + Buffer.contents buff + } +; + value inter_phrases = ref None; diff --git a/camlp4/camlp4/pcaml.mli b/camlp4/camlp4/pcaml.mli index cd734d538..c87ebe39a 100644 --- a/camlp4/camlp4/pcaml.mli +++ b/camlp4/camlp4/pcaml.mli @@ -17,14 +17,29 @@ Hold variables to be set by language syntax extensions. Some of them are provided for quotations management. *) +value syntax_name : ref string; + (** {6 Parsers} *) value parse_interf : ref (Stream.t char -> (list (MLast.sig_item * MLast.loc) * bool)); value parse_implem : ref (Stream.t char -> (list (MLast.str_item * MLast.loc) * bool)); + (** Called when parsing an interface (mli file) or an implementation + (ml file) to build the syntax tree; the returned list contains the + phrases (signature items or structure items) and their locations; + the boolean tells that the parser has encountered a directive; in + this case, since the directive may change the syntax, the parsing + stops, the directive is evaluated, and this function is called + again. + These functions are references, because they can be changed to + use another technology than the Camlp4 extended grammars. By + default, they use the grammars entries [implem] and [interf] + defined below. *) value gram : Grammar.g; + (** Grammar variable of the OCaml language *) + value interf : Grammar.Entry.e (list (MLast.sig_item * MLast.loc) * bool); value implem : Grammar.Entry.e (list (MLast.str_item * MLast.loc) * bool); value top_phrase : Grammar.Entry.e (option MLast.str_item); @@ -37,12 +52,12 @@ value expr : Grammar.Entry.e MLast.expr; value patt : Grammar.Entry.e MLast.patt; value ctyp : Grammar.Entry.e MLast.ctyp; value let_binding : Grammar.Entry.e (MLast.patt * MLast.expr); +value type_declaration : Grammar.Entry.e MLast.type_decl; value class_sig_item : Grammar.Entry.e MLast.class_sig_item; value class_str_item : Grammar.Entry.e MLast.class_str_item; value class_expr : Grammar.Entry.e MLast.class_expr; value class_type : Grammar.Entry.e MLast.class_type; - (** Some grammar and entries of the language, set by [pa_o.cmo] and - [pa_r.cmo]. *) + (** Some entries of the language, set by [pa_o.cmo] and [pa_r.cmo]. *) value input_file : ref string; (** The file currently being parsed. *) @@ -78,6 +93,10 @@ value expr_reloc : value patt_reloc : (MLast.loc -> MLast.loc) -> int -> MLast.patt -> MLast.patt; +(** To possibly rename identifiers; parsers may call this function + when generating their identifiers; default = identity *) +value rename_id : ref (string -> string); + (** Allow user to catch exceptions in quotations *) type err_ctx = [ Finding | Expanding | ParsingResult of (int * int) and string | Locating ] @@ -106,18 +125,25 @@ and next 'a = 'a -> string -> kont -> pretty and kont = Stream.t pretty ; -value pr_str_item : printer_t MLast.str_item; value pr_sig_item : printer_t MLast.sig_item; +value pr_str_item : printer_t MLast.str_item; +value pr_module_type : printer_t MLast.module_type; +value pr_module_expr : printer_t MLast.module_expr; value pr_expr : printer_t MLast.expr; value pr_patt : printer_t MLast.patt; value pr_ctyp : printer_t MLast.ctyp; +value pr_class_sig_item : printer_t MLast.class_sig_item; value pr_class_str_item : printer_t MLast.class_str_item; +value pr_class_type : printer_t MLast.class_type; +value pr_class_expr : printer_t MLast.class_expr; + value pr_expr_fun_args : ref (Extfun.t MLast.expr (list MLast.patt * MLast.expr)); value find_pr_level : string -> list (pr_level 'a) -> pr_level 'a; value top_printer : printer_t 'a -> 'a -> unit; +value string_of : printer_t 'a -> 'a -> string; value inter_phrases : ref (option string); diff --git a/camlp4/camlp4/reloc.ml b/camlp4/camlp4/reloc.ml index 78cc626e5..00604d70e 100644 --- a/camlp4/camlp4/reloc.ml +++ b/camlp4/camlp4/reloc.ml @@ -74,10 +74,12 @@ value rec patt floc sh = | PaChr loc x1 -> PaChr (floc loc) x1 | PaInt loc x1 -> PaInt (floc loc) x1 | PaFlo loc x1 -> PaFlo (floc loc) x1 - | PaLab loc x1 x2 -> PaLab (floc loc) x1 (self x2) + | PaLab loc x1 x2 -> PaLab (floc loc) x1 (option_map self x2) | PaLid loc x1 -> PaLid (floc loc) x1 - | PaOlb loc x1 x2 x3 -> - PaOlb (floc loc) x1 (self x2) (option_map (expr floc sh) x3) + | PaOlb loc x1 x2 -> + PaOlb (floc loc) x1 + (option_map + (fun (x1, x2) -> (self x1, option_map (expr floc sh) x2)) x2) | PaOrp loc x1 x2 -> PaOrp (floc loc) (self x1) (self x2) | PaRng loc x1 x2 -> PaRng (floc loc) (self x1) (self x2) | PaRec loc x1 -> @@ -115,7 +117,7 @@ and expr floc sh = x1) | ExIfe loc x1 x2 x3 -> ExIfe (floc loc) (self x1) (self x2) (self x3) | ExInt loc x1 -> ExInt (floc loc) x1 - | ExLab loc x1 x2 -> ExLab (floc loc) x1 (self x2) + | ExLab loc x1 x2 -> ExLab (floc loc) x1 (option_map self x2) | ExLaz loc x1 -> ExLaz (floc loc) (self x1) | ExLet loc x1 x2 x3 -> ExLet (floc loc) x1 @@ -130,7 +132,7 @@ and expr floc sh = (patt floc sh x1, option_map self x2, self x3)) x2) | ExNew loc x1 -> ExNew (floc loc) x1 - | ExOlb loc x1 x2 -> ExOlb (floc loc) x1 (self x2) + | ExOlb loc x1 x2 -> ExOlb (floc loc) x1 (option_map self x2) | ExOvr loc x1 -> ExOvr (floc loc) (List.map (fun (x1, x2) -> (x1, self x2)) x1) | ExRec loc x1 x2 -> @@ -187,6 +189,7 @@ and sig_item floc sh = List.map (fun (x1, x2) -> (ctyp floc sh x1, ctyp floc sh x2)) x4)) x1) + | SgUse loc x1 x2 -> SgUse loc x1 x2 | SgVal loc x1 x2 -> SgVal (floc loc) x1 (ctyp floc sh x2) ] and with_constr floc sh = self where rec self = @@ -227,6 +230,7 @@ and str_item floc sh = List.map (fun (x1, x2) -> (ctyp floc sh x1, ctyp floc sh x2)) x4)) x1) + | StUse loc x1 x2 -> StUse loc x1 x2 | StVal loc x1 x2 -> StVal (floc loc) x1 (List.map (fun (x1, x2) -> (patt floc sh x1, expr floc sh x2)) x2) ] diff --git a/camlp4/compile/compile.ml b/camlp4/compile/compile.ml index 17261de64..5fff04b27 100644 --- a/camlp4/compile/compile.ml +++ b/camlp4/compile/compile.ml @@ -131,6 +131,15 @@ value parse_standard_symbol e rkont fkont ending_act = >> ; +value parse_symbol_no_failure e rkont fkont ending_act = + <:expr< + let $nth_patt_of_act ending_act$ = + try $e$ strm__ with [ Stream.Failure -> raise (Stream.Error "") ] + in + $rkont$ + >> +; + value rec contain_loc = fun [ <:expr< $lid:s$ >> -> s = "loc" @@ -194,7 +203,7 @@ and parse_symbol entry nlevn s rkont fkont ending_act = match s with [ Slist0 s -> let e = <:expr< P.list0 $symbol_parser entry nlevn s$ >> in - parse_standard_symbol e rkont fkont ending_act + parse_symbol_no_failure e rkont fkont ending_act | Slist1 s -> let e = <:expr< P.list1 $symbol_parser entry nlevn s$ >> in parse_standard_symbol e rkont fkont ending_act @@ -204,7 +213,7 @@ and parse_symbol entry nlevn s rkont fkont ending_act = P.list0sep $symbol_parser entry nlevn s$ $symbol_parser entry nlevn sep$ >> in - parse_standard_symbol e rkont fkont ending_act + parse_symbol_no_failure e rkont fkont ending_act | Slist1sep s sep -> let e = <:expr< @@ -214,7 +223,7 @@ and parse_symbol entry nlevn s rkont fkont ending_act = parse_standard_symbol e rkont fkont ending_act | Sopt s -> let e = <:expr< P.option $symbol_parser entry nlevn s$ >> in - parse_standard_symbol e rkont fkont ending_act + parse_symbol_no_failure e rkont fkont ending_act | Stree tree -> let kont = <:expr< raise Stream.Failure >> in let act_kont _ act = gen_let_loc loc (final_action act) in diff --git a/camlp4/config/Makefile-nt.cnf b/camlp4/config/Makefile-nt.cnf index 379f33850..e69de29bb 100644 --- a/camlp4/config/Makefile-nt.cnf +++ b/camlp4/config/Makefile-nt.cnf @@ -1,7 +0,0 @@ -EXE=.exe -OPT= -OTOP=../.. -OLIBDIR=$(OTOP)/boot -BINDIR=C:/ocaml/bin -LIBDIR=C:/ocaml/lib -MANDIR=C:/ocaml/man diff --git a/camlp4/etc/.cvsignore b/camlp4/etc/.cvsignore index 10e1e6044..92c764cac 100644 --- a/camlp4/etc/.cvsignore +++ b/camlp4/etc/.cvsignore @@ -1,5 +1,6 @@ *.cm[oia] camlp4o +camlp4sch camlp4o.opt mkcamlp4.sh mkcamlp4.mpw diff --git a/camlp4/etc/.depend b/camlp4/etc/.depend index 350e7f9c4..50e140c7b 100644 --- a/camlp4/etc/.depend +++ b/camlp4/etc/.depend @@ -1,3 +1,4 @@ +parserify.cmi: ../camlp4/mLast.cmi pa_extfold.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi pa_extfold.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx pa_extfun.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi @@ -26,8 +27,14 @@ pa_oop.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi pa_oop.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx pa_op.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi pa_op.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx +parserify.cmo: ../camlp4/mLast.cmi parserify.cmi +parserify.cmx: ../camlp4/mLast.cmi parserify.cmi pa_ru.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi pa_ru.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx +pa_scheme.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi +pa_scheme.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx +pa_schemer.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi +pa_schemer.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx pa_sml.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi pa_sml.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx pr_depend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi @@ -40,11 +47,21 @@ pr_null.cmo: ../camlp4/pcaml.cmi pr_null.cmx: ../camlp4/pcaml.cmx pr_o.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi pr_o.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx -pr_op.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi -pr_op.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx +pr_op_main.cmo: ../camlp4/mLast.cmi parserify.cmi ../camlp4/pcaml.cmi \ + ../camlp4/spretty.cmi +pr_op_main.cmx: ../camlp4/mLast.cmi parserify.cmx ../camlp4/pcaml.cmx \ + ../camlp4/spretty.cmx pr_r.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi pr_r.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx -pr_rp.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi -pr_rp.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx +pr_rp_main.cmo: ../camlp4/mLast.cmi parserify.cmi ../camlp4/pcaml.cmi \ + ../camlp4/spretty.cmi +pr_rp_main.cmx: ../camlp4/mLast.cmi parserify.cmx ../camlp4/pcaml.cmx \ + ../camlp4/spretty.cmx +pr_scheme.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi +pr_scheme.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx +pr_schp_main.cmo: ../camlp4/mLast.cmi parserify.cmi ../camlp4/pcaml.cmi \ + pr_scheme.cmo +pr_schp_main.cmx: ../camlp4/mLast.cmi parserify.cmx ../camlp4/pcaml.cmx \ + pr_scheme.cmx q_phony.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/quotation.cmi q_phony.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/quotation.cmx diff --git a/camlp4/etc/Makefile b/camlp4/etc/Makefile index 61f45a773..abd9f1159 100644 --- a/camlp4/etc/Makefile +++ b/camlp4/etc/Makefile @@ -4,21 +4,35 @@ include ../config/Makefile INCLUDES=-I ../camlp4 -I ../boot -I $(OTOP)/lex OCAMLCFLAGS=-warn-error A $(INCLUDES) -OBJS=q_phony.cmo pa_o.cmo pa_op.cmo pa_oop.cmo pa_ru.cmo pa_format.cmo pa_olabl.cmo pa_sml.cmo pa_lisp.cmo pa_extfold.cmo pa_extfun.cmo pa_fstream.cmo pa_ocamllex.cma pa_lefteval.cmo pr_r.cmo pr_rp.cmo pr_o.cmo pr_op.cmo pr_extend.cmo pr_extfun.cmo pr_null.cmo pr_depend.cmo +OBJS=q_phony.cmo pa_o.cmo pa_op.cmo pa_oop.cmo pa_ru.cmo pa_format.cmo pa_olabl.cmo pa_sml.cmo pa_lisp.cmo pa_scheme.cmo pa_extfold.cmo pa_extfun.cmo pa_fstream.cmo pa_lefteval.cmo pa_ifdef.cmo pr_r.cmo pr_rp.cmo pr_o.cmo pr_op.cmo pr_scheme.cmo pr_schemep.cmo pr_extend.cmo pr_extfun.cmo pr_null.cmo pr_depend.cmo INTF=pa_o.cmi CAMLP4OM=pa_o.cmo pa_op.cmo ../meta/pr_dump.cmo CAMLP4OMX=pa_o.cmx pa_op.cmx ../meta/pr_dump.cmx +CAMLP4SCHM=pa_scheme.cmo ../meta/pr_dump.cmo SHELL=/bin/sh -COUT=$(OBJS) camlp4o$(EXE) +COUT=$(OBJS) camlp4o$(EXE) camlp4sch$(EXE) COPT=camlp4o.opt all: $(COUT) mkcamlp4.sh opt: $(COPT) +pr_rp.cmo: parserify.cmo pr_rp_main.cmo + $(OCAMLC) parserify.cmo pr_rp_main.cmo -a -o $@ + +pr_op.cmo: parserify.cmo pr_op_main.cmo + $(OCAMLC) parserify.cmo pr_op_main.cmo -a -o $@ + +pr_schemep.cmo: parserify.cmo pr_schp_main.cmo + $(OCAMLC) parserify.cmo pr_schp_main.cmo -a -o $@ + camlp4o$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4OM) rm -f camlp4o$(EXE) cd ../camlp4; $(MAKE) CAMLP4=../etc/camlp4o$(EXE) CAMLP4M="-I ../etc $(CAMLP4OM)" +camlp4sch$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4SCHM) + rm -f camlp4sch$(EXE) + cd ../camlp4; $(MAKE) CAMLP4=../etc/camlp4sch$(EXE) CAMLP4M="-I ../etc $(CAMLP4SCHM)" + camlp4o.opt: $(CAMLP4OMX) rm -f camlp4o.opt cd ../camlp4; $(MAKE) optp4 CAMLP4OPT=../etc/camlp4o.opt CAMLP4M="-I ../etc $(CAMLP4OMX)" @@ -29,17 +43,27 @@ mkcamlp4.sh: mkcamlp4.sh.tpl pa_ocamllex.cma: pa_ocamllex.cmo $(OCAMLC) -I $(OTOP)/lex cset.cmo syntax.cmo table.cmo lexgen.cmo compact.cmo pa_ocamllex.cmo -a -o pa_ocamllex.cma +bootstrap_scheme: + @$(MAKE) bootstrap_l L=scheme | grep -v directory +compare_scheme: + @$(MAKE) compare_l L=scheme | grep -v directory bootstrap_lisp: - ../boot/camlp4 ./pa_lispr.cmo -I ../boot pa_extend.cmo q_MLast.cmo ./pr_r.cmo ./pr_extend.cmo ./pr_rp.cmo -phony_quot pa_lisp.ml | sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's|./pa_lispr.cmo|pa_r.cmo pa_rp.cmo|' -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' > tmp - mv pa_lispr.ml pa_lispr.ml.old - mv tmp pa_lispr.ml - + @$(MAKE) bootstrap_l L=lisp | grep -v directory compare_lisp: - ../boot/camlp4 ./pa_lispr.cmo -I ../boot pa_extend.cmo q_MLast.cmo ./pr_r.cmo ./pr_extend.cmo ./pr_rp.cmo -phony_quot pa_lisp.ml | sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's|./pa_lispr.cmo|pa_r.cmo pa_rp.cmo|' -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' | diff pa_lispr.ml - + @$(MAKE) compare_l L=lisp | grep -v directory + +bootstrap_l: + ../boot/camlp4 ./pa_$Lr.cmo ./q_phony.cmo -I ../boot pa_extend.cmo ./pr_r.cmo ./pr_extend.cmo ./pr_rp.cmo pa_$L.ml > tmp + mv pa_$Lr.ml pa_$Lr.ml.old + sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' -e 's|./pa_$Lr.cmo|pa_r.cmo pa_rp.cmo|' -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' tmp > pa_$Lr.ml + rm -f tmp + +compare_l: + ../boot/camlp4 ./pa_$Lr.cmo ./q_phony.cmo -I ../boot pa_extend.cmo ./pr_r.cmo ./pr_extend.cmo ./pr_rp.cmo pa_$L.ml | sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' -e 's|./pa_$Lr.cmo|pa_r.cmo pa_rp.cmo|' -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' | diff -c pa_$Lr.ml - clean:: rm -f *.cm* *.pp[io] *.o *.bak .*.bak *.out *.opt - rm -f mkcamlp4.sh camlp4o$(EXE) + rm -f mkcamlp4.sh camlp4o$(EXE) camlp4sch$(EXE) depend: cp .depend .depend.bak @@ -52,16 +76,17 @@ depend: get_promote: install: - -$(MKDIR) $(LIBDIR)/camlp4 $(BINDIR) - cp $(OBJS) $(LIBDIR)/camlp4/. - cp $(INTF) $(LIBDIR)/camlp4/. - cp lib.sml $(LIBDIR)/camlp4/. - cp camlp4o$(EXE) $(BINDIR)/. - if test -f $(COPT); then cp $(COPT) $(BINDIR)/.; fi - cp mkcamlp4.sh $(BINDIR)/mkcamlp4 - chmod a+x $(BINDIR)/mkcamlp4 + -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDI1R)" + cp $(OBJS) "$(LIBDIR)/camlp4/." + cp $(INTF) "$(LIBDIR)/camlp4/." + cp lib.sml "$(LIBDIR)/camlp4/." + cp camlp4o$(EXE) camlp4sch$(EXE) "$(BINDIR)/." + if test -f $(COPT); then cp $(COPT) "$(BINDIR)/."; fi + cp mkcamlp4.sh "$(BINDIR)/mkcamlp4" + chmod a+x "$(BINDIR)/mkcamlp4" pa_lisp.cmo: pa_lispr.cmo +pa_scheme.cmo: pa_schemer.cmo pa_ocamllex.cmo: pa_o.cmo pr_extend.cmo: pa_extfun.cmo pr_o.cmo: pa_extfun.cmo diff --git a/camlp4/etc/mkcamlp4.mpw.tpl b/camlp4/etc/mkcamlp4.mpw.tpl index 494e86af2..6b174bf6a 100644 --- a/camlp4/etc/mkcamlp4.mpw.tpl +++ b/camlp4/etc/mkcamlp4.mpw.tpl @@ -31,11 +31,3 @@ loop end shift end - -set CRC crc_temporary_file - -"{LIB}extract_crc" -I "{OLIB}" {INCL} {INTERFACES} > "{CRC}.ml" -echo "let _ = Dynlink.add_available_units crc_unit_list" >> "{CRC}.ml" -ocamlc -I "{LIB}" odyl.cma camlp4.cma "{CRC}.ml" {INCL} {OPTS} ¶ - odyl.cmo -linkall -delete -i "{CRC}.ml" "{CRC}.cmi" "{CRC}.cmo" diff --git a/camlp4/etc/mkcamlp4.sh.tpl b/camlp4/etc/mkcamlp4.sh.tpl index 5780f2ce8..00ae41fbd 100755 --- a/camlp4/etc/mkcamlp4.sh.tpl +++ b/camlp4/etc/mkcamlp4.sh.tpl @@ -22,11 +22,3 @@ while test "" != "$1"; do esac shift done - -CRC=crc_$$ -set -e -trap 'rm -f $CRC.ml $CRC.cmi $CRC.cmo' 0 2 -$OLIB/extract_crc -I $OLIB $INCL $INTERFACES > $CRC.ml -echo "let _ = Dynlink.add_available_units crc_unit_list" >> $CRC.ml -ocamlc -I $LIB odyl.cma camlp4.cma $CRC.ml $INCL $OPTS odyl.cmo -linkall -rm -f $CRC.ml $CRC.cmi $CRC.cmo diff --git a/camlp4/etc/pa_ifdef.ml b/camlp4/etc/pa_ifdef.ml new file mode 100644 index 000000000..bc80a7d55 --- /dev/null +++ b/camlp4/etc/pa_ifdef.ml @@ -0,0 +1,87 @@ +(* camlp4r pa_extend.cmo q_MLast.cmo *) +(* $Id$ *) + +(* This module is deprecated since version 3.07; use pa_macro.ml instead *) + +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_307"; "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/etc/pa_lefteval.ml b/camlp4/etc/pa_lefteval.ml index 30920cfe3..e96e8d34f 100644 --- a/camlp4/etc/pa_lefteval.ml +++ b/camlp4/etc/pa_lefteval.ml @@ -123,6 +123,20 @@ value left_eval_tuple loc expr el = <:expr< ($list:[e :: el]$) >> pel ; +value left_eval_record loc expr lel = + let el = List.map snd lel in + if not (may_depend_on_order el) then + let lel = List.map (fun (p, e) -> (p, expr e)) lel in + <:expr< { $list:lel$ } >> + else + let (pel, e, el) = gen_let_in loc expr el in + let e = + let lel = List.combine (List.map fst lel) [e :: el] in + <:expr< { $list:lel$ } >> + in + List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) e pel +; + value left_eval_assign loc expr e1 e2 = <:expr< $e1$ := $expr e2$ >>; (* scanning the input tree, calling "left_eval_*" functions if necessary *) @@ -148,8 +162,8 @@ value rec expr x = <:expr< match $expr e$ with [ $list:List.map match_assoc pwel$ ] >> | <:expr< try $e$ with [ $list:pwel$ ] >> -> <:expr< try $expr e$ with [ $list:List.map match_assoc pwel$ ] >> - | <:expr< let $rec:rf$ $list:pel$ in $e$ >> -> - <:expr< let $rec:rf$ $list:List.map let_binding pel$ in $expr e$ >> + | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> + <:expr< let $opt:rf$ $list:List.map let_binding pel$ in $expr e$ >> | <:expr< let module $s$ = $me$ in $e$ >> -> <:expr< let module $s$ = $module_expr me$ in $expr e$ >> | <:expr< if $e1$ then $e2$ else $e3$ >> -> @@ -163,6 +177,7 @@ value rec expr x = | <:expr< $e1$ && $e2$ >> -> <:expr< $expr e1$ && $expr e2$ >> | <:expr< $e1$ $e2$ >> -> left_eval_apply loc expr e1 e2 | <:expr< ($list:el$) >> -> left_eval_tuple loc expr el + | <:expr< { $list:lel$ } >> -> left_eval_record loc expr lel | <:expr< $e1$ := $e2$ >> -> left_eval_assign loc expr e1 e2 | <:expr< $_$ . $_$ >> | <:expr< $uid:_$ >> | <:expr< $lid:_$ >> | <:expr< $str:_$ >> | <:expr< $chr:_$ >> | <:expr< $int:_$ >> | @@ -188,8 +203,8 @@ and str_item x = match x with [ <:str_item< module $s$ = $me$ >> -> <:str_item< module $s$ = $module_expr me$ >> - | <:str_item< value $rec:rf$ $list:pel$ >> -> - <:str_item< value $rec:rf$ $list:List.map let_binding pel$ >> + | <:str_item< value $opt:rf$ $list:pel$ >> -> + <:str_item< value $opt:rf$ $list:List.map let_binding pel$ >> | <:str_item< declare $list:sil$ end >> -> <:str_item< declare $list:List.map str_item sil$ end >> | <:str_item< class $list:ce$ >> -> @@ -209,8 +224,8 @@ and class_expr x = and class_str_item x = let loc = MLast.loc_of_class_str_item x in match x with - [ <:class_str_item< value $mut:mf$ $s$ = $e$ >> -> - <:class_str_item< value $mut:mf$ $s$ = $expr e$ >> + [ <:class_str_item< value $opt:mf$ $s$ = $e$ >> -> + <:class_str_item< value $opt:mf$ $s$ = $expr e$ >> | <:class_str_item< method $s$ = $e$ >> -> <:class_str_item< method $s$ = $expr e$ >> | x -> not_impl "class_str_item" x ] diff --git a/camlp4/etc/pa_lisp.ml b/camlp4/etc/pa_lisp.ml index 6df3e9c97..653baf1ed 100644 --- a/camlp4/etc/pa_lisp.ml +++ b/camlp4/etc/pa_lisp.ml @@ -148,7 +148,8 @@ (Token.tok_using (lexer_using kwt)) (Token.tok_removing (lambda)) (Token.tok_match Token.default_match) - (Token.tok_text lexer_text))))) + (Token.tok_text lexer_text) + (Token.tok_comm None))))) ;; Building AST @@ -222,7 +223,7 @@ ((list (Satom _ Alid "rec") :: sel) (, True sel)) ((_) (, False sel)))) (lbs (value_binding_se sel))) - <:str_item< value $rec:r$ $list:lbs$ >>)) + <:str_item< value $opt:r$ $list:lbs$ >>)) ((Sexpr loc _) (let ((e (expr_se se))) <:str_item< $exp:e$ >>)))) @@ -277,7 +278,7 @@ ((list (Sexpr _ sel1) :: sel2) (let* ((lbs (List.map let_binding_se sel1)) (e (progn_se loc sel2))) - <:expr< let $rec:r$ $list:lbs$ in $e$ >>)) + <:expr< let $opt:r$ $list:lbs$ in $e$ >>)) ((list se :: _) (error se "let_binding")) ((_) (error_loc loc "let_binding"))))) ((Sexpr loc (list (Satom _ Alid "let*") :: sel)) diff --git a/camlp4/etc/pa_lispr.ml b/camlp4/etc/pa_lispr.ml index b68850bfe..fb150e209 100644 --- a/camlp4/etc/pa_lispr.ml +++ b/camlp4/etc/pa_lispr.ml @@ -142,7 +142,8 @@ value lexer_gmake () = let kwt = Hashtbl.create 89 in {Token.tok_func = Token.lexer_func_of_parser (lexer kwt); Token.tok_using = lexer_using kwt; Token.tok_removing = fun []; - Token.tok_match = Token.default_match; Token.tok_text = lexer_text} + Token.tok_match = Token.default_match; Token.tok_text = lexer_text; + Token.tok_comm = None} ; (* Building AST *) @@ -222,7 +223,7 @@ and str_item_se se = | _ -> (False, sel) ] in let lbs = value_binding_se sel in - <:str_item< value $rec:r$ $list:lbs$ >> + <:str_item< value $opt:r$ $list:lbs$ >> | Sexpr loc _ -> let e = expr_se se in <:str_item< $exp:e$ >> ] @@ -272,7 +273,7 @@ and expr_se = [ [Sexpr _ sel1 :: sel2] -> let lbs = List.map let_binding_se sel1 in let e = progn_se loc sel2 in - <:expr< let $rec:r$ $list:lbs$ in $e$ >> + <:expr< let $opt:r$ $list:lbs$ in $e$ >> | [se :: _] -> error se "let_binding" | _ -> error_loc loc "let_binding" ] | Sexpr loc [Satom _ Alid "let*" :: sel] -> diff --git a/camlp4/etc/pa_o.ml b/camlp4/etc/pa_o.ml index 7d83e09d5..19fa493bb 100644 --- a/camlp4/etc/pa_o.ml +++ b/camlp4/etc/pa_o.ml @@ -15,6 +15,7 @@ open Stdpp; open Pcaml; +Pcaml.syntax_name.val := "OCaml"; Pcaml.no_constructors_arity.val := True; do { @@ -34,6 +35,7 @@ do { 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; @@ -282,19 +284,43 @@ value test_typevar_list_dot = value constr_arity = ref [("Some", 1); ("Match_Failure", 1)]; -value rec constr_expr_arity = +value rec is_expr_constr_call = + fun + [ <:expr< $uid:_$ >> -> True + | <:expr< $uid:_$.$e$ >> -> is_expr_constr_call e + | <:expr< $e$ $_$ >> -> is_expr_constr_call e + | _ -> False ] +; + +value rec constr_expr_arity loc = fun [ <:expr< $uid:c$ >> -> try List.assoc c constr_arity.val with [ Not_found -> 0 ] - | <:expr< $uid:_$.$e$ >> -> constr_expr_arity e + | <:expr< $uid:_$.$e$ >> -> constr_expr_arity loc e + | <:expr< $e$ $_$ >> -> + if is_expr_constr_call e then + Stdpp.raise_with_loc loc (Stream.Error "currified constructor") + else 1 | _ -> 1 ] ; -value rec constr_patt_arity = +value rec is_patt_constr_call = + fun + [ <:patt< $uid:_$ >> -> True + | <:patt< $uid:_$.$p$ >> -> is_patt_constr_call p + | <:patt< $p$ $_$ >> -> is_patt_constr_call p + | _ -> False ] +; + +value rec constr_patt_arity loc = fun [ <:patt< $uid:c$ >> -> try List.assoc c constr_arity.val with [ Not_found -> 0 ] - | <:patt< $uid:_$.$p$ >> -> constr_patt_arity p + | <:patt< $uid:_$.$p$ >> -> constr_patt_arity loc p + | <:patt< $p$ $_$ >> -> + if is_patt_constr_call p then + Stdpp.raise_with_loc loc (Stream.Error "currified constructor") + else 1 | _ -> 1 ] ; @@ -322,11 +348,13 @@ value choose_tvar tpl = value rec patt_lid = fun - [ <:patt< $lid:i$ $p$ >> -> Some (i, [p]) - | <:patt< $p1$ $p2$ >> -> - match patt_lid p1 with - [ Some (i, pl) -> Some (i, [p2 :: pl]) - | None -> None ] + [ <:patt< $p1$ $p2$ >> -> + match p1 with + [ <:patt< $lid:i$ >> -> Some (MLast.loc_of_patt p1, i, [p2]) + | _ -> + match patt_lid p1 with + [ Some (loc, i, pl) -> Some (loc, i, [p2 :: pl]) + | None -> None ] ] | _ -> None ] ; @@ -375,7 +403,7 @@ Pcaml.sync.val := sync; 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; + class_expr class_sig_item class_str_item let_binding type_declaration; module_expr: [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->"; me = SELF -> @@ -412,12 +440,12 @@ EXTEND <:str_item< type $list:tdl$ >> | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; x = expr -> - let e = <:expr< let $rec:o2b r$ $list:l$ in $x$ >> in + let e = <:expr< let $opt:o2b r$ $list:l$ in $x$ >> in <:str_item< $exp:e$ >> | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and" -> match l with [ [(<:patt< _ >>, e)] -> <:str_item< $exp:e$ >> - | _ -> <:str_item< value $rec:o2b r$ $list:l$ >> ] + | _ -> <:str_item< value $opt:o2b r$ $list:l$ >> ] | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr -> <:str_item< let module $m$ = $mb$ in $e$ >> | e = expr -> <:str_item< $exp:e$ >> ] ] @@ -498,7 +526,7 @@ EXTEND | "expr1" [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; x = expr LEVEL "top" -> - <:expr< let $rec:o2b o$ $list:l$ in $x$ >> + <:expr< let $opt:o2b o$ $list:l$ in $x$ >> | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr LEVEL "top" -> <:expr< let module $m$ = $mb$ in $e$ >> @@ -576,7 +604,7 @@ EXTEND | "-."; e = SELF -> <:expr< $mkumin loc "-." e$ >> ] | "apply" LEFTA [ e1 = SELF; e2 = SELF -> - match constr_expr_arity e1 with + match constr_expr_arity loc e1 with [ 1 -> <:expr< $e1$ $e2$ >> | _ -> match e2 with @@ -622,6 +650,7 @@ EXTEND | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >> | "("; e = SELF; ")" -> <:expr< $e$ >> | "begin"; e = SELF; "end" -> <:expr< $e$ >> + | "begin"; "end" -> <:expr< () >> | x = LOCATE -> let x = try @@ -646,7 +675,7 @@ EXTEND let_binding: [ [ p = patt; e = fun_binding -> match patt_lid p with - [ Some (i, pl) -> + [ Some (loc, i, pl) -> let e = List.fold_left (fun e p -> <:expr< fun $p$ -> $e$ >>) e pl in @@ -709,7 +738,7 @@ EXTEND [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ] | LEFTA [ p1 = SELF; p2 = SELF -> - match constr_patt_arity p1 with + match constr_patt_arity loc p1 with [ 1 -> <:patt< $p1$ $p2$ >> | n -> let p2 = @@ -922,7 +951,7 @@ EXTEND [ "fun"; cfd = class_fun_def -> cfd | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in"; ce = SELF -> - <:class_expr< let $rec:o2b rf$ $list:lb$ in $ce$ >> ] + <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ] | "apply" LEFTA [ ce = SELF; e = expr LEVEL "label" -> <:class_expr< $ce$ $e$ >> ] @@ -948,9 +977,9 @@ EXTEND ; class_str_item: [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] -> - <:class_str_item< inherit $ce$ $as:pb$ >> - | "val"; (lab, mf, e) = cvalue -> - <:class_str_item< value $mut:mf$ $lab$ = $e$ >> + <:class_str_item< inherit $ce$ $opt:pb$ >> + | "val"; mf = OPT "mutable"; lab = label; e = cvalue_binding -> + <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >> | "method"; "private"; "virtual"; l = label; ":"; t = poly_type -> <:class_str_item< method virtual private $l$ : $t$ >> | "method"; "virtual"; "private"; l = label; ":"; t = poly_type -> @@ -969,15 +998,13 @@ EXTEND <:class_str_item< type $t1$ = $t2$ >> | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ] ; - cvalue: - [ [ mf = OPT "mutable"; l = label; "="; e = expr -> (l, o2b mf, e) - | mf = OPT "mutable"; l = label; ":"; t = ctyp; "="; e = expr -> - (l, o2b mf, <:expr< ($e$ : $t$) >>) - | mf = OPT "mutable"; l = label; ":"; t = ctyp; ":>"; t2 = ctyp; "="; - e = expr -> - (l, o2b mf, <:expr< ($e$ : $t$ :> $t2$) >>) - | mf = OPT "mutable"; l = label; ":>"; t = ctyp; "="; e = expr -> - (l, o2b mf, <:expr< ($e$ :> $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 ] ] @@ -1002,7 +1029,7 @@ EXTEND class_sig_item: [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >> | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> - <:class_sig_item< value $mut:o2b mf$ $l$ : $t$ >> + <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >> | "method"; "private"; "virtual"; l = label; ":"; t = poly_type -> <:class_sig_item< method virtual private $l$ : $t$ >> | "method"; "virtual"; "private"; l = label; ":"; t = poly_type -> @@ -1029,7 +1056,7 @@ EXTEND MLast.ciNam = n; MLast.ciExp = cs} ] ] ; (* Expressions *) - expr: LEVEL "apply" + expr: LEVEL "simple" [ LEFTA [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ] ; @@ -1052,7 +1079,7 @@ EXTEND (* Core types *) ctyp: LEVEL "simple" [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >> - | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $v$ > >> + | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $opt:v$ > >> | "<"; ">" -> <:ctyp< < > >> ] ] ; meth_list: @@ -1089,8 +1116,9 @@ EXTEND | i = QUESTIONIDENT; ":"; t = SELF -> <:ctyp< ? $i$ : $t$ >> ] ] ; ctyp: LEVEL "simple" - [ [ "["; OPT "|"; rfl = LIST0 row_field SEP "|"; "]" -> + [ [ "["; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> <:ctyp< [ = $list:rfl$ ] >> + | "["; ">"; "]" -> <:ctyp< [ > $list:[]$ ] >> | "["; ">"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> <:ctyp< [ > $list:rfl$ ] >> | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> @@ -1149,15 +1177,15 @@ EXTEND | i = QUESTIONIDENT; ":"; "("; p = patt; ":"; t = ctyp; "="; e = expr; ")" -> <:patt< ? $i$ : ( $p$ : $t$ = $e$ ) >> - | i = QUESTIONIDENT -> <:patt< ? $i$ : ($lid:i$) >> + | i = QUESTIONIDENT -> <:patt< ? $i$ >> | "?"; "("; i = LIDENT; "="; e = expr; ")" -> - <:patt< ? $i$ : ( $lid:i$ = $e$ ) >> + <:patt< ? ( $lid:i$ = $e$ ) >> | "?"; "("; i = LIDENT; ":"; t = ctyp; "="; e = expr; ")" -> - <:patt< ? $i$ : ( $lid:i$ : $t$ = $e$ ) >> + <:patt< ? ( $lid:i$ : $t$ = $e$ ) >> | "?"; "("; i = LIDENT; ")" -> <:patt< ? $i$ >> | "?"; "("; i = LIDENT; ":"; t = ctyp; ")" -> - <:patt< ? $i$ : ( $lid:i$ : $t$ ) >> ] ] + <:patt< ? ( $lid:i$ : $t$ ) >> ] ] ; class_type: [ [ i = lident_colon; t = ctyp LEVEL "ctyp1"; "->"; ct = SELF -> @@ -1208,3 +1236,6 @@ EXTEND | "#"; n = LIDENT; dp = OPT expr -> <:str_item< # $n$ $opt:dp$ >> ] ] ; END; + +Pcaml.add_option "-no_quot" (Arg.Set Plexer.no_quotations) + "Don't parse quotations, allowing to use, e.g. \"<:>\" as token"; diff --git a/camlp4/etc/pa_olabl.ml b/camlp4/etc/pa_olabl.ml index 7cb286781..d43b499df 100644 --- a/camlp4/etc/pa_olabl.ml +++ b/camlp4/etc/pa_olabl.ml @@ -568,7 +568,7 @@ module Plexer = let kwd_table = Hashtbl.create 301 in {tok_func = func kwd_table; tok_using = using_token kwd_table; tok_removing = removing_token kwd_table; - tok_match = Token.default_match; tok_text = text} + tok_match = Token.default_match; tok_text = text; tok_comm = None} ; end ; @@ -913,12 +913,12 @@ EXTEND <:str_item< type $list:tdl$ >> | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; x = expr -> - let e = <:expr< let $rec:o2b r$ $list:l$ in $x$ >> in + let e = <:expr< let $opt:o2b r$ $list:l$ in $x$ >> in <:str_item< $exp:e$ >> | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and" -> match l with [ [(<:patt< _ >>, e)] -> <:str_item< $exp:e$ >> - | _ -> <:str_item< value $rec:o2b r$ $list:l$ >> ] + | _ -> <:str_item< value $opt:o2b r$ $list:l$ >> ] | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr -> <:str_item< let module $m$ = $mb$ in $e$ >> | e = expr -> <:str_item< $exp:e$ >> ] ] @@ -996,7 +996,7 @@ EXTEND | "expr1" [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; x = expr LEVEL "top" -> - <:expr< let $rec:o2b o$ $list:l$ in $x$ >> + <:expr< let $opt:o2b o$ $list:l$ in $x$ >> | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr LEVEL "top" -> <:expr< let module $m$ = $mb$ in $e$ >> @@ -1452,7 +1452,7 @@ EXTEND [ "fun"; cfd = class_fun_def -> cfd | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in"; ce = SELF -> - <:class_expr< let $rec:o2b rf$ $list:lb$ in $ce$ >> ] + <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ] | "apply" NONA [ ce = SELF; e = expr LEVEL "label" -> <:class_expr< $ce$ $e$ >> ] @@ -1478,9 +1478,9 @@ EXTEND ; class_str_item: [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] -> - <:class_str_item< inherit $ce$ $as:pb$ >> + <:class_str_item< inherit $ce$ $opt:pb$ >> | "val"; (lab, mf, e) = cvalue -> - <:class_str_item< value $mut:mf$ $lab$ = $e$ >> + <:class_str_item< value $opt:mf$ $lab$ = $e$ >> | "method"; "private"; "virtual"; l = label; ":"; t = ctyp -> <:class_str_item< method virtual private $l$ : $t$ >> | "method"; "virtual"; "private"; l = label; ":"; t = ctyp -> @@ -1532,7 +1532,7 @@ EXTEND class_sig_item: [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >> | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> - <:class_sig_item< value $mut:o2b mf$ $l$ : $t$ >> + <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >> | "method"; "private"; "virtual"; l = label; ":"; t = ctyp -> <:class_sig_item< method virtual private $l$ : $t$ >> | "method"; "virtual"; "private"; l = label; ":"; t = ctyp -> @@ -1586,7 +1586,7 @@ EXTEND (* Core types *) ctyp: LEVEL "simple" [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >> - | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $v$ > >> + | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $opt:v$ > >> | "<"; ">" -> <:ctyp< < > >> ] ] ; meth_list: @@ -1766,8 +1766,8 @@ value rec subst v e = | <:expr< $chr:_$ >> -> e | <:expr< $str:_$ >> -> e | <:expr< $_$ . $_$ >> -> e - | <:expr< let $rec:rf$ $list:pel$ in $e$ >> -> - <:expr< let $rec:rf$ $list:List.map (subst_pe v) pel$ in $subst v 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 ] diff --git a/camlp4/etc/pa_op.ml b/camlp4/etc/pa_op.ml index 7ca28819b..5f2fff0fa 100644 --- a/camlp4/etc/pa_op.ml +++ b/camlp4/etc/pa_op.ml @@ -93,8 +93,8 @@ value rec subst v e = | <:expr< $chr:_$ >> -> e | <:expr< $str:_$ >> -> e | <:expr< $_$ . $_$ >> -> e - | <:expr< let $rec:rf$ $list:pel$ in $e$ >> -> - <:expr< let $rec:rf$ $list:List.map (subst_pe v) pel$ in $subst v 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 ] diff --git a/camlp4/etc/pa_ru.ml b/camlp4/etc/pa_ru.ml index 9e9522fa9..d3060c88c 100644 --- a/camlp4/etc/pa_ru.ml +++ b/camlp4/etc/pa_ru.ml @@ -36,7 +36,7 @@ EXTEND [ [e] -> e | _ -> <:expr< do { $list:el$ } >> ] in - [<:expr< let $rec:o2b o$ $list:l$ in $e$ >>] + [<:expr< let $opt:o2b o$ $list:l$ in $e$ >>] | e = expr; ";"; el = SELF -> let e = let loc = MLast.loc_of_expr e in <:expr< ($e$ : unit) >> in [e :: el] diff --git a/camlp4/etc/pa_scheme.ml b/camlp4/etc/pa_scheme.ml new file mode 100644 index 000000000..846a11e46 --- /dev/null +++ b/camlp4/etc/pa_scheme.ml @@ -0,0 +1,1002 @@ +; camlp4 ./pa_schemer.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo +; $Id$ + +(open Pcaml) +(open Stdpp) + +(type (choice 'a 'b) (sum (Left 'a) (Right 'b))) + +; Buffer + +(module Buff + (struct + (define buff (ref (String.create 80))) + (define (store len x) + (if (>= len (String.length buff.val)) + (:= buff.val (^ buff.val (String.create (String.length buff.val))))) + (:= buff.val.[len] x) + (succ len)) + (define (get len) (String.sub buff.val 0 len)))) + +; Lexer + +(definerec skip_to_eol + (parser + (((` (or '\n' '\r'))) ()) + (((` _) s) (skip_to_eol s)))) + +(define no_ident ['(' ')' '[' ']' '{' '}' ' ' '\t' '\n' '\r' ';']) + +(definerec (ident len) + (parser + (((` '.')) (values (Buff.get len) True)) + (((` x (not (List.mem x no_ident))) s) (ident (Buff.store len x) s)) + (() (values (Buff.get len) False)))) + +(define (identifier kwt (values s dot)) + (let ((con + (try (begin (: (Hashtbl.find kwt s) unit) "") + (Not_found + (match s.[0] + ((range 'A' 'Z') (if dot "UIDENTDOT" "UIDENT")) + (_ (if dot "LIDENTDOT" "LIDENT"))))))) + (values con s))) + +(definerec (string len) + (parser + (((` '"')) (Buff.get len)) + (((` '\\') (` c) s) (string (Buff.store (Buff.store len '\\') c) s)) + (((` x) s) (string (Buff.store len x) s)))) + +(definerec (end_exponent_part_under len) + (parser + (((` (as (range '0' '9') c)) s) + (end_exponent_part_under (Buff.store len c) s)) + (() (values "FLOAT" (Buff.get len))))) + +(define (end_exponent_part len) + (parser + (((` (as (range '0' '9') c)) s) + (end_exponent_part_under (Buff.store len c) s)) + (() (raise (Stream.Error "ill-formed floating-point constant"))))) + +(define (exponent_part len) + (parser + (((` (as (or '+' '-') c)) s) (end_exponent_part (Buff.store len c) s)) + (((a (end_exponent_part len))) a))) + +(definerec (decimal_part len) + (parser + (((` (as (range '0' '9') c)) s) (decimal_part (Buff.store len c) s)) + (((` (or 'e' 'E')) s) (exponent_part (Buff.store len 'E') s)) + (() (values "FLOAT" (Buff.get len))))) + +(definerec (number len) + (parser + (((` (as (range '0' '9') c)) s) (number (Buff.store len c) s)) + (((` '.') s) (decimal_part (Buff.store len '.') s)) + (((` (or 'e' 'E')) s) (exponent_part (Buff.store len 'E') s)) + (() (values "INT" (Buff.get len))))) + +(define binary + (parser + (((` (as (range '0' '1') c))) c))) + +(define octal + (parser + (((` (as (range '0' '7') c))) c))) + +(define hexa + (parser + (((` (as (or (range '0' '9') (range 'a' 'f') (range 'A' 'F')) c))) c))) + +(definerec (digits_under kind len) + (parser + (((d kind) s) (digits_under kind (Buff.store len d) s)) + (() (Buff.get len)))) + +(define (digits kind bp len) + (parser + (((d kind) s) (values "INT" (digits_under kind (Buff.store len d) s))) + ((s) ep + (raise_with_loc (values bp ep) (Failure "ill-formed integer constant"))))) + +(define (base_number kwt bp len) + (parser + (((` (or 'b' 'B')) s) (digits binary bp (Buff.store len 'b') s)) + (((` (or 'o' 'O')) s) (digits octal bp (Buff.store len 'o') s)) + (((` (or 'x' 'X')) s) (digits hexa bp (Buff.store len 'x') s)) + (((id (ident (Buff.store 0 '#')))) (identifier kwt id)))) + +(definerec (operator len) + (parser + (((` '.')) (Buff.get (Buff.store len '.'))) + (() (Buff.get len)))) + +(define (char_or_quote_id x) + (parser + (((` ''')) (values "CHAR" (String.make 1 x))) + ((s) ep + (if (List.mem x no_ident) + (Stdpp.raise_with_loc (values (- ep 2) (- ep 1)) + (Stream.Error "bad quote")) + (let* ((len (Buff.store (Buff.store 0 ''') x)) + ((values s dot) (ident len s))) + (values (if dot "LIDENTDOT" "LIDENT") s)))))) + +(definerec (char len) + (parser + (((` ''')) len) + (((` x) s) (char (Buff.store len x) s)))) + +(define quote + (parser + (((` '\\') (len (char (Buff.store 0 '\\')))) + (values "CHAR" (Buff.get len))) + (((` x) s) (char_or_quote_id x s)))) + +; The system with LIDENTDOT and UIDENTDOT is not great (it would be +; better to have a token DOT (actually SPACEDOT and DOT)) but it is +; the only way (that I have found) to have a good behaviour in the +; toplevel (not expecting tokens after a phrase). Drawbacks: 1/ to be +; complete, we should have STRINGDOT, RIGHTPARENDOT, and so on 2/ the +; parser rule with dot is right associative and we have to reverse +; the resulting tree (using the function leftify). +; This is a complicated issue: the behaviour of the OCaml toplevel +; is strange, anyway. For example, even without Camlp4, The OCaml +; toplevel accepts that: +; # let x = 32;; foo bar match let ) + +(definerec* + ((lexer kwt) + (parser + (((t (lexer0 kwt)) + (_ no_dot)) t))) + (no_dot + (parser + (((` '.')) ep + (Stdpp.raise_with_loc (values (- ep 1) ep) (Stream.Error "bad dot"))) + (() ()))) + ((lexer0 kwt) + (parser bp + (((` (or '\t' '\n' '\r')) s) (lexer0 kwt s)) + (((` ' ') s) (after_space kwt s)) + (((` ';') (_ skip_to_eol) s) (lexer kwt s)) + (((` '(')) (values (values "" "(") (values bp (+ bp 1)))) + (((` ')') s) ep (values (values "" (rparen s)) (values bp ep))) + (((` '[')) (values (values "" "[") (values bp (+ bp 1)))) + (((` ']')) (values (values "" "]") (values bp (+ bp 1)))) + (((` '{')) (values (values "" "{") (values bp (+ bp 1)))) + (((` '}')) (values (values "" "}") (values bp (+ bp 1)))) + (((` '"') (s (string 0))) ep + (values (values "STRING" s) (values bp ep))) + (((` ''') (tok quote)) ep (values tok (values bp ep))) + (((` '<') (tok (less kwt))) ep (values tok (values bp ep))) + (((` '-') (tok (minus kwt))) ep (values tok (values bp ep))) + (((` '~') (tok tilde)) ep (values tok (values bp ep))) + (((` '?') (tok question)) ep (values tok (values bp ep))) + (((` '#') (tok (base_number kwt bp (Buff.store 0 '0')))) ep + (values tok (values bp ep))) + (((` (as (range '0' '9') c)) (tok (number (Buff.store 0 c)))) ep + (values tok (values bp ep))) + (((` (as (or '+' '*' '/') c)) (id (operator (Buff.store 0 c)))) ep + (values (identifier kwt (values id False)) (values bp ep))) + (((` x) (id (ident (Buff.store 0 x)))) ep + (values (identifier kwt id) (values bp ep))) + (() (values (values "EOI" "") (values bp (+ bp 1)))))) + (rparen + (parser + (((` '.')) ").") + ((_) ")"))) + ((after_space kwt) + (parser + (((` '.')) ep (values (values "" ".") (values (- ep 1) ep))) + (((x (lexer0 kwt))) x))) + (tilde + (parser + (((` (as (range 'a' 'z') c)) ((values s dot) (ident (Buff.store 0 c)))) + (values "TILDEIDENT" s)) + (() (values "LIDENT" "~")))) + (question + (parser + (((` (as (range 'a' 'z') c)) ((values s dot) (ident (Buff.store 0 c)))) + (values "QUESTIONIDENT" s)) + (() (values "LIDENT" "?")))) + ((minus kwt) + (parser + (((` '.')) (identifier kwt (values "-." False))) + (((` (as (range '0' '9') c)) + (n (number (Buff.store (Buff.store 0 '-') c)))) ep n) + (((id (ident (Buff.store 0 '-')))) (identifier kwt id)))) + ((less kwt) + (parser + (((` ':') (lab (label 0)) (? (` '<') "'<' expected") (q (quotation 0))) + (values "QUOT" (^ lab ":" q))) + (((id (ident (Buff.store 0 '<')))) (identifier kwt id)))) + ((label len) + (parser + (((` (as (or (range 'a' 'z') (range 'A' 'Z') '_') c)) s) + (label (Buff.store len c) s)) + (() (Buff.get len)))) + ((quotation len) + (parser + (((` '>') s) (quotation_greater len s)) + (((` x) s) (quotation (Buff.store len x) s)) + (() (failwith "quotation not terminated")))) + ((quotation_greater len) + (parser + (((` '>')) (Buff.get len)) + (((a (quotation (Buff.store len '>')))) a)))) + +(define (lexer_using kwt (values con prm)) + (match con + ((or "CHAR" "EOI" "INT" "FLOAT" "LIDENT" "LIDENTDOT" "QUESTIONIDENT" + "QUOT" "STRING" "TILDEIDENT" "UIDENT" "UIDENTDOT") + ()) + ("ANTIQUOT" ()) + ("" (try (Hashtbl.find kwt prm) (Not_found (Hashtbl.add kwt prm ())))) + (_ + (raise + (Token.Error + (^ "the constructor \"" con "\" is not recognized by Plexer")))))) + +(define (lexer_text (values con prm)) + (cond + ((= con "") (^ "'"prm "'")) + ((= prm "") con) + (else (^ con " \"" prm "\"")))) + +(define (lexer_gmake ()) + (let ((kwt (Hashtbl.create 89))) + {(Token.tok_func (Token.lexer_func_of_parser (lexer kwt))) + (Token.tok_using (lexer_using kwt)) + (Token.tok_removing (lambda)) + (Token.tok_match Token.default_match) + (Token.tok_text lexer_text) + (Token.tok_comm None)})) + +; Building AST + +(type sexpr + (sum + (Sacc MLast.loc sexpr sexpr) + (Schar MLast.loc string) + (Sexpr MLast.loc (list sexpr)) + (Sint MLast.loc string) + (Sfloat MLast.loc string) + (Slid MLast.loc string) + (Slist MLast.loc (list sexpr)) + (Sqid MLast.loc string) + (Squot MLast.loc string string) + (Srec MLast.loc (list sexpr)) + (Sstring MLast.loc string) + (Stid MLast.loc string) + (Suid MLast.loc string))) + +(define loc_of_sexpr + (lambda_match + ((or (Sacc loc _ _) (Schar loc _) (Sexpr loc _) (Sint loc _) + (Sfloat loc _) (Slid loc _) (Slist loc _) (Sqid loc _) (Squot loc _ _) + (Srec loc _) (Sstring loc _) (Stid loc _) (Suid loc _)) + loc))) +(define (error_loc loc err) + (raise_with_loc loc (Stream.Error (^ err " expected")))) +(define (error se err) (error_loc (loc_of_sexpr se) err)) + +(define strm_n "strm__") +(define (peek_fun loc) <:expr< Stream.peek >>) +(define (junk_fun loc) <:expr< Stream.junk >>) + +(define assoc_left_parsed_op_list ["+" "*" "+." "*." "land" "lor" "lxor"]) +(define assoc_right_parsed_op_list ["and" "or" "^" "@"]) +(define and_by_couple_op_list ["=" "<>" "<" ">" "<=" ">=" "==" "!="]) + +(define (op_apply loc e1 e2) + (lambda_match + ("and" <:expr< $e1$ && $e2$ >>) + ("or" <:expr< $e1$ || $e2$ >>) + (x <:expr< $lid:x$ $e1$ $e2$ >>))) + +(define string_se + (lambda_match + ((Sstring loc s) s) + (se (error se "string")))) + +(define mod_ident_se + (lambda_match + ((Suid _ s) [(Pcaml.rename_id.val s)]) + ((Slid _ s) [(Pcaml.rename_id.val s)]) + (se (error se "mod_ident")))) + +(define (lident_expr loc s) + (if (&& (> (String.length s) 1) (= s.[0] '`')) + (let ((s (String.sub s 1 (- (String.length s) 1)))) + <:expr< ` $s$ >>) + <:expr< $lid:(Pcaml.rename_id.val s)$ >>)) + +(definerec* + (module_expr_se + (lambda_match + ((Sexpr loc [(Slid _ "functor") (Suid _ s) se1 se2]) + (let* ((s (Pcaml.rename_id.val s)) + (mt (module_type_se se1)) + (me (module_expr_se se2))) + <:module_expr< functor ($s$ : $mt$) -> $me$ >>)) + ((Sexpr loc [(Slid _ "struct") . sl]) + (let ((mel (List.map str_item_se sl))) + <:module_expr< struct $list:mel$ end >>)) + ((Sexpr loc [se1 se2]) + (let* ((me1 (module_expr_se se1)) + (me2 (module_expr_se se2))) + <:module_expr< $me1$ $me2$ >>)) + ((Suid loc s) <:module_expr< $uid:(Pcaml.rename_id.val s)$ >>) + (se (error se "module expr")))) + (module_type_se + (lambda_match + ((Sexpr loc [(Slid _ "functor") (Suid _ s) se1 se2]) + (let* ((s (Pcaml.rename_id.val s)) + (mt1 (module_type_se se1)) + (mt2 (module_type_se se2))) + <:module_type< functor ($s$ : $mt1$) -> $mt2$ >>)) + ((Sexpr loc [(Slid _ "sig") . sel]) + (let ((sil (List.map sig_item_se sel))) + <:module_type< sig $list:sil$ end >>)) + ((Sexpr loc [(Slid _ "with") se (Sexpr _ sel)]) + (let* ((mt (module_type_se se)) + (wcl (List.map with_constr_se sel))) + <:module_type< $mt$ with $list:wcl$ >>)) + ((Suid loc s) <:module_type< $uid:(Pcaml.rename_id.val s)$ >>) + (se (error se "module type")))) + (with_constr_se + (lambda_match + ((Sexpr loc [(Slid _ "type") se1 se2]) + (let* ((tn (mod_ident_se se1)) + (te (ctyp_se se2))) + (MLast.WcTyp loc tn [] te))) + (se (error se "with constr")))) + (sig_item_se + (lambda_match + ((Sexpr loc [(Slid _ "type") . sel]) + (let ((tdl (type_declaration_list_se sel))) + <:sig_item< type $list:tdl$ >>)) + ((Sexpr loc [(Slid _ "exception") (Suid _ c) . sel]) + (let* ((c (Pcaml.rename_id.val c)) + (tl (List.map ctyp_se sel))) + <:sig_item< exception $c$ of $list:tl$ >>)) + ((Sexpr loc [(Slid _ "value") (Slid _ s) se]) + (let* ((s (Pcaml.rename_id.val s)) + (t (ctyp_se se))) + <:sig_item< value $s$ : $t$ >>)) + ((Sexpr loc [(Slid _ "external") (Slid _ i) se . sel]) + (let* ((i (Pcaml.rename_id.val i)) + (pd (List.map string_se sel)) + (t (ctyp_se se))) + <:sig_item< external $i$ : $t$ = $list:pd$ >>)) + ((Sexpr loc [(Slid _ "module") (Suid _ s) se]) + (let* ((s (Pcaml.rename_id.val s)) + (mb (module_type_se se))) + <:sig_item< module $s$ : $mb$ >>)) + ((Sexpr loc [(Slid _ "moduletype") (Suid _ s) se]) + (let* ((s (Pcaml.rename_id.val s)) + (mt (module_type_se se))) + <:sig_item< module type $s$ = $mt$ >>)) + (se (error se "sig item")))) + ((str_item_se se) + (match se + ((Sexpr loc [(Slid _ "open") se]) + (let ((s (mod_ident_se se))) <:str_item< open $s$ >>)) + ((Sexpr loc [(Slid _ "type") . sel]) + (let ((tdl (type_declaration_list_se sel))) + <:str_item< type $list:tdl$ >>)) + ((Sexpr loc [(Slid _ "exception") (Suid _ c) . sel]) + (let* ((c (Pcaml.rename_id.val c)) + (tl (List.map ctyp_se sel))) + <:str_item< exception $c$ of $list:tl$ >>)) + ((Sexpr loc [(Slid _ (as (or "define" "definerec") r)) se . sel]) + (let* ((r (= r "definerec")) + ((values p e) (fun_binding_se se (begin_se loc sel)))) + <:str_item< value $opt:r$ $p$ = $e$ >>)) + ((Sexpr loc [(Slid _ (as (or "define*" "definerec*") r)) . sel]) + (let* ((r (= r "definerec*")) + (lbs (List.map let_binding_se sel))) + <:str_item< value $opt:r$ $list:lbs$ >>)) + ((Sexpr loc [(Slid _ "external") (Slid _ i) se . sel]) + (let* ((i (Pcaml.rename_id.val i)) + (pd (List.map string_se sel)) + (t (ctyp_se se))) + <:str_item< external $i$ : $t$ = $list:pd$ >>)) + ((Sexpr loc [(Slid _ "module") (Suid _ i) se]) + (let* ((i (Pcaml.rename_id.val i)) + (mb (module_binding_se se))) + <:str_item< module $i$ = $mb$ >>)) + ((Sexpr loc [(Slid _ "moduletype") (Suid _ s) se]) + (let* ((s (Pcaml.rename_id.val s)) + (mt (module_type_se se))) + <:str_item< module type $s$ = $mt$ >>)) + (_ + (let* ((loc (loc_of_sexpr se)) + (e (expr_se se))) + <:str_item< $exp:e$ >>)))) + ((module_binding_se se) (module_expr_se se)) + (expr_se + (lambda_match + ((Sacc loc se1 se2) + (let ((e1 (expr_se se1))) + (match se2 + ((Slist loc [se2]) + (let ((e2 (expr_se se2))) <:expr< $e1$ .[ $e2$ ] >>)) + ((Sexpr loc [se2]) + (let ((e2 (expr_se se2))) <:expr< $e1$ .( $e2$ ) >>)) + (_ (let ((e2 (expr_se se2))) <:expr< $e1$ . $e2$ >>))))) + ((Slid loc s) (lident_expr loc s)) + ((Suid loc s) <:expr< $uid:(Pcaml.rename_id.val s)$ >>) + ((Sint loc s) <:expr< $int:s$ >>) + ((Sfloat loc s) <:expr< $flo:s$ >>) + ((Schar loc s) <:expr< $chr:s$ >>) + ((Sstring loc s) <:expr< $str:s$ >>) + ((Stid loc s) <:expr< ~ $(Pcaml.rename_id.val s)$ >>) + ((Sqid loc s) <:expr< ? $(Pcaml.rename_id.val s)$ >>) + ((Sexpr loc []) <:expr< () >>) + ((when (Sexpr loc [(Slid _ s) e1 . (as [_ . _] sel)]) + (List.mem s assoc_left_parsed_op_list)) + (letrec + (((loop e1) + (lambda_match + ([] e1) + ([e2 . el] (loop (op_apply loc e1 e2 s) el))))) + (loop (expr_se e1) (List.map expr_se sel)))) + ((when (Sexpr loc [(Slid _ s) . (as [_ _ . _] sel)]) + (List.mem s assoc_right_parsed_op_list)) + (letrec + ((loop + (lambda_match + ([] + (assert False)) + ([e1] e1) + ([e1 . el] (let ((e2 (loop el))) (op_apply loc e1 e2 s)))))) + (loop (List.map expr_se sel)))) + ((when (Sexpr loc [(Slid _ s) . (as [_ _ . _] sel)]) + (List.mem s and_by_couple_op_list)) + (letrec + ((loop + (lambda_match + ((or [] [_]) (assert False)) + ([e1 e2] <:expr< $lid:s$ $e1$ $e2$ >>) + ([e1 . (as [e2 _ . _] el)] + (let* ((a1 (op_apply loc e1 e2 s)) + (a2 (loop el))) + <:expr< $a1$ && $a2$ >>))))) + (loop (List.map expr_se sel)))) + ((Sexpr loc [(Stid _ s) se]) + (let ((e (expr_se se))) <:expr< ~ $s$ : $e$ >>)) + ((Sexpr loc [(Slid _ "-") se]) + (let ((e (expr_se se))) <:expr< - $e$ >>)) + ((Sexpr loc [(Slid _ "if") se se1]) + (let* ((e (expr_se se)) + (e1 (expr_se se1))) + <:expr< if $e$ then $e1$ else () >>)) + ((Sexpr loc [(Slid _ "if") se se1 se2]) + (let* ((e (expr_se se)) + (e1 (expr_se se1)) + (e2 (expr_se se2))) + <:expr< if $e$ then $e1$ else $e2$ >>)) + ((Sexpr loc [(Slid _ "cond") . sel]) + (letrec + ((loop + (lambda_match + ([(Sexpr loc [(Slid _ "else") . sel])] (begin_se loc sel)) + ([(Sexpr loc [se1 . sel1]) . sel] + (let* ((e1 (expr_se se1)) + (e2 (begin_se loc sel1)) + (e3 (loop sel))) + <:expr< if $e1$ then $e2$ else $e3$ >>)) + ([] <:expr< () >>) + ([se . _] (error se "cond clause"))))) + (loop sel))) + ((Sexpr loc [(Slid _ "while") se . sel]) + (let* ((e (expr_se se)) + (el (List.map expr_se sel))) + <:expr< while $e$ do { $list:el$ } >>)) + ((Sexpr loc [(Slid _ "for") (Slid _ i) se1 se2 . sel]) + (let* ((i (Pcaml.rename_id.val i)) + (e1 (expr_se se1)) + (e2 (expr_se se2)) + (el (List.map expr_se sel))) + <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >>)) + ((Sexpr loc [(Slid loc1 "lambda")]) <:expr< fun [] >>) + ((Sexpr loc [(Slid loc1 "lambda") sep . sel]) + (let ((e (begin_se loc1 sel))) + (match (ipatt_opt_se sep) + ((Left p) <:expr< fun $p$ -> $e$ >>) + ((Right (values se sel)) + (List.fold_right + (lambda (se e) + (let ((p (ipatt_se se))) <:expr< fun $p$ -> $e$ >>)) + [se . sel] e))))) + ((Sexpr loc [(Slid _ "lambda_match") . sel]) + (let ((pel (List.map (match_case loc) sel))) + <:expr< fun [ $list:pel$ ] >>)) + ((Sexpr loc [(Slid _ (as (or "let" "letrec") r)) . sel]) + (match sel + ([(Sexpr _ sel1) . sel2] + (let* ((r (= r "letrec")) + (lbs (List.map let_binding_se sel1)) + (e (begin_se loc sel2))) + <:expr< let $opt:r$ $list:lbs$ in $e$ >>)) + ([(Slid _ n) (Sexpr _ sl) . sel] + (let* ((n (Pcaml.rename_id.val n)) + ((values pl el) + (List.fold_right + (lambda (se (values pl el)) + (match se + ((Sexpr _ [se1 se2]) + (values [(patt_se se1) . pl] + [(expr_se se2) . el])) + (se (error se "named let")))) + sl (values [] []))) + (e1 + (List.fold_right + (lambda (p e) <:expr< fun $p$ -> $e$ >>) + pl (begin_se loc sel))) + (e2 + (List.fold_left + (lambda (e1 e2) <:expr< $e1$ $e2$ >>) + <:expr< $lid:n$ >> el))) + <:expr< let rec $lid:n$ = $e1$ in $e2$ >>)) + ([se . _] (error se "let_binding")) + (_ (error_loc loc "let_binding")))) + ((Sexpr loc [(Slid _ "let*") . sel]) + (match sel + ([(Sexpr _ sel1) . sel2] + (List.fold_right + (lambda (se ek) + (let (((values p e) (let_binding_se se))) + <:expr< let $p$ = $e$ in $ek$ >>)) + sel1 (begin_se loc sel2))) + ([se . _] (error se "let_binding")) + (_ (error_loc loc "let_binding")))) + ((Sexpr loc [(Slid _ "match") se . sel]) + (let* ((e (expr_se se)) + (pel (List.map (match_case loc) sel))) + <:expr< match $e$ with [ $list:pel$ ] >>)) + ((Sexpr loc [(Slid _ "parser") . sel]) + (let ((e + (match sel + ([(as (Slid _ _) se) . sel] + (let* ((p (patt_se se)) + (pc (parser_cases_se loc sel))) + <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >>)) + (_ (parser_cases_se loc sel))))) + <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >>)) + ((Sexpr loc [(Slid _ "match_with_parser") se . sel]) + (let* ((me (expr_se se)) + ((values bpo sel) + (match sel + ([(as (Slid _ _) se) . sel] (values (Some (patt_se se)) sel)) + (_ (values None sel)))) + (pc (parser_cases_se loc sel)) + (e + (match bpo + ((Some bp) + <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>) + (None pc)))) + (match me + ((when <:expr< $lid:x$ >> (= x strm_n)) e) + (_ <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >>)))) + ((Sexpr loc [(Slid _ "try") se . sel]) + (let* ((e (expr_se se)) + (pel (List.map (match_case loc) sel))) + <:expr< try $e$ with [ $list:pel$ ] >>)) + ((Sexpr loc [(Slid _ "begin") . sel]) + (let ((el (List.map expr_se sel))) <:expr< do { $list:el$ } >>)) + ((Sexpr loc [(Slid _ ":=") se1 se2]) + (let* ((e1 (expr_se se1)) + (e2 (expr_se se2))) + <:expr< $e1$ := $e2$ >>)) + ((Sexpr loc [(Slid _ "values") . sel]) + (let ((el (List.map expr_se sel))) <:expr< ( $list:el$ ) >>)) + ((Srec loc [(Slid _ "with") se . sel]) + (let* ((e (expr_se se)) + (lel (List.map (label_expr_se loc) sel))) + <:expr< { ($e$) with $list:lel$ } >>)) + ((Srec loc sel) + (let ((lel (List.map (label_expr_se loc) sel))) + <:expr< { $list:lel$ } >>)) + ((Sexpr loc [(Slid _ ":") se1 se2]) + (let* ((e (expr_se se1)) (t (ctyp_se se2))) <:expr< ( $e$ : $t$ ) >>)) + ((Sexpr loc [se]) (let ((e (expr_se se))) <:expr< $e$ () >>)) + ((Sexpr loc [(Slid _ "assert") se]) + (let ((e (expr_se se))) <:expr< assert $e$ >>)) + ((Sexpr loc [(Slid _ "lazy") se]) + (let ((e (expr_se se))) <:expr< lazy $e$ >>)) + ((Sexpr loc [se . sel]) + (List.fold_left + (lambda (e se) (let ((e1 (expr_se se))) <:expr< $e$ $e1$ >>)) + (expr_se se) sel)) + ((Slist loc sel) + (letrec ((loop + (lambda_match + ([] <:expr< [] >>) + ([se1 (Slid _ ".") se2] + (let* ((e (expr_se se1)) + (el (expr_se se2))) + <:expr< [$e$ :: $el$] >>)) + ([se . sel] + (let* ((e (expr_se se)) + (el (loop sel))) + <:expr< [$e$ :: $el$] >>))))) + (loop sel))) + ((Squot loc typ txt) + (Pcaml.handle_expr_quotation loc (values typ txt))))) + ((begin_se loc) + (lambda_match + ([] <:expr< () >>) + ([se] (expr_se se)) + ((sel) + (let* ((el (List.map expr_se sel)) + (loc (values (fst (loc_of_sexpr (List.hd sel))) (snd loc)))) + <:expr< do { $list:el$ } >>)))) + (let_binding_se + (lambda_match + ((Sexpr loc [se . sel]) + (let ((e (begin_se loc sel))) + (match (ipatt_opt_se se) + ((Left p) (values p e)) + ((Right _) (fun_binding_se se e))))) + (se (error se "let_binding")))) + ((fun_binding_se se e) + (match se + ((Sexpr _ [(Slid _ "values") . _]) (values (ipatt_se se) e)) + ((Sexpr _ [(Slid loc s) . sel]) + (let* ((s (Pcaml.rename_id.val s)) + (e + (List.fold_right + (lambda (se e) + (let* ((loc + (values (fst (loc_of_sexpr se)) + (snd (MLast.loc_of_expr e)))) + (p (ipatt_se se))) + <:expr< fun $p$ -> $e$ >>)) + sel e)) + (p <:patt< $lid:s$ >>)) + (values p e))) + ((_) (values (ipatt_se se) e)))) + ((match_case loc) + (lambda_match + ((Sexpr loc [(Sexpr _ [(Slid _ "when") se sew]) . sel]) + (values (patt_se se) (Some (expr_se sew)) (begin_se loc sel))) + ((Sexpr loc [se . sel]) + (values (patt_se se) None (begin_se loc sel))) + (se (error se "match_case")))) + ((label_expr_se loc) + (lambda_match + ((Sexpr _ [se1 se2]) (values (patt_se se1) (expr_se se2))) + (se (error se "label_expr")))) + ((label_patt_se loc) + (lambda_match + ((Sexpr _ [se1 se2]) (values (patt_se se1) (patt_se se2))) + (se (error se "label_patt")))) + ((parser_cases_se loc) + (lambda_match + ([] <:expr< raise Stream.Failure >>) + ([(Sexpr loc [(Sexpr _ spsel) . act]) . sel] + (let* ((ekont (lambda _ (parser_cases_se loc sel))) + (act (match act + ([se] (expr_se se)) + ([sep se] + (let* ((p (patt_se sep)) + (e (expr_se se))) + <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >>)) + (_ (error_loc loc "parser_case"))))) + (stream_pattern_se loc act ekont spsel))) + ([se . _] + (error se "parser_case")))) + ((stream_pattern_se loc act ekont) + (lambda_match + ([] act) + ([se . sel] + (let* ((ckont (lambda err <:expr< raise (Stream.Error $err$) >>)) + (skont (stream_pattern_se loc act ckont sel))) + (stream_pattern_component skont ekont <:expr< "" >> se))))) + ((stream_pattern_component skont ekont err) + (lambda_match + ((Sexpr loc [(Slid _ "`") se . wol]) + (let* ((wo (match wol + ([se] (Some (expr_se se))) + ([] None) + (_ (error_loc loc "stream_pattern_component")))) + (e (peek_fun loc)) + (p (patt_se se)) + (j (junk_fun loc)) + (k (ekont err))) + <:expr< match $e$ $lid:strm_n$ with + [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ } + | _ -> $k$ ] >>)) + ((Sexpr loc [se1 se2]) + (let* ((p (patt_se se1)) + (e (let ((e (expr_se se2))) + <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>)) + (k (ekont err))) + <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >>)) + ((Sexpr loc [(Slid _ "?") se1 se2]) + (stream_pattern_component skont ekont (expr_se se2) se1)) + ((Slid loc s) + (let ((s (Pcaml.rename_id.val s))) + <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>)) + (se + (error se "stream_pattern_component")))) + (patt_se + (lambda_match + ((Sacc loc se1 se2) + (let* ((p1 (patt_se se1)) (p2 (patt_se se2))) <:patt< $p1$ . $p2$ >>)) + ((Slid loc "_") <:patt< _ >>) + ((Slid loc s) <:patt< $lid:(Pcaml.rename_id.val s)$ >>) + ((Suid loc s) <:patt< $uid:(Pcaml.rename_id.val s)$ >>) + ((Sint loc s) <:patt< $int:s$ >>) + ((Sfloat loc s) <:patt< $flo:s$ >>) + ((Schar loc s) <:patt< $chr:s$ >>) + ((Sstring loc s) <:patt< $str:s$ >>) + ((Stid loc _) (error_loc loc "patt")) + ((Sqid loc _) (error_loc loc "patt")) + ((Srec loc sel) + (let ((lpl (List.map (label_patt_se loc) sel))) + <:patt< { $list:lpl$ } >>)) + ((Sexpr loc [(Slid _ ":") se1 se2]) + (let* ((p (patt_se se1)) (t (ctyp_se se2))) <:patt< ($p$ : $t$) >>)) + ((Sexpr loc [(Slid _ "or") se . sel]) + (List.fold_left + (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ | $p1$ >>)) + (patt_se se) sel)) + ((Sexpr loc [(Slid _ "range") se1 se2]) + (let* ((p1 (patt_se se1)) (p2 (patt_se se2))) <:patt< $p1$ .. $p2$ >>)) + ((Sexpr loc [(Slid _ "values") . sel]) + (let ((pl (List.map patt_se sel))) <:patt< ( $list:pl$ ) >>)) + ((Sexpr loc [(Slid _ "as") se1 se2]) + (let* ((p1 (patt_se se1)) + (p2 (patt_se se2))) + <:patt< ($p1$ as $p2$) >>)) + ((Sexpr loc [se . sel]) + (List.fold_left + (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ $p1$ >>)) + (patt_se se) sel)) + ((Sexpr loc []) <:patt< () >>) + ((Slist loc sel) + (letrec ((loop + (lambda_match + ([] <:patt< [] >>) + ([se1 (Slid _ ".") se2] + (let* ((p (patt_se se1)) + (pl (patt_se se2))) + <:patt< [$p$ :: $pl$] >>)) + ([se . sel] + (let* ((p (patt_se se)) + (pl (loop sel))) + <:patt< [$p$ :: $pl$] >>))))) + (loop sel))) + ((Squot loc typ txt) + (Pcaml.handle_patt_quotation loc (values typ txt))))) + ((ipatt_se se) + (match (ipatt_opt_se se) + ((Left p) p) + ((Right (values se _)) (error se "ipatt")))) + (ipatt_opt_se + (lambda_match + ((Slid loc "_") (Left <:patt< _ >>)) + ((Slid loc s) (Left <:patt< $lid:(Pcaml.rename_id.val s)$ >>)) + ((Stid loc s) (Left <:patt< ~ $(Pcaml.rename_id.val s)$ >>)) + ((Sqid loc s) (Left <:patt< ? $(Pcaml.rename_id.val s)$ >>)) + ((Sexpr loc [(Sqid _ s) se]) + (let* ((s (Pcaml.rename_id.val s)) + (e (expr_se se))) + (Left <:patt< ? ( $lid:s$ = $e$ ) >>))) + ((Sexpr loc [(Slid _ ":") se1 se2]) + (let* ((p (ipatt_se se1)) (t (ctyp_se se2))) + (Left <:patt< ($p$ : $t$) >>))) + ((Sexpr loc [(Slid _ "values") . sel]) + (let ((pl (List.map ipatt_se sel))) (Left <:patt< ( $list:pl$ ) >>))) + ((Sexpr loc []) (Left <:patt< () >>)) + ((Sexpr loc [se . sel]) (Right (values se sel))) + (se (error se "ipatt")))) + (type_declaration_list_se + (lambda_match + ([se1 se2 . sel] + (let (((values n1 loc1 tpl) + (match se1 + ((Sexpr _ [(Slid loc n) . sel]) + (values n loc (List.map type_parameter_se sel))) + ((Slid loc n) + (values n loc [])) + ((se) + (error se "type declaration"))))) + [(values (values loc1 (Pcaml.rename_id.val n1)) tpl (ctyp_se se2) []) . + (type_declaration_list_se sel)])) + ([] []) + ([se . _] (error se "type_declaration")))) + (type_parameter_se + (lambda_match + ((when (Slid _ s) (and (>= (String.length s) 2) (= s.[0] '''))) + (values (String.sub s 1 (- (String.length s) 1)) (values False False))) + (se + (error se "type_parameter")))) + (ctyp_se + (lambda_match + ((Sexpr loc [(Slid _ "sum") . sel]) + (let ((cdl (List.map constructor_declaration_se sel))) + <:ctyp< [ $list:cdl$ ] >>)) + ((Srec loc sel) + (let ((ldl (List.map label_declaration_se sel))) + <:ctyp< { $list:ldl$ } >>)) + ((Sexpr loc [(Slid _ "->") . (as [_ _ . _] sel)]) + (letrec + ((loop + (lambda_match + ([] (assert False)) + ([se] (ctyp_se se)) + ([se . sel] + (let* ((t1 (ctyp_se se)) + (loc (values (fst (loc_of_sexpr se)) (snd loc))) + (t2 (loop sel))) + <:ctyp< $t1$ -> $t2$ >>))))) + (loop sel))) + ((Sexpr loc [(Slid _ "*") . sel]) + (let ((tl (List.map ctyp_se sel))) <:ctyp< ($list:tl$) >>)) + ((Sexpr loc [se . sel]) + (List.fold_left + (lambda (t se) (let ((t2 (ctyp_se se))) <:ctyp< $t$ $t2$ >>)) + (ctyp_se se) sel)) + ((Sacc loc se1 se2) + (let* ((t1 (ctyp_se se1)) (t2 (ctyp_se se2))) <:ctyp< $t1$ . $t2$ >>)) + ((Slid loc "_") <:ctyp< _ >>) + ((Slid loc s) + (if (= s.[0] ''') + (let ((s (String.sub s 1 (- (String.length s) 1)))) + <:ctyp< '$s$ >>) + <:ctyp< $lid:(Pcaml.rename_id.val s)$ >>)) + ((Suid loc s) <:ctyp< $uid:(Pcaml.rename_id.val s)$ >>) + (se (error se "ctyp")))) + (constructor_declaration_se + (lambda_match + ((Sexpr loc [(Suid _ ci) . sel]) + (values loc (Pcaml.rename_id.val ci) (List.map ctyp_se sel))) + (se + (error se "constructor_declaration")))) + (label_declaration_se + (lambda_match + ((Sexpr loc [(Slid _ lab) (Slid _ "mutable") se]) + (values loc (Pcaml.rename_id.val lab) True (ctyp_se se))) + ((Sexpr loc [(Slid _ lab) se]) + (values loc (Pcaml.rename_id.val lab) False (ctyp_se se))) + (se + (error se "label_declaration"))))) + +(define directive_se + (lambda_match + ((Sexpr _ [(Slid _ s)]) (values s None)) + ((Sexpr _ [(Slid _ s) se]) (let ((e (expr_se se))) (values s (Some e)))) + (se (error se "directive")))) + +; Parser + +(:= Pcaml.syntax_name.val "Scheme") +(:= Pcaml.no_constructors_arity.val False) + +(begin + (Grammar.Unsafe.gram_reinit gram (lexer_gmake ())) + (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)) + +(define sexpr (Grammar.Entry.create gram "sexpr")) + +(definerec leftify + (lambda_match + ((Sacc loc1 se1 se2) + (match (leftify se2) + ((Sacc loc2 se2 se3) (Sacc loc1 (Sacc loc2 se1 se2) se3)) + (se2 (Sacc loc1 se1 se2)))) + (x x))) + +EXTEND + GLOBAL : implem interf top_phrase use_file str_item sig_item expr + patt sexpr / + implem : + [ [ "#" / se = sexpr -> + (let (((values n dp) (directive_se se))) + (values [(values <:str_item< # $n$ $opt:dp$ >> loc)] True)) + | si = str_item / x = SELF -> + (let* (((values sil stopped) x) + (loc (MLast.loc_of_str_item si))) + (values [(values si loc) . sil] stopped)) + | EOI -> (values [] False) ] ] + / + interf : + [ [ "#" / se = sexpr -> + (let (((values n dp) (directive_se se))) + (values [(values <:sig_item< # $n$ $opt:dp$ >> loc)] True)) + | si = sig_item / x = SELF -> + (let* (((values sil stopped) x) + (loc (MLast.loc_of_sig_item si))) + (values [(values si loc) . sil] stopped)) + | EOI -> (values [] False) ] ] + / + top_phrase : + [ [ "#" / se = sexpr -> + (let (((values n dp) (directive_se se))) + (Some <:str_item< # $n$ $opt:dp$ >>)) + | se = sexpr -> (Some (str_item_se se)) + | EOI -> None ] ] + / + use_file : + [ [ "#" / se = sexpr -> + (let (((values n dp) (directive_se se))) + (values [<:str_item< # $n$ $opt:dp$ >>] True)) + | si = str_item / x = SELF -> + (let (((values sil stopped) x)) (values [si . sil] stopped)) + | EOI -> (values [] False) ] ] + / + str_item : + [ [ se = sexpr -> (str_item_se se) + | e = expr -> <:str_item< $exp:e$ >> ] ] + / + sig_item : + [ [ se = sexpr -> (sig_item_se se) ] ] + / + expr : + [ "top" + [ se = sexpr -> (expr_se se) ] ] + / + patt : + [ [ se = sexpr -> (patt_se se) ] ] + / + sexpr : + [ [ se1 = sexpr_dot / se2 = sexpr -> (leftify (Sacc loc se1 se2)) ] + | [ "(" / sl = LIST0 sexpr / ")" -> (Sexpr loc sl) + | "(" / sl = LIST0 sexpr / ")." / se = sexpr -> + (leftify (Sacc loc (Sexpr loc sl) se)) + | "[" / sl = LIST0 sexpr / "]" -> (Slist loc sl) + | "{" / sl = LIST0 sexpr / "}" -> (Srec loc sl) + | a = pa_extend_keyword -> (Slid loc a) + | s = LIDENT -> (Slid loc s) + | s = UIDENT -> (Suid loc s) + | s = TILDEIDENT -> (Stid loc s) + | s = QUESTIONIDENT -> (Sqid loc s) + | s = INT -> (Sint loc s) + | s = FLOAT -> (Sfloat loc s) + | s = CHAR -> (Schar loc s) + | s = STRING -> (Sstring loc s) + | s = QUOT -> + (let* ((i (String.index s ':')) + (typ (String.sub s 0 i)) + (txt (String.sub s (+ i 1) (- (- (String.length s) i) 1)))) + (Squot loc typ txt)) ] ] + / + sexpr_dot : + [ [ s = LIDENTDOT -> (Slid loc s) + | s = UIDENTDOT -> (Suid loc s) ] ] + / + pa_extend_keyword : + [ [ "_" -> "_" + | "," -> "," + | "=" -> "=" + | ":" -> ":" + | "." -> "." + | "/" -> "/" ] ] + / +END diff --git a/camlp4/etc/pa_schemer.ml b/camlp4/etc/pa_schemer.ml new file mode 100644 index 000000000..a7d64ce4a --- /dev/null +++ b/camlp4/etc/pa_schemer.ml @@ -0,0 +1,1067 @@ +(* camlp4 pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) +(* File generated by pretty print; do not edit! *) + +open Pcaml; +open Stdpp; + +type choice 'a 'b = + [ Left of 'a + | Right of 'b ] +; + +(* Buffer *) + +module Buff = + struct + value buff = ref (String.create 80); + value store len x = + do { + if len >= String.length buff.val then + buff.val := buff.val ^ String.create (String.length buff.val) + else (); + buff.val.[len] := x; + succ len + } + ; + value get len = String.sub buff.val 0 len; + end +; + +(* Lexer *) + +value rec skip_to_eol = + parser + [ [: `'\n' | '\r' :] -> () + | [: `_; s :] -> skip_to_eol s ] +; + +value no_ident = ['('; ')'; '['; ']'; '{'; '}'; ' '; '\t'; '\n'; '\r'; ';']; + +value rec ident len = + parser + [ [: `'.' :] -> (Buff.get len, True) + | [: `x when not (List.mem x no_ident); s :] -> ident (Buff.store len x) s + | [: :] -> (Buff.get len, False) ] +; + +value identifier kwt (s, dot) = + let con = + try do { (Hashtbl.find kwt s : unit); "" } with + [ Not_found -> + match s.[0] with + [ 'A'..'Z' -> if dot then "UIDENTDOT" else "UIDENT" + | _ -> if dot then "LIDENTDOT" else "LIDENT" ] ] + in + (con, s) +; + +value rec string len = + parser + [ [: `'"' :] -> Buff.get len + | [: `'\\'; `c; s :] -> string (Buff.store (Buff.store len '\\') c) s + | [: `x; s :] -> string (Buff.store len x) s ] +; + +value rec end_exponent_part_under len = + parser + [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (Buff.store len c) s + | [: :] -> ("FLOAT", Buff.get len) ] +; + +value end_exponent_part len = + parser + [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (Buff.store len c) s + | [: :] -> raise (Stream.Error "ill-formed floating-point constant") ] +; + +value exponent_part len = + parser + [ [: `('+' | '-' as c); s :] -> end_exponent_part (Buff.store len c) s + | [: a = end_exponent_part len :] -> a ] +; + +value rec decimal_part len = + parser + [ [: `('0'..'9' as c); s :] -> decimal_part (Buff.store len c) s + | [: `'e' | 'E'; s :] -> exponent_part (Buff.store len 'E') s + | [: :] -> ("FLOAT", Buff.get len) ] +; + +value rec number len = + parser + [ [: `('0'..'9' as c); s :] -> number (Buff.store len c) s + | [: `'.'; s :] -> decimal_part (Buff.store len '.') s + | [: `'e' | 'E'; s :] -> exponent_part (Buff.store len 'E') s + | [: :] -> ("INT", Buff.get len) ] +; + +value binary = parser [: `('0'..'1' as c) :] -> c; + +value octal = parser [: `('0'..'7' as c) :] -> c; + +value hexa = parser [: `('0'..'9' | 'a'..'f' | 'A'..'F' as c) :] -> c; + +value rec digits_under kind len = + parser + [ [: d = kind; s :] -> digits_under kind (Buff.store len d) s + | [: :] -> Buff.get len ] +; + +value digits kind bp len = + parser + [ [: d = kind; s :] -> ("INT", digits_under kind (Buff.store len d) s) + | [: s :] ep -> + raise_with_loc (bp, ep) (Failure "ill-formed integer constant") ] +; + +value base_number kwt bp len = + parser + [ [: `'b' | 'B'; s :] -> digits binary bp (Buff.store len 'b') s + | [: `'o' | 'O'; s :] -> digits octal bp (Buff.store len 'o') s + | [: `'x' | 'X'; s :] -> digits hexa bp (Buff.store len 'x') s + | [: id = ident (Buff.store 0 '#') :] -> identifier kwt id ] +; + +value rec operator len = + parser + [ [: `'.' :] -> Buff.get (Buff.store len '.') + | [: :] -> Buff.get len ] +; + +value char_or_quote_id x = + parser + [ [: `''' :] -> ("CHAR", String.make 1 x) + | [: s :] ep -> + if List.mem x no_ident then + Stdpp.raise_with_loc (ep - 2, ep - 1) (Stream.Error "bad quote") + else + let len = Buff.store (Buff.store 0 ''') x in + let (s, dot) = ident len s in + (if dot then "LIDENTDOT" else "LIDENT", s) ] +; + +value rec char len = + parser + [ [: `''' :] -> len + | [: `x; s :] -> char (Buff.store len x) s ] +; + +value quote = + parser + [ [: `'\\'; len = char (Buff.store 0 '\\') :] -> ("CHAR", Buff.get len) + | [: `x; s :] -> char_or_quote_id x s ] +; + +(* The system with LIDENTDOT and UIDENTDOT is not great (it would be *) +(* better to have a token DOT (actually SPACEDOT and DOT)) but it is *) +(* the only way (that I have found) to have a good behaviour in the *) +(* toplevel (not expecting tokens after a phrase). Drawbacks: 1/ to be *) +(* complete, we should have STRINGDOT, RIGHTPARENDOT, and so on 2/ the *) +(* parser rule with dot is right associative and we have to reverse *) +(* the resulting tree (using the function leftify). *) +(* This is a complicated issue: the behaviour of the OCaml toplevel *) +(* is strange, anyway. For example, even without Camlp4, The OCaml *) +(* toplevel accepts that: *) +(* # let x = 32;; foo bar match let ) *) + +value rec lexer kwt = parser [: t = lexer0 kwt; _ = no_dot :] -> t +and no_dot = + parser + [ [: `'.' :] ep -> + Stdpp.raise_with_loc (ep - 1, ep) (Stream.Error "bad dot") + | [: :] -> () ] +and lexer0 kwt = + parser bp + [ [: `'\t' | '\n' | '\r'; s :] -> lexer0 kwt s + | [: `' '; s :] -> after_space kwt s + | [: `';'; _ = skip_to_eol; s :] -> lexer kwt s + | [: `'(' :] -> (("", "("), (bp, bp + 1)) + | [: `')'; s :] ep -> (("", rparen s), (bp, ep)) + | [: `'[' :] -> (("", "["), (bp, bp + 1)) + | [: `']' :] -> (("", "]"), (bp, bp + 1)) + | [: `'{' :] -> (("", "{"), (bp, bp + 1)) + | [: `'}' :] -> (("", "}"), (bp, bp + 1)) + | [: `'"'; s = string 0 :] ep -> (("STRING", s), (bp, ep)) + | [: `'''; tok = quote :] ep -> (tok, (bp, ep)) + | [: `'<'; tok = less kwt :] ep -> (tok, (bp, ep)) + | [: `'-'; tok = minus kwt :] ep -> (tok, (bp, ep)) + | [: `'~'; tok = tilde :] ep -> (tok, (bp, ep)) + | [: `'?'; tok = question :] ep -> (tok, (bp, ep)) + | [: `'#'; tok = base_number kwt bp (Buff.store 0 '0') :] ep -> + (tok, (bp, ep)) + | [: `('0'..'9' as c); tok = number (Buff.store 0 c) :] ep -> + (tok, (bp, ep)) + | [: `('+' | '*' | '/' as c); id = operator (Buff.store 0 c) :] ep -> + (identifier kwt (id, False), (bp, ep)) + | [: `x; id = ident (Buff.store 0 x) :] ep -> (identifier kwt id, (bp, ep)) + | [: :] -> (("EOI", ""), (bp, bp + 1)) ] +and rparen = + parser + [ [: `'.' :] -> ")." + | [: ___ :] -> ")" ] +and after_space kwt = + parser + [ [: `'.' :] ep -> (("", "."), (ep - 1, ep)) + | [: x = lexer0 kwt :] -> x ] +and tilde = + parser + [ [: `('a'..'z' as c); (s, dot) = ident (Buff.store 0 c) :] -> + ("TILDEIDENT", s) + | [: :] -> ("LIDENT", "~") ] +and question = + parser + [ [: `('a'..'z' as c); (s, dot) = ident (Buff.store 0 c) :] -> + ("QUESTIONIDENT", s) + | [: :] -> ("LIDENT", "?") ] +and minus kwt = + parser + [ [: `'.' :] -> identifier kwt ("-.", False) + | [: `('0'..'9' as c); n = number (Buff.store (Buff.store 0 '-') c) :] ep -> + n + | [: id = ident (Buff.store 0 '-') :] -> identifier kwt id ] +and less kwt = + parser + [ [: `':'; lab = label 0; `'<' ? "'<' expected"; q = quotation 0 :] -> + ("QUOT", lab ^ ":" ^ q) + | [: id = ident (Buff.store 0 '<') :] -> identifier kwt id ] +and label len = + parser + [ [: `('a'..'z' | 'A'..'Z' | '_' as c); s :] -> label (Buff.store len c) s + | [: :] -> Buff.get len ] +and quotation len = + parser + [ [: `'>'; s :] -> quotation_greater len s + | [: `x; s :] -> quotation (Buff.store len x) s + | [: :] -> failwith "quotation not terminated" ] +and quotation_greater len = + parser + [ [: `'>' :] -> Buff.get len + | [: a = quotation (Buff.store len '>') :] -> a ] +; + +value lexer_using kwt (con, prm) = + match con with + [ "CHAR" | "EOI" | "INT" | "FLOAT" | "LIDENT" | "LIDENTDOT" | + "QUESTIONIDENT" | "QUOT" | "STRING" | "TILDEIDENT" | "UIDENT" | + "UIDENTDOT" -> + () + | "ANTIQUOT" -> () + | "" -> + try Hashtbl.find kwt prm with [ Not_found -> Hashtbl.add kwt prm () ] + | _ -> + raise + (Token.Error + ("the constructor \"" ^ con ^ "\" is not recognized by Plexer")) ] +; + +value lexer_text (con, prm) = + if con = "" then "'" ^ prm ^ "'" + else if prm = "" then con + else con ^ " \"" ^ prm ^ "\"" +; + +value lexer_gmake () = + let kwt = Hashtbl.create 89 in + {Token.tok_func = Token.lexer_func_of_parser (lexer kwt); + Token.tok_using = lexer_using kwt; Token.tok_removing = fun []; + Token.tok_match = Token.default_match; Token.tok_text = lexer_text; + Token.tok_comm = None} +; + +(* Building AST *) + +type sexpr = + [ Sacc of MLast.loc and sexpr and sexpr + | Schar of MLast.loc and string + | Sexpr of MLast.loc and list sexpr + | Sint of MLast.loc and string + | Sfloat of MLast.loc and string + | Slid of MLast.loc and string + | Slist of MLast.loc and list sexpr + | Sqid of MLast.loc and string + | Squot of MLast.loc and string and string + | Srec of MLast.loc and list sexpr + | Sstring of MLast.loc and string + | Stid of MLast.loc and string + | Suid of MLast.loc and string ] +; + +value loc_of_sexpr = + fun [ + Sacc loc _ _ | Schar loc _ | Sexpr loc _ | Sint loc _ | Sfloat loc _ | + Slid loc _ | Slist loc _ | Sqid loc _ | Squot loc _ _ | Srec loc _ | + Sstring loc _ | Stid loc _ | Suid loc _ -> + loc ] +; +value error_loc loc err = + raise_with_loc loc (Stream.Error (err ^ " expected")) +; +value error se err = error_loc (loc_of_sexpr se) err; + +value strm_n = "strm__"; +value peek_fun loc = <:expr< Stream.peek >>; +value junk_fun loc = <:expr< Stream.junk >>; + +value assoc_left_parsed_op_list = + ["+"; "*"; "+."; "*."; "land"; "lor"; "lxor"] +; +value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"]; +value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="]; + +value op_apply loc e1 e2 = + fun + [ "and" -> <:expr< $e1$ && $e2$ >> + | "or" -> <:expr< $e1$ || $e2$ >> + | x -> <:expr< $lid:x$ $e1$ $e2$ >> ] +; + +value string_se = + fun + [ Sstring loc s -> s + | se -> error se "string" ] +; + +value mod_ident_se = + fun + [ Suid _ s -> [Pcaml.rename_id.val s] + | Slid _ s -> [Pcaml.rename_id.val s] + | se -> error se "mod_ident" ] +; + +value lident_expr loc s = + if String.length s > 1 && s.[0] = '`' then + let s = String.sub s 1 (String.length s - 1) in + <:expr< ` $s$ >> + else <:expr< $lid:(Pcaml.rename_id.val s)$ >> +; + +value rec module_expr_se = + fun + [ Sexpr loc [Slid _ "functor"; Suid _ s; se1; se2] -> + let s = Pcaml.rename_id.val s in + let mt = module_type_se se1 in + let me = module_expr_se se2 in + <:module_expr< functor ($s$ : $mt$) -> $me$ >> + | Sexpr loc [Slid _ "struct" :: sl] -> + let mel = List.map str_item_se sl in + <:module_expr< struct $list:mel$ end >> + | Sexpr loc [se1; se2] -> + let me1 = module_expr_se se1 in + let me2 = module_expr_se se2 in + <:module_expr< $me1$ $me2$ >> + | Suid loc s -> <:module_expr< $uid:(Pcaml.rename_id.val s)$ >> + | se -> error se "module expr" ] +and module_type_se = + fun + [ Sexpr loc [Slid _ "functor"; Suid _ s; se1; se2] -> + let s = Pcaml.rename_id.val s in + let mt1 = module_type_se se1 in + let mt2 = module_type_se se2 in + <:module_type< functor ($s$ : $mt1$) -> $mt2$ >> + | Sexpr loc [Slid _ "sig" :: sel] -> + let sil = List.map sig_item_se sel in + <:module_type< sig $list:sil$ end >> + | Sexpr loc [Slid _ "with"; se; Sexpr _ sel] -> + let mt = module_type_se se in + let wcl = List.map with_constr_se sel in + <:module_type< $mt$ with $list:wcl$ >> + | Suid loc s -> <:module_type< $uid:(Pcaml.rename_id.val s)$ >> + | se -> error se "module type" ] +and with_constr_se = + fun + [ Sexpr loc [Slid _ "type"; se1; se2] -> + let tn = mod_ident_se se1 in + let te = ctyp_se se2 in + MLast.WcTyp loc tn [] te + | se -> error se "with constr" ] +and sig_item_se = + fun + [ Sexpr loc [Slid _ "type" :: sel] -> + let tdl = type_declaration_list_se sel in + <:sig_item< type $list:tdl$ >> + | Sexpr loc [Slid _ "exception"; Suid _ c :: sel] -> + let c = Pcaml.rename_id.val c in + let tl = List.map ctyp_se sel in + <:sig_item< exception $c$ of $list:tl$ >> + | Sexpr loc [Slid _ "value"; Slid _ s; se] -> + let s = Pcaml.rename_id.val s in + let t = ctyp_se se in + <:sig_item< value $s$ : $t$ >> + | Sexpr loc [Slid _ "external"; Slid _ i; se :: sel] -> + let i = Pcaml.rename_id.val i in + let pd = List.map string_se sel in + let t = ctyp_se se in + <:sig_item< external $i$ : $t$ = $list:pd$ >> + | Sexpr loc [Slid _ "module"; Suid _ s; se] -> + let s = Pcaml.rename_id.val s in + let mb = module_type_se se in + <:sig_item< module $s$ : $mb$ >> + | Sexpr loc [Slid _ "moduletype"; Suid _ s; se] -> + let s = Pcaml.rename_id.val s in + let mt = module_type_se se in + <:sig_item< module type $s$ = $mt$ >> + | se -> error se "sig item" ] +and str_item_se se = + match se with + [ Sexpr loc [Slid _ "open"; se] -> + let s = mod_ident_se se in + <:str_item< open $s$ >> + | Sexpr loc [Slid _ "type" :: sel] -> + let tdl = type_declaration_list_se sel in + <:str_item< type $list:tdl$ >> + | Sexpr loc [Slid _ "exception"; Suid _ c :: sel] -> + let c = Pcaml.rename_id.val c in + let tl = List.map ctyp_se sel in + <:str_item< exception $c$ of $list:tl$ >> + | Sexpr loc [Slid _ ("define" | "definerec" as r); se :: sel] -> + let r = r = "definerec" in + let (p, e) = fun_binding_se se (begin_se loc sel) in + <:str_item< value $opt:r$ $p$ = $e$ >> + | Sexpr loc [Slid _ ("define*" | "definerec*" as r) :: sel] -> + let r = r = "definerec*" in + let lbs = List.map let_binding_se sel in + <:str_item< value $opt:r$ $list:lbs$ >> + | Sexpr loc [Slid _ "external"; Slid _ i; se :: sel] -> + let i = Pcaml.rename_id.val i in + let pd = List.map string_se sel in + let t = ctyp_se se in + <:str_item< external $i$ : $t$ = $list:pd$ >> + | Sexpr loc [Slid _ "module"; Suid _ i; se] -> + let i = Pcaml.rename_id.val i in + let mb = module_binding_se se in + <:str_item< module $i$ = $mb$ >> + | Sexpr loc [Slid _ "moduletype"; Suid _ s; se] -> + let s = Pcaml.rename_id.val s in + let mt = module_type_se se in + <:str_item< module type $s$ = $mt$ >> + | _ -> + let loc = loc_of_sexpr se in + let e = expr_se se in + <:str_item< $exp:e$ >> ] +and module_binding_se se = module_expr_se se +and expr_se = + fun + [ Sacc loc se1 se2 -> + let e1 = expr_se se1 in + match se2 with + [ Slist loc [se2] -> + let e2 = expr_se se2 in + <:expr< $e1$ .[ $e2$ ] >> + | Sexpr loc [se2] -> + let e2 = expr_se se2 in + <:expr< $e1$ .( $e2$ ) >> + | _ -> + let e2 = expr_se se2 in + <:expr< $e1$ . $e2$ >> ] + | Slid loc s -> lident_expr loc s + | Suid loc s -> <:expr< $uid:(Pcaml.rename_id.val s)$ >> + | Sint loc s -> <:expr< $int:s$ >> + | Sfloat loc s -> <:expr< $flo:s$ >> + | Schar loc s -> <:expr< $chr:s$ >> + | Sstring loc s -> <:expr< $str:s$ >> + | Stid loc s -> <:expr< ~ $(Pcaml.rename_id.val s)$ >> + | Sqid loc s -> <:expr< ? $(Pcaml.rename_id.val s)$ >> + | Sexpr loc [] -> <:expr< () >> + | Sexpr loc [Slid _ s; e1 :: ([_ :: _] as sel)] + when List.mem s assoc_left_parsed_op_list -> + let rec loop e1 = + fun + [ [] -> e1 + | [e2 :: el] -> loop (op_apply loc e1 e2 s) el ] + in + loop (expr_se e1) (List.map expr_se sel) + | Sexpr loc [Slid _ s :: ([_; _ :: _] as sel)] + when List.mem s assoc_right_parsed_op_list -> + let rec loop = + fun + [ [] -> assert False + | [e1] -> e1 + | [e1 :: el] -> + let e2 = loop el in + op_apply loc e1 e2 s ] + in + loop (List.map expr_se sel) + | Sexpr loc [Slid _ s :: ([_; _ :: _] as sel)] + when List.mem s and_by_couple_op_list -> + let rec loop = + fun + [ [] | [_] -> assert False + | [e1; e2] -> <:expr< $lid:s$ $e1$ $e2$ >> + | [e1 :: ([e2; _ :: _] as el)] -> + let a1 = op_apply loc e1 e2 s in + let a2 = loop el in + <:expr< $a1$ && $a2$ >> ] + in + loop (List.map expr_se sel) + | Sexpr loc [Stid _ s; se] -> + let e = expr_se se in + <:expr< ~ $s$ : $e$ >> + | Sexpr loc [Slid _ "-"; se] -> + let e = expr_se se in + <:expr< - $e$ >> + | Sexpr loc [Slid _ "if"; se; se1] -> + let e = expr_se se in + let e1 = expr_se se1 in + <:expr< if $e$ then $e1$ else () >> + | Sexpr loc [Slid _ "if"; se; se1; se2] -> + let e = expr_se se in + let e1 = expr_se se1 in + let e2 = expr_se se2 in + <:expr< if $e$ then $e1$ else $e2$ >> + | Sexpr loc [Slid _ "cond" :: sel] -> + let rec loop = + fun + [ [Sexpr loc [Slid _ "else" :: sel]] -> begin_se loc sel + | [Sexpr loc [se1 :: sel1] :: sel] -> + let e1 = expr_se se1 in + let e2 = begin_se loc sel1 in + let e3 = loop sel in + <:expr< if $e1$ then $e2$ else $e3$ >> + | [] -> <:expr< () >> + | [se :: _] -> error se "cond clause" ] + in + loop sel + | Sexpr loc [Slid _ "while"; se :: sel] -> + let e = expr_se se in + let el = List.map expr_se sel in + <:expr< while $e$ do { $list:el$ } >> + | Sexpr loc [Slid _ "for"; Slid _ i; se1; se2 :: sel] -> + let i = Pcaml.rename_id.val i in + let e1 = expr_se se1 in + let e2 = expr_se se2 in + let el = List.map expr_se sel in + <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >> + | Sexpr loc [Slid loc1 "lambda"] -> <:expr< fun [] >> + | Sexpr loc [Slid loc1 "lambda"; sep :: sel] -> + let e = begin_se loc1 sel in + match ipatt_opt_se sep with + [ Left p -> <:expr< fun $p$ -> $e$ >> + | Right (se, sel) -> + List.fold_right + (fun se e -> + let p = ipatt_se se in + <:expr< fun $p$ -> $e$ >>) + [se :: sel] e ] + | Sexpr loc [Slid _ "lambda_match" :: sel] -> + let pel = List.map (match_case loc) sel in + <:expr< fun [ $list:pel$ ] >> + | Sexpr loc [Slid _ ("let" | "letrec" as r) :: sel] -> + match sel with + [ [Sexpr _ sel1 :: sel2] -> + let r = r = "letrec" in + let lbs = List.map let_binding_se sel1 in + let e = begin_se loc sel2 in + <:expr< let $opt:r$ $list:lbs$ in $e$ >> + | [Slid _ n; Sexpr _ sl :: sel] -> + let n = Pcaml.rename_id.val n in + let (pl, el) = + List.fold_right + (fun se (pl, el) -> + match se with + [ Sexpr _ [se1; se2] -> + ([patt_se se1 :: pl], [expr_se se2 :: el]) + | se -> error se "named let" ]) + sl ([], []) + in + let e1 = + List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl + (begin_se loc sel) + in + let e2 = + List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) + <:expr< $lid:n$ >> el + in + <:expr< let rec $lid:n$ = $e1$ in $e2$ >> + | [se :: _] -> error se "let_binding" + | _ -> error_loc loc "let_binding" ] + | Sexpr loc [Slid _ "let*" :: sel] -> + match sel with + [ [Sexpr _ sel1 :: sel2] -> + List.fold_right + (fun se ek -> + let (p, e) = let_binding_se se in + <:expr< let $p$ = $e$ in $ek$ >>) + sel1 (begin_se loc sel2) + | [se :: _] -> error se "let_binding" + | _ -> error_loc loc "let_binding" ] + | Sexpr loc [Slid _ "match"; se :: sel] -> + let e = expr_se se in + let pel = List.map (match_case loc) sel in + <:expr< match $e$ with [ $list:pel$ ] >> + | Sexpr loc [Slid _ "parser" :: sel] -> + let e = + match sel with + [ [(Slid _ _ as se) :: sel] -> + let p = patt_se se in + let pc = parser_cases_se loc sel in + <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >> + | _ -> parser_cases_se loc sel ] + in + <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >> + | Sexpr loc [Slid _ "match_with_parser"; se :: sel] -> + let me = expr_se se in + let (bpo, sel) = + match sel with + [ [(Slid _ _ as se) :: sel] -> (Some (patt_se se), sel) + | _ -> (None, sel) ] + in + let pc = parser_cases_se loc sel 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$ >> ] + | Sexpr loc [Slid _ "try"; se :: sel] -> + let e = expr_se se in + let pel = List.map (match_case loc) sel in + <:expr< try $e$ with [ $list:pel$ ] >> + | Sexpr loc [Slid _ "begin" :: sel] -> + let el = List.map expr_se sel in + <:expr< do { $list:el$ } >> + | Sexpr loc [Slid _ ":="; se1; se2] -> + let e1 = expr_se se1 in + let e2 = expr_se se2 in + <:expr< $e1$ := $e2$ >> + | Sexpr loc [Slid _ "values" :: sel] -> + let el = List.map expr_se sel in + <:expr< ( $list:el$ ) >> + | Srec loc [Slid _ "with"; se :: sel] -> + let e = expr_se se in + let lel = List.map (label_expr_se loc) sel in + <:expr< { ($e$) with $list:lel$ } >> + | Srec loc sel -> + let lel = List.map (label_expr_se loc) sel in + <:expr< { $list:lel$ } >> + | Sexpr loc [Slid _ ":"; se1; se2] -> + let e = expr_se se1 in + let t = ctyp_se se2 in + <:expr< ( $e$ : $t$ ) >> + | Sexpr loc [se] -> + let e = expr_se se in + <:expr< $e$ () >> + | Sexpr loc [Slid _ "assert"; Suid _ "False" ] -> + <:expr< assert False >> + | Sexpr loc [Slid _ "assert"; se] -> + let e = expr_se se in + <:expr< assert $e$ >> + | Sexpr loc [Slid _ "lazy"; se] -> + let e = expr_se se in + <:expr< lazy $e$ >> + | Sexpr loc [se :: sel] -> + List.fold_left + (fun e se -> + let e1 = expr_se se in + <:expr< $e$ $e1$ >>) + (expr_se se) sel + | Slist loc sel -> + let rec loop = + fun + [ [] -> <:expr< [] >> + | [se1; Slid _ "."; se2] -> + let e = expr_se se1 in + let el = expr_se se2 in + <:expr< [$e$ :: $el$] >> + | [se :: sel] -> + let e = expr_se se in + let el = loop sel in + <:expr< [$e$ :: $el$] >> ] + in + loop sel + | Squot loc typ txt -> Pcaml.handle_expr_quotation loc (typ, txt) ] +and begin_se loc = + fun + [ [] -> <:expr< () >> + | [se] -> expr_se se + | sel -> + let el = List.map expr_se sel in + let loc = (fst (loc_of_sexpr (List.hd sel)), snd loc) in + <:expr< do { $list:el$ } >> ] +and let_binding_se = + fun + [ Sexpr loc [se :: sel] -> + let e = begin_se loc sel in + match ipatt_opt_se se with + [ Left p -> (p, e) + | Right _ -> fun_binding_se se e ] + | se -> error se "let_binding" ] +and fun_binding_se se e = + match se with + [ Sexpr _ [Slid _ "values" :: _] -> (ipatt_se se, e) + | Sexpr _ [Slid loc s :: sel] -> + let s = Pcaml.rename_id.val s in + let e = + List.fold_right + (fun se e -> + let loc = (fst (loc_of_sexpr se), snd (MLast.loc_of_expr e)) in + let p = ipatt_se se in + <:expr< fun $p$ -> $e$ >>) + sel e + in + let p = <:patt< $lid:s$ >> in + (p, e) + | _ -> (ipatt_se se, e) ] +and match_case loc = + fun + [ Sexpr loc [Sexpr _ [Slid _ "when"; se; sew] :: sel] -> + (patt_se se, Some (expr_se sew), begin_se loc sel) + | Sexpr loc [se :: sel] -> (patt_se se, None, begin_se loc sel) + | se -> error se "match_case" ] +and label_expr_se loc = + fun + [ Sexpr _ [se1; se2] -> (patt_se se1, expr_se se2) + | se -> error se "label_expr" ] +and label_patt_se loc = + fun + [ Sexpr _ [se1; se2] -> (patt_se se1, patt_se se2) + | se -> error se "label_patt" ] +and parser_cases_se loc = + fun + [ [] -> <:expr< raise Stream.Failure >> + | [Sexpr loc [Sexpr _ spsel :: act] :: sel] -> + let ekont _ = parser_cases_se loc sel in + let act = + match act with + [ [se] -> expr_se se + | [sep; se] -> + let p = patt_se sep in + let e = expr_se se in + <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >> + | _ -> error_loc loc "parser_case" ] + in + stream_pattern_se loc act ekont spsel + | [se :: _] -> error se "parser_case" ] +and stream_pattern_se loc act ekont = + fun + [ [] -> act + | [se :: sel] -> + let ckont err = <:expr< raise (Stream.Error $err$) >> in + let skont = stream_pattern_se loc act ckont sel in + stream_pattern_component skont ekont <:expr< "" >> se ] +and stream_pattern_component skont ekont err = + fun + [ Sexpr loc [Slid _ "`"; se :: wol] -> + let wo = + match wol with + [ [se] -> Some (expr_se se) + | [] -> None + | _ -> error_loc loc "stream_pattern_component" ] + in + let e = peek_fun loc in + let p = patt_se se in + let j = junk_fun loc in + let k = ekont err in + <:expr< match $e$ $lid:strm_n$ with + [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ } + | _ -> $k$ ] >> + | Sexpr loc [se1; se2] -> + let p = patt_se se1 in + let e = + let e = expr_se se2 in + <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >> + in + let k = ekont err in + <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >> + | Sexpr loc [Slid _ "?"; se1; se2] -> + stream_pattern_component skont ekont (expr_se se2) se1 + | Slid loc s -> + let s = Pcaml.rename_id.val s in + <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >> + | se -> error se "stream_pattern_component" ] +and patt_se = + fun + [ Sacc loc se1 se2 -> + let p1 = patt_se se1 in + let p2 = patt_se se2 in + <:patt< $p1$ . $p2$ >> + | Slid loc "_" -> <:patt< _ >> + | Slid loc s -> <:patt< $lid:(Pcaml.rename_id.val s)$ >> + | Suid loc s -> <:patt< $uid:(Pcaml.rename_id.val s)$ >> + | Sint loc s -> <:patt< $int:s$ >> + | Sfloat loc s -> <:patt< $flo:s$ >> + | Schar loc s -> <:patt< $chr:s$ >> + | Sstring loc s -> <:patt< $str:s$ >> + | Stid loc _ -> error_loc loc "patt" + | Sqid loc _ -> error_loc loc "patt" + | Srec loc sel -> + let lpl = List.map (label_patt_se loc) sel in + <:patt< { $list:lpl$ } >> + | Sexpr loc [Slid _ ":"; se1; se2] -> + let p = patt_se se1 in + let t = ctyp_se se2 in + <:patt< ($p$ : $t$) >> + | Sexpr loc [Slid _ "or"; se :: sel] -> + List.fold_left + (fun p se -> + let p1 = patt_se se in + <:patt< $p$ | $p1$ >>) + (patt_se se) sel + | Sexpr loc [Slid _ "range"; se1; se2] -> + let p1 = patt_se se1 in + let p2 = patt_se se2 in + <:patt< $p1$ .. $p2$ >> + | Sexpr loc [Slid _ "values" :: sel] -> + let pl = List.map patt_se sel in + <:patt< ( $list:pl$ ) >> + | Sexpr loc [Slid _ "as"; se1; se2] -> + let p1 = patt_se se1 in + let p2 = patt_se se2 in + <:patt< ($p1$ as $p2$) >> + | Sexpr loc [se :: sel] -> + List.fold_left + (fun p se -> + let p1 = patt_se se in + <:patt< $p$ $p1$ >>) + (patt_se se) sel + | Sexpr loc [] -> <:patt< () >> + | Slist loc sel -> + let rec loop = + fun + [ [] -> <:patt< [] >> + | [se1; Slid _ "."; se2] -> + let p = patt_se se1 in + let pl = patt_se se2 in + <:patt< [$p$ :: $pl$] >> + | [se :: sel] -> + let p = patt_se se in + let pl = loop sel in + <:patt< [$p$ :: $pl$] >> ] + in + loop sel + | Squot loc typ txt -> Pcaml.handle_patt_quotation loc (typ, txt) ] +and ipatt_se se = + match ipatt_opt_se se with + [ Left p -> p + | Right (se, _) -> error se "ipatt" ] +and ipatt_opt_se = + fun + [ Slid loc "_" -> Left <:patt< _ >> + | Slid loc s -> Left <:patt< $lid:(Pcaml.rename_id.val s)$ >> + | Stid loc s -> Left <:patt< ~ $(Pcaml.rename_id.val s)$ >> + | Sqid loc s -> Left <:patt< ? $(Pcaml.rename_id.val s)$ >> + | Sexpr loc [Sqid _ s; se] -> + let s = Pcaml.rename_id.val s in + let e = expr_se se in + Left <:patt< ? ( $lid:s$ = $e$ ) >> + | Sexpr loc [Slid _ ":"; se1; se2] -> + let p = ipatt_se se1 in + let t = ctyp_se se2 in + Left <:patt< ($p$ : $t$) >> + | Sexpr loc [Slid _ "values" :: sel] -> + let pl = List.map ipatt_se sel in + Left <:patt< ( $list:pl$ ) >> + | Sexpr loc [] -> Left <:patt< () >> + | Sexpr loc [se :: sel] -> Right (se, sel) + | se -> error se "ipatt" ] +and type_declaration_list_se = + fun + [ [se1; se2 :: sel] -> + let (n1, loc1, tpl) = + match se1 with + [ Sexpr _ [Slid loc n :: sel] -> + (n, loc, List.map type_parameter_se sel) + | Slid loc n -> (n, loc, []) + | se -> error se "type declaration" ] + in + [((loc1, Pcaml.rename_id.val n1), tpl, ctyp_se se2, []) :: + type_declaration_list_se sel] + | [] -> [] + | [se :: _] -> error se "type_declaration" ] +and type_parameter_se = + fun + [ Slid _ s when String.length s >= 2 && s.[0] = ''' -> + (String.sub s 1 (String.length s - 1), (False, False)) + | se -> error se "type_parameter" ] +and ctyp_se = + fun + [ Sexpr loc [Slid _ "sum" :: sel] -> + let cdl = List.map constructor_declaration_se sel in + <:ctyp< [ $list:cdl$ ] >> + | Srec loc sel -> + let ldl = List.map label_declaration_se sel in + <:ctyp< { $list:ldl$ } >> + | Sexpr loc [Slid _ "->" :: ([_; _ :: _] as sel)] -> + let rec loop = + fun + [ [] -> assert False + | [se] -> ctyp_se se + | [se :: sel] -> + let t1 = ctyp_se se in + let loc = (fst (loc_of_sexpr se), snd loc) in + let t2 = loop sel in + <:ctyp< $t1$ -> $t2$ >> ] + in + loop sel + | Sexpr loc [Slid _ "*" :: sel] -> + let tl = List.map ctyp_se sel in + <:ctyp< ($list:tl$) >> + | Sexpr loc [se :: sel] -> + List.fold_left + (fun t se -> + let t2 = ctyp_se se in + <:ctyp< $t$ $t2$ >>) + (ctyp_se se) sel + | Sacc loc se1 se2 -> + let t1 = ctyp_se se1 in + let t2 = ctyp_se se2 in + <:ctyp< $t1$ . $t2$ >> + | Slid loc "_" -> <:ctyp< _ >> + | Slid loc s -> + if s.[0] = ''' then + let s = String.sub s 1 (String.length s - 1) in + <:ctyp< '$s$ >> + else <:ctyp< $lid:(Pcaml.rename_id.val s)$ >> + | Suid loc s -> <:ctyp< $uid:(Pcaml.rename_id.val s)$ >> + | se -> error se "ctyp" ] +and constructor_declaration_se = + fun + [ Sexpr loc [Suid _ ci :: sel] -> + (loc, Pcaml.rename_id.val ci, List.map ctyp_se sel) + | se -> error se "constructor_declaration" ] +and label_declaration_se = + fun + [ Sexpr loc [Slid _ lab; Slid _ "mutable"; se] -> + (loc, Pcaml.rename_id.val lab, True, ctyp_se se) + | Sexpr loc [Slid _ lab; se] -> + (loc, Pcaml.rename_id.val lab, False, ctyp_se se) + | se -> error se "label_declaration" ] +; + +value directive_se = + fun + [ Sexpr _ [Slid _ s] -> (s, None) + | Sexpr _ [Slid _ s; se] -> + let e = expr_se se in + (s, Some e) + | se -> error se "directive" ] +; + +(* Parser *) + +Pcaml.syntax_name.val := "Scheme"; +Pcaml.no_constructors_arity.val := False; + +do { + Grammar.Unsafe.gram_reinit gram (lexer_gmake ()); + 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 sexpr = Grammar.Entry.create gram "sexpr"; + +value rec leftify = + fun + [ Sacc loc1 se1 se2 -> + match leftify se2 with + [ Sacc loc2 se2 se3 -> Sacc loc1 (Sacc loc2 se1 se2) se3 + | se2 -> Sacc loc1 se1 se2 ] + | x -> x ] +; + +EXTEND + GLOBAL: implem interf top_phrase use_file str_item sig_item expr patt sexpr; + implem: + [ [ "#"; se = sexpr -> + let (n, dp) = directive_se se in + ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True) + | si = str_item; x = SELF -> + let (sil, stopped) = x in + let loc = MLast.loc_of_str_item si in + ([(si, loc) :: sil], stopped) + | EOI -> ([], False) ] ] + ; + interf: + [ [ "#"; se = sexpr -> + let (n, dp) = directive_se se in + ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True) + | si = sig_item; x = SELF -> + let (sil, stopped) = x in + let loc = MLast.loc_of_sig_item si in + ([(si, loc) :: sil], stopped) + | EOI -> ([], False) ] ] + ; + top_phrase: + [ [ "#"; se = sexpr -> + let (n, dp) = directive_se se in + Some <:str_item< # $n$ $opt:dp$ >> + | se = sexpr -> Some (str_item_se se) + | EOI -> None ] ] + ; + use_file: + [ [ "#"; se = sexpr -> + let (n, dp) = directive_se se in + ([<:str_item< # $n$ $opt:dp$ >>], True) + | si = str_item; x = SELF -> + let (sil, stopped) = x in + ([si :: sil], stopped) + | EOI -> ([], False) ] ] + ; + str_item: + [ [ se = sexpr -> str_item_se se + | e = expr -> <:str_item< $exp:e$ >> ] ] + ; + sig_item: + [ [ se = sexpr -> sig_item_se se ] ] + ; + expr: + [ "top" + [ se = sexpr -> expr_se se ] ] + ; + patt: + [ [ se = sexpr -> patt_se se ] ] + ; + sexpr: + [ [ se1 = sexpr_dot; se2 = SELF -> leftify (Sacc loc se1 se2) ] + | [ "("; sl = LIST0 sexpr; ")" -> Sexpr loc sl + | "("; sl = LIST0 sexpr; ")."; se = SELF -> + leftify (Sacc loc (Sexpr loc sl) se) + | "["; sl = LIST0 sexpr; "]" -> Slist loc sl + | "{"; sl = LIST0 sexpr; "}" -> Srec loc sl + | a = pa_extend_keyword -> Slid loc a + | s = LIDENT -> Slid loc s + | s = UIDENT -> Suid loc s + | s = TILDEIDENT -> Stid loc s + | s = QUESTIONIDENT -> Sqid loc s + | s = INT -> Sint loc s + | s = FLOAT -> Sfloat loc s + | s = CHAR -> Schar loc s + | s = STRING -> Sstring loc s + | s = QUOT -> + let i = String.index s ':' in + let typ = String.sub s 0 i in + let txt = String.sub s (i + 1) (String.length s - i - 1) in + Squot loc typ txt ] ] + ; + sexpr_dot: + [ [ s = LIDENTDOT -> Slid loc s + | s = UIDENTDOT -> Suid loc s ] ] + ; + pa_extend_keyword: + [ [ "_" -> "_" + | "," -> "," + | "=" -> "=" + | ":" -> ":" + | "." -> "." + | "/" -> "/" ] ] + ; +END; diff --git a/camlp4/etc/pa_sml.ml b/camlp4/etc/pa_sml.ml index 5b1aac915..ee5db540d 100644 --- a/camlp4/etc/pa_sml.ml +++ b/camlp4/etc/pa_sml.ml @@ -15,6 +15,8 @@ open Stdpp; open Pcaml; +value ocaml_records = ref False; + Pcaml.no_constructors_arity.val := True; value lexer = Plexer.gmake (); @@ -133,7 +135,7 @@ value make_local loc sl1 sl2 = let pl = List.map (fun - [ <:str_item< value $rec:_$ $p$ = $_$ >> -> p + [ <:str_item< value $opt:_$ $p$ = $_$ >> -> p | _ -> raise Exit ]) sl2 in @@ -244,6 +246,67 @@ value function_of_clause_list loc xl = (let loc = fname_loc in <:patt< $lid:fname$ >>, e) ; +value record_expr loc x1 = + if ocaml_records.val then <:expr< { $list:x1$ } >> + else + let list1 = + List.map + (fun (l, v) -> + let id = + match l with + [ <:patt< $lid:l$ >> -> l + | _ -> "" ] + in + let loc = MLast.loc_of_expr v in + <:class_str_item< value $id$ = $v$ >>) + x1 + in + let list2 = + List.map + (fun (l, v) -> + let id = + match l with + [ <:patt< $lid:l$ >> -> l + | _ -> "" ] + in + let loc = MLast.loc_of_patt l in + <:class_str_item< method $id$ = $lid:id$ >>) + x1 + in + <:expr< + let module M = + struct + class a = object $list:list1 @ list2$ end; + end + in + new M.a + >> +; + +value record_match_assoc loc lpl e = + if ocaml_records.val then (<:patt< { $list:lpl$ } >>, e) + else + let pl = List.map (fun (_, p) -> p) lpl in + let e = + let el = + List.map + (fun (l, _) -> + let s = + match l with + [ <:patt< $lid:l$ >> -> l + | _ -> "" ] + in + let loc = MLast.loc_of_patt l in + <:expr< v # $lid:s$ >>) + lpl + in + let loc = MLast.loc_of_expr e in + <:expr< let v = $e$ in ($list:el$) >> + in + let p = <:patt< ($list:pl$) >> in + (p, e) +; + value op = Grammar.Entry.of_parser gram "op" (parser [: `("", "op"); `(_, x) :] -> x) @@ -380,8 +443,10 @@ EXTEND [ "'"; x1 = LIDENT -> <:ctyp< '$x1$ >> | "'"; "'"; x1 = LIDENT -> <:ctyp< '$x1$ >> | "{"; x1 = LIST1 tlabel SEP ","; "}" -> - let list = List.map (fun (_, l, _, t) -> (l, t)) x1 in - <:ctyp< < $list:list$ > >> + if ocaml_records.val then <:ctyp< { $list:x1$ } >> + else + let list = List.map (fun (_, l, _, t) -> (l, t)) x1 in + <:ctyp< < $list:list$ > >> | "{"; "}" -> not_impl loc "ty' 3" | "("; x1 = ctyp; ","; x2 = LIST1 ctyp SEP ","; ")"; x3 = tycon -> List.fold_left (fun t1 t2 -> <:ctyp< $t1$ $t2$ >>) x3 [x1 :: x2] @@ -443,7 +508,9 @@ EXTEND | LEFTA [ x1 = expr; x2 = expr -> <:expr< $x1$ $x2$ >> ] | [ "#"; x1 = STRING -> <:expr< $chr:x1$ >> - | "#"; x1 = selector; x2 = expr -> <:expr< $x2$ # $lid:x1$ >> + | "#"; x1 = selector; x2 = expr -> + if ocaml_records.val then <:expr< $x2$ . $lid:x1$ >> + else <:expr< $x2$ # $lid:x1$ >> | x1 = expr; "ocaml_record_access"; x2 = expr -> <:expr< $x1$ . $x2$ >> ] | [ "!"; x1 = expr -> <:expr< $x1$ . val >> | "~"; x1 = expr -> <:expr< - $x1$ >> ] @@ -479,66 +546,13 @@ EXTEND (fun (p, e) -> match p with [ <:patt< { $list:lpl$ } >> -> - let pl = List.map (fun (_, p) -> p) lpl in - let e = - let el = - List.map - (fun (l, _) -> - let s = - match l with - [ <:patt< $lid:l$ >> -> l - | _ -> "" ] - in - let loc = MLast.loc_of_patt l in - <:expr< v # $lid:s$ >>) - lpl - in - let loc = MLast.loc_of_expr e in - <:expr< let v = $e$ in ($list:el$) >> - in - let p = - let loc = MLast.loc_of_patt p in - <:patt< ($list:pl$) >> - in - (p, e) + record_match_assoc (MLast.loc_of_patt p) lpl e | _ -> (p, e) ]) pel in <:expr< let $list:pel$ in $x2$ >> ]) x1 x2 - | "{"; x1 = LIST1 elabel SEP ","; "}" -> - let list1 = - List.map - (fun (l, v) -> - let id = - match l with - [ <:patt< $lid:l$ >> -> l - | _ -> "" ] - in - let loc = MLast.loc_of_expr v in - <:class_str_item< value $id$ = $v$ >>) - x1 - in - let list2 = - List.map - (fun (l, v) -> - let id = - match l with - [ <:patt< $lid:l$ >> -> l - | _ -> "" ] - in - let loc = MLast.loc_of_patt l in - <:class_str_item< method $id$ = $lid:id$ >>) - x1 - in - <:expr< - let module M = - struct - class a = object $list:list1 @ list2$ end; - end - in - new M.a - >> + | "{"; x1 = LIST1 elabel SEP ","; "}" -> record_expr loc x1 | "["; "]" -> <:expr< [] >> | "["; x1 = expr; "]" -> <:expr< [$x1$] >> | "["; x1 = expr; ","; x2 = LIST1 SELF SEP ","; "]" -> @@ -928,3 +942,6 @@ EXTEND | x = expr; OPT ";" -> not_impl loc "interdec 2" ] ] ; END; + +Pcaml.add_option "-records" (Arg.Set ocaml_records) + "Convert record into OCaml records, instead of objects"; diff --git a/camlp4/etc/parserify.ml b/camlp4/etc/parserify.ml new file mode 100644 index 000000000..c8ce44171 --- /dev/null +++ b/camlp4/etc/parserify.ml @@ -0,0 +1,301 @@ +(* camlp4r q_MLast.cmo *) +(* $Id$ *) + +value loc = (0, 0); + +type spc = + [ SPCterm of (MLast.patt * option MLast.expr) + | SPCnterm of MLast.patt and MLast.expr + | SPCsterm of MLast.patt ] +; + +exception NotImpl; + +value rec subst v e = + match e with + [ <:expr< $lid:x$ >> -> if x = "strm__" then <:expr< $lid:v$ >> else e + | <:expr< $uid:_$ >> -> e + | <:expr< $int:_$ >> -> e + | <:expr< $chr:_$ >> -> e + | <:expr< $str:_$ >> -> e + | <:expr< $e1$ . $lab$ >> -> <:expr< $subst v e1$ . $lab$ >> + | <:expr< $x$ $y$ >> -> <:expr< $subst v x$ $subst v y$ >> + | <:expr< let $lid:s1$ = $e1$ in $e2$ >> -> + if s1 = v then <:expr< let $lid:s1$ = $subst v e1$ in $e2$ >> + else <:expr< let $lid:s1$ = $subst v e1$ in $subst v e2$ >> + | <:expr< let _ = $e1$ in $e2$ >> -> + <:expr< let _ = $subst v e1$ in $subst v e2$ >> + | <:expr< ($list:el$) >> -> <:expr< ($list:List.map (subst v) el$) >> + | _ -> raise NotImpl ] +; + +value rec is_free v = + fun + [ <:expr< $lid:x$ >> -> x <> v + | <:expr< $uid:_$ >> -> True + | <:expr< $int:_$ >> -> True + | <:expr< $chr:_$ >> -> True + | <:expr< $str:_$ >> -> True + | <:expr< $e$ . $_$ >> -> is_free v e + | <:expr< $x$ $y$ >> -> is_free v x && is_free v y + | <:expr< let $lid:s1$ = $e1$ in $e2$ >> -> + is_free v e1 && (s1 = v || is_free v e2) + | <:expr< let _ = $e1$ in $e2$ >> -> is_free v e1 && is_free v e2 + | <:expr< ($list:el$) >> -> List.for_all (is_free v) el + | _ -> raise NotImpl ] +; + +value gensym = + let cnt = ref 0 in + fun () -> + do { incr cnt; "pr_rp_symb_" ^ string_of_int cnt.val } +; + +value free_var_in_expr c e = + let rec loop_alpha v = + let x = String.make 1 v in + if is_free x e then Some x + else if v = 'z' then None + else loop_alpha (Char.chr (Char.code v + 1)) + in + let rec loop_count cnt = + let x = String.make 1 c ^ string_of_int cnt in + if is_free x e then x else loop_count (succ cnt) + in + try + match loop_alpha c with + [ Some v -> v + | None -> loop_count 1 ] + with + [ NotImpl -> gensym () ] +; + +value parserify = + fun + [ <:expr< $e$ strm__ >> -> e + | e -> <:expr< fun strm__ -> $e$ >> ] +; + +value is_raise_failure = + fun + [ <:expr< raise Stream.Failure >> -> True + | _ -> False ] +; + +value is_raise_error = + fun + [ <:expr< raise (Stream.Error $_$) >> -> True + | _ -> False ] +; + +value semantic e = + try + if is_free "strm__" e then e + else + let v = free_var_in_expr 's' e in + <:expr< let $lid:v$ = strm__ in $subst v e$ >> + with + [ NotImpl -> e ] +; + +value rewrite_parser = + rewrite True where rec rewrite top ge = + match ge with + [ <:expr< let $p$ = try $e$ with [ Stream.Failure -> raise $exc$ ] in + $sp_kont$ >> -> + let f = parserify e in + <:expr< + match try Some ($f$ strm__) with [ Stream.Failure -> None ] with + [ Some $p$ -> $rewrite False sp_kont$ + | _ -> raise $exc$ ] + >> + | <:expr< let $p$ = Stream.count strm__ in $f$ >> -> + try + if is_free "strm__" f then ge + else + let v = free_var_in_expr 's' f in + <:expr< + let $lid:v$ = strm__ in + let $p$ = Stream.count strm__ in $subst v f$ + >> + with + [ NotImpl -> ge ] + | <:expr< let $p$ = strm__ in $e$ >> -> + <:expr< let $p$ = strm__ in $rewrite False e$ >> + | <:expr< let $p$ = $f$ strm__ in $sp_kont$ >> when top -> + <:expr< + match try Some ($f$ strm__) with [ Stream.Failure -> None ] with + [ Some $p$ -> $rewrite False sp_kont$ + | _ -> raise Stream.Failure ] + >> + | <:expr< let $p$ = $e$ in $sp_kont$ >> -> + if match e with + [ <:expr< match try Some $_$ with [ Stream.Failure -> None ] with + [ $list:_$ ] >> + | <:expr< match Stream.peek strm__ with [ $list:_$ ] >> + | <:expr< try $_$ with [ Stream.Failure -> $_$ ] >> + | <:expr< let $_$ = Stream.count strm__ in $_$ >> -> True + | _ -> False ] + then + let f = rewrite True <:expr< fun strm__ -> $e$ >> in + let exc = + if top then <:expr< Stream.Failure >> + else <:expr< Stream.Error "" >> + in + <:expr< + match try Some ($f$ strm__) with [ Stream.Failure -> None ] with + [ Some $p$ -> $rewrite False sp_kont$ + | _ -> raise $exc$ ] + >> + else semantic ge + | <:expr< match try Some $e$ with [ Stream.Failure -> None ] with + [ Some $p$ -> $sp_kont$ + | _ -> $p_kont$ ] >> -> + let f = parserify e in + if not top && is_raise_failure p_kont then semantic ge + else + let (p, f, sp_kont, p_kont) = + if top || is_raise_error p_kont then + (p, f, rewrite False sp_kont, rewrite top p_kont) + else + let f = + <:expr< + fun strm__ -> + match + try Some ($f$ strm__) with [ Stream.Failure -> None ] + with + [ Some $p$ -> $rewrite False sp_kont$ + | _ -> $rewrite top p_kont$ ] + >> + in + (<:patt< a >>, f, <:expr< a >>, + <:expr< raise (Stream.Error "") >>) + in + <:expr< + match try Some ($f$ strm__) with [ Stream.Failure -> None ] with + [ Some $p$ -> $sp_kont$ + | _ -> $p_kont$ ] + >> + | <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> -> + let rec iter pel = + match pel with + [ [(<:patt< Some $p$ >>, eo, + <:expr< do { Stream.junk strm__; $sp_kont$ } >>); + (<:patt< _ >>, None, p_kont) :: _] -> + <:expr< + match Stream.peek strm__ with + [ Some $p$ $when:eo$ -> + do { Stream.junk strm__; $rewrite False sp_kont$ } + | _ -> $rewrite top p_kont$ ] + >> + | [(<:patt< Some $p$ >>, eo, + <:expr< do { Stream.junk strm__; $sp_kont$ } >>) :: pel] -> + let p_kont = iter pel in + <:expr< + match Stream.peek strm__ with + [ Some $p$ $when:eo$ -> + do { Stream.junk strm__; $rewrite False sp_kont$ } + | _ -> $p_kont$ ] + >> + | _ -> + <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> ] + in + iter pel + | <:expr< try Some $e$ with [ Stream.Failure -> $p_kont$ ] >> -> + let f = parserify e in + let e = + <:expr< + match try Some ($f$ strm__) with [ Stream.Failure -> None ] with + [ Some a -> Some a + | _ -> $p_kont$ ] + >> + in + rewrite top e + | <:expr< try $e$ with [ Stream.Failure -> $p_kont$ ] >> -> + let f = parserify e in + let e = + <:expr< + match try Some ($f$ strm__) with [ Stream.Failure -> None ] with + [ Some a -> a + | _ -> $rewrite top p_kont$ ] + >> + in + rewrite top e + | <:expr< $f$ strm__ >> -> + if top then + <:expr< + match try Some ($f$ strm__) with [ Stream.Failure -> None ] with + [ Some a -> a + | _ -> raise Stream.Failure ] + >> + else + let v = free_var_in_expr 's' f in + <:expr< let $lid:v$ = strm__ in $subst v f$ $lid:v$ >> + | e -> semantic e ] +; + +value spc_of_parser = + let rec parser_cases e = + match e with + [ <:expr< + match try Some ($f$ strm__) with [ Stream.Failure -> None ] with + [ Some $p$ -> $sp_kont$ + | _ -> $p_kont$ ] + >> -> + let spc = (SPCnterm p f, None) in + let (sp, epo, e) = kont sp_kont in + [([spc :: sp], epo, e) :: parser_cases p_kont] + | <:expr< + match Stream.peek strm__ with + [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ } + | _ -> $p_kont$ ] + >> -> + let spc = (SPCterm (p, wo), None) in + let (sp, epo, e) = kont sp_kont in + [([spc :: sp], epo, e) :: parser_cases p_kont] + | <:expr< let $p$ = strm__ in $sp_kont$ >> -> + let spc = (SPCsterm p, None) in + let (sp, epo, e) = kont sp_kont in + [([spc :: sp], epo, e)] + | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> [([], Some p, e)] + | <:expr< raise Stream.Failure >> -> [] + | _ -> [([], None, e)] ] + and kont e = + match e with + [ <:expr< + match try Some ($f$ strm__) with [ Stream.Failure -> None ] with + [ Some $p$ -> $sp_kont$ + | _ -> raise (Stream.Error $err$) ] + >> -> + let err = + match err with + [ <:expr< "" >> -> None + | _ -> Some err ] + in + let spc = (SPCnterm p f, err) in + let (sp, epo, e) = kont sp_kont in + ([spc :: sp], epo, e) + | <:expr< + match Stream.peek strm__ with + [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ } + | _ -> raise (Stream.Error $err$) ] + >> -> + let err = + match err with + [ <:expr< "" >> -> None + | _ -> Some err ] + in + let spc = (SPCterm (p, wo), err) in + let (sp, epo, e) = kont sp_kont in + ([spc :: sp], epo, e) + | <:expr< let $p$ = strm__ in $sp_kont$ >> -> + let spc = (SPCsterm p, None) in + let (sp, epo, e) = kont sp_kont in + ([spc :: sp], epo, e) + | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> ([], Some p, e) + | _ -> ([], None, e) ] + in + parser_cases +; + +value parser_of_expr e = spc_of_parser (rewrite_parser e); diff --git a/camlp4/etc/parserify.mli b/camlp4/etc/parserify.mli new file mode 100644 index 000000000..ece8b8927 --- /dev/null +++ b/camlp4/etc/parserify.mli @@ -0,0 +1,12 @@ +(* camlp4r *) +(* $Id$ *) + +type spc = + [ SPCterm of (MLast.patt * option MLast.expr) + | SPCnterm of MLast.patt and MLast.expr + | SPCsterm of MLast.patt ] +; + +value parser_of_expr : + MLast.expr -> + list (list (spc * option MLast.expr) * option MLast.patt * MLast.expr); diff --git a/camlp4/etc/pr_depend.ml b/camlp4/etc/pr_depend.ml index 4d352fb1f..443bc6097 100644 --- a/camlp4/etc/pr_depend.ml +++ b/camlp4/etc/pr_depend.ml @@ -76,9 +76,10 @@ value rec patt = | PaArr _ pl -> list patt pl | PaChr _ _ -> () | PaInt _ _ -> () - | PaLab _ _ p -> patt p + | PaLab _ _ po -> option patt po | PaLid _ _ -> () - | PaOlb _ _ p eo -> patt p + | PaOlb _ _ peoo -> + option (fun (p, eo) -> do { patt p; option expr eo }) peoo | PaOrp _ p1 p2 -> do { patt p1; patt p2; } | PaRec _ lpl -> list label_patt lpl | PaRng _ p1 p2 -> do { patt p1; patt p2; } @@ -93,9 +94,8 @@ and patt_module = [ PaUid _ m -> addmodule m | PaAcc _ p _ -> patt_module p | x -> not_impl "patt_module" x ] -and label_patt (p1, p2) = do { patt p1; patt p2; }; - -value rec expr = +and label_patt (p1, p2) = do { patt p1; patt p2; } +and expr = fun [ ExAcc _ e1 e2 -> do { expr_module e1; expr e2; } | ExApp _ e1 e2 -> do { expr e1; expr e2; } @@ -109,14 +109,14 @@ value rec expr = | ExIfe _ e1 e2 e3 -> do { expr e1; expr e2; expr e3; } | ExInt _ _ -> () | ExFlo _ _ -> () - | ExLab _ _ e -> expr e + | ExLab _ _ eo -> option expr eo | ExLaz _ e -> expr e | ExLet _ _ pel e -> do { list let_binding pel; expr e; } | ExLid _ _ -> () | ExLmd _ _ me e -> do { module_expr me; expr e; } | ExMat _ e pwel -> do { expr e; list match_case pwel; } | ExNew _ li -> longident li - | ExOlb _ _ e -> expr e + | ExOlb _ _ eo -> option expr eo | ExRec _ lel w -> do { list label_expr lel; option expr w; } | ExSeq _ el -> list expr el | ExSnd _ e _ -> expr e diff --git a/camlp4/etc/pr_o.ml b/camlp4/etc/pr_o.ml index a2b3a9f8f..6e658d35c 100644 --- a/camlp4/etc/pr_o.ml +++ b/camlp4/etc/pr_o.ml @@ -79,7 +79,7 @@ value is_infix = ["=="; "!="; "+"; "+."; "-"; "-."; "*"; "*."; "/"; "/."; "**"; "**."; "="; "=."; "<>"; "<>."; "<"; "<."; ">"; ">."; "<="; "<=."; ">="; ">=."; "^"; "@"; "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; - "&&"; "||"; "~-"; "~-."]; + "quo"; "&&"; "||"; "~-"; "~-."]; fun s -> try Hashtbl.find infixes s with [ Not_found -> False ] } ; @@ -174,6 +174,8 @@ value str_item x dg k = let k = if no_ss.val then k else [: `S RO ";;"; k :] in pr_str_item.pr_fun "top" x "" k ; +value module_type e k = pr_module_type.pr_fun "top" e "" k; +value module_expr e dg k = pr_module_expr.pr_fun "top" e "" k; value expr e dg k = pr_expr.pr_fun "top" e dg k; value patt e dg k = pr_patt.pr_fun "top" e dg k; value expr1 e dg k = pr_expr.pr_fun "expr1" e dg k; @@ -183,7 +185,10 @@ value simple_patt e dg k = pr_patt.pr_fun "simple" e dg k; value ctyp e dg k = pr_ctyp.pr_fun "top" e dg k; value simple_ctyp e dg k = pr_ctyp.pr_fun "simple" e dg k; value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge; -value class_str_item x dg k = pr_class_str_item.pr_fun "" x "" k; +value class_sig_item x dg k = pr_class_sig_item.pr_fun "top" x "" k; +value class_str_item x dg k = pr_class_str_item.pr_fun "top" x "" k; +value class_type x k = pr_class_type.pr_fun "top" x "" k; +value class_expr x k = pr_class_expr.pr_fun "top" x "" k; (* type core *) @@ -204,8 +209,7 @@ value rec labels loc b vl _ k = [ [] -> [: b; k :] | [v] -> [: `label True b v "" k; `LocInfo (snd loc, snd loc) (HVbox [: :]) :] - | [v :: l] -> - [: `label False b v "" [: :]; labels loc [: :] l "" k :] ] + | [v :: l] -> [: `label False b v "" [: :]; labels loc [: :] l "" k :] ] and label is_last b (loc, f, m, t) _ k = let m = flag "mutable" m in let k = [: if is_last then [: :] else [: `S RO ";" :]; k :] in @@ -222,14 +226,12 @@ value rec ctyp_list tel _ k = listws simple_ctyp (S LR "*") tel "" k; value rec variants loc b vl dg k = match vl with [ [] -> [: b; k :] - | [v] -> - [: `variant b v "" k; `LocInfo (snd loc, snd loc) (HVbox [: :]) :] + | [v] -> [: `variant b v "" k; `LocInfo (snd loc, snd loc) (HVbox [: :]) :] | [v :: l] -> [: `variant b v "" [: :]; variants loc [: `S LR "|" :] l "" k :] ] and variant b (loc, c, tl) _ k = match tl with - [ [] -> - HVbox [: `LocInfo loc (HVbox b); `HOVbox [: `S LR c; k :] :] + [ [] -> HVbox [: `LocInfo loc (HVbox b); `HOVbox [: `S LR c; k :] :] | _ -> HVbox [: `LocInfo loc (HVbox b); @@ -296,7 +298,8 @@ value rec meth_list (ml, v) dg k = | ([f :: ml], v) -> [: `field f "" [: `S RO ";" :]; meth_list (ml, v) dg k :] ] and field (lab, t) dg k = - HVbox [: `S LR (var_escaped lab); `S LR ":"; `ctyp t dg k :]; + HVbox [: `S LR (var_escaped lab); `S LR ":"; `ctyp t dg k :] +; (* patterns *) @@ -318,6 +321,7 @@ value rec is_irrefut_patt = | <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl | <:patt< ? $_$ : ($p$) >> -> is_irrefut_patt p | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p + | <:patt< ~ $_$ >> -> True | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p | _ -> False ] ; @@ -334,15 +338,15 @@ pr_expr_fun_args.val := | ge -> ([], ge) ]; value raise_match_failure (bp, ep) k = - let (line, char, _) = + let (fname, line, char, _) = if Pcaml.input_file.val <> "-" then Stdpp.line_of_loc Pcaml.input_file.val (bp, ep) else - (1, bp, ep) + ("-", 1, bp, ep) in HOVbox [: `S LR "raise"; `S LO "("; `S LR "Match_failure"; `S LO "("; - `S LR ("\"" ^ Pcaml.input_file.val ^ "\""); `S RO ","; + `S LR ("\"" ^ fname ^ "\""); `S RO ","; `S LR (string_of_int line); `S RO ","; `S LR (string_of_int char); `S RO ")"; `S RO ")"; k :] ; @@ -474,66 +478,15 @@ value rec mod_ident sl _ k = | [s :: sl] -> [: `S LR s; `S NO "."; mod_ident sl "" k :] ] ; -value rec module_type mt k = - let next = module_type1 in - let rec curr mt k = - match mt with - [ <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> -> - let head = - HVbox - [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; - `HVbox (curr mt1 [: `S RO ")" :]); `S LR "->" :] - in - [: `head; `module_type mt2 k :] - | _ -> [: `next mt k :] ] - in - HVbox (curr mt k) -and module_type1 mt k = - let curr = module_type1 in - let next = module_type2 in - match mt with - [ <:module_type< $mt$ with $list:icl$ >> -> - HVbox - [: `curr mt [: :]; `with_constraints [: `S LR "with" :] icl "" k :] - | _ -> next mt k ] -and module_type2 mt k = - let next = module_type3 in - let rec curr mt k = - match mt with - [ <:module_type< sig $list:s$ end >> -> - let ep = snd (MLast.loc_of_module_type mt) in - [: `BEbox - [: `S LR "sig"; - `HVbox - [: `HVbox [: :]; list sig_item s "" [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] :] - | _ -> [: `next mt k :] ] - in - HVbox (curr mt k) -and module_type3 mt k = - let curr = module_type3 in - let next = module_type5 in - match mt with - [ <:module_type< $mt1$ $mt2$ >> -> - HVbox [: `curr mt1 [: :]; `S LO "("; `next mt2 [: `S RO ")"; k :] :] - | <:module_type< $mt1$ . $mt2$ >> -> - HVbox [: `curr mt1 [: `S NO "." :]; `next mt2 k :] - | _ -> next mt k ] -and module_type5 mt k = - match mt with - [ <:module_type< $lid:s$ >> -> HVbox [: `S LR s; k :] - | <:module_type< $uid:s$ >> -> HVbox [: `S LR s; k :] - | _ -> HVbox [: `S LO "("; `module_type mt [: `S RO ")"; k :] :] ] -and module_declaration b mt k = +value rec module_declaration b mt k = match mt with [ <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> -> module_declaration [: `HVbox - [: b; - `HVbox - [: `S LO "("; `S LR i; `S LR ":"; - `module_type t [: `S RO ")" :] :] :] :] + [: b; + `HVbox + [: `S LO "("; `S LR i; `S LR ":"; + `module_type t [: `S RO ")" :] :] :] :] mt k | _ -> HVbox @@ -548,7 +501,8 @@ and modtype_declaration (s, mt) _ k = HVbox [: `HVbox [: :]; `HVbox - [: `HVbox [: `S LR "module"; `S LR "type"; `S LR s; `S LR "=" :]; + [: `HVbox + [: `S LR "module"; `S LR "type"; `S LR s; `S LR "=" :]; `module_type mt [: :] :]; k :] ] and with_constraints b icl _ k = @@ -571,55 +525,9 @@ and with_constraint b wc _ k = HVbox [: b; `S LR "module"; mod_ident sl "" [: `S LR "=" :]; `module_expr me "" k :] ] -and module_expr me _ k = - let next = module_expr1 in - let rec curr me dg k = - match me with - [ <:module_expr< struct $list:s$ end >> -> - let ep = snd (MLast.loc_of_module_expr me) in - [: `HVbox [: :]; - `HVbox - [: `S LR "struct"; list str_item s "" [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] - | <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> - let head = - HVbox - [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; - `module_type mt [: `S RO ")" :]; `S LR "->" :] - in - [: `head; curr me "" k :] - | _ -> [: `next me "" k :] ] - in - HVbox (curr me "" k) -and module_expr1 me _ k = - let next = module_expr2 in - let rec curr me dg k = - match me with - [ <:module_expr< $me1$ $me2$ >> -> - [: curr me1 "" [: :]; - `HVbox [: `S LO "("; `module_expr me2 "" [: `S RO ")"; k :] :] :] - | _ -> [: `next me "" k :] ] - in - HOVbox (curr me "" k) -and module_expr2 me _ k = - let curr = module_expr2 in - let next = module_expr3 in - match me with - [ <:module_expr< $me1$ . $me2$ >> -> - HVbox [: `curr me1 "" [: `S NO "." :]; `next me2 "" k :] - | _ -> next me "" k ] -and module_expr3 me _ k = - match me with - [ <:module_expr< $uid:s$ >> -> HVbox [: `S LR s; k :] - | <:module_expr< ( $me$ : $mt$ ) >> -> - HVbox - [: `S LO "("; `module_expr me "" [: `S LR ":" :]; - `module_type mt [: `S RO ")"; k :] :] - | <:module_expr< struct $list:_$ end >> -> - HVbox [: `S LO "("; `module_expr me "" [: `S RO ")"; k :] :] - | x -> not_impl "module_expr2" x ] -and module_binding b me k = +; + +value rec module_binding b me k = match me with [ <:module_expr< functor ($s$ : $mt$) -> $mb$ >> -> module_binding @@ -660,46 +568,6 @@ and class_type_parameters (loc, tpl) = [: `S LO "["; listws type_parameter (S RO ",") tpl "" [: `S RO "]" :] :] ] and type_parameter tp dg k = HVbox [: `S LO "'"; `S LR (fst tp); k :] -and class_expr ce k = - match ce with - [ MLast.CeFun _ p ce -> - HVbox - [: `S LR "fun"; `simple_patt p "" [: `S LR "->" :]; - `class_expr ce k :] - | MLast.CeLet _ rf lb ce -> - Vbox - [: `HVbox [: :]; - `bind_list [: `S LR "let"; rec_flag rf :] lb "" [: `S LR "in" :]; - `class_expr ce k :] - | ce -> class_expr1 ce k ] -and class_expr1 ce k = - match ce with - [ MLast.CeApp _ ce e -> - HVbox [: `class_expr1 ce [: :]; `simple_expr e "" k :] - | ce -> class_expr2 ce k ] -and class_expr2 ce k = - match ce with - [ MLast.CeCon _ ci [] -> class_longident ci "" k - | MLast.CeCon _ ci ctcl -> - HVbox - [: `S LO "["; listws ctyp (S RO ",") ctcl "" [: `S RO "]" :]; - `class_longident ci "" k :] - | MLast.CeStr _ csp cf -> - let ep = snd (MLast.loc_of_class_expr ce) in - BEbox - [: `HVbox [: `S LR "object"; `class_self_patt_opt csp :]; - `HVbox - [: `HVbox [: :]; - list class_str_item cf "" [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] - | MLast.CeTyc _ ce ct -> - HVbox - [: `S LO "("; `class_expr ce [: `S LR ":" :]; - `class_type ct [: `S RO ")"; k :] :] - | MLast.CeFun _ _ _ -> - HVbox [: `S LO "("; `class_expr ce [: `S RO ")"; k :] :] - | _ -> HVbox [: `not_impl "class_expr" ce; k :] ] and class_self_patt_opt csp = match csp with [ Some p -> HVbox [: `S LO "("; `patt p "" [: `S RO ")" :] :] @@ -712,11 +580,6 @@ and fun_binding b fb k = [ <:expr< fun $p$ -> $e$ >> -> fun_binding [: b; `simple_patt p "" [: :] :] e k | e -> HVbox [: `HVbox [: b; `S LR "=" :]; `expr e "" k :] ] -and class_type ct k = - match ct with - [ MLast.CtFun _ t ct -> - HVbox [: `ctyp t "" [: `S LR "->" :]; `class_type ct k :] - | _ -> class_signature ct k ] and class_signature cs k = match cs with [ MLast.CtCon _ id [] -> clty_longident id "" k @@ -728,8 +591,7 @@ and class_signature cs k = let ep = snd (MLast.loc_of_class_type cs) in class_self_type [: `S LR "object" :] cst [: `HVbox - [: `HVbox [: :]; - list class_sig_item csf "" [: :]; + [: `HVbox [: :]; list class_sig_item csf "" [: :]; `LocInfo (ep, ep) (HVbox [: :]) :]; `HVbox [: `S LR "end"; k :] :] | _ -> HVbox [: `not_impl "class_signature" cs; k :] ] @@ -741,28 +603,6 @@ and class_self_type b cst k = [ None -> [: :] | Some t -> [: `S LO "("; `ctyp t "" [: `S RO ")" :] :] ] :]; k :] -and class_sig_item csf dg k = - let rec curr csf dg k = - match csf with - [ MLast.CgCtr _ t1 t2 -> - [: `S LR "constraint"; `ctyp t1 "" [: `S LR "=" :]; `ctyp t2 "" k :] - | MLast.CgDcl _ s -> - [: `HVbox [: :]; list class_sig_item s "" [: :] :] - | MLast.CgInh _ ce -> [: `S LR "inherit"; `class_type ce k :] - | MLast.CgMth _ lab pf t -> - [: `HVbox - [: `S LR "method"; private_flag pf; `label lab; `S LR ":" :]; - `ctyp t "" k :] - | MLast.CgVal _ lab mf t -> - [: `HVbox [: `S LR "val"; mutable_flag mf; `label lab; `S LR ":" :]; - `ctyp t "" k :] - | MLast.CgVir _ lab pf t -> - [: `HVbox - [: `S LR "method"; `S LR "virtual"; private_flag pf; - `label lab; `S LR ":" :]; - `ctyp t "" k :] ] - in - LocInfo (MLast.loc_of_class_sig_item csf) (HVbox (curr csf dg k)) and class_description b ci _ k = HVbox [: `HVbox @@ -779,6 +619,111 @@ and class_type_declaration b ci _ k = `class_signature ci.MLast.ciExp k :] ; +pr_module_type.pr_levels := + [{pr_label = "top"; pr_box mt x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> -> + fun curr next dg k -> + let head = + HVbox + [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; + `HVbox (curr mt1 "" [: `S RO ")" :]); `S LR "->" :] + in + [: `head; curr mt2 "" k :] + | e -> fun curr next dg k -> [: `next e dg k :] ]}; + {pr_label = ""; pr_box mt x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_type< $mt$ with $list:icl$ >> -> + fun curr next dg k -> + [: curr mt "" [: :]; + `with_constraints [: `S LR "with" :] icl "" k :] + | e -> fun curr next dg k -> [: `next e dg k :] ]}; + {pr_label = ""; pr_box mt x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_type< sig $list:s$ end >> as mt -> + fun curr next dg k -> + let ep = snd (MLast.loc_of_module_type mt) in + [: `BEbox + [: `S LR "sig"; + `HVbox + [: `HVbox [: :]; list sig_item s "" [: :]; + `LocInfo (ep, ep) (HVbox [: :]) :]; + `HVbox [: `S LR "end"; k :] :] :] + | e -> fun curr next dg k -> [: `next e dg k :] ]}; + {pr_label = ""; pr_box mt x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_type< $mt1$ $mt2$ >> -> + fun curr next dg k -> + [: curr mt1 "" [: :]; `S LO "("; + `next mt2 "" [: `S RO ")"; k :] :] + | <:module_type< $mt1$ . $mt2$ >> -> + fun curr next dg k -> + [: curr mt1 "" [: `S NO "." :]; `next mt2 "" k :] + | e -> fun curr next dg k -> [: `next e dg k :] ]}; + {pr_label = ""; pr_box mt x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_type< $lid:s$ >> -> fun curr next dg k -> [: `S LR s; k :] + | <:module_type< $uid:s$ >> -> fun curr next dg k -> [: `S LR s; k :] + | mt -> + fun curr next dg k -> + [: `S LO "("; `module_type mt [: `S RO ")"; k :] :] ]}]; + +pr_module_expr.pr_levels := + [{pr_label = "top"; pr_box mt x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_expr< struct $list:s$ end >> as me -> + fun curr next dg k -> + let ep = snd (MLast.loc_of_module_expr me) in + [: `HVbox [: :]; + `HVbox + [: `S LR "struct"; list str_item s "" [: :]; + `LocInfo (ep, ep) (HVbox [: :]) :]; + `HVbox [: `S LR "end"; k :] :] + | <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> + fun curr next dg k -> + let head = + HVbox + [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; + `module_type mt [: `S RO ")" :]; `S LR "->" :] + in + [: `head; curr me "" k :] + | e -> fun curr next dg k -> [: `next e dg k :] ]}; + {pr_label = ""; pr_box mt x = HOVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_expr< $me1$ $me2$ >> -> + fun curr next dg k -> + [: curr me1 "" [: :]; + `HVbox + [: `S LO "("; `module_expr me2 "" [: `S RO ")"; k :] :] :] + | e -> fun curr next dg k -> [: `next e dg k :] ]}; + {pr_label = ""; pr_box mt x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_expr< $me1$ . $me2$ >> -> + fun curr next dg k -> + [: curr me1 "" [: `S NO "." :]; `next me2 "" k :] + | e -> fun curr next dg k -> [: `next e dg k :] ]}; + {pr_label = ""; pr_box mt x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_expr< $uid:s$ >> -> fun curr next dg k -> [: `S LR s; k :] + | <:module_expr< ( $me$ : $mt$ ) >> -> + fun curr next dg k -> + [: `S LO "("; `module_expr me "" [: `S LR ":" :]; + `module_type mt [: `S RO ")"; k :] :] + | <:module_expr< struct $list:_$ end >> | + <:module_expr< functor ($_$ : $_$) -> $_$ >> | + <:module_expr< $_$ $_$ >> | <:module_expr< $_$ . $_$ >> as me -> + fun curr next dg k -> + [: `S LO "("; `module_expr me "" [: `S RO ")"; k :] :] ]}]; + pr_sig_item.pr_levels := [{pr_label = "top"; pr_box s x = LocInfo (MLast.loc_of_sig_item s) (HVbox x); @@ -818,7 +763,9 @@ pr_sig_item.pr_levels := [: `HVbox [: :]; listwbws class_type_declaration [: `S LR "class"; `S LR "type" :] (S LR "and") cd "" - k :] ]}]; + k :] + | MLast.SgUse _ _ _ -> + fun curr next dg k -> [: :] ]}]; pr_str_item.pr_levels := [{pr_label = "top"; @@ -859,7 +806,7 @@ pr_str_item.pr_levels := fun curr next dg k -> [: `S LR "include"; `module_expr me "" k :] | <:str_item< type $list:tdl$ >> -> fun curr next dg k -> [: `type_list [: `S LR "type" :] tdl "" k :] - | <:str_item< value $rec:rf$ $list:pel$ >> -> + | <:str_item< value $opt:rf$ $list:pel$ >> -> fun curr next dg k -> [: `bind_list [: `S LR "let"; if rf then [: `S LR "rec" :] else [: :] :] @@ -888,7 +835,9 @@ pr_str_item.pr_levels := [: `HVbox [: :]; listwbws class_type_declaration [: `S LR "class"; `S LR "type" :] (S LR "and") cd "" - k :] ]}]; + k :] + | MLast.StUse _ _ _ -> + fun curr next dg k -> [: :] ]}]; value ocaml_char = fun @@ -908,7 +857,7 @@ pr_expr.pr_levels := {pr_label = "expr1"; pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x); pr_rules = extfun Extfun.empty with - [ <:expr< let $rec:r$ $p1$ = $e1$ in $e$ >> -> + [ <:expr< let $opt:r$ $p1$ = $e1$ in $e$ >> -> fun curr next dg k -> let r = if r then [: `S LR "rec" :] else [: :] in if dg <> ";" then @@ -929,7 +878,7 @@ pr_expr.pr_levels := [: `S LR "in" :]; `expr e "" [: :] :]; `HVbox [: `S LR "end"; k :] :] :] - | <:expr< let $rec:r$ $list:pel$ in $e$ >> -> + | <:expr< let $opt:r$ $list:pel$ in $e$ >> -> fun curr next dg k -> let r = if r then [: `S LR "rec" :] else [: :] in if dg <> ";" then @@ -1078,15 +1027,13 @@ pr_expr.pr_levels := [: `BEbox [: `HVbox [: `S LR "else"; `S LR "if" :]; - `expr e1 "" [: :]; - `S LR "then" :]; + `expr e1 "" [: :]; `S LR "then" :]; `expr1 e2 "else" k :]) eel "" [: :]; `HVbox [: `BEbox [: `HVbox [: `S LR "else"; `S LR "if" :]; - `expr e1f "" [: :]; - `S LR "then" :]; + `expr e1f "" [: :]; `S LR "then" :]; `expr1 e2f dg k :] :] :] | (eel, e) -> [: `HVbox @@ -1102,8 +1049,7 @@ pr_expr.pr_levels := [: `BEbox [: `HVbox [: `S LR "else"; `S LR "if" :]; - `expr e1 "" [: :]; - `S LR "then" :]; + `expr e1 "" [: :]; `S LR "then" :]; `expr1 e2 "else" k :]) eel "" [: :]; `HVbox [: `S LR "else"; `expr1 e dg k :] :] :] ] @@ -1124,8 +1070,7 @@ pr_expr.pr_levels := [: `BEbox [: `HVbox [: `S LR "else"; `S LR "if" :]; - `expr e1 "" [: :]; - `S LR "then" :]; + `expr e1 "" [: :]; `S LR "then" :]; `expr1 e2 "" [: :] :]) eel "" [: :]; `HVbox [: `S LR "else"; `expr1 e "" k :] :] :] ] @@ -1275,9 +1220,11 @@ pr_expr.pr_levels := fun curr next dg k -> [: `next e "" k :] | <:expr< lazy ($x$) >> -> fun curr next dg k -> [: `S LR "lazy"; `next x "" k :] - | <:expr< assert False >> -> + | MLast.ExAsf _ -> +(* | <:expr< assert False >> -> *) fun curr next dg k -> [: `S LR "assert"; `S LR "false"; k :] - | <:expr< assert ($e$) >> -> + | MLast.ExAsr _ e -> +(* | <:expr< assert ($e$) >> -> *) fun curr next dg k -> [: `S LR "assert"; `next e "" k :] | <:expr< $lid:n$ $x$ $y$ >> as e -> fun curr next dg k -> @@ -1295,8 +1242,6 @@ pr_expr.pr_levels := listws (fun x _ k -> HOVbox [: curr x "" k :]) (S RO ",") al "" [: `S RO ")"; k :] :] :] | _ -> [: curr x "" [: :]; `next y "" k :] ] - | MLast.ExNew _ sl -> - fun curr next dg k -> [: `S LR "new"; `class_longident sl "" k :] | e -> fun curr next dg k -> [: `next e dg k :] ]}; {pr_label = "dot"; pr_box _ x = HOVbox x; pr_rules = @@ -1359,11 +1304,11 @@ pr_expr.pr_levels := | <:expr< $lid:s$ >> -> fun curr next dg k -> [: `S LR (var_escaped s); k :] | <:expr< ` $i$ >> -> fun curr next dg k -> [: `S LR ("`" ^ i); k :] - | <:expr< ~ $i$ : $lid:j$ >> when i = j -> + | <:expr< ~ $i$ >> -> fun curr next dg k -> [: `S LR ("~" ^ i); k :] | <:expr< ~ $i$ : $e$ >> -> fun curr next dg k -> [: `S LO ("~" ^ i ^ ":"); curr e "" k :] - | <:expr< ? $i$ : $lid:j$ >> when i = j -> + | <:expr< ? $i$ >> -> fun curr next dg k -> [: `S LR ("?" ^ i); k :] | <:expr< ? $i$ : $e$ >> -> fun curr next dg k -> [: `S LO ("?" ^ i ^ ":"); curr e "" k :] @@ -1396,8 +1341,10 @@ pr_expr.pr_levels := fun curr next dg k -> [: `S LO "("; `expr e "" [: `S LR ":>" :]; `ctyp t2 "" [: `S RO ")"; k :] :] - | MLast.ExOvr _ [] -> fun curr next dg k -> [: `S LR "{< >}"; k :] - | MLast.ExOvr _ fel -> + | <:expr< new $list:sl$ >> -> + fun curr next dg k -> [: `S LR "new"; `class_longident sl "" k :] + | <:expr< {< >} >> -> fun curr next dg k -> [: `S LR "{< >}"; k :] + | <:expr< {< $list:fel$ >} >> -> fun curr next dg k -> [: `S LR "{<"; listws field_expr (S RO ";") fel dg [: `S LR ">}"; k :] :] @@ -1412,21 +1359,19 @@ pr_expr.pr_levels := [: `HVbox [: :]; listws expr1 (S RO ";") el "" [: :] :]; `HVbox [: `S LR "end"; k :] :] :] ] - | <:expr< $_$ $_$ >> | <:expr< $uid:_$ $_$ $_$ >> | + | <:expr< $_$ $_$ >> | <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> | + <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> | + <:expr< $_$ # $_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< match $_$ with [ $list:_$ ] >> | - <:expr< if $_$ then $_$ else $_$ >> | <:expr< try $_$ with [ $list:_$ ] >> | - <:expr< let $rec:_$ $list:_$ in $_$ >> | + <:expr< if $_$ then $_$ else $_$ >> | <:expr< for $_$ = $_$ $to:_$ $_$ do { $list:_$ } >> | <:expr< while $_$ do { $list:_$ } >> | <:expr< ($list: _$) >> | - <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> | - <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> | - <:expr< $_$ # $_$ >> | - <:expr< let module $_$ = $_$ in $_$ >> | - <:expr< new $list:_$ >> as e -> + <:expr< let $opt:_$ $list:_$ in $_$ >> | + <:expr< let module $_$ = $_$ in $_$ >> as e -> fun curr next dg k -> [: `S LO "("; `expr e "" [: `HVbox [: `S RO ")"; k :] :] :] - | e -> fun curr next dg k -> [: `next e "" k :] ]}]; + | e -> fun curr next _ k -> [: `not_impl "expr" e :] ]}]; pr_patt.pr_levels := [{pr_label = "top"; pr_box p x = LocInfo (MLast.loc_of_patt p) (HOVCbox x); @@ -1550,36 +1495,31 @@ pr_patt.pr_levels := | <:patt< ` $i$ >> -> fun curr next dg k -> [: `S LR ("`" ^ i); k :] | <:patt< # $list:sl$ >> -> fun curr next dg k -> [: `S LO "#"; mod_ident sl dg k :] - | <:patt< ~ $i$ : $lid:j$ >> when i = j -> + | <:patt< ~ $i$ >> -> fun curr next dg k -> [: `S LR ("~" ^ i); k :] | <:patt< ~ $i$ : $p$ >> -> fun curr next dg k -> [: `S LO ("~" ^ i ^ ":"); `simple_patt p "" k :] | <:patt< ? $i$ : ($p$) >> -> fun curr next dg k -> - match p with - [ <:patt< $lid:x$ >> when i = x -> [: `S LR ("?" ^ i); k :] - | _ -> [: `S LO ("?" ^ i ^ ":"); `simple_patt p "" k :] ] + if i = "" then [: `S LO "?"; `simple_patt p "" k :] + else [: `S LO ("?" ^ i ^ ":"); `simple_patt p "" k :] | <:patt< ? $i$ : ($p$ = $e$) >> -> fun curr next dg k -> - match p with - [ <:patt< $lid:x$ >> when i = x -> - [: `S LO "?"; `S LO "("; `patt p "" [: `S LR "=" :]; - `expr e "" [: `S RO ")"; k :] :] - | _ -> - [: `S LO ("?" ^ i ^ ":"); `S LO "("; - `patt p "" [: `S LR "=" :]; - `expr e "" [: `S RO ")"; k :] :] ] + if i = "" then + [: `S LO "?"; `S LO "("; `patt p "" [: `S LR "=" :]; + `expr e "" [: `S RO ")"; k :] :] + else + [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p "" [: `S LR "=" :]; + `expr e "" [: `S RO ")"; k :] :] | <:patt< ? $i$ : ($p$ : $t$ = $e$) >> -> fun curr next dg k -> - match p with - [ <:patt< $lid:x$ >> when i = x -> - [: `S LO "?"; `S LO "("; `patt p "" [: `S LR "=" :]; - `expr e "" [: `S RO ")"; k :] :] - | _ -> - [: `S LO ("?" ^ i ^ ":"); `S LO "("; - `patt p "" [: `S LR "=" :]; - `expr e "" [: `S RO ")"; k :] :] ] + if i = "" then + [: `S LO "?"; `S LO "("; `patt p "" [: `S LR "=" :]; + `expr e "" [: `S RO ")"; k :] :] + else + [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p "" [: `S LR "=" :]; + `expr e "" [: `S RO ")"; k :] :] | <:patt< _ >> -> fun curr next dg k -> [: `S LR "_"; k :] | <:patt< $_$ $_$ >> | <:patt< ($_$ as $_$) >> | <:patt< $_$ | $_$ >> | <:patt< ($list:_$) >> | <:patt< $_$ .. $_$ >> as p -> @@ -1671,8 +1611,8 @@ pr_ctyp.pr_levels := fun curr next dg k -> let loc = MLast.loc_of_ctyp t in [: `Vbox - [: `HVbox [: :]; - variants loc [: `S LR " " :] ctl "" [: :]; k :] :] + [: `HVbox [: :]; variants loc [: `S LR " " :] ctl "" [: :]; + k :] :] | <:ctyp< [ = $list:rfl$ ] >> -> fun curr next dg k -> [: `HVbox @@ -1716,13 +1656,12 @@ pr_ctyp.pr_levels := | t -> fun curr next dg k -> [: `next t "" k :] ]}]; pr_class_str_item.pr_levels := - [{pr_label = ""; + [{pr_label = "top"; pr_box s x = LocInfo (MLast.loc_of_class_str_item s) (HVbox x); pr_rules = extfun Extfun.empty with [ MLast.CrDcl _ s -> - fun curr next dg k -> - [: `HVbox [: :]; list class_str_item s "" [: :] :] + fun curr next dg k -> [: `HVbox [: :]; list class_str_item s "" k :] | MLast.CrInh _ ce pb -> fun curr next dg k -> [: `S LR "inherit"; `class_expr ce [: :]; @@ -1743,7 +1682,7 @@ pr_class_str_item.pr_levels := | MLast.CrMth _ lab pf fb (Some t) -> fun curr next dg k -> [: `HOVbox - [: `S LR "method"; private_flag pf; `label lab; `S LR ":"; + [: `S LR "method"; private_flag pf; `label lab; `S LR ":"; `ctyp t "" [: `S LR "=" :] :]; `expr fb "" k :] | MLast.CrCtr _ t1 t2 -> @@ -1754,6 +1693,97 @@ pr_class_str_item.pr_levels := fun curr next dg k -> [: `S LR "initializer"; `expr se "" k :] | csi -> fun curr next dg k -> [: `next csi "" k :] ]}]; +pr_class_sig_item.pr_levels := + [{pr_label = "top"; + pr_box s x = LocInfo (MLast.loc_of_class_sig_item s) (HVbox x); + pr_rules = + extfun Extfun.empty with + [ MLast.CgCtr _ t1 t2 -> + fun curr next dg k -> + [: `S LR "constraint"; `ctyp t1 "" [: `S LR "=" :]; + `ctyp t2 "" k :] + | MLast.CgDcl _ s -> + fun curr next dg k -> + [: `HVbox [: :]; list class_sig_item s "" [: :] :] + | MLast.CgInh _ ce -> + fun curr next dg k -> [: `S LR "inherit"; `class_type ce k :] + | MLast.CgMth _ lab pf t -> + fun curr next dg k -> + [: `HVbox + [: `S LR "method"; private_flag pf; `label lab; + `S LR ":" :]; + `ctyp t "" k :] + | MLast.CgVal _ lab mf t -> + fun curr next dg k -> + [: `HVbox + [: `S LR "val"; mutable_flag mf; `label lab; `S LR ":" :]; + `ctyp t "" k :] + | MLast.CgVir _ lab pf t -> + fun curr next dg k -> + [: `HVbox + [: `S LR "method"; `S LR "virtual"; private_flag pf; + `label lab; `S LR ":" :]; + `ctyp t "" k :] + | csi -> fun curr next dg k -> [: `next csi "" k :] ]}]; + +pr_class_type.pr_levels := + [{pr_label = "top"; pr_box s x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ MLast.CtFun _ t ct -> + fun curr next dg k -> + [: `ctyp t "" [: `S LR "->" :]; curr ct "" k :] + | ct -> fun curr next dg k -> [: `class_signature ct k :] ]}]; + +pr_class_expr.pr_levels := + [{pr_label = "top"; pr_box s x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ MLast.CeFun _ p ce -> + fun curr next dg k -> + [: `S LR "fun"; `simple_patt p "" [: `S LR "->" :]; + `class_expr ce k :] + | MLast.CeLet _ rf lb ce -> + fun curr next dg k -> + [: `Vbox + [: `HVbox [: :]; + `bind_list [: `S LR "let"; rec_flag rf :] lb "" + [: `S LR "in" :]; + `class_expr ce k :] :] + | x -> fun curr next dg k -> [: `next x "" k :] ]}; + {pr_label = ""; pr_box s x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ MLast.CeApp _ ce e -> + fun curr next dg k -> [: curr ce "" [: :]; `simple_expr e "" k :] + | x -> fun curr next dg k -> [: `next x "" k :] ]}; + {pr_label = ""; pr_box s x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ MLast.CeCon _ ci [] -> + fun curr next dg k -> [: `class_longident ci "" k :] + | MLast.CeCon _ ci ctcl -> + fun curr next dg k -> + [: `S LO "["; listws ctyp (S RO ",") ctcl "" [: `S RO "]" :]; + `class_longident ci "" k :] + | MLast.CeStr _ csp cf as ce -> + let ep = snd (MLast.loc_of_class_expr ce) in + fun curr next dg k -> + [: `BEbox + [: `HVbox [: `S LR "object"; `class_self_patt_opt csp :]; + `HVbox + [: `HVbox [: :]; list class_str_item cf "" [: :]; + `LocInfo (ep, ep) (HVbox [: :]) :]; + `HVbox [: `S LR "end"; k :] :] :] + | MLast.CeTyc _ ce ct -> + fun curr next dg k -> + [: `S LO "("; `class_expr ce [: `S LR ":" :]; + `class_type ct [: `S RO ")"; k :] :] + | MLast.CeFun _ _ _ as ce -> + fun curr next dg k -> + [: `S LO "("; `class_expr ce [: `S RO ")"; k :] :] + | ce -> fun curr next dg k -> [: `not_impl "class_expr" ce; k :] ]}]; + value output_string_eval oc s = loop 0 where rec loop i = if i == String.length s then () @@ -1770,15 +1800,20 @@ value ncip = ref True; value input_source ic len = let buff = Buffer.create 20 in - let rec loop i = - if i = len then Buffer.contents buff - else do { - let c = input_char ic in - Buffer.add_char buff c; - loop (i + 1) - } - in - loop 0 + try + let rec loop i = + if i >= len then Buffer.contents buff + else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) } + in + loop 0 + with + [ End_of_file -> + let s = Buffer.contents buff in + if s = "" then + match sep.val with + [ Some s -> s + | None -> "\n" ] + else s ] ; value copy_source ic oc first bp ep = @@ -1789,9 +1824,7 @@ value copy_source ic oc first bp ep = else output_string_eval oc str | None -> do { - seek_in ic bp; - let s = input_source ic (ep - bp) in - output_string oc s + seek_in ic bp; let s = input_source ic (ep - bp) in output_string oc s } ] ; @@ -1858,7 +1891,7 @@ value extract_comment strm = | [: :] -> Buff.get len ] and find_star2 len = parser - [ [: `'*'; len = insert2 (Buff.store len '*'); s :] -> len + [ [: `'*'; a = insert2 (Buff.store len '*') :] -> a | [: :] -> len ] and insert2 len = parser @@ -1868,7 +1901,7 @@ value extract_comment strm = | [: :] -> 0 ] and rparen2 len = parser - [ [: `')'; s :] -> Buff.store len ')' + [ [: `')' :] -> Buff.store len ')' | [: a = insert2 len :] -> a ] in find_comm 0 0 strm @@ -1908,23 +1941,20 @@ value apply_printer printer ast = else get_no_comment in try - do { - let (first, last_pos) = - List.fold_left - (fun (first, last_pos) (si, (bp, ep)) -> - do { - copy_source ic oc first last_pos bp; - flush oc; - print_pretty pr_ch pr_str pr_nl "" "" maxl.val getcom bp - (printer si "" [: :]); - flush oc; - (False, ep) - }) - (True, 0) ast - in - copy_to_end ic oc first last_pos; - flush oc - } + let (first, last_pos) = + List.fold_left + (fun (first, last_pos) (si, (bp, ep)) -> + do { + copy_source ic oc first last_pos bp; + flush oc; + print_pretty pr_ch pr_str pr_nl "" "" maxl.val getcom bp + (printer si "" [: :]); + flush oc; + (False, ep) + }) + (True, 0) ast + in + do { copy_to_end ic oc first last_pos; flush oc } with x -> do { close_in ic; cleanup (); raise x }; close_in ic; diff --git a/camlp4/etc/pr_op_main.ml b/camlp4/etc/pr_op_main.ml new file mode 100644 index 000000000..d7203e6e3 --- /dev/null +++ b/camlp4/etc/pr_op_main.ml @@ -0,0 +1,214 @@ +(* camlp4r q_MLast.cmo ./pa_extfun.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; +open Spretty; + +value loc = (0, 0); + +value expr e dg k = pr_expr.pr_fun "top" e dg k; +value patt e dg k = pr_patt.pr_fun "top" e dg k; + +value spatt p dg k = + match p with + [ <:patt< $lid:s$ >> -> + if String.length s >= 2 && s.[1] == ''' then + HVbox [: `S LR (" " ^ s); k :] + else patt p dg k + | _ -> patt p dg k ] +; + +(* Streams *) + +value stream e _ k = + let rec get = + fun + [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y] + | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y] + | <:expr< Stream.ising $x$ >> -> [(True, x)] + | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y] + | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y] + | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)] + | <:expr< Stream.sempty >> -> [] + | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)] + | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)] + | e -> [(False, e)] ] + in + let elem e dg k = + match e with + [ (True, e) -> [: `HOVbox [: `S LO "'"; `expr e dg k :] :] + | (False, e) -> [: `expr e dg k :] ] + in + let rec glop e k = + match e with + [ [] -> k + | [e] -> [: elem e "" k :] + | [e :: el] -> [: elem e ";" [: `S RO ";" :]; glop el k :] ] + in + HOVbox [: `S LR "[<"; glop (get e) [: `S LR ">]"; k :] :] +; + +(* Parsers *) + +open Parserify; + +value parser_cases b spel dg k = + let rec parser_cases b spel dg k = + match spel with + [ [] -> [: `HVbox [: b; k :] :] + | [(sp, epo, e)] -> [: `parser_case b sp epo e dg k :] + | [(sp, epo, e) :: spel] -> + [: `parser_case b sp epo e "|" [: :]; + parser_cases [: `S LR "|" :] spel dg k :] ] + and parser_case b sp epo e dg k = + let epo = + match epo with + [ Some p -> [: `patt p "" [: `S LR "->" :] :] + | _ -> [: `S LR "->" :] ] + in + HVbox + [: b; + `HOVbox + [: `HOVbox + [: `S LR "[<"; + stream_patt [: :] sp [: `S LR ">]"; epo :] :]; + `expr e dg k :] :] + and stream_patt b sp k = + match sp with + [ [] -> [: `HVbox [: b; k :] :] + | [(spc, None)] -> [: `stream_patt_comp b spc "" k :] + | [(spc, Some e)] -> + [: `HVbox + [: `stream_patt_comp b spc "" [: :]; + `HVbox [: `S LR "??"; `expr e "" k :] :] :] + | [(spc, None) :: spcl] -> + [: `stream_patt_comp b spc ";" [: `S RO ";" :]; + stream_patt [: :] spcl k :] + | [(spc, Some e) :: spcl] -> + [: `HVbox + [: `stream_patt_comp b spc "" [: :]; + `HVbox [: `S LR "??"; `expr e ";" [: `S RO ";" :] :] :]; + stream_patt [: :] spcl k :] ] + and stream_patt_comp b spc dg k = + match spc with + [ SPCterm (p, w) -> + HVbox [: b; `S LO "'"; `spatt p "" (when_opt w k) :] + | SPCnterm p e -> + HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e dg k :] :] + | SPCsterm p -> HVbox [: b; `patt p "" k :] ] + and when_opt wo k = + match wo with + [ Some e -> [: `S LR "when"; `expr e "" k :] + | _ -> k ] + in + parser_cases b spel dg k +; + +value parser_body e dg k = + let (bp, e) = + match e with + [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) + | e -> (None, e) ] + in + match parser_of_expr e with + [ [] -> + let spe = ([], None, <:expr< raise Stream.Failure >>) in + HVbox + [: `HVbox + [: `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + parser_cases [: :] [spe] dg k :] + | spel -> + BEVbox + [: `HVbox + [: `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + parser_cases [: :] spel dg k :] ] +; + +value pmatch e dg k = + let (me, e) = + match e with + [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e) + | _ -> failwith "Pr_op.pmatch" ] + in + let (bp, e) = + match e with + [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) + | e -> (None, e) ] + in + let spel = parser_of_expr e in + Vbox + [: `HVbox [: :]; + `HVbox + [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + `BEbox [: `HVbox [: :]; parser_cases [: :] spel dg k :] :] +; + +(* Printer extensions *) + +pr_expr_fun_args.val := + extfun pr_expr_fun_args.val with + [ <:expr< fun strm__ -> $_$ >> as ge -> ([], ge) + | <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ]; + +let lev = find_pr_level "expr1" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e -> + fun curr next dg k -> + if not (List.mem dg ["|"; ";"]) then [: `pmatch e dg k :] + else [: `S LO "("; `pmatch e "" [: `S RO ")"; k :] :] + | <:expr< fun strm__ -> $x$ >> -> + fun curr next dg k -> + if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :] + else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] + | <:expr< fun [ (strm__ : $_$) -> $x$ ] >> -> + fun curr next dg k -> + if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :] + else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] ]; + +let lev = find_pr_level "apply" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | + <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | + <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | + <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | + <:expr< Stream.slazy $_$ >> as e -> + fun curr next dg k -> [: `next e "" k :] ]; + +let lev = find_pr_level "dot" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Stream.sempty >> as e -> + fun curr next dg k -> [: `next e "" k :] ]; + +let lev = find_pr_level "simple" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | + <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | + <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | + <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | + <:expr< Stream.slazy $_$ >> as e -> + fun curr next dg k -> + [: `stream e "" k :] ]; diff --git a/camlp4/etc/pr_r.ml b/camlp4/etc/pr_r.ml index 11ddd8ecc..1c5c34d7a 100644 --- a/camlp4/etc/pr_r.ml +++ b/camlp4/etc/pr_r.ml @@ -75,10 +75,10 @@ value is_infix = let infixes = Hashtbl.create 73 in do { List.iter (fun s -> Hashtbl.add infixes s True) - ["=="; "!="; "+"; "+."; "-"; "-."; "*"; "*."; "/"; "/."; "**"; "**."; + ["=="; "!="; "+"; "+."; "-"; "-."; "*"; "*."; "/"; "/."; "**"; "="; "=."; "<>"; "<>."; "<"; "<."; ">"; ">."; "<="; "<=."; ">="; ">=."; "^"; "@"; "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; - "quo"; "&&"; "||"; "~-"; "~-."]; + "&&"; "||"; "~-"; "~-."]; fun s -> try Hashtbl.find infixes s with [ Not_found -> False ] } ; @@ -118,7 +118,7 @@ value has_special_chars v = value var_escaped v = if v = "" then "$lid:\"\"$" - else if has_special_chars v then "\\" ^ v + else if has_special_chars v || is_infix v then "\\" ^ v else if is_keyword v then v ^ "__" else v ; @@ -131,6 +131,8 @@ value loc = (0, 0); (* extensible printers *) +value module_type e k = pr_module_type.pr_fun "top" e "" k; +value module_expr e k = pr_module_expr.pr_fun "top" e "" k; value sig_item x k = pr_sig_item.pr_fun "top" x "" [: `S RO ";"; k :]; value str_item x k = pr_str_item.pr_fun "top" x "" [: `S RO ";"; k :]; value expr x k = pr_expr.pr_fun "top" x "" k; @@ -138,9 +140,15 @@ value patt x k = pr_patt.pr_fun "top" x "" k; value ctyp x k = pr_ctyp.pr_fun "top" x "" k; value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge; value simple_expr x k = pr_expr.pr_fun "simple" x "" k; +value class_sig_item x k = + pr_class_sig_item.pr_fun "top" x "" [: `S RO ";"; k :] +; value class_str_item x k = - pr_class_str_item.pr_fun "" x "" [: `S RO ";"; k :] + pr_class_str_item.pr_fun "top" x "" [: `S RO ";"; k :] ; +value class_type x k = pr_class_type.pr_fun "top" x "" k; +value class_expr x k = pr_class_expr.pr_fun "top" x "" k; + (* type core *) @@ -149,11 +157,9 @@ value rec labels loc b vl k = [ [] -> [: b; k :] | [v] -> [: `HVbox - [: `HVbox [: :]; - `label True b v [: :]; + [: `HVbox [: :]; `label True b v [: :]; `LocInfo (snd loc, snd loc) (HVbox k) :] :] - | [v :: l] -> - [: `label False b v [: :]; labels loc [: :] l k :] ] + | [v :: l] -> [: `label False b v [: :]; labels loc [: :] l k :] ] and label is_last b (loc, f, m, t) k = let m = flag "mutable" m in let k = [: if is_last then [: :] else [: `S RO ";" :]; k :] in @@ -172,12 +178,9 @@ value rec variants loc b vl k = [ [] -> [: b; k :] | [v] -> [: `HVbox - [: `HVbox [: :]; - `variant b v [: :]; + [: `HVbox [: :]; `variant b v [: :]; `LocInfo (snd loc, snd loc) (HVbox k) :] :] - | [v :: l] -> - [: `variant b v [: :]; - variants loc [: `S LR "|" :] l k :] ] + | [v :: l] -> [: `variant b v [: :]; variants loc [: `S LR "|" :] l k :] ] and variant b (loc, c, tl) k = match tl with [ [] -> HVbox [: `LocInfo loc (HVbox b); `HOVbox [: `S LR c; k :] :] @@ -223,7 +226,8 @@ value rec meth_list (ml, v) k = | ([], _) -> [: `S LR ".."; k :] | ([f :: ml], v) -> [: `field f [: `S RO ";" :]; meth_list (ml, v) k :] ] and field (lab, t) k = - HVbox [: `S LR (var_escaped lab); `S LR ":"; `ctyp t k :]; + HVbox [: `S LR (var_escaped lab); `S LR ":"; `ctyp t k :] +; (* patterns *) @@ -237,8 +241,10 @@ value rec is_irrefut_patt = List.for_all (fun (_, p) -> is_irrefut_patt p) fpl | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p | <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl + | <:patt< ? $_$ >> -> True | <:patt< ? $_$ : ( $p$ ) >> -> is_irrefut_patt p | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p + | <:patt< ~ $_$ >> -> True | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p | _ -> False ] ; @@ -264,10 +270,12 @@ value rec get_defined_ident = | <:patt< $p1$ | $p2$ >> -> get_defined_ident p1 @ get_defined_ident p2 | <:patt< $p1$ .. $p2$ >> -> get_defined_ident p1 @ get_defined_ident p2 | <:patt< ($p$ : $_$) >> -> get_defined_ident p + | <:patt< ~ $_$ >> -> [] | <:patt< ~ $_$ : $p$ >> -> get_defined_ident p + | <:patt< ? $_$ >> -> [] | <:patt< ? $_$ : ($p$) >> -> get_defined_ident p | <:patt< ? $_$ : ($p$ = $e$) >> -> get_defined_ident p - | MLast.PaAnt _ p -> get_defined_ident p ] + | <:patt< $anti:p$ >> -> get_defined_ident p ] ; value un_irrefut_patt p = @@ -316,7 +324,7 @@ and let_binding b (p, e) k = and let_binding0 b e k = let (pl, e) = expr_fun_args e in match e with - [ <:expr< let $rec:r$ $lid:f$ = fun [ $list:pel$ ] in $e$ >> + [ <:expr< let $opt:r$ $lid:f$ = fun [ $list:pel$ ] in $e$ >> when let rec call_f = fun @@ -371,7 +379,7 @@ value field_expr (lab, e) k = HVbox [: `label lab; `S LR "="; `expr e k :]; value rec sequence_loop = fun - [ [<:expr< let $rec:r$ $list:pel$ in $e$ >>] -> + [ [<:expr< let $opt:r$ $list:pel$ in $e$ >>] -> let el = match e with [ <:expr< do { $list:el$ } >> -> el @@ -381,7 +389,7 @@ value rec sequence_loop = [: listwbws (fun b (p, e) k -> let_binding b (p, e) k) [: `S LR "let"; r :] (S LR "and") pel [: `S LR "in" :]; sequence_loop el :] - | [(<:expr< let $rec:_$ $list:_$ in $_$ >> as e) :: el] -> + | [(<:expr< let $opt:_$ $list:_$ in $_$ >> as e) :: el] -> [: `simple_expr e [: `S RO ";" :]; sequence_loop el :] | [e] -> [: `expr e [: :] :] | [e :: el] -> [: `expr e [: `S RO ";" :]; sequence_loop el :] @@ -398,7 +406,7 @@ value sequence b1 b2 b3 el k = value rec let_sequence e = match e with [ <:expr< do { $list:el$ } >> -> Some el - | <:expr< let $rec:_$ $list:_$ in $e1$ >> -> + | <:expr< let $opt:_$ $list:_$ in $e1$ >> -> match let_sequence e1 with [ Some _ -> Some [e] | None -> None ] @@ -465,67 +473,15 @@ value rec mod_ident sl k = | [s :: sl] -> [: `S LR s; `S NO "."; mod_ident sl k :] ] ; -value rec module_type mt k = - let next = module_type1 in - match mt with - [ <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> -> - let head = - HVbox - [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; - `module_type mt1 [: `S RO ")" :]; `S LR "->" :] - in - HVbox [: `head; `module_type mt2 k :] - | _ -> next mt k ] -and module_type1 mt k = - let curr = module_type1 in - let next = module_type2 in - match mt with - [ <:module_type< $mt$ with $list:icl$ >> -> - HVbox [: `curr mt [: :]; `with_constraints [: `S LR "with" :] icl k :] - | _ -> next mt k ] -and module_type2 mt k = - let next = module_type3 in - let rec curr mt k = - match mt with - [ <:module_type< sig $list:s$ end >> -> - let ep = snd (MLast.loc_of_module_type mt) in - [: `BEbox - [: `S LR "sig"; - `HVbox - [: `HVbox [: :]; list sig_item s [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] :] - | _ -> [: `next mt k :] ] - in - HVbox (curr mt k) -and module_type3 mt k = - let curr = module_type3 in - let next = module_type4 in - match mt with - [ <:module_type< $mt1$ $mt2$ >> -> HVbox [: `curr mt1 [: :]; `next mt2 k :] - | _ -> next mt k ] -and module_type4 mt k = - let curr = module_type4 in - let next = module_type5 in - match mt with - [ <:module_type< $mt1$ . $mt2$ >> -> - HVbox [: `curr mt1 [: `S NO "." :]; `next mt2 k :] - | _ -> next mt k ] -and module_type5 mt k = - match mt with - [ <:module_type< $lid:s$ >> -> HVbox [: `S LR s; k :] - | <:module_type< $uid:s$ >> -> HVbox [: `S LR s; k :] - | <:module_type< ' $s$ >> -> HVbox [: `S LR ("'" ^ s); k :] - | _ -> HVbox [: `S LO "("; `module_type mt [: `S RO ")"; k :] :] ] -and module_declaration b mt k = +value rec module_declaration b mt k = match mt with [ <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> -> module_declaration [: `HVbox - [: b; - `HVbox - [: `S LO "("; `S LR i; `S LR ":"; - `module_type t [: `S RO ")" :] :] :] :] + [: b; + `HVbox + [: `S LO "("; `S LR i; `S LR ":"; + `module_type t [: `S RO ")" :] :] :] :] mt k | _ -> HVbox @@ -543,7 +499,7 @@ and with_constraints b icl k = HVbox [: `HVbox [: :]; listwbws with_constraint b (S LR "and") icl k :] and with_constraint b wc k = match wc with - [ MLast.WcTyp _ p al e -> + [ <:with_constr< type $p$ $list:al$ = $e$ >> -> let params = match al with [ [] -> [: :] @@ -555,57 +511,10 @@ and with_constraint b wc k = [: `HVbox b; `S LR "type"; params; mod_ident p [: `S LR "=" :] :]; `ctyp e k :] - | MLast.WcMod _ sl me -> + | <:with_constr< module $sl$ = $me$ >> -> HVbox [: b; `S LR "module"; mod_ident sl [: `S LR "=" :]; `module_expr me k :] ] -and module_expr me k = - let next = module_expr1 in - let rec curr me k = - match me with - [ <:module_expr< struct $list:s$ end >> -> - let ep = snd (MLast.loc_of_module_expr me) in - [: `HVbox [: :]; - `HVbox - [: `S LR "struct"; list str_item s [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] - | <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> - let head = - HVbox - [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; - `module_type mt [: `S RO ")" :]; `S LR "->" :] - in - [: `head; curr me k :] - | _ -> [: `next me k :] ] - in - HVbox (curr me k) -and module_expr1 me k = - let next = module_expr2 in - let rec curr me k = - match me with - [ <:module_expr< $me1$ $me2$ >> -> [: curr me1 [: :]; `next me2 k :] - | _ -> [: `next me k :] ] - in - HOVbox (curr me k) -and module_expr2 me k = - let curr = module_expr2 in - let next = module_expr3 in - match me with - [ <:module_expr< $me1$ . $me2$ >> -> - HVbox [: `curr me1 [: `S NO "." :]; `next me2 k :] - | _ -> next me k ] -and module_expr3 me k = - let curr = module_expr3 in - match me with - [ <:module_expr< $uid:s$ >> -> HVbox [: `S LR s; k :] - | <:module_expr< ( $me$ : $mt$ ) >> -> - HVbox - [: `S LO "("; `module_expr me [: `S LR ":" :]; - `module_type mt [: `S RO ")"; k :] :] - | <:module_expr< struct $list:_$ end >> -> - HVbox [: `S LO "("; `module_expr me [: `S RO ")"; k :] :] - | x -> not_impl "module_expr3" x ] and module_binding b me k = match me with [ <:module_expr< functor ($s$ : $mt$) -> $mb$ >> -> @@ -637,7 +546,8 @@ and class_declaration b ci k = ci.MLast.ciExp k and class_fun_binding b ce k = match ce with - [ MLast.CeFun _ p cfb -> class_fun_binding [: b; `patt p [: :] :] cfb k + [ <:class_expr< fun $p$ -> $cfb$ >> -> + class_fun_binding [: b; `patt p [: :] :] cfb k | ce -> HVbox [: `HVbox [: b; `S LR "=" :]; `class_expr ce k :] ] and class_type_parameters (loc, tpl) = match tpl with @@ -645,44 +555,6 @@ and class_type_parameters (loc, tpl) = | tpl -> [: `S LO "["; listws type_parameter (S RO ",") tpl [: `S RO "]" :] :] ] and type_parameter tp k = HVbox [: `S LO "'"; `S LR (fst tp); k :] -and class_expr ce k = - match ce with - [ MLast.CeFun _ p ce -> - HVbox - [: `S LR "fun"; `simple_patt p [: `S LR "->" :]; `class_expr ce k :] - | MLast.CeLet _ rf lb ce -> - Vbox - [: `HVbox [: :]; - `bind_list [: `S LR "let"; flag "rec" rf :] lb [: `S LR "in" :]; - `class_expr ce k :] - | ce -> class_expr1 ce k ] -and class_expr1 ce k = - match ce with - [ MLast.CeApp _ ce e -> HVbox [: `class_expr1 ce [: :]; `simple_expr e k :] - | ce -> class_expr2 ce k ] -and class_expr2 ce k = - match ce with - [ MLast.CeCon _ ci [] -> class_longident ci k - | MLast.CeCon _ ci ctcl -> - HVbox - [: `class_longident ci [: :]; `S LO "["; - listws ctyp (S RO ",") ctcl [: `S RO "]"; k :] :] - | MLast.CeStr _ csp cf -> - let ep = snd (MLast.loc_of_class_expr ce) in - BEbox - [: `HVbox [: `S LR "object"; `class_self_patt_opt csp :]; - `HVbox - [: `HVbox [: :]; - list class_str_item cf [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] - | MLast.CeTyc _ ce ct -> - HVbox - [: `S LO "("; `class_expr ce [: `S LR ":" :]; - `class_type ct [: `S RO ")"; k :] :] - | MLast.CeFun _ _ _ -> - HVbox [: `S LO "("; `class_expr ce [: `S RO ")"; k :] :] - | _ -> HVbox [: `not_impl "class_expr" ce; k :] ] and simple_expr e k = match e with [ <:expr< $lid:_$ >> -> expr e k @@ -701,27 +573,21 @@ and fun_binding b fb k = | e -> HVbox [: `HVbox [: b; `S LR "=" :]; `expr e k :] ] and simple_patt p k = match p with - [ <:patt< $lid:_$ >> | <:patt< ~ $_$ : $_$ >> -> patt p k + [ <:patt< $lid:_$ >> | <:patt< ~ $_$ : $_$ >> | + <:patt< ? $_$ : ($_$ $opt:_$) >> -> patt p k | _ -> HVbox [: `S LO "("; `patt p [: `S RO ")"; k :] :] ] -and class_type ct k = - match ct with - [ MLast.CtFun _ t ct -> - HVbox - [: `S LR "["; `ctyp t [: `S LR "]"; `S LR "->" :]; `class_type ct k :] - | _ -> class_signature ct k ] and class_signature cs k = match cs with - [ MLast.CtCon _ id [] -> clty_longident id k - | MLast.CtCon _ id tl -> + [ <:class_type< $list:id$ >> -> clty_longident id k + | <:class_type< $list:id$ [ $list:tl$ ] >> -> HVbox [: `clty_longident id [: :]; `S LO "["; listws ctyp (S RO ",") tl [: `S RO "]"; k :] :] - | MLast.CtSig _ cst csf -> + | <:class_type< object $opt:cst$ $list:csf$ end >> -> let ep = snd (MLast.loc_of_class_type cs) in class_self_type [: `S LR "object" :] cst [: `HVbox - [: `HVbox [: :]; - list class_sig_item csf [: :]; + [: `HVbox [: :]; list class_sig_item csf [: :]; `LocInfo (ep, ep) (HVbox [: :]) :]; `HVbox [: `S LR "end"; k :] :] | _ -> HVbox [: `not_impl "class_signature" cs; k :] ] @@ -733,29 +599,6 @@ and class_self_type b cst k = [ None -> [: :] | Some t -> [: `S LO "("; `ctyp t [: `S RO ")" :] :] ] :]; k :] -and class_sig_item csf k = - let k = [: `S RO ";"; k :] in - let rec curr csf k = - match csf with - [ MLast.CgCtr _ t1 t2 -> - [: `S LR "type"; `ctyp t1 [: `S LR "=" :]; `ctyp t2 k :] - | MLast.CgDcl _ s -> [: `HVbox [: :]; list class_sig_item s k :] - | MLast.CgInh _ ce -> [: `S LR "inherit"; `class_type ce k :] - | MLast.CgMth _ lab pf t -> - [: `HVbox - [: `S LR "method"; flag "private" pf; `label lab; `S LR ":" :]; - `ctyp t k :] - | MLast.CgVal _ lab mf t -> - [: `HVbox - [: `S LR "value"; flag "mutable" mf; `label lab; `S LR ":" :]; - `ctyp t k :] - | MLast.CgVir _ lab pf t -> - [: `HVbox - [: `S LR "method"; `S LR "virtual"; flag "private" pf; - `label lab; `S LR ":" :]; - `ctyp t k :] ] - in - LocInfo (MLast.loc_of_class_sig_item csf) (HVbox (curr csf k)) and class_description b ci k = HVbox [: `HVbox @@ -770,6 +613,111 @@ and class_type_declaration b ci k = `class_signature ci.MLast.ciExp k :] ; +pr_module_type.pr_levels := + [{pr_label = "top"; pr_box s x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> -> + fun curr next _ k -> + let head = + HVbox + [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; + `module_type mt1 [: `S RO ")" :]; `S LR "->" :] + in + [: `head; `module_type mt2 k :] + | e -> fun curr next dg k -> [: `next e dg k :] ]}; + {pr_label = ""; pr_box s x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_type< $mt$ with $list:icl$ >> -> + fun curr next _ k -> + [: curr mt "" [: :]; `with_constraints [: `S LR "with" :] icl k :] + | e -> fun curr next dg k -> [: `next e dg k :] ]}; + {pr_label = ""; pr_box s x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_type< sig $list:s$ end >> as mt -> + fun curr next _ k -> + let ep = snd (MLast.loc_of_module_type mt) in + [: `BEbox + [: `S LR "sig"; + `HVbox + [: `HVbox [: :]; list sig_item s [: :]; + `LocInfo (ep, ep) (HVbox [: :]) :]; + `HVbox [: `S LR "end"; k :] :] :] + | e -> fun curr next dg k -> [: `next e dg k :] ]}; + {pr_label = ""; pr_box s x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_type< $mt1$ $mt2$ >> -> + fun curr next _ k -> [: curr mt1 "" [: :]; `next mt2 "" k :] + | e -> fun curr next dg k -> [: `next e dg k :] ]}; + {pr_label = ""; pr_box s x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_type< $mt1$ . $mt2$ >> -> + fun curr next _ k -> + [: curr mt1 "" [: `S NO "." :]; `next mt2 "" k :] + | e -> fun curr next dg k -> [: `next e dg k :] ]}; + {pr_label = ""; pr_box s x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_type< $lid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] + | <:module_type< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] + | <:module_type< ' $s$ >> -> + fun curr next _ k -> [: `S LR ("'" ^ s); k :] + | mt -> + fun curr next _ k -> + [: `S LO "("; `module_type mt [: `S RO ")"; k :] :] ]}]; + +pr_module_expr.pr_levels := + [{pr_label = "top"; pr_box s x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_expr< struct $list:s$ end >> as me -> + fun curr next _ k -> + let ep = snd (MLast.loc_of_module_expr me) in + [: `HVbox [: :]; + `HVbox + [: `S LR "struct"; list str_item s [: :]; + `LocInfo (ep, ep) (HVbox [: :]) :]; + `HVbox [: `S LR "end"; k :] :] + | <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> + fun curr next _ k -> + let head = + HVbox + [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; + `module_type mt [: `S RO ")" :]; `S LR "->" :] + in + [: `head; curr me "" k :] + | e -> fun curr next dg k -> [: `next e dg k :] ]}; + {pr_label = ""; pr_box s x = HOVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_expr< $me1$ $me2$ >> -> + fun curr next _ k -> [: curr me1 "" [: :]; `next me2 "" k :] + | e -> fun curr next dg k -> [: `next e dg k :] ]}; + {pr_label = ""; pr_box s x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_expr< $me1$ . $me2$ >> -> + fun curr next _ k -> + [: curr me1 "" [: `S NO "." :]; `next me2 "" k :] + | e -> fun curr next dg k -> [: `next e dg k :] ]}; + {pr_label = ""; pr_box s x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ <:module_expr< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] + | <:module_expr< ( $me$ : $mt$ ) >> -> + fun curr next _ k -> + [: `S LO "("; `module_expr me [: `S LR ":" :]; + `module_type mt [: `S RO ")"; k :] :] + | <:module_expr< struct $list:_$ end >> | + <:module_expr< functor ($_$ : $_$) -> $_$ >> | + <:module_expr< $_$ $_$ >> | <:module_expr< $_$ . $_$ >> as me -> + fun curr next _ k -> + [: `S LO "("; `module_expr me [: `S RO ")"; k :] :] ]}]; + pr_sig_item.pr_levels := [{pr_label = "top"; pr_box s x = LocInfo (MLast.loc_of_sig_item s) (HVbox x); @@ -787,7 +735,7 @@ pr_sig_item.pr_levels := [: `S LR "declare"; `HVbox [: `HVbox [: :]; list sig_item s [: :] :]; `HVbox [: `S LR "end"; k :] :] :] - | MLast.SgDir _ _ _ as si -> + | <:sig_item< # $_$ $opt:_$ >> as si -> fun curr next _ k -> [: `not_impl "sig_item1" si :] | <:sig_item< exception $c$ of $list:tl$ >> -> fun curr next _ k -> @@ -805,16 +753,18 @@ pr_sig_item.pr_levels := fun curr next _ k -> [: `modtype_declaration s mt k :] | <:sig_item< open $sl$ >> -> fun curr next _ k -> [: `S LR "open"; mod_ident sl k :] - | MLast.SgCls _ cd -> + | <:sig_item< class $list:cd$ >> -> fun curr next _ k -> [: `HVbox [: :]; listwbws class_description [: `S LR "class" :] (S LR "and") cd k :] - | MLast.SgClt _ cd -> + | <:sig_item< class type $list:cd$ >> -> fun curr next _ k -> [: `HVbox [: :]; listwbws class_type_declaration - [: `S LR "class"; `S LR "type" :] (S LR "and") cd k :] ]}]; + [: `S LR "class"; `S LR "type" :] (S LR "and") cd k :] + | MLast.SgUse _ _ _ -> + fun curr next _ k -> [: :] ]}]; pr_str_item.pr_levels := [{pr_label = "top"; @@ -857,7 +807,7 @@ pr_str_item.pr_levels := fun curr next _ k -> [: `S LR "include"; `module_expr me k :] | <:str_item< type $list:tdl$ >> -> fun curr next _ k -> [: `type_list [: `S LR "type" :] tdl k :] - | <:str_item< value $rec:rf$ $list:pel$ >> -> + | <:str_item< value $opt:rf$ $list:pel$ >> -> fun curr next _ k -> [: `bind_list [: `S LR "value"; flag "rec" rf :] pel k :] | <:str_item< external $s$ : $t$ = $list:pl$ >> -> @@ -874,16 +824,18 @@ pr_str_item.pr_levels := `S LR "=" :]; `module_type mt [: :] :]; k :] - | MLast.StCls _ cd -> + | <:str_item< class $list:cd$ >> -> fun curr next _ k -> [: `HVbox [: :]; listwbws class_declaration [: `S LR "class" :] (S LR "and") cd k :] - | MLast.StClt _ cd -> + | <:str_item< class type $list:cd$ >> -> fun curr next _ k -> [: `HVbox [: :]; listwbws class_type_declaration - [: `S LR "class"; `S LR "type" :] (S LR "and") cd k :] ]}]; + [: `S LR "class"; `S LR "type" :] (S LR "and") cd k :] + | MLast.StUse _ _ _ -> + fun curr next _ k -> [: :] ]}]; (* EXTEND_PRINTER @@ -911,7 +863,7 @@ pr_expr.pr_levels := [{pr_label = "top"; pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x); pr_rules = extfun Extfun.empty with - [ <:expr< let $rec:r$ $p1$ = $e1$ in $e$ >> -> + [ <:expr< let $opt:r$ $p1$ = $e1$ in $e$ >> -> fun curr next _ k -> let r = flag "rec" r in [: `Vbox @@ -919,7 +871,7 @@ pr_expr.pr_levels := `let_binding [: `S LR "let"; r :] (p1, e1) [: `S LR "in" :]; `expr e k :] :] - | <:expr< let $rec:r$ $list:pel$ in $e$ >> -> + | <:expr< let $opt:r$ $list:pel$ in $e$ >> -> fun curr next _ k -> let r = flag "rec" r in [: `Vbox @@ -1165,7 +1117,7 @@ pr_expr.pr_levels := else [: curr <:expr< $lid:n$ $x$ >> "" [: :]; `next y "" k :] | <:expr< $x$ $y$ >> -> fun curr next _ k -> [: curr x "" [: :]; `next y "" k :] - | MLast.ExNew _ sl -> + | <:expr< new $list:sl$ >> -> fun curr next _ k -> [: `S LR "new"; `class_longident sl k :] | e -> fun curr next _ k -> [: `next e "" k :] ]}; {pr_label = "dot"; pr_box _ x = HOVbox x; @@ -1202,11 +1154,11 @@ pr_expr.pr_levels := | <:expr< $lid:s$ >> -> fun curr next _ k -> [: `S LR (var_escaped s); k :] | <:expr< ` $i$ >> -> fun curr next _ k -> [: `S LR ("`" ^ i); k :] - | <:expr< ~ $i$ : $lid:j$ >> when i = j -> + | <:expr< ~ $i$ >> -> fun curr next _ k -> [: `S LR ("~" ^ i); k :] | <:expr< ~ $i$ : $e$ >> -> fun curr next _ k -> [: `S LO ("~" ^ i ^ ":"); curr e "" k :] - | <:expr< ? $i$ : $lid:j$ >> when i = j -> + | <:expr< ? $i$ >> -> fun curr next _ k -> [: `S LR ("?" ^ i); k :] | <:expr< ? $i$ : $e$ >> -> fun curr next _ k -> [: `S LO ("?" ^ i ^ ":"); curr e "" k :] @@ -1258,27 +1210,28 @@ pr_expr.pr_levels := fun curr next _ k -> [: `S LO "("; `expr e [: `S LR ":>" :]; `ctyp t2 [: `S RO ")"; k :] :] - | MLast.ExOvr _ [] -> fun curr next _ k -> [: `S LR "{< >}"; k :] - | MLast.ExOvr _ fel -> + | <:expr< {< >} >> -> fun curr next _ k -> [: `S LR "{< >}"; k :] + | <:expr< {< $list:fel$ >} >> -> fun curr next _ k -> [: `S LR "{<"; listws field_expr (S RO ";") fel [: `S LR ">}"; k :] :] | <:expr< ($list:el$) >> -> fun curr next _ k -> [: `S LO "("; listws expr (S RO ",") el [: `S RO ")"; k :] :] - | <:expr< $_$ $_$ >> | <:expr< $uid:_$ $_$ $_$ >> | - <:expr< $_$ . $_$ >> | <:expr< $_$ # $_$ >> | + | <:expr< $_$ $_$ >> | <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> | + <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> | + <:expr< $_$ # $_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< match $_$ with [ $list:_$ ] >> | <:expr< try $_$ with [ $list:_$ ] >> | <:expr< if $_$ then $_$ else $_$ >> | <:expr< do { $list:_$ } >> | <:expr< for $_$ = $_$ $to:_$ $_$ do { $list:_$ } >> | <:expr< while $_$ do { $list:_$ } >> | - <:expr< let $rec:_$ $list:_$ in $_$ >> | + <:expr< let $opt:_$ $list:_$ in $_$ >> | <:expr< let module $_$ = $_$ in $_$ >> | <:expr< new $list:_$ >> as e -> fun curr next _ k -> [: `S LO "("; `expr e [: `HVbox [: `S RO ")"; k :] :] :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}]; + | e -> fun curr next _ k -> [: `not_impl "expr" e :] ]}]; pr_patt.pr_levels := [{pr_label = "top"; @@ -1373,37 +1326,38 @@ pr_patt.pr_levels := | <:patt< ` $i$ >> -> fun curr next _ k -> [: `S LR ("`" ^ i); k :] | <:patt< # $list:sl$ >> -> fun curr next _ k -> [: `S LO "#"; mod_ident sl k :] + | <:patt< ~ $i$ >> -> + fun curr next _ k -> [: `S LR ("~" ^ i); k :] | <:patt< ~ $i$ : $p$ >> -> fun curr next _ k -> [: `S LO ("~" ^ i ^ ":"); curr p "" k :] + | <:patt< ? $i$ >> -> + fun curr next _ k -> [: `S LR ("?" ^ i); k :] | <:patt< ? $i$ : ($p$ : $t$) >> -> fun curr next _ k -> [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR ":" :]; `ctyp t [: `S RO ")"; k :] :] | <:patt< ? $i$ : ($p$) >> -> fun curr next _ k -> - match p with - [ <:patt< $lid:x$ >> when i = x -> [: `S LR ("?" ^ i); k :] - | _ -> - [: `S LO ("?" ^ i ^ ":"); `S LO "("; - `patt p [: `S RO ")"; k :] :] ] + if i = "" then [: `S LO "?"; curr p "" k :] + else + [: `S LO ("?" ^ i ^ ":"); `S LO "("; + `patt p [: `S RO ")"; k :] :] | <:patt< ? $i$ : ($p$ : $t$ = $e$) >> -> fun curr next _ k -> - match p with - [ <:patt< $lid:x$ >> when i = x -> - [: `S LO "?"; `S LO "("; `patt p [: `S LR ":" :]; - `ctyp t [: `S LR "=" :]; `expr e [: `S RO ")"; k :] :] - | _ -> - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR ":" :]; - `ctyp t [: `S LR "=" :]; `expr e [: `S RO ")"; k :] :] ] + if i = "" then + [: `S LO "?"; `S LO "("; `patt p [: `S LR ":" :]; + `ctyp t [: `S LR "=" :]; `expr e [: `S RO ")"; k :] :] + else + [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR ":" :]; + `ctyp t [: `S LR "=" :]; `expr e [: `S RO ")"; k :] :] | <:patt< ? $i$ : ($p$ = $e$) >> -> fun curr next _ k -> - match p with - [ <:patt< $lid:x$ >> when i = x -> - [: `S LO "?"; `S LO "("; `patt p [: `S LR "=" :]; - `expr e [: `S RO ")"; k :] :] - | _ -> - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR "=" :]; - `expr e [: `S RO ")"; k :] :] ] + if i = "" then + [: `S LO "?"; `S LO "("; `patt p [: `S LR "=" :]; + `expr e [: `S RO ")"; k :] :] + else + [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR "=" :]; + `expr e [: `S RO ")"; k :] :] | <:patt< _ >> -> fun curr next _ k -> [: `S LR "_"; k :] | <:patt< $_$ $_$ >> | <:patt< $_$ .. $_$ >> | <:patt< $_$ | $_$ >> as p -> @@ -1496,8 +1450,7 @@ pr_ctyp.pr_levels := fun curr next _ k -> [: `HVbox [: `HVbox [: :]; - row_fields [: `S LR "[ >" :] rfl [: `S LR "]" :]; - k :] :] + row_fields [: `S LR "[ >" :] rfl [: `S LR "]" :]; k :] :] | <:ctyp< [ < $list:rfl$ > $list:sl$ ] >> -> fun curr next _ k -> let k1 = [: `S LR "]" :] in @@ -1509,12 +1462,12 @@ pr_ctyp.pr_levels := list (fun x k -> HVbox [: `S LR x; k :]) l k1 :] ] in [: `HVbox - [: `HVbox [: :]; - row_fields [: `S LR "[ <" :] rfl k1; k :] :] - | MLast.TyCls _ id -> + [: `HVbox [: :]; row_fields [: `S LR "[ <" :] rfl k1; + k :] :] + | <:ctyp< # $list:id$ >> -> fun curr next _ k -> [: `S LO "#"; `class_longident id k :] - | MLast.TyObj _ [] False -> fun curr next _ k -> [: `S LR "<>"; k :] - | MLast.TyObj _ ml v -> + | <:ctyp< < > >> -> fun curr next _ k -> [: `S LR "<>"; k :] + | <:ctyp< < $list:ml$ $opt:v$ > >> -> fun curr next _ k -> [: `S LR "<"; meth_list (ml, v) [: `S LR ">"; k :] :] | <:ctyp< $_$ -> $_$ >> | <:ctyp< $_$ $_$ >> | <:ctyp< $_$ == $_$ >> | @@ -1525,8 +1478,51 @@ pr_ctyp.pr_levels := [: `S LO "("; `ctyp t [: `HVbox [: `S RO ")"; k :] :] :] | t -> fun curr next _ k -> [: `next t "" k :] ]}]; +pr_class_sig_item.pr_levels := + [{pr_label = "top"; + pr_box s x = LocInfo (MLast.loc_of_class_sig_item s) (HVbox x); + pr_rules = + extfun Extfun.empty with + [ <:class_sig_item< type $t1$ = $t2$ >> -> + fun curr next _ k -> + [: `S LR "type"; `ctyp t1 [: `S LR "=" :]; `ctyp t2 k :] + | <:class_sig_item< declare $list:s$ end >> -> + fun curr next _ k -> [: `HVbox [: :]; list class_sig_item s k :] + | <:class_sig_item< inherit $ce$ >> -> + fun curr next _ k -> [: `S LR "inherit"; `class_type ce k :] + | <:class_sig_item< method $lab$ : $t$ >> -> + fun curr next _ k -> + [: `HVbox + [: `S LR "method"; `label lab; `S LR ":" :]; + `ctyp t k :] + | <:class_sig_item< method private $lab$ : $t$ >> -> + fun curr next _ k -> + [: `HVbox + [: `S LR "method"; `S LR "private"; `label lab; + `S LR ":" :]; + `ctyp t k :] + | <:class_sig_item< value $opt:mf$ $lab$ : $t$ >> -> + fun curr next _ k -> + [: `HVbox + [: `S LR "value"; flag "mutable" mf; `label lab; + `S LR ":" :]; + `ctyp t k :] + | <:class_sig_item< method virtual $lab$ : $t$ >> -> + fun curr next _ k -> + [: `HVbox + [: `S LR "method"; `S LR "virtual"; `label lab; + `S LR ":" :]; + `ctyp t k :] + | <:class_sig_item< method virtual private $lab$ : $t$ >> -> + fun curr next _ k -> + [: `HVbox + [: `S LR "method"; `S LR "virtual"; `S LR "private"; + `label lab; `S LR ":" :]; + `ctyp t k :] + | csi -> fun curr next dg k -> [: `next csi "" k :] ]}]; + pr_class_str_item.pr_levels := - [{pr_label = ""; + [{pr_label = "top"; pr_box s x = LocInfo (MLast.loc_of_class_str_item s) (HVbox x); pr_rules = extfun Extfun.empty with @@ -1540,7 +1536,8 @@ pr_class_str_item.pr_levels := | _ -> [: :] ]; k :] | MLast.CrVal _ lab mf e -> - fun curr next _ k -> [: `cvalue [: `S LR "value" :] (lab, mf, e) k :] + fun curr next _ k -> + [: `cvalue [: `S LR "value" :] (lab, mf, e) k :] | MLast.CrVir _ lab pf t -> fun curr next _ k -> [: `S LR "method"; `S LR "virtual"; flag "private" pf; `label lab; @@ -1552,7 +1549,7 @@ pr_class_str_item.pr_levels := | MLast.CrMth _ lab pf fb (Some t) -> fun curr next dg k -> [: `HOVbox - [: `S LR "method"; flag "private" pf; `label lab; `S LR ":"; + [: `S LR "method"; flag "private" pf; `label lab; `S LR ":"; `ctyp t [: `S LR "=" :] :]; `expr fb k :] | MLast.CrCtr _ t1 t2 -> @@ -1563,6 +1560,65 @@ pr_class_str_item.pr_levels := fun curr next _ k -> [: `S LR "initializer"; `expr se k :] | csi -> fun curr next dg k -> [: `next csi "" k :] ]}]; +pr_class_type.pr_levels := + [{pr_label = "top"; pr_box s x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ MLast.CtFun _ t ct -> + fun curr next _ k -> + [: `S LR "["; `ctyp t [: `S LR "]"; `S LR "->" :]; + `class_type ct k :] + | ct -> fun curr next _ k -> [: `class_signature ct k :] ]}]; + +pr_class_expr.pr_levels := + [{pr_label = "top"; pr_box s x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ MLast.CeFun _ p ce -> + fun curr next _ k -> + [: `S LR "fun"; `simple_patt p [: `S LR "->" :]; + `class_expr ce k :] + | MLast.CeLet _ rf lb ce -> + fun curr next _ k -> + [: `Vbox + [: `HVbox [: :]; + `bind_list [: `S LR "let"; flag "rec" rf :] lb + [: `S LR "in" :]; + `class_expr ce k :] :] + | x -> fun curr next dg k -> [: `next x "" k :] ]}; + {pr_label = ""; pr_box s x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ MLast.CeApp _ ce e -> + fun curr next _ k -> [: curr ce "" [: :]; `simple_expr e k :] + | x -> fun curr next dg k -> [: `next x "" k :] ]}; + {pr_label = ""; pr_box s x = HVbox x; + pr_rules = + extfun Extfun.empty with + [ MLast.CeCon _ ci [] -> + fun curr next _ k -> [: `class_longident ci k :] + | MLast.CeCon _ ci ctcl -> + fun curr next _ k -> + [: `class_longident ci [: :]; `S LO "["; + listws ctyp (S RO ",") ctcl [: `S RO "]"; k :] :] + | MLast.CeStr _ csp cf as ce -> + fun curr next _ k -> + let ep = snd (MLast.loc_of_class_expr ce) in + [: `BEbox + [: `HVbox [: `S LR "object"; `class_self_patt_opt csp :]; + `HVbox + [: `HVbox [: :]; list class_str_item cf [: :]; + `LocInfo (ep, ep) (HVbox [: :]) :]; + `HVbox [: `S LR "end"; k :] :] :] + | MLast.CeTyc _ ce ct -> + fun curr next _ k -> + [: `S LO "("; `class_expr ce [: `S LR ":" :]; + `class_type ct [: `S RO ")"; k :] :] + | MLast.CeFun _ _ _ as ce -> + fun curr next _ k -> + [: `S LO "("; `class_expr ce [: `S RO ")"; k :] :] + | ce -> fun curr next _ k -> [: `not_impl "class_expr" ce; k :] ]}]; + value output_string_eval oc s = loop 0 where rec loop i = if i == String.length s then () @@ -1579,15 +1635,20 @@ value ncip = ref True; value input_source ic len = let buff = Buffer.create 20 in - let rec loop i = - if i = len then Buffer.contents buff - else do { - let c = input_char ic in - Buffer.add_char buff c; - loop (i + 1) - } - in - loop 0 + try + let rec loop i = + if i >= len then Buffer.contents buff + else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) } + in + loop 0 + with + [ End_of_file -> + let s = Buffer.contents buff in + if s = "" then + match sep.val with + [ Some s -> s + | None -> "\n" ] + else s ] ; value copy_source ic oc first bp ep = @@ -1667,7 +1728,7 @@ value extract_comment strm = | [: :] -> Buff.get len ] and find_star2 len = parser - [ [: `'*'; len = insert2 (Buff.store len '*'); s :] -> len + [ [: `'*'; a = insert2 (Buff.store len '*') :] -> a | [: :] -> len ] and insert2 len = parser @@ -1677,7 +1738,7 @@ value extract_comment strm = | [: :] -> 0 ] and rparen2 len = parser - [ [: `')'; s :] -> Buff.store len ')' + [ [: `')' :] -> Buff.store len ')' | [: a = insert2 len :] -> a ] in find_comm 0 0 strm @@ -1717,23 +1778,20 @@ value apply_printer printer ast = else get_no_comment in try - do { - let (first, last_pos) = - List.fold_left - (fun (first, last_pos) (si, (bp, ep)) -> - do { - copy_source ic oc first last_pos bp; - flush oc; - print_pretty pr_ch pr_str pr_nl "" "" maxl.val getcom bp - (printer si [: :]); - flush oc; - (False, ep) - }) - (True, 0) ast - in - copy_to_end ic oc first last_pos; - flush oc - } + let (first, last_pos) = + List.fold_left + (fun (first, last_pos) (si, (bp, ep)) -> + do { + copy_source ic oc first last_pos bp; + flush oc; + print_pretty pr_ch pr_str pr_nl "" "" maxl.val getcom bp + (printer si [: :]); + flush oc; + (False, ep) + }) + (True, 0) ast + in + do { copy_to_end ic oc first last_pos; flush oc } with x -> do { close_in ic; cleanup (); raise x }; close_in ic; @@ -1780,5 +1838,5 @@ Pcaml.add_option "-old_seq" (Arg.Set old_sequences) Pcaml.add_option "-exp_dcl" (Arg.Set expand_declare) "Expand the \"declare\" items."; -Pcaml.add_option "-tc" (Arg.Clear ncip ) +Pcaml.add_option "-tc" (Arg.Clear ncip) "Deprecated since version 3.05; equivalent to -cip."; diff --git a/camlp4/etc/pr_rp_main.ml b/camlp4/etc/pr_rp_main.ml new file mode 100644 index 000000000..11ad11af7 --- /dev/null +++ b/camlp4/etc/pr_rp_main.ml @@ -0,0 +1,206 @@ +(* camlp4r q_MLast.cmo ./pa_extfun.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; +open Spretty; + +value loc = (0, 0); + +value expr e dg k = pr_expr.pr_fun "top" e dg k; +value patt e dg k = pr_patt.pr_fun "top" e dg k; + +(* Streams *) + +value stream e dg k = + let rec get = + fun + [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y] + | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y] + | <:expr< Stream.ising $x$ >> -> [(True, x)] + | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y] + | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y] + | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)] + | <:expr< Stream.sempty >> -> [] + | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)] + | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)] + | e -> [(False, e)] ] + in + let elem e k = + match e with + [ (True, e) -> [: `HOVbox [: `S LO "`"; `expr e "" k :] :] + | (False, e) -> [: `expr e "" k :] ] + in + let rec glop e k = + match e with + [ [] -> k + | [e] -> [: elem e k :] + | [e :: el] -> [: elem e [: `S RO ";" :]; glop el k :] ] + in + HOVbox [: `S LR "[:"; glop (get e) [: `S LR ":]"; k :] :] +; + +(* Parsers *) + +open Parserify; + +value parser_cases b spel k = + let rec parser_cases b spel k = + match spel with + [ [] -> [: `HVbox [: b; k :] :] + | [(sp, epo, e)] -> [: `parser_case b sp epo e k :] + | [(sp, epo, e) :: spel] -> + [: `parser_case b sp epo e [: :]; + parser_cases [: `S LR "|" :] spel k :] ] + and parser_case b sp epo e k = + let epo = + match epo with + [ Some p -> [: `patt p "" [: `S LR "->" :] :] + | _ -> [: `S LR "->" :] ] + in + HVbox + [: b; + `HOVbox + [: `HOVbox + [: `S LR "[:"; + stream_patt [: :] sp [: `S LR ":]"; epo :] :]; + `expr e "" k :] :] + and stream_patt b sp k = + match sp with + [ [] -> [: `HVbox [: b; k :] :] + | [(spc, None)] -> [: `stream_patt_comp b spc k :] + | [(spc, Some e)] -> + [: `HVbox + [: `stream_patt_comp b spc [: :]; + `HVbox [: `S LR "?"; `expr e "" k :] :] :] + | [(spc, None) :: spcl] -> + [: `stream_patt_comp b spc [: `S RO ";" :]; + stream_patt [: :] spcl k :] + | [(spc, Some e) :: spcl] -> + [: `HVbox + [: `stream_patt_comp b spc [: :]; + `HVbox [: `S LR "?"; `expr e "" [: `S RO ";" :] :] :]; + stream_patt [: :] spcl k :] ] + and stream_patt_comp b spc k = + match spc with + [ SPCterm (p, w) -> + HVbox [: b; `S LO "`"; `patt p "" [: :]; `HVbox [: when_opt w k :] :] + | SPCnterm p e -> + HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e "" k :] :] + | SPCsterm p -> HVbox [: b; `patt p "" k :] ] + and when_opt wo k = + match wo with + [ Some e -> [: `S LR "when"; `expr e "" k :] + | _ -> k ] + in + parser_cases b spel k +; + +value parser_body e dg k = + let (bp, e) = + match e with + [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) + | e -> (None, e) ] + in + match parser_of_expr e with + [ [] -> + HVbox + [: `HVbox + [: `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + `HVbox [: `S LR "[]"; k :] :] + | [spe] -> + HVbox + [: `HVbox + [: `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + parser_cases [: :] [spe] k :] + | spel -> + Vbox + [: `HVbox [: :]; + `HVbox + [: `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] ] +; + +value pmatch e dg k = + let (me, e) = + match e with + [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e) + | _ -> failwith "Pr_rp.pmatch" ] + in + let (bp, e) = + match e with + [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) + | e -> (None, e) ] + in + let spel = parser_of_expr e in + Vbox + [: `HVbox [: :]; + `HVbox + [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] +; + +(* Printer extensions *) + +pr_expr_fun_args.val := + extfun pr_expr_fun_args.val with + [ <:expr< fun strm__ -> $_$ >> as ge -> ([], ge) + | <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ]; + +let lev = find_pr_level "top" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e -> + fun curr next _ k -> [: `pmatch e "" k :] + | <:expr< fun strm__ -> $x$ >> -> + fun curr next _ k -> [: `parser_body x "" k :] + | <:expr< fun (strm__ : $_$) -> $x$ >> -> + fun curr next _ k -> [: `parser_body x "" k :] ]; + +let lev = find_pr_level "apply" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | + <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | + <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | + <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | + <:expr< Stream.slazy $_$ >> as e -> + fun curr next _ k -> [: `next e "" k :] ]; + +let lev = find_pr_level "dot" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Stream.sempty >> as e -> + fun curr next _ k -> [: `next e "" k :] ]; + +let lev = find_pr_level "simple" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | + <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | + <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | + <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | + <:expr< Stream.slazy $_$ >> as e -> + fun curr next _ k -> [: `stream e "" k :] ]; diff --git a/camlp4/etc/pr_scheme.ml b/camlp4/etc/pr_scheme.ml new file mode 100644 index 000000000..a7c230948 --- /dev/null +++ b/camlp4/etc/pr_scheme.ml @@ -0,0 +1,813 @@ +(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) +(* $Id$ *) + +open Pcaml; +open Format; + +type printer_t 'a = + { pr_fun : mutable string -> next 'a; + pr_levels : mutable list (pr_level 'a) } +and pr_level 'a = + { pr_label : string; + pr_box : formatter -> (formatter -> unit) -> 'a -> unit; + pr_rules : mutable pr_rule 'a } +and pr_rule 'a = + Extfun.t 'a (formatter -> curr 'a -> next 'a -> string -> kont -> unit) +and curr 'a = formatter -> ('a * string * kont) -> unit +and next 'a = formatter -> ('a * string * kont) -> unit +and kont = formatter -> unit; + +value not_impl name x ppf k = + 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 + fprintf ppf "<pr_scheme: not impl: %s; %s>%t" name desc k +; + +value pr_fun name pr lab = + loop False pr.pr_levels where rec loop app = + fun + [ [] -> fun ppf (x, dg, k) -> failwith ("unable to print " ^ name) + | [lev :: levl] -> + if app || lev.pr_label = lab then + let next = loop True levl in + let rec curr ppf (x, dg, k) = + Extfun.apply lev.pr_rules x ppf curr next dg k + in + fun ppf ((x, _, _) as n) -> lev.pr_box ppf (fun ppf -> curr ppf n) x + else loop app levl ] +; + +value rec find_pr_level lab = + fun + [ [] -> failwith ("level " ^ lab ^ " not found") + | [lev :: levl] -> + if lev.pr_label = lab then lev else find_pr_level lab levl ] +; + +value pr_constr_decl = {pr_fun = fun []; pr_levels = []}; +value constr_decl ppf (x, k) = pr_constr_decl.pr_fun "top" ppf (x, "", k); +pr_constr_decl.pr_fun := pr_fun "constr_decl" pr_constr_decl; + +value pr_ctyp = {pr_fun = fun []; pr_levels = []}; +pr_ctyp.pr_fun := pr_fun "ctyp" pr_ctyp; +value ctyp ppf (x, k) = pr_ctyp.pr_fun "top" ppf (x, "", k); + +value pr_expr = {pr_fun = fun []; pr_levels = []}; +pr_expr.pr_fun := pr_fun "expr" pr_expr; +value expr ppf (x, k) = pr_expr.pr_fun "top" ppf (x, "", k); + +value pr_label_decl = {pr_fun = fun []; pr_levels = []}; +value label_decl ppf (x, k) = pr_label_decl.pr_fun "top" ppf (x, "", k); +pr_label_decl.pr_fun := pr_fun "label_decl" pr_label_decl; + +value pr_let_binding = {pr_fun = fun []; pr_levels = []}; +pr_let_binding.pr_fun := pr_fun "let_binding" pr_let_binding; +value let_binding ppf (x, k) = pr_let_binding.pr_fun "top" ppf (x, "", k); + +value pr_match_assoc = {pr_fun = fun []; pr_levels = []}; +pr_match_assoc.pr_fun := pr_fun "match_assoc" pr_match_assoc; +value match_assoc ppf (x, k) = pr_match_assoc.pr_fun "top" ppf (x, "", k); + +value pr_mod_ident = {pr_fun = fun []; pr_levels = []}; +pr_mod_ident.pr_fun := pr_fun "mod_ident" pr_mod_ident; +value mod_ident ppf (x, k) = pr_mod_ident.pr_fun "top" ppf (x, "", k); + +value pr_module_binding = {pr_fun = fun []; pr_levels = []}; +pr_module_binding.pr_fun := pr_fun "module_binding" pr_module_binding; +value module_binding ppf (x, k) = + pr_module_binding.pr_fun "top" ppf (x, "", k); + +value pr_module_expr = {pr_fun = fun []; pr_levels = []}; +pr_module_expr.pr_fun := pr_fun "module_expr" pr_module_expr; +value module_expr ppf (x, k) = pr_module_expr.pr_fun "top" ppf (x, "", k); + +value pr_module_type = {pr_fun = fun []; pr_levels = []}; +pr_module_type.pr_fun := pr_fun "module_type" pr_module_type; +value module_type ppf (x, k) = pr_module_type.pr_fun "top" ppf (x, "", k); + +value pr_patt = {pr_fun = fun []; pr_levels = []}; +pr_patt.pr_fun := pr_fun "patt" pr_patt; +value patt ppf (x, k) = pr_patt.pr_fun "top" ppf (x, "", k); + +value pr_sig_item = {pr_fun = fun []; pr_levels = []}; +pr_sig_item.pr_fun := pr_fun "sig_item" pr_sig_item; +value sig_item ppf (x, k) = pr_sig_item.pr_fun "top" ppf (x, "", k); + +value pr_str_item = {pr_fun = fun []; pr_levels = []}; +pr_str_item.pr_fun := pr_fun "str_item" pr_str_item; +value str_item ppf (x, k) = pr_str_item.pr_fun "top" ppf (x, "", k); + +value pr_type_decl = {pr_fun = fun []; pr_levels = []}; +value type_decl ppf (x, k) = pr_type_decl.pr_fun "top" ppf (x, "", k); +pr_type_decl.pr_fun := pr_fun "type_decl" pr_type_decl; + +value pr_type_params = {pr_fun = fun []; pr_levels = []}; +value type_params ppf (x, k) = pr_type_params.pr_fun "top" ppf (x, "", k); +pr_type_params.pr_fun := pr_fun "type_params" pr_type_params; + +value pr_with_constr = {pr_fun = fun []; pr_levels = []}; +value with_constr ppf (x, k) = pr_with_constr.pr_fun "top" ppf (x, "", k); +pr_with_constr.pr_fun := pr_fun "with_constr" pr_with_constr; + +(* general functions *) + +value nok ppf = (); +value ks s k ppf = fprintf ppf "%s%t" s k; + +value rec list f ppf (l, k) = + match l with + [ [] -> k ppf + | [x] -> f ppf (x, k) + | [x :: l] -> fprintf ppf "%a@ %a" f (x, nok) (list f) (l, k) ] +; + +value rec listwb b f ppf (l, k) = + match l with + [ [] -> k ppf + | [x] -> f ppf ((b, x), k) + | [x :: l] -> fprintf ppf "%a@ %a" f ((b, x), nok) (listwb "" f) (l, k) ] +; + +(* specific functions *) + +value rec is_irrefut_patt = + fun + [ <:patt< $lid:_$ >> -> True + | <:patt< () >> -> True + | <:patt< _ >> -> True + | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y + | <:patt< { $list:fpl$ } >> -> + List.for_all (fun (_, p) -> is_irrefut_patt p) fpl + | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p + | <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl + | <:patt< ? $_$ : ( $p$ ) >> -> is_irrefut_patt p + | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p + | <:patt< ~ $_$ >> -> True + | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p + | _ -> False ] +; + +value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge; + +pr_expr_fun_args.val := + extfun Extfun.empty with + [ <:expr< fun [$p$ -> $e$] >> as ge -> + if is_irrefut_patt p then + let (pl, e) = expr_fun_args e in + ([p :: pl], e) + else ([], ge) + | ge -> ([], ge) ]; + +value sequence ppf (e, k) = + match e with + [ <:expr< do { $list:el$ } >> -> + fprintf ppf "@[<hv>%a@]" (list expr) (el, k) + | _ -> expr ppf (e, k) ] +; + +value string ppf (s, k) = fprintf ppf "\"%s\"%t" s k; + +value int_repr s = + if String.length s > 2 && s.[0] = '0' then + match s.[1] with + [ 'b' | 'o' | 'x' | 'B' | 'O' | 'X' -> + "#" ^ String.sub s 1 (String.length s - 1) + | _ -> s ] + else s +; + +value assoc_left_parsed_op_list = ["+"; "*"; "land"; "lor"; "lxor"]; +value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"]; +value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="]; + +(* extensible pretty print functions *) + +pr_constr_decl.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ (loc, c, []) as x -> + fun ppf curr next dg k -> fprintf ppf "(@[<hv>%s%t@]" c (ks ")" k) + | (loc, c, tl) -> + fun ppf curr next dg k -> + fprintf ppf "(@[<hv>%s@ %a@]" c (list ctyp) (tl, ks ")" k) ]}]; + +pr_ctyp.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ <:ctyp< [ $list:cdl$ ] >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[<hv>sum@ %a@]" (list constr_decl) (cdl, ks ")" k) + | <:ctyp< { $list:cdl$ } >> -> + fun ppf curr next dg k -> + fprintf ppf "{@[<hv>%a@]" (list label_decl) (cdl, ks "}" k) + | <:ctyp< ( $list:tl$ ) >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[* @[<hv>%a@]@]" (list ctyp) (tl, ks ")" k) + | <:ctyp< $t1$ -> $t2$ >> -> + fun ppf curr next dg k -> + let tl = + loop t2 where rec loop = + fun + [ <:ctyp< $t1$ -> $t2$ >> -> [t1 :: loop t2] + | t -> [t] ] + in + fprintf ppf "(@[-> @[<hv>%a@]@]" (list ctyp) + ([t1 :: tl], ks ")" k) + | <:ctyp< $t1$ $t2$ >> -> + fun ppf curr next dg k -> + let (t, tl) = + loop [t2] t1 where rec loop tl = + fun + [ <:ctyp< $t1$ $t2$ >> -> loop [t2 :: tl] t1 + | t1 -> (t1, tl) ] + in + fprintf ppf "(@[%a@ %a@]" ctyp (t, nok) (list ctyp) (tl, ks ")" k) + | <:ctyp< $t1$ . $t2$ >> -> + fun ppf curr next dg k -> + fprintf ppf "%a.%a" ctyp (t1, nok) ctyp (t2, k) + | <:ctyp< $lid:s$ >> | <:ctyp< $uid:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "%s%t" s k + | <:ctyp< ' $s$ >> -> + fun ppf curr next dg k -> fprintf ppf "'%s%t" s k + | <:ctyp< _ >> -> + fun ppf curr next dg k -> fprintf ppf "_%t" k + | x -> + fun ppf curr next dg k -> not_impl "ctyp" x ppf k ]}]; + +pr_expr.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ <:expr< fun [] >> -> + fun ppf curr next dg k -> + fprintf ppf "(lambda%t" (ks ")" k) + | <:expr< fun $lid:s$ -> $e$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(lambda@ %s@;<1 1>%a" s expr (e, ks ")" k) + | <:expr< fun [ $list:pwel$ ] >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[<hv>lambda_match@ %a@]" (list match_assoc) + (pwel, ks ")" k) + | <:expr< match $e$ with [ $list:pwel$ ] >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[<hv>@[<b 2>match@ %a@]@ %a@]" expr (e, nok) + (list match_assoc) (pwel, ks ")" k) + | <:expr< try $e$ with [ $list:pwel$ ] >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[<hv>@[<b 2>try@ %a@]@ %a@]" expr (e, nok) + (list match_assoc) (pwel, ks ")" k) + | <:expr< let $p1$ = $e1$ in $e2$ >> -> + fun ppf curr next dg k -> + let (pel, e) = + loop [(p1, e1)] e2 where rec loop pel = + fun + [ <:expr< let $p1$ = $e1$ in $e2$ >> -> + loop [(p1, e1) :: pel] e2 + | e -> (List.rev pel, e) ] + in + let b = + match pel with + [ [_] -> "let" + | _ -> "let*" ] + in + fprintf ppf "(@[@[%s (@[<v>%a@]@]@;<1 2>%a@]" b + (listwb "" let_binding) (pel, ks ")" nok) + sequence (e, ks ")" k) + | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> + fun ppf curr next dg k -> + let b = if rf then "letrec" else "let" in + fprintf ppf "(@[<hv>%s@ (@[<hv>%a@]@ %a@]" b + (listwb "" let_binding) (pel, ks ")" nok) expr (e, ks ")" k) + | <:expr< if $e1$ then $e2$ else () >> -> + fun ppf curr next dg k -> + fprintf ppf "(if @[%a@;<1 0>%a@]" expr (e1, nok) + expr (e2, ks ")" k) + | <:expr< if $e1$ then $e2$ else $e3$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(if @[%a@ %a@ %a@]" expr (e1, nok) + expr (e2, nok) expr (e3, ks ")" k) + | <:expr< do { $list:el$ } >> -> + fun ppf curr next dg k -> + fprintf ppf "(begin@;<1 1>@[<hv>%a@]" (list expr) (el, ks ")" k) + | <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[for %s@ %a@ %a %a@]" i expr (e1, nok) + expr (e2, nok) (list expr) (el, ks ")" k) + | <:expr< ($e$ : $t$) >> -> + fun ppf curr next dg k -> + fprintf ppf "(:@ %a@ %a" expr (e, nok) ctyp (t, ks ")" k) + | <:expr< ($list:el$) >> -> + fun ppf curr next dg k -> + fprintf ppf "(values @[%a@]" (list expr) (el, ks ")" k) + | <:expr< { $list:fel$ } >> -> + fun ppf curr next dg k -> + let record_binding ppf ((p, e), k) = + fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k) + in + fprintf ppf "{@[<hv>%a@]" (list record_binding) (fel, ks "}" k) + | <:expr< { ($e$) with $list:fel$ } >> -> + fun ppf curr next dg k -> + let record_binding ppf ((p, e), k) = + fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k) + in + fprintf ppf "{@[@[with@ %a@]@ @[%a@]@]" expr (e, nok) + (list record_binding) (fel, ks "}" k) + | <:expr< $e1$ := $e2$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(:=@;<1 1>%a@;<1 1>%a" expr (e1, nok) + expr (e2, ks ")" k) + | <:expr< [$_$ :: $_$] >> as e -> + fun ppf curr next dg k -> + let (el, c) = + make_list e where rec make_list e = + match e with + [ <:expr< [$e$ :: $y$] >> -> + let (el, c) = make_list y in + ([e :: el], c) + | <:expr< [] >> -> ([], None) + | x -> ([], Some e) ] + in + match c with + [ None -> + fprintf ppf "[%a" (list expr) (el, ks "]" k) + | Some x -> + fprintf ppf "[%a@ %a" (list expr) (el, ks " ." nok) + expr (x, ks "]" k) ] + | <:expr< lazy ($x$) >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[lazy@ %a@]" expr (x, ks ")" k) + | <:expr< $lid:s$ $e1$ $e2$ >> + when List.mem s assoc_right_parsed_op_list -> + fun ppf curr next dg k -> + let el = + loop [e1] e2 where rec loop el = + fun + [ <:expr< $lid:s1$ $e1$ $e2$ >> when s1 = s -> + loop [e1 :: el] e2 + | e -> List.rev [e :: el] ] + in + fprintf ppf "(@[%s %a@]" s (list expr) (el, ks ")" k) + | <:expr< $e1$ $e2$ >> -> + fun ppf curr next dg k -> + let (f, el) = + loop [e2] e1 where rec loop el = + fun + [ <:expr< $e1$ $e2$ >> -> loop [e2 :: el] e1 + | e1 -> (e1, el) ] + in + fprintf ppf "(@[%a@ %a@]" expr (f, nok) (list expr) (el, ks ")" k) + | <:expr< ~ $s$ : ($e$) >> -> + fun ppf curr next dg k -> + fprintf ppf "(~%s@ %a" s expr (e, ks ")" k) + | <:expr< $e1$ .[ $e2$ ] >> -> + fun ppf curr next dg k -> + fprintf ppf "%a.[%a" expr (e1, nok) expr (e2, ks "]" k) + | <:expr< $e1$ .( $e2$ ) >> -> + fun ppf curr next dg k -> + fprintf ppf "%a.(%a" expr (e1, nok) expr (e2, ks ")" k) + | <:expr< $e1$ . $e2$ >> -> + fun ppf curr next dg k -> + fprintf ppf "%a.%a" expr (e1, nok) expr (e2, k) + | <:expr< $int:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k + | <:expr< $lid:s$ >> | <:expr< $uid:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "%s%t" s k + | <:expr< ` $s$ >> -> + fun ppf curr next dg k -> fprintf ppf "`%s%t" s k + | <:expr< $str:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k + | <:expr< $chr:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k + | x -> + fun ppf curr next dg k -> not_impl "expr" x ppf k ]}]; + +pr_label_decl.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ (loc, f, m, t) -> + fun ppf curr next dg k -> + fprintf ppf "(@[<hv>%s%t@ %a@]" f + (fun ppf -> if m then fprintf ppf "@ mutable" else ()) + ctyp (t, ks ")" k) ]}]; + +pr_let_binding.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ (b, (p, e)) -> + fun ppf curr next dg k -> + let (pl, e) = expr_fun_args e in + match pl with + [ [] -> + fprintf ppf "(@[<b 1>%s%s%a@ %a@]" b + (if b = "" then "" else " ") patt (p, nok) + sequence (e, ks ")" k) + | _ -> + fprintf ppf "(@[<b 1>%s%s(%a)@ %a@]" b + (if b = "" then "" else " ") (list patt) ([p :: pl], nok) + sequence (e, ks ")" k) ] ]}]; + +pr_match_assoc.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ (p, we, e) -> + fun ppf curr next dg k -> + fprintf ppf "(@[%t@ %a@]" + (fun ppf -> + match we with + [ Some e -> + fprintf ppf "(when@ %a@ %a" patt (p, nok) + expr (e, ks ")" nok) + | None -> patt ppf (p, nok) ]) + sequence (e, ks ")" k) ]}]; + +pr_mod_ident.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ [s] -> + fun ppf curr next dg k -> + fprintf ppf "%s%t" s k + | [s :: sl] -> + fun ppf curr next dg k -> + fprintf ppf "%s.%a" s curr (sl, "", k) + | x -> + fun ppf curr next dg k -> not_impl "mod_ident" x ppf k ]}]; + +pr_module_binding.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ (b, s, me) -> + fun ppf curr next dg k -> + fprintf ppf "%s@ %s@ %a" b s module_expr (me, k) ]}]; + +pr_module_expr.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ <:module_expr< functor ($i$ : $mt$) -> $me$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]" + i module_type (mt, nok) module_expr (me, ks ")" k) + | <:module_expr< struct $list:sil$ end >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[struct@ @[<hv>%a@]@]" (list str_item) + (sil, ks ")" k) + | <:module_expr< $me1$ $me2$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[%a@ %a@]" module_expr (me1, nok) + module_expr (me2, ks ")" k) + | <:module_expr< $uid:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "%s%t" s k + | x -> + fun ppf curr next dg k -> not_impl "module_expr" x ppf k ]}]; + +pr_module_type.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ <:module_type< functor ($i$ : $mt1$) -> $mt2$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]" + i module_type (mt1, nok) module_type (mt2, ks ")" k) + | <:module_type< sig $list:sil$ end >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[sig@ @[<hv>%a@]@]" (list sig_item) (sil, ks ")" k) + | <:module_type< $mt$ with $list:wcl$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[with@;<1 2>@[%a@ (%a@]@]" module_type (mt, nok) + (list with_constr) (wcl, ks "))" k) + | <:module_type< $uid:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "%s%t" s k + | x -> + fun ppf curr next dg k -> not_impl "module_type" x ppf k ]}]; + +pr_patt.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ <:patt< $p1$ | $p2$ >> -> + fun ppf curr next dg k -> + let (f, pl) = + loop [p2] p1 where rec loop pl = + fun + [ <:patt< $p1$ | $p2$ >> -> loop [p2 :: pl] p1 + | p1 -> (p1, pl) ] + in + fprintf ppf "(@[or@ %a@ %a@]" patt (f, nok) (list patt) + (pl, ks ")" k) + | <:patt< ($p1$ as $p2$) >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[as@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k) + | <:patt< $p1$ .. $p2$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[range@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k) + | <:patt< [$_$ :: $_$] >> as p -> + fun ppf curr next dg k -> + let (pl, c) = + make_list p where rec make_list p = + match p with + [ <:patt< [$p$ :: $y$] >> -> + let (pl, c) = make_list y in + ([p :: pl], c) + | <:patt< [] >> -> ([], None) + | x -> ([], Some p) ] + in + match c with + [ None -> + fprintf ppf "[%a" (list patt) (pl, ks "]" k) + | Some x -> + fprintf ppf "[%a@ %a" (list patt) (pl, ks " ." nok) + patt (x, ks "]" k) ] + | <:patt< $p1$ $p2$ >> -> + fun ppf curr next dg k -> + let pl = + loop [p2] p1 where rec loop pl = + fun + [ <:patt< $p1$ $p2$ >> -> loop [p2 :: pl] p1 + | p1 -> [p1 :: pl] ] + in + fprintf ppf "(@[%a@]" (list patt) (pl, ks ")" k) + | <:patt< ($p$ : $t$) >> -> + fun ppf curr next dg k -> + fprintf ppf "(:@ %a@ %a" patt (p, nok) ctyp (t, ks ")" k) + | <:patt< ($list:pl$) >> -> + fun ppf curr next dg k -> + fprintf ppf "(values @[%a@]" (list patt) (pl, ks ")" k) + | <:patt< { $list:fpl$ } >> -> + fun ppf curr next dg k -> + let record_binding ppf ((p1, p2), k) = + fprintf ppf "(@[%a@ %a@]" patt (p1, nok) patt (p2, ks ")" k) + in + fprintf ppf "(@[<hv>{}@ %a@]" (list record_binding) (fpl, ks ")" k) + | <:patt< ? $x$ >> -> + fun ppf curr next dg k -> fprintf ppf "?%s%t" x k + | <:patt< ? ($lid:x$ = $e$) >> -> + fun ppf curr next dg k -> fprintf ppf "(?%s@ %a" x expr (e, ks ")" k) + | <:patt< $p1$ . $p2$ >> -> + fun ppf curr next dg k -> + fprintf ppf "%a.%a" patt (p1, nok) patt (p2, k) + | <:patt< $lid:s$ >> | <:patt< $uid:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "%s%t" s k + | <:patt< $str:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k + | <:patt< $chr:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k + | <:patt< $int:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k + | <:patt< $flo:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "%s%t" s k + | <:patt< _ >> -> + fun ppf curr next dg k -> fprintf ppf "_%t" k + | x -> + fun ppf curr next dg k -> not_impl "patt" x ppf k ]}]; + +pr_sig_item.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ <:sig_item< type $list:tdl$ >> -> + fun ppf curr next dg k -> + match tdl with + [ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k) + | tdl -> + fprintf ppf "(@[<hv>type@ %a@]" (listwb "" type_decl) + (tdl, ks ")" k) ] + | <:sig_item< exception $c$ of $list:tl$ >> -> + fun ppf curr next dg k -> + match tl with + [ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k) + | tl -> + fprintf ppf "(@[@[exception@ %s@]@ %a@]" c + (list ctyp) (tl, ks ")" k) ] + | <:sig_item< value $i$ : $t$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[@[value %s@]@ %a@]" i ctyp (t, ks ")" k) + | <:sig_item< external $i$ : $t$ = $list:pd$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[@[external@ %s@]@ %a@ %a@]" i ctyp (t, nok) + (list string) (pd, ks ")" k) + | <:sig_item< module $s$ : $mt$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[@[module@ %s@]@ %a@]" s + module_type (mt, ks ")" k) + | <:sig_item< module type $s$ = $mt$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s + module_type (mt, ks ")" k) + | <:sig_item< declare $list:s$ end >> -> + fun ppf curr next dg k -> + if s = [] then fprintf ppf "; ..." + else fprintf ppf "%a" (list sig_item) (s, k) + | MLast.SgUse _ _ _ -> + fun ppf curr next dg k -> () + | x -> + fun ppf curr next dg k -> not_impl "sig_item" x ppf k ]}]; + +pr_str_item.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ <:str_item< open $i$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(open@ %a" mod_ident (i, ks ")" k) + | <:str_item< type $list:tdl$ >> -> + fun ppf curr next dg k -> + match tdl with + [ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k) + | tdl -> + fprintf ppf "(@[<hv>type@ %a@]" (listwb "" type_decl) + (tdl, ks ")" k) ] + | <:str_item< exception $c$ of $list:tl$ >> -> + fun ppf curr next dg k -> + match tl with + [ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k) + | tl -> + fprintf ppf "(@[@[exception@ %s@]@ %a@]" c + (list ctyp) (tl, ks ")" k) ] + | <:str_item< value $opt:rf$ $list:pel$ >> -> + fun ppf curr next dg k -> + let b = if rf then "definerec" else "define" in + match pel with + [ [(p, e)] -> + fprintf ppf "%a" let_binding ((b, (p, e)), k) + | pel -> + fprintf ppf "(@[<hv 1>%s*@ %a@]" b (listwb "" let_binding) + (pel, ks ")" k) ] + | <:str_item< module $s$ = $me$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(%a" module_binding (("module", s, me), ks ")" k) + | <:str_item< module type $s$ = $mt$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s + module_type (mt, ks ")" k) + | <:str_item< external $i$ : $t$ = $list:pd$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[external@ %s@ %a@ %a@]" i ctyp (t, nok) + (list string) (pd, ks ")" k) + | <:str_item< $exp:e$ >> -> + fun ppf curr next dg k -> + fprintf ppf "%a" expr (e, k) + | <:str_item< # $s$ $opt:x$ >> -> + fun ppf curr next dg k -> + match x with + [ Some e -> fprintf ppf "; # (%s %a" s expr (e, ks ")" k) + | None -> fprintf ppf "; # (%s%t" s (ks ")" k) ] + | <:str_item< declare $list:s$ end >> -> + fun ppf curr next dg k -> + if s = [] then fprintf ppf "; ..." + else fprintf ppf "%a" (list str_item) (s, k) + | MLast.StUse _ _ _ -> + fun ppf curr next dg k -> () + | x -> + fun ppf curr next dg k -> not_impl "str_item" x ppf k ]}]; + +pr_type_decl.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ (b, ((_, tn), tp, te, cl)) -> + fun ppf curr next dg k -> + fprintf ppf "%t%t@;<1 1>%a" + (fun ppf -> + if b <> "" then fprintf ppf "%s@ " b + else ()) + (fun ppf -> + match tp with + [ [] -> fprintf ppf "%s" tn + | tp -> fprintf ppf "(%s%a)" tn type_params (tp, nok) ]) + ctyp (te, k) ]}]; + +pr_type_params.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ [(s, vari) :: tpl] -> + fun ppf curr next dg k -> + fprintf ppf "@ '%s%a" s type_params (tpl, k) + | [] -> + fun ppf curr next dg k -> () ]}]; + +pr_with_constr.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ MLast.WcTyp _ m tp te -> + fun ppf curr next dg k -> + fprintf ppf "(type@ %t@;<1 1>%a" + (fun ppf -> + match tp with + [ [] -> fprintf ppf "%a" mod_ident (m, nok) + | tp -> + fprintf ppf "(%a@ %a)" mod_ident (m, nok) + type_params (tp, nok) ]) + ctyp (te, ks ")" k) + | x -> + fun ppf curr next dg k -> not_impl "with_constr" x ppf k ]}]; + +(* main *) + +value output_string_eval ppf s = + loop 0 where rec loop i = + if i == String.length s then () + else if i == String.length s - 1 then pp_print_char ppf s.[i] + else + match (s.[i], s.[i + 1]) with + [ ('\\', 'n') -> do { pp_print_char ppf '\n'; loop (i + 2) } + | (c, _) -> do { pp_print_char ppf c; loop (i + 1) } ] +; + +value sep = Pcaml.inter_phrases; + +value input_source ic len = + let buff = Buffer.create 20 in + try + let rec loop i = + if i >= len then Buffer.contents buff + else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) } + in + loop 0 + with + [ End_of_file -> + let s = Buffer.contents buff in + if s = "" then + match sep.val with + [ Some s -> s + | None -> "\n" ] + else s ] +; + +value copy_source ppf (ic, first, bp, ep) = + match sep.val with + [ Some str -> + if first then () + else if ep == in_channel_length ic then pp_print_string ppf "\n" + else output_string_eval ppf str + | None -> + do { + seek_in ic bp; + let s = input_source ic (ep - bp) in pp_print_string ppf s + } ] +; + +value copy_to_end ppf (ic, first, bp) = + let ilen = in_channel_length ic in + if bp < ilen then copy_source ppf (ic, first, bp, ilen) + else pp_print_string ppf "\n" +; + +value apply_printer printer ast = + let ppf = std_formatter in + if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do { + let ic = open_in_bin Pcaml.input_file.val in + try + let (first, last_pos) = + List.fold_left + (fun (first, last_pos) (si, (bp, ep)) -> + do { + fprintf ppf "@[%a@]@?" copy_source (ic, first, last_pos, bp); + fprintf ppf "@[%a@]@?" printer (si, nok); + (False, ep) + }) + (True, 0) ast + in + fprintf ppf "@[%a@]@?" copy_to_end (ic, first, last_pos) + with x -> + do { fprintf ppf "@."; close_in ic; raise x }; + close_in ic; + } + else failwith "not implemented" +; + +Pcaml.print_interf.val := apply_printer sig_item; +Pcaml.print_implem.val := apply_printer str_item; + +Pcaml.add_option "-l" (Arg.Int (fun x -> set_margin x)) + "<length> Maximum line length for pretty printing."; + +Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x)) + "<string> Use this string between phrases instead of reading source."; diff --git a/camlp4/etc/pr_schp_main.ml b/camlp4/etc/pr_schp_main.ml new file mode 100644 index 000000000..c53511149 --- /dev/null +++ b/camlp4/etc/pr_schp_main.ml @@ -0,0 +1,119 @@ +(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) +(* $Id$ *) + +open Format; +open Pcaml; +open Parserify; + +value nok = Pr_scheme.nok; +value ks = Pr_scheme.ks; +value patt = Pr_scheme.patt; +value expr = Pr_scheme.expr; +value find_pr_level = Pr_scheme.find_pr_level; +value pr_expr = Pr_scheme.pr_expr; +type printer_t 'a = Pr_scheme.printer_t 'a == + { pr_fun : mutable string -> Pr_scheme.next 'a; + pr_levels : mutable list (pr_level 'a) } +and pr_level 'a = Pr_scheme.pr_level 'a == + { pr_label : string; + pr_box : formatter -> (formatter -> unit) -> 'a -> unit; + pr_rules : mutable Pr_scheme.pr_rule 'a } +; + +(* extensions for rebuilding syntax of parsers *) + +value parser_cases ppf (spel, k) = + let rec parser_cases ppf (spel, k) = + match spel with + [ [] -> fprintf ppf "[: `HVbox [: b; k :] :]" + | [(sp, epo, e)] -> parser_case ppf (sp, epo, e, k) + | [(sp, epo, e) :: spel] -> + fprintf ppf "%a@ %a" parser_case (sp, epo, e, nok) + parser_cases (spel, k) ] + and parser_case ppf (sp, epo, e, k) = + fprintf ppf "(@[@[(%a)%t@]@ %a@]" stream_patt (sp, nok) + (fun ppf -> + match epo with + [ Some p -> fprintf ppf "@ %a" patt (p, nok) + | None -> () ]) + expr (e, ks ")" k) + and stream_patt ppf (sp, k) = + match sp with + [ [] -> k ppf + | [(spc, None)] -> fprintf ppf "%a" stream_patt_comp (spc, k) + | [(spc, Some e)] -> + fprintf ppf "(@[? %a@ %a@]" stream_patt_comp (spc, nok) + expr (e, ks ")" k) + | [(spc, None) :: spcl] -> + fprintf ppf "%a@ %a" stream_patt_comp (spc, nok) stream_patt (spcl, k) + | [(spc, Some e) :: spcl] -> + fprintf ppf "(@[? %a@ %a@]@ %a" stream_patt_comp (spc, nok) + expr (e, ks ")" nok) stream_patt (spcl, k) ] + and stream_patt_comp ppf (spc, k) = + match spc with + [ SPCterm (p, w) -> + match w with + [ Some e -> + fprintf ppf "(` %a@ %a" patt (p, nok) expr (e, ks ")" k) + | None -> fprintf ppf "(` %a" patt (p, ks ")" k) ] + | SPCnterm p e -> + fprintf ppf "(@[%a %a@]" patt (p, nok) expr (e, ks ")" k) + | SPCsterm p -> fprintf ppf "%a" patt (p, k) ] + in + parser_cases ppf (spel, k) +; + +value parser_body ppf (e, k) = + let (bp, e) = + match e with + [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) + | e -> (None, e) ] + in + match parser_of_expr e with + [ [] -> + fprintf ppf "(parser%t%t" + (fun ppf -> + match bp with + [ Some p -> fprintf ppf "@ %a" patt (p, nok) + | _ -> ()]) + (ks ")" k) + | spel -> + fprintf ppf "(@[<v>@[parser%t@]@ @[<v 0>%a@]@]" + (fun ppf -> + match bp with + [ Some p -> fprintf ppf "@ %a" patt (p, nok) + | _ -> ()]) + parser_cases (spel, ks ")" k) ] +; + +value pmatch ppf (e, k) = + let (me, e) = + match e with + [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e) + | _ -> failwith "Pr_schp_main.pmatch" ] + in + let (bp, e) = + match e with + [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) + | e -> (None, e) ] + in + let spel = parser_of_expr e in + fprintf ppf "(@[@[match_with_parser@ %a@]%t@ @[<v 0>%a@]@]" expr (me, nok) + (fun ppf -> + match bp with + [ Some p -> fprintf ppf "@ %a" patt (p, nok) + | _ -> () ]) + parser_cases (spel, ks ")" k) +; + +pr_expr_fun_args.val := + extfun pr_expr_fun_args.val with + [ <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ]; + +let lev = find_pr_level "top" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< fun (strm__ : $_$) -> $x$ >> -> + fun ppf curr next dg k -> fprintf ppf "%a" parser_body (x, k) + | <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e -> + fun ppf curr next dg k -> fprintf ppf "%a" pmatch (e, k) ]; diff --git a/camlp4/etc/q_phony.ml b/camlp4/etc/q_phony.ml index e7a92c932..841e2bec9 100644 --- a/camlp4/etc/q_phony.ml +++ b/camlp4/etc/q_phony.ml @@ -37,11 +37,13 @@ Quotation.add "" Quotation.default.val := ""; Quotation.translate.val := fun s -> do { t.val := s; "" }; -EXTEND - expr: LEVEL "top" - [ [ "ifdef"; c = UIDENT; "then"; e1 = expr; "else"; e2 = expr -> - <:expr< if def $uid:c$ then $e1$ else $e2$ >> - | "ifndef"; c = UIDENT; "then"; e1 = expr; "else"; e2 = expr -> - <:expr< if ndef $uid:c$ then $e1$ else $e2$ >> ] ] - ; -END; +if Pcaml.syntax_name.val <> "Scheme" then + EXTEND + expr: LEVEL "top" + [ [ "IFDEF"; c = UIDENT; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" -> + <:expr< if DEF $uid:c$ then $e1$ else $e2$ >> + | "IFNDEF"; c = UIDENT; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" -> + <:expr< if NDEF $uid:c$ then $e1$ else $e2$ >> ] ] + ; + END +else (); diff --git a/camlp4/lib/Makefile b/camlp4/lib/Makefile index 41b77bea8..1a8bc6604 100644 --- a/camlp4/lib/Makefile +++ b/camlp4/lib/Makefile @@ -36,17 +36,17 @@ compare: done install: - -$(MKDIR) $(LIBDIR)/camlp4 - cp $(TARGET) *.mli $(LIBDIR)/camlp4/. - cp *.cmi $(LIBDIR)/camlp4/. - if test -f $(TARGET:.cma=.cmxa); then $(MAKE) installopt LIBDIR=$(LIBDIR); fi + -$(MKDIR) "$(LIBDIR)/camlp4" + cp $(TARGET) *.mli "$(LIBDIR)/camlp4/." + cp *.cmi "$(LIBDIR)/camlp4/." + if test -f $(TARGET:.cma=.cmxa); then $(MAKE) installopt LIBDIR="$(LIBDIR)"; fi installopt: - cp $(TARGET:.cma=.cmxa) *.cmx $(LIBDIR)/camlp4/. + cp $(TARGET:.cma=.cmxa) *.cmx "$(LIBDIR)/camlp4/." if test -f $(TARGET:.cma=.lib); then \ - cp $(TARGET:.cma=.lib) $(LIBDIR)/camlp4/.; \ + cp $(TARGET:.cma=.lib) "$(LIBDIR)/camlp4/."; \ else \ - tar cf - $(TARGET:.cma=.a) | (cd $(LIBDIR)/camlp4/.; tar xf -); \ + tar cf - $(TARGET:.cma=.a) | (cd "$(LIBDIR)/camlp4/."; tar xf -); \ fi include .depend diff --git a/camlp4/lib/extfun.ml b/camlp4/lib/extfun.ml index 9d7a7365d..866ea221c 100644 --- a/camlp4/lib/extfun.ml +++ b/camlp4/lib/extfun.ml @@ -86,7 +86,7 @@ value print ef = value insert_matching matchings (patt, has_when, expr) = let m1 = {patt = patt; has_when = has_when; expr = expr} in - loop matchings where rec loop = + let rec loop = fun [ [m :: ml] as gml -> if m1.has_when && not m.has_when then [m1 :: gml] @@ -98,6 +98,8 @@ value insert_matching matchings (patt, has_when, expr) = else if m.has_when then [m1 :: gml] else [m1 :: ml] | [] -> [m1] ] + in + loop matchings ; (* available extension function *) diff --git a/camlp4/lib/fstream.ml b/camlp4/lib/fstream.ml index 3a9d58a1b..14ab3a3d1 100644 --- a/camlp4/lib/fstream.ml +++ b/camlp4/lib/fstream.ml @@ -59,7 +59,9 @@ value of_channel ic = value iter f = do_rec where rec do_rec strm = match next strm with - [ Some (a, strm) -> let _ = f a in do_rec strm + [ Some (a, strm) -> + let _ = f a in + do_rec strm | None -> () ] ; @@ -69,7 +71,7 @@ value count_unfrozen s = loop 0 s where rec loop cnt s = if Lazy.lazy_is_val s.data then match Lazy.force s.data with - [ (Cons _ s) -> loop (cnt + 1) s + [ Cons _ s -> loop (cnt + 1) s | _ -> cnt ] else cnt ; diff --git a/camlp4/lib/grammar.ml b/camlp4/lib/grammar.ml index eceeb41d7..b8c22d507 100644 --- a/camlp4/lib/grammar.ml +++ b/camlp4/lib/grammar.ml @@ -28,22 +28,17 @@ value print_str ppf s = fprintf ppf "\"%s\"" (String.escaped s); value rec print_symbol ppf = fun - [ Smeta n sl _ -> - print_meta ppf n sl - | Slist0 s -> - fprintf ppf "LIST0 %a" print_symbol1 s + [ Smeta n sl _ -> print_meta ppf n sl + | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s | Slist0sep s t -> fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t - | Slist1 s -> - fprintf ppf "LIST1 %a" print_symbol1 s + | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s | Slist1sep s t -> fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t - | Sopt s -> - fprintf ppf "OPT %a" print_symbol1 s + | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s | Stoken (con, prm) when con <> "" && prm <> "" -> fprintf ppf "%s@ %a" con print_str prm - | Snterml e l -> - fprintf ppf "%s@ LEVEL@ %a" e.ename print_str l + | Snterml e l -> fprintf ppf "%s@ LEVEL@ %a" e.ename print_str l | Snterm _ | Snext | Sself | Stoken _ | Stree _ as s -> print_symbol1 ppf s ] and print_meta ppf n sl = @@ -52,16 +47,12 @@ and print_meta ppf n sl = [ [] -> () | [s :: sl] -> let j = - try String.index_from n i ' ' with - [ Not_found -> String.length n ] + try String.index_from n i ' ' with [ Not_found -> String.length n ] in do { fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s; if sl = [] then () - else do { - fprintf ppf " "; - loop (min (j + 1) (String.length n)) sl - } + else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl } } ] and print_symbol1 ppf = fun @@ -72,7 +63,7 @@ and print_symbol1 ppf = | Stoken (con, "") -> pp_print_string ppf con | Stree t -> print_level ppf pp_print_space (flatten_tree t) | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | - Slist1sep _ _ | Sopt _ | Stoken _ as s -> + Slist1sep _ _ | Sopt _ | Stoken _ as s -> fprintf ppf "(%a)" print_symbol s ] and print_rule ppf symbols = do { @@ -100,7 +91,7 @@ and print_level ppf pp_print_space rules = }) (fun ppf -> ()) rules in - fprintf ppf " ]@]"; + fprintf ppf " ]@]" } ; @@ -136,10 +127,75 @@ value print_entry ppf e = match e.edesc with [ Dlevels elev -> print_levels ppf elev | Dparser _ -> fprintf ppf "<parser>" ]; - fprintf ppf " ]@]@."; + fprintf ppf " ]@]" } ; +value iter_entry f e = + let treated = ref [] in + let rec do_entry e = + if List.memq e treated.val then () + else do { + treated.val := [e :: treated.val]; + f e; + match e.edesc with + [ Dlevels ll -> List.iter do_level ll + | Dparser _ -> () ] + } + and do_level lev = do { do_tree lev.lsuffix; do_tree lev.lprefix } + and do_tree = + fun + [ Node n -> do_node n + | LocAct _ _ | DeadEnd -> () ] + and do_node n = do { do_symbol n.node; do_tree n.son; do_tree n.brother } + and do_symbol = + fun + [ Smeta _ sl _ -> List.iter do_symbol sl + | Snterm e | Snterml e _ -> do_entry e + | Slist0 s | Slist1 s | Sopt s -> do_symbol s + | Slist0sep s1 s2 | Slist1sep s1 s2 -> do { do_symbol s1; do_symbol s2 } + | Stree t -> do_tree t + | Sself | Snext | Stoken _ -> () ] + in + do_entry e +; + +value fold_entry f e init = + let treated = ref [] in + let rec do_entry accu e = + if List.memq e treated.val then accu + else do { + treated.val := [e :: treated.val]; + let accu = f e accu in + match e.edesc with + [ Dlevels ll -> List.fold_left do_level accu ll + | Dparser _ -> accu ] + } + and do_level accu lev = + let accu = do_tree accu lev.lsuffix in + do_tree accu lev.lprefix + and do_tree accu = + fun + [ Node n -> do_node accu n + | LocAct _ _ | DeadEnd -> accu ] + and do_node accu n = + let accu = do_symbol accu n.node in + let accu = do_tree accu n.son in + do_tree accu n.brother + and do_symbol accu = + fun + [ Smeta _ sl _ -> List.fold_left do_symbol accu sl + | Snterm e | Snterml e _ -> do_entry accu e + | Slist0 s | Slist1 s | Sopt s -> do_symbol accu s + | Slist0sep s1 s2 | Slist1sep s1 s2 -> + let accu = do_symbol accu s1 in + do_symbol accu s2 + | Stree t -> do_tree accu t + | Sself | Snext | Stoken _ -> accu ] + in + do_entry init e +; + type g = Gramext.grammar Token.t; external grammar_obj : g -> grammar Token.t = "%identity"; @@ -327,7 +383,7 @@ value tree_failed entry prev_symb_result prev_symb tree = print_level ppf pp_force_newline (flatten_tree tree); fprintf ppf "@]@,"; fprintf ppf "----------------------------------@,"; - fprintf ppf "@]@."; + fprintf ppf "@]@." } else (); txt ^ " (in [" ^ entry.ename ^ "])" @@ -581,7 +637,9 @@ and parser_of_symbol entry nlevn = let f = entry.egram.glexer.Token.tok_match tok in fun strm -> match Stream.peek strm with - [ Some tok -> let r = f tok in do { Stream.junk strm; Obj.repr r } + [ Some tok -> + let r = f tok in + do { Stream.junk strm; Obj.repr r } | None -> raise Stream.Failure ] ] and parse_top_symb entry symb = parser_of_symbol entry 0 (top_symb entry symb) @@ -671,11 +729,7 @@ value parse_parsable entry efun (cs, (ts, fun_loc)) = let restore = let old_floc = floc.val in let old_tc = token_count.val in - fun () -> - do { - floc.val := old_floc; - token_count.val := old_tc; - } + fun () -> do { floc.val := old_floc; token_count.val := old_tc } in let get_loc () = try @@ -723,15 +777,12 @@ value tematch tparse tok = | None -> Token.default_match tok ] ; value glexer_of_lexer lexer = - {Token.tok_func = lexer.Token.func; - Token.tok_using = lexer.Token.using; + {Token.tok_func = lexer.Token.func; Token.tok_using = lexer.Token.using; Token.tok_removing = lexer.Token.removing; Token.tok_match = tematch lexer.Token.tparse; - Token.tok_text = lexer.Token.text} -; -value create lexer = - gcreate (glexer_of_lexer lexer) + Token.tok_text = lexer.Token.text; Token.tok_comm = None} ; +value create lexer = gcreate (glexer_of_lexer lexer); (* Extend syntax *) @@ -813,9 +864,7 @@ value gram_reinit g glexer = do { Hashtbl.clear g.gtokens; g.glexer := glexer } ; -value reinit_gram g lexer = - gram_reinit g (glexer_of_lexer lexer) -; +value reinit_gram g lexer = gram_reinit g (glexer_of_lexer lexer); module Unsafe = struct @@ -887,20 +936,19 @@ module Entry = value parse (entry : e 'a) cs : 'a = Obj.magic (wrap_parse entry (entry.estart 0) cs) ; - value parse_token (entry : e 'a) ts : 'a = - Obj.magic (entry.estart 0 ts); + value parse_token (entry : e 'a) ts : 'a = Obj.magic (entry.estart 0 ts); value name e = e.ename; value of_parser g n (p : Stream.t te -> 'a) : e 'a = {egram = g; ename = n; estart _ = Obj.magic p; econtinue _ _ _ = parser []; edesc = Dparser (Obj.magic p)} ; external obj : e 'a -> Gramext.g_entry te = "%identity"; - value print e = print_entry std_formatter (obj e); + value print e = printf "%a@." print_entry (obj e); value find e s = find_entry (obj e) s; end ; -value gen_tokens g con = +value tokens g con = let list = ref [] in do { Hashtbl.iter @@ -911,17 +959,13 @@ value gen_tokens g con = } ; -value tokens g = gen_tokens (grammar_obj g); +value glexer g = g.glexer; value warning_verbose = Gramext.warning_verbose; (* Functorial interface *) -module type GLexerType = - sig - type te = 'x; - value lexer : Token.glexer te; - end; +module type GLexerType = sig type te = 'x; value lexer : Token.glexer te; end; module type S = sig @@ -929,6 +973,7 @@ module type S = type parsable = 'x; value parsable : Stream.t char -> parsable; value tokens : string -> list (string * int); + value glexer : Token.glexer te; module Entry : sig type e 'a = 'x; @@ -958,21 +1003,17 @@ module type S = end ; -module type ReinitType = - sig - value reinit_gram : g -> Token.lexer -> unit; - end +module type ReinitType = sig value reinit_gram : g -> Token.lexer -> unit; end ; module GGMake (R : ReinitType) (L : GLexerType) = struct type te = L.te; - type parsable = - (Stream.t char * (Stream.t te * Token.location_function)) - ; + type parsable = (Stream.t char * (Stream.t te * Token.location_function)); value gram = gcreate L.lexer; value parsable cs = (cs, L.lexer.Token.tok_func cs); - value tokens = gen_tokens gram; + value tokens = tokens gram; + value glexer = glexer gram; module Entry = struct type e 'a = g_entry te; @@ -990,7 +1031,7 @@ module GGMake (R : ReinitType) (L : GLexerType) = {egram = gram; ename = n; estart _ = Obj.magic p; econtinue _ _ _ = parser []; edesc = Dparser (Obj.magic p)} ; - value print e = print_entry std_formatter (obj e); + value print e = printf "%a@." print_entry (obj e); end ; module Unsafe = @@ -1015,16 +1056,9 @@ module GMake (L : GLexerType) = L ; -module type LexerType = - sig - value lexer : Token.lexer; - end; +module type LexerType = sig value lexer : Token.lexer; end; module Make (L : LexerType) = - GGMake - (struct value reinit_gram = reinit_gram; end) - (struct - type te = Token.t; - value lexer = glexer_of_lexer L.lexer; - end) + GGMake (struct value reinit_gram = reinit_gram; end) + (struct type te = Token.t; value lexer = glexer_of_lexer L.lexer; end) ; diff --git a/camlp4/lib/grammar.mli b/camlp4/lib/grammar.mli index 0b805613c..fe8345fb3 100644 --- a/camlp4/lib/grammar.mli +++ b/camlp4/lib/grammar.mli @@ -35,6 +35,8 @@ value tokens : g -> string -> list (string * int); list. - The call [Grammar.token g "IDENT"] returns the list of all usages of the pattern "IDENT" in the [EXTEND] statements. *) +value glexer : g -> Token.glexer Token.t; + (** Return the lexer used by the grammar *) module Entry : sig @@ -106,6 +108,7 @@ module type S = type parsable = 'x; value parsable : Stream.t char -> parsable; value tokens : string -> list (string * int); + value glexer : Token.glexer te; module Entry : sig type e 'a = 'y; @@ -165,6 +168,20 @@ value strict_parsing : ref bool; value print_entry : Format.formatter -> Gramext.g_entry 'te -> unit; (** General printer for all kinds of entries (obj entries) *) +value iter_entry : + (Gramext.g_entry 'te -> unit) -> Gramext.g_entry 'te -> unit; + (** [Grammar.iter_entry f e] applies [f] to the entry [e] and + transitively all entries called by [e]. The order in which + the entries are passed to [f] is the order they appear in + each entry. Each entry is passed only once. *) + +value fold_entry : + (Gramext.g_entry 'te -> 'a -> 'a) -> Gramext.g_entry 'te -> 'a -> 'a; + (** [Grammar.fold_entry f e init] computes [(f eN .. (f e2 (f e1 init)))], + where [e1 .. eN] are [e] and transitively all entries called by [e]. + The order in which the entries are passed to [f] is the order they + appear in each entry. Each entry is passed only once. *) + (**/**) (*** deprecated since version 3.05; use rather the functor GMake *) @@ -183,8 +200,7 @@ value extend : (option string * option Gramext.g_assoc * list (list (Gramext.g_symbol 'te) * Gramext.g_action))) -> unit; -value delete_rule : - Entry.e 'a -> list (Gramext.g_symbol Token.t) -> unit; +value delete_rule : Entry.e 'a -> list (Gramext.g_symbol Token.t) -> unit; value parse_top_symb : Gramext.g_entry 'te -> Gramext.g_symbol 'te -> Stream.t 'te -> Obj.t; diff --git a/camlp4/lib/plexer.ml b/camlp4/lib/plexer.ml index 236d56551..0fd9adcfc 100644 --- a/camlp4/lib/plexer.ml +++ b/camlp4/lib/plexer.ml @@ -37,6 +37,14 @@ value get_buff len = String.sub buff.val 0 len; (* The lexer *) +value stream_peek_nth n strm = + loop n (Stream.npeek n strm) where rec loop n = + fun + [ [] -> None + | [x] -> if n == 1 then Some x else None + | [_ :: l] -> loop (n - 1) l ] +; + value rec ident len = parser [ [: `('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | @@ -115,6 +123,7 @@ and end_exponent_part_under len = value error_on_unknown_keywords = ref False; value err loc msg = raise_with_loc loc (Token.Error msg); +(* value next_token_fun dfa find_kwd = let keyword_or_error loc s = try (("", find_kwd s), loc) with @@ -212,7 +221,7 @@ value next_token_fun dfa find_kwd = id = parser [ [: `'.' :] -> ".." - | [: :] -> "." ] :] ep -> + | [: :] -> if ssd && after_space then " ." else "." ] :] ep -> keyword_or_error (bp, ep) id | [: `';'; id = @@ -227,8 +236,8 @@ value next_token_fun dfa find_kwd = if no_quotations.val then match strm with parser [ [: len = ident2 (store 0 '<') :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id ] + let id = get_buff len in + keyword_or_error (bp, ep) id ] else match strm with parser [ [: `'<'; len = quotation bp 0 :] ep -> @@ -267,8 +276,7 @@ value next_token_fun dfa find_kwd = [ [: `c :] -> ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - else - ("", get_buff (ident2 (store 0 '$') s)) ] + else ("", get_buff (ident2 (store 0 '$') s)) ] and maybe_locate bp len = parser [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) @@ -303,7 +311,7 @@ value next_token_fun dfa find_kwd = parser [ [: `'>'; s :] -> maybe_end_quotation bp len s | [: `'<'; s :] -> - quotation bp (maybe_nested_quotation bp (store len '<') strm__) s + quotation bp (maybe_nested_quotation bp (store len '<') s) s | [: `'\\'; len = parser @@ -329,7 +337,7 @@ value next_token_fun dfa find_kwd = | [: a = quotation bp (store len '>') :] -> a ] and left_paren bp = parser - [ [: `'*'; _ = comment bp; a = next_token :] -> a + [ [: `'*'; _ = comment bp; a = next_token True :] -> a | [: :] ep -> keyword_or_error (bp, ep) "(" ] and comment bp = parser @@ -405,37 +413,361 @@ value next_token_fun dfa find_kwd = parser [ [: `')' :] -> () | [: a = comment bp :] -> a ] - and linenum bp = - parser - [ [: `'0'..'9'; _ = digits; _ = spaces_tabs; `'"'; _ = any_to_nl; s :] -> - next_token s - | [: :] -> keyword_or_error (bp, bp + 1) "#" ] - and spaces_tabs = + and linedir n s = + match stream_peek_nth n s with + [ Some (' ' | '\t') -> linedir (n + 1) s + | Some ('0'..'9') -> linedir_digits (n + 1) s + | _ -> False ] + and linedir_digits n s = + match stream_peek_nth n s with + [ Some ('0'..'9') -> linedir_digits (n + 1) s + | _ -> linedir_quote n s ] + and linedir_quote n s = + match stream_peek_nth n s with + [ Some (' ' | '\t') -> linedir_quote (n + 1) s + | Some '"' -> True + | _ -> False ] + and any_to_nl = parser - [ [: `' ' | '\t'; s :] -> spaces_tabs s + [ [: `'\013' | '\010' :] ep -> bolpos.val := ep + | [: `_; s :] -> any_to_nl s | [: :] -> () ] - and digits = + in + fun cstrm -> + try + let glex = glexr.val in + let comm_bp = Stream.count cstrm in + let r = next_token False cstrm in + do { + match glex.tok_comm with + [ Some list -> + if fst (snd r) > comm_bp then + let comm_loc = (comm_bp, fst (snd r)) in + glex.tok_comm := Some [comm_loc :: list] + else () + | None -> () ]; + r + } + with + [ Stream.Error str -> + err (Stream.count cstrm, Stream.count cstrm + 1) str ] +; +*) + +value next_token_fun dfa ssd find_kwd bolpos glexr = + let keyword_or_error loc s = + try (("", find_kwd s), loc) with + [ Not_found -> + if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s) + else (("", s), loc) ] + in + let rec next_token after_space = + parser bp + [ [: `'\010' | '\013'; s :] ep -> + do { bolpos.val := ep; next_token True s } + | [: `' ' | '\t' | '\026' | '\012'; s :] -> next_token True s + | [: `'#' when bp = bolpos.val; s :] -> + if linedir 1 s then do { any_to_nl s; next_token True s } + else keyword_or_error (bp, bp + 1) "#" + | [: `'('; s :] -> left_paren bp s + | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] -> + let id = get_buff (ident (store 0 c) s) in + let loc = (bp, Stream.count s) in + (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc) + | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] -> + let id = get_buff (ident (store 0 c) s) in + let loc = (bp, Stream.count s) in + (try ("", find_kwd id) with [ Not_found -> ("LIDENT", id) ], loc) + | [: `('1'..'9' as c); s :] -> + let tok = number (store 0 c) s in + let loc = (bp, Stream.count s) in + (tok, loc) + | [: `'0'; s :] -> + let tok = base_number (store 0 '0') s in + let loc = (bp, Stream.count s) in + (tok, loc) + | [: `'''; s :] -> + match Stream.npeek 2 s with + [ [_; '''] | ['\\'; _] -> + let tok = ("CHAR", get_buff (char bp 0 s)) in + let loc = (bp, Stream.count s) in + (tok, loc) + | _ -> keyword_or_error (bp, Stream.count s) "'" ] + | [: `'"'; s :] -> + let tok = ("STRING", get_buff (string bp 0 s)) in + let loc = (bp, Stream.count s) in + (tok, loc) + | [: `'$'; s :] -> + let tok = dollar bp 0 s in + let loc = (bp, Stream.count s) in + (tok, loc) + | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c); + s :] -> + let id = get_buff (ident2 (store 0 c) s) in + keyword_or_error (bp, Stream.count s) id + | [: `('~' as c); + a = + parser + [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep -> + (("TILDEIDENT", get_buff len), (bp, ep)) + | [: s :] -> + let id = get_buff (ident2 (store 0 c) s) in + keyword_or_error (bp, Stream.count s) id ] :] -> + a + | [: `('?' as c); + a = + parser + [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep -> + (("QUESTIONIDENT", get_buff len), (bp, ep)) + | [: s :] -> + let id = get_buff (ident2 (store 0 c) s) in + keyword_or_error (bp, Stream.count s) id ] :] -> + a + | [: `'<'; s :] -> less bp s + | [: `(':' as c1); + len = + parser + [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2 + | [: :] -> store 0 c1 ] :] ep -> + let id = get_buff len in + keyword_or_error (bp, ep) id + | [: `('>' | '|' as c1); + len = + parser + [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2 + | [: a = ident2 (store 0 c1) :] -> a ] :] ep -> + let id = get_buff len in + keyword_or_error (bp, ep) id + | [: `('[' | '{' as c1); s :] -> + let len = + match Stream.npeek 2 s with + [ ['<'; '<' | ':'] -> store 0 c1 + | _ -> + match s with parser + [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2 + | [: :] -> store 0 c1 ] ] + in + let ep = Stream.count s in + let id = get_buff len in + keyword_or_error (bp, ep) id + | [: `'.'; + id = + parser + [ [: `'.' :] -> ".." + | [: :] -> if ssd && after_space then " ." else "." ] :] ep -> + keyword_or_error (bp, ep) id + | [: `';'; + id = + parser + [ [: `';' :] -> ";;" + | [: :] -> ";" ] :] ep -> + keyword_or_error (bp, ep) id + | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), (bp, ep)) + | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c) + | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ] + and less bp strm = + if no_quotations.val then + match strm with parser + [ [: len = ident2 (store 0 '<') :] ep -> + let id = get_buff len in + keyword_or_error (bp, ep) id ] + else + match strm with parser + [ [: `'<'; len = quotation bp 0 :] ep -> + (("QUOTATION", ":" ^ get_buff len), (bp, ep)) + | [: `':'; i = parser [: len = ident 0 :] -> get_buff len; + `'<' ? "character '<' expected"; len = quotation bp 0 :] ep -> + (("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep)) + | [: len = ident2 (store 0 '<') :] ep -> + let id = get_buff len in + keyword_or_error (bp, ep) id ] + and string bp len = parser - [ [: `'0'..'9'; s :] -> digits s - | [: :] -> () ] + [ [: `'"' :] -> len + | [: `'\\'; `c; s :] -> string bp (store (store len '\\') c) s + | [: `c; s :] -> string bp (store len c) s + | [: :] ep -> err (bp, ep) "string not terminated" ] + and char bp len = + parser + [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else len + | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s + | [: `c; s :] -> char bp (store len c) s + | [: :] ep -> err (bp, ep) "char not terminated" ] + and dollar bp len = + parser + [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) + | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s + | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s + | [: `':'; s :] -> + let k = get_buff len in + ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) + | [: `'\\'; `c; s :] -> + ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) + | [: s :] -> + if dfa then + match s with parser + [ [: `c :] -> + ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) + | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] + else ("", get_buff (ident2 (store 0 '$') s)) ] + and maybe_locate bp len = + parser + [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) + | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s + | [: `':'; s :] -> + ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s) + | [: `'\\'; `c; s :] -> + ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) + | [: `c; s :] -> + ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) + | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] + and antiquot bp len = + parser + [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) + | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] -> + antiquot bp (store len c) s + | [: `':'; s :] -> + let k = get_buff len in + ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) + | [: `'\\'; `c; s :] -> + ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) + | [: `c; s :] -> + ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) + | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] + and locate_or_antiquot_rest bp len = + parser + [ [: `'$' :] -> get_buff len + | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s + | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s + | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] + and quotation bp len = + parser + [ [: `'>'; s :] -> maybe_end_quotation bp len s + | [: `'<'; s :] -> + quotation bp (maybe_nested_quotation bp (store len '<') s) s + | [: `'\\'; + len = + parser + [ [: `('>' | '<' | '\\' as c) :] -> store len c + | [: :] -> store len '\\' ]; + s :] -> + quotation bp len s + | [: `c; s :] -> quotation bp (store len c) s + | [: :] ep -> err (bp, ep) "quotation not terminated" ] + and maybe_nested_quotation bp len = + parser + [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" + | [: `':'; len = ident (store len ':'); + a = + parser + [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" + | [: :] -> len ] :] -> + a + | [: :] -> len ] + and maybe_end_quotation bp len = + parser + [ [: `'>' :] -> len + | [: a = quotation bp (store len '>') :] -> a ] + and left_paren bp = + parser + [ [: `'*'; _ = comment bp; a = next_token True :] -> a + | [: :] ep -> keyword_or_error (bp, ep) "(" ] + and comment bp = + parser + [ [: `'('; s :] -> left_paren_in_comment bp s + | [: `'*'; s :] -> star_in_comment bp s + | [: `'"'; _ = string bp 0; s :] -> comment bp s + | [: `'''; s :] -> quote_in_comment bp s + | [: `c; s :] -> comment bp s + | [: :] ep -> err (bp, ep) "comment not terminated" ] + and quote_in_comment bp = + parser + [ [: `'''; s :] -> comment bp s + | [: `'\\'; s :] -> quote_antislash_in_comment bp 0 s + | [: s :] -> + do { + match Stream.npeek 2 s with + [ [_; '''] -> do { Stream.junk s; Stream.junk s } + | _ -> () ]; + comment bp s + } ] + and quote_any_in_comment bp = + parser + [ [: `'''; s :] -> comment bp s + | [: a = comment bp :] -> a ] + and quote_antislash_in_comment bp len = + parser + [ [: `'''; s :] -> comment bp s + | [: `'\\' | '"' | 'n' | 't' | 'b' | 'r'; s :] -> + quote_any_in_comment bp s + | [: `'0'..'9'; s :] -> quote_antislash_digit_in_comment bp s + | [: a = comment bp :] -> a ] + and quote_antislash_digit_in_comment bp = + parser + [ [: `'0'..'9'; s :] -> quote_antislash_digit2_in_comment bp s + | [: a = comment bp :] -> a ] + and quote_antislash_digit2_in_comment bp = + parser + [ [: `'0'..'9'; s :] -> quote_any_in_comment bp s + | [: a = comment bp :] -> a ] + and left_paren_in_comment bp = + parser + [ [: `'*'; s :] -> do { comment bp s; comment bp s } + | [: a = comment bp :] -> a ] + and star_in_comment bp = + parser + [ [: `')' :] -> () + | [: a = comment bp :] -> a ] + and linedir n s = + match stream_peek_nth n s with + [ Some (' ' | '\t') -> linedir (n + 1) s + | Some ('0'..'9') -> linedir_digits (n + 1) s + | _ -> False ] + and linedir_digits n s = + match stream_peek_nth n s with + [ Some ('0'..'9') -> linedir_digits (n + 1) s + | _ -> linedir_quote n s ] + and linedir_quote n s = + match stream_peek_nth n s with + [ Some (' ' | '\t') -> linedir_quote (n + 1) s + | Some '"' -> True + | _ -> False ] and any_to_nl = parser - [ [: `'\013' | '\010' :] -> () + [ [: `'\013' | '\010' :] ep -> bolpos.val := ep | [: `_; s :] -> any_to_nl s | [: :] -> () ] in fun cstrm -> - try next_token cstrm with + try + let glex = glexr.val in + let comm_bp = Stream.count cstrm in + let r = next_token False cstrm in + do { + match glex.tok_comm with + [ Some list -> + if fst (snd r) > comm_bp then + let comm_loc = (comm_bp, fst (snd r)) in + glex.tok_comm := Some [comm_loc :: list] + else () + | None -> () ]; + r + } + with [ Stream.Error str -> err (Stream.count cstrm, Stream.count cstrm + 1) str ] ; + value dollar_for_antiquotation = ref True; +value specific_space_dot = ref False; -value func kwd_table = +value func kwd_table glexr = + let bolpos = ref 0 in let find = Hashtbl.find kwd_table in let dfa = dollar_for_antiquotation.val in - Token.lexer_func_of_parser (next_token_fun dfa find) + let ssd = specific_space_dot.val in + Token.lexer_func_of_parser (next_token_fun dfa ssd find bolpos glexr) ; value rec check_keyword_stream = @@ -505,8 +837,8 @@ value check_keyword s = value error_no_respect_rules p_con p_prm = raise - (Token.Error - ("the token " ^ + (Token.Error + ("the token " ^ (if p_con = "" then "\"" ^ p_prm ^ "\"" else if p_prm = "" then p_con else p_con ^ " \"" ^ p_prm ^ "\"") ^ @@ -516,8 +848,8 @@ value error_no_respect_rules p_con p_prm = value error_ident_and_keyword p_con p_prm = raise (Token.Error - ("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^ - " and as keyword")) + ("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^ + " and as keyword")) ; value using_token kwd_table ident_table (p_con, p_prm) = @@ -548,9 +880,8 @@ value using_token kwd_table ident_table (p_con, p_prm) = if Hashtbl.mem kwd_table p_prm then error_ident_and_keyword p_con p_prm else Hashtbl.add ident_table p_prm p_con ] - | "TILDEIDENT" | "QUESTIONIDENT" | - "INT" | "FLOAT" | "CHAR" | "STRING" | "QUOTATION" | - "ANTIQUOT" | "LOCATE" | "EOI" -> + | "TILDEIDENT" | "QUESTIONIDENT" | "INT" | "FLOAT" | "CHAR" | "STRING" | + "QUOTATION" | "ANTIQUOT" | "LOCATE" | "EOI" -> () | _ -> raise @@ -563,8 +894,7 @@ value removing_token kwd_table ident_table (p_con, p_prm) = match p_con with [ "" -> Hashtbl.remove kwd_table p_prm | "LIDENT" | "UIDENT" -> - if p_prm <> "" then Hashtbl.remove ident_table p_prm - else () + if p_prm <> "" then Hashtbl.remove ident_table p_prm else () | _ -> () ] ; @@ -611,16 +941,24 @@ value tok_match = fun [ ("ANTIQUOT", prm) when eq_before_colon p_prm prm -> after_colon prm | _ -> raise Stream.Failure ] - | tok -> - Token.default_match tok ] + | tok -> Token.default_match tok ] ; value gmake () = let kwd_table = Hashtbl.create 301 in let id_table = Hashtbl.create 301 in - {tok_func = func kwd_table; tok_using = using_token kwd_table id_table; - tok_removing = removing_token kwd_table id_table; - tok_match = tok_match; tok_text = text} + let glexr = + ref + {tok_func = fun []; tok_using = fun []; tok_removing = fun []; + tok_match = fun []; tok_text = fun []; tok_comm = None} + in + let glex = + {tok_func = func kwd_table glexr; + tok_using = using_token kwd_table id_table; + tok_removing = removing_token kwd_table id_table; tok_match = tok_match; + tok_text = text; tok_comm = None} + in + do { glexr.val := glex; glex } ; value tparse = @@ -638,7 +976,11 @@ value tparse = value make () = let kwd_table = Hashtbl.create 301 in let id_table = Hashtbl.create 301 in - {func = func kwd_table; using = using_token kwd_table id_table; - removing = removing_token kwd_table id_table; tparse = tparse; - text = text} + let glexr = + ref + {tok_func = fun []; tok_using = fun []; tok_removing = fun []; + tok_match = fun []; tok_text = fun []; tok_comm = None} + in + {func = func kwd_table glexr; using = using_token kwd_table id_table; + removing = removing_token kwd_table id_table; tparse = tparse; text = text} ; diff --git a/camlp4/lib/plexer.mli b/camlp4/lib/plexer.mli index 181bb0d28..a5d563d01 100644 --- a/camlp4/lib/plexer.mli +++ b/camlp4/lib/plexer.mli @@ -54,6 +54,12 @@ value dollar_for_antiquotation : ref bool; lexer where the dollar sign is used for antiquotations. If False, the dollar sign can be used as token. *) +value specific_space_dot : ref bool; + (** When False (default), the next call to [Plexer.make ()] returns a + lexer where the dots can be preceded by spaces. If True, dots + preceded by spaces return the keyword " ." (space dot), otherwise + return the keyword "." (dot). *) + value no_quotations : ref bool; (** When True, all lexers built by [Plexer.make ()] do not lex the quotation syntax any more. Default is False (quotations are diff --git a/camlp4/lib/stdpp.ml b/camlp4/lib/stdpp.ml index bdd8cb9d2..a89cb15d8 100644 --- a/camlp4/lib/stdpp.ml +++ b/camlp4/lib/stdpp.ml @@ -23,20 +23,57 @@ value raise_with_loc loc exc = value line_of_loc fname (bp, ep) = try let ic = open_in_bin fname in - let rec loop lin col cnt = - if cnt < bp then - let (lin, col) = - match input_char ic with - [ '\n' -> (lin + 1, 0) - | _ -> (lin, col + 1) ] - in - loop lin col (cnt + 1) - else (lin, col, col + ep - bp) + let strm = Stream.of_channel ic in + let rec loop fname lin = + let rec not_a_line_dir col = + parser cnt + [: `c; s :] -> + if cnt < bp then + if c = '\n' then loop fname (lin + 1) + else not_a_line_dir (col + 1) s + else + let col = col - (cnt - bp) in + (fname, lin, col, col + ep - bp) + in + let rec a_line_dir str n col = + parser + [ [: `'\n' :] -> loop str n + | [: `_; s :] -> a_line_dir str n (col + 1) s ] + in + let rec spaces col = + parser + [ [: `' '; s :] -> spaces (col + 1) s + | [: :] -> col ] + in + let rec check_string str n col = + parser + [ [: `'"'; col = spaces (col + 1); s :] -> a_line_dir str n col s + | [: `c when c <> '\n'; s :] -> + check_string (str ^ String.make 1 c) n (col + 1) s + | [: a = not_a_line_dir col :] -> a ] + in + let check_quote n col = + parser + [ [: `'"'; s :] -> check_string "" n (col + 1) s + | [: a = not_a_line_dir col :] -> a ] + in + let rec check_num n col = + parser + [ [: `('0'..'9' as c); s :] -> + check_num (10 * n + Char.code c - Char.code '0') (col + 1) s + | [: col = spaces col; s :] -> check_quote n col s ] + in + let begin_line = + parser + [ [: `'#'; col = spaces 1; s :] -> check_num 0 col s + | [: a = not_a_line_dir 0 :] -> a ] + in + begin_line strm in - let r = try loop 1 0 0 with [ End_of_file -> (1, bp, ep) ] in + let r = try loop fname 1 with [ Stream.Failure -> (fname, 1, bp, ep) ] in do { close_in ic; r } with - [ Sys_error _ -> (1, bp, ep) ] + [ Sys_error _ -> (fname, 1, bp, ep) ] ; value loc_name = ref "loc"; diff --git a/camlp4/lib/stdpp.mli b/camlp4/lib/stdpp.mli index 540e2e9b0..069e56bee 100644 --- a/camlp4/lib/stdpp.mli +++ b/camlp4/lib/stdpp.mli @@ -25,10 +25,12 @@ value raise_with_loc : (int * int) -> exn -> 'a; (** [raise_with_loc loc e], if [e] is already the exception [Exc_located], re-raise it, else raise the exception [Exc_located loc e]. *) -value line_of_loc : string -> (int * int) -> (int * int * int); +value line_of_loc : string -> (int * int) -> (string * int * int * int); (** [line_of_loc fname loc] reads the file [fname] up to the - location [loc] and returns the line number and the characters - location in the line *) + location [loc] and returns the real input file, the line number + and the characters location in the line; the real input file + can be different from [fname] because of possibility of line + directives typically generated by /lib/cpp. *) value loc_name : ref string; (** Name of the location variable used in grammars and in the predefined diff --git a/camlp4/lib/token.ml b/camlp4/lib/token.ml index 90543c10f..a6adaf6b9 100644 --- a/camlp4/lib/token.ml +++ b/camlp4/lib/token.ml @@ -26,7 +26,8 @@ type glexer 'te = tok_using : pattern -> unit; tok_removing : pattern -> unit; tok_match : pattern -> 'te -> string; - tok_text : pattern -> string } + tok_text : pattern -> string; + tok_comm : mutable option (list location) } ; type lexer = { func : lexer_func t; @@ -54,19 +55,16 @@ value loct_func (loct, ov) i = | _ -> locerr () ] ; value loct_add (loct, ov) i loc = - do { - if i >= Array.length loct.val then do { - let new_tmax = Array.length loct.val * 2 in - if new_tmax < Sys.max_array_length then do { - let new_loct = Array.create new_tmax None in - Array.blit loct.val 0 new_loct 0 (Array.length loct.val); - loct.val := new_loct; - loct.val.(i) := Some loc - } - else ov.val := True + if i >= Array.length loct.val then + let new_tmax = Array.length loct.val * 2 in + if new_tmax < Sys.max_array_length then do { + let new_loct = Array.create new_tmax None in + Array.blit loct.val 0 new_loct 0 (Array.length loct.val); + loct.val := new_loct; + loct.val.(i) := Some loc } - else loct.val.(i) := Some loc - } + else ov.val := True + else loct.val.(i) := Some loc ; value make_stream_and_location next_token_loc = diff --git a/camlp4/lib/token.mli b/camlp4/lib/token.mli index 9fc8ec7d1..a761ee2a3 100644 --- a/camlp4/lib/token.mli +++ b/camlp4/lib/token.mli @@ -47,7 +47,8 @@ type glexer 'te = tok_using : pattern -> unit; tok_removing : pattern -> unit; tok_match : pattern -> 'te -> string; - tok_text : pattern -> string } + tok_text : pattern -> string; + tok_comm : mutable option (list location) } ; (** The type for a lexer used by Camlp4 grammars. - The field [tok_func] is the main lexer function. See [lexer_func] @@ -66,7 +67,9 @@ type glexer 'te = efficency, write it as a function returning functions according to the values of the pattern, not a function with two parameters. - The field [tok_text] returns the name of some token pattern, - used in error messages. *) + used in error messages. +- The field [tok_comm] if not None asks the lexer to record the + locations of the comments. *) value lexer_text : pattern -> string; (** A simple [tok_text] function for lexers *) diff --git a/camlp4/man/camlp4.1.tpl b/camlp4/man/camlp4.1.tpl index b7f802a5b..b40b5f9f0 100644 --- a/camlp4/man/camlp4.1.tpl +++ b/camlp4/man/camlp4.1.tpl @@ -28,10 +28,19 @@ load-options other-options ] .br +.B camlp4sch +[ +load-options +] [--] [ +other-options +] +.br .B camlp4o.cma .br .B camlp4r.cma .br +.B camlp4sch.cma +.br .B mkcamlp4 .br .B ocpp @@ -56,16 +65,18 @@ other-options is a Pre-Processor-Pretty-Printer for OCaml, parsing a source file and printing some result on standard output. .LP -.B camlp4o -and +.B camlp4o, .B camlp4r +and +.B camlp4sch are versions of .B camlp4 with some files already loaded (see further). .LP -.B camlp4o.cma -and +.B camlp4o.cma, .B camlp4r.cma +and +.B camlp4sch.cma are files to be loaded in ocaml toplevel to use the camlp4 machinery .LP .B mkcamlp4 @@ -175,10 +186,10 @@ of comments. Added by pr_o.cmo: do not print double semicolons .TP .BI \-D\ ident -Added by pa_ifdef.cmo: define the ident. +Added by pa_macro.cmo: define the ident. .TP .BI \-U\ ident -Added by pa_ifdef.cmo: undefine the ident. +Added by pa_macro.cmo: undefine the ident. .SH "PROVIDED FILES" These files are installed in the directory LIBDIR/camlp4. @@ -192,12 +203,12 @@ Parsing files: pa_oop.cmo: streams and parsers (without code optimization) pa_r.cmo: revised syntax pa_rp.cmo: streams and parsers - pa_lisp.cmo: lisp syntax + pa_scheme.cmo: scheme syntax pa_extend.cmo: syntax extension for grammars pa_extfold.cmo: extension of pa_extend with FOLD0 and FOLD1 pa_extfun.cmo: syntax extension for extensible functions pa_fstream.cmo: syntax extension for functional streams - pa_ifdef.cmo: add ifdef instruction (conditional compilation) + pa_macro.cmo: add macros (ifdef, define) like in C pa_lefteval.cmo: left-to-right evaluation of parameters pa_olabl.cmo: old syntax for labels .fi @@ -209,6 +220,8 @@ Printing files: pr_op.cmo: try to rebuild streams and parsers syntax pr_r.cmo: revised syntax pr_rp.cmo: try to rebuild streams and parsers syntax + pr_scheme.cmo: scheme syntax + pr_schemep.cmo: try to rebuild streams and parsers syntax pr_extend.cmo: try to rebuild EXTEND statements pr_extfun.cmo: try to rebuild extfun statements pr_dump.cmo: syntax tree @@ -239,6 +252,14 @@ is a shortcut for: camlp4 pa_r.cmo pa_rp.cmo pr_dump.cmo .fi .LP +The command +.B camlp4sch +is a shortcut for: +.nf +.ta 1c + camlp4 pa_scheme.cmo pr_dump.cmo +.fi +.LP .LP The file .B camlp4o.cma @@ -247,6 +268,10 @@ can be loaded in the toplevel to start camlp4 with OCaml syntax. The file .B camlp4r.cma can be loaded in the toplevel to start camlp4 with revised syntax. +.LP +The file +.B camlp4sch.cma +can be loaded in the toplevel to start camlp4 with Scheme syntax. .SH "MKCAMLP4" diff --git a/camlp4/meta/Makefile b/camlp4/meta/Makefile index 4985afa07..992e87184 100644 --- a/camlp4/meta/Makefile +++ b/camlp4/meta/Makefile @@ -4,7 +4,7 @@ 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_ifdef.cmo pr_dump.cmo +OBJS=q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo pa_macro.cmo pr_dump.cmo CAMLP4RM=pa_r.cmo pa_rp.cmo pr_dump.cmo CAMLP4RMX=pa_r.cmx pa_rp.cmx pr_dump.cmx SHELL=/bin/sh @@ -42,10 +42,10 @@ compare: done install: - -$(MKDIR) $(LIBDIR)/camlp4 $(BINDIR) - cp $(OBJS) $(LIBDIR)/camlp4/. - cp pa_ifdef.cmi pa_extend.cmi $(LIBDIR)/camlp4/. - cp camlp4r$(EXE) $(BINDIR)/. - if test -f $(COPT); then cp $(COPT) $(BINDIR)/.; fi + -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" + cp $(OBJS) "$(LIBDIR)/camlp4/." + cp pa_macro.cmi pa_extend.cmi "$(LIBDIR)/camlp4/." + cp camlp4r$(EXE) "$(BINDIR)/." + if test -f $(COPT); then cp $(COPT) "$(BINDIR)/."; fi include .depend diff --git a/camlp4/meta/Makefile.Mac.depend b/camlp4/meta/Makefile.Mac.depend index e48bfb7f6..29675238e 100644 --- a/camlp4/meta/Makefile.Mac.depend +++ b/camlp4/meta/Makefile.Mac.depend @@ -2,8 +2,8 @@ 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_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 diff --git a/camlp4/meta/pa_extend.ml b/camlp4/meta/pa_extend.ml index 8234f416f..e8fed87b6 100644 --- a/camlp4/meta/pa_extend.ml +++ b/camlp4/meta/pa_extend.ml @@ -295,9 +295,12 @@ value rec quot_expr e = [ <:expr< $uid:c$ >> -> let al = List.map quot_expr al in <:expr< Qast.Node $str:c$ $mklistexp loc al$ >> - | <:expr< $_$.$uid:c$ >> -> + | <: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$ >>) @@ -322,15 +325,16 @@ value rec quot_expr e = [ Not_found -> e ] | <:expr< $lid:s$ >> -> if s = Stdpp.loc_name.val then <:expr< Qast.Loc >> else e - | <:expr< $_$.$uid:s$ >> -> <:expr< Qast.Node $str:s$ [] >> + | <: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 $rec:r$ $list:pel$ in $e$ >> -> + | <:expr< let $opt:r$ $list:pel$ in $e$ >> -> let pel = List.map (fun (p, e) -> (p, quot_expr e)) pel in - <:expr< let $rec:r$ $list:pel$ in $quot_expr e$ >> + <:expr< let $opt:r$ $list:pel$ in $quot_expr e$ >> | _ -> e ] ; @@ -722,6 +726,12 @@ value text_of_functorial_extend loc gmod gl el = 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; @@ -732,29 +742,30 @@ EXTEND | "GDELETE_RULE"; e = gdelete_rule_body; "END" -> e ] ] ; extend_body: - [ [ f = efunction; sl = OPT global; el = LIST1 [ e = entry; ";" -> e ] -> + [ [ 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; ";" -> e ] -> + [ [ 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 ";" -> + [ [ 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 ";" -> + [ [ 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; ";" -> f + [ [ UIDENT "FUNCTION"; ":"; f = qualid; semi_sep -> f | -> <:expr< Grammar.extend >> ] ] ; global: - [ [ UIDENT "GLOBAL"; ":"; sl = LIST1 name; ";" -> sl ] ] + [ [ UIDENT "GLOBAL"; ":"; sl = LIST1 name; semi_sep -> sl ] ] ; entry: [ [ n = name; ":"; pos = OPT position; ll = level_list -> @@ -785,9 +796,9 @@ EXTEND retype_rule_list_without_patterns loc rules ] ] ; rule: - [ [ psl = LIST0 psymbol SEP ";"; "->"; act = expr -> + [ [ psl = LIST0 psymbol SEP semi_sep; "->"; act = expr -> {prod = psl; action = Some act} - | psl = LIST0 psymbol SEP ";" -> + | psl = LIST0 psymbol SEP semi_sep -> {prod = psl; action = None} ] ] ; psymbol: diff --git a/camlp4/meta/pa_macro.ml b/camlp4/meta/pa_macro.ml new file mode 100644 index 000000000..406a3bd62 --- /dev/null +++ b/camlp4/meta/pa_macro.ml @@ -0,0 +1,251 @@ +(* 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 index cc8ff0932..9ad2d1f1b 100644 --- a/camlp4/meta/pa_r.ml +++ b/camlp4/meta/pa_r.ml @@ -54,6 +54,7 @@ do { 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; @@ -83,22 +84,25 @@ value mkmatchcase loc p aso w e = 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$ >> when int_of_string n > 0 -> - let n = "-" ^ n in - <:expr< $int:n$ >> - | <:expr< $flo:n$ >> when float_of_string n > 0.0 -> - let n = "-" ^ n in - <:expr< $flo:n$ >> + [ <:expr< $int:n$ >> -> <:expr< $int:neg_string n$ >> + | <:expr< $flo:n$ >> -> <:expr< $flo:neg_string n$ >> | _ -> let f = "~" ^ f in <:expr< $lid:f$ $arg$ >> ] ; value mkuminpat loc f is_int n = - if is_int then <:patt< $int:"-" ^ n$ >> else <:patt< $flo:"-" ^ n$ >> + if is_int then <:patt< $int:neg_string n$ >> + else <:patt< $flo:neg_string n$ >> ; value mklistexp loc last = @@ -140,8 +144,8 @@ value mkexprident loc i j = value mkassert loc e = match e with - [ <:expr< False >> -> <:expr< assert False >> - | _ -> <:expr< assert ($e$) >> ] + [ <:expr< False >> -> MLast.ExAsf loc + | _ -> MLast.ExAsr loc e ] ; value append_elem el e = el @ [e]; @@ -163,25 +167,26 @@ 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 () = +value warn_variant loc = if not_yet_warned_variant.val then do { not_yet_warned_variant.val := False; - Printf.eprintf "\ -*** warning: use of syntax of variants types deprecated since version 3.05\n"; - flush stderr + 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 () = +value warn_sequence loc = if not_yet_warned.val then do { not_yet_warned.val := False; - Printf.eprintf "\ -*** warning: use of syntax of sequences deprecated since version 3.01.1\n"; - flush stderr + Pcaml.warning.val loc + ("use of syntax of sequences deprecated since version 3.01.1"); } else () ; @@ -190,7 +195,8 @@ Pcaml.add_option "-no_warn_seq" (Arg.Clear not_yet_warned) 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 ipatt; + 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 -> @@ -221,8 +227,8 @@ EXTEND | "open"; i = mod_ident -> <:str_item< open $i$ >> | "type"; tdl = LIST1 type_declaration SEP "and" -> <:str_item< type $list:tdl$ >> - | "value"; r = rec_flag; l = LIST1 let_binding SEP "and" -> - <:str_item< value $rec:r$ $list:l$ >> + | "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: @@ -279,15 +285,15 @@ EXTEND ; with_constr: [ [ "type"; i = mod_ident; tpl = LIST0 type_parameter; "="; t = ctyp -> - MLast.WcTyp loc i tpl t + <:with_constr< type $i$ $list:tpl$ = $t$ >> | "module"; i = mod_ident; "="; me = module_expr -> - MLast.WcMod loc i me ] ] + <:with_constr< module $i$ = $me$ >> ] ] ; expr: [ "top" RIGHTA - [ "let"; r = rec_flag; l = LIST1 let_binding SEP "and"; "in"; + [ "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; x = SELF -> - <:expr< let $rec:r$ $list:l$ in $x$ >> + <: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 "|"; "]" -> @@ -310,8 +316,8 @@ EXTEND | "while"; e = SELF; "do"; "{"; seq = sequence; "}" -> <:expr< while $e$ do { $list:seq$ } >> ] | "where" - [ e = SELF; "where"; rf = rec_flag; lb = let_binding -> - <:expr< let $rec:rf$ $list:[lb]$ in $e$ >> ] + [ 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 @@ -391,9 +397,9 @@ EXTEND [ [ -> () ] ] ; sequence: - [ [ "let"; rf = rec_flag; l = LIST1 let_binding SEP "and"; [ "in" | ";" ]; + [ [ "let"; rf = OPT "rec"; l = LIST1 let_binding SEP "and"; [ "in" | ";" ]; el = SELF -> - [ <:expr< let $rec:rf$ $list:l$ in $mksequence loc el$ >>] + [<:expr< let $opt:o2b rf$ $list:l$ in $mksequence loc el$ >>] | e = expr; ";"; el = SELF -> [e :: el] | e = expr; ";" -> [e] | e = expr -> [e] ] ] @@ -540,8 +546,8 @@ EXTEND | ci = UIDENT -> (loc, ci, []) ] ] ; label_declaration: - [ [ i = LIDENT; ":"; mf = mutable_flag; t = ctyp -> - (loc, i, mf, t) ] ] + [ [ i = LIDENT; ":"; mf = OPT "mutable"; t = ctyp -> + (loc, i, o2b mf, t) ] ] ; ident: [ [ i = LIDENT -> i @@ -567,9 +573,9 @@ EXTEND <:sig_item< class type $list:ctd$ >> ] ] ; class_declaration: - [ [ vf = virtual_flag; i = LIDENT; ctp = class_type_parameters; + [ [ vf = OPT "virtual"; i = LIDENT; ctp = class_type_parameters; cfb = class_fun_binding -> - {MLast.ciLoc = loc; MLast.ciVir = vf; MLast.ciPrm = ctp; + {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; MLast.ciNam = i; MLast.ciExp = cfb} ] ] ; class_fun_binding: @@ -590,17 +596,17 @@ EXTEND [ "top" [ "fun"; p = ipatt; ce = class_fun_def -> <:class_expr< fun $p$ -> $ce$ >> - | "let"; rf = rec_flag; lb = LIST1 let_binding SEP "and"; "in"; + | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in"; ce = SELF -> - <:class_expr< let $rec:rf$ $list:lb$ in $ce$ >> ] + <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ] | "apply" NONA - [ ce = SELF; e = expr LEVEL "simple" -> + [ 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 = class_self_patt_opt; cf = class_structure; "end" -> + | "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$) >> @@ -609,47 +615,38 @@ EXTEND class_structure: [ [ cf = LIST0 [ cf = class_str_item; ";" -> cf ] -> cf ] ] ; - class_self_patt_opt: - [ [ "("; p = patt; ")" -> Some p - | "("; p = patt; ":"; t = ctyp; ")" -> Some <:patt< ($p$ : $t$) >> - | -> None ] ] + 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 = as_lident_opt -> - <:class_str_item< inherit $ce$ $as:pb$ >> - | "value"; (lab, mf, e) = cvalue -> - <:class_str_item< value $mut:mf$ $lab$ = $e$ >> - | "method"; "virtual"; "private"; l = label; ":"; t = ctyp -> - <:class_str_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; l = label; ":"; t = ctyp -> - <:class_str_item< method virtual $l$ : $t$ >> - | "method"; "private"; l = label; ":"; t = ctyp; "="; e = expr -> - <:class_str_item< method private $l$ : $t$ = $e$ >> - | "method"; "private"; l = label; fb = fun_binding -> - <:class_str_item< method private $l$ = $fb$ >> - | "method"; l = label; ":"; t = ctyp; "="; e = expr -> - <:class_str_item< method $l$ : $t$ = $e$ >> - | "method"; l = label; fb = fun_binding -> - <:class_str_item< method $l$ = $fb$ >> + | "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_opt: - [ [ "as"; i = LIDENT -> Some i - | -> None ] ] + as_lident: + [ [ "as"; i = LIDENT -> i ] ] + ; + polyt: + [ [ ":"; t = ctyp -> t ] ] ; - cvalue: - [ [ mf = mutable_flag; l = label; "="; e = expr -> (l, mf, e) - | mf = mutable_flag; l = label; ":"; t = ctyp; "="; e = expr -> - (l, mf, <:expr< ($e$ : $t$) >>) - | mf = mutable_flag; l = label; ":"; t = ctyp; ":>"; t2 = ctyp; "="; - e = expr -> - (l, mf, <:expr< ($e$ : $t$ :> $t2$) >>) - | mf = mutable_flag; l = label; ":>"; t = ctyp; "="; e = expr -> - (l, mf, <:expr< ($e$ :> $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 ] ] @@ -671,29 +668,25 @@ EXTEND [ [ "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 = mutable_flag; l = label; ":"; t = ctyp -> - <:class_sig_item< value $mut:mf$ $l$ : $t$ >> - | "method"; "virtual"; "private"; l = label; ":"; t = ctyp -> - <:class_sig_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; l = label; ":"; t = ctyp -> - <:class_sig_item< method virtual $l$ : $t$ >> - | "method"; "private"; l = label; ":"; t = ctyp -> - <:class_sig_item< method private $l$ : $t$ >> - | "method"; l = label; ":"; t = ctyp -> - <:class_sig_item< method $l$ : $t$ >> + | "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 = virtual_flag; n = LIDENT; ctp = class_type_parameters; ":"; + [ [ vf = OPT "virtual"; n = LIDENT; ctp = class_type_parameters; ":"; ct = class_type -> - {MLast.ciLoc = loc; MLast.ciVir = vf; MLast.ciPrm = ctp; + {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; MLast.ciNam = n; MLast.ciExp = ct} ] ] ; class_type_declaration: - [ [ vf = virtual_flag; n = LIDENT; ctp = class_type_parameters; "="; + [ [ vf = OPT "virtual"; n = LIDENT; ctp = class_type_parameters; "="; cs = class_type -> - {MLast.ciLoc = loc; MLast.ciVir = vf; MLast.ciPrm = ctp; + {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; MLast.ciNam = n; MLast.ciExp = cs} ] ] ; expr: LEVEL "apply" @@ -707,24 +700,16 @@ EXTEND [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" -> <:expr< ($e$ : $t$ :> $t2$ ) >> | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >> - | "{<"; ">}" -> <:expr< {< >} >> - | "{<"; fel = field_expr_list; ">}" -> <:expr< {< $list:fel$ >} >> ] ] + | "{<"; fel = LIST0 field_expr SEP ";"; ">}" -> + <:expr< {< $list:fel$ >} >> ] ] ; - field_expr_list: - [ [ l = label; "="; e = expr; ";"; fel = SELF -> [(l, e) :: fel] - | l = label; "="; e = expr; ";" -> [(l, e)] - | l = label; "="; e = expr -> [(l, e)] ] ] + field_expr: + [ [ l = label; "="; e = expr -> (l, e) ] ] ; ctyp: LEVEL "simple" [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >> - | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $v$ > >> - | "<"; ">" -> <:ctyp< < > >> ] ] - ; - meth_list: - [ [ f = field; ";"; (ml, v) = SELF -> ([f :: ml], v) - | f = field; ";" -> ([f], False) - | f = field -> ([f], False) - | ".." -> ([], True) ] ] + | "<"; ml = LIST0 field SEP ";"; v = OPT ".."; ">" -> + <:ctyp< < $list:ml$ $opt:o2b v$ > >> ] ] ; field: [ [ lab = LIDENT; ":"; t = ctyp -> (lab, t) ] ] @@ -760,10 +745,10 @@ EXTEND [ [ rfl = LIST0 row_field SEP "|" -> rfl ] ] ; row_field: - [ [ "`"; i = ident -> MLast.RfTag i True [] + [ [ "`"; i = ident -> <:row_field< ` $i$ >> | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" -> - MLast.RfTag i (o2b ao) l - | t = ctyp -> MLast.RfInh t ] ] + <:row_field< ` $i$ of $opt:o2b ao$ $list:l$ >> + | t = ctyp -> <:row_field< $t$ >> ] ] ; name_tag: [ [ "`"; i = ident -> i ] ] @@ -771,46 +756,35 @@ EXTEND patt: LEVEL "simple" [ [ "`"; s = ident -> <:patt< ` $s$ >> | "#"; sl = mod_ident -> <:patt< # $list:sl$ >> - | i = TILDEIDENT; ":"; p = SELF -> - <:patt< ~ $i$ : $p$ >> - | i = TILDEIDENT -> - <:patt< ~ $i$ >> - | i = QUESTIONIDENT; ":"; "("; p = patt; ")" -> - <:patt< ? $i$ : ( $p$ ) >> - | i = QUESTIONIDENT; ":"; "("; p = patt; "="; e = expr; ")" -> - <:patt< ? $i$ : ( $p$ = $e$ ) >> - | i = QUESTIONIDENT; ":"; "("; p = patt; ":"; t = ctyp; ")" -> - <:patt< ? $i$ : ( $p$ : $t$ ) >> - | i = QUESTIONIDENT; ":"; "("; p = patt; ":"; t = ctyp; "="; - e = expr; ")" -> - <:patt< ? $i$ : ( $p$ : $t$ = $e$ ) >> + | i = TILDEIDENT; ":"; p = SELF -> <:patt< ~ $i$ : $p$ >> + | i = TILDEIDENT -> <:patt< ~ $i$ >> + | i = QUESTIONIDENT; ":"; "("; p = patt_tcon; eo = OPT eq_expr; ")" -> + <:patt< ? $i$ : ($p$ $opt:eo$) >> | i = QUESTIONIDENT -> <:patt< ? $i$ >> - | "?"; "("; i = LIDENT; "="; e = expr; ")" -> - <:patt< ? ( $i$ = $e$ ) >> - | "?"; "("; i = LIDENT; ":"; t = ctyp; "="; e = expr; ")" -> - <:patt< ? ( $i$ : $t$ = $e$ ) >> ] ] + | "?"; "("; 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 = TILDEIDENT -> - <:patt< ~ $i$ >> - | i = QUESTIONIDENT; ":"; "("; p = ipatt; ")" -> - <:patt< ? $i$ : ( $p$ ) >> - | i = QUESTIONIDENT; ":"; "("; p = ipatt; "="; e = expr; ")" -> - <:patt< ? $i$ : ( $p$ = $e$ ) >> - | i = QUESTIONIDENT; ":"; "("; p = ipatt; ":"; t = ctyp; ")" -> - <:patt< ? $i$ : ( $p$ : $t$ ) >> - | i = QUESTIONIDENT; ":"; "("; p = ipatt; ":"; t = ctyp; "="; - e = expr; ")" -> - <:patt< ? $i$ : ( $p$ : $t$ = $e$ ) >> + [ [ i = TILDEIDENT; ":"; p = SELF -> <:patt< ~ $i$ : $p$ >> + | i = TILDEIDENT -> <:patt< ~ $i$ >> + | i = QUESTIONIDENT; ":"; "("; p = ipatt_tcon; eo = OPT eq_expr; ")" -> + <:patt< ? $i$ : ($p$ $opt:eo$) >> | i = QUESTIONIDENT -> <:patt< ? $i$ >> - | "?"; "("; i = LIDENT; "="; e = expr; ")" -> - <:patt< ? ( $i$ = $e$ ) >> - | "?"; "("; i = LIDENT; ":"; t = ctyp; "="; e = expr; ")" -> - <:patt< ? ( $i$ : $t$ = $e$ ) >> ] ] + | "?"; "("; 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 @@ -822,22 +796,10 @@ EXTEND expr: LEVEL "simple" [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ] ; - rec_flag: - [ [ "rec" -> True - | -> False ] ] - ; direction_flag: [ [ "to" -> True | "downto" -> False ] ] ; - mutable_flag: - [ [ "mutable" -> True - | -> False ] ] - ; - virtual_flag: - [ [ "virtual" -> True - | -> False ] ] - ; (* Compatibility old syntax of variant types definitions *) ctyp: LEVEL "simple" [ [ "[|"; warning_variant; rfl = row_field_list; "|]" -> @@ -851,7 +813,7 @@ EXTEND <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ] ; warning_variant: - [ [ -> warn_variant () ] ] + [ [ -> warn_variant loc ] ] ; (* Compatibility old syntax of sequences *) expr: LEVEL "top" @@ -866,7 +828,7 @@ EXTEND <:expr< while $e$ do { $list:seq$ } >> ] ] ; warning_sequence: - [ [ -> warn_sequence () ] ] + [ [ -> warn_sequence loc ] ] ; END; @@ -896,7 +858,7 @@ EXTEND ; use_file: [ [ "#"; n = LIDENT; dp = OPT expr; ";" -> - ([ <:str_item< # $n$ $opt:dp$ >>], True) + ([<:str_item< # $n$ $opt:dp$ >>], True) | si = str_item; ";"; (sil, stopped) = SELF -> ([si :: sil], stopped) | EOI -> ([], False) ] ] ; diff --git a/camlp4/meta/pa_rp.ml b/camlp4/meta/pa_rp.ml index 793d0d35a..cb3566cd3 100644 --- a/camlp4/meta/pa_rp.ml +++ b/camlp4/meta/pa_rp.ml @@ -90,9 +90,9 @@ value rec subst v e = | <:expr< $int:_$ >> -> e | <:expr< $chr:_$ >> -> e | <:expr< $str:_$ >> -> e - | <:expr< $_$ . $_$ >> -> e - | <:expr< let $rec:rf$ $list:pel$ in $e$ >> -> - <:expr< let $rec:rf$ $list:List.map (subst_pe v) pel$ in $subst v 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 ] diff --git a/camlp4/meta/pr_dump.ml b/camlp4/meta/pr_dump.ml index e52f75b69..2558c5fa9 100644 --- a/camlp4/meta/pr_dump.ml +++ b/camlp4/meta/pr_dump.ml @@ -21,9 +21,10 @@ value open_out_file () = 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 Pcaml.input_file.val; + output_value oc (if fname = "-" then "" else fname); output_value oc pt; flush oc; match Pcaml.output_file.val with @@ -35,9 +36,10 @@ value interf ast = 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 Pcaml.input_file.val; + output_value oc (if fname = "-" then "" else fname); output_value oc pt; flush oc; match Pcaml.output_file.val with diff --git a/camlp4/meta/q_MLast.ml b/camlp4/meta/q_MLast.ml index a61ee49e2..0da0005f8 100644 --- a/camlp4/meta/q_MLast.ml +++ b/camlp4/meta/q_MLast.ml @@ -114,6 +114,9 @@ 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"; @@ -149,13 +152,19 @@ value mkmatchcase _ p aso w e = 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 = "-" ^ n in + 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 = "-" ^ n in + let n = neg_string n in Qast.Node "ExFlo" [Qast.Loc; Qast.Str n] | _ -> match f with @@ -167,6 +176,11 @@ value mkumin _ f arg = ; 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] @@ -223,31 +237,43 @@ value mkassert _ 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 () = +value warn_variant _ = if not_yet_warned_variant.val then do { not_yet_warned_variant.val := False; - Printf.eprintf "\ -*** warning: use of syntax of variants types deprecated since version 3.05\n"; - flush stderr + Pcaml.warning.val (0, 1) + (Printf.sprintf + "use of syntax of variants types deprecated since version 3.05"); } else () ; -value not_yet_warned = ref True; -value warn_sequence () = - if not_yet_warned.val then do { - not_yet_warned.val := False; - Printf.eprintf "\ -*** warning: use of syntax of sequences deprecated since version 3.01.1\n"; - flush stderr +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 ipatt; + 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 -> @@ -284,8 +310,8 @@ EXTEND | "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 = rec_flag; l = SLIST1 let_binding SEP "and" -> - Qast.Node "StVal" [Qast.Loc; r; l] + | "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: @@ -353,9 +379,9 @@ EXTEND ; expr: [ "top" RIGHTA - [ "let"; r = rec_flag; l = SLIST1 let_binding SEP "and"; "in"; + [ "let"; r = SOPT "rec"; l = SLIST1 let_binding SEP "and"; "in"; x = SELF -> - Qast.Node "ExLet" [Qast.Loc; r; l; x] + 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 "|"; "]" -> @@ -382,8 +408,8 @@ EXTEND | "while"; e = SELF; "do"; "{"; seq = sequence; "}" -> Qast.Node "ExWhi" [Qast.Loc; e; seq] ] | "where" - [ e = SELF; "where"; rf = rec_flag; lb = let_binding -> - Qast.Node "ExLet" [Qast.Loc; rf; Qast.List [lb]; e] ] + [ 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] ] @@ -613,10 +639,10 @@ EXTEND [ [ -> () ] ] ; sequence: - [ [ "let"; rf = rec_flag; l = SLIST1 let_binding SEP "and"; + [ [ "let"; rf = SOPT "rec"; l = SLIST1 let_binding SEP "and"; [ "in" | ";" ]; el = SELF -> Qast.List - [Qast.Node "ExLet" [Qast.Loc; rf; l; mksequence Qast.Loc el]] + [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] ] ] @@ -779,8 +805,8 @@ EXTEND | ci = a_UIDENT -> Qast.Tuple [Qast.Loc; ci; Qast.List []] ] ] ; label_declaration: - [ [ i = a_LIDENT; ":"; mf = mutable_flag; t = ctyp -> - Qast.Tuple [Qast.Loc; i; mf; t] ] ] + [ [ i = a_LIDENT; ":"; mf = SOPT "mutable"; t = ctyp -> + Qast.Tuple [Qast.Loc; i; o2b mf; t] ] ] ; ident: [ [ i = a_LIDENT -> i @@ -806,11 +832,11 @@ EXTEND Qast.Node "SgClt" [Qast.Loc; ctd] ] ] ; class_declaration: - [ [ vf = virtual_flag; i = a_LIDENT; ctp = class_type_parameters; + [ [ vf = SOPT "virtual"; i = a_LIDENT; ctp = class_type_parameters; cfb = class_fun_binding -> Qast.Record - [("ciLoc", Qast.Loc); ("ciVir", vf); ("ciPrm", ctp); ("ciNam", i); - ("ciExp", cfb)] ] ] + [("ciLoc", Qast.Loc); ("ciVir", o2b vf); ("ciPrm", ctp); + ("ciNam", i); ("ciExp", cfb)] ] ] ; class_fun_binding: [ [ "="; ce = class_expr -> ce @@ -831,17 +857,17 @@ EXTEND [ "top" [ "fun"; p = ipatt; ce = class_fun_def -> Qast.Node "CeFun" [Qast.Loc; p; ce] - | "let"; rf = rec_flag; lb = SLIST1 let_binding SEP "and"; "in"; + | "let"; rf = SOPT "rec"; lb = SLIST1 let_binding SEP "and"; "in"; ce = SELF -> - Qast.Node "CeLet" [Qast.Loc; rf; lb; ce] ] + Qast.Node "CeLet" [Qast.Loc; o2b rf; lb; ce] ] | "apply" NONA - [ ce = SELF; e = expr LEVEL "simple" -> + [ 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 = class_self_patt_opt; cf = class_structure; "end" -> + | "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] @@ -850,59 +876,40 @@ EXTEND class_structure: [ [ cf = SLIST0 [ cf = class_str_item; ";" -> cf ] -> cf ] ] ; - class_self_patt_opt: - [ [ "("; p = patt; ")" -> Qast.Option (Some p) + class_self_patt: + [ [ "("; p = patt; ")" -> p | "("; p = patt; ":"; t = ctyp; ")" -> - Qast.Option (Some (Qast.Node "PaTyc" [Qast.Loc; p; t])) - | -> Qast.Option None ] ] + 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 = as_lident_opt -> + | "inherit"; ce = class_expr; pb = SOPT as_lident -> Qast.Node "CrInh" [Qast.Loc; ce; pb] - | "value"; labmfe = cvalue -> - let (lab, mf, e) = - match labmfe with - [ Qast.Tuple [xx1; xx2; xx3] -> (xx1, xx2, xx3) - | _ -> match () with [] ] - in - Qast.Node "CrVal" [Qast.Loc; lab; mf; e] - | "method"; "virtual"; "private"; l = label; ":"; t = ctyp -> - Qast.Node "CrVir" [Qast.Loc; l; Qast.Bool True; t] - | "method"; "virtual"; l = label; ":"; t = ctyp -> - Qast.Node "CrVir" [Qast.Loc; l; Qast.Bool False; t] - | "method"; "private"; l = label; ":"; t = ctyp; "="; e = expr -> - Qast.Node "CrMth" - [Qast.Loc; l; Qast.Bool True; e; Qast.Option (Some t)] - | "method"; "private"; l = label; fb = fun_binding -> - Qast.Node "CrMth" - [Qast.Loc; l; Qast.Bool True; fb; Qast.Option None] - | "method"; l = label; ":"; t = ctyp; "="; e = expr -> - Qast.Node "CrMth" - [Qast.Loc; l; Qast.Bool False; e; Qast.Option (Some t)] - | "method"; l = label; fb = fun_binding -> - Qast.Node "CrMth" - [Qast.Loc; l; Qast.Bool False; fb; Qast.Option None] + | "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_opt: - [ [ "as"; i = a_LIDENT -> Qast.Option (Some i) - | -> Qast.Option None ] ] + as_lident: + [ [ "as"; i = a_LIDENT -> i ] ] ; - cvalue: - [ [ mf = mutable_flag; l = label; "="; e = expr -> Qast.Tuple [l; mf; e] - | mf = mutable_flag; l = label; ":"; t = ctyp; "="; e = expr -> - Qast.Tuple [l; mf; Qast.Node "ExTyc" [Qast.Loc; e; t]] - | mf = mutable_flag; l = label; ":"; t = ctyp; ":>"; t2 = ctyp; "="; - e = expr -> - Qast.Tuple - [l; mf; Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option (Some t); t2]] - | mf = mutable_flag; l = label; ":>"; t = ctyp; "="; e = expr -> - Qast.Tuple - [l; mf; Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option None; t]] ] ] + 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 ] ] @@ -924,32 +931,28 @@ EXTEND [ [ "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 = mutable_flag; l = label; ":"; t = ctyp -> - Qast.Node "CgVal" [Qast.Loc; l; mf; t] - | "method"; "virtual"; "private"; l = label; ":"; t = ctyp -> - Qast.Node "CgVir" [Qast.Loc; l; Qast.Bool True; t] - | "method"; "virtual"; l = label; ":"; t = ctyp -> - Qast.Node "CgVir" [Qast.Loc; l; Qast.Bool False; t] - | "method"; "private"; l = label; ":"; t = ctyp -> - Qast.Node "CgMth" [Qast.Loc; l; Qast.Bool True; t] - | "method"; l = label; ":"; t = ctyp -> - Qast.Node "CgMth" [Qast.Loc; l; Qast.Bool False; t] + | "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 = virtual_flag; n = a_LIDENT; ctp = class_type_parameters; ":"; + [ [ vf = SOPT "virtual"; n = a_LIDENT; ctp = class_type_parameters; ":"; ct = class_type -> Qast.Record - [("ciLoc", Qast.Loc); ("ciVir", vf); ("ciPrm", ctp); ("ciNam", n); - ("ciExp", ct)] ] ] + [("ciLoc", Qast.Loc); ("ciVir", o2b vf); ("ciPrm", ctp); + ("ciNam", n); ("ciExp", ct)] ] ] ; class_type_declaration: - [ [ vf = virtual_flag; n = a_LIDENT; ctp = class_type_parameters; "="; + [ [ vf = SOPT "virtual"; n = a_LIDENT; ctp = class_type_parameters; "="; cs = class_type -> Qast.Record - [("ciLoc", Qast.Loc); ("ciVir", vf); ("ciPrm", ctp); ("ciNam", n); - ("ciExp", cs)] ] ] + [("ciLoc", Qast.Loc); ("ciVir", o2b vf); ("ciPrm", ctp); + ("ciNam", n); ("ciExp", cs)] ] ] ; expr: LEVEL "apply" [ LEFTA @@ -963,39 +966,16 @@ EXTEND 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] - | "{<"; ">}" -> Qast.Node "ExOvr" [Qast.Loc; Qast.List []] - | "{<"; fel = field_expr_list; ">}" -> + | "{<"; fel = SLIST0 field_expr SEP ";"; ">}" -> Qast.Node "ExOvr" [Qast.Loc; fel] ] ] ; - field_expr_list: - [ [ l = label; "="; e = expr; ";"; fel = SELF -> - Qast.Cons (Qast.Tuple [l; e]) fel - | l = label; "="; e = expr; ";" -> Qast.List [Qast.Tuple [l; e]] - | l = label; "="; e = expr -> Qast.List [Qast.Tuple [l; e]] ] ] + field_expr: + [ [ l = label; "="; e = expr -> Qast.Tuple [l; e] ] ] ; ctyp: LEVEL "simple" [ [ "#"; id = class_longident -> Qast.Node "TyCls" [Qast.Loc; id] - | "<"; mlv = meth_list; ">" -> - let (ml, v) = - match mlv with - [ Qast.Tuple [xx1; xx2] -> (xx1, xx2) - | _ -> match () with [] ] - in - Qast.Node "TyObj" [Qast.Loc; ml; v] - | "<"; ">" -> - Qast.Node "TyObj" [Qast.Loc; Qast.List []; Qast.Bool False] ] ] - ; - meth_list: - [ [ f = field; ";"; mlv = SELF -> - let (ml, v) = - match mlv with - [ Qast.Tuple [xx1; xx2] -> (xx1, xx2) - | _ -> match () with [] ] - in - Qast.Tuple [Qast.Cons f ml; v] - | f = field; ";" -> Qast.Tuple [Qast.List [f]; Qast.Bool False] - | f = field -> Qast.Tuple [Qast.List [f]; Qast.Bool False] - | ".." -> Qast.Tuple [Qast.List []; Qast.Bool True] ] ] + | "<"; ml = SLIST0 field SEP ";"; v = SOPT ".."; ">" -> + Qast.Node "TyObj" [Qast.Loc; ml; o2b v] ] ] ; field: [ [ lab = a_LIDENT; ":"; t = ctyp -> Qast.Tuple [lab; t] ] ] @@ -1047,94 +1027,63 @@ EXTEND 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; p] - | i = a_TILDEIDENT -> - Qast.Node "PaLab" [Qast.Loc; i; Qast.Node "PaLid" [Qast.Loc; i]] - | i = a_QUESTIONIDENT; ":"; "("; p = SELF; ")" -> - Qast.Node "PaOlb" [Qast.Loc; i; p; Qast.Option None] - | i = a_QUESTIONIDENT; ":"; "("; p = SELF; "="; e = expr; ")" -> - Qast.Node "PaOlb" [Qast.Loc; i; p; Qast.Option (Some e)] - | i = a_QUESTIONIDENT; ":"; "("; p = SELF; ":"; t = ctyp; ")" -> - Qast.Node "PaOlb" - [Qast.Loc; i; Qast.Node "PaTyc" [Qast.Loc; p; t]; - Qast.Option None] - | i = a_QUESTIONIDENT; ":"; "("; p = SELF; ":"; t = ctyp; "="; e = expr; + | i = a_TILDEIDENT; ":"; 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.Node "PaTyc" [Qast.Loc; p; t]; - Qast.Option (Some e)] + [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; i; Qast.Node "PaLid" [Qast.Loc; i]; Qast.Option None] - | "?"; "("; i = a_LIDENT; "="; e = expr; ")" -> - Qast.Node "PaOlb" - [Qast.Loc; i; Qast.Node "PaLid" [Qast.Loc; i]; - Qast.Option (Some e)] - | "?"; "("; i = a_LIDENT; ":"; t = ctyp; "="; e = expr; ")" -> - Qast.Node "PaOlb" - [Qast.Loc; i; - Qast.Node "PaTyc" [Qast.Loc; Qast.Node "PaLid" [Qast.Loc; i]; t]; - Qast.Option (Some e)] ] ] + [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; p] - | i = a_TILDEIDENT -> - Qast.Node "PaLab" [Qast.Loc; i; Qast.Node "PaLid" [Qast.Loc; i]] - | i = a_QUESTIONIDENT; ":"; "("; p = SELF; ")" -> - Qast.Node "PaOlb" [Qast.Loc; i; p; Qast.Option None] - | i = a_QUESTIONIDENT; ":"; "("; p = SELF; "="; e = expr; ")" -> - Qast.Node "PaOlb" [Qast.Loc; i; p; Qast.Option (Some e)] - | i = a_QUESTIONIDENT; ":"; "("; p = SELF; ":"; t = ctyp; ")" -> - Qast.Node "PaOlb" - [Qast.Loc; i; Qast.Node "PaTyc" [Qast.Loc; p; t]; - Qast.Option None] - | i = a_QUESTIONIDENT; ":"; "("; p = SELF; ":"; t = ctyp; "="; e = expr; + [ [ i = a_TILDEIDENT; ":"; 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.Node "PaTyc" [Qast.Loc; p; t]; - Qast.Option (Some e)] + [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; i; Qast.Node "PaLid" [Qast.Loc; i]; Qast.Option None] - | "?"; "("; i = a_LIDENT; "="; e = expr; ")" -> - Qast.Node "PaOlb" - [Qast.Loc; i; Qast.Node "PaLid" [Qast.Loc; i]; - Qast.Option (Some e)] - | "?"; "("; i = a_LIDENT; ":"; t = ctyp; "="; e = expr; ")" -> - Qast.Node "PaOlb" - [Qast.Loc; i; - Qast.Node "PaTyc" [Qast.Loc; Qast.Node "PaLid" [Qast.Loc; i]; t]; - Qast.Option (Some e)] ] ] + [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; e] - | i = a_TILDEIDENT -> - Qast.Node "ExLab" [Qast.Loc; i; Qast.Node "ExLid" [Qast.Loc; i]] + [ i = a_TILDEIDENT; ":"; 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; e] + Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option (Some e)] | i = a_QUESTIONIDENT -> - Qast.Node "ExOlb" [Qast.Loc; i; Qast.Node "ExLid" [Qast.Loc; i]] ] ] + Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option None] ] ] ; expr: LEVEL "simple" [ [ "`"; s = ident -> Qast.Node "ExVrn" [Qast.Loc; s] ] ] ; - rec_flag: - [ [ "rec" -> Qast.Bool True - | -> Qast.Bool False ] ] - ; direction_flag: [ [ "to" -> Qast.Bool True | "downto" -> Qast.Bool False ] ] ; - mutable_flag: - [ [ "mutable" -> Qast.Bool True - | -> Qast.Bool False ] ] - ; - virtual_flag: - [ [ "virtual" -> Qast.Bool True - | -> Qast.Bool False ] ] - ; (* Compatibility old syntax of variant types definitions *) ctyp: LEVEL "simple" [ [ "[|"; warning_variant; rfl = row_field_list; "|]" -> @@ -1152,7 +1101,7 @@ EXTEND [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))] ] ] ; warning_variant: - [ [ -> warn_variant () ] ] + [ [ -> warn_variant Qast.Loc ] ] ; (* Compatibility old syntax of sequences *) expr: LEVEL "top" @@ -1167,7 +1116,7 @@ EXTEND Qast.Node "ExWhi" [Qast.Loc; e; seq] ] ] ; warning_sequence: - [ [ -> warn_sequence () ] ] + [ [ -> warn_sequence Qast.Loc ] ] ; (* Antiquotations for local entries *) sequence: @@ -1185,39 +1134,69 @@ EXTEND mod_ident: [ [ a = ANTIQUOT -> antiquot "" loc a ] ] ; - class_self_patt_opt: - [ [ a = ANTIQUOT "opt" -> antiquot "opt" loc a - | a = ANTIQUOT -> antiquot "" loc a ] ] - ; - as_lident_opt: - [ [ a = ANTIQUOT "as" -> antiquot "as" loc a ] ] - ; - meth_list: - [ [ a = a_list -> Qast.Tuple [a; Qast.Bool False] - | a = a_list; b = ANTIQUOT -> Qast.Tuple [a; antiquot "" loc b] ] ] - ; clty_longident: [ [ a = a_list -> a ] ] ; class_longident: [ [ a = a_list -> a ] ] ; - rec_flag: - [ [ a = ANTIQUOT "rec" -> antiquot "rec" loc a ] ] - ; direction_flag: [ [ a = ANTIQUOT "to" -> antiquot "to" loc a ] ] ; - mutable_flag: - [ [ a = ANTIQUOT "mut" -> antiquot "mut" 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] ] ] ; - virtual_flag: - [ [ a = ANTIQUOT "virt" -> antiquot "virt" loc a ] ] + 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] ] ] ; - (* compatibility hack with version 3.04 *) - class_expr: LEVEL "simple" - [ [ "object"; cspo = ANTIQUOT; cf = class_structure; "end" -> - Qast.Node "CeStr" [Qast.Loc; antiquot "" loc cspo; cf] ] ] + 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; @@ -1463,3 +1442,23 @@ do { 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) +}; diff --git a/camlp4/ocaml_src/camlp4/Makefile b/camlp4/ocaml_src/camlp4/Makefile index 7ea191f41..7d770e626 100644 --- a/camlp4/ocaml_src/camlp4/Makefile +++ b/camlp4/ocaml_src/camlp4/Makefile @@ -5,7 +5,7 @@ include ../../config/Makefile SHELL=/bin/sh INCLUDES=-I ../odyl -I ../../boot -I $(OTOP)/utils -I $(OTOP)/parsing -I $(OTOP)/otherlibs/dynlink -OCAMLCFLAGS= $(INCLUDES) -warn-error A +OCAMLCFLAGS= $(INCLUDES) -warn-error A $(INCLUDES) LINKFLAGS=$(INCLUDES) INTERFACES=-I $(OLIBDIR) Arg Array ArrayLabels Buffer Callback CamlinternalOO Char Complex Digest Filename Format Gc Genlex Hashtbl Int32 Int64 Lazy Lexing List ListLabels Map Marshal MoreLabels Nativeint Obj Oo Parsing Pervasives Printexc Printf Queue Random Scanf Set Sort Stack StdLabels Stream String StringLabels Sys Weak -I ../../boot Extfold Extfun Fstream Gramext Grammar Plexer Stdpp Token -I $(OTOP)/utils Config Warnings -I $(OTOP)/parsing Asttypes Location Longident Parsetree -I . Ast2pt MLast Pcaml Quotation Spretty CAMLP4_INTF=$(OTOP)/utils/config.cmi $(OTOP)/utils/warnings.cmi $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmi $(OTOP)/parsing/longident.cmi $(OTOP)/parsing/parsetree.cmi ast2pt.cmi mLast.cmi pcaml.cmi spretty.cmi quotation.cmi @@ -36,14 +36,9 @@ camlp4.cma: $(CAMLP4_OBJS) camlp4.cmxa: $(CAMLP4_XOBJS) $(OCAMLOPT) $(LINKFLAGS) $(CAMLP4_XOBJS) -a -o camlp4.cmxa -crc.cmo: $(CAMLP4_INTF) - @OTOP=$(OTOP) EXE=$(EXE) ../tools/extract_crc.sh $(INTERFACES) > crc.ml - echo "let _ = Dynlink.add_available_units crc_unit_list" >> crc.ml - $(OCAMLC) $(OCAMLCFLAGS) -c crc.ml - clean:: rm -f *.cm* *.pp[io] *.o *.bak .*.bak *.out *.opt - rm -f $(CAMLP4) crc.ml + rm -f $(CAMLP4) depend: cp .depend .depend.bak @@ -62,11 +57,15 @@ compare: done install: - -$(MKDIR) $(BINDIR) - -$(MKDIR) $(LIBDIR)/camlp4 - cp $(CAMLP4) $(BINDIR)/. - cp mLast.mli quotation.mli ast2pt.mli pcaml.mli spretty.mli $(LIBDIR)/camlp4/. - cp mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi $(LIBDIR)/camlp4/. + -$(MKDIR) "$(BINDIR)" + -$(MKDIR) "$(LIBDIR)/camlp4" + cp $(CAMLP4) "$(BINDIR)/." + cp mLast.mli quotation.mli ast2pt.mli pcaml.mli spretty.mli "$(LIBDIR)/camlp4/." + cp mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi "$(LIBDIR)/camlp4/." cp camlp4.cma $(LIBDIR)/camlp4/. + if [ -f camlp4.cmxa ]; \ + then cp camlp4.cmxa camlp4.a $(LIBDIR)/camlp4/.; \ + else : ; \ + fi include .depend diff --git a/camlp4/ocaml_src/camlp4/Makefile.Mac b/camlp4/ocaml_src/camlp4/Makefile.Mac index 438a744ca..b7561d8cb 100644 --- a/camlp4/ocaml_src/camlp4/Makefile.Mac +++ b/camlp4/ocaml_src/camlp4/Makefile.Mac @@ -45,13 +45,8 @@ all Ä {CAMLP4} camlp4.cma Ä {CAMLP4_OBJS} {OCAMLC} {LINKFLAGS} {CAMLP4_OBJS} -a -o camlp4.cma -crc.cmo Ä {CAMLP4_INTF} - ::tools:extract_crc.mpw {INTERFACES} > crc.ml - echo "let _ = Dynlink.add_available_units crc_unit_list" >> crc.ml - {OCAMLC} {OCAMLCFLAGS} -c crc.ml - clean ÄÄ - delete -i {CAMLP4} crc.ml extract_crc + delete -i {CAMLP4} {dependrule} diff --git a/camlp4/ocaml_src/camlp4/argl.ml b/camlp4/ocaml_src/camlp4/argl.ml index 4e73fcdc0..0f6ac98ce 100644 --- a/camlp4/ocaml_src/camlp4/argl.ml +++ b/camlp4/ocaml_src/camlp4/argl.ml @@ -3,9 +3,21 @@ open Printf;; -let action_arg s sl = +let rec action_arg s sl = function Arg.Unit f -> if s = "" then begin f (); Some sl end else None + | Arg.Bool f -> + if s = "" then + match sl with + s :: sl -> + begin try f (bool_of_string s); Some sl with + Invalid_argument "bool_of_string" -> None + end + | [] -> None + else + begin try f (bool_of_string s); Some sl with + Invalid_argument "bool_of_string" -> None + end | Arg.Set r -> if s = "" then begin r := true; Some sl end else None | Arg.Clear r -> if s = "" then begin r := false; Some sl end else None | Arg.Rest f -> List.iter f (s :: sl); Some [] @@ -57,11 +69,21 @@ let action_arg s sl = s :: sl -> r := float_of_string s; Some sl | [] -> None else begin r := float_of_string s; Some sl end + | Arg.Tuple specs -> + let rec action_args s sl = + function + [] -> Some sl + | spec :: spec_list -> + match action_arg s sl spec with + None -> action_args "" [] spec_list + | Some (s :: sl) -> action_args s sl spec_list + | Some sl -> action_args "" sl spec_list + in + action_args s sl specs | Arg.Symbol (syms, f) -> - begin match if s = "" then sl else s :: sl with + match if s = "" then sl else s :: sl with s :: sl when List.mem s syms -> f s; Some sl - | _ -> None end - | _ -> assert false + | _ -> None ;; let common_start s1 s2 = @@ -104,14 +126,14 @@ let loc_fmt = let print_location loc = if !(Pcaml.input_file) <> "-" then - let (line, bp, ep) = Stdpp.line_of_loc !(Pcaml.input_file) loc in + let (fname, line, bp, ep) = Stdpp.line_of_loc !(Pcaml.input_file) loc in eprintf loc_fmt !(Pcaml.input_file) line bp ep else eprintf "At location %d-%d\n" (fst loc) (snd loc) ;; let print_warning loc s = print_location loc; eprintf "%s\n" s;; -let process pa pr getdir = +let rec parse_file pa getdir useast = let name = !(Pcaml.input_file) in Pcaml.warning := print_warning; let ic = if name = "-" then stdin else open_in_bin name in @@ -122,30 +144,44 @@ let process pa pr getdir = let rec loop () = let (pl, stopped_at_directive) = pa cs in if stopped_at_directive then - begin - begin match getdir (List.rev pl) with + let pl = + let rpl = List.rev pl in + match getdir rpl with Some x -> begin match x with loc, "load", Some (MLast.ExStr (_, s)) -> - Odyl_main.loadfile s + Odyl_main.loadfile s; pl | loc, "directory", Some (MLast.ExStr (_, s)) -> - Odyl_main.directory s + Odyl_main.directory s; pl + | loc, "use", Some (MLast.ExStr (_, s)) -> + List.rev_append rpl + [useast loc s (use_file pa getdir useast s), loc] | loc, _, _ -> Stdpp.raise_with_loc loc (Stream.Error "bad directive") end - | None -> () - end; - pl @ loop () - end + | None -> pl + in + pl @ loop () else pl in loop () with x -> clear (); raise x in - clear (); pr phr + clear (); phr +and use_file pa getdir useast s = + let clear = + let v_input_file = !(Pcaml.input_file) in + fun () -> Pcaml.input_file := v_input_file + in + Pcaml.input_file := s; + try let r = parse_file pa getdir useast in clear (); r with + e -> clear (); raise e ;; +let process pa pr getdir useast = pr (parse_file pa getdir useast);; + + let gind = function (MLast.SgDir (loc, n, dp), _) :: _ -> Some (loc, n, dp) @@ -158,11 +194,14 @@ let gimd = | _ -> None ;; +let usesig loc fname ast = MLast.SgUse (loc, fname, ast);; +let usestr loc fname ast = MLast.StUse (loc, fname, ast);; + let process_intf () = - process !(Pcaml.parse_interf) !(Pcaml.print_interf) gind + process !(Pcaml.parse_interf) !(Pcaml.print_interf) gind usesig ;; let process_impl () = - process !(Pcaml.parse_implem) !(Pcaml.print_implem) gimd + process !(Pcaml.parse_implem) !(Pcaml.print_implem) gimd usestr ;; type file_kind = @@ -232,6 +271,24 @@ let print_usage_list l = l ;; +let make_symlist l = + match l with + [] -> "<none>" + | h :: t -> List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t ^ "}" +;; + +let print_usage_list l = + List.iter + (fun (key, spec, doc) -> + match spec with + Arg.Symbol (symbs, _) -> + let s = make_symlist symbs in + let synt = key ^ " " ^ s in + eprintf " %s %s\n" synt (align_doc synt doc) + | _ -> eprintf " %s %s\n" key (align_doc key doc)) + l +;; + let usage ini_sl ext_sl = eprintf "\ Usage: camlp4 [load-options] [--] [other-options] diff --git a/camlp4/ocaml_src/camlp4/ast2pt.ml b/camlp4/ocaml_src/camlp4/ast2pt.ml index fe0e08873..5f9211765 100644 --- a/camlp4/ocaml_src/camlp4/ast2pt.ml +++ b/camlp4/ocaml_src/camlp4/ast2pt.ml @@ -37,9 +37,11 @@ let string_of_string_token loc s = Failure _ as exn -> raise_with_loc loc exn ;; +let glob_fname = ref "";; + let mkloc (bp, ep) = let loc_at n = - {Lexing.pos_fname = ""; Lexing.pos_lnum = 1; Lexing.pos_bol = 0; + {Lexing.pos_fname = !glob_fname; Lexing.pos_lnum = 1; Lexing.pos_bol = 0; Lexing.pos_cnum = n} in {Location.loc_start = loc_at bp; Location.loc_end = loc_at ep; @@ -237,6 +239,33 @@ let option f = | None -> None ;; +let expr_of_lab loc lab = + function + Some e -> e + | None -> ExLid (loc, lab) +;; + +let patt_of_lab loc lab = + function + Some p -> p + | None -> PaLid (loc, lab) +;; + +let paolab loc lab peoo = + let lab = + match lab, peoo with + "", Some ((PaLid (_, i) | PaTyc (_, PaLid (_, i), _)), _) -> i + | "", _ -> error loc "bad ast" + | _ -> lab + in + let (p, eo) = + match peoo with + Some peo -> peo + | None -> PaLid (loc, lab), None + in + lab, p, eo +;; + let rec same_type_expr ct ce = match ct, ce with TyLid (_, s1), ExLid (_, s2) -> s1 = s2 @@ -396,7 +425,7 @@ let rec patt = | PaFlo (loc, s) -> mkpat loc (Ppat_constant (Const_float s)) | PaLab (loc, _, _) -> error loc "labeled pattern not allowed here" | PaLid (loc, s) -> mkpat loc (Ppat_var s) - | PaOlb (loc, _, _, _) -> error loc "labeled pattern not allowed here" + | PaOlb (loc, _, _) -> error loc "labeled pattern not allowed here" | PaOrp (loc, p1, p2) -> mkpat loc (Ppat_or (patt p1, patt p2)) | PaRng (loc, p1, p2) -> begin match p1, p2 with @@ -456,6 +485,12 @@ let class_info class_expr ci = pci_variance = variance} ;; +let apply_with_var v x f = + let vx = !v in + try v := x; let r = f () in v := vx; r with + e -> v := vx; raise e +;; + let rec expr = function ExAcc (loc, x, ExLid (_, "val")) -> @@ -550,9 +585,12 @@ let rec expr = let e3 = ExSeq (loc, el) in let df = if df then Upto else Downto in mkexp loc (Pexp_for (i, expr e1, expr e2, df, expr e3)) - | ExFun (loc, [PaLab (_, lab, p), w, e]) -> - mkexp loc (Pexp_function (lab, None, [patt p, when_expr e w])) - | ExFun (loc, [PaOlb (_, lab, p, eo), w, e]) -> + | ExFun (loc, [PaLab (_, lab, po), w, e]) -> + mkexp loc + (Pexp_function + (lab, None, [patt (patt_of_lab loc lab po), when_expr e w])) + | ExFun (loc, [PaOlb (_, lab, peoo), w, e]) -> + let (lab, p, eo) = paolab loc lab peoo in mkexp loc (Pexp_function (("?" ^ lab), option expr eo, [patt p, when_expr e w])) | ExFun (loc, pel) -> @@ -572,12 +610,14 @@ let rec expr = | ExOlb (loc, _, _) -> error loc "labeled expression not allowed here" | ExOvr (loc, iel) -> mkexp loc (Pexp_override (List.map mkideexp iel)) | ExRec (loc, lel, eo) -> - let eo = - match eo with - Some e -> Some (expr e) - | None -> None - in - mkexp loc (Pexp_record (List.map mklabexp lel, eo)) + if lel = [] then error loc "empty record" + else + let eo = + match eo with + Some e -> Some (expr e) + | None -> None + in + mkexp loc (Pexp_record (List.map mklabexp lel, eo)) | ExSeq (loc, el) -> let rec loop = function @@ -608,8 +648,8 @@ let rec expr = let e2 = ExSeq (loc, el) in mkexp loc (Pexp_while (expr e1, expr e2)) and label_expr = function - ExLab (loc, lab, e) -> lab, expr e - | ExOlb (loc, lab, e) -> "?" ^ lab, expr e + ExLab (loc, lab, eo) -> lab, expr (expr_of_lab loc lab eo) + | ExOlb (loc, lab, eo) -> "?" ^ lab, expr (expr_of_lab loc lab eo) | e -> "", expr e and mkpe (p, e) = patt p, expr e and mkpwe (p, w, e) = patt p, when_expr e w @@ -664,6 +704,9 @@ and sig_item s l = | SgOpn (loc, id) -> mksig loc (Psig_open (long_id_of_string_list loc id)) :: l | SgTyp (loc, tdl) -> mksig loc (Psig_type (List.map mktype_decl tdl)) :: l + | SgUse (loc, fn, sl) -> + apply_with_var glob_fname fn + (fun () -> List.fold_right (fun (si, _) -> sig_item si) sl l) | SgVal (loc, n, t) -> mksig loc (Psig_value (n, mkvalue_desc t [])) :: l and module_expr = function @@ -702,6 +745,9 @@ and str_item s l = | StOpn (loc, id) -> mkstr loc (Pstr_open (long_id_of_string_list loc id)) :: l | StTyp (loc, tdl) -> mkstr loc (Pstr_type (List.map mktype_decl tdl)) :: l + | StUse (loc, fn, sl) -> + apply_with_var glob_fname fn + (fun () -> List.fold_right (fun (si, _) -> str_item si) sl l) | StVal (loc, rf, pel) -> mkstr loc (Pstr_value (mkrf rf, List.map mkpe pel)) :: l and class_type = @@ -742,15 +788,12 @@ and class_expr = mkpcl loc (Pcl_apply (class_expr ce, el)) | CeCon (loc, id, tl) -> mkpcl loc (Pcl_constr (long_id_of_string_list loc id, List.map ctyp tl)) - | CeFun (loc, PaLab (_, lab, p), ce) -> - mkpcl loc (Pcl_fun (lab, None, patt p, class_expr ce)) - | CeFun (loc, PaOlb (_, lab, p, eo), ce) -> - let eo = - match eo with - Some e -> Some (expr e) - | None -> None - in - mkpcl loc (Pcl_fun (("?" ^ lab), eo, patt p, class_expr ce)) + | CeFun (loc, PaLab (_, lab, po), ce) -> + mkpcl loc + (Pcl_fun (lab, None, patt (patt_of_lab loc lab po), class_expr ce)) + | CeFun (loc, PaOlb (_, lab, peoo), ce) -> + let (lab, p, eo) = paolab loc lab peoo in + mkpcl loc (Pcl_fun (("?" ^ lab), option expr eo, patt p, class_expr ce)) | CeFun (loc, p, ce) -> mkpcl loc (Pcl_fun ("", None, patt p, class_expr ce)) | CeLet (loc, rf, pel, ce) -> diff --git a/camlp4/ocaml_src/camlp4/mLast.mli b/camlp4/ocaml_src/camlp4/mLast.mli index e357b9757..7ab3d467c 100644 --- a/camlp4/ocaml_src/camlp4/mLast.mli +++ b/camlp4/ocaml_src/camlp4/mLast.mli @@ -5,14 +5,19 @@ (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) (* This file has been generated by program: do not edit! *) -(* Module [MLast]: abstract syntax tree *) +(* Module [MLast]: abstract syntax tree + + This is undocumented because the AST is not supposed to be used + directly; the good usage is to use the quotations representing + these values in concrete syntax (see the Camlp4 documentation). + See also the file q_MLast.ml in Camlp4 sources. *) type loc = int * int;; @@ -58,9 +63,9 @@ type patt = | PaChr of loc * string | PaInt of loc * string | PaFlo of loc * string - | PaLab of loc * string * patt + | PaLab of loc * string * patt option | PaLid of loc * string - | PaOlb of loc * string * patt * expr option + | PaOlb of loc * string * (patt * expr option) option | PaOrp of loc * patt * patt | PaRng of loc * patt * patt | PaRec of loc * (patt * patt) list @@ -86,14 +91,14 @@ and expr = | ExFun of loc * (patt * expr option * expr) list | ExIfe of loc * expr * expr * expr | ExInt of loc * string - | ExLab of loc * string * expr + | ExLab of loc * string * expr option | ExLaz of loc * expr | ExLet of loc * bool * (patt * expr) list * expr | ExLid of loc * string | ExLmd of loc * string * module_expr * expr | ExMat of loc * expr * (patt * expr option * expr) list | ExNew of loc * string list - | ExOlb of loc * string * expr + | ExOlb of loc * string * expr option | ExOvr of loc * (string * expr) list | ExRec of loc * (patt * expr) list * expr option | ExSeq of loc * expr list @@ -127,6 +132,7 @@ and sig_item = | SgMty of loc * string * module_type | SgOpn of loc * string list | SgTyp of loc * type_decl list + | SgUse of loc * string * (sig_item * loc) list | SgVal of loc * string * ctyp and with_constr = WcTyp of loc * string list * (string * (bool * bool)) list * ctyp @@ -151,6 +157,7 @@ and str_item = | StMty of loc * string * module_type | StOpn of loc * string list | StTyp of loc * type_decl list + | StUse of loc * string * (str_item * loc) list | StVal of loc * bool * (patt * expr) list and type_decl = (loc * string) * (string * (bool * bool)) list * ctyp * (ctyp * ctyp) list diff --git a/camlp4/ocaml_src/camlp4/pcaml.ml b/camlp4/ocaml_src/camlp4/pcaml.ml index bd0d6ca20..7258fa070 100644 --- a/camlp4/ocaml_src/camlp4/pcaml.ml +++ b/camlp4/ocaml_src/camlp4/pcaml.ml @@ -14,12 +14,14 @@ let version = Sys.ocaml_version;; +let syntax_name = ref "";; + let gram = Grammar.gcreate {Token.tok_func = (fun _ -> failwith "no loaded parsing module"); Token.tok_using = (fun _ -> ()); Token.tok_removing = (fun _ -> ()); - Token.tok_match = (fun _ -> raise (Match_failure ("pcaml.ml", 21, 23))); - Token.tok_text = fun _ -> ""} + Token.tok_match = (fun _ -> raise (Match_failure ("pcaml.ml", 23, 23))); + Token.tok_text = (fun _ -> ""); Token.tok_comm = None} ;; let interf = Grammar.Entry.create gram "interf";; @@ -34,6 +36,7 @@ let expr = Grammar.Entry.create gram "expr";; let patt = Grammar.Entry.create gram "patt";; let ctyp = Grammar.Entry.create gram "type";; let let_binding = Grammar.Entry.create gram "let_binding";; +let type_declaration = Grammar.Entry.create gram "type_declaration";; let class_sig_item = Grammar.Entry.create gram "class_sig_item";; let class_str_item = Grammar.Entry.create gram "class_str_item";; @@ -54,6 +57,18 @@ let sync = ref skip_to_eol;; let input_file = ref "";; let output_file = ref None;; +let warning_default_function (bp, ep) txt = + Printf.eprintf "<W> loc %d %d: %s\n" bp ep txt; flush stderr +;; + +let warning = ref warning_default_function;; + +let apply_with_var v x f = + let vx = !v in + try v := x; let r = f () in v := vx; r with + e -> v := vx; raise e +;; + List.iter (fun (n, f) -> Quotation.add n f) ["id", Quotation.ExStr (fun _ s -> "$0:" ^ s ^ "$"); "string", Quotation.ExStr (fun _ s -> "\"" ^ String.escaped s ^ "\"")];; @@ -69,13 +84,19 @@ type err_ctx = exception Qerror of string * err_ctx * exn;; let expand_quotation loc expander shift name str = - try expander str with - Stdpp.Exc_located ((p1, p2), exc) -> - let exc1 = Qerror (name, Expanding, exc) in - raise (Stdpp.Exc_located ((shift + p1, shift + p2), exc1)) - | exc -> - let exc1 = Qerror (name, Expanding, exc) in - raise (Stdpp.Exc_located (loc, exc1)) + let new_warning = + let warn = !warning in + fun (bp, ep) txt -> warn (shift + bp, shift + ep) txt + in + apply_with_var warning new_warning + (fun () -> + try expander str with + Stdpp.Exc_located ((p1, p2), exc) -> + let exc1 = Qerror (name, Expanding, exc) in + raise (Stdpp.Exc_located ((shift + p1, shift + p2), exc1)) + | exc -> + let exc1 = Qerror (name, Expanding, exc) in + raise (Stdpp.Exc_located (loc, exc1))) ;; let parse_quotation_result entry loc shift name str = @@ -167,6 +188,8 @@ let handle_patt_locate loc x = handle_locate loc patt_eoi patt_anti x;; let expr_reloc = Reloc.expr;; let patt_reloc = Reloc.patt;; +let rename_id = ref (fun x -> x);; + let find_line (bp, ep) str = let rec find i line col = if i == String.length str then line, 0, col @@ -247,16 +270,23 @@ let print_format str = Format.open_box 2; loop 0 0; Format.close_box () ;; +let print_file_failed file line char = + Format.print_string ", file \""; + Format.print_string file; + Format.print_string "\", line "; + Format.print_int line; + Format.print_string ", char "; + Format.print_int char +;; + let print_exn = function Out_of_memory -> Format.print_string "Out of memory\n" + | Assert_failure (file, line, char) -> + Format.print_string "Assertion failed"; print_file_failed file line char | Match_failure (file, line, char) -> - Format.print_string "Pattern matching failed, file "; - Format.print_string file; - Format.print_string ", line "; - Format.print_int line; - Format.print_string ", char "; - Format.print_int char + Format.print_string "Pattern matching failed"; + print_file_failed file line char | Stream.Error str -> print_format ("Parse error: " ^ str) | Stream.Failure -> Format.print_string "Parse failure" | Token.Error str -> @@ -278,7 +308,7 @@ let print_exn = let arg = Obj.field (Obj.repr x) i in if not (Obj.is_block arg) then Format.print_int (Obj.magic arg : int) - else if Obj.tag arg = 252 then + else if Obj.tag arg = Obj.tag (Obj.repr "a") then begin Format.print_char '\"'; Format.print_string (Obj.magic arg : string); @@ -302,12 +332,6 @@ let report_error exn = | e -> print_exn exn ;; -let warning_default_function (bp, ep) txt = - Printf.eprintf "<W> loc %d %d: %s\n" bp ep txt; flush stderr -;; - -let warning = ref warning_default_function;; - let no_constructors_arity = Ast2pt.no_constructors_arity;; (*value no_assert = ref False;*) @@ -336,46 +360,55 @@ and kont = pretty Stream.t ;; let pr_str_item = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 349, 30))); + {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 385, 30))); pr_levels = []} ;; let pr_sig_item = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 350, 30))); + {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 386, 30))); + pr_levels = []} +;; +let pr_module_type = + {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 387, 33))); + pr_levels = []} +;; +let pr_module_expr = + {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 388, 33))); pr_levels = []} ;; let pr_expr = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 351, 26))); + {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 389, 26))); pr_levels = []} ;; let pr_patt = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 352, 26))); + {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 390, 26))); pr_levels = []} ;; let pr_ctyp = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 353, 26))); + {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 391, 26))); + pr_levels = []} +;; +let pr_class_sig_item = + {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 392, 36))); pr_levels = []} ;; let pr_class_str_item = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 354, 36))); + {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 393, 36))); pr_levels = []} ;; -let pr_expr_fun_args = ref Extfun.empty;; - -let not_impl name 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 - HVbox - (Stream.lsing - (fun _ -> S (NO, ("<pr_fun: not impl: " ^ name ^ "; " ^ desc ^ ">")))) +let pr_class_type = + {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 394, 32))); + pr_levels = []} +;; +let pr_class_expr = + {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 395, 32))); + pr_levels = []} ;; +let pr_expr_fun_args = ref Extfun.empty;; let pr_fun name pr lab = let rec loop app = function - [] -> (fun x dg k -> not_impl name x) + [] -> (fun x dg k -> failwith ("unable to print " ^ name)) | lev :: levl -> if app || lev.pr_label = lab then let next = loop true levl in @@ -388,10 +421,15 @@ let pr_fun name pr lab = pr_str_item.pr_fun <- pr_fun "str_item" pr_str_item;; pr_sig_item.pr_fun <- pr_fun "sig_item" pr_sig_item;; +pr_module_type.pr_fun <- pr_fun "module_type" pr_module_type;; +pr_module_expr.pr_fun <- pr_fun "module_expr" pr_module_expr;; pr_expr.pr_fun <- pr_fun "expr" pr_expr;; pr_patt.pr_fun <- pr_fun "patt" pr_patt;; pr_ctyp.pr_fun <- pr_fun "ctyp" pr_ctyp;; +pr_class_sig_item.pr_fun <- pr_fun "class_sig_item" pr_class_sig_item;; pr_class_str_item.pr_fun <- pr_fun "class_str_item" pr_class_str_item;; +pr_class_type.pr_fun <- pr_fun "class_type" pr_class_type;; +pr_class_expr.pr_fun <- pr_fun "class_expr" pr_class_expr;; let rec find_pr_level lab = function @@ -411,4 +449,16 @@ let top_printer pr x = Format.print_string " >>" ;; +let buff = Buffer.create 73;; +let buffer_char = Buffer.add_char buff;; +let buffer_string = Buffer.add_string buff;; +let buffer_newline () = Buffer.add_char buff '\n';; + +let string_of pr x = + Buffer.clear buff; + Spretty.print_pretty buffer_char buffer_string buffer_newline "" "" 78 + (fun _ _ -> "", 0, 0, 0) 0 (pr.pr_fun "top" x "" Stream.sempty); + Buffer.contents buff +;; + let inter_phrases = ref None;; diff --git a/camlp4/ocaml_src/camlp4/pcaml.mli b/camlp4/ocaml_src/camlp4/pcaml.mli index 05415844e..8f8eacaf2 100644 --- a/camlp4/ocaml_src/camlp4/pcaml.mli +++ b/camlp4/ocaml_src/camlp4/pcaml.mli @@ -17,14 +17,29 @@ Hold variables to be set by language syntax extensions. Some of them are provided for quotations management. *) +val syntax_name : string ref;; + (** {6 Parsers} *) val parse_interf : (char Stream.t -> (MLast.sig_item * MLast.loc) list * bool) ref;; val parse_implem : (char Stream.t -> (MLast.str_item * MLast.loc) list * bool) ref;; + (** Called when parsing an interface (mli file) or an implementation + (ml file) to build the syntax tree; the returned list contains the + phrases (signature items or structure items) and their locations; + the boolean tells that the parser has encountered a directive; in + this case, since the directive may change the syntax, the parsing + stops, the directive is evaluated, and this function is called + again. + These functions are references, because they can be changed to + use another technology than the Camlp4 extended grammars. By + default, they use the grammars entries [implem] and [interf] + defined below. *) val gram : Grammar.g;; + (** Grammar variable of the OCaml language *) + val interf : ((MLast.sig_item * MLast.loc) list * bool) Grammar.Entry.e;; val implem : ((MLast.str_item * MLast.loc) list * bool) Grammar.Entry.e;; val top_phrase : MLast.str_item option Grammar.Entry.e;; @@ -37,12 +52,12 @@ val expr : MLast.expr Grammar.Entry.e;; val patt : MLast.patt Grammar.Entry.e;; val ctyp : MLast.ctyp Grammar.Entry.e;; val let_binding : (MLast.patt * MLast.expr) Grammar.Entry.e;; +val type_declaration : MLast.type_decl Grammar.Entry.e;; val class_sig_item : MLast.class_sig_item Grammar.Entry.e;; val class_str_item : MLast.class_str_item Grammar.Entry.e;; val class_expr : MLast.class_expr Grammar.Entry.e;; val class_type : MLast.class_type Grammar.Entry.e;; - (** Some grammar and entries of the language, set by [pa_o.cmo] and - [pa_r.cmo]. *) + (** Some entries of the language, set by [pa_o.cmo] and [pa_r.cmo]. *) val input_file : string ref;; (** The file currently being parsed. *) @@ -76,6 +91,10 @@ val handle_patt_locate : MLast.loc -> int * string -> MLast.patt;; val expr_reloc : (MLast.loc -> MLast.loc) -> int -> MLast.expr -> MLast.expr;; val patt_reloc : (MLast.loc -> MLast.loc) -> int -> MLast.patt -> MLast.patt;; +(** To possibly rename identifiers; parsers may call this function + when generating their identifiers; default = identity *) +val rename_id : (string -> string) ref;; + (** Allow user to catch exceptions in quotations *) type err_ctx = Finding @@ -107,18 +126,25 @@ and 'a next = 'a -> string -> kont -> pretty and kont = pretty Stream.t ;; -val pr_str_item : MLast.str_item printer_t;; val pr_sig_item : MLast.sig_item printer_t;; +val pr_str_item : MLast.str_item printer_t;; +val pr_module_type : MLast.module_type printer_t;; +val pr_module_expr : MLast.module_expr printer_t;; val pr_expr : MLast.expr printer_t;; val pr_patt : MLast.patt printer_t;; val pr_ctyp : MLast.ctyp printer_t;; +val pr_class_sig_item : MLast.class_sig_item printer_t;; val pr_class_str_item : MLast.class_str_item printer_t;; +val pr_class_type : MLast.class_type printer_t;; +val pr_class_expr : MLast.class_expr printer_t;; + val pr_expr_fun_args : (MLast.expr, (MLast.patt list * MLast.expr)) Extfun.t ref;; val find_pr_level : string -> 'a pr_level list -> 'a pr_level;; val top_printer : 'a printer_t -> 'a -> unit;; +val string_of : 'a printer_t -> 'a -> string;; val inter_phrases : string option ref;; diff --git a/camlp4/ocaml_src/camlp4/reloc.ml b/camlp4/ocaml_src/camlp4/reloc.ml index bb85b5bc2..fc1f23fae 100644 --- a/camlp4/ocaml_src/camlp4/reloc.ml +++ b/camlp4/ocaml_src/camlp4/reloc.ml @@ -76,10 +76,13 @@ let rec patt floc sh = | PaChr (loc, x1) -> PaChr (floc loc, x1) | PaInt (loc, x1) -> PaInt (floc loc, x1) | PaFlo (loc, x1) -> PaFlo (floc loc, x1) - | PaLab (loc, x1, x2) -> PaLab (floc loc, x1, self x2) + | PaLab (loc, x1, x2) -> PaLab (floc loc, x1, option_map self x2) | PaLid (loc, x1) -> PaLid (floc loc, x1) - | PaOlb (loc, x1, x2, x3) -> - PaOlb (floc loc, x1, self x2, option_map (expr floc sh) x3) + | PaOlb (loc, x1, x2) -> + PaOlb + (floc loc, x1, + option_map (fun (x1, x2) -> self x1, option_map (expr floc sh) x2) + x2) | PaOrp (loc, x1, x2) -> PaOrp (floc loc, self x1, self x2) | PaRng (loc, x1, x2) -> PaRng (floc loc, self x1, self x2) | PaRec (loc, x1) -> @@ -120,7 +123,7 @@ and expr floc sh = x1) | ExIfe (loc, x1, x2, x3) -> ExIfe (floc loc, self x1, self x2, self x3) | ExInt (loc, x1) -> ExInt (floc loc, x1) - | ExLab (loc, x1, x2) -> ExLab (floc loc, x1, self x2) + | ExLab (loc, x1, x2) -> ExLab (floc loc, x1, option_map self x2) | ExLaz (loc, x1) -> ExLaz (floc loc, self x1) | ExLet (loc, x1, x2, x3) -> ExLet @@ -137,7 +140,7 @@ and expr floc sh = patt floc sh x1, option_map self x2, self x3) x2) | ExNew (loc, x1) -> ExNew (floc loc, x1) - | ExOlb (loc, x1, x2) -> ExOlb (floc loc, x1, self x2) + | ExOlb (loc, x1, x2) -> ExOlb (floc loc, x1, option_map self x2) | ExOvr (loc, x1) -> ExOvr (floc loc, List.map (fun (x1, x2) -> x1, self x2) x1) | ExRec (loc, x1, x2) -> @@ -200,6 +203,7 @@ and sig_item floc sh = List.map (fun (x1, x2) -> ctyp floc sh x1, ctyp floc sh x2) x4) x1) + | SgUse (loc, x1, x2) -> SgUse (loc, x1, x2) | SgVal (loc, x1, x2) -> SgVal (floc loc, x1, ctyp floc sh x2) in self @@ -248,6 +252,7 @@ and str_item floc sh = List.map (fun (x1, x2) -> ctyp floc sh x1, ctyp floc sh x2) x4) x1) + | StUse (loc, x1, x2) -> StUse (loc, x1, x2) | StVal (loc, x1, x2) -> StVal (floc loc, x1, diff --git a/camlp4/ocaml_src/lib/Makefile b/camlp4/ocaml_src/lib/Makefile index 524831704..d587e7446 100644 --- a/camlp4/ocaml_src/lib/Makefile +++ b/camlp4/ocaml_src/lib/Makefile @@ -36,17 +36,17 @@ compare: done install: - -$(MKDIR) $(LIBDIR)/camlp4 - cp $(TARGET) *.mli $(LIBDIR)/camlp4/. - cp *.cmi $(LIBDIR)/camlp4/. - if test -f $(TARGET:.cma=.cmxa); then $(MAKE) installopt LIBDIR=$(LIBDIR); fi + -$(MKDIR) "$(LIBDIR)/camlp4" + cp $(TARGET) *.mli "$(LIBDIR)/camlp4/." + cp *.cmi "$(LIBDIR)/camlp4/." + if test -f $(TARGET:.cma=.cmxa); then $(MAKE) installopt LIBDIR="$(LIBDIR)"; fi installopt: - cp $(TARGET:.cma=.cmxa) *.cmx $(LIBDIR)/camlp4/. + cp $(TARGET:.cma=.cmxa) *.cmx "$(LIBDIR)/camlp4/." if test -f $(TARGET:.cma=.lib); then \ - cp $(TARGET:.cma=.lib) $(LIBDIR)/camlp4/.; \ + cp $(TARGET:.cma=.lib) "$(LIBDIR)/camlp4/."; \ else \ - tar cf - $(TARGET:.cma=.a) | (cd $(LIBDIR)/camlp4/.; tar xf -); \ + tar cf - $(TARGET:.cma=.a) | (cd "$(LIBDIR)/camlp4/."; tar xf -); \ fi include .depend diff --git a/camlp4/ocaml_src/lib/grammar.ml b/camlp4/ocaml_src/lib/grammar.ml index 66e7d3580..196a6b954 100644 --- a/camlp4/ocaml_src/lib/grammar.ml +++ b/camlp4/ocaml_src/lib/grammar.ml @@ -120,7 +120,71 @@ let print_entry ppf e = Dlevels elev -> print_levels ppf elev | Dparser _ -> fprintf ppf "<parser>" end; - fprintf ppf " ]@]@." + fprintf ppf " ]@]" +;; + +let iter_entry f e = + let treated = ref [] in + let rec do_entry e = + if List.memq e !treated then () + else + begin + treated := e :: !treated; + f e; + match e.edesc with + Dlevels ll -> List.iter do_level ll + | Dparser _ -> () + end + and do_level lev = do_tree lev.lsuffix; do_tree lev.lprefix + and do_tree = + function + Node n -> do_node n + | LocAct (_, _) | DeadEnd -> () + and do_node n = do_symbol n.node; do_tree n.son; do_tree n.brother + and do_symbol = + function + Smeta (_, sl, _) -> List.iter do_symbol sl + | Snterm e | Snterml (e, _) -> do_entry e + | Slist0 s | Slist1 s | Sopt s -> do_symbol s + | Slist0sep (s1, s2) | Slist1sep (s1, s2) -> do_symbol s1; do_symbol s2 + | Stree t -> do_tree t + | Sself | Snext | Stoken _ -> () + in + do_entry e +;; + +let fold_entry f e init = + let treated = ref [] in + let rec do_entry accu e = + if List.memq e !treated then accu + else + begin + treated := e :: !treated; + let accu = f e accu in + match e.edesc with + Dlevels ll -> List.fold_left do_level accu ll + | Dparser _ -> accu + end + and do_level accu lev = + let accu = do_tree accu lev.lsuffix in do_tree accu lev.lprefix + and do_tree accu = + function + Node n -> do_node accu n + | LocAct (_, _) | DeadEnd -> accu + and do_node accu n = + let accu = do_symbol accu n.node in + let accu = do_tree accu n.son in do_tree accu n.brother + and do_symbol accu = + function + Smeta (_, sl, _) -> List.fold_left do_symbol accu sl + | Snterm e | Snterml (e, _) -> do_entry accu e + | Slist0 s | Slist1 s | Sopt s -> do_symbol accu s + | Slist0sep (s1, s2) | Slist1sep (s1, s2) -> + let accu = do_symbol accu s1 in do_symbol accu s2 + | Stree t -> do_tree accu t + | Sself | Snext | Stoken _ -> accu + in + do_entry init e ;; type g = Token.t Gramext.grammar;; @@ -774,7 +838,7 @@ let glexer_of_lexer lexer = {Token.tok_func = lexer.Token.func; Token.tok_using = lexer.Token.using; Token.tok_removing = lexer.Token.removing; Token.tok_match = tematch lexer.Token.tparse; - Token.tok_text = lexer.Token.text} + Token.tok_text = lexer.Token.text; Token.tok_comm = None} ;; let create lexer = gcreate (glexer_of_lexer lexer);; @@ -933,12 +997,12 @@ module Entry = edesc = Dparser (Obj.magic p)} ;; external obj : 'a e -> te Gramext.g_entry = "%identity";; - let print e = print_entry std_formatter (obj e);; + let print e = printf "%a@." print_entry (obj e);; let find e s = find_entry (obj e) s;; end ;; -let gen_tokens g con = +let tokens g con = let list = ref [] in Hashtbl.iter (fun (p_con, p_prm) c -> if p_con = con then list := (p_prm, !c) :: !list) @@ -946,7 +1010,7 @@ let gen_tokens g con = !list ;; -let tokens g = gen_tokens (grammar_obj g);; +let glexer g = g.glexer;; let warning_verbose = Gramext.warning_verbose;; @@ -960,6 +1024,7 @@ module type S = type parsable;; val parsable : char Stream.t -> parsable;; val tokens : string -> (string * int) list;; + val glexer : te Token.glexer;; module Entry : sig type 'a e;; @@ -998,7 +1063,8 @@ module GGMake (R : ReinitType) (L : GLexerType) = type parsable = char Stream.t * (te Stream.t * Token.location_function);; let gram = gcreate L.lexer;; let parsable cs = cs, L.lexer.Token.tok_func cs;; - let tokens = gen_tokens gram;; + let tokens = tokens gram;; + let glexer = glexer gram;; module Entry = struct type 'a e = te g_entry;; @@ -1020,7 +1086,7 @@ module GGMake (R : ReinitType) (L : GLexerType) = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); edesc = Dparser (Obj.magic p)} ;; - let print e = print_entry std_formatter (obj e);; + let print e = printf "%a@." print_entry (obj e);; end ;; module Unsafe = diff --git a/camlp4/ocaml_src/lib/grammar.mli b/camlp4/ocaml_src/lib/grammar.mli index c29e8f8a7..d38b449f9 100644 --- a/camlp4/ocaml_src/lib/grammar.mli +++ b/camlp4/ocaml_src/lib/grammar.mli @@ -35,6 +35,8 @@ val tokens : g -> string -> (string * int) list;; list. - The call [Grammar.token g "IDENT"] returns the list of all usages of the pattern "IDENT" in the [EXTEND] statements. *) +val glexer : g -> Token.t Token.glexer;; + (** Return the lexer used by the grammar *) module Entry : sig @@ -100,6 +102,7 @@ module type S = type parsable;; val parsable : char Stream.t -> parsable;; val tokens : string -> (string * int) list;; + val glexer : te Token.glexer;; module Entry : sig type 'a e;; @@ -156,6 +159,20 @@ val strict_parsing : bool ref;; val print_entry : Format.formatter -> 'te Gramext.g_entry -> unit;; (** General printer for all kinds of entries (obj entries) *) +val iter_entry : + ('te Gramext.g_entry -> unit) -> 'te Gramext.g_entry -> unit;; + (** [Grammar.iter_entry f e] applies [f] to the entry [e] and + transitively all entries called by [e]. The order in which + the entries are passed to [f] is the order they appear in + each entry. Each entry is passed only once. *) + +val fold_entry : + ('te Gramext.g_entry -> 'a -> 'a) -> 'te Gramext.g_entry -> 'a -> 'a;; + (** [Grammar.fold_entry f e init] computes [(f eN .. (f e2 (f e1 init)))], + where [e1 .. eN] are [e] and transitively all entries called by [e]. + The order in which the entries are passed to [f] is the order they + appear in each entry. Each entry is passed only once. *) + (**/**) (*** deprecated since version 3.05; use rather the functor GMake *) diff --git a/camlp4/ocaml_src/lib/plexer.ml b/camlp4/ocaml_src/lib/plexer.ml index 718e17b4f..20471597e 100644 --- a/camlp4/ocaml_src/lib/plexer.ml +++ b/camlp4/ocaml_src/lib/plexer.ml @@ -36,6 +36,16 @@ let get_buff len = String.sub !buff 0 len;; (* The lexer *) +let stream_peek_nth n strm = + let rec loop n = + function + [] -> None + | [x] -> if n == 1 then Some x else None + | _ :: l -> loop (n - 1) l + in + loop n (Stream.npeek n strm) +;; + let rec ident len (strm__ : _ Stream.t) = match Stream.peek strm__ with Some @@ -132,21 +142,359 @@ and end_exponent_part_under len (strm__ : _ Stream.t) = let error_on_unknown_keywords = ref false;; let err loc msg = raise_with_loc loc (Token.Error msg);; -let next_token_fun dfa find_kwd = +(* +value next_token_fun dfa find_kwd = + let keyword_or_error loc s = + try (("", find_kwd s), loc) with + [ Not_found -> + if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s) + else (("", s), loc) ] + in + let rec next_token = + parser bp + [ [: `' ' | '\010' | '\013' | '\t' | '\026' | '\012'; s :] -> + next_token s + | [: `'('; s :] -> left_paren bp s + | [: `'#'; s :] -> do { spaces_tabs s; linenum bp s } + | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] -> + let id = get_buff (ident (store 0 c) s) in + let loc = (bp, Stream.count s) in + (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc) + | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] -> + let id = get_buff (ident (store 0 c) s) in + let loc = (bp, Stream.count s) in + (try ("", find_kwd id) with [ Not_found -> ("LIDENT", id) ], loc) + | [: `('1'..'9' as c); s :] -> + let tok = number (store 0 c) s in + let loc = (bp, Stream.count s) in + (tok, loc) + | [: `'0'; s :] -> + let tok = base_number (store 0 '0') s in + let loc = (bp, Stream.count s) in + (tok, loc) + | [: `'''; s :] -> + match Stream.npeek 3 s with + [ [_; '''; _] | ['\\'; _; _] | ['\x0D'; '\x0A'; '''] -> + let tok = ("CHAR", get_buff (char bp 0 s)) in + let loc = (bp, Stream.count s) in + (tok, loc) + | _ -> keyword_or_error (bp, Stream.count s) "'" ] + | [: `'"'; s :] -> + let tok = ("STRING", get_buff (string bp 0 s)) in + let loc = (bp, Stream.count s) in + (tok, loc) + | [: `'$'; s :] -> + let tok = dollar bp 0 s in + let loc = (bp, Stream.count s) in + (tok, loc) + | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c); + s :] -> + let id = get_buff (ident2 (store 0 c) s) in + keyword_or_error (bp, Stream.count s) id + | [: `('~' as c); + a = + parser + [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep -> + (("TILDEIDENT", get_buff len), (bp, ep)) + | [: s :] -> + let id = get_buff (ident2 (store 0 c) s) in + keyword_or_error (bp, Stream.count s) id ] :] -> + a + | [: `('?' as c); + a = + parser + [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep -> + (("QUESTIONIDENT", get_buff len), (bp, ep)) + | [: s :] -> + let id = get_buff (ident2 (store 0 c) s) in + keyword_or_error (bp, Stream.count s) id ] :] -> + a + | [: `'<'; s :] -> less bp s + | [: `(':' as c1); + len = + parser + [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2 + | [: :] -> store 0 c1 ] :] ep -> + let id = get_buff len in + keyword_or_error (bp, ep) id + | [: `('>' | '|' as c1); + len = + parser + [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2 + | [: a = ident2 (store 0 c1) :] -> a ] :] ep -> + let id = get_buff len in + keyword_or_error (bp, ep) id + | [: `('[' | '{' as c1); s :] -> + let len = + match Stream.npeek 2 s with + [ ['<'; '<' | ':'] -> store 0 c1 + | _ -> + match s with parser + [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2 + | [: :] -> store 0 c1 ] ] + in + let ep = Stream.count s in + let id = get_buff len in + keyword_or_error (bp, ep) id + | [: `'.'; + id = + parser + [ [: `'.' :] -> ".." + | [: :] -> if ssd && after_space then " ." else "." ] :] ep -> + keyword_or_error (bp, ep) id + | [: `';'; + id = + parser + [ [: `';' :] -> ";;" + | [: :] -> ";" ] :] ep -> + keyword_or_error (bp, ep) id + | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), (bp, ep)) + | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c) + | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ] + and less bp strm = + if no_quotations.val then + match strm with parser + [ [: len = ident2 (store 0 '<') :] ep -> + let id = get_buff len in + keyword_or_error (bp, ep) id ] + else + match strm with parser + [ [: `'<'; len = quotation bp 0 :] ep -> + (("QUOTATION", ":" ^ get_buff len), (bp, ep)) + | [: `':'; i = parser [: len = ident 0 :] -> get_buff len; + `'<' ? "character '<' expected"; len = quotation bp 0 :] ep -> + (("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep)) + | [: len = ident2 (store 0 '<') :] ep -> + let id = get_buff len in + keyword_or_error (bp, ep) id ] + and string bp len = + parser + [ [: `'"' :] -> len + | [: `'\\'; `c; s :] -> string bp (store (store len '\\') c) s + | [: `c; s :] -> string bp (store len c) s + | [: :] ep -> err (bp, ep) "string not terminated" ] + and char bp len = + parser + [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else len + | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s + | [: `c; s :] -> char bp (store len c) s + | [: :] ep -> err (bp, ep) "char not terminated" ] + and dollar bp len = + parser + [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) + | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s + | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s + | [: `':'; s :] -> + let k = get_buff len in + ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) + | [: `'\\'; `c; s :] -> + ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) + | [: s :] -> + if dfa then + match s with parser + [ [: `c :] -> + ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) + | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] + else ("", get_buff (ident2 (store 0 '$') s)) ] + and maybe_locate bp len = + parser + [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) + | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s + | [: `':'; s :] -> + ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s) + | [: `'\\'; `c; s :] -> + ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) + | [: `c; s :] -> + ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) + | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] + and antiquot bp len = + parser + [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) + | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] -> + antiquot bp (store len c) s + | [: `':'; s :] -> + let k = get_buff len in + ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) + | [: `'\\'; `c; s :] -> + ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) + | [: `c; s :] -> + ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) + | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] + and locate_or_antiquot_rest bp len = + parser + [ [: `'$' :] -> get_buff len + | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s + | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s + | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] + and quotation bp len = + parser + [ [: `'>'; s :] -> maybe_end_quotation bp len s + | [: `'<'; s :] -> + quotation bp (maybe_nested_quotation bp (store len '<') s) s + | [: `'\\'; + len = + parser + [ [: `('>' | '<' | '\\' as c) :] -> store len c + | [: :] -> store len '\\' ]; + s :] -> + quotation bp len s + | [: `c; s :] -> quotation bp (store len c) s + | [: :] ep -> err (bp, ep) "quotation not terminated" ] + and maybe_nested_quotation bp len = + parser + [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" + | [: `':'; len = ident (store len ':'); + a = + parser + [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" + | [: :] -> len ] :] -> + a + | [: :] -> len ] + and maybe_end_quotation bp len = + parser + [ [: `'>' :] -> len + | [: a = quotation bp (store len '>') :] -> a ] + and left_paren bp = + parser + [ [: `'*'; _ = comment bp; a = next_token True :] -> a + | [: :] ep -> keyword_or_error (bp, ep) "(" ] + and comment bp = + parser + [ [: `'('; s :] -> left_paren_in_comment bp s + | [: `'*'; s :] -> star_in_comment bp s + | [: `'"'; _ = string bp 0; s :] -> comment bp s + | [: `'''; s :] -> quote_in_comment bp s + | [: `c; s :] -> comment bp s + | [: :] ep -> err (bp, ep) "comment not terminated" ] + and quote_in_comment bp = + parser + [ [: `'''; s :] -> comment bp s + | [: `'\013'; s :] -> quote_cr_in_comment bp s + | [: `'\\'; s :] -> quote_antislash_in_comment bp s + | [: `'('; s :] -> quote_left_paren_in_comment bp s + | [: `'*'; s :] -> quote_star_in_comment bp s + | [: `'"'; s :] -> quote_doublequote_in_comment bp s + | [: `_; s :] -> quote_any_in_comment bp s + | [: s :] -> comment bp s ] + and quote_any_in_comment bp = + parser + [ [: `'''; s :] -> comment bp s + | [: s :] -> comment bp s ] + and quote_cr_in_comment bp = + parser + [ [: `'\010'; s :] -> quote_any_in_comment bp s + | [: s :] -> quote_any_in_comment bp s ] + and quote_left_paren_in_comment bp = + parser + [ [: `'''; s :] -> comment bp s + | [: s :] -> left_paren_in_comment bp s ] + and quote_star_in_comment bp = + parser + [ [: `'''; s :] -> comment bp s + | [: s :] -> star_in_comment bp s ] + and quote_doublequote_in_comment bp = + parser + [ [: `'''; s :] -> comment bp s + | [: _ = string bp 0; s :] -> comment bp s ] + and quote_antislash_in_comment bp = + parser + [ [: `'''; s :] -> quote_antislash_quote_in_comment bp s + | [: `('\\' | '"' | 'n' | 't' | 'b' | 'r'); s :] -> + quote_any_in_comment bp s + | [: `('0'..'9'); s :] -> quote_antislash_digit_in_comment bp s + | [: `'x'; s :] -> quote_antislash_x_in_comment bp s + | [: s :] -> comment bp s ] + and quote_antislash_quote_in_comment bp = + parser + [ [: `'''; s :] -> comment bp s + | [: s :] -> quote_in_comment bp s ] + and quote_antislash_digit_in_comment bp = + parser + [ [: `('0'..'9'); s :] -> quote_antislash_digit2_in_comment bp s + | [: s :] -> comment bp s ] + and quote_antislash_digit2_in_comment bp = + parser + [ [: `('0'..'9'); s :] -> quote_any_in_comment bp s + | [: s :] -> comment bp s ] + and quote_antislash_x_in_comment bp = + parser + [ [: _ = hexa; s :] -> quote_antislash_x_digit_in_comment bp s + | [: s :] -> comment bp s ] + and quote_antislash_x_digit_in_comment bp = + parser + [ [: _ = hexa; s :] -> quote_any_in_comment bp s + | [: s :] -> comment bp s ] + and left_paren_in_comment bp = + parser + [ [: `'*'; s :] -> do { comment bp s; comment bp s } + | [: a = comment bp :] -> a ] + and star_in_comment bp = + parser + [ [: `')' :] -> () + | [: a = comment bp :] -> a ] + and linedir n s = + match stream_peek_nth n s with + [ Some (' ' | '\t') -> linedir (n + 1) s + | Some ('0'..'9') -> linedir_digits (n + 1) s + | _ -> False ] + and linedir_digits n s = + match stream_peek_nth n s with + [ Some ('0'..'9') -> linedir_digits (n + 1) s + | _ -> linedir_quote n s ] + and linedir_quote n s = + match stream_peek_nth n s with + [ Some (' ' | '\t') -> linedir_quote (n + 1) s + | Some '"' -> True + | _ -> False ] + and any_to_nl = + parser + [ [: `'\013' | '\010' :] ep -> bolpos.val := ep + | [: `_; s :] -> any_to_nl s + | [: :] -> () ] + in + fun cstrm -> + try + let glex = glexr.val in + let comm_bp = Stream.count cstrm in + let r = next_token False cstrm in + do { + match glex.tok_comm with + [ Some list -> + if fst (snd r) > comm_bp then + let comm_loc = (comm_bp, fst (snd r)) in + glex.tok_comm := Some [comm_loc :: list] + else () + | None -> () ]; + r + } + with + [ Stream.Error str -> + err (Stream.count cstrm, Stream.count cstrm + 1) str ] +; +*) + +let next_token_fun dfa ssd find_kwd bolpos glexr = let keyword_or_error loc s = try ("", find_kwd s), loc with Not_found -> if !error_on_unknown_keywords then err loc ("illegal token: " ^ s) else ("", s), loc in - let rec next_token (strm__ : _ Stream.t) = + let rec next_token after_space (strm__ : _ Stream.t) = let bp = Stream.count strm__ in match Stream.peek strm__ with - Some (' ' | '\010' | '\013' | '\t' | '\026' | '\012') -> - Stream.junk strm__; next_token strm__ + Some ('\010' | '\013') -> + Stream.junk strm__; + let s = strm__ in + let ep = Stream.count strm__ in bolpos := ep; next_token true s + | Some (' ' | '\t' | '\026' | '\012') -> + Stream.junk strm__; next_token true strm__ + | Some '#' when bp = !bolpos -> + Stream.junk strm__; + let s = strm__ in + if linedir 1 s then begin any_to_nl s; next_token true s end + else keyword_or_error (bp, bp + 1) "#" | Some '(' -> Stream.junk strm__; left_paren bp strm__ - | Some '#' -> - Stream.junk strm__; let s = strm__ in spaces_tabs s; linenum bp s | Some ('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c) -> Stream.junk strm__; let s = strm__ in @@ -174,8 +522,8 @@ let next_token_fun dfa find_kwd = | Some '\'' -> Stream.junk strm__; let s = strm__ in - begin match Stream.npeek 3 s with - [_; '\''; _] | ['\\'; _; _] | ['\x0D'; '\x0A'; '\''] -> + begin match Stream.npeek 2 s with + [_; '\''] | ['\\'; _] -> let tok = "CHAR", get_buff (char bp 0 s) in let loc = bp, Stream.count s in tok, loc | _ -> keyword_or_error (bp, Stream.count s) "'" @@ -276,7 +624,7 @@ let next_token_fun dfa find_kwd = try match Stream.peek strm__ with Some '.' -> Stream.junk strm__; ".." - | _ -> "." + | _ -> if ssd && after_space then " ." else "." with Stream.Failure -> raise (Stream.Error "") in @@ -511,7 +859,7 @@ let next_token_fun dfa find_kwd = try comment bp strm__ with Stream.Failure -> raise (Stream.Error "") in - begin try next_token strm__ with + begin try next_token true strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> let ep = Stream.count strm__ in keyword_or_error (bp, ep) "(" @@ -533,47 +881,26 @@ let next_token_fun dfa find_kwd = and quote_in_comment bp (strm__ : _ Stream.t) = match Stream.peek strm__ with Some '\'' -> Stream.junk strm__; comment bp strm__ - | Some '\013' -> Stream.junk strm__; quote_cr_in_comment bp strm__ - | Some '\\' -> Stream.junk strm__; quote_antislash_in_comment bp strm__ - | Some '(' -> Stream.junk strm__; quote_left_paren_in_comment bp strm__ - | Some '*' -> Stream.junk strm__; quote_star_in_comment bp strm__ - | Some '\"' -> Stream.junk strm__; quote_doublequote_in_comment bp strm__ - | Some _ -> Stream.junk strm__; quote_any_in_comment bp strm__ - | _ -> comment bp strm__ + | Some '\\' -> Stream.junk strm__; quote_antislash_in_comment bp 0 strm__ + | _ -> + let s = strm__ in + begin match Stream.npeek 2 s with + [_; '\''] -> Stream.junk s; Stream.junk s + | _ -> () + end; + comment bp s and quote_any_in_comment bp (strm__ : _ Stream.t) = match Stream.peek strm__ with Some '\'' -> Stream.junk strm__; comment bp strm__ | _ -> comment bp strm__ - and quote_cr_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\010' -> Stream.junk strm__; quote_any_in_comment bp strm__ - | _ -> quote_any_in_comment bp strm__ - and quote_left_paren_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\'' -> Stream.junk strm__; comment bp strm__ - | _ -> left_paren_in_comment bp strm__ - and quote_star_in_comment bp (strm__ : _ Stream.t) = + and quote_antislash_in_comment bp len (strm__ : _ Stream.t) = match Stream.peek strm__ with Some '\'' -> Stream.junk strm__; comment bp strm__ - | _ -> star_in_comment bp strm__ - and quote_doublequote_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\'' -> Stream.junk strm__; comment bp strm__ - | _ -> let _ = string bp 0 strm__ in comment bp strm__ - and quote_antislash_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\'' -> - Stream.junk strm__; quote_antislash_quote_in_comment bp strm__ | Some ('\\' | '\"' | 'n' | 't' | 'b' | 'r') -> Stream.junk strm__; quote_any_in_comment bp strm__ | Some ('0'..'9') -> Stream.junk strm__; quote_antislash_digit_in_comment bp strm__ - | Some 'x' -> Stream.junk strm__; quote_antislash_x_in_comment bp strm__ | _ -> comment bp strm__ - and quote_antislash_quote_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\'' -> Stream.junk strm__; comment bp strm__ - | _ -> quote_in_comment bp strm__ and quote_antislash_digit_in_comment bp (strm__ : _ Stream.t) = match Stream.peek strm__ with Some ('0'..'9') -> @@ -583,20 +910,6 @@ let next_token_fun dfa find_kwd = match Stream.peek strm__ with Some ('0'..'9') -> Stream.junk strm__; quote_any_in_comment bp strm__ | _ -> comment bp strm__ - and quote_antislash_x_in_comment bp (strm__ : _ Stream.t) = - match - try Some (hexa strm__) with - Stream.Failure -> None - with - Some _ -> quote_antislash_x_digit_in_comment bp strm__ - | _ -> comment bp strm__ - and quote_antislash_x_digit_in_comment bp (strm__ : _ Stream.t) = - match - try Some (hexa strm__) with - Stream.Failure -> None - with - Some _ -> quote_any_in_comment bp strm__ - | _ -> comment bp strm__ and left_paren_in_comment bp (strm__ : _ Stream.t) = match Stream.peek strm__ with Some '*' -> @@ -606,54 +919,54 @@ let next_token_fun dfa find_kwd = match Stream.peek strm__ with Some ')' -> Stream.junk strm__; () | _ -> comment bp strm__ - and linenum bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9') -> - Stream.junk strm__; - let _ = - try digits strm__ with - Stream.Failure -> raise (Stream.Error "") - in - let _ = - try spaces_tabs strm__ with - Stream.Failure -> raise (Stream.Error "") - in - begin match Stream.peek strm__ with - Some '\"' -> - Stream.junk strm__; - let _ = - try any_to_nl strm__ with - Stream.Failure -> raise (Stream.Error "") - in - next_token strm__ - | _ -> raise (Stream.Error "") - end - | _ -> keyword_or_error (bp, bp + 1) "#" - and spaces_tabs (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some (' ' | '\t') -> Stream.junk strm__; spaces_tabs strm__ - | _ -> () - and digits (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9') -> Stream.junk strm__; digits strm__ - | _ -> () + and linedir n s = + match stream_peek_nth n s with + Some (' ' | '\t') -> linedir (n + 1) s + | Some ('0'..'9') -> linedir_digits (n + 1) s + | _ -> false + and linedir_digits n s = + match stream_peek_nth n s with + Some ('0'..'9') -> linedir_digits (n + 1) s + | _ -> linedir_quote n s + and linedir_quote n s = + match stream_peek_nth n s with + Some (' ' | '\t') -> linedir_quote (n + 1) s + | Some '\"' -> true + | _ -> false and any_to_nl (strm__ : _ Stream.t) = match Stream.peek strm__ with - Some ('\013' | '\010') -> Stream.junk strm__; () + Some ('\013' | '\010') -> + Stream.junk strm__; let ep = Stream.count strm__ in bolpos := ep | Some _ -> Stream.junk strm__; any_to_nl strm__ | _ -> () in fun cstrm -> - try next_token cstrm with + try + let glex = !glexr in + let comm_bp = Stream.count cstrm in + let r = next_token false cstrm in + begin match glex.tok_comm with + Some list -> + if fst (snd r) > comm_bp then + let comm_loc = comm_bp, fst (snd r) in + glex.tok_comm <- Some (comm_loc :: list) + | None -> () + end; + r + with Stream.Error str -> err (Stream.count cstrm, Stream.count cstrm + 1) str ;; + let dollar_for_antiquotation = ref true;; +let specific_space_dot = ref false;; -let func kwd_table = +let func kwd_table glexr = + let bolpos = ref 0 in let find = Hashtbl.find kwd_table in let dfa = !dollar_for_antiquotation in - Token.lexer_func_of_parser (next_token_fun dfa find) + let ssd = !specific_space_dot in + Token.lexer_func_of_parser (next_token_fun dfa ssd find bolpos glexr) ;; let rec check_keyword_stream (strm__ : _ Stream.t) = @@ -862,9 +1175,22 @@ let tok_match = let gmake () = let kwd_table = Hashtbl.create 301 in let id_table = Hashtbl.create 301 in - {tok_func = func kwd_table; tok_using = using_token kwd_table id_table; - tok_removing = removing_token kwd_table id_table; tok_match = tok_match; - tok_text = text} + let glexr = + ref + {tok_func = (fun _ -> raise (Match_failure ("plexer.ml", 952, 17))); + tok_using = (fun _ -> raise (Match_failure ("plexer.ml", 952, 37))); + tok_removing = (fun _ -> raise (Match_failure ("plexer.ml", 952, 60))); + tok_match = (fun _ -> raise (Match_failure ("plexer.ml", 953, 18))); + tok_text = (fun _ -> raise (Match_failure ("plexer.ml", 953, 37))); + tok_comm = None} + in + let glex = + {tok_func = func kwd_table glexr; + tok_using = using_token kwd_table id_table; + tok_removing = removing_token kwd_table id_table; tok_match = tok_match; + tok_text = text; tok_comm = None} + in + glexr := glex; glex ;; let tparse = @@ -883,6 +1209,15 @@ let tparse = let make () = let kwd_table = Hashtbl.create 301 in let id_table = Hashtbl.create 301 in - {func = func kwd_table; using = using_token kwd_table id_table; + let glexr = + ref + {tok_func = (fun _ -> raise (Match_failure ("plexer.ml", 981, 17))); + tok_using = (fun _ -> raise (Match_failure ("plexer.ml", 981, 37))); + tok_removing = (fun _ -> raise (Match_failure ("plexer.ml", 981, 60))); + tok_match = (fun _ -> raise (Match_failure ("plexer.ml", 982, 18))); + tok_text = (fun _ -> raise (Match_failure ("plexer.ml", 982, 37))); + tok_comm = None} + in + {func = func kwd_table glexr; using = using_token kwd_table id_table; removing = removing_token kwd_table id_table; tparse = tparse; text = text} ;; diff --git a/camlp4/ocaml_src/lib/plexer.mli b/camlp4/ocaml_src/lib/plexer.mli index d682f83ae..19bc0ce1b 100644 --- a/camlp4/ocaml_src/lib/plexer.mli +++ b/camlp4/ocaml_src/lib/plexer.mli @@ -54,6 +54,12 @@ val dollar_for_antiquotation : bool ref;; lexer where the dollar sign is used for antiquotations. If False, the dollar sign can be used as token. *) +val specific_space_dot : bool ref;; + (** When False (default), the next call to [Plexer.make ()] returns a + lexer where the dots can be preceded by spaces. If True, dots + preceded by spaces return the keyword " ." (space dot), otherwise + return the keyword "." (dot). *) + val no_quotations : bool ref;; (** When True, all lexers built by [Plexer.make ()] do not lex the quotation syntax any more. Default is False (quotations are diff --git a/camlp4/ocaml_src/lib/stdpp.ml b/camlp4/ocaml_src/lib/stdpp.ml index 0830e6842..d91ee78c0 100644 --- a/camlp4/ocaml_src/lib/stdpp.ml +++ b/camlp4/ocaml_src/lib/stdpp.ml @@ -23,23 +23,77 @@ let raise_with_loc loc exc = let line_of_loc fname (bp, ep) = try let ic = open_in_bin fname in - let rec loop lin col cnt = - if cnt < bp then - let (lin, col) = - match input_char ic with - '\n' -> lin + 1, 0 - | _ -> lin, col + 1 - in - loop lin col (cnt + 1) - else lin, col, col + ep - bp + let strm = Stream.of_channel ic in + let rec loop fname lin = + let rec not_a_line_dir col (strm__ : _ Stream.t) = + let cnt = Stream.count strm__ in + match Stream.peek strm__ with + Some c -> + Stream.junk strm__; + let s = strm__ in + if cnt < bp then + if c = '\n' then loop fname (lin + 1) + else not_a_line_dir (col + 1) s + else let col = col - (cnt - bp) in fname, lin, col, col + ep - bp + | _ -> raise Stream.Failure + in + let rec a_line_dir str n col (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some '\n' -> Stream.junk strm__; loop str n + | Some _ -> Stream.junk strm__; a_line_dir str n (col + 1) strm__ + | _ -> raise Stream.Failure + in + let rec spaces col (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some ' ' -> Stream.junk strm__; spaces (col + 1) strm__ + | _ -> col + in + let rec check_string str n col (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some '\"' -> + Stream.junk strm__; + let col = + try spaces (col + 1) strm__ with + Stream.Failure -> raise (Stream.Error "") + in + a_line_dir str n col strm__ + | Some c when c <> '\n' -> + Stream.junk strm__; + check_string (str ^ String.make 1 c) n (col + 1) strm__ + | _ -> not_a_line_dir col strm__ + in + let check_quote n col (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some '\"' -> Stream.junk strm__; check_string "" n (col + 1) strm__ + | _ -> not_a_line_dir col strm__ + in + let rec check_num n col (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some ('0'..'9' as c) -> + Stream.junk strm__; + check_num (10 * n + Char.code c - Char.code '0') (col + 1) strm__ + | _ -> let col = spaces col strm__ in check_quote n col strm__ + in + let begin_line (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some '#' -> + Stream.junk strm__; + let col = + try spaces 1 strm__ with + Stream.Failure -> raise (Stream.Error "") + in + check_num 0 col strm__ + | _ -> not_a_line_dir 0 strm__ + in + begin_line strm in let r = - try loop 1 0 0 with - End_of_file -> 1, bp, ep + try loop fname 1 with + Stream.Failure -> fname, 1, bp, ep in close_in ic; r with - Sys_error _ -> 1, bp, ep + Sys_error _ -> fname, 1, bp, ep ;; let loc_name = ref "loc";; diff --git a/camlp4/ocaml_src/lib/stdpp.mli b/camlp4/ocaml_src/lib/stdpp.mli index 5afd1b2db..68c0cb6ad 100644 --- a/camlp4/ocaml_src/lib/stdpp.mli +++ b/camlp4/ocaml_src/lib/stdpp.mli @@ -25,10 +25,12 @@ val raise_with_loc : int * int -> exn -> 'a;; (** [raise_with_loc loc e], if [e] is already the exception [Exc_located], re-raise it, else raise the exception [Exc_located loc e]. *) -val line_of_loc : string -> int * int -> int * int * int;; +val line_of_loc : string -> int * int -> string * int * int * int;; (** [line_of_loc fname loc] reads the file [fname] up to the - location [loc] and returns the line number and the characters - location in the line *) + location [loc] and returns the real input file, the line number + and the characters location in the line; the real input file + can be different from [fname] because of possibility of line + directives typically generated by /lib/cpp. *) val loc_name : string ref;; (** Name of the location variable used in grammars and in the predefined diff --git a/camlp4/ocaml_src/lib/token.ml b/camlp4/ocaml_src/lib/token.ml index 63f09bc19..67aaffdec 100644 --- a/camlp4/ocaml_src/lib/token.ml +++ b/camlp4/ocaml_src/lib/token.ml @@ -26,7 +26,8 @@ type 'te glexer = tok_using : pattern -> unit; tok_removing : pattern -> unit; tok_match : pattern -> 'te -> string; - tok_text : pattern -> string } + tok_text : pattern -> string; + mutable tok_comm : location list option } ;; type lexer = { func : t lexer_func; diff --git a/camlp4/ocaml_src/lib/token.mli b/camlp4/ocaml_src/lib/token.mli index 4e14469d6..e561e28e8 100644 --- a/camlp4/ocaml_src/lib/token.mli +++ b/camlp4/ocaml_src/lib/token.mli @@ -47,7 +47,8 @@ type 'te glexer = tok_using : pattern -> unit; tok_removing : pattern -> unit; tok_match : pattern -> 'te -> string; - tok_text : pattern -> string } + tok_text : pattern -> string; + mutable tok_comm : location list option } ;; (** The type for a lexer used by Camlp4 grammars. - The field [tok_func] is the main lexer function. See [lexer_func] @@ -66,7 +67,9 @@ type 'te glexer = efficency, write it as a function returning functions according to the values of the pattern, not a function with two parameters. - The field [tok_text] returns the name of some token pattern, - used in error messages. *) + used in error messages. +- The field [tok_comm] if not None asks the lexer to record the + locations of the comments. *) val lexer_text : pattern -> string;; (** A simple [tok_text] function for lexers *) diff --git a/camlp4/ocaml_src/meta/Makefile b/camlp4/ocaml_src/meta/Makefile index aac0f0abd..a7cd03d73 100644 --- a/camlp4/ocaml_src/meta/Makefile +++ b/camlp4/ocaml_src/meta/Makefile @@ -4,7 +4,7 @@ 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_ifdef.cmo pr_dump.cmo +OBJS=q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo pa_macro.cmo pr_dump.cmo CAMLP4RM=pa_r.cmo pa_rp.cmo pr_dump.cmo CAMLP4RMX=pa_r.cmx pa_rp.cmx pr_dump.cmx SHELL=/bin/sh @@ -42,10 +42,10 @@ compare: done install: - -$(MKDIR) $(LIBDIR)/camlp4 $(BINDIR) - cp $(OBJS) $(LIBDIR)/camlp4/. - cp pa_ifdef.cmi pa_extend.cmi $(LIBDIR)/camlp4/. - cp camlp4r$(EXE) $(BINDIR)/. - if test -f $(COPT); then cp $(COPT) $(BINDIR)/.; fi + -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" + cp $(OBJS) "$(LIBDIR)/camlp4/." + cp pa_macro.cmi pa_extend.cmi "$(LIBDIR)/camlp4/." + cp camlp4r$(EXE) "$(BINDIR)/." + if test -f $(COPT); then cp $(COPT) "$(BINDIR)/."; fi include .depend diff --git a/camlp4/ocaml_src/meta/Makefile.Mac.depend b/camlp4/ocaml_src/meta/Makefile.Mac.depend index e48bfb7f6..29675238e 100644 --- a/camlp4/ocaml_src/meta/Makefile.Mac.depend +++ b/camlp4/ocaml_src/meta/Makefile.Mac.depend @@ -2,8 +2,8 @@ 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_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 diff --git a/camlp4/ocaml_src/meta/pa_extend.ml b/camlp4/ocaml_src/meta/pa_extend.ml index ea822c6b3..d68baf8d5 100644 --- a/camlp4/ocaml_src/meta/pa_extend.ml +++ b/camlp4/ocaml_src/meta/pa_extend.ml @@ -693,7 +693,7 @@ let rec quot_expr e = (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")), MLast.ExStr (loc, c)), mklistexp loc al) - | MLast.ExAcc (_, _, MLast.ExUid (_, c)) -> + | MLast.ExAcc (_, MLast.ExUid (_, "MLast"), MLast.ExUid (_, c)) -> let al = List.map quot_expr al in MLast.ExApp (loc, @@ -703,6 +703,16 @@ let rec quot_expr e = (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")), MLast.ExStr (loc, c)), mklistexp loc al) + | MLast.ExAcc (_, MLast.ExUid (_, m), MLast.ExUid (_, c)) -> + let al = List.map quot_expr al in + MLast.ExApp + (loc, + MLast.ExApp + (loc, + MLast.ExAcc + (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")), + MLast.ExStr (loc, (m ^ "." ^ c))), + mklistexp loc al) | MLast.ExLid (_, f) -> let al = List.map quot_expr al in List.fold_left (fun f e -> MLast.ExApp (loc, f, e)) @@ -736,7 +746,7 @@ let rec quot_expr e = if s = !(Stdpp.loc_name) then MLast.ExAcc (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Loc")) else e - | MLast.ExAcc (_, _, MLast.ExUid (_, s)) -> + | MLast.ExAcc (_, MLast.ExUid (_, "MLast"), MLast.ExUid (_, s)) -> MLast.ExApp (loc, MLast.ExApp @@ -745,6 +755,15 @@ let rec quot_expr e = (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")), MLast.ExStr (loc, s)), MLast.ExUid (loc, "[]")) + | MLast.ExAcc (_, MLast.ExUid (_, m), MLast.ExUid (_, s)) -> + MLast.ExApp + (loc, + MLast.ExApp + (loc, + MLast.ExAcc + (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")), + MLast.ExStr (loc, (m ^ "." ^ s))), + MLast.ExUid (loc, "[]")) | MLast.ExUid (_, s) -> MLast.ExApp (loc, @@ -1442,6 +1461,20 @@ let text_of_functorial_extend loc gmod gl el = open Pcaml;; let symbol = Grammar.Entry.create gram "symbol";; +let semi_sep = + if !syntax_name = "Scheme" then + Grammar.Entry.of_parser gram "'/'" + (fun (strm__ : _ Stream.t) -> + match Stream.peek strm__ with + Some ("", "/") -> Stream.junk strm__; () + | _ -> raise Stream.Failure) + else + Grammar.Entry.of_parser gram "';'" + (fun (strm__ : _ Stream.t) -> + match Stream.peek strm__ with + Some ("", ";") -> Stream.junk strm__; () + | _ -> raise Stream.Failure) +;; Grammar.extend (let _ = (expr : 'expr Grammar.Entry.e) @@ -1516,7 +1549,8 @@ Grammar.extend (Gramext.srules [[Gramext.Snterm (Grammar.Entry.obj (entry : 'entry Grammar.Entry.e)); - Gramext.Stoken ("", ";")], + Gramext.Snterm + (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], Gramext.action (fun _ (e : 'entry) (loc : int * int) -> (e : 'e__1))])], Gramext.action @@ -1533,7 +1567,8 @@ Grammar.extend (Gramext.srules [[Gramext.Snterm (Grammar.Entry.obj (entry : 'entry Grammar.Entry.e)); - Gramext.Stoken ("", ";")], + Gramext.Snterm + (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], Gramext.action (fun _ (e : 'entry) (loc : int * int) -> (e : 'e__2))])], Gramext.action @@ -1548,7 +1583,8 @@ Grammar.extend Gramext.Slist1sep (Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], + Gramext.Snterm + (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))], Gramext.action (fun (sl : 'symbol list) _ (n : 'name) (loc : int * int) -> (let (e, b) = expr_of_delete_rule loc "Grammar" n sl in @@ -1572,7 +1608,8 @@ Grammar.extend Gramext.Slist1sep (Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], + Gramext.Snterm + (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))], Gramext.action (fun (sl : 'symbol list) _ (n : 'name) (g : string) (loc : int * int) -> @@ -1598,7 +1635,8 @@ Grammar.extend 'efunction)); [Gramext.Stoken ("UIDENT", "FUNCTION"); Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e)); - Gramext.Stoken ("", ";")], + Gramext.Snterm + (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], Gramext.action (fun _ (f : 'qualid) _ _ (loc : int * int) -> (f : 'efunction))]]; Grammar.Entry.obj (global : 'global Grammar.Entry.e), None, @@ -1606,7 +1644,8 @@ Grammar.extend [[Gramext.Stoken ("UIDENT", "GLOBAL"); Gramext.Stoken ("", ":"); Gramext.Slist1 (Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e))); - Gramext.Stoken ("", ";")], + Gramext.Snterm + (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], Gramext.action (fun _ (sl : 'name list) _ _ (loc : int * int) -> (sl : 'global))]]; Grammar.Entry.obj (entry : 'entry Grammar.Entry.e), None, @@ -1731,14 +1770,16 @@ Grammar.extend [[Gramext.Slist0sep (Gramext.Snterm (Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], + Gramext.Snterm + (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))], Gramext.action (fun (psl : 'psymbol list) (loc : int * int) -> ({prod = psl; action = None} : 'rule)); [Gramext.Slist0sep (Gramext.Snterm (Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e)), - Gramext.Stoken ("", ";")); + Gramext.Snterm + (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))); Gramext.Stoken ("", "->"); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action diff --git a/camlp4/ocaml_src/meta/pa_macro.ml b/camlp4/ocaml_src/meta/pa_macro.ml new file mode 100644 index 000000000..599608f9f --- /dev/null +++ b/camlp4/ocaml_src/meta/pa_macro.ml @@ -0,0 +1,392 @@ +(* camlp4r *) +(* This file has been generated by program: do not edit! *) + +(* +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 'a item_or_def = + SdStr of 'a + | SdDef of string * (string list * MLast.expr) option + | SdUnd of string + | SdNop +;; + +let rec list_remove x = + function + (y, _) :: l when y = x -> l + | d :: l -> d :: list_remove x l + | [] -> [] +;; + +let defined = ref [];; + +let is_defined i = List.mem_assoc i !defined;; + +let loc = 0, 0;; + +let subst mloc env = + let rec loop = + function + MLast.ExLet (_, rf, pel, e) -> + let pel = List.map (fun (p, e) -> p, loop e) pel in + MLast.ExLet (loc, rf, pel, loop e) + | MLast.ExIfe (_, e1, e2, e3) -> + MLast.ExIfe (loc, loop e1, loop e2, loop e3) + | MLast.ExApp (_, e1, e2) -> MLast.ExApp (loc, loop e1, loop e2) + | MLast.ExLid (_, x) | MLast.ExUid (_, x) as e -> + begin try MLast.ExAnt (loc, List.assoc x env) with + Not_found -> e + end + | MLast.ExTup (_, x) -> MLast.ExTup (loc, List.map loop x) + | MLast.ExRec (_, pel, None) -> + let pel = List.map (fun (p, e) -> p, loop e) pel in + MLast.ExRec (loc, pel, None) + | e -> e + in + loop +;; + +let substp mloc env = + let rec loop = + function + MLast.ExApp (_, e1, e2) -> MLast.PaApp (loc, loop e1, loop e2) + | MLast.ExLid (_, x) -> + begin try MLast.PaAnt (loc, List.assoc x env) with + Not_found -> MLast.PaLid (loc, x) + end + | MLast.ExUid (_, x) -> + begin try MLast.PaAnt (loc, List.assoc x env) with + Not_found -> MLast.PaUid (loc, x) + end + | MLast.ExInt (_, x) -> MLast.PaInt (loc, x) + | MLast.ExTup (_, x) -> MLast.PaTup (loc, List.map loop x) + | MLast.ExRec (_, pel, None) -> + let ppl = List.map (fun (p, e) -> p, loop e) pel in + MLast.PaRec (loc, ppl) + | x -> + Stdpp.raise_with_loc mloc + (Failure + "this macro cannot be used in a pattern (see its definition)") + in + loop +;; + +let incorrect_number loc l1 l2 = + Stdpp.raise_with_loc loc + (Failure + (Printf.sprintf "expected %d parameters; found %d" (List.length l2) + (List.length l1))) +;; + +let define eo x = + begin match eo with + Some ([], e) -> + Grammar.extend + [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), + Some (Gramext.Level "simple"), + [None, None, + [[Gramext.Stoken ("UIDENT", x)], + Gramext.action + (fun _ (loc : int * int) -> + (Pcaml.expr_reloc (fun _ -> loc) 0 e : 'expr))]]; + Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), + Some (Gramext.Level "simple"), + [None, None, + [[Gramext.Stoken ("UIDENT", x)], + Gramext.action + (fun _ (loc : int * int) -> + (let p = substp loc [] e in + Pcaml.patt_reloc (fun _ -> loc) 0 p : + 'patt))]]] + | Some (sl, e) -> + Grammar.extend + [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), + Some (Gramext.Level "apply"), + [None, None, + [[Gramext.Stoken ("UIDENT", x); Gramext.Sself], + Gramext.action + (fun (param : 'expr) _ (loc : int * int) -> + (let el = + match param with + MLast.ExTup (_, 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 : + 'expr))]]; + Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), + Some (Gramext.Level "simple"), + [None, None, + [[Gramext.Stoken ("UIDENT", x); Gramext.Sself], + Gramext.action + (fun (param : 'patt) _ (loc : int * int) -> + (let pl = + match param with + MLast.PaTup (_, 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 : + 'patt))]]] + | None -> () + end; + defined := (x, eo) :: !defined +;; + +let undef x = + try + let eo = List.assoc x !defined in + begin match eo with + Some ([], _) -> + Grammar.delete_rule expr [Gramext.Stoken ("UIDENT", x)]; + Grammar.delete_rule patt [Gramext.Stoken ("UIDENT", x)] + | Some (_, _) -> + Grammar.delete_rule expr + [Gramext.Stoken ("UIDENT", x); Gramext.Sself]; + Grammar.delete_rule patt [Gramext.Stoken ("UIDENT", x); Gramext.Sself] + | None -> () + end; + defined := list_remove x !defined + with + Not_found -> () +;; + +Grammar.extend + (let _ = (expr : 'expr Grammar.Entry.e) + and _ = (patt : 'patt Grammar.Entry.e) + and _ = (str_item : 'str_item Grammar.Entry.e) + and _ = (sig_item : 'sig_item Grammar.Entry.e) in + let grammar_entry_create s = + Grammar.Entry.create (Grammar.of_entry expr) s + in + let macro_def : 'macro_def Grammar.Entry.e = + grammar_entry_create "macro_def" + and str_item_or_macro : 'str_item_or_macro Grammar.Entry.e = + grammar_entry_create "str_item_or_macro" + and opt_macro_value : 'opt_macro_value Grammar.Entry.e = + grammar_entry_create "opt_macro_value" + and uident : 'uident Grammar.Entry.e = grammar_entry_create "uident" in + [Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), + Some Gramext.First, + [None, None, + [[Gramext.Snterm + (Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e))], + Gramext.action + (fun (x : 'macro_def) (loc : int * int) -> + (match x with + SdStr [si] -> si + | SdStr sil -> MLast.StDcl (loc, sil) + | SdDef (x, eo) -> define eo x; MLast.StDcl (loc, []) + | SdUnd x -> undef x; MLast.StDcl (loc, []) + | SdNop -> MLast.StDcl (loc, []) : + 'str_item))]]; + Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e), None, + [None, None, + [[Gramext.Stoken ("", "IFNDEF"); + Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); + Gramext.Stoken ("", "THEN"); + Gramext.Snterm + (Grammar.Entry.obj + (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); + Gramext.Stoken ("", "ELSE"); + Gramext.Snterm + (Grammar.Entry.obj + (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); + Gramext.Stoken ("", "END")], + Gramext.action + (fun _ (d2 : 'str_item_or_macro) _ (d1 : 'str_item_or_macro) _ + (i : 'uident) _ (loc : int * int) -> + (if is_defined i then d2 else d1 : 'macro_def)); + [Gramext.Stoken ("", "IFNDEF"); + Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); + Gramext.Stoken ("", "THEN"); + Gramext.Snterm + (Grammar.Entry.obj + (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); + Gramext.Stoken ("", "END")], + Gramext.action + (fun _ (d : 'str_item_or_macro) _ (i : 'uident) _ (loc : int * int) -> + (if is_defined i then SdNop else d : 'macro_def)); + [Gramext.Stoken ("", "IFDEF"); + Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); + Gramext.Stoken ("", "THEN"); + Gramext.Snterm + (Grammar.Entry.obj + (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); + Gramext.Stoken ("", "ELSE"); + Gramext.Snterm + (Grammar.Entry.obj + (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); + Gramext.Stoken ("", "END")], + Gramext.action + (fun _ (d2 : 'str_item_or_macro) _ (d1 : 'str_item_or_macro) _ + (i : 'uident) _ (loc : int * int) -> + (if is_defined i then d1 else d2 : 'macro_def)); + [Gramext.Stoken ("", "IFDEF"); + Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); + Gramext.Stoken ("", "THEN"); + Gramext.Snterm + (Grammar.Entry.obj + (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); + Gramext.Stoken ("", "END")], + Gramext.action + (fun _ (d : 'str_item_or_macro) _ (i : 'uident) _ (loc : int * int) -> + (if is_defined i then d else SdNop : 'macro_def)); + [Gramext.Stoken ("", "UNDEF"); + Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e))], + Gramext.action + (fun (i : 'uident) _ (loc : int * int) -> (SdUnd i : 'macro_def)); + [Gramext.Stoken ("", "DEFINE"); + Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); + Gramext.Snterm + (Grammar.Entry.obj + (opt_macro_value : 'opt_macro_value Grammar.Entry.e))], + Gramext.action + (fun (def : 'opt_macro_value) (i : 'uident) _ (loc : int * int) -> + (SdDef (i, def) : 'macro_def))]]; + Grammar.Entry.obj + (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e), + None, + [None, None, + [[Gramext.Slist1 + (Gramext.Snterm + (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)))], + Gramext.action + (fun (si : 'str_item list) (loc : int * int) -> + (SdStr si : 'str_item_or_macro)); + [Gramext.Snterm + (Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e))], + Gramext.action + (fun (d : 'macro_def) (loc : int * int) -> + (d : 'str_item_or_macro))]]; + Grammar.Entry.obj (opt_macro_value : 'opt_macro_value Grammar.Entry.e), + None, + [None, None, + [[], Gramext.action (fun (loc : int * int) -> (None : 'opt_macro_value)); + [Gramext.Stoken ("", "="); + Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], + Gramext.action + (fun (e : 'expr) _ (loc : int * int) -> + (Some ([], e) : 'opt_macro_value)); + [Gramext.Stoken ("", "("); + Gramext.Slist1sep + (Gramext.Stoken ("LIDENT", ""), Gramext.Stoken ("", ",")); + Gramext.Stoken ("", ")"); Gramext.Stoken ("", "="); + Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], + Gramext.action + (fun (e : 'expr) _ _ (pl : string list) _ (loc : int * int) -> + (Some (pl, e) : 'opt_macro_value))]]; + Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), + Some (Gramext.Level "top"), + [None, None, + [[Gramext.Stoken ("", "IFNDEF"); + Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); + Gramext.Stoken ("", "THEN"); Gramext.Sself; + Gramext.Stoken ("", "ELSE"); Gramext.Sself; + Gramext.Stoken ("", "END")], + Gramext.action + (fun _ (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _ + (loc : int * int) -> + (if is_defined i then e2 else e1 : 'expr)); + [Gramext.Stoken ("", "IFDEF"); + Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); + Gramext.Stoken ("", "THEN"); Gramext.Sself; + Gramext.Stoken ("", "ELSE"); Gramext.Sself; + Gramext.Stoken ("", "END")], + Gramext.action + (fun _ (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _ + (loc : int * int) -> + (if is_defined i then e1 else e2 : 'expr))]]; + Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), + Some (Gramext.Level "simple"), + [None, None, + [[Gramext.Stoken ("LIDENT", "__LOCATION__")], + Gramext.action + (fun _ (loc : int * int) -> + (let bp = string_of_int (fst loc) in + let ep = string_of_int (snd loc) in + MLast.ExTup + (loc, [MLast.ExInt (loc, bp); MLast.ExInt (loc, ep)]) : + 'expr)); + [Gramext.Stoken ("LIDENT", "__FILE__")], + Gramext.action + (fun _ (loc : int * int) -> + (MLast.ExStr (loc, !(Pcaml.input_file)) : 'expr))]]; + Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), None, + [None, None, + [[Gramext.Stoken ("", "IFNDEF"); + Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); + Gramext.Stoken ("", "THEN"); Gramext.Sself; + Gramext.Stoken ("", "ELSE"); Gramext.Sself; + Gramext.Stoken ("", "END")], + Gramext.action + (fun _ (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _ + (loc : int * int) -> + (if is_defined i then p2 else p1 : 'patt)); + [Gramext.Stoken ("", "IFDEF"); + Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); + Gramext.Stoken ("", "THEN"); Gramext.Sself; + Gramext.Stoken ("", "ELSE"); Gramext.Sself; + Gramext.Stoken ("", "END")], + Gramext.action + (fun _ (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _ + (loc : int * int) -> + (if is_defined i then p1 else p2 : 'patt))]]; + Grammar.Entry.obj (uident : 'uident Grammar.Entry.e), None, + [None, None, + [[Gramext.Stoken ("UIDENT", "")], + Gramext.action + (fun (i : string) (loc : int * int) -> (i : 'uident))]]]);; + +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/ocaml_src/meta/pa_r.ml b/camlp4/ocaml_src/meta/pa_r.ml index 05e18e8ce..fc26cb351 100644 --- a/camlp4/ocaml_src/meta/pa_r.ml +++ b/camlp4/ocaml_src/meta/pa_r.ml @@ -51,6 +51,7 @@ 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; @@ -79,19 +80,22 @@ let mkmatchcase loc p aso w e = in p, w, e ;; + +let neg_string n = + let len = String.length n in + if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1) else "-" ^ n +;; let mkumin loc f arg = match arg with - MLast.ExInt (_, n) when int_of_string n > 0 -> - let n = "-" ^ n in MLast.ExInt (loc, n) - | MLast.ExFlo (_, n) when float_of_string n > 0.0 -> - let n = "-" ^ n in MLast.ExFlo (loc, n) + MLast.ExInt (_, n) -> MLast.ExInt (loc, neg_string n) + | MLast.ExFlo (_, n) -> MLast.ExFlo (loc, neg_string n) | _ -> let f = "~" ^ f in MLast.ExApp (loc, MLast.ExLid (loc, f), arg) ;; let mkuminpat loc f is_int n = - if is_int then MLast.PaInt (loc, ("-" ^ n)) - else MLast.PaFlo (loc, ("-" ^ n)) + if is_int then MLast.PaInt (loc, neg_string n) + else MLast.PaFlo (loc, neg_string n) ;; let mklistexp loc last = @@ -160,26 +164,27 @@ Pcaml.sync.val := sync; *) let ipatt = Grammar.Entry.create gram "ipatt";; +let with_constr = Grammar.Entry.create gram "with_constr";; +let row_field = Grammar.Entry.create gram "row_field";; let not_yet_warned_variant = ref true;; -let warn_variant () = +let warn_variant loc = if !not_yet_warned_variant then begin not_yet_warned_variant := false; - Printf.eprintf "\ -*** warning: use of syntax of variants types deprecated since version 3.05\n"; - flush stderr + !(Pcaml.warning) loc + (Printf.sprintf + "use of syntax of variants types deprecated since version 3.05") end ;; let not_yet_warned = ref true;; -let warn_sequence () = +let warn_sequence loc = if !not_yet_warned then begin not_yet_warned := false; - Printf.eprintf "\ -*** warning: use of syntax of sequences deprecated since version 3.01.1\n"; - flush stderr + !(Pcaml.warning) loc + "use of syntax of sequences deprecated since version 3.01.1" end ;; Pcaml.add_option "-no_warn_seq" (Arg.Clear not_yet_warned) @@ -198,7 +203,10 @@ Grammar.extend and _ = (class_sig_item : 'class_sig_item Grammar.Entry.e) and _ = (class_str_item : 'class_str_item Grammar.Entry.e) and _ = (let_binding : 'let_binding Grammar.Entry.e) - and _ = (ipatt : 'ipatt Grammar.Entry.e) in + and _ = (type_declaration : 'type_declaration Grammar.Entry.e) + and _ = (ipatt : 'ipatt Grammar.Entry.e) + and _ = (with_constr : 'with_constr Grammar.Entry.e) + and _ = (row_field : 'row_field Grammar.Entry.e) in let grammar_entry_create s = Grammar.Entry.create (Grammar.of_entry sig_item) s in @@ -208,8 +216,6 @@ Grammar.extend grammar_entry_create "module_binding" and module_declaration : 'module_declaration Grammar.Entry.e = grammar_entry_create "module_declaration" - and with_constr : 'with_constr Grammar.Entry.e = - grammar_entry_create "with_constr" and cons_expr_opt : 'cons_expr_opt Grammar.Entry.e = grammar_entry_create "cons_expr_opt" and dummy : 'dummy Grammar.Entry.e = grammar_entry_create "dummy" @@ -235,8 +241,6 @@ Grammar.extend grammar_entry_create "patt_label_ident" and label_ipatt : 'label_ipatt Grammar.Entry.e = grammar_entry_create "label_ipatt" - and type_declaration : 'type_declaration Grammar.Entry.e = - grammar_entry_create "type_declaration" and type_patt : 'type_patt Grammar.Entry.e = grammar_entry_create "type_patt" and constrain : 'constrain Grammar.Entry.e = @@ -260,11 +264,13 @@ Grammar.extend grammar_entry_create "class_fun_def" and class_structure : 'class_structure Grammar.Entry.e = grammar_entry_create "class_structure" - and class_self_patt_opt : 'class_self_patt_opt Grammar.Entry.e = - grammar_entry_create "class_self_patt_opt" - and as_lident_opt : 'as_lident_opt Grammar.Entry.e = - grammar_entry_create "as_lident_opt" - and cvalue : 'cvalue Grammar.Entry.e = grammar_entry_create "cvalue" + and class_self_patt : 'class_self_patt Grammar.Entry.e = + grammar_entry_create "class_self_patt" + and as_lident : 'as_lident Grammar.Entry.e = + grammar_entry_create "as_lident" + and polyt : 'polyt Grammar.Entry.e = grammar_entry_create "polyt" + and cvalue_binding : 'cvalue_binding Grammar.Entry.e = + grammar_entry_create "cvalue_binding" and label : 'label Grammar.Entry.e = grammar_entry_create "label" and class_self_type : 'class_self_type Grammar.Entry.e = grammar_entry_create "class_self_type" @@ -272,10 +278,8 @@ Grammar.extend grammar_entry_create "class_description" and class_type_declaration : 'class_type_declaration Grammar.Entry.e = grammar_entry_create "class_type_declaration" - and field_expr_list : 'field_expr_list Grammar.Entry.e = - grammar_entry_create "field_expr_list" - and meth_list : 'meth_list Grammar.Entry.e = - grammar_entry_create "meth_list" + and field_expr : 'field_expr Grammar.Entry.e = + grammar_entry_create "field_expr" and field : 'field Grammar.Entry.e = grammar_entry_create "field" and typevar : 'typevar Grammar.Entry.e = grammar_entry_create "typevar" and clty_longident : 'clty_longident Grammar.Entry.e = @@ -284,16 +288,14 @@ Grammar.extend grammar_entry_create "class_longident" and row_field_list : 'row_field_list Grammar.Entry.e = grammar_entry_create "row_field_list" - and row_field : 'row_field Grammar.Entry.e = - grammar_entry_create "row_field" and name_tag : 'name_tag Grammar.Entry.e = grammar_entry_create "name_tag" - and rec_flag : 'rec_flag Grammar.Entry.e = grammar_entry_create "rec_flag" + and patt_tcon : 'patt_tcon Grammar.Entry.e = + grammar_entry_create "patt_tcon" + and ipatt_tcon : 'ipatt_tcon Grammar.Entry.e = + grammar_entry_create "ipatt_tcon" + and eq_expr : 'eq_expr Grammar.Entry.e = grammar_entry_create "eq_expr" and direction_flag : 'direction_flag Grammar.Entry.e = grammar_entry_create "direction_flag" - and mutable_flag : 'mutable_flag Grammar.Entry.e = - grammar_entry_create "mutable_flag" - and virtual_flag : 'virtual_flag Grammar.Entry.e = - grammar_entry_create "virtual_flag" and warning_variant : 'warning_variant Grammar.Entry.e = grammar_entry_create "warning_variant" and warning_sequence : 'warning_sequence Grammar.Entry.e = @@ -356,15 +358,15 @@ Grammar.extend (fun (e : 'expr) (loc : int * int) -> (MLast.StExp (loc, e) : 'str_item)); [Gramext.Stoken ("", "value"); - Gramext.Snterm - (Grammar.Entry.obj (rec_flag : 'rec_flag Grammar.Entry.e)); + Gramext.Sopt (Gramext.Stoken ("", "rec")); Gramext.Slist1sep (Gramext.Snterm (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (l : 'let_binding list) (r : 'rec_flag) _ (loc : int * int) -> - (MLast.StVal (loc, r, l) : 'str_item)); + (fun (l : 'let_binding list) (r : string option) _ + (loc : int * int) -> + (MLast.StVal (loc, o2b r, l) : 'str_item)); [Gramext.Stoken ("", "type"); Gramext.Slist1sep (Gramext.Snterm @@ -736,28 +738,25 @@ Grammar.extend (fun (e : 'expr) _ (mb : 'module_binding) (m : string) _ _ (loc : int * int) -> (MLast.ExLmd (loc, m, mb, e) : 'expr)); - [Gramext.Stoken ("", "let"); - Gramext.Snterm - (Grammar.Entry.obj (rec_flag : 'rec_flag Grammar.Entry.e)); + [Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec")); Gramext.Slist1sep (Gramext.Snterm (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)), Gramext.Stoken ("", "and")); Gramext.Stoken ("", "in"); Gramext.Sself], Gramext.action - (fun (x : 'expr) _ (l : 'let_binding list) (r : 'rec_flag) _ + (fun (x : 'expr) _ (l : 'let_binding list) (r : string option) _ (loc : int * int) -> - (MLast.ExLet (loc, r, l, x) : 'expr))]; + (MLast.ExLet (loc, o2b r, l, x) : 'expr))]; Some "where", None, [[Gramext.Sself; Gramext.Stoken ("", "where"); - Gramext.Snterm - (Grammar.Entry.obj (rec_flag : 'rec_flag Grammar.Entry.e)); + Gramext.Sopt (Gramext.Stoken ("", "rec")); Gramext.Snterm (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e))], Gramext.action - (fun (lb : 'let_binding) (rf : 'rec_flag) _ (e : 'expr) + (fun (lb : 'let_binding) (rf : string option) _ (e : 'expr) (loc : int * int) -> - (MLast.ExLet (loc, rf, [lb], e) : 'expr))]; + (MLast.ExLet (loc, o2b rf, [lb], e) : 'expr))]; Some ":=", Some Gramext.NonA, [[Gramext.Sself; Gramext.Stoken ("", ":="); Gramext.Sself; Gramext.Snterm (Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e))], @@ -1086,9 +1085,7 @@ Grammar.extend Gramext.action (fun (el : 'sequence) _ (e : 'expr) (loc : int * int) -> (e :: el : 'sequence)); - [Gramext.Stoken ("", "let"); - Gramext.Snterm - (Grammar.Entry.obj (rec_flag : 'rec_flag Grammar.Entry.e)); + [Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec")); Gramext.Slist1sep (Gramext.Snterm (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)), @@ -1100,9 +1097,9 @@ Grammar.extend Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__5))]; Gramext.Sself], Gramext.action - (fun (el : 'sequence) _ (l : 'let_binding list) (rf : 'rec_flag) _ + (fun (el : 'sequence) _ (l : 'let_binding list) (rf : string option) _ (loc : int * int) -> - ([MLast.ExLet (loc, rf, l, mksequence loc el)] : 'sequence))]]; + ([MLast.ExLet (loc, o2b rf, l, mksequence loc el)] : 'sequence))]]; Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e), None, [None, None, [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); @@ -1539,13 +1536,12 @@ Grammar.extend None, [None, None, [[Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (mutable_flag : 'mutable_flag Grammar.Entry.e)); + Gramext.Sopt (Gramext.Stoken ("", "mutable")); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t : 'ctyp) (mf : 'mutable_flag) _ (i : string) + (fun (t : 'ctyp) (mf : string option) _ (i : string) (loc : int * int) -> - (loc, i, mf, t : 'label_declaration))]]; + (loc, i, o2b mf, t : 'label_declaration))]]; Grammar.Entry.obj (ident : 'ident Grammar.Entry.e), None, [None, None, [[Gramext.Stoken ("UIDENT", "")], @@ -1611,8 +1607,7 @@ Grammar.extend (class_declaration : 'class_declaration Grammar.Entry.e), None, [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (virtual_flag : 'virtual_flag Grammar.Entry.e)); + [[Gramext.Sopt (Gramext.Stoken ("", "virtual")); Gramext.Stoken ("LIDENT", ""); Gramext.Snterm (Grammar.Entry.obj @@ -1622,8 +1617,8 @@ Grammar.extend (class_fun_binding : 'class_fun_binding Grammar.Entry.e))], Gramext.action (fun (cfb : 'class_fun_binding) (ctp : 'class_type_parameters) - (i : string) (vf : 'virtual_flag) (loc : int * int) -> - ({MLast.ciLoc = loc; MLast.ciVir = vf; MLast.ciPrm = ctp; + (i : string) (vf : string option) (loc : int * int) -> + ({MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; MLast.ciNam = i; MLast.ciExp = cfb} : 'class_declaration))]]; Grammar.Entry.obj @@ -1681,18 +1676,16 @@ Grammar.extend (MLast.CeFun (loc, p, ce) : 'class_fun_def))]]; Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), None, [Some "top", None, - [[Gramext.Stoken ("", "let"); - Gramext.Snterm - (Grammar.Entry.obj (rec_flag : 'rec_flag Grammar.Entry.e)); + [[Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec")); Gramext.Slist1sep (Gramext.Snterm (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)), Gramext.Stoken ("", "and")); Gramext.Stoken ("", "in"); Gramext.Sself], Gramext.action - (fun (ce : 'class_expr) _ (lb : 'let_binding list) (rf : 'rec_flag) _ - (loc : int * int) -> - (MLast.CeLet (loc, rf, lb, ce) : 'class_expr)); + (fun (ce : 'class_expr) _ (lb : 'let_binding list) + (rf : string option) _ (loc : int * int) -> + (MLast.CeLet (loc, o2b rf, lb, ce) : 'class_expr)); [Gramext.Stoken ("", "fun"); Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); Gramext.Snterm @@ -1704,7 +1697,7 @@ Grammar.extend Some "apply", Some Gramext.NonA, [[Gramext.Sself; Gramext.Snterml - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), "simple")], + (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), "label")], Gramext.action (fun (e : 'expr) (ce : 'class_expr) (loc : int * int) -> (MLast.CeApp (loc, ce, e) : 'class_expr))]; @@ -1720,15 +1713,16 @@ Grammar.extend (fun _ (ct : 'class_type) _ (ce : 'class_expr) _ (loc : int * int) -> (MLast.CeTyc (loc, ce, ct) : 'class_expr)); [Gramext.Stoken ("", "object"); - Gramext.Snterm - (Grammar.Entry.obj - (class_self_patt_opt : 'class_self_patt_opt Grammar.Entry.e)); + Gramext.Sopt + (Gramext.Snterm + (Grammar.Entry.obj + (class_self_patt : 'class_self_patt Grammar.Entry.e))); Gramext.Snterm (Grammar.Entry.obj (class_structure : 'class_structure Grammar.Entry.e)); Gramext.Stoken ("", "end")], Gramext.action - (fun _ (cf : 'class_structure) (cspo : 'class_self_patt_opt) _ + (fun _ (cf : 'class_structure) (cspo : 'class_self_patt option) _ (loc : int * int) -> (MLast.CeStr (loc, cspo, cf) : 'class_expr)); [Gramext.Snterm @@ -1764,26 +1758,22 @@ Grammar.extend Gramext.action (fun (cf : 'e__6 list) (loc : int * int) -> (cf : 'class_structure))]]; - Grammar.Entry.obj - (class_self_patt_opt : 'class_self_patt_opt Grammar.Entry.e), + Grammar.Entry.obj (class_self_patt : 'class_self_patt Grammar.Entry.e), None, [None, None, - [[], - Gramext.action (fun (loc : int * int) -> (None : 'class_self_patt_opt)); - [Gramext.Stoken ("", "("); + [[Gramext.Stoken ("", "("); Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("", ")")], Gramext.action (fun _ (t : 'ctyp) _ (p : 'patt) _ (loc : int * int) -> - (Some (MLast.PaTyc (loc, p, t)) : 'class_self_patt_opt)); + (MLast.PaTyc (loc, p, t) : 'class_self_patt)); [Gramext.Stoken ("", "("); Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); Gramext.Stoken ("", ")")], Gramext.action - (fun _ (p : 'patt) _ (loc : int * int) -> - (Some p : 'class_self_patt_opt))]]; + (fun _ (p : 'patt) _ (loc : int * int) -> (p : 'class_self_patt))]]; Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e), None, [None, None, @@ -1800,65 +1790,45 @@ Grammar.extend (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> (MLast.CrCtr (loc, t1, t2) : 'class_str_item)); [Gramext.Stoken ("", "method"); + Gramext.Sopt (Gramext.Stoken ("", "private")); Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); + Gramext.Sopt + (Gramext.Snterm + (Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e))); Gramext.Snterm (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], Gramext.action - (fun (fb : 'fun_binding) (l : 'label) _ (loc : int * int) -> - (MLast.CrMth (loc, l, false, fb, None) : 'class_str_item)); - [Gramext.Stoken ("", "method"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (l : 'label) _ (loc : int * int) -> - (MLast.CrMth (loc, l, false, e, Some t) : 'class_str_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "private"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (fb : 'fun_binding) (l : 'label) _ _ (loc : int * int) -> - (MLast.CrMth (loc, l, true, fb, None) : 'class_str_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "private"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (l : 'label) _ _ (loc : int * int) -> - (MLast.CrMth (loc, l, true, e, Some t) : 'class_str_item)); + (fun (e : 'fun_binding) (topt : 'polyt option) (l : 'label) + (pf : string option) _ (loc : int * int) -> + (MLast.CrMth (loc, l, o2b pf, e, topt) : 'class_str_item)); [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); + Gramext.Sopt (Gramext.Stoken ("", "private")); Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t : 'ctyp) _ (l : 'label) _ _ (loc : int * int) -> - (MLast.CrVir (loc, l, false, t) : 'class_str_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.Stoken ("", "private"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) _ _ _ (loc : int * int) -> - (MLast.CrVir (loc, l, true, t) : 'class_str_item)); + (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _ + (loc : int * int) -> + (MLast.CrVir (loc, l, o2b pf, t) : 'class_str_item)); [Gramext.Stoken ("", "value"); - Gramext.Snterm (Grammar.Entry.obj (cvalue : 'cvalue Grammar.Entry.e))], + Gramext.Sopt (Gramext.Stoken ("", "mutable")); + Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); + Gramext.Snterm + (Grammar.Entry.obj + (cvalue_binding : 'cvalue_binding Grammar.Entry.e))], Gramext.action - (fun (lab, mf, e : 'cvalue) _ (loc : int * int) -> - (MLast.CrVal (loc, lab, mf, e) : 'class_str_item)); + (fun (e : 'cvalue_binding) (lab : 'label) (mf : string option) _ + (loc : int * int) -> + (MLast.CrVal (loc, lab, o2b mf, e) : 'class_str_item)); [Gramext.Stoken ("", "inherit"); Gramext.Snterm (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (as_lident_opt : 'as_lident_opt Grammar.Entry.e))], + Gramext.Sopt + (Gramext.Snterm + (Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e)))], Gramext.action - (fun (pb : 'as_lident_opt) (ce : 'class_expr) _ (loc : int * int) -> + (fun (pb : 'as_lident option) (ce : 'class_expr) _ + (loc : int * int) -> (MLast.CrInh (loc, ce, pb) : 'class_str_item)); [Gramext.Stoken ("", "declare"); Gramext.Slist0 @@ -1874,58 +1844,46 @@ Grammar.extend Gramext.action (fun _ (st : 'e__7 list) _ (loc : int * int) -> (MLast.CrDcl (loc, st) : 'class_str_item))]]; - Grammar.Entry.obj (as_lident_opt : 'as_lident_opt Grammar.Entry.e), None, + Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e), None, [None, None, - [[], Gramext.action (fun (loc : int * int) -> (None : 'as_lident_opt)); - [Gramext.Stoken ("", "as"); Gramext.Stoken ("LIDENT", "")], + [[Gramext.Stoken ("", "as"); Gramext.Stoken ("LIDENT", "")], Gramext.action - (fun (i : string) _ (loc : int * int) -> (Some i : 'as_lident_opt))]]; - Grammar.Entry.obj (cvalue : 'cvalue Grammar.Entry.e), None, + (fun (i : string) _ (loc : int * int) -> (i : 'as_lident))]]; + Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e), None, [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (mutable_flag : 'mutable_flag Grammar.Entry.e)); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":>"); + [[Gramext.Stoken ("", ":"); + Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], + Gramext.action (fun (t : 'ctyp) _ (loc : int * int) -> (t : 'polyt))]]; + Grammar.Entry.obj (cvalue_binding : 'cvalue_binding Grammar.Entry.e), + None, + [None, None, + [[Gramext.Stoken ("", ":>"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (l : 'label) (mf : 'mutable_flag) - (loc : int * int) -> - (l, mf, MLast.ExCoe (loc, e, None, t) : 'cvalue)); - [Gramext.Snterm - (Grammar.Entry.obj (mutable_flag : 'mutable_flag Grammar.Entry.e)); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); + (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> + (MLast.ExCoe (loc, e, None, t) : 'cvalue_binding)); + [Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("", ":>"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _ (l : 'label) - (mf : 'mutable_flag) (loc : int * int) -> - (l, mf, MLast.ExCoe (loc, e, Some t, t2) : 'cvalue)); - [Gramext.Snterm - (Grammar.Entry.obj (mutable_flag : 'mutable_flag Grammar.Entry.e)); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); + (fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _ (loc : int * int) -> + (MLast.ExCoe (loc, e, Some t, t2) : 'cvalue_binding)); + [Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (l : 'label) (mf : 'mutable_flag) - (loc : int * int) -> - (l, mf, MLast.ExTyc (loc, e, t) : 'cvalue)); - [Gramext.Snterm - (Grammar.Entry.obj (mutable_flag : 'mutable_flag Grammar.Entry.e)); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", "="); + (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> + (MLast.ExTyc (loc, e, t) : 'cvalue_binding)); + [Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (l : 'label) (mf : 'mutable_flag) - (loc : int * int) -> - (l, mf, e : 'cvalue))]]; + (fun (e : 'expr) _ (loc : int * int) -> (e : 'cvalue_binding))]]; Grammar.Entry.obj (label : 'label Grammar.Entry.e), None, [None, None, [[Gramext.Stoken ("LIDENT", "")], @@ -1993,44 +1951,32 @@ Grammar.extend (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> (MLast.CgCtr (loc, t1, t2) : 'class_sig_item)); [Gramext.Stoken ("", "method"); + Gramext.Sopt (Gramext.Stoken ("", "private")); Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t : 'ctyp) _ (l : 'label) _ (loc : int * int) -> - (MLast.CgMth (loc, l, false, t) : 'class_sig_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "private"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) _ _ (loc : int * int) -> - (MLast.CgMth (loc, l, true, t) : 'class_sig_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) _ _ (loc : int * int) -> - (MLast.CgVir (loc, l, false, t) : 'class_sig_item)); + (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ + (loc : int * int) -> + (MLast.CgMth (loc, l, o2b pf, t) : 'class_sig_item)); [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.Stoken ("", "private"); + Gramext.Sopt (Gramext.Stoken ("", "private")); Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t : 'ctyp) _ (l : 'label) _ _ _ (loc : int * int) -> - (MLast.CgVir (loc, l, true, t) : 'class_sig_item)); + (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _ + (loc : int * int) -> + (MLast.CgVir (loc, l, o2b pf, t) : 'class_sig_item)); [Gramext.Stoken ("", "value"); - Gramext.Snterm - (Grammar.Entry.obj (mutable_flag : 'mutable_flag Grammar.Entry.e)); + Gramext.Sopt (Gramext.Stoken ("", "mutable")); Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (mf : 'mutable_flag) _ + (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _ (loc : int * int) -> - (MLast.CgVal (loc, l, mf, t) : 'class_sig_item)); + (MLast.CgVal (loc, l, o2b mf, t) : 'class_sig_item)); [Gramext.Stoken ("", "inherit"); Gramext.Snterm (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], @@ -2055,8 +2001,7 @@ Grammar.extend (class_description : 'class_description Grammar.Entry.e), None, [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (virtual_flag : 'virtual_flag Grammar.Entry.e)); + [[Gramext.Sopt (Gramext.Stoken ("", "virtual")); Gramext.Stoken ("LIDENT", ""); Gramext.Snterm (Grammar.Entry.obj @@ -2066,16 +2011,15 @@ Grammar.extend (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], Gramext.action (fun (ct : 'class_type) _ (ctp : 'class_type_parameters) (n : string) - (vf : 'virtual_flag) (loc : int * int) -> - ({MLast.ciLoc = loc; MLast.ciVir = vf; MLast.ciPrm = ctp; + (vf : string option) (loc : int * int) -> + ({MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; MLast.ciNam = n; MLast.ciExp = ct} : 'class_description))]]; Grammar.Entry.obj (class_type_declaration : 'class_type_declaration Grammar.Entry.e), None, [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (virtual_flag : 'virtual_flag Grammar.Entry.e)); + [[Gramext.Sopt (Gramext.Stoken ("", "virtual")); Gramext.Stoken ("LIDENT", ""); Gramext.Snterm (Grammar.Entry.obj @@ -2085,8 +2029,8 @@ Grammar.extend (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], Gramext.action (fun (cs : 'class_type) _ (ctp : 'class_type_parameters) (n : string) - (vf : 'virtual_flag) (loc : int * int) -> - ({MLast.ciLoc = loc; MLast.ciVir = vf; MLast.ciPrm = ctp; + (vf : string option) (loc : int * int) -> + ({MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; MLast.ciNam = n; MLast.ciExp = cs} : 'class_type_declaration))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), @@ -2111,16 +2055,14 @@ Grammar.extend Some (Gramext.Level "simple"), [None, None, [[Gramext.Stoken ("", "{<"); - Gramext.Snterm - (Grammar.Entry.obj - (field_expr_list : 'field_expr_list Grammar.Entry.e)); + Gramext.Slist0sep + (Gramext.Snterm + (Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e)), + Gramext.Stoken ("", ";")); Gramext.Stoken ("", ">}")], Gramext.action - (fun _ (fel : 'field_expr_list) _ (loc : int * int) -> + (fun _ (fel : 'field_expr list) _ (loc : int * int) -> (MLast.ExOvr (loc, fel) : 'expr)); - [Gramext.Stoken ("", "{<"); Gramext.Stoken ("", ">}")], - Gramext.action - (fun _ _ (loc : int * int) -> (MLast.ExOvr (loc, []) : 'expr)); [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":>"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("", ")")], @@ -2135,43 +2077,25 @@ Grammar.extend Gramext.action (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) -> (MLast.ExCoe (loc, e, Some t, t2) : 'expr))]]; - Grammar.Entry.obj (field_expr_list : 'field_expr_list Grammar.Entry.e), - None, + Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e), None, [None, None, [[Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action (fun (e : 'expr) _ (l : 'label) (loc : int * int) -> - ([l, e] : 'field_expr_list)); - [Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) _ (l : 'label) (loc : int * int) -> - ([l, e] : 'field_expr_list)); - [Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";"); Gramext.Sself], - Gramext.action - (fun (fel : 'field_expr_list) _ (e : 'expr) _ (l : 'label) - (loc : int * int) -> - ((l, e) :: fel : 'field_expr_list))]]; + (l, e : 'field_expr))]]; Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), Some (Gramext.Level "simple"), [None, None, - [[Gramext.Stoken ("", "<"); Gramext.Stoken ("", ">")], - Gramext.action - (fun _ _ (loc : int * int) -> (MLast.TyObj (loc, [], false) : 'ctyp)); - [Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj (meth_list : 'meth_list Grammar.Entry.e)); - Gramext.Stoken ("", ">")], + [[Gramext.Stoken ("", "<"); + Gramext.Slist0sep + (Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e)), + Gramext.Stoken ("", ";")); + Gramext.Sopt (Gramext.Stoken ("", "..")); Gramext.Stoken ("", ">")], Gramext.action - (fun _ (ml, v : 'meth_list) _ (loc : int * int) -> - (MLast.TyObj (loc, ml, v) : 'ctyp)); + (fun _ (v : string option) (ml : 'field list) _ (loc : int * int) -> + (MLast.TyObj (loc, ml, o2b v) : 'ctyp)); [Gramext.Stoken ("", "#"); Gramext.Snterm (Grammar.Entry.obj @@ -2179,22 +2103,6 @@ Grammar.extend Gramext.action (fun (id : 'class_longident) _ (loc : int * int) -> (MLast.TyCls (loc, id) : 'ctyp))]]; - Grammar.Entry.obj (meth_list : 'meth_list Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "..")], - Gramext.action (fun _ (loc : int * int) -> ([], true : 'meth_list)); - [Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e))], - Gramext.action - (fun (f : 'field) (loc : int * int) -> ([f], false : 'meth_list)); - [Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (f : 'field) (loc : int * int) -> ([f], false : 'meth_list)); - [Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e)); - Gramext.Stoken ("", ";"); Gramext.Sself], - Gramext.action - (fun (ml, v : 'meth_list) _ (f : 'field) (loc : int * int) -> - (f :: ml, v : 'meth_list))]]; Grammar.Entry.obj (field : 'field Grammar.Entry.e), None, [None, None, [[Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", ":"); @@ -2323,66 +2231,41 @@ Grammar.extend Some (Gramext.Level "simple"), [None, None, [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); - Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); + Gramext.Snterm + (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); + Gramext.Sopt + (Gramext.Snterm + (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); Gramext.Stoken ("", ")")], Gramext.action - (fun _ (e : 'expr) _ (t : 'ctyp) _ (i : string) _ _ + (fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ _ (loc : int * int) -> - (MLast.PaOlb - (loc, i, MLast.PaTyc (loc, MLast.PaLid (loc, i), t), Some e) : - 'patt)); - [Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); - Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (e : 'expr) _ (i : string) _ _ (loc : int * int) -> - (MLast.PaOlb (loc, i, MLast.PaLid (loc, i), Some e) : 'patt)); + (MLast.PaOlb (loc, "", Some (p, eo)) : 'patt)); [Gramext.Stoken ("QUESTIONIDENT", "")], Gramext.action (fun (i : string) (loc : int * int) -> - (MLast.PaOlb (loc, i, MLast.PaLid (loc, i), None) : 'patt)); + (MLast.PaOlb (loc, i, None) : 'patt)); [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); + Gramext.Stoken ("", "("); + Gramext.Snterm + (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); + Gramext.Sopt + (Gramext.Snterm + (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); Gramext.Stoken ("", ")")], Gramext.action - (fun _ (e : 'expr) _ (t : 'ctyp) _ (p : 'patt) _ _ (i : string) + (fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ _ (i : string) (loc : int * int) -> - (MLast.PaOlb (loc, i, MLast.PaTyc (loc, p, t), Some e) : 'patt)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'patt) _ _ (i : string) (loc : int * int) -> - (MLast.PaOlb (loc, i, MLast.PaTyc (loc, p, t), None) : 'patt)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (e : 'expr) _ (p : 'patt) _ _ (i : string) (loc : int * int) -> - (MLast.PaOlb (loc, i, p, Some e) : 'patt)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p : 'patt) _ _ (i : string) (loc : int * int) -> - (MLast.PaOlb (loc, i, p, None) : 'patt)); + (MLast.PaOlb (loc, i, Some (p, eo)) : 'patt)); [Gramext.Stoken ("TILDEIDENT", "")], Gramext.action (fun (i : string) (loc : int * int) -> - (MLast.PaLab (loc, i, MLast.PaLid (loc, i)) : 'patt)); + (MLast.PaLab (loc, i, None) : 'patt)); [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action (fun (p : 'patt) _ (i : string) (loc : int * int) -> - (MLast.PaLab (loc, i, p) : 'patt)); + (MLast.PaLab (loc, i, Some p) : 'patt)); [Gramext.Stoken ("", "#"); Gramext.Snterm (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], @@ -2394,92 +2277,92 @@ Grammar.extend Gramext.action (fun (s : 'ident) _ (loc : int * int) -> (MLast.PaVrn (loc, s) : 'patt))]]; + Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e), None, + [None, None, + [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], + Gramext.action (fun (p : 'patt) (loc : int * int) -> (p : 'patt_tcon)); + [Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); + Gramext.Stoken ("", ":"); + Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], + Gramext.action + (fun (t : 'ctyp) _ (p : 'patt) (loc : int * int) -> + (MLast.PaTyc (loc, p, t) : 'patt_tcon))]]; Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, [None, None, [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); - Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); + Gramext.Snterm + (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); + Gramext.Sopt + (Gramext.Snterm + (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); Gramext.Stoken ("", ")")], Gramext.action - (fun _ (e : 'expr) _ (t : 'ctyp) _ (i : string) _ _ + (fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ _ (loc : int * int) -> - (MLast.PaOlb - (loc, i, MLast.PaTyc (loc, MLast.PaLid (loc, i), t), Some e) : - 'ipatt)); - [Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); - Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (e : 'expr) _ (i : string) _ _ (loc : int * int) -> - (MLast.PaOlb (loc, i, MLast.PaLid (loc, i), Some e) : 'ipatt)); + (MLast.PaOlb (loc, "", Some (p, eo)) : 'ipatt)); [Gramext.Stoken ("QUESTIONIDENT", "")], Gramext.action (fun (i : string) (loc : int * int) -> - (MLast.PaOlb (loc, i, MLast.PaLid (loc, i), None) : 'ipatt)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (e : 'expr) _ (t : 'ctyp) _ (p : 'ipatt) _ _ (i : string) - (loc : int * int) -> - (MLast.PaOlb (loc, i, MLast.PaTyc (loc, p, t), Some e) : 'ipatt)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'ipatt) _ _ (i : string) - (loc : int * int) -> - (MLast.PaOlb (loc, i, MLast.PaTyc (loc, p, t), None) : 'ipatt)); + (MLast.PaOlb (loc, i, None) : 'ipatt)); [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); + Gramext.Stoken ("", "("); + Gramext.Snterm + (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); + Gramext.Sopt + (Gramext.Snterm + (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); Gramext.Stoken ("", ")")], Gramext.action - (fun _ (e : 'expr) _ (p : 'ipatt) _ _ (i : string) + (fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ _ (i : string) (loc : int * int) -> - (MLast.PaOlb (loc, i, p, Some e) : 'ipatt)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p : 'ipatt) _ _ (i : string) (loc : int * int) -> - (MLast.PaOlb (loc, i, p, None) : 'ipatt)); + (MLast.PaOlb (loc, i, Some (p, eo)) : 'ipatt)); [Gramext.Stoken ("TILDEIDENT", "")], Gramext.action (fun (i : string) (loc : int * int) -> - (MLast.PaLab (loc, i, MLast.PaLid (loc, i)) : 'ipatt)); + (MLast.PaLab (loc, i, None) : 'ipatt)); [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action (fun (p : 'ipatt) _ (i : string) (loc : int * int) -> - (MLast.PaLab (loc, i, p) : 'ipatt))]]; + (MLast.PaLab (loc, i, Some p) : 'ipatt))]]; + Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e), None, + [None, None, + [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))], + Gramext.action + (fun (p : 'ipatt) (loc : int * int) -> (p : 'ipatt_tcon)); + [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); + Gramext.Stoken ("", ":"); + Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], + Gramext.action + (fun (t : 'ctyp) _ (p : 'ipatt) (loc : int * int) -> + (MLast.PaTyc (loc, p, t) : 'ipatt_tcon))]]; + Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e), None, + [None, None, + [[Gramext.Stoken ("", "="); + Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], + Gramext.action + (fun (e : 'expr) _ (loc : int * int) -> (e : 'eq_expr))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), Some (Gramext.After "apply"), [Some "label", Some Gramext.NonA, [[Gramext.Stoken ("QUESTIONIDENT", "")], Gramext.action (fun (i : string) (loc : int * int) -> - (MLast.ExOlb (loc, i, MLast.ExLid (loc, i)) : 'expr)); + (MLast.ExOlb (loc, i, None) : 'expr)); [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action (fun (e : 'expr) _ (i : string) (loc : int * int) -> - (MLast.ExOlb (loc, i, e) : 'expr)); + (MLast.ExOlb (loc, i, Some e) : 'expr)); [Gramext.Stoken ("TILDEIDENT", "")], Gramext.action (fun (i : string) (loc : int * int) -> - (MLast.ExLab (loc, i, MLast.ExLid (loc, i)) : 'expr)); + (MLast.ExLab (loc, i, None) : 'expr)); [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action (fun (e : 'expr) _ (i : string) (loc : int * int) -> - (MLast.ExLab (loc, i, e) : 'expr))]]; + (MLast.ExLab (loc, i, Some e) : 'expr))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), Some (Gramext.Level "simple"), [None, None, @@ -2488,11 +2371,6 @@ Grammar.extend Gramext.action (fun (s : 'ident) _ (loc : int * int) -> (MLast.ExVrn (loc, s) : 'expr))]]; - Grammar.Entry.obj (rec_flag : 'rec_flag Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> (false : 'rec_flag)); - [Gramext.Stoken ("", "rec")], - Gramext.action (fun _ (loc : int * int) -> (true : 'rec_flag))]]; Grammar.Entry.obj (direction_flag : 'direction_flag Grammar.Entry.e), None, [None, None, @@ -2500,16 +2378,6 @@ Grammar.extend Gramext.action (fun _ (loc : int * int) -> (false : 'direction_flag)); [Gramext.Stoken ("", "to")], Gramext.action (fun _ (loc : int * int) -> (true : 'direction_flag))]]; - Grammar.Entry.obj (mutable_flag : 'mutable_flag Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> (false : 'mutable_flag)); - [Gramext.Stoken ("", "mutable")], - Gramext.action (fun _ (loc : int * int) -> (true : 'mutable_flag))]]; - Grammar.Entry.obj (virtual_flag : 'virtual_flag Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> (false : 'virtual_flag)); - [Gramext.Stoken ("", "virtual")], - Gramext.action (fun _ (loc : int * int) -> (true : 'virtual_flag))]]; Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), Some (Gramext.Level "simple"), [None, None, @@ -2570,7 +2438,7 @@ Grammar.extend [None, None, [[], Gramext.action - (fun (loc : int * int) -> (warn_variant () : 'warning_variant))]]; + (fun (loc : int * int) -> (warn_variant loc : 'warning_variant))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), Some (Gramext.Level "top"), [None, None, @@ -2632,7 +2500,7 @@ Grammar.extend [[], Gramext.action (fun (loc : int * int) -> - (warn_sequence () : 'warning_sequence))]]]);; + (warn_sequence loc : 'warning_sequence))]]]);; Grammar.extend (let _ = (interf : 'interf Grammar.Entry.e) diff --git a/camlp4/ocaml_src/meta/pr_dump.ml b/camlp4/ocaml_src/meta/pr_dump.ml index af7744b6a..db4228531 100644 --- a/camlp4/ocaml_src/meta/pr_dump.ml +++ b/camlp4/ocaml_src/meta/pr_dump.ml @@ -21,8 +21,9 @@ let open_out_file () = let interf ast = let pt = Ast2pt.interf (List.map fst ast) in let oc = open_out_file () in + let fname = !(Pcaml.input_file) in output_string oc Config.ast_intf_magic_number; - output_value oc !(Pcaml.input_file); + output_value oc (if fname = "-" then "" else fname); output_value oc pt; flush oc; match !(Pcaml.output_file) with @@ -33,8 +34,9 @@ let interf ast = let implem ast = let pt = Ast2pt.implem (List.map fst ast) in let oc = open_out_file () in + let fname = !(Pcaml.input_file) in output_string oc Config.ast_impl_magic_number; - output_value oc !(Pcaml.input_file); + output_value oc (if fname = "-" then "" else fname); output_value oc pt; flush oc; match !(Pcaml.output_file) with diff --git a/camlp4/ocaml_src/meta/q_MLast.ml b/camlp4/ocaml_src/meta/q_MLast.ml index f5a41f5c0..7045185f4 100644 --- a/camlp4/ocaml_src/meta/q_MLast.ml +++ b/camlp4/ocaml_src/meta/q_MLast.ml @@ -140,6 +140,9 @@ let class_str_item = Grammar.Entry.create gram "class structure item";; let ipatt = Grammar.Entry.create gram "ipatt";; let let_binding = Grammar.Entry.create gram "let_binding";; +let type_declaration = Grammar.Entry.create gram "type_declaration";; +let with_constr = Grammar.Entry.create gram "with_constr";; +let row_field = Grammar.Entry.create gram "row_field";; let a_list = Grammar.Entry.create gram "a_list";; let a_opt = Grammar.Entry.create gram "a_opt";; @@ -175,13 +178,18 @@ let mkmatchcase _ p aso w e = Qast.Tuple [p; w; e] ;; +let neg_string n = + let len = String.length n in + if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1) else "-" ^ n +;; + let mkumin _ f arg = match arg with Qast.Node ("ExInt", [Qast.Loc; Qast.Str n]) when int_of_string n > 0 -> - let n = "-" ^ n in Qast.Node ("ExInt", [Qast.Loc; Qast.Str n]) + 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 = "-" ^ n in Qast.Node ("ExFlo", [Qast.Loc; Qast.Str n]) + let n = neg_string n in Qast.Node ("ExFlo", [Qast.Loc; Qast.Str n]) | _ -> match f with Qast.Str f -> @@ -193,6 +201,11 @@ let mkumin _ f arg = ;; let 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]) @@ -264,25 +277,36 @@ let mkassert _ e = let append_elem el e = Qast.Apply ("@", [el; Qast.List [e]]);; +let not_yet_warned_antiq = ref true;; +let warn_antiq loc vers = + if !not_yet_warned_antiq then + begin + not_yet_warned_antiq := false; + !(Pcaml.warning) loc + (Printf.sprintf + "use of antiquotation syntax deprecated since version %s" vers) + end +;; + let not_yet_warned_variant = ref true;; -let warn_variant () = +let warn_variant _ = if !not_yet_warned_variant then begin not_yet_warned_variant := false; - Printf.eprintf "\ -*** warning: use of syntax of variants types deprecated since version 3.05\n"; - flush stderr + !(Pcaml.warning) (0, 1) + (Printf.sprintf + "use of syntax of variants types deprecated since version 3.05") end ;; -let not_yet_warned = ref true;; -let warn_sequence () = - if !not_yet_warned then +let not_yet_warned_seq = ref true;; +let warn_sequence _ = + if !not_yet_warned_seq then begin - not_yet_warned := false; - Printf.eprintf "\ -*** warning: use of syntax of sequences deprecated since version 3.01.1\n"; - flush stderr + not_yet_warned_seq := false; + !(Pcaml.warning) (0, 1) + (Printf.sprintf + "use of syntax of sequences deprecated since version 3.01.1") end ;; @@ -299,7 +323,10 @@ Grammar.extend and _ = (class_sig_item : 'class_sig_item Grammar.Entry.e) and _ = (class_str_item : 'class_str_item Grammar.Entry.e) and _ = (let_binding : 'let_binding Grammar.Entry.e) - and _ = (ipatt : 'ipatt Grammar.Entry.e) in + and _ = (type_declaration : 'type_declaration Grammar.Entry.e) + and _ = (ipatt : 'ipatt Grammar.Entry.e) + and _ = (with_constr : 'with_constr Grammar.Entry.e) + and _ = (row_field : 'row_field Grammar.Entry.e) in let grammar_entry_create s = Grammar.Entry.create (Grammar.of_entry sig_item) s in @@ -309,8 +336,6 @@ Grammar.extend grammar_entry_create "module_binding" and module_declaration : 'module_declaration Grammar.Entry.e = grammar_entry_create "module_declaration" - and with_constr : 'with_constr Grammar.Entry.e = - grammar_entry_create "with_constr" and cons_expr_opt : 'cons_expr_opt Grammar.Entry.e = grammar_entry_create "cons_expr_opt" and dummy : 'dummy Grammar.Entry.e = grammar_entry_create "dummy" @@ -329,8 +354,6 @@ Grammar.extend grammar_entry_create "label_patt" and label_ipatt : 'label_ipatt Grammar.Entry.e = grammar_entry_create "label_ipatt" - and type_declaration : 'type_declaration Grammar.Entry.e = - grammar_entry_create "type_declaration" and type_patt : 'type_patt Grammar.Entry.e = grammar_entry_create "type_patt" and constrain : 'constrain Grammar.Entry.e = @@ -352,7 +375,13 @@ Grammar.extend grammar_entry_create "class_fun_def" and class_structure : 'class_structure Grammar.Entry.e = grammar_entry_create "class_structure" - and cvalue : 'cvalue Grammar.Entry.e = grammar_entry_create "cvalue" + and class_self_patt : 'class_self_patt Grammar.Entry.e = + grammar_entry_create "class_self_patt" + and as_lident : 'as_lident Grammar.Entry.e = + grammar_entry_create "as_lident" + and polyt : 'polyt Grammar.Entry.e = grammar_entry_create "polyt" + and cvalue_binding : 'cvalue_binding Grammar.Entry.e = + grammar_entry_create "cvalue_binding" and label : 'label Grammar.Entry.e = grammar_entry_create "label" and class_self_type : 'class_self_type Grammar.Entry.e = grammar_entry_create "class_self_type" @@ -360,15 +389,18 @@ Grammar.extend grammar_entry_create "class_description" and class_type_declaration : 'class_type_declaration Grammar.Entry.e = grammar_entry_create "class_type_declaration" - and field_expr_list : 'field_expr_list Grammar.Entry.e = - grammar_entry_create "field_expr_list" + and field_expr : 'field_expr Grammar.Entry.e = + grammar_entry_create "field_expr" and field : 'field Grammar.Entry.e = grammar_entry_create "field" and typevar : 'typevar Grammar.Entry.e = grammar_entry_create "typevar" and row_field_list : 'row_field_list Grammar.Entry.e = grammar_entry_create "row_field_list" - and row_field : 'row_field Grammar.Entry.e = - grammar_entry_create "row_field" and name_tag : 'name_tag Grammar.Entry.e = grammar_entry_create "name_tag" + and patt_tcon : 'patt_tcon Grammar.Entry.e = + grammar_entry_create "patt_tcon" + and ipatt_tcon : 'ipatt_tcon Grammar.Entry.e = + grammar_entry_create "ipatt_tcon" + and eq_expr : 'eq_expr Grammar.Entry.e = grammar_entry_create "eq_expr" and warning_variant : 'warning_variant Grammar.Entry.e = grammar_entry_create "warning_variant" and warning_sequence : 'warning_sequence Grammar.Entry.e = @@ -382,23 +414,12 @@ Grammar.extend grammar_entry_create "when_expr_opt" and mod_ident : 'mod_ident Grammar.Entry.e = grammar_entry_create "mod_ident" - and class_self_patt_opt : 'class_self_patt_opt Grammar.Entry.e = - grammar_entry_create "class_self_patt_opt" - and as_lident_opt : 'as_lident_opt Grammar.Entry.e = - grammar_entry_create "as_lident_opt" - and meth_list : 'meth_list Grammar.Entry.e = - grammar_entry_create "meth_list" and clty_longident : 'clty_longident Grammar.Entry.e = grammar_entry_create "clty_longident" and class_longident : 'class_longident Grammar.Entry.e = grammar_entry_create "class_longident" - and rec_flag : 'rec_flag Grammar.Entry.e = grammar_entry_create "rec_flag" and direction_flag : 'direction_flag Grammar.Entry.e = grammar_entry_create "direction_flag" - and mutable_flag : 'mutable_flag Grammar.Entry.e = - grammar_entry_create "mutable_flag" - and virtual_flag : 'virtual_flag Grammar.Entry.e = - grammar_entry_create "virtual_flag" in [Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e), None, [None, None, @@ -470,8 +491,20 @@ Grammar.extend (fun (e : 'expr) (loc : int * int) -> (Qast.Node ("StExp", [Qast.Loc; e]) : 'str_item)); [Gramext.Stoken ("", "value"); - Gramext.Snterm - (Grammar.Entry.obj (rec_flag : 'rec_flag Grammar.Entry.e)); + Gramext.srules + [[Gramext.Sopt + (Gramext.srules + [[Gramext.Stoken ("", "rec")], + Gramext.action + (fun (x : string) (loc : int * int) -> + (Qast.Str x : 'e__3))])], + Gramext.action + (fun (a : 'e__3 option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.srules [[Gramext.Slist1sep (Gramext.Snterm @@ -486,8 +519,8 @@ Grammar.extend Gramext.action (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], Gramext.action - (fun (l : 'a_list) (r : 'rec_flag) _ (loc : int * int) -> - (Qast.Node ("StVal", [Qast.Loc; r; l]) : 'str_item)); + (fun (l : 'a_list) (r : 'a_opt) _ (loc : int * int) -> + (Qast.Node ("StVal", [Qast.Loc; o2b r; l]) : 'str_item)); [Gramext.Stoken ("", "type"); Gramext.srules [[Gramext.Slist1sep @@ -571,7 +604,7 @@ Grammar.extend Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3 | _ -> match () with - _ -> raise (Match_failure ("q_MLast.ml", 274, 19)) + _ -> raise (Match_failure ("q_MLast.ml", 300, 19)) in Qast.Node ("StExc", [Qast.Loc; c; tl; b]) : 'str_item)); @@ -675,9 +708,9 @@ Grammar.extend Gramext.Stoken ("", ";")], Gramext.action (fun _ (s : 'sig_item) (loc : int * int) -> - (s : 'e__3))])], + (s : 'e__4))])], Gramext.action - (fun (a : 'e__3 list) (loc : int * int) -> + (fun (a : 'e__4 list) (loc : int * int) -> (Qast.List a : 'a_list)); [Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], @@ -807,7 +840,7 @@ Grammar.extend Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3 | _ -> match () with - _ -> raise (Match_failure ("q_MLast.ml", 326, 19)) + _ -> raise (Match_failure ("q_MLast.ml", 352, 19)) in Qast.Node ("SgExc", [Qast.Loc; c; tl]) : 'sig_item)); @@ -821,9 +854,9 @@ Grammar.extend Gramext.Stoken ("", ";")], Gramext.action (fun _ (s : 'sig_item) (loc : int * int) -> - (s : 'e__4))])], + (s : 'e__5))])], Gramext.action - (fun (a : 'e__4 list) (loc : int * int) -> + (fun (a : 'e__5 list) (loc : int * int) -> (Qast.List a : 'a_list)); [Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], @@ -1022,8 +1055,20 @@ Grammar.extend (loc : int * int) -> (Qast.Node ("ExLmd", [Qast.Loc; m; mb; e]) : 'expr)); [Gramext.Stoken ("", "let"); - Gramext.Snterm - (Grammar.Entry.obj (rec_flag : 'rec_flag Grammar.Entry.e)); + Gramext.srules + [[Gramext.Sopt + (Gramext.srules + [[Gramext.Stoken ("", "rec")], + Gramext.action + (fun (x : string) (loc : int * int) -> + (Qast.Str x : 'e__6))])], + Gramext.action + (fun (a : 'e__6 option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.srules [[Gramext.Slist1sep (Gramext.Snterm @@ -1039,19 +1084,31 @@ Grammar.extend (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; Gramext.Stoken ("", "in"); Gramext.Sself], Gramext.action - (fun (x : 'expr) _ (l : 'a_list) (r : 'rec_flag) _ - (loc : int * int) -> - (Qast.Node ("ExLet", [Qast.Loc; r; l; x]) : 'expr))]; + (fun (x : 'expr) _ (l : 'a_list) (r : 'a_opt) _ (loc : int * int) -> + (Qast.Node ("ExLet", [Qast.Loc; o2b r; l; x]) : 'expr))]; Some "where", None, [[Gramext.Sself; Gramext.Stoken ("", "where"); - Gramext.Snterm - (Grammar.Entry.obj (rec_flag : 'rec_flag Grammar.Entry.e)); + Gramext.srules + [[Gramext.Sopt + (Gramext.srules + [[Gramext.Stoken ("", "rec")], + Gramext.action + (fun (x : string) (loc : int * int) -> + (Qast.Str x : 'e__7))])], + Gramext.action + (fun (a : 'e__7 option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.Snterm (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e))], Gramext.action - (fun (lb : 'let_binding) (rf : 'rec_flag) _ (e : 'expr) + (fun (lb : 'let_binding) (rf : 'a_opt) _ (e : 'expr) (loc : int * int) -> - (Qast.Node ("ExLet", [Qast.Loc; rf; Qast.List [lb]; e]) : 'expr))]; + (Qast.Node ("ExLet", [Qast.Loc; o2b rf; Qast.List [lb]; e]) : + 'expr))]; Some ":=", Some Gramext.NonA, [[Gramext.Sself; Gramext.Stoken ("", ":="); Gramext.Sself; Gramext.Snterm (Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e))], @@ -1612,8 +1669,20 @@ Grammar.extend (fun (el : 'sequence) _ (e : 'expr) (loc : int * int) -> (Qast.Cons (e, el) : 'sequence)); [Gramext.Stoken ("", "let"); - Gramext.Snterm - (Grammar.Entry.obj (rec_flag : 'rec_flag Grammar.Entry.e)); + Gramext.srules + [[Gramext.Sopt + (Gramext.srules + [[Gramext.Stoken ("", "rec")], + Gramext.action + (fun (x : string) (loc : int * int) -> + (Qast.Str x : 'e__8))])], + Gramext.action + (fun (a : 'e__8 option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.srules [[Gramext.Slist1sep (Gramext.Snterm @@ -1629,16 +1698,16 @@ Grammar.extend (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; Gramext.srules [[Gramext.Stoken ("", ";")], - Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__5)); + Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__9)); [Gramext.Stoken ("", "in")], - Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__5))]; + Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__9))]; Gramext.Sself], Gramext.action - (fun (el : 'sequence) _ (l : 'a_list) (rf : 'rec_flag) _ + (fun (el : 'sequence) _ (l : 'a_list) (rf : 'a_opt) _ (loc : int * int) -> (Qast.List [Qast.Node - ("ExLet", [Qast.Loc; rf; l; mksequence Qast.Loc el])] : + ("ExLet", [Qast.Loc; o2b rf; l; mksequence Qast.Loc el])] : 'sequence))]]; Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e), None, [None, None, @@ -2238,13 +2307,24 @@ Grammar.extend [[Gramext.Snterm (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (mutable_flag : 'mutable_flag Grammar.Entry.e)); + Gramext.srules + [[Gramext.Sopt + (Gramext.srules + [[Gramext.Stoken ("", "mutable")], + Gramext.action + (fun (x : string) (loc : int * int) -> + (Qast.Str x : 'e__10))])], + Gramext.action + (fun (a : 'e__10 option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t : 'ctyp) (mf : 'mutable_flag) _ (i : 'a_LIDENT) - (loc : int * int) -> - (Qast.Tuple [Qast.Loc; i; mf; t] : 'label_declaration))]]; + (fun (t : 'ctyp) (mf : 'a_opt) _ (i : 'a_LIDENT) (loc : int * int) -> + (Qast.Tuple [Qast.Loc; i; o2b mf; t] : 'label_declaration))]]; Grammar.Entry.obj (ident : 'ident Grammar.Entry.e), None, [None, None, [[Gramext.Snterm @@ -2350,8 +2430,20 @@ Grammar.extend (class_declaration : 'class_declaration Grammar.Entry.e), None, [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (virtual_flag : 'virtual_flag Grammar.Entry.e)); + [[Gramext.srules + [[Gramext.Sopt + (Gramext.srules + [[Gramext.Stoken ("", "virtual")], + Gramext.action + (fun (x : string) (loc : int * int) -> + (Qast.Str x : 'e__11))])], + Gramext.action + (fun (a : 'e__11 option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.Snterm (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); Gramext.Snterm @@ -2362,9 +2454,9 @@ Grammar.extend (class_fun_binding : 'class_fun_binding Grammar.Entry.e))], Gramext.action (fun (cfb : 'class_fun_binding) (ctp : 'class_type_parameters) - (i : 'a_LIDENT) (vf : 'virtual_flag) (loc : int * int) -> + (i : 'a_LIDENT) (vf : 'a_opt) (loc : int * int) -> (Qast.Record - ["ciLoc", Qast.Loc; "ciVir", vf; "ciPrm", ctp; "ciNam", i; + ["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", i; "ciExp", cfb] : 'class_declaration))]]; Grammar.Entry.obj @@ -2432,8 +2524,20 @@ Grammar.extend Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), None, [Some "top", None, [[Gramext.Stoken ("", "let"); - Gramext.Snterm - (Grammar.Entry.obj (rec_flag : 'rec_flag Grammar.Entry.e)); + Gramext.srules + [[Gramext.Sopt + (Gramext.srules + [[Gramext.Stoken ("", "rec")], + Gramext.action + (fun (x : string) (loc : int * int) -> + (Qast.Str x : 'e__12))])], + Gramext.action + (fun (a : 'e__12 option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.srules [[Gramext.Slist1sep (Gramext.Snterm @@ -2449,9 +2553,9 @@ Grammar.extend (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; Gramext.Stoken ("", "in"); Gramext.Sself], Gramext.action - (fun (ce : 'class_expr) _ (lb : 'a_list) (rf : 'rec_flag) _ + (fun (ce : 'class_expr) _ (lb : 'a_list) (rf : 'a_opt) _ (loc : int * int) -> - (Qast.Node ("CeLet", [Qast.Loc; rf; lb; ce]) : 'class_expr)); + (Qast.Node ("CeLet", [Qast.Loc; o2b rf; lb; ce]) : 'class_expr)); [Gramext.Stoken ("", "fun"); Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); Gramext.Snterm @@ -2463,7 +2567,7 @@ Grammar.extend Some "apply", Some Gramext.NonA, [[Gramext.Sself; Gramext.Snterml - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), "simple")], + (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), "label")], Gramext.action (fun (e : 'expr) (ce : 'class_expr) (loc : int * int) -> (Qast.Node ("CeApp", [Qast.Loc; ce; e]) : 'class_expr))]; @@ -2479,16 +2583,24 @@ Grammar.extend (fun _ (ct : 'class_type) _ (ce : 'class_expr) _ (loc : int * int) -> (Qast.Node ("CeTyc", [Qast.Loc; ce; ct]) : 'class_expr)); [Gramext.Stoken ("", "object"); - Gramext.Snterm - (Grammar.Entry.obj - (class_self_patt_opt : 'class_self_patt_opt Grammar.Entry.e)); + Gramext.srules + [[Gramext.Sopt + (Gramext.Snterm + (Grammar.Entry.obj + (class_self_patt : 'class_self_patt Grammar.Entry.e)))], + Gramext.action + (fun (a : 'class_self_patt option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.Snterm (Grammar.Entry.obj (class_structure : 'class_structure Grammar.Entry.e)); Gramext.Stoken ("", "end")], Gramext.action - (fun _ (cf : 'class_structure) (cspo : 'class_self_patt_opt) _ - (loc : int * int) -> + (fun _ (cf : 'class_structure) (cspo : 'a_opt) _ (loc : int * int) -> (Qast.Node ("CeStr", [Qast.Loc; cspo; cf]) : 'class_expr)); [Gramext.Snterm (Grammar.Entry.obj @@ -2528,9 +2640,9 @@ Grammar.extend Gramext.Stoken ("", ";")], Gramext.action (fun _ (cf : 'class_str_item) (loc : int * int) -> - (cf : 'e__6))])], + (cf : 'e__13))])], Gramext.action - (fun (a : 'e__6 list) (loc : int * int) -> + (fun (a : 'e__13 list) (loc : int * int) -> (Qast.List a : 'a_list)); [Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], @@ -2538,28 +2650,22 @@ Grammar.extend (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], Gramext.action (fun (cf : 'a_list) (loc : int * int) -> (cf : 'class_structure))]]; - Grammar.Entry.obj - (class_self_patt_opt : 'class_self_patt_opt Grammar.Entry.e), + Grammar.Entry.obj (class_self_patt : 'class_self_patt Grammar.Entry.e), None, [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> (Qast.Option None : 'class_self_patt_opt)); - [Gramext.Stoken ("", "("); + [[Gramext.Stoken ("", "("); Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("", ")")], Gramext.action (fun _ (t : 'ctyp) _ (p : 'patt) _ (loc : int * int) -> - (Qast.Option (Some (Qast.Node ("PaTyc", [Qast.Loc; p; t]))) : - 'class_self_patt_opt)); + (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'class_self_patt)); [Gramext.Stoken ("", "("); Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); Gramext.Stoken ("", ")")], Gramext.action - (fun _ (p : 'patt) _ (loc : int * int) -> - (Qast.Option (Some p) : 'class_self_patt_opt))]]; + (fun _ (p : 'patt) _ (loc : int * int) -> (p : 'class_self_patt))]]; Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e), None, [None, None, @@ -2576,86 +2682,101 @@ Grammar.extend (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> (Qast.Node ("CrCtr", [Qast.Loc; t1; t2]) : 'class_str_item)); [Gramext.Stoken ("", "method"); + Gramext.srules + [[Gramext.Sopt + (Gramext.srules + [[Gramext.Stoken ("", "private")], + Gramext.action + (fun (x : string) (loc : int * int) -> + (Qast.Str x : 'e__17))])], + Gramext.action + (fun (a : 'e__17 option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); + Gramext.srules + [[Gramext.Sopt + (Gramext.Snterm + (Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e)))], + Gramext.action + (fun (a : 'polyt option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.Snterm (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], Gramext.action - (fun (fb : 'fun_binding) (l : 'label) _ (loc : int * int) -> - (Qast.Node - ("CrMth", - [Qast.Loc; l; Qast.Bool false; fb; Qast.Option None]) : - 'class_str_item)); - [Gramext.Stoken ("", "method"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (l : 'label) _ (loc : int * int) -> - (Qast.Node - ("CrMth", - [Qast.Loc; l; Qast.Bool false; e; Qast.Option (Some t)]) : - 'class_str_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "private"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (fb : 'fun_binding) (l : 'label) _ _ (loc : int * int) -> - (Qast.Node - ("CrMth", [Qast.Loc; l; Qast.Bool true; fb; Qast.Option None]) : - 'class_str_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "private"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (l : 'label) _ _ (loc : int * int) -> - (Qast.Node - ("CrMth", - [Qast.Loc; l; Qast.Bool true; e; Qast.Option (Some t)]) : - 'class_str_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) _ _ (loc : int * int) -> - (Qast.Node ("CrVir", [Qast.Loc; l; Qast.Bool false; t]) : + (fun (e : 'fun_binding) (topt : 'a_opt) (l : 'label) (pf : 'a_opt) _ + (loc : int * int) -> + (Qast.Node ("CrMth", [Qast.Loc; l; o2b pf; e; topt]) : 'class_str_item)); [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.Stoken ("", "private"); + Gramext.srules + [[Gramext.Sopt + (Gramext.srules + [[Gramext.Stoken ("", "private")], + Gramext.action + (fun (x : string) (loc : int * int) -> + (Qast.Str x : 'e__16))])], + Gramext.action + (fun (a : 'e__16 option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t : 'ctyp) _ (l : 'label) _ _ _ (loc : int * int) -> - (Qast.Node ("CrVir", [Qast.Loc; l; Qast.Bool true; t]) : - 'class_str_item)); + (fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ _ (loc : int * int) -> + (Qast.Node ("CrVir", [Qast.Loc; l; o2b pf; t]) : 'class_str_item)); [Gramext.Stoken ("", "value"); - Gramext.Snterm (Grammar.Entry.obj (cvalue : 'cvalue Grammar.Entry.e))], + Gramext.srules + [[Gramext.Sopt + (Gramext.srules + [[Gramext.Stoken ("", "mutable")], + Gramext.action + (fun (x : string) (loc : int * int) -> + (Qast.Str x : 'e__15))])], + Gramext.action + (fun (a : 'e__15 option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; + Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); + Gramext.Snterm + (Grammar.Entry.obj + (cvalue_binding : 'cvalue_binding Grammar.Entry.e))], Gramext.action - (fun (labmfe : 'cvalue) _ (loc : int * int) -> - (let (lab, mf, e) = - match labmfe with - Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3 - | _ -> - match () with - _ -> raise (Match_failure ("q_MLast.ml", 868, 19)) - in - Qast.Node ("CrVal", [Qast.Loc; lab; mf; e]) : + (fun (e : 'cvalue_binding) (lab : 'label) (mf : 'a_opt) _ + (loc : int * int) -> + (Qast.Node ("CrVal", [Qast.Loc; lab; o2b mf; e]) : 'class_str_item)); [Gramext.Stoken ("", "inherit"); Gramext.Snterm (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (as_lident_opt : 'as_lident_opt Grammar.Entry.e))], + Gramext.srules + [[Gramext.Sopt + (Gramext.Snterm + (Grammar.Entry.obj + (as_lident : 'as_lident Grammar.Entry.e)))], + Gramext.action + (fun (a : 'as_lident option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]], Gramext.action - (fun (pb : 'as_lident_opt) (ce : 'class_expr) _ (loc : int * int) -> + (fun (pb : 'a_opt) (ce : 'class_expr) _ (loc : int * int) -> (Qast.Node ("CrInh", [Qast.Loc; ce; pb]) : 'class_str_item)); [Gramext.Stoken ("", "declare"); Gramext.srules @@ -2667,9 +2788,9 @@ Grammar.extend Gramext.Stoken ("", ";")], Gramext.action (fun _ (s : 'class_str_item) (loc : int * int) -> - (s : 'e__7))])], + (s : 'e__14))])], Gramext.action - (fun (a : 'e__7 list) (loc : int * int) -> + (fun (a : 'e__14 list) (loc : int * int) -> (Qast.List a : 'a_list)); [Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], @@ -2679,70 +2800,50 @@ Grammar.extend Gramext.action (fun _ (st : 'a_list) _ (loc : int * int) -> (Qast.Node ("CrDcl", [Qast.Loc; st]) : 'class_str_item))]]; - Grammar.Entry.obj (as_lident_opt : 'as_lident_opt Grammar.Entry.e), None, + Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e), None, [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> (Qast.Option None : 'as_lident_opt)); - [Gramext.Stoken ("", "as"); + [[Gramext.Stoken ("", "as"); Gramext.Snterm (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], Gramext.action - (fun (i : 'a_LIDENT) _ (loc : int * int) -> - (Qast.Option (Some i) : 'as_lident_opt))]]; - Grammar.Entry.obj (cvalue : 'cvalue Grammar.Entry.e), None, + (fun (i : 'a_LIDENT) _ (loc : int * int) -> (i : 'as_lident))]]; + Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e), None, [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (mutable_flag : 'mutable_flag Grammar.Entry.e)); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":>"); + [[Gramext.Stoken ("", ":"); + Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], + Gramext.action (fun (t : 'ctyp) _ (loc : int * int) -> (t : 'polyt))]]; + Grammar.Entry.obj (cvalue_binding : 'cvalue_binding Grammar.Entry.e), + None, + [None, None, + [[Gramext.Stoken ("", ":>"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (l : 'label) (mf : 'mutable_flag) - (loc : int * int) -> - (Qast.Tuple - [l; mf; - Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option None; t])] : - 'cvalue)); - [Gramext.Snterm - (Grammar.Entry.obj (mutable_flag : 'mutable_flag Grammar.Entry.e)); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); + (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> + (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option None; t]) : + 'cvalue_binding)); + [Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("", ":>"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _ (l : 'label) - (mf : 'mutable_flag) (loc : int * int) -> - (Qast.Tuple - [l; mf; - Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option (Some t); t2])] : - 'cvalue)); - [Gramext.Snterm - (Grammar.Entry.obj (mutable_flag : 'mutable_flag Grammar.Entry.e)); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); + (fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _ (loc : int * int) -> + (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option (Some t); t2]) : + 'cvalue_binding)); + [Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (l : 'label) (mf : 'mutable_flag) - (loc : int * int) -> - (Qast.Tuple [l; mf; Qast.Node ("ExTyc", [Qast.Loc; e; t])] : - 'cvalue)); - [Gramext.Snterm - (Grammar.Entry.obj (mutable_flag : 'mutable_flag Grammar.Entry.e)); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", "="); + (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> + (Qast.Node ("ExTyc", [Qast.Loc; e; t]) : 'cvalue_binding)); + [Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (l : 'label) (mf : 'mutable_flag) - (loc : int * int) -> - (Qast.Tuple [l; mf; e] : 'cvalue))]]; + (fun (e : 'expr) _ (loc : int * int) -> (e : 'cvalue_binding))]]; Grammar.Entry.obj (label : 'label Grammar.Entry.e), None, [None, None, [[Gramext.Snterm @@ -2773,9 +2874,9 @@ Grammar.extend Gramext.Stoken ("", ";")], Gramext.action (fun _ (csf : 'class_sig_item) (loc : int * int) -> - (csf : 'e__8))])], + (csf : 'e__18))])], Gramext.action - (fun (a : 'e__8 list) (loc : int * int) -> + (fun (a : 'e__18 list) (loc : int * int) -> (Qast.List a : 'a_list)); [Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], @@ -2836,48 +2937,68 @@ Grammar.extend (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> (Qast.Node ("CgCtr", [Qast.Loc; t1; t2]) : 'class_sig_item)); [Gramext.Stoken ("", "method"); + Gramext.srules + [[Gramext.Sopt + (Gramext.srules + [[Gramext.Stoken ("", "private")], + Gramext.action + (fun (x : string) (loc : int * int) -> + (Qast.Str x : 'e__22))])], + Gramext.action + (fun (a : 'e__22 option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t : 'ctyp) _ (l : 'label) _ (loc : int * int) -> - (Qast.Node ("CgMth", [Qast.Loc; l; Qast.Bool false; t]) : - 'class_sig_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "private"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) _ _ (loc : int * int) -> - (Qast.Node ("CgMth", [Qast.Loc; l; Qast.Bool true; t]) : - 'class_sig_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) _ _ (loc : int * int) -> - (Qast.Node ("CgVir", [Qast.Loc; l; Qast.Bool false; t]) : - 'class_sig_item)); + (fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ (loc : int * int) -> + (Qast.Node ("CgMth", [Qast.Loc; l; o2b pf; t]) : 'class_sig_item)); [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.Stoken ("", "private"); + Gramext.srules + [[Gramext.Sopt + (Gramext.srules + [[Gramext.Stoken ("", "private")], + Gramext.action + (fun (x : string) (loc : int * int) -> + (Qast.Str x : 'e__21))])], + Gramext.action + (fun (a : 'e__21 option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t : 'ctyp) _ (l : 'label) _ _ _ (loc : int * int) -> - (Qast.Node ("CgVir", [Qast.Loc; l; Qast.Bool true; t]) : - 'class_sig_item)); + (fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ _ (loc : int * int) -> + (Qast.Node ("CgVir", [Qast.Loc; l; o2b pf; t]) : 'class_sig_item)); [Gramext.Stoken ("", "value"); - Gramext.Snterm - (Grammar.Entry.obj (mutable_flag : 'mutable_flag Grammar.Entry.e)); + Gramext.srules + [[Gramext.Sopt + (Gramext.srules + [[Gramext.Stoken ("", "mutable")], + Gramext.action + (fun (x : string) (loc : int * int) -> + (Qast.Str x : 'e__20))])], + Gramext.action + (fun (a : 'e__20 option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (mf : 'mutable_flag) _ - (loc : int * int) -> - (Qast.Node ("CgVal", [Qast.Loc; l; mf; t]) : 'class_sig_item)); + (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _ (loc : int * int) -> + (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; t]) : 'class_sig_item)); [Gramext.Stoken ("", "inherit"); Gramext.Snterm (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], @@ -2894,9 +3015,9 @@ Grammar.extend Gramext.Stoken ("", ";")], Gramext.action (fun _ (s : 'class_sig_item) (loc : int * int) -> - (s : 'e__9))])], + (s : 'e__19))])], Gramext.action - (fun (a : 'e__9 list) (loc : int * int) -> + (fun (a : 'e__19 list) (loc : int * int) -> (Qast.List a : 'a_list)); [Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], @@ -2910,8 +3031,20 @@ Grammar.extend (class_description : 'class_description Grammar.Entry.e), None, [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (virtual_flag : 'virtual_flag Grammar.Entry.e)); + [[Gramext.srules + [[Gramext.Sopt + (Gramext.srules + [[Gramext.Stoken ("", "virtual")], + Gramext.action + (fun (x : string) (loc : int * int) -> + (Qast.Str x : 'e__23))])], + Gramext.action + (fun (a : 'e__23 option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.Snterm (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); Gramext.Snterm @@ -2922,17 +3055,29 @@ Grammar.extend (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], Gramext.action (fun (ct : 'class_type) _ (ctp : 'class_type_parameters) - (n : 'a_LIDENT) (vf : 'virtual_flag) (loc : int * int) -> + (n : 'a_LIDENT) (vf : 'a_opt) (loc : int * int) -> (Qast.Record - ["ciLoc", Qast.Loc; "ciVir", vf; "ciPrm", ctp; "ciNam", n; + ["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", n; "ciExp", ct] : 'class_description))]]; Grammar.Entry.obj (class_type_declaration : 'class_type_declaration Grammar.Entry.e), None, [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (virtual_flag : 'virtual_flag Grammar.Entry.e)); + [[Gramext.srules + [[Gramext.Sopt + (Gramext.srules + [[Gramext.Stoken ("", "virtual")], + Gramext.action + (fun (x : string) (loc : int * int) -> + (Qast.Str x : 'e__24))])], + Gramext.action + (fun (a : 'e__24 option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.Snterm (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); Gramext.Snterm @@ -2943,9 +3088,9 @@ Grammar.extend (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], Gramext.action (fun (cs : 'class_type) _ (ctp : 'class_type_parameters) - (n : 'a_LIDENT) (vf : 'virtual_flag) (loc : int * int) -> + (n : 'a_LIDENT) (vf : 'a_opt) (loc : int * int) -> (Qast.Record - ["ciLoc", Qast.Loc; "ciVir", vf; "ciPrm", ctp; "ciNam", n; + ["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", n; "ciExp", cs] : 'class_type_declaration))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), @@ -2970,17 +3115,23 @@ Grammar.extend Some (Gramext.Level "simple"), [None, None, [[Gramext.Stoken ("", "{<"); - Gramext.Snterm - (Grammar.Entry.obj - (field_expr_list : 'field_expr_list Grammar.Entry.e)); + Gramext.srules + [[Gramext.Slist0sep + (Gramext.Snterm + (Grammar.Entry.obj + (field_expr : 'field_expr Grammar.Entry.e)), + Gramext.Stoken ("", ";"))], + Gramext.action + (fun (a : 'field_expr list) (loc : int * int) -> + (Qast.List a : 'a_list)); + [Gramext.Snterm + (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; Gramext.Stoken ("", ">}")], Gramext.action - (fun _ (fel : 'field_expr_list) _ (loc : int * int) -> + (fun _ (fel : 'a_list) _ (loc : int * int) -> (Qast.Node ("ExOvr", [Qast.Loc; fel]) : 'expr)); - [Gramext.Stoken ("", "{<"); Gramext.Stoken ("", ">}")], - Gramext.action - (fun _ _ (loc : int * int) -> - (Qast.Node ("ExOvr", [Qast.Loc; Qast.List []]) : 'expr)); [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":>"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("", ")")], @@ -2996,53 +3147,48 @@ Grammar.extend (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) -> (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option (Some t); t2]) : 'expr))]]; - Grammar.Entry.obj (field_expr_list : 'field_expr_list Grammar.Entry.e), - None, + Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e), None, [None, None, [[Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action (fun (e : 'expr) _ (l : 'label) (loc : int * int) -> - (Qast.List [Qast.Tuple [l; e]] : 'field_expr_list)); - [Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) _ (l : 'label) (loc : int * int) -> - (Qast.List [Qast.Tuple [l; e]] : 'field_expr_list)); - [Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";"); Gramext.Sself], - Gramext.action - (fun (fel : 'field_expr_list) _ (e : 'expr) _ (l : 'label) - (loc : int * int) -> - (Qast.Cons (Qast.Tuple [l; e], fel) : 'field_expr_list))]]; + (Qast.Tuple [l; e] : 'field_expr))]]; Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), Some (Gramext.Level "simple"), [None, None, - [[Gramext.Stoken ("", "<"); Gramext.Stoken ("", ">")], - Gramext.action - (fun _ _ (loc : int * int) -> - (Qast.Node ("TyObj", [Qast.Loc; Qast.List []; Qast.Bool false]) : - 'ctyp)); - [Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj (meth_list : 'meth_list Grammar.Entry.e)); + [[Gramext.Stoken ("", "<"); + Gramext.srules + [[Gramext.Slist0sep + (Gramext.Snterm + (Grammar.Entry.obj (field : 'field Grammar.Entry.e)), + Gramext.Stoken ("", ";"))], + Gramext.action + (fun (a : 'field list) (loc : int * int) -> + (Qast.List a : 'a_list)); + [Gramext.Snterm + (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; + Gramext.srules + [[Gramext.Sopt + (Gramext.srules + [[Gramext.Stoken ("", "..")], + Gramext.action + (fun (x : string) (loc : int * int) -> + (Qast.Str x : 'e__25))])], + Gramext.action + (fun (a : 'e__25 option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.Stoken ("", ">")], Gramext.action - (fun _ (mlv : 'meth_list) _ (loc : int * int) -> - (let (ml, v) = - match mlv with - Qast.Tuple [xx1; xx2] -> xx1, xx2 - | _ -> - match () with - _ -> raise (Match_failure ("q_MLast.ml", 982, 19)) - in - Qast.Node ("TyObj", [Qast.Loc; ml; v]) : - 'ctyp)); + (fun _ (v : 'a_opt) (ml : 'a_list) _ (loc : int * int) -> + (Qast.Node ("TyObj", [Qast.Loc; ml; o2b v]) : 'ctyp)); [Gramext.Stoken ("", "#"); Gramext.Snterm (Grammar.Entry.obj @@ -3050,34 +3196,6 @@ Grammar.extend Gramext.action (fun (id : 'class_longident) _ (loc : int * int) -> (Qast.Node ("TyCls", [Qast.Loc; id]) : 'ctyp))]]; - Grammar.Entry.obj (meth_list : 'meth_list Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "..")], - Gramext.action - (fun _ (loc : int * int) -> - (Qast.Tuple [Qast.List []; Qast.Bool true] : 'meth_list)); - [Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e))], - Gramext.action - (fun (f : 'field) (loc : int * int) -> - (Qast.Tuple [Qast.List [f]; Qast.Bool false] : 'meth_list)); - [Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (f : 'field) (loc : int * int) -> - (Qast.Tuple [Qast.List [f]; Qast.Bool false] : 'meth_list)); - [Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e)); - Gramext.Stoken ("", ";"); Gramext.Sself], - Gramext.action - (fun (mlv : 'meth_list) _ (f : 'field) (loc : int * int) -> - (let (ml, v) = - match mlv with - Qast.Tuple [xx1; xx2] -> xx1, xx2 - | _ -> - match () with - _ -> raise (Match_failure ("q_MLast.ml", 993, 19)) - in - Qast.Tuple [Qast.Cons (f, ml); v] : - 'meth_list))]]; Grammar.Entry.obj (field : 'field Grammar.Entry.e), None, [None, None, [[Gramext.Snterm @@ -3228,9 +3346,9 @@ Grammar.extend [[Gramext.Stoken ("", "&")], Gramext.action (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__10))])], + (Qast.Str x : 'e__26))])], Gramext.action - (fun (a : 'e__10 option) (loc : int * int) -> + (fun (a : 'e__26 option) (loc : int * int) -> (Qast.Option a : 'a_opt)); [Gramext.Snterm (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], @@ -3268,111 +3386,69 @@ Grammar.extend [None, None, [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (e : 'expr) _ (t : 'ctyp) _ (i : 'a_LIDENT) _ _ - (loc : int * int) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; i; - Qast.Node - ("PaTyc", - [Qast.Loc; Qast.Node ("PaLid", [Qast.Loc; i]); t]); - Qast.Option (Some e)]) : - 'patt)); - [Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); + (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); + Gramext.srules + [[Gramext.Sopt + (Gramext.Snterm + (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], + Gramext.action + (fun (a : 'eq_expr option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.Stoken ("", ")")], Gramext.action - (fun _ (e : 'expr) _ (i : 'a_LIDENT) _ _ (loc : int * int) -> + (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ _ (loc : int * int) -> (Qast.Node ("PaOlb", - [Qast.Loc; i; Qast.Node ("PaLid", [Qast.Loc; i]); - Qast.Option (Some e)]) : + [Qast.Loc; Qast.Str ""; + Qast.Option (Some (Qast.Tuple [p; eo]))]) : 'patt)); [Gramext.Snterm (Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))], Gramext.action (fun (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; i; Qast.Node ("PaLid", [Qast.Loc; i]); - Qast.Option None]) : - 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); Gramext.Sself; - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (e : 'expr) _ (t : 'ctyp) _ (p : 'patt) _ _ - (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; i; Qast.Node ("PaTyc", [Qast.Loc; p; t]); - Qast.Option (Some e)]) : - 'patt)); + (Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option None]) : 'patt)); [Gramext.Snterm (Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); Gramext.Sself; - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); + Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); + Gramext.Snterm + (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); + Gramext.srules + [[Gramext.Sopt + (Gramext.Snterm + (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], + Gramext.action + (fun (a : 'eq_expr option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.Stoken ("", ")")], Gramext.action - (fun _ (t : 'ctyp) _ (p : 'patt) _ _ (i : 'a_QUESTIONIDENT) + (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ _ (i : 'a_QUESTIONIDENT) (loc : int * int) -> (Qast.Node ("PaOlb", - [Qast.Loc; i; Qast.Node ("PaTyc", [Qast.Loc; p; t]); - Qast.Option None]) : - 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); Gramext.Sself; - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (e : 'expr) _ (p : 'patt) _ _ (i : 'a_QUESTIONIDENT) - (loc : int * int) -> - (Qast.Node ("PaOlb", [Qast.Loc; i; p; Qast.Option (Some e)]) : + [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : 'patt)); [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); Gramext.Sself; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p : 'patt) _ _ (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node ("PaOlb", [Qast.Loc; i; p; Qast.Option None]) : 'patt)); - [Gramext.Snterm (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))], Gramext.action (fun (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node - ("PaLab", [Qast.Loc; i; Qast.Node ("PaLid", [Qast.Loc; i])]) : - 'patt)); + (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option None]) : 'patt)); [Gramext.Snterm (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action (fun (p : 'patt) _ (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node ("PaLab", [Qast.Loc; i; p]) : 'patt)); + (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) : + 'patt)); [Gramext.Stoken ("", "#"); Gramext.Snterm (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], @@ -3384,116 +3460,100 @@ Grammar.extend Gramext.action (fun (s : 'ident) _ (loc : int * int) -> (Qast.Node ("PaVrn", [Qast.Loc; s]) : 'patt))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, + Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e), None, [None, None, - [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); + [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], + Gramext.action (fun (p : 'patt) (loc : int * int) -> (p : 'patt_tcon)); + [Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ")")], + Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun _ (e : 'expr) _ (t : 'ctyp) _ (i : 'a_LIDENT) _ _ - (loc : int * int) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; i; - Qast.Node - ("PaTyc", - [Qast.Loc; Qast.Node ("PaLid", [Qast.Loc; i]); t]); - Qast.Option (Some e)]) : - 'ipatt)); - [Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); + (fun (t : 'ctyp) _ (p : 'patt) (loc : int * int) -> + (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'patt_tcon))]]; + Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, + [None, None, + [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); + (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); + Gramext.srules + [[Gramext.Sopt + (Gramext.Snterm + (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], + Gramext.action + (fun (a : 'eq_expr option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.Stoken ("", ")")], Gramext.action - (fun _ (e : 'expr) _ (i : 'a_LIDENT) _ _ (loc : int * int) -> + (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ _ (loc : int * int) -> (Qast.Node ("PaOlb", - [Qast.Loc; i; Qast.Node ("PaLid", [Qast.Loc; i]); - Qast.Option (Some e)]) : + [Qast.Loc; Qast.Str ""; + Qast.Option (Some (Qast.Tuple [p; eo]))]) : 'ipatt)); [Gramext.Snterm (Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))], Gramext.action (fun (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; i; Qast.Node ("PaLid", [Qast.Loc; i]); - Qast.Option None]) : - 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); Gramext.Sself; - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (e : 'expr) _ (t : 'ctyp) _ (p : 'ipatt) _ _ - (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; i; Qast.Node ("PaTyc", [Qast.Loc; p; t]); - Qast.Option (Some e)]) : - 'ipatt)); + (Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option None]) : 'ipatt)); [Gramext.Snterm (Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); Gramext.Sself; - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); + Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); + Gramext.Snterm + (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); + Gramext.srules + [[Gramext.Sopt + (Gramext.Snterm + (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], + Gramext.action + (fun (a : 'eq_expr option) (loc : int * int) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; Gramext.Stoken ("", ")")], Gramext.action - (fun _ (t : 'ctyp) _ (p : 'ipatt) _ _ (i : 'a_QUESTIONIDENT) + (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ _ (i : 'a_QUESTIONIDENT) (loc : int * int) -> (Qast.Node ("PaOlb", - [Qast.Loc; i; Qast.Node ("PaTyc", [Qast.Loc; p; t]); - Qast.Option None]) : - 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); Gramext.Sself; - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (e : 'expr) _ (p : 'ipatt) _ _ (i : 'a_QUESTIONIDENT) - (loc : int * int) -> - (Qast.Node ("PaOlb", [Qast.Loc; i; p; Qast.Option (Some e)]) : - 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); Gramext.Sself; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p : 'ipatt) _ _ (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node ("PaOlb", [Qast.Loc; i; p; Qast.Option None]) : + [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : 'ipatt)); [Gramext.Snterm (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))], Gramext.action (fun (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node - ("PaLab", [Qast.Loc; i; Qast.Node ("PaLid", [Qast.Loc; i])]) : - 'ipatt)); + (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option None]) : 'ipatt)); [Gramext.Snterm (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action (fun (p : 'ipatt) _ (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node ("PaLab", [Qast.Loc; i; p]) : 'ipatt))]]; + (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) : + 'ipatt))]]; + Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e), None, + [None, None, + [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))], + Gramext.action + (fun (p : 'ipatt) (loc : int * int) -> (p : 'ipatt_tcon)); + [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); + Gramext.Stoken ("", ":"); + Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], + Gramext.action + (fun (t : 'ctyp) _ (p : 'ipatt) (loc : int * int) -> + (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'ipatt_tcon))]]; + Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e), None, + [None, None, + [[Gramext.Stoken ("", "="); + Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], + Gramext.action + (fun (e : 'expr) _ (loc : int * int) -> (e : 'eq_expr))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), Some (Gramext.After "apply"), [Some "label", Some Gramext.NonA, @@ -3502,29 +3562,27 @@ Grammar.extend (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))], Gramext.action (fun (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node - ("ExOlb", [Qast.Loc; i; Qast.Node ("ExLid", [Qast.Loc; i])]) : - 'expr)); + (Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option None]) : 'expr)); [Gramext.Snterm (Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action (fun (e : 'expr) _ (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node ("ExOlb", [Qast.Loc; i; e]) : 'expr)); + (Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option (Some e)]) : + 'expr)); [Gramext.Snterm (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))], Gramext.action (fun (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node - ("ExLab", [Qast.Loc; i; Qast.Node ("ExLid", [Qast.Loc; i])]) : - 'expr)); + (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option None]) : 'expr)); [Gramext.Snterm (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action (fun (e : 'expr) _ (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node ("ExLab", [Qast.Loc; i; e]) : 'expr))]]; + (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option (Some e)]) : + 'expr))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), Some (Gramext.Level "simple"), [None, None, @@ -3533,13 +3591,6 @@ Grammar.extend Gramext.action (fun (s : 'ident) _ (loc : int * int) -> (Qast.Node ("ExVrn", [Qast.Loc; s]) : 'expr))]]; - Grammar.Entry.obj (rec_flag : 'rec_flag Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action (fun (loc : int * int) -> (Qast.Bool false : 'rec_flag)); - [Gramext.Stoken ("", "rec")], - Gramext.action - (fun _ (loc : int * int) -> (Qast.Bool true : 'rec_flag))]]; Grammar.Entry.obj (direction_flag : 'direction_flag Grammar.Entry.e), None, [None, None, @@ -3549,22 +3600,6 @@ Grammar.extend [Gramext.Stoken ("", "to")], Gramext.action (fun _ (loc : int * int) -> (Qast.Bool true : 'direction_flag))]]; - Grammar.Entry.obj (mutable_flag : 'mutable_flag Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> (Qast.Bool false : 'mutable_flag)); - [Gramext.Stoken ("", "mutable")], - Gramext.action - (fun _ (loc : int * int) -> (Qast.Bool true : 'mutable_flag))]]; - Grammar.Entry.obj (virtual_flag : 'virtual_flag Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> (Qast.Bool false : 'virtual_flag)); - [Gramext.Stoken ("", "virtual")], - Gramext.action - (fun _ (loc : int * int) -> (Qast.Bool true : 'virtual_flag))]]; Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), Some (Gramext.Level "simple"), [None, None, @@ -3644,7 +3679,8 @@ Grammar.extend [None, None, [[], Gramext.action - (fun (loc : int * int) -> (warn_variant () : 'warning_variant))]]; + (fun (loc : int * int) -> + (warn_variant Qast.Loc : 'warning_variant))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), Some (Gramext.Level "top"), [None, None, @@ -3656,9 +3692,9 @@ Grammar.extend (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__13))])], + (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__29))])], Gramext.action - (fun (a : 'e__13 list) (loc : int * int) -> + (fun (a : 'e__29 list) (loc : int * int) -> (Qast.List a : 'a_list)); [Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], @@ -3686,9 +3722,9 @@ Grammar.extend (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__12))])], + (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__28))])], Gramext.action - (fun (a : 'e__12 list) (loc : int * int) -> + (fun (a : 'e__28 list) (loc : int * int) -> (Qast.List a : 'a_list)); [Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], @@ -3710,9 +3746,9 @@ Grammar.extend (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__11))])], + (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__27))])], Gramext.action - (fun (a : 'e__11 list) (loc : int * int) -> + (fun (a : 'e__27 list) (loc : int * int) -> (Qast.List a : 'a_list)); [Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], @@ -3731,7 +3767,8 @@ Grammar.extend [None, None, [[], Gramext.action - (fun (loc : int * int) -> (warn_sequence () : 'warning_sequence))]]; + (fun (loc : int * int) -> + (warn_sequence Qast.Loc : 'warning_sequence))]]; Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e), None, [None, None, [[Gramext.Stoken ("ANTIQUOT", "list")], @@ -3763,35 +3800,6 @@ Grammar.extend Gramext.action (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'mod_ident))]]; - Grammar.Entry.obj - (class_self_patt_opt : 'class_self_patt_opt Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'class_self_patt_opt)); - [Gramext.Stoken ("ANTIQUOT", "opt")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "opt" loc a : 'class_self_patt_opt))]]; - Grammar.Entry.obj (as_lident_opt : 'as_lident_opt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "as")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "as" loc a : 'as_lident_opt))]]; - Grammar.Entry.obj (meth_list : 'meth_list Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); - Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (b : string) (a : 'a_list) (loc : int * int) -> - (Qast.Tuple [a; antiquot "" loc b] : 'meth_list)); - [Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> - (Qast.Tuple [a; Qast.Bool false] : 'meth_list))]]; Grammar.Entry.obj (clty_longident : 'clty_longident Grammar.Entry.e), None, [None, None, @@ -3804,12 +3812,6 @@ Grammar.extend [[Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], Gramext.action (fun (a : 'a_list) (loc : int * int) -> (a : 'class_longident))]]; - Grammar.Entry.obj (rec_flag : 'rec_flag Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "rec")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "rec" loc a : 'rec_flag))]]; Grammar.Entry.obj (direction_flag : 'direction_flag Grammar.Entry.e), None, [None, None, @@ -3817,30 +3819,205 @@ Grammar.extend Gramext.action (fun (a : string) (loc : int * int) -> (antiquot "to" loc a : 'direction_flag))]]; - Grammar.Entry.obj (mutable_flag : 'mutable_flag Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "mut")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "mut" loc a : 'mutable_flag))]]; - Grammar.Entry.obj (virtual_flag : 'virtual_flag Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "virt")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "virt" loc a : 'virtual_flag))]]; Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), Some (Gramext.Level "simple"), [None, None, [[Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", ""); + Gramext.Stoken ("", ";"); + Gramext.srules + [[Gramext.Slist0 + (Gramext.srules + [[Gramext.Snterm + (Grammar.Entry.obj + (class_str_item : 'class_str_item Grammar.Entry.e)); + Gramext.Stoken ("", ";")], + Gramext.action + (fun _ (cf : 'class_str_item) (loc : int * int) -> + (cf : 'e__30))])], + Gramext.action + (fun (a : 'e__30 list) (loc : int * int) -> + (Qast.List a : 'a_list)); + [Gramext.Snterm + (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; + Gramext.Stoken ("", "end")], + Gramext.action + (fun _ (csl : 'a_list) _ (x : string) _ (loc : int * int) -> + (let _ = warn_antiq loc "3.05" in + Qast.Node + ("CeStr", + [Qast.Loc; Qast.Option None; + Qast.Cons (antiquot "" loc x, csl)]) : + 'class_expr)); + [Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", ""); Gramext.Snterm (Grammar.Entry.obj (class_structure : 'class_structure Grammar.Entry.e)); Gramext.Stoken ("", "end")], Gramext.action - (fun _ (cf : 'class_structure) (cspo : string) _ (loc : int * int) -> - (Qast.Node ("CeStr", [Qast.Loc; antiquot "" loc cspo; cf]) : - 'class_expr))]]]);; + (fun _ (cf : 'class_structure) (x : string) _ (loc : int * int) -> + (let _ = warn_antiq loc "3.05" in + Qast.Node ("CeStr", [Qast.Loc; antiquot "" loc x; cf]) : + 'class_expr))]]; + Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None, + [None, None, + [[Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", ""); + Gramext.Stoken ("", ";"); + Gramext.srules + [[Gramext.Slist0 + (Gramext.srules + [[Gramext.Snterm + (Grammar.Entry.obj + (class_sig_item : 'class_sig_item Grammar.Entry.e)); + Gramext.Stoken ("", ";")], + Gramext.action + (fun _ (csf : 'class_sig_item) (loc : int * int) -> + (csf : 'e__32))])], + Gramext.action + (fun (a : 'e__32 list) (loc : int * int) -> + (Qast.List a : 'a_list)); + [Gramext.Snterm + (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; + Gramext.Stoken ("", "end")], + Gramext.action + (fun _ (csf : 'a_list) _ (x : string) _ (loc : int * int) -> + (let _ = warn_antiq loc "3.05" in + Qast.Node + ("CtSig", + [Qast.Loc; Qast.Option None; + Qast.Cons (antiquot "" loc x, csf)]) : + 'class_type)); + [Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", ""); + Gramext.srules + [[Gramext.Slist0 + (Gramext.srules + [[Gramext.Snterm + (Grammar.Entry.obj + (class_sig_item : 'class_sig_item Grammar.Entry.e)); + Gramext.Stoken ("", ";")], + Gramext.action + (fun _ (csf : 'class_sig_item) (loc : int * int) -> + (csf : 'e__31))])], + Gramext.action + (fun (a : 'e__31 list) (loc : int * int) -> + (Qast.List a : 'a_list)); + [Gramext.Snterm + (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; + Gramext.Stoken ("", "end")], + Gramext.action + (fun _ (csf : 'a_list) (x : string) _ (loc : int * int) -> + (let _ = warn_antiq loc "3.05" in + Qast.Node ("CtSig", [Qast.Loc; antiquot "" loc x; csf]) : + 'class_type))]]; + Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), + Some (Gramext.Level "top"), + [None, None, + [[Gramext.Stoken ("", "let"); Gramext.Stoken ("ANTIQUOT", "rec"); + Gramext.srules + [[Gramext.Slist1sep + (Gramext.Snterm + (Grammar.Entry.obj + (let_binding : 'let_binding Grammar.Entry.e)), + Gramext.Stoken ("", "and"))], + Gramext.action + (fun (a : 'let_binding list) (loc : int * int) -> + (Qast.List a : 'a_list)); + [Gramext.Snterm + (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; + Gramext.Stoken ("", "in"); Gramext.Sself], + Gramext.action + (fun (x : 'expr) _ (l : 'a_list) (r : string) _ (loc : int * int) -> + (let _ = warn_antiq loc "3.06+18" in + Qast.Node ("ExLet", [Qast.Loc; antiquot "rec" loc r; l; x]) : + 'expr))]]; + Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), + Some (Gramext.Level "top"), + [None, None, + [[Gramext.Stoken ("", "value"); Gramext.Stoken ("ANTIQUOT", "rec"); + Gramext.srules + [[Gramext.Slist1sep + (Gramext.Snterm + (Grammar.Entry.obj + (let_binding : 'let_binding Grammar.Entry.e)), + Gramext.Stoken ("", "and"))], + Gramext.action + (fun (a : 'let_binding list) (loc : int * int) -> + (Qast.List a : 'a_list)); + [Gramext.Snterm + (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], + Gramext.action + (fun (l : 'a_list) (r : string) _ (loc : int * int) -> + (let _ = warn_antiq loc "3.06+18" in + Qast.Node ("StVal", [Qast.Loc; antiquot "rec" loc r; l]) : + 'str_item))]]; + Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), + Some (Gramext.Level "top"), + [None, None, + [[Gramext.Stoken ("", "let"); Gramext.Stoken ("ANTIQUOT", "rec"); + Gramext.srules + [[Gramext.Slist1sep + (Gramext.Snterm + (Grammar.Entry.obj + (let_binding : 'let_binding Grammar.Entry.e)), + Gramext.Stoken ("", "and"))], + Gramext.action + (fun (a : 'let_binding list) (loc : int * int) -> + (Qast.List a : 'a_list)); + [Gramext.Snterm + (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; + Gramext.Stoken ("", "in"); Gramext.Sself], + Gramext.action + (fun (ce : 'class_expr) _ (lb : 'a_list) (r : string) _ + (loc : int * int) -> + (let _ = warn_antiq loc "3.06+18" in + Qast.Node ("CeLet", [Qast.Loc; antiquot "rec" loc r; lb; ce]) : + 'class_expr))]]; + Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e), + None, + [None, None, + [[Gramext.Stoken ("", "value"); Gramext.Stoken ("ANTIQUOT", "mut"); + Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); + Gramext.Snterm + (Grammar.Entry.obj + (cvalue_binding : 'cvalue_binding Grammar.Entry.e))], + Gramext.action + (fun (e : 'cvalue_binding) (lab : 'label) (mf : string) _ + (loc : int * int) -> + (let _ = warn_antiq loc "3.06+18" in + Qast.Node ("CrVal", [Qast.Loc; lab; antiquot "mut" loc mf; e]) : + 'class_str_item)); + [Gramext.Stoken ("", "inherit"); + Gramext.Snterm + (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e)); + Gramext.Stoken ("ANTIQUOT", "as")], + Gramext.action + (fun (pb : string) (ce : 'class_expr) _ (loc : int * int) -> + (let _ = warn_antiq loc "3.06+18" in + Qast.Node ("CrInh", [Qast.Loc; ce; antiquot "as" loc pb]) : + 'class_str_item))]]; + Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e), + None, + [None, None, + [[Gramext.Stoken ("", "value"); Gramext.Stoken ("ANTIQUOT", "mut"); + Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); + Gramext.Stoken ("", ":"); + Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], + Gramext.action + (fun (t : 'ctyp) _ (l : 'label) (mf : string) _ (loc : int * int) -> + (let _ = warn_antiq loc "3.06+18" in + Qast.Node ("CgVal", [Qast.Loc; l; antiquot "mut" loc mf; t]) : + 'class_sig_item))]]]);; Grammar.extend (let _ = (str_item : 'str_item Grammar.Entry.e) @@ -4294,3 +4471,27 @@ Grammar.extend (fun _ (x : 'class_str_item) (loc : int * int) -> (x : 'class_str_item_eoi))]]]; Quotation.add "class_str_item" (apply_entry class_str_item_eoi);; + +let with_constr_eoi = Grammar.Entry.create gram "with constr" in +Grammar.extend + [Grammar.Entry.obj (with_constr_eoi : 'with_constr_eoi Grammar.Entry.e), + None, + [None, None, + [[Gramext.Snterm + (Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e)); + Gramext.Stoken ("EOI", "")], + Gramext.action + (fun _ (x : 'with_constr) (loc : int * int) -> + (x : 'with_constr_eoi))]]]; +Quotation.add "with_constr" (apply_entry with_constr_eoi);; + +let row_field_eoi = Grammar.Entry.create gram "row_field" in +Grammar.extend + [Grammar.Entry.obj (row_field_eoi : 'row_field_eoi Grammar.Entry.e), None, + [None, None, + [[Gramext.Snterm + (Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e)); + Gramext.Stoken ("EOI", "")], + Gramext.action + (fun _ (x : 'row_field) (loc : int * int) -> (x : 'row_field_eoi))]]]; +Quotation.add "row_field" (apply_entry row_field_eoi);; diff --git a/camlp4/ocaml_src/odyl/Makefile b/camlp4/ocaml_src/odyl/Makefile index 016a2f65e..8e8d8c268 100644 --- a/camlp4/ocaml_src/odyl/Makefile +++ b/camlp4/ocaml_src/odyl/Makefile @@ -31,7 +31,8 @@ odyl_main.cmx: odyl_main.ml odyl_config.ml: echo "let standard_library =" > odyl_config.ml echo " try Sys.getenv \"CAMLP4LIB\" with" >> odyl_config.ml - echo " Not_found -> \"$(LIBDIR)/camlp4\"" >> odyl_config.ml + echo " Not_found -> \"$(LIBDIR)/camlp4\"" | \ + sed -e 's|\\|/|g' >> odyl_config.ml clean:: rm -f *.cm* *.pp[io] *.o *.bak .*.bak *.out *.opt *.a @@ -51,7 +52,7 @@ promote: compare: install: - -$(MKDIR) $(LIBDIR)/camlp4 $(BINDIR) - cp odyl.cmo odyl.cma $(LIBDIR)/camlp4/. + -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" + cp odyl.cmo odyl.cma "$(LIBDIR)/camlp4/." include .depend diff --git a/camlp4/ocaml_src/odyl/odyl_main.ml b/camlp4/ocaml_src/odyl/odyl_main.ml index 6fbdb1490..22e5e65d9 100644 --- a/camlp4/ocaml_src/odyl/odyl_main.ml +++ b/camlp4/ocaml_src/odyl/odyl_main.ml @@ -1,4 +1,4 @@ -(* camlp4r pa_ifdef.cmo *) +(* camlp4r pa_macro.cmo *) (***********************************************************************) (* *) (* Camlp4 *) diff --git a/camlp4/ocaml_src/tools/extract_crc.sh b/camlp4/ocaml_src/tools/extract_crc.sh index e711fe10c..e69de29bb 100755 --- a/camlp4/ocaml_src/tools/extract_crc.sh +++ b/camlp4/ocaml_src/tools/extract_crc.sh @@ -1,6 +0,0 @@ -#!/bin/sh -e -COMM="ocamlrun$EXE $OTOP/otherlibs/dynlink/extract_crc" -if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM="$OTOP/boot/$COMM" -fi -$COMM $* diff --git a/camlp4/ocpp/Makefile b/camlp4/ocpp/Makefile index 809bc94b9..60729e323 100644 --- a/camlp4/ocpp/Makefile +++ b/camlp4/ocpp/Makefile @@ -7,25 +7,19 @@ SHELL=/bin/sh INCLUDES=-I ../camlp4 -I ../boot -I ../odyl -I $(OTOP)/otherlibs/dynlink OCAMLCFLAGS=-warn-error A $(INCLUDES) LINKFLAGS=$(INCLUDES) -OBJS=crc.cmo ocpp.cmo -INTERFACES=-I $(OLIBDIR) Arg Array Callback Char Digest Filename Format Gc Genlex Hashtbl Lexing List Map Obj Oo Parsing Pervasives Printexc Printf Queue Random Set Sort Stack Stream String Sys Weak -I ../boot Gramext Grammar Plexer Stdpp Token -I ../camlp4 MLast Quotation +OBJS=ocpp.cmo all: ocpp$(EXE) ocpp$(EXE): $(OBJS) $(OCAMLC) $(LINKFLAGS) ../boot/stdpp.cmo ../camlp4/quotation.cmo ../odyl/odyl.cma $(OBJS) ../odyl/odyl.cmo -linkall -o ocpp$(EXE) -crc.cmo: - @OTOP=$(OTOP) EXE=$(EXE) ../tools/extract_crc.sh $(INTERFACES) > crc.ml - echo "let _ = Dynlink.add_available_units crc_unit_list" >> crc.ml - $(OCAMLC) $(OCAMLCFLAGS) -c crc.ml - clean:: - rm -f *.cm[ioa] *.pp[io] *.o *.out *.bak .*.bak crc.ml ocpp$(EXE) + rm -f *.cm[ioa] *.pp[io] *.o *.out *.bak .*.bak ocpp$(EXE) install: - -$(MKDIR) $(LIBDIR)/camlp4 $(BINDIR) - cp $(OBJS) $(LIBDIR)/camlp4/. - cp ocpp$(EXE) $(BINDIR)/. + -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" + cp $(OBJS) "$(LIBDIR)/camlp4/." + cp ocpp$(EXE) "$(BINDIR)/." depend: diff --git a/camlp4/ocpp/Makefile.Mac b/camlp4/ocpp/Makefile.Mac index 55356683f..5994a500c 100644 --- a/camlp4/ocpp/Makefile.Mac +++ b/camlp4/ocpp/Makefile.Mac @@ -27,13 +27,8 @@ ocpp Ä {OBJS} {OCAMLC} {LINKFLAGS} ::boot:stdpp.cmo ::camlp4:quotation.cmo ¶ ::odyl:odyl.cma {OBJS} ::odyl:odyl.cmo -linkall -o ocpp -crc.cmo Ä - ::tools:extract_crc.mpw {INTERFACES} > crc.ml - echo "let _ = Dynlink.add_available_units crc_unit_list" >> crc.ml - {OCAMLC} {OCAMLCFLAGS} -c crc.ml - clean ÄÄ - delete -i crc.ml ocpp + delete -i ocpp install Ä (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null diff --git a/camlp4/ocpp/ocpp.ml b/camlp4/ocpp/ocpp.ml index 5f13a482b..afe517c0e 100644 --- a/camlp4/ocpp/ocpp.ml +++ b/camlp4/ocpp/ocpp.ml @@ -111,7 +111,7 @@ value loc_fmt = ; value print_location loc file = - let (line, c1, c2) = Stdpp.line_of_loc file loc in + let (fname, line, c1, c2) = Stdpp.line_of_loc file loc in do { Printf.eprintf loc_fmt file line c1 c2; flush stderr; } ; diff --git a/camlp4/odyl/.cvsignore b/camlp4/odyl/.cvsignore index 76d350592..8ae0ebb06 100644 --- a/camlp4/odyl/.cvsignore +++ b/camlp4/odyl/.cvsignore @@ -1,3 +1,4 @@ *.cm[oia] odyl +*.lib odyl_config.ml diff --git a/camlp4/odyl/Makefile b/camlp4/odyl/Makefile index 935396e4c..ee55d69ca 100644 --- a/camlp4/odyl/Makefile +++ b/camlp4/odyl/Makefile @@ -31,7 +31,8 @@ odyl_main.cmx: odyl_main.ml odyl_config.ml: echo "let standard_library =" > odyl_config.ml echo " try Sys.getenv \"CAMLP4LIB\" with" >> odyl_config.ml - echo " Not_found -> \"$(LIBDIR)/camlp4\"" >> odyl_config.ml + echo " Not_found -> \"$(LIBDIR)/camlp4\"" | \ + sed -e 's|\\|/|g' >> odyl_config.ml clean:: rm -f *.cm* *.pp[io] *.o *.bak .*.bak *.out *.opt *.a @@ -51,7 +52,7 @@ promote: compare: install: - -$(MKDIR) $(LIBDIR)/camlp4 $(BINDIR) - cp odyl.cmo odyl.cma $(LIBDIR)/camlp4/. + -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" + cp odyl.cmo odyl.cma "$(LIBDIR)/camlp4/." include .depend diff --git a/camlp4/odyl/odyl_main.ml b/camlp4/odyl/odyl_main.ml index b7633994a..c0996568d 100644 --- a/camlp4/odyl/odyl_main.ml +++ b/camlp4/odyl/odyl_main.ml @@ -1,4 +1,4 @@ -(* camlp4r pa_ifdef.cmo *) +(* camlp4r pa_macro.cmo *) (***********************************************************************) (* *) (* Camlp4 *) @@ -55,12 +55,13 @@ value initialized = ref False; value path = ref ([] : list string); value loadfile file = - ifdef OPT then + IFDEF OPT THEN raise (Error file "native-code program cannot do a dynamic load") - else do { + ELSE do { if not initialized.val then do { - ifdef OPT then () - else do { Dynlink.init (); Dynlink.allow_unsafe_modules True }; + IFDEF OPT THEN () + ELSE do { Dynlink.init (); Dynlink.allow_unsafe_modules True } + END; initialized.val := True } else (); @@ -75,6 +76,7 @@ value loadfile file = try Dynlink.loadfile fname with [ Dynlink.Error e -> raise (Error fname (Dynlink.error_message e)) ] } + END ; value directory d = path.val := [d :: path.val]; diff --git a/camlp4/tools/camlp4_comm.sh b/camlp4/tools/camlp4_comm.sh index d23a01cc5..0b0cab1dd 100755 --- a/camlp4/tools/camlp4_comm.sh +++ b/camlp4/tools/camlp4_comm.sh @@ -3,8 +3,10 @@ ARGS1= FILE= +QUIET=no while test "" != "$1"; do case $1 in + -q) QUIET=yes;; *.ml*) FILE=$1;; *) ARGS1="$ARGS1 $1";; esac @@ -22,7 +24,7 @@ if test "$2" = "camlp4r" -o "$2" = "camlp4"; then shift; shift ARGS2=`echo $* | sed -e "s/[()*]//g"` # ARGS1="$ARGS1 -verbose" - echo $COMM $ARGS2 $ARGS1 $FILE + if test "$QUIET" = "no"; then echo $COMM $ARGS2 $ARGS1 $FILE; fi $COMM $ARGS2 $ARGS1 $FILE else if test "`basename $FILE .mli`.mli" = "$FILE"; then @@ -30,6 +32,6 @@ else else OFILE=`basename $FILE .ml`.ppo fi - echo cp $FILE $OFILE + if test "$QUIET" = "no"; then echo cp $FILE $OFILE; fi cp $FILE $OFILE fi diff --git a/camlp4/tools/extract_crc.sh b/camlp4/tools/extract_crc.sh index e711fe10c..e69de29bb 100755 --- a/camlp4/tools/extract_crc.sh +++ b/camlp4/tools/extract_crc.sh @@ -1,6 +0,0 @@ -#!/bin/sh -e -COMM="ocamlrun$EXE $OTOP/otherlibs/dynlink/extract_crc" -if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM="$OTOP/boot/$COMM" -fi -$COMM $* diff --git a/camlp4/top/Makefile b/camlp4/top/Makefile index 986ed21d2..4ea4e46bc 100644 --- a/camlp4/top/Makefile +++ b/camlp4/top/Makefile @@ -8,11 +8,12 @@ OCAMLCFLAGS=-warn-error A $(INCLUDES) CAMLP4_OBJS=$(OTOP)/utils/config.cmo ../boot/stdpp.cmo ../boot/token.cmo ../boot/plexer.cmo ../boot/gramext.cmo ../boot/grammar.cmo ../boot/extfold.cmo ../boot/extfun.cmo ../boot/fstream.cmo ../camlp4/quotation.cmo ../camlp4/ast2pt.cmo ../camlp4/reloc.cmo ../camlp4/spretty.cmo ../camlp4/pcaml.cmo TOP=camlp4_top.cmo ROBJS=$(CAMLP4_OBJS) ../meta/pa_r.cmo ../meta/pa_rp.cmo rprint.cmo $(TOP) +SOBJS=$(CAMLP4_OBJS) ../etc/pa_scheme.cmo $(TOP) OOBJS=$(CAMLP4_OBJS) ../etc/pa_o.cmo ../etc/pa_op.cmo $(TOP) OOOBJS=$(CAMLP4_OBJS) ../etc/pa_o.cmo ../etc/pa_oop.cmo $(TOP) OBJS=$(OTOP)/utils/config.cmo ../camlp4/quotation.cmo ../camlp4/reloc.cmo ../camlp4/ast2pt.cmo ../camlp4/spretty.cmo ../camlp4/pcaml.cmo camlp4_top.cmo -TARGET=camlp4o.cma camlp4r.cma camlp4_top.cma +TARGET=camlp4o.cma camlp4r.cma camlp4sch.cma camlp4_top.cma all: $(TARGET) @@ -25,6 +26,9 @@ camlp4o.cma: $(OOBJS) camlp4r.cma: $(ROBJS) $(OCAMLC) $(ROBJS) -linkall -a -o camlp4r.cma +camlp4sch.cma: $(SOBJS) + $(OCAMLC) $(SOBJS) -linkall -a -o camlp4sch.cma + camlp4_top.cma: $(OBJS) $(OCAMLC) $(OBJS) -a -o camlp4_top.cma @@ -42,7 +46,7 @@ depend: get_promote: install: - -$(MKDIR) $(LIBDIR)/camlp4 - cp $(TARGET) $(LIBDIR)/camlp4/. + -$(MKDIR) "$(LIBDIR)/camlp4" + cp $(TARGET) "$(LIBDIR)/camlp4/." include .depend |