SHARE
TWEET

Untitled

a guest Feb 16th, 2019 81 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. commit e3d5b20b04c3bbec55330d7c6d88d5211e49083f
  2. Author: Gabriel Scherer <gabriel.scherer@inria.fr>
  3. Date:   Tue Jun 4 17:11:10 2013 +0200
  4.  
  5.     camlp4 bootstrap
  6.  
  7. diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml
  8. index 7ccaa75..2a6a4fb 100644
  9. --- a/camlp4/boot/Camlp4.ml
  10. +++ b/camlp4/boot/Camlp4.ml
  11. @@ -14522,7 +14522,12 @@ module Struct =
  12.                function
  13.                | Ast.TyMan (_, t1, t2) ->
  14.                    type_decl tl cl loc (Some (ctyp t1)) pflag t2
  15. -              | Ast.TyPrv (_, t) -> type_decl tl cl loc m true t
  16. +              | Ast.TyPrv (_loc, t) ->
  17. +                  if pflag
  18. +                  then
  19. +                    error _loc
  20. +                      "multiple private keyword used, use only one instead"
  21. +                  else type_decl tl cl loc m true t
  22.                | Ast.TyRec (_, t) ->
  23.                    mktype loc tl cl
  24.                      (Ptype_record (List.map mktrecord (list_of_ctyp t [])))
  25. @@ -15347,7 +15352,7 @@ module Struct =
  26.                       | _ -> Pmodtype_manifest (module_type mt))
  27.                    in (mksig loc (Psig_modtype ((with_loc n loc), si))) :: l
  28.                | SgOpn (loc, id) ->
  29. -                  (mksig loc (Psig_open (Fresh, long_uident id))) :: l
  30. +                  (mksig loc (Psig_open (Fresh, (long_uident id)))) :: l
  31.                | SgTyp (loc, tdl) ->
  32.                    (mksig loc (Psig_type (mktype_decl tdl []))) :: l
  33.                | SgVal (loc, n, t) ->
  34. @@ -15431,7 +15436,7 @@ module Struct =
  35.                    (Ast.OSome i)) ->
  36.                    (mkstr loc
  37.                       (Pstr_exn_rebind ((with_loc (conv_con s) loc),
  38. -                        (ident i)))) ::
  39. +                        (long_uident ~conv_con i)))) ::
  40.                      l
  41.                | Ast.StExc (loc,
  42.                    (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, _)))), _)),
  43. @@ -15457,7 +15462,7 @@ module Struct =
  44.                       (Pstr_modtype ((with_loc n loc), (module_type mt)))) ::
  45.                      l
  46.                | StOpn (loc, id) ->
  47. -                  (mkstr loc (Pstr_open (Fresh, long_uident id))) :: l
  48. +                  (mkstr loc (Pstr_open (Fresh, (long_uident id)))) :: l
  49.                | StTyp (loc, tdl) ->
  50.                    (mkstr loc (Pstr_type (mktype_decl tdl []))) :: l
  51.                | StVal (loc, rf, bi) ->
  52. @@ -17974,14 +17979,43 @@ module Struct =
  53.            
  54.          module Delete =
  55.            struct
  56. +            exception Rule_not_found of (string * string)
  57. +              
  58. +            let _ =
  59. +              let () =
  60. +                Printexc.register_printer
  61. +                  (function
  62. +                   | Rule_not_found ((symbols, entry)) ->
  63. +                       let msg =
  64. +                         Printf.sprintf
  65. +                           "rule %S cannot be found in entry\n%s" symbols
  66. +                           entry
  67. +                       in Some msg
  68. +                   | _ -> None)
  69. +              in ()
  70. +              
  71.              module Make (Structure : Structure.S) =
  72.                struct
  73.                  module Tools = Tools.Make(Structure)
  74.                    
  75.                  module Parser = Parser.Make(Structure)
  76.                    
  77. +                module Print = Print.Make(Structure)
  78. +                  
  79.                  open Structure
  80.                    
  81. +                let raise_rule_not_found entry symbols =
  82. +                  let to_string f x =
  83. +                    let buff = Buffer.create 128 in
  84. +                    let ppf = Format.formatter_of_buffer buff
  85. +                    in
  86. +                      (f ppf x;
  87. +                       Format.pp_print_flush ppf ();
  88. +                       Buffer.contents buff) in
  89. +                  let entry = to_string Print.entry entry in
  90. +                  let symbols = to_string Print.print_rule symbols
  91. +                  in raise (Rule_not_found ((symbols, entry)))
  92. +                  
  93.                  let delete_rule_in_tree entry =
  94.                    let rec delete_in_tree symbols tree =
  95.                      match (symbols, tree) with
  96. @@ -18080,7 +18114,7 @@ module Struct =
  97.                             let levs =
  98.                               delete_rule_in_suffix entry symbols levs
  99.                             in lev :: levs)
  100. -                  | [] -> raise Not_found
  101. +                  | [] -> raise_rule_not_found entry symbols
  102.                    
  103.                  let rec delete_rule_in_prefix entry symbols =
  104.                    function
  105. @@ -18107,7 +18141,7 @@ module Struct =
  106.                             let levs =
  107.                               delete_rule_in_prefix entry symbols levs
  108.                             in lev :: levs)
  109. -                  | [] -> raise Not_found
  110. +                  | [] -> raise_rule_not_found entry symbols
  111.                    
  112.                  let rec delete_rule_in_level_list entry symbols levs =
  113.                    match symbols with
  114. diff --git a/camlp4/boot/camlp4boot.ml b/camlp4/boot/camlp4boot.ml
  115. index 9f7a6d7..07a4b82 100644
  116. --- a/camlp4/boot/camlp4boot.ml
  117. +++ b/camlp4/boot/camlp4boot.ml
  118. @@ -957,8 +957,8 @@ New syntax:\
  119.            and sequence' : 'sequence' Gram.Entry.t =
  120.              grammar_entry_create "sequence'"
  121.            and infixop6 : 'infixop6 Gram.Entry.t =
  122. -            grammar_entry_create "infixop6"
  123. -          in
  124. +            grammar_entry_create "infixop6" in
  125. +          let f1 () =
  126.              (Gram.extend (module_expr : 'module_expr Gram.Entry.t)
  127.                 ((fun () ->
  128.                     (None,
  129. @@ -7143,8 +7143,9 @@ New syntax:\
  130.                                         (mk_anti ~c: "ctyp" n s)) :
  131.                                        'meth_decl)
  132.                                  | _ -> assert false))) ]) ]))
  133. -                  ());
  134. -             Gram.extend (opt_meth_list : 'opt_meth_list Gram.Entry.t)
  135. +                  ()))
  136. +          and f2 () =
  137. +            (Gram.extend (opt_meth_list : 'opt_meth_list Gram.Entry.t)
  138.                 ((fun () ->
  139.                     (None,
  140.                      [ (None, None,
  141. @@ -9404,6 +9405,7 @@ New syntax:\
  142.                                  | EOI -> (x : 'expr_eoi)
  143.                                  | _ -> assert false))) ]) ]))
  144.                    ()))
  145. +          in (f1 (); f2 ())
  146.            
  147.        end
  148.        
  149. @@ -12053,6 +12055,76 @@ module G =
  150.            
  151.          let subst_gmod ast gmod = (new subst gmod)#expr ast
  152.            
  153. +        let linear_let_and _loc decls body =
  154. +          match decls with
  155. +          | [] -> body
  156. +          | (i1, e1) :: xs ->
  157. +              let bindings =
  158. +                List.fold_right
  159. +                  (fun (i, e) acc ->
  160. +                     Ast.BiAnd (_loc, acc,
  161. +                       (Ast.BiEq (_loc,
  162. +                          (Ast.PaId (_loc, (Ast.IdLid (_loc, i)))), e))))
  163. +                  xs
  164. +                  (Ast.BiEq (_loc, (Ast.PaId (_loc, (Ast.IdLid (_loc, i1)))),
  165. +                     e1))
  166. +              in Ast.ExLet (_loc, Ast.ReNil, bindings, body)
  167. +          
  168. +        let linear_seq _loc el =
  169. +          match el with
  170. +          | [] -> Ast.ExId (_loc, (Ast.IdUid (_loc, "()")))
  171. +          | [ e ] -> e
  172. +          | e :: el ->
  173. +              Ast.ExSeq (_loc,
  174. +                (List.fold_left (fun acc x -> Ast.ExSem (_loc, acc, x)) e el))
  175. +          
  176. +        let rec clever_seq _loc el =
  177. +          let limit = 100
  178. +          in
  179. +            if (List.length el) <= limit
  180. +            then linear_seq _loc el
  181. +            else
  182. +              (let unfold state next =
  183. +                 let rec unfold acc state next =
  184. +                   match next state with
  185. +                   | None -> ((List.rev acc), state)
  186. +                   | Some ((elem, state')) ->
  187. +                       unfold (elem :: acc) state' next
  188. +                 in unfold [] state next in
  189. +               let take n li =
  190. +                 let (prefix, (_count, rest)) =
  191. +                   unfold (n, li)
  192. +                     (function
  193. +                      | (0, _) | (_, []) -> None
  194. +                      | (n, x :: xs) -> Some ((x, ((n - 1), xs))))
  195. +                 in (prefix, rest) in
  196. +               let (bigseq, _) =
  197. +                 unfold (el, 1)
  198. +                   (fun (el, n) ->
  199. +                      match el with
  200. +                      | [] -> None
  201. +                      | rest ->
  202. +                          let funid = "f" ^ (string_of_int n) in
  203. +                          let (prefix, rest) = take limit rest
  204. +                          in
  205. +                            Some
  206. +                              (((funid,
  207. +                                 (Ast.ExFun (_loc,
  208. +                                    (Ast.McArr (_loc,
  209. +                                       (Ast.PaId (_loc,
  210. +                                          (Ast.IdUid (_loc, "()")))),
  211. +                                       (Ast.ExNil _loc),
  212. +                                       (linear_seq _loc prefix)))))),
  213. +                                (rest, (n + 1))))) in
  214. +               let funcalls =
  215. +                 List.map
  216. +                   (fun (name, _) ->
  217. +                      Ast.ExApp (_loc,
  218. +                        (Ast.ExId (_loc, (Ast.IdLid (_loc, name)))),
  219. +                        (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))))))
  220. +                   bigseq
  221. +               in linear_let_and _loc bigseq (clever_seq _loc funcalls))
  222. +          
  223.          let text_of_functorial_extend _loc gmod gram gl el =
  224.            let args =
  225.              let el =
  226. @@ -12089,14 +12161,7 @@ module G =
  227.                              (Ast.ExId (_loc, (Ast.IdUid (_loc, "()")))))))
  228.                       else e)
  229.                  el
  230. -            in
  231. -              match el with
  232. -              | [] -> Ast.ExId (_loc, (Ast.IdUid (_loc, "()")))
  233. -              | [ e ] -> e
  234. -              | e :: el ->
  235. -                  Ast.ExSeq (_loc,
  236. -                    (List.fold_left (fun acc x -> Ast.ExSem (_loc, acc, x)) e
  237. -                       el))
  238. +            in clever_seq _loc el
  239.            in subst_gmod (let_in_of_extend _loc gram gl el args) gmod
  240.            
  241.          let wildcarder =
  242. @@ -15201,7 +15266,7 @@ module L =
  243.                   Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t));
  244.                   Gram.Skeyword "]" ];
  245.               true)
  246. -          with | Not_found -> false
  247. +          with | Struct.Grammar.Delete.Rule_not_found _ -> false
  248.            
  249.          let comprehension_or_sem_expr_for_list =
  250.            Gram.Entry.mk "comprehension_or_sem_expr_for_list"
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top