Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- commit e3d5b20b04c3bbec55330d7c6d88d5211e49083f
- Author: Gabriel Scherer <gabriel.scherer@inria.fr>
- Date: Tue Jun 4 17:11:10 2013 +0200
- camlp4 bootstrap
- diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml
- index 7ccaa75..2a6a4fb 100644
- --- a/camlp4/boot/Camlp4.ml
- +++ b/camlp4/boot/Camlp4.ml
- @@ -14522,7 +14522,12 @@ module Struct =
- function
- | Ast.TyMan (_, t1, t2) ->
- type_decl tl cl loc (Some (ctyp t1)) pflag t2
- - | Ast.TyPrv (_, t) -> type_decl tl cl loc m true t
- + | Ast.TyPrv (_loc, t) ->
- + if pflag
- + then
- + error _loc
- + "multiple private keyword used, use only one instead"
- + else type_decl tl cl loc m true t
- | Ast.TyRec (_, t) ->
- mktype loc tl cl
- (Ptype_record (List.map mktrecord (list_of_ctyp t [])))
- @@ -15347,7 +15352,7 @@ module Struct =
- | _ -> Pmodtype_manifest (module_type mt))
- in (mksig loc (Psig_modtype ((with_loc n loc), si))) :: l
- | SgOpn (loc, id) ->
- - (mksig loc (Psig_open (Fresh, long_uident id))) :: l
- + (mksig loc (Psig_open (Fresh, (long_uident id)))) :: l
- | SgTyp (loc, tdl) ->
- (mksig loc (Psig_type (mktype_decl tdl []))) :: l
- | SgVal (loc, n, t) ->
- @@ -15431,7 +15436,7 @@ module Struct =
- (Ast.OSome i)) ->
- (mkstr loc
- (Pstr_exn_rebind ((with_loc (conv_con s) loc),
- - (ident i)))) ::
- + (long_uident ~conv_con i)))) ::
- l
- | Ast.StExc (loc,
- (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, _)))), _)),
- @@ -15457,7 +15462,7 @@ module Struct =
- (Pstr_modtype ((with_loc n loc), (module_type mt)))) ::
- l
- | StOpn (loc, id) ->
- - (mkstr loc (Pstr_open (Fresh, long_uident id))) :: l
- + (mkstr loc (Pstr_open (Fresh, (long_uident id)))) :: l
- | StTyp (loc, tdl) ->
- (mkstr loc (Pstr_type (mktype_decl tdl []))) :: l
- | StVal (loc, rf, bi) ->
- @@ -17974,14 +17979,43 @@ module Struct =
- module Delete =
- struct
- + exception Rule_not_found of (string * string)
- +
- + let _ =
- + let () =
- + Printexc.register_printer
- + (function
- + | Rule_not_found ((symbols, entry)) ->
- + let msg =
- + Printf.sprintf
- + "rule %S cannot be found in entry\n%s" symbols
- + entry
- + in Some msg
- + | _ -> None)
- + in ()
- +
- module Make (Structure : Structure.S) =
- struct
- module Tools = Tools.Make(Structure)
- module Parser = Parser.Make(Structure)
- + module Print = Print.Make(Structure)
- +
- open Structure
- + let raise_rule_not_found entry symbols =
- + let to_string f x =
- + let buff = Buffer.create 128 in
- + let ppf = Format.formatter_of_buffer buff
- + in
- + (f ppf x;
- + Format.pp_print_flush ppf ();
- + Buffer.contents buff) in
- + let entry = to_string Print.entry entry in
- + let symbols = to_string Print.print_rule symbols
- + in raise (Rule_not_found ((symbols, entry)))
- +
- let delete_rule_in_tree entry =
- let rec delete_in_tree symbols tree =
- match (symbols, tree) with
- @@ -18080,7 +18114,7 @@ module Struct =
- let levs =
- delete_rule_in_suffix entry symbols levs
- in lev :: levs)
- - | [] -> raise Not_found
- + | [] -> raise_rule_not_found entry symbols
- let rec delete_rule_in_prefix entry symbols =
- function
- @@ -18107,7 +18141,7 @@ module Struct =
- let levs =
- delete_rule_in_prefix entry symbols levs
- in lev :: levs)
- - | [] -> raise Not_found
- + | [] -> raise_rule_not_found entry symbols
- let rec delete_rule_in_level_list entry symbols levs =
- match symbols with
- diff --git a/camlp4/boot/camlp4boot.ml b/camlp4/boot/camlp4boot.ml
- index 9f7a6d7..07a4b82 100644
- --- a/camlp4/boot/camlp4boot.ml
- +++ b/camlp4/boot/camlp4boot.ml
- @@ -957,8 +957,8 @@ New syntax:\
- and sequence' : 'sequence' Gram.Entry.t =
- grammar_entry_create "sequence'"
- and infixop6 : 'infixop6 Gram.Entry.t =
- - grammar_entry_create "infixop6"
- - in
- + grammar_entry_create "infixop6" in
- + let f1 () =
- (Gram.extend (module_expr : 'module_expr Gram.Entry.t)
- ((fun () ->
- (None,
- @@ -7143,8 +7143,9 @@ New syntax:\
- (mk_anti ~c: "ctyp" n s)) :
- 'meth_decl)
- | _ -> assert false))) ]) ]))
- - ());
- - Gram.extend (opt_meth_list : 'opt_meth_list Gram.Entry.t)
- + ()))
- + and f2 () =
- + (Gram.extend (opt_meth_list : 'opt_meth_list Gram.Entry.t)
- ((fun () ->
- (None,
- [ (None, None,
- @@ -9404,6 +9405,7 @@ New syntax:\
- | EOI -> (x : 'expr_eoi)
- | _ -> assert false))) ]) ]))
- ()))
- + in (f1 (); f2 ())
- end
- @@ -12053,6 +12055,76 @@ module G =
- let subst_gmod ast gmod = (new subst gmod)#expr ast
- + let linear_let_and _loc decls body =
- + match decls with
- + | [] -> body
- + | (i1, e1) :: xs ->
- + let bindings =
- + List.fold_right
- + (fun (i, e) acc ->
- + Ast.BiAnd (_loc, acc,
- + (Ast.BiEq (_loc,
- + (Ast.PaId (_loc, (Ast.IdLid (_loc, i)))), e))))
- + xs
- + (Ast.BiEq (_loc, (Ast.PaId (_loc, (Ast.IdLid (_loc, i1)))),
- + e1))
- + in Ast.ExLet (_loc, Ast.ReNil, bindings, body)
- +
- + let linear_seq _loc el =
- + match el with
- + | [] -> Ast.ExId (_loc, (Ast.IdUid (_loc, "()")))
- + | [ e ] -> e
- + | e :: el ->
- + Ast.ExSeq (_loc,
- + (List.fold_left (fun acc x -> Ast.ExSem (_loc, acc, x)) e el))
- +
- + let rec clever_seq _loc el =
- + let limit = 100
- + in
- + if (List.length el) <= limit
- + then linear_seq _loc el
- + else
- + (let unfold state next =
- + let rec unfold acc state next =
- + match next state with
- + | None -> ((List.rev acc), state)
- + | Some ((elem, state')) ->
- + unfold (elem :: acc) state' next
- + in unfold [] state next in
- + let take n li =
- + let (prefix, (_count, rest)) =
- + unfold (n, li)
- + (function
- + | (0, _) | (_, []) -> None
- + | (n, x :: xs) -> Some ((x, ((n - 1), xs))))
- + in (prefix, rest) in
- + let (bigseq, _) =
- + unfold (el, 1)
- + (fun (el, n) ->
- + match el with
- + | [] -> None
- + | rest ->
- + let funid = "f" ^ (string_of_int n) in
- + let (prefix, rest) = take limit rest
- + in
- + Some
- + (((funid,
- + (Ast.ExFun (_loc,
- + (Ast.McArr (_loc,
- + (Ast.PaId (_loc,
- + (Ast.IdUid (_loc, "()")))),
- + (Ast.ExNil _loc),
- + (linear_seq _loc prefix)))))),
- + (rest, (n + 1))))) in
- + let funcalls =
- + List.map
- + (fun (name, _) ->
- + Ast.ExApp (_loc,
- + (Ast.ExId (_loc, (Ast.IdLid (_loc, name)))),
- + (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))))))
- + bigseq
- + in linear_let_and _loc bigseq (clever_seq _loc funcalls))
- +
- let text_of_functorial_extend _loc gmod gram gl el =
- let args =
- let el =
- @@ -12089,14 +12161,7 @@ module G =
- (Ast.ExId (_loc, (Ast.IdUid (_loc, "()")))))))
- else e)
- el
- - in
- - match el with
- - | [] -> Ast.ExId (_loc, (Ast.IdUid (_loc, "()")))
- - | [ e ] -> e
- - | e :: el ->
- - Ast.ExSeq (_loc,
- - (List.fold_left (fun acc x -> Ast.ExSem (_loc, acc, x)) e
- - el))
- + in clever_seq _loc el
- in subst_gmod (let_in_of_extend _loc gram gl el args) gmod
- let wildcarder =
- @@ -15201,7 +15266,7 @@ module L =
- Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
- Gram.Skeyword "]" ];
- true)
- - with | Not_found -> false
- + with | Struct.Grammar.Delete.Rule_not_found _ -> false
- let comprehension_or_sem_expr_for_list =
- Gram.Entry.mk "comprehension_or_sem_expr_for_list"
Add Comment
Please, Sign In to add comment
