Commits

HongboZhang committed 4dbe926

refactored finished

  • Participants
  • Parent commits f625805

Comments (0)

Files changed (33)

build/partial-install.sh

 installbin camlp4/camlp4orf.native$EXE $BINDIR/camlp4orf.opt$EXE
 installbin camlp4/camlp4r.native$EXE $BINDIR/camlp4r.opt$EXE
 installbin camlp4/camlp4rf.native$EXE $BINDIR/camlp4rf.opt$EXE
-
+# add MakeCamlp4Bin to install
 if test -d camlp4; then
   cd camlp4
   CAMLP4DIR=$LIBDIR/camlp4
     camlp4fulllib.cma camlp4fulllib.cmxa \
     camlp4o.cma camlp4of.cma camlp4oof.cma \
     camlp4orf.cma camlp4r.cma camlp4rf.cma \
-    Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Top.cm[io] \
+    MakeCamlp4Bin.cm[iox] Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Top.cm[io] \
     Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O Camlp4_import.cmi \
     $CAMLP4DIR
   installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR

camlp4/Camlp4.mlpack

 ErrorHandler
 MakePreCast
 MakeRegister
-MakeCamlp4Bin
 OCamlInitSyntax
 Options
 PreCast
 Register
 Sig
 Struct
+

camlp4/Camlp4/MakeRegister.ml

   value enable_null_printer : unit -> unit;
   value enable_dump_ocaml_ast_printer : unit -> unit;
   value enable_dump_camlp4_ast_printer : unit -> unit;
+  value enable_auto : (unit -> bool) -> unit ;  
   end ;
 (* end; *)
   
 
   value enable_null_printer () =
     let module M = Printer PP.Null.Id PP.Null.Make in ();
+
+  value enable_auto isatty  =
+    if isatty () then
+      enable_ocaml_printer ()
+    else
+      enable_dump_ocaml_ast_printer ();
+
 end;

camlp4/Camlp4/Sig.ml

   module AstFilters:AstFilters with module Ast = Ast; 
 end ;
 
-  
+

camlp4/Camlp4Bin.ml

 ();
       
 
-(* open Camlp4;
- * open PreCast.Syntax;
- * open PreCast;
- * open Format;
- * module CleanAst = Camlp4.Struct.CleanAst.Make PreCast.Ast;
- * module SSet = Set.Make String;
- * 
- * value pa_r  = "Camlp4OCamlRevisedParser";
- * value pa_rr = "Camlp4OCamlReloadedParser";
- * value pa_o  = "Camlp4OCamlParser";
- * value pa_rp = "Camlp4OCamlRevisedParserParser";
- * value pa_op = "Camlp4OCamlParserParser";
- * value pa_g  = "Camlp4GrammarParser";
- * value pa_m  = "Camlp4MacroParser";
- * value pa_qb = "Camlp4QuotationCommon";
- * value pa_q  = "Camlp4QuotationExpander";
- * value pa_rq = "Camlp4OCamlRevisedQuotationExpander";
- * value pa_oq = "Camlp4OCamlOriginalQuotationExpander";
- * value pa_l  = "Camlp4ListComprehension";
- * 
- * (\* open Register; *\)
- * 
- * value dyn_loader = ref (fun []);
- * value rcall_callback = ref (fun () -> ());
- * value loaded_modules = ref SSet.empty;
- * value add_to_loaded_modules name =
- *   loaded_modules.val := SSet.add name loaded_modules.val;
- * 
- * value (objext,libext) =
- *   if PreCast.DynLoader.is_native then (".cmxs",".cmxs")
- *   else (".cmo",".cma");
- * 
- * value rewrite_and_load n x =
- *   let dyn_loader = dyn_loader.val () in
- *   let find_in_path = PreCast.DynLoader.find_in_path dyn_loader in
- *   let real_load name = do {
- *     add_to_loaded_modules name;
- *     PreCast.DynLoader.load dyn_loader name
- *   } in
- *   let load = List.iter begin fun n ->
- *     if SSet.mem n loaded_modules.val || List.mem n Register.loaded_modules.val then ()
- *     else begin
- *       add_to_loaded_modules n;
- *       PreCast.DynLoader.load dyn_loader (n ^ objext);
- *     end
- *   end in
- *   do {
- *     match (n, String.lowercase x) with
- *     [ ("Parsers"|"", "pa_r.cmo"      | "r"  | "ocamlr" | "ocamlrevised" | "camlp4ocamlrevisedparser.cmo") -> load [pa_r]
- *     | ("Parsers"|"", "rr" | "reloaded" | "ocamlreloaded" | "camlp4ocamlreloadedparser.cmo") -> load [pa_rr]
- *     | ("Parsers"|"", "pa_o.cmo"      | "o"  | "ocaml" | "camlp4ocamlparser.cmo") -> load [pa_r; pa_o]
- *     | ("Parsers"|"", "pa_rp.cmo"     | "rp" | "rparser" | "camlp4ocamlrevisedparserparser.cmo") -> load [pa_r; pa_rp]
- *     | ("Parsers"|"", "pa_op.cmo"     | "op" | "parser" | "camlp4ocamlparserparser.cmo") -> load [pa_r; pa_o; pa_rp; pa_op]
- *     | ("Parsers"|"", "pa_extend.cmo" | "pa_extend_m.cmo" | "g" | "grammar" | "camlp4grammarparser.cmo") -> load [pa_g]
- *     | ("Parsers"|"", "pa_macro.cmo"  | "m"  | "macro" | "camlp4macroparser.cmo") -> load [pa_m]
- *     | ("Parsers"|"", "q" | "camlp4quotationexpander.cmo") -> load [pa_qb; pa_q]
- *     | ("Parsers"|"", "q_mlast.cmo" | "rq" | "camlp4ocamlrevisedquotationexpander.cmo") -> load [pa_qb; pa_rq]
- *     | ("Parsers"|"", "oq" | "camlp4ocamloriginalquotationexpander.cmo") -> load [pa_r; pa_o; pa_qb; pa_oq]
- *     | ("Parsers"|"", "rf") -> load [pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m]
- *     | ("Parsers"|"", "of") -> load [pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_q; pa_g; pa_l; pa_m]
- *     | ("Parsers"|"", "comp" | "camlp4listcomprehension.cmo") -> load [pa_l]
- *     | ("Filters"|"", "lift" | "camlp4astlifter.cmo") -> load ["Camlp4AstLifter"]
- *     | ("Filters"|"", "exn" | "camlp4exceptiontracer.cmo") -> load ["Camlp4ExceptionTracer"]
- *     | ("Filters"|"", "prof" | "camlp4profiler.cmo") -> load ["Camlp4Profiler"]
- *     (\* map is now an alias of fold since fold handles map too *\)
- *     | ("Filters"|"", "map" | "camlp4mapgenerator.cmo") -> load ["Camlp4FoldGenerator"]
- *     | ("Filters"|"", "fold" | "camlp4foldgenerator.cmo") -> load ["Camlp4FoldGenerator"]
- *     | ("Filters"|"", "meta" | "camlp4metagenerator.cmo") -> load ["Camlp4MetaGenerator"]
- *     | ("Filters"|"", "trash" | "camlp4trashremover.cmo") -> load ["Camlp4TrashRemover"]
- *     | ("Filters"|"", "striploc" | "camlp4locationstripper.cmo") -> load ["Camlp4LocationStripper"]
- *     | ("Printers"|"", "pr_r.cmo" | "r" | "ocamlr" | "camlp4ocamlrevisedprinter.cmo") ->
- *         Register.enable_ocamlr_printer ()
- *     | ("Printers"|"", "pr_o.cmo" | "o" | "ocaml" | "camlp4ocamlprinter.cmo") ->
- *         Register.enable_ocaml_printer ()
- *     | ("Printers"|"", "pr_dump.cmo" | "p" | "dumpocaml" | "camlp4ocamlastdumper.cmo") ->
- *         Register.enable_dump_ocaml_ast_printer ()
- *     | ("Printers"|"", "d" | "dumpcamlp4" | "camlp4astdumper.cmo") ->
- *         Register.enable_dump_camlp4_ast_printer ()
- *     | ("Printers"|"", "a" | "auto" | "camlp4autoprinter.cmo") ->
- *         load ["Camlp4AutoPrinter"]
- *     | _ ->
- *       let y = "Camlp4"^n^"/"^x^objext in
- *       real_load (try find_in_path y with [ Not_found -> x ]) ];
- *     rcall_callback.val ();
- *   };
- * 
- * value print_warning = eprintf "%a:\n%s@." PreCast.Loc.print;
- * 
- * value rec parse_file dyn_loader name pa getdir =
- *   let directive_handler = Some (fun ast ->
- *     match getdir ast with
- *     [ Some x ->
- *         match x with
- *         [ (_, "load", s) -> do { rewrite_and_load "" s; None }
- *         | (_, "directory", s) -> do { PreCast.DynLoader.include_dir dyn_loader s; None }
- *         | (_, "use", s) -> Some (parse_file dyn_loader s pa getdir)
- *         | (_, "default_quotation", s) -> do { PreCast.Quotation.default.val := s; None }
- *         | (loc, _, _) -> PreCast.Loc.raise loc (Stream.Error "bad directive") ]
- *     | None -> None ]) in
- *   let loc = PreCast.Loc.mk name
- *   in do {
- *     PreCast.Syntax.current_warning.val := print_warning;
- *     let ic = if name = "-" then stdin else open_in_bin name;
- *     let cs = Stream.of_channel ic;
- *     let clear () = if name = "-" then () else close_in ic;
- *     let phr =
- *       try pa ?directive_handler loc cs
- *       with x -> do { clear (); raise x };
- *     clear ();
- *     phr
- *   };
- * 
- * value output_file = ref None;
- * 
- * value process dyn_loader name pa pr clean fold_filters getdir =
- *   let ast = parse_file dyn_loader name pa getdir in
- *   let ast = fold_filters (fun t filter -> filter t) ast in
- *   let ast = clean ast in
- *   pr ?input_file:(Some name) ?output_file:output_file.val ast;
- * 
- * value gind =
- *   fun
- *   [ <:sig_item@loc< # $n$ $str:s$ >> -> Some (loc, n, s)
- *   | _ -> None ];
- * 
- * value gimd =
- *   fun
- *   [ <:str_item@loc< # $n$ $str:s$ >> -> Some (loc, n, s)
- *   | _ -> None ];
- * 
- * value process_intf dyn_loader name =
- *   process dyn_loader name Register.CurrentParser.parse_interf Register.CurrentPrinter.print_interf
- *           (new CleanAst.clean_ast)#sig_item
- *           AstFilters.fold_interf_filters gind;
- * value process_impl dyn_loader name =
- *   process dyn_loader name Register.CurrentParser.parse_implem Register.CurrentPrinter.print_implem
- *           (new CleanAst.clean_ast)#str_item
- *           AstFilters.fold_implem_filters gimd;
- * 
- * value just_print_the_version () =
- *   do { printf "%s@." Camlp4_config.version; exit 0 };
- * 
- * value print_version () =
- *   do { eprintf "Camlp4 version %s@." Camlp4_config.version; exit 0 };
- * 
- * value print_stdlib () =
- *   do { printf "%s@." Camlp4_config.camlp4_standard_library; exit 0 };
- * 
- * value usage ini_sl ext_sl =
- *   do {
- *     eprintf "\
- * Usage: camlp4 [load-options] [--] [other-options]\n\
- * Options:\n\
- * <file>.ml        Parse this implementation file\n\
- * <file>.mli       Parse this interface file\n\
- * <file>.%s Load this module inside the Camlp4 core@."
- * (if DynLoader.is_native then "cmxs     " else "(cmo|cma)")
- * ;
- *     Options.print_usage_list ini_sl;
- *     (\* loop (ini_sl @ ext_sl) where rec loop =
- *       fun
- *       [ [(y, _, _) :: _] when y = "-help" -> ()
- *       | [_ :: sl] -> loop sl
- *       | [] -> eprintf "  -help         Display this list of options.@." ];    *\)
- *     if ext_sl <> [] then do {
- *       eprintf "Options added by loaded object files:@.";
- *       Options.print_usage_list ext_sl;
- *     }
- *     else ();
- *   };
- * 
- * value warn_noassert () =
- *   do {
- *     eprintf "\
- * camlp4 warning: option -noassert is obsolete\n\
- * You should give the -noassert option to the ocaml compiler instead.@.";
- *   };
- * 
- * type file_kind =
- *   [ Intf of string
- *   | Impl of string
- *   | Str of string
- *   | ModuleImpl of string
- *   | IncludeDir of string ];
- * 
- * value search_stdlib = ref True;
- * value print_loaded_modules = ref False;
- * value (task, do_task) =
- *   let t = ref None in
- *   let task f x =
- *     let () = Camlp4_config.current_input_file.val := x in
- *     t.val := Some (if t.val = None then (fun _ -> f x)
- *                    else (fun usage -> usage ())) in
- *   let do_task usage = match t.val with [ Some f -> f usage | None -> () ] in
- *   (task, do_task);
- * value input_file x =
- *   let dyn_loader = dyn_loader.val () in
- *   do {
- *     rcall_callback.val ();
- *     match x with
- *     [ Intf file_name -> task (process_intf dyn_loader) file_name
- *     | Impl file_name -> task (process_impl dyn_loader) file_name
- *     | Str s ->
- *         begin
- *           let (f, o) = Filename.open_temp_file "from_string" ".ml";
- *           output_string o s;
- *           close_out o;
- *           task (process_impl dyn_loader) f;
- *           at_exit (fun () -> Sys.remove f);
- *         end
- *     | ModuleImpl file_name -> rewrite_and_load "" file_name
- *     | IncludeDir dir -> DynLoader.include_dir dyn_loader dir ];
- *     rcall_callback.val ();
- *   };
- * 
- * value initial_spec_list =
- *   [("-I", Arg.String (fun x -> input_file (IncludeDir x)),
- *     "<directory>  Add directory in search patch for object files.");
- *   ("-where", Arg.Unit print_stdlib,
- *     "Print camlp4 library directory and exit.");
- *   ("-nolib", Arg.Clear search_stdlib,
- *     "No automatic search for object files in library directory.");
- *   ("-intf", Arg.String (fun x -> input_file (Intf x)),
- *     "<file>  Parse <file> as an interface, whatever its extension.");
- *   ("-impl", Arg.String (fun x -> input_file (Impl x)),
- *     "<file>  Parse <file> as an implementation, whatever its extension.");
- *   ("-str", Arg.String (fun x -> input_file (Str x)),
- *     "<string>  Parse <string> as an implementation.");
- *   ("-unsafe", Arg.Set Camlp4_config.unsafe,
- *     "Generate unsafe accesses to array and strings.");
- *   ("-noassert", Arg.Unit warn_noassert,
- *     "Obsolete, do not use this option.");
- *   ("-verbose", Arg.Set Camlp4_config.verbose,
- *     "More verbose in parsing errors.");
- *   ("-loc", Arg.Set_string Loc.name,
- *     "<name>   Name of the location variable (default: " ^ Loc.name.val ^ ").");
- *   ("-QD", Arg.String (fun x -> Quotation.dump_file.val := Some x),
- *     "<file> Dump quotation expander result in case of syntax error.");
- *   ("-o", Arg.String (fun x -> output_file.val := Some x),
- *     "<file> Output on <file> instead of standard output.");
- *   ("-v", Arg.Unit print_version,
- *     "Print Camlp4 version and exit.");
- *   ("-version", Arg.Unit just_print_the_version,
- *     "Print Camlp4 version number and exit.");
- *   ("-vnum", Arg.Unit just_print_the_version,
- *     "Print Camlp4 version number and exit.");
- *   ("-no_quot", Arg.Clear Camlp4_config.quotations,
- *     "Don't parse quotations, allowing to use, e.g. \"<:>\" as token.");
- *   ("-loaded-modules", Arg.Set print_loaded_modules, "Print the list of loaded modules.");
- *   ("-parser", Arg.String (rewrite_and_load "Parsers"),
- *     "<name>  Load the parser Camlp4Parsers/<name>.cm(o|a|xs)");
- *   ("-printer", Arg.String (rewrite_and_load "Printers"),
- *     "<name>  Load the printer Camlp4Printers/<name>.cm(o|a|xs)");
- *   ("-filter", Arg.String (rewrite_and_load "Filters"),
- *     "<name>  Load the filter Camlp4Filters/<name>.cm(o|a|xs)");
- *   ("-ignore", Arg.String ignore, "ignore the next argument");
- *   ("--", Arg.Unit ignore, "Deprecated, does nothing")
- * ];
- * 
- * Options.init initial_spec_list;
- * 
- * value anon_fun name =
- *   input_file
- *   (if Filename.check_suffix name ".mli" then Intf name
- *     else if Filename.check_suffix name ".ml" then Impl name
- *     else if Filename.check_suffix name objext then ModuleImpl name
- *     else if Filename.check_suffix name libext then ModuleImpl name
- *     else raise (Arg.Bad ("don't know what to do with " ^ name)));
- * 
- * value main argv =
- *   let usage () = do { usage initial_spec_list (Options.ext_spec_list ()); exit 0 } in
- *   try do {
- *     let dynloader = DynLoader.mk ~ocaml_stdlib:search_stdlib.val
- *                                  ~camlp4_stdlib:search_stdlib.val ();
- *     dyn_loader.val := fun () -> dynloader;
- *     let call_callback () =
- *       Register.iter_and_take_callbacks
- *         (fun (name, module_callback) ->
- *            let () = add_to_loaded_modules name in
- *            module_callback ());
- *     call_callback ();
- *     rcall_callback.val := call_callback;
- *     match Options.parse anon_fun argv with
- *     [ [] -> ()
- *     | ["-help"|"--help"|"-h"|"-?" :: _] -> usage ()
- *     | [s :: _] ->
- *         do { eprintf "%s: unknown or misused option\n" s;
- *             eprintf "Use option -help for usage@.";
- *             exit 2 } ];
- *     do_task usage;
- *     call_callback ();
- *     if print_loaded_modules.val then do {
- *       SSet.iter (eprintf "%s@.") loaded_modules.val;
- *     } else ()
- *   }
- *   with
- *   [ Arg.Bad s -> do { eprintf "Error: %s\n" s;
- *                       eprintf "Use option -help for usage@.";
- *                       exit 2 }
- *   | Arg.Help _ -> usage ()
- *   | exc -> do { eprintf "@[<v0>%a@]@." ErrorHandler.print exc; exit 2 } ];
- * 
- * main Sys.argv; *)

camlp4/Camlp4Filters/Camlp4AstLifter.ml

  *)
 
 
-(* open Camlp4; *)
+open Camlp4;
 
-
-let module M = Camlp4.Register.AstFilter
-    Camlp4Filters.IdAstLifter Camlp4Filters.MakeAstLifter in ();
+Camlp4Filters.f_lift (module Register);

camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml

 (*                                                                          *)
 (****************************************************************************)
 
-(* Authors:
- * - Nicolas Pouillard: initial version
- *)
 
+open Camlp4;
 
-
-let module M = Camlp4.Register.AstFilter
-    Camlp4Filters.IdExceptionTracer
-    Camlp4Filters.MakeExceptionTracer in ();
+Camlp4Filters.f_exn (module Register);

camlp4/Camlp4Filters/Camlp4Filters.ml

   register_str_item_filter filter;
 end;
   
+value f_lift (module Register:MakeRegister.S) =
+  let module M = Register.AstFilter IdAstLifter MakeAstLifter in ();
+value f_exn (module Register:MakeRegister.S) =
+  let module M = Register.AstFilter IdExceptionTracer MakeExceptionTracer in ();
+value f_prof (module Register:MakeRegister.S) =
+  let module M = Register.AstFilter IdProfiler MakeProfiler in ();
+value f_fold (module Register:MakeRegister.S) =
+  let module M = Register.AstFilter IdFoldGenerator MakeFoldGenerator in ();
+value f_striploc (module Register:MakeRegister.S) =
+  let module M = Register.AstFilter IdLocationStripper MakeLocationStripper in ();
+value f_trash (module Register:MakeRegister.S) =
+  let module M = Register.AstFilter IdTrashRemover MakeTrashRemover in ();
+value f_meta (module Register:MakeRegister.S) =
+  let module M = Register.AstFilter IdMetaGenerator MakeMetaGenerator in ();
+  
+  

camlp4/Camlp4Filters/Camlp4FoldGenerator.ml

  * - Nicolas Pouillard: initial version
  *)
 
-
-
-
-
-
-let module M = Camlp4.Register.AstFilter
-    Camlp4Filters.IdFoldGenerator
-    Camlp4Filters.MakeFoldGenerator  in
-  () ;
+open Camlp4;
+Camlp4Filters.f_fold (module Register);

camlp4/Camlp4Filters/Camlp4LocationStripper.ml

 
 open Camlp4;
 
+Camlp4Filters.f_striploc (module Register);
 
-let module M = Camlp4.Register.AstFilter
-    Camlp4Filters.IdLocationStripper
-    Camlp4Filters.MakeLocationStripper in ();

camlp4/Camlp4Filters/Camlp4MetaGenerator.ml

 (* open Camlp4; *)
 (* open PreCast; *)
 (* AstFilters.register_str_item_filter filter; *)
-
-let module M = Camlp4.Register.AstFilter
-  Camlp4Filters.IdMetaGenerator
-  Camlp4Filters.MakeMetaGenerator in ();
+open Camlp4;
+Camlp4Filters.f_meta (module Register);

camlp4/Camlp4Filters/Camlp4Profiler.ml

 
 open Camlp4;
 
-
-let module M = Camlp4.Register.AstFilter
-    Camlp4Filters.IdProfiler
-    Camlp4Filters.MakeProfiler in ();
+Camlp4Filters.f_prof (module Register);

camlp4/Camlp4Filters/Camlp4TrashRemover.ml

 
 open Camlp4;
 
-
-let module M = Camlp4.Register.AstFilter
-    Camlp4Filters.IdTrashRemover
-    Camlp4Filters.MakeTrashRemover in ();
+Camlp4Filters.f_trash (module Register);

camlp4/Camlp4Parsers/Camlp4GrammarParser.ml

 (*                                                                          *)
 (****************************************************************************)
 
-(* Authors:
- * - Daniel de Rauglaudre: initial version
- * - Nicolas Pouillard: refactoring
- *)
-
-
-
-module M = Register.OCamlSyntaxExtension Camlp4Parsers.IdGrammarParser
-    Camlp4Parsers.MakeGrammarParser;
+open Camlp4;
+open Camlp4Parsers;
+pa_g (module Register);

camlp4/Camlp4Parsers/Camlp4ListComprehension.ml

 
 
 
-let module M = Register.OCamlSyntaxExtension Camlp4Parsers.IdListComprehension
-    Camlp4Parsers.MakeListComprehension in ();
+(* let module M = Register.OCamlSyntaxExtension Camlp4Parsers.IdListComprehension
+ *     Camlp4Parsers.MakeListComprehension in (); *)
+open Camlp4;
+open Camlp4Parsers;
+pa_l (module Register);

camlp4/Camlp4Parsers/Camlp4MacroParser.ml

  * - Jean-vincent Loddo: definitions inside IFs.
  *)
 
-let module M = Register.OCamlSyntaxExtension Camlp4Parsers.IdMacroParser
-    Camlp4Parsers.MakeMacroParser in ();
-let module M = Camlp4.Register.AstFilter Camlp4Parsers.IdMacroParser
-    Camlp4Parsers.MakeNothing in ();
+(* let module M = Register.OCamlSyntaxExtension Camlp4Parsers.IdMacroParser
+ *     Camlp4Parsers.MakeMacroParser in ();
+ * let module M = Camlp4.Register.AstFilter Camlp4Parsers.IdMacroParser
+ *     Camlp4Parsers.MakeNothing in (); *)
+open Camlp4;
+open Camlp4Parsers;
+pa_m (module Register);

camlp4/Camlp4Parsers/Camlp4OCamlOriginalQuotationExpander.ml

  * - Nicolas Pouillard: initial version
  *)
 
-open PreCast;
-let module Gram = MakeGram Lexer in
-let module M1 = OCamlInitSyntax.Make Ast Gram Quotation in
-let module M2 = Camlp4Parsers.MakeRevisedParser M1 in
-let module M3 = Camlp4Parsers.MakeParser M2 in
-let module M3 = Camlp4QuotationCommon.Make M3 Syntax.AntiquotSyntax in ();
+open Camlp4;
+open Camlp4Parsers;
+(* let module Gram = MakeGram Lexer in
+ * let module M1 = OCamlInitSyntax.Make Ast Gram Quotation in
+ * let module M2 = MakeRevisedParser M1 in
+ * let module M3 = MakeParser M2 in
+ * let module M3 = MakeQuotationCommon M3 Syntax.AntiquotSyntax  in (); *)
+
+pa_oq (module Register) (module PreCast);

camlp4/Camlp4Parsers/Camlp4OCamlParser.ml

 (*                                                                          *)
 (****************************************************************************)
 
-(* Authors:
- * - Daniel de Rauglaudre: initial version
- * - Nicolas Pouillard: refactoring
- *)
 
-
-
-let module M = Register.OCamlSyntaxExtension
-    Camlp4Parsers.IdParser
-    Camlp4Parsers.MakeParser in ();
+open Camlp4;
+open Camlp4Parsers;
+pa_o (module Register);

camlp4/Camlp4Parsers/Camlp4OCamlParserParser.ml

 
 
 open Camlp4;
-
-
-let module M = Register.OCamlSyntaxExtension
-    Camlp4Parsers.IdOCamlParserParser
-    Camlp4Parsers.MakeOCamlParserParser in ();
+open Camlp4Parsers;
+pa_op (module Register);

camlp4/Camlp4Parsers/Camlp4OCamlReloadedParser.ml

  *)
 
 
-let module M = Register.OCamlSyntaxExtension Camlp4Parsers.IdReloadedParser
-    Camlp4Parsers.MakeReloadedParser in ();
+(* let module M = Register.OCamlSyntaxExtension Camlp4Parsers.IdReloadedParser
+ *     Camlp4Parsers.MakeReloadedParser in (); *)
+open Camlp4;
+open Camlp4Parsers;
+pa_rr (module Register);

camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml

 (*                                                                          *)
 (****************************************************************************)
 
-(* Authors:
- * - Daniel de Rauglaudre: initial version
- * - Nicolas Pouillard: refactoring
- *)
 
-
-
-let module M = Register.OCamlSyntaxExtension Camlp4Parsers.IdRevisedParser
-    Camlp4Parsers.MakeRevisedParser in ();
+open Camlp4;
+open Camlp4Parsers;
+pa_r (module Register);

camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml

 
 
 
-module M = Register.OCamlSyntaxExtension Camlp4Parsers.IdRevisedParserParser
-    Camlp4Parsers.MakeRevisedParserParser;
+(* module M = Register.OCamlSyntaxExtension Camlp4Parsers.IdRevisedParserParser
+ *     Camlp4Parsers.MakeRevisedParserParser; *)
+open Camlp4;
+open Camlp4Parsers;
+pa_rp (module Register);

camlp4/Camlp4Parsers/Camlp4OCamlRevisedQuotationExpander.ml

  * - Nicolas Pouillard: initial version
  *)
 
-open PreCast;
-let module Gram = MakeGram Lexer in
-let module M1 = OCamlInitSyntax.Make Ast Gram Quotation in
-let module M2 = Camlp4Parsers.MakeRevisedParser M1 in
-let module M3 = Camlp4QuotationCommon.Make M2 Syntax.AntiquotSyntax in ();
+
+
+open Camlp4Parsers;
+pa_rq (module Register) (module PreCast) ;
+(* let module Gram = MakeGram Lexer in
+ * let module M1 = OCamlInitSyntax.Make Ast Gram Quotation in
+ * let module M2 = Camlp4Parsers.MakeRevisedParser M1 in
+ * let module M3 = MakeQuotationCommon M2 Syntax.AntiquotSyntax in (); *)

camlp4/Camlp4Parsers/Camlp4Parsers.ml

 end;  
 
 
-module IdOCamlParserParser : Sig.Id = struct
+module IdParserParser : Sig.Id = struct
   value name = "Camlp4OCamlParserParser";
   value version = Sys.ocaml_version;
 end;
 
-module MakeOCamlParserParser (Syntax : Sig.Camlp4Syntax) = struct
+module MakeParserParser (Syntax : Sig.Camlp4Syntax) = struct
   open Sig;
   include Syntax;
 
   END;
 end;
   
+module IdQuotationCommon = struct (* FIXME unused here *)
+  value name = "Camlp4QuotationCommon";
+  value version = Sys.ocaml_version;
+end;
+
+module MakeQuotationCommon (Syntax : Sig.Camlp4Syntax)
+            (TheAntiquotSyntax : (Sig.Parser Syntax.Ast).SIMPLE)
+= struct
+  open Sig;
+  include Syntax; (* Be careful an AntiquotSyntax module appears here *)
+
+  module MetaLocHere = Ast.Meta.MetaLoc;
+  module MetaLoc = struct
+    module Ast = Ast;
+    value loc_name = ref None;
+    value meta_loc_expr _loc loc =
+      match loc_name.val with
+      [ None -> <:expr< $lid:Loc.name.val$ >>
+      | Some "here" -> MetaLocHere.meta_loc_expr _loc loc
+      | Some x -> <:expr< $lid:x$ >> ];
+    value meta_loc_patt _loc _ = <:patt< _ >>;
+  end;
+  module MetaAst = Ast.Meta.Make MetaLoc;
+  module ME = MetaAst.Expr;
+  module MP = MetaAst.Patt;
+
+  value is_antiquot s =
+    let len = String.length s in
+    len > 2 && s.[0] = '\\' && s.[1] = '$';
+
+  value handle_antiquot_in_string s term parse loc decorate =
+    if is_antiquot s then
+      let pos = String.index s ':' in
+      let name = String.sub s 2 (pos - 2)
+      and code = String.sub s (pos + 1) (String.length s - pos - 1) in
+      decorate name (parse loc code)
+    else term;
+
+  value antiquot_expander = object
+    inherit Ast.map as super;
+    method patt = fun
+      [ <:patt@_loc< $anti:s$ >> | <:patt@_loc< $str:s$ >> as p ->
+          let mloc _loc = MetaLoc.meta_loc_patt _loc _loc in
+          handle_antiquot_in_string s p TheAntiquotSyntax.parse_patt _loc (fun n p ->
+            match n with
+            [ "antisig_item" -> <:patt< Ast.SgAnt $mloc _loc$ $p$ >>
+            | "antistr_item" -> <:patt< Ast.StAnt $mloc _loc$ $p$ >>
+            | "antictyp" -> <:patt< Ast.TyAnt $mloc _loc$ $p$ >>
+            | "antipatt" -> <:patt< Ast.PaAnt $mloc _loc$ $p$ >>
+            | "antiexpr" -> <:patt< Ast.ExAnt $mloc _loc$ $p$ >>
+            | "antimodule_type" -> <:patt< Ast.MtAnt $mloc _loc$ $p$ >>
+            | "antimodule_expr" -> <:patt< Ast.MeAnt $mloc _loc$ $p$ >>
+            | "anticlass_type" -> <:patt< Ast.CtAnt $mloc _loc$ $p$ >>
+            | "anticlass_expr" -> <:patt< Ast.CeAnt $mloc _loc$ $p$ >>
+            | "anticlass_sig_item" -> <:patt< Ast.CgAnt $mloc _loc$ $p$ >>
+            | "anticlass_str_item" -> <:patt< Ast.CrAnt $mloc _loc$ $p$ >>
+            | "antiwith_constr" -> <:patt< Ast.WcAnt $mloc _loc$ $p$ >>
+            | "antibinding" -> <:patt< Ast.BiAnt $mloc _loc$ $p$ >>
+            | "antirec_binding" -> <:patt< Ast.RbAnt $mloc _loc$ $p$ >>
+            | "antimatch_case" -> <:patt< Ast.McAnt $mloc _loc$ $p$ >>
+            | "antimodule_binding" -> <:patt< Ast.MbAnt $mloc _loc$ $p$ >>
+            | "antiident" -> <:patt< Ast.IdAnt $mloc _loc$ $p$ >>
+            | _ -> p ])
+      | p -> super#patt p ];
+    method expr = fun
+      [ <:expr@_loc< $anti:s$ >> | <:expr@_loc< $str:s$ >> as e ->
+          let mloc _loc = MetaLoc.meta_loc_expr _loc _loc in
+          handle_antiquot_in_string s e TheAntiquotSyntax.parse_expr _loc (fun n e ->
+            match n with
+            [ "`int" -> <:expr< string_of_int $e$ >>
+            | "`int32" -> <:expr< Int32.to_string $e$ >>
+            | "`int64" -> <:expr< Int64.to_string $e$ >>
+            | "`nativeint" -> <:expr< Nativeint.to_string $e$ >>
+            | "`flo" -> <:expr< Camlp4_import.Oprint.float_repres $e$ >>
+            | "`str" -> <:expr< Ast.safe_string_escaped $e$ >>
+            | "`chr" -> <:expr< Char.escaped $e$ >>
+            | "`bool" -> <:expr< Ast.IdUid $mloc _loc$ (if $e$ then "True" else "False") >>
+            | "liststr_item" -> <:expr< Ast.stSem_of_list $e$ >>
+            | "listsig_item" -> <:expr< Ast.sgSem_of_list $e$ >>
+            | "listclass_sig_item" -> <:expr< Ast.cgSem_of_list $e$ >>
+            | "listclass_str_item" -> <:expr< Ast.crSem_of_list $e$ >>
+            | "listmodule_expr" -> <:expr< Ast.meApp_of_list $e$ >>
+            | "listmodule_type" -> <:expr< Ast.mtApp_of_list $e$ >>
+            | "listmodule_binding" -> <:expr< Ast.mbAnd_of_list $e$ >>
+            | "listbinding" -> <:expr< Ast.biAnd_of_list $e$ >>
+            | "listbinding;" -> <:expr< Ast.biSem_of_list $e$ >>
+            | "listrec_binding" -> <:expr< Ast.rbSem_of_list $e$ >>
+            | "listclass_type" -> <:expr< Ast.ctAnd_of_list $e$ >>
+            | "listclass_expr" -> <:expr< Ast.ceAnd_of_list $e$ >>
+            | "listident" -> <:expr< Ast.idAcc_of_list $e$ >>
+            | "listctypand" -> <:expr< Ast.tyAnd_of_list $e$ >>
+            | "listctyp;" -> <:expr< Ast.tySem_of_list $e$ >>
+            | "listctyp*" -> <:expr< Ast.tySta_of_list $e$ >>
+            | "listctyp|" -> <:expr< Ast.tyOr_of_list $e$ >>
+            | "listctyp," -> <:expr< Ast.tyCom_of_list $e$ >>
+            | "listctyp&" -> <:expr< Ast.tyAmp_of_list $e$ >>
+            | "listwith_constr" -> <:expr< Ast.wcAnd_of_list $e$ >>
+            | "listmatch_case" -> <:expr< Ast.mcOr_of_list $e$ >>
+            | "listpatt," -> <:expr< Ast.paCom_of_list $e$ >>
+            | "listpatt;" -> <:expr< Ast.paSem_of_list $e$ >>
+            | "listexpr," -> <:expr< Ast.exCom_of_list $e$ >>
+            | "listexpr;" -> <:expr< Ast.exSem_of_list $e$ >>
+            | "antisig_item" -> <:expr< Ast.SgAnt $mloc _loc$ $e$ >>
+            | "antistr_item" -> <:expr< Ast.StAnt $mloc _loc$ $e$ >>
+            | "antictyp" -> <:expr< Ast.TyAnt $mloc _loc$ $e$ >>
+            | "antipatt" -> <:expr< Ast.PaAnt $mloc _loc$ $e$ >>
+            | "antiexpr" -> <:expr< Ast.ExAnt $mloc _loc$ $e$ >>
+            | "antimodule_type" -> <:expr< Ast.MtAnt $mloc _loc$ $e$ >>
+            | "antimodule_expr" -> <:expr< Ast.MeAnt $mloc _loc$ $e$ >>
+            | "anticlass_type" -> <:expr< Ast.CtAnt $mloc _loc$ $e$ >>
+            | "anticlass_expr" -> <:expr< Ast.CeAnt $mloc _loc$ $e$ >>
+            | "anticlass_sig_item" -> <:expr< Ast.CgAnt $mloc _loc$ $e$ >>
+            | "anticlass_str_item" -> <:expr< Ast.CrAnt $mloc _loc$ $e$ >>
+            | "antiwith_constr" -> <:expr< Ast.WcAnt $mloc _loc$ $e$ >>
+            | "antibinding" -> <:expr< Ast.BiAnt $mloc _loc$ $e$ >>
+            | "antirec_binding" -> <:expr< Ast.RbAnt $mloc _loc$ $e$ >>
+            | "antimatch_case" -> <:expr< Ast.McAnt $mloc _loc$ $e$ >>
+            | "antimodule_binding" -> <:expr< Ast.MbAnt $mloc _loc$ $e$ >>
+            | "antiident" -> <:expr< Ast.IdAnt $mloc _loc$ $e$ >>
+            | _ -> e ])
+      | e -> super#expr e ];
+  end;
+
+  value add_quotation name entry mexpr mpatt =
+    let entry_eoi = Gram.Entry.mk (Gram.Entry.name entry) in
+    let parse_quot_string entry loc s =
+      let q = Camlp4_config.antiquotations.val in
+      let () = Camlp4_config.antiquotations.val := True in
+      let res = Gram.parse_string entry loc s in
+      let () = Camlp4_config.antiquotations.val := q in
+      res in
+    let expand_expr loc loc_name_opt s =
+      let ast = parse_quot_string entry_eoi loc s in
+      let () = MetaLoc.loc_name.val := loc_name_opt in
+      let meta_ast = mexpr loc ast in
+      let exp_ast = antiquot_expander#expr meta_ast in
+      exp_ast in
+    let expand_str_item loc loc_name_opt s =
+      let exp_ast = expand_expr loc loc_name_opt s in
+      <:str_item@loc< $exp:exp_ast$ >> in
+    let expand_patt _loc loc_name_opt s =
+      let ast = parse_quot_string entry_eoi _loc s in
+      let meta_ast = mpatt _loc ast in
+      let exp_ast = antiquot_expander#patt meta_ast in
+      match loc_name_opt with
+      [ None -> exp_ast
+      | Some name ->
+        let rec subst_first_loc =
+          fun
+          [ <:patt@_loc< Ast.$uid:u$ $_$ >> -> <:patt< Ast.$uid:u$ $lid:name$ >>
+          | <:patt@_loc< $a$ $b$ >> -> <:patt< $subst_first_loc a$ $b$ >>
+          | p -> p ] in
+        subst_first_loc exp_ast ] in
+    do {
+      EXTEND Gram
+        entry_eoi:
+          [ [ x = entry; `EOI -> x ] ]
+        ;
+      END;
+      Quotation.add name Quotation.DynAst.expr_tag expand_expr;
+      Quotation.add name Quotation.DynAst.patt_tag expand_patt;
+      Quotation.add name Quotation.DynAst.str_item_tag expand_str_item;
+    };
+
+  add_quotation "sig_item" sig_item_quot ME.meta_sig_item MP.meta_sig_item;
+  add_quotation "str_item" str_item_quot ME.meta_str_item MP.meta_str_item;
+  add_quotation "ctyp" ctyp_quot ME.meta_ctyp MP.meta_ctyp;
+  add_quotation "patt" patt_quot ME.meta_patt MP.meta_patt;
+  add_quotation "expr" expr_quot ME.meta_expr MP.meta_expr;
+  add_quotation "module_type" module_type_quot ME.meta_module_type MP.meta_module_type;
+  add_quotation "module_expr" module_expr_quot ME.meta_module_expr MP.meta_module_expr;
+  add_quotation "class_type" class_type_quot ME.meta_class_type MP.meta_class_type;
+  add_quotation "class_expr" class_expr_quot ME.meta_class_expr MP.meta_class_expr;
+  add_quotation "class_sig_item"
+                class_sig_item_quot ME.meta_class_sig_item MP.meta_class_sig_item;
+  add_quotation "class_str_item"
+                class_str_item_quot ME.meta_class_str_item MP.meta_class_str_item;
+  add_quotation "with_constr" with_constr_quot ME.meta_with_constr MP.meta_with_constr;
+  add_quotation "binding" binding_quot ME.meta_binding MP.meta_binding;
+  add_quotation "rec_binding" rec_binding_quot ME.meta_rec_binding MP.meta_rec_binding;
+  add_quotation "match_case" match_case_quot ME.meta_match_case MP.meta_match_case;
+  add_quotation "module_binding"
+                module_binding_quot ME.meta_module_binding MP.meta_module_binding;
+  add_quotation "ident" ident_quot ME.meta_ident MP.meta_ident;
+  add_quotation "rec_flag" rec_flag_quot ME.meta_rec_flag MP.meta_rec_flag;
+  add_quotation "private_flag" private_flag_quot ME.meta_private_flag MP.meta_private_flag;
+  add_quotation "row_var_flag" row_var_flag_quot ME.meta_row_var_flag MP.meta_row_var_flag;
+  add_quotation "mutable_flag" mutable_flag_quot ME.meta_mutable_flag MP.meta_mutable_flag;
+  add_quotation "virtual_flag" virtual_flag_quot ME.meta_virtual_flag MP.meta_virtual_flag;
+  add_quotation "override_flag" override_flag_quot ME.meta_override_flag MP.meta_override_flag;
+  add_quotation "direction_flag" direction_flag_quot ME.meta_direction_flag MP.meta_direction_flag;
+
+end;
+
+
+
+module IdQuotationExpander = struct
+  value name = "Camlp4QuotationExpander";
+  value version = Sys.ocaml_version;
+end;
+
+module MakeQuotationExpander (Syntax : Sig.Camlp4Syntax)
+= struct
+  module M = MakeQuotationCommon Syntax Syntax.AntiquotSyntax;
+  include M;
+end;
+
+(* value pa_r  = "Camlp4OCamlRevisedParser"; *)  
+value pa_r (module Register: MakeRegister.S) =
+  let module M = Register.OCamlSyntaxExtension IdRevisedParser MakeRevisedParser  in
+  ();
+
+(* value pa_rr = "Camlp4OCamlReloadedParser"; *)
+value pa_rr (module Register: MakeRegister.S) =
+  let module M = Register.OCamlSyntaxExtension
+      IdReloadedParser
+      MakeReloadedParser in ();
+  
+(* value pa_o  = "Camlp4OCamlParser"; *)
+value pa_o (module Register:MakeRegister.S) =
+  let module M = Register.OCamlSyntaxExtension
+      IdParser
+      MakeParser in  ();
+  
+(* value pa_rp = "Camlp4OCamlRevisedParserParser"; *)
+value pa_rp (module Register:MakeRegister.S) =
+  let module M = Register.OCamlSyntaxExtension
+      IdRevisedParserParser
+      MakeRevisedParserParser in ();
+
+(* value pa_op = "Camlp4OCamlParserParser"; *)
+value pa_op (module Register:MakeRegister.S) =
+  let module M = Register.OCamlSyntaxExtension
+      IdParserParser
+      MakeParserParser in ();
+
+(* value pa_g  = "Camlp4GrammarParser"; *)
+value pa_g (module Register:MakeRegister.S) =
+  let module M = Register.OCamlSyntaxExtension
+      IdGrammarParser
+      MakeGrammarParser in ();
+(* value pa_m  = "Camlp4MacroParser"; *)
+value pa_m (module Register:MakeRegister.S) =
+  let module M = Register.OCamlSyntaxExtension
+      IdMacroParser
+      MakeMacroParser in
+  let module M = Register.AstFilter IdMacroParser
+      MakeNothing in ();
+  
+(* value pa_qb = "Camlp4QuotationCommon"; pure module no longer used
+         Compatibility issue?  *)
+(* value pa_q  = "Camlp4QuotationExpander"; *)
+value pa_q (module Register:MakeRegister.S) =
+  let module M = Register.OCamlSyntaxExtension
+      IdQuotationExpander
+      MakeQuotationExpander in ();
+  
+(* value pa_rq = "Camlp4OCamlRevisedQuotationExpander";
+   *unreflective*, quotation syntax use revised syntax.
+ *)
+value pa_rq (module Register:MakeRegister.S) (module PreCast:MakePreCast.S) =
+  let open PreCast in 
+  let module Gram = PreCast.MakeGram PreCast.Lexer in
+  let module M1 = OCamlInitSyntax.Make Ast Gram Quotation in
+  let module M2 = MakeRevisedParser M1 in
+  let module M3 = MakeQuotationCommon M2 Syntax.AntiquotSyntax  in ();
+
+(* value pa_oq = "Camlp4OCamlOriginalQuotationExpander";
+   *unreflective*, quotation syntax use original syntax.
+   *There's a bug in ocamlbuild* which will generate wrong dependency based on 
+ *)
+value pa_oq (module Register:MakeRegister.S) (module PreCast:MakePreCast.S) =
+  let open PreCast in 
+  let module Gram = PreCast.MakeGram PreCast.Lexer in
+  let module M1 = OCamlInitSyntax.Make Ast Gram Quotation in (* *)
+  let module M2 = MakeRevisedParser M1 in
+  let module M3 = MakeParser M2 in 
+  let module M3 = MakeQuotationCommon M3 Syntax.AntiquotSyntax in ();
+
+(* value pa_l  = "Camlp4ListComprehension"; *)
+value pa_l (module Register:MakeRegister.S)  =
+  let module M = Register.OCamlSyntaxExtension
+      IdListComprehension
+      MakeListComprehension in ();
+  
+
+

camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml

  * - Nicolas Pouillard: initial version
  *)
 
-module Id = struct
-  value name = "Camlp4QuotationCommon";
-  value version = Sys.ocaml_version;
-end;
-
-module Make (Syntax : Sig.Camlp4Syntax)
-            (TheAntiquotSyntax : (Sig.Parser Syntax.Ast).SIMPLE)
-= struct
-  open Sig;
-  include Syntax; (* Be careful an AntiquotSyntax module appears here *)
-
-  module MetaLocHere = Ast.Meta.MetaLoc;
-  module MetaLoc = struct
-    module Ast = Ast;
-    value loc_name = ref None;
-    value meta_loc_expr _loc loc =
-      match loc_name.val with
-      [ None -> <:expr< $lid:Loc.name.val$ >>
-      | Some "here" -> MetaLocHere.meta_loc_expr _loc loc
-      | Some x -> <:expr< $lid:x$ >> ];
-    value meta_loc_patt _loc _ = <:patt< _ >>;
-  end;
-  module MetaAst = Ast.Meta.Make MetaLoc;
-  module ME = MetaAst.Expr;
-  module MP = MetaAst.Patt;
-
-  value is_antiquot s =
-    let len = String.length s in
-    len > 2 && s.[0] = '\\' && s.[1] = '$';
-
-  value handle_antiquot_in_string s term parse loc decorate =
-    if is_antiquot s then
-      let pos = String.index s ':' in
-      let name = String.sub s 2 (pos - 2)
-      and code = String.sub s (pos + 1) (String.length s - pos - 1) in
-      decorate name (parse loc code)
-    else term;
-
-  value antiquot_expander = object
-    inherit Ast.map as super;
-    method patt = fun
-      [ <:patt@_loc< $anti:s$ >> | <:patt@_loc< $str:s$ >> as p ->
-          let mloc _loc = MetaLoc.meta_loc_patt _loc _loc in
-          handle_antiquot_in_string s p TheAntiquotSyntax.parse_patt _loc (fun n p ->
-            match n with
-            [ "antisig_item" -> <:patt< Ast.SgAnt $mloc _loc$ $p$ >>
-            | "antistr_item" -> <:patt< Ast.StAnt $mloc _loc$ $p$ >>
-            | "antictyp" -> <:patt< Ast.TyAnt $mloc _loc$ $p$ >>
-            | "antipatt" -> <:patt< Ast.PaAnt $mloc _loc$ $p$ >>
-            | "antiexpr" -> <:patt< Ast.ExAnt $mloc _loc$ $p$ >>
-            | "antimodule_type" -> <:patt< Ast.MtAnt $mloc _loc$ $p$ >>
-            | "antimodule_expr" -> <:patt< Ast.MeAnt $mloc _loc$ $p$ >>
-            | "anticlass_type" -> <:patt< Ast.CtAnt $mloc _loc$ $p$ >>
-            | "anticlass_expr" -> <:patt< Ast.CeAnt $mloc _loc$ $p$ >>
-            | "anticlass_sig_item" -> <:patt< Ast.CgAnt $mloc _loc$ $p$ >>
-            | "anticlass_str_item" -> <:patt< Ast.CrAnt $mloc _loc$ $p$ >>
-            | "antiwith_constr" -> <:patt< Ast.WcAnt $mloc _loc$ $p$ >>
-            | "antibinding" -> <:patt< Ast.BiAnt $mloc _loc$ $p$ >>
-            | "antirec_binding" -> <:patt< Ast.RbAnt $mloc _loc$ $p$ >>
-            | "antimatch_case" -> <:patt< Ast.McAnt $mloc _loc$ $p$ >>
-            | "antimodule_binding" -> <:patt< Ast.MbAnt $mloc _loc$ $p$ >>
-            | "antiident" -> <:patt< Ast.IdAnt $mloc _loc$ $p$ >>
-            | _ -> p ])
-      | p -> super#patt p ];
-    method expr = fun
-      [ <:expr@_loc< $anti:s$ >> | <:expr@_loc< $str:s$ >> as e ->
-          let mloc _loc = MetaLoc.meta_loc_expr _loc _loc in
-          handle_antiquot_in_string s e TheAntiquotSyntax.parse_expr _loc (fun n e ->
-            match n with
-            [ "`int" -> <:expr< string_of_int $e$ >>
-            | "`int32" -> <:expr< Int32.to_string $e$ >>
-            | "`int64" -> <:expr< Int64.to_string $e$ >>
-            | "`nativeint" -> <:expr< Nativeint.to_string $e$ >>
-            | "`flo" -> <:expr< Camlp4_import.Oprint.float_repres $e$ >>
-            | "`str" -> <:expr< Ast.safe_string_escaped $e$ >>
-            | "`chr" -> <:expr< Char.escaped $e$ >>
-            | "`bool" -> <:expr< Ast.IdUid $mloc _loc$ (if $e$ then "True" else "False") >>
-            | "liststr_item" -> <:expr< Ast.stSem_of_list $e$ >>
-            | "listsig_item" -> <:expr< Ast.sgSem_of_list $e$ >>
-            | "listclass_sig_item" -> <:expr< Ast.cgSem_of_list $e$ >>
-            | "listclass_str_item" -> <:expr< Ast.crSem_of_list $e$ >>
-            | "listmodule_expr" -> <:expr< Ast.meApp_of_list $e$ >>
-            | "listmodule_type" -> <:expr< Ast.mtApp_of_list $e$ >>
-            | "listmodule_binding" -> <:expr< Ast.mbAnd_of_list $e$ >>
-            | "listbinding" -> <:expr< Ast.biAnd_of_list $e$ >>
-            | "listbinding;" -> <:expr< Ast.biSem_of_list $e$ >>
-            | "listrec_binding" -> <:expr< Ast.rbSem_of_list $e$ >>
-            | "listclass_type" -> <:expr< Ast.ctAnd_of_list $e$ >>
-            | "listclass_expr" -> <:expr< Ast.ceAnd_of_list $e$ >>
-            | "listident" -> <:expr< Ast.idAcc_of_list $e$ >>
-            | "listctypand" -> <:expr< Ast.tyAnd_of_list $e$ >>
-            | "listctyp;" -> <:expr< Ast.tySem_of_list $e$ >>
-            | "listctyp*" -> <:expr< Ast.tySta_of_list $e$ >>
-            | "listctyp|" -> <:expr< Ast.tyOr_of_list $e$ >>
-            | "listctyp," -> <:expr< Ast.tyCom_of_list $e$ >>
-            | "listctyp&" -> <:expr< Ast.tyAmp_of_list $e$ >>
-            | "listwith_constr" -> <:expr< Ast.wcAnd_of_list $e$ >>
-            | "listmatch_case" -> <:expr< Ast.mcOr_of_list $e$ >>
-            | "listpatt," -> <:expr< Ast.paCom_of_list $e$ >>
-            | "listpatt;" -> <:expr< Ast.paSem_of_list $e$ >>
-            | "listexpr," -> <:expr< Ast.exCom_of_list $e$ >>
-            | "listexpr;" -> <:expr< Ast.exSem_of_list $e$ >>
-            | "antisig_item" -> <:expr< Ast.SgAnt $mloc _loc$ $e$ >>
-            | "antistr_item" -> <:expr< Ast.StAnt $mloc _loc$ $e$ >>
-            | "antictyp" -> <:expr< Ast.TyAnt $mloc _loc$ $e$ >>
-            | "antipatt" -> <:expr< Ast.PaAnt $mloc _loc$ $e$ >>
-            | "antiexpr" -> <:expr< Ast.ExAnt $mloc _loc$ $e$ >>
-            | "antimodule_type" -> <:expr< Ast.MtAnt $mloc _loc$ $e$ >>
-            | "antimodule_expr" -> <:expr< Ast.MeAnt $mloc _loc$ $e$ >>
-            | "anticlass_type" -> <:expr< Ast.CtAnt $mloc _loc$ $e$ >>
-            | "anticlass_expr" -> <:expr< Ast.CeAnt $mloc _loc$ $e$ >>
-            | "anticlass_sig_item" -> <:expr< Ast.CgAnt $mloc _loc$ $e$ >>
-            | "anticlass_str_item" -> <:expr< Ast.CrAnt $mloc _loc$ $e$ >>
-            | "antiwith_constr" -> <:expr< Ast.WcAnt $mloc _loc$ $e$ >>
-            | "antibinding" -> <:expr< Ast.BiAnt $mloc _loc$ $e$ >>
-            | "antirec_binding" -> <:expr< Ast.RbAnt $mloc _loc$ $e$ >>
-            | "antimatch_case" -> <:expr< Ast.McAnt $mloc _loc$ $e$ >>
-            | "antimodule_binding" -> <:expr< Ast.MbAnt $mloc _loc$ $e$ >>
-            | "antiident" -> <:expr< Ast.IdAnt $mloc _loc$ $e$ >>
-            | _ -> e ])
-      | e -> super#expr e ];
-  end;
-
-  value add_quotation name entry mexpr mpatt =
-    let entry_eoi = Gram.Entry.mk (Gram.Entry.name entry) in
-    let parse_quot_string entry loc s =
-      let q = Camlp4_config.antiquotations.val in
-      let () = Camlp4_config.antiquotations.val := True in
-      let res = Gram.parse_string entry loc s in
-      let () = Camlp4_config.antiquotations.val := q in
-      res in
-    let expand_expr loc loc_name_opt s =
-      let ast = parse_quot_string entry_eoi loc s in
-      let () = MetaLoc.loc_name.val := loc_name_opt in
-      let meta_ast = mexpr loc ast in
-      let exp_ast = antiquot_expander#expr meta_ast in
-      exp_ast in
-    let expand_str_item loc loc_name_opt s =
-      let exp_ast = expand_expr loc loc_name_opt s in
-      <:str_item@loc< $exp:exp_ast$ >> in
-    let expand_patt _loc loc_name_opt s =
-      let ast = parse_quot_string entry_eoi _loc s in
-      let meta_ast = mpatt _loc ast in
-      let exp_ast = antiquot_expander#patt meta_ast in
-      match loc_name_opt with
-      [ None -> exp_ast
-      | Some name ->
-        let rec subst_first_loc =
-          fun
-          [ <:patt@_loc< Ast.$uid:u$ $_$ >> -> <:patt< Ast.$uid:u$ $lid:name$ >>
-          | <:patt@_loc< $a$ $b$ >> -> <:patt< $subst_first_loc a$ $b$ >>
-          | p -> p ] in
-        subst_first_loc exp_ast ] in
-    do {
-      EXTEND Gram
-        entry_eoi:
-          [ [ x = entry; `EOI -> x ] ]
-        ;
-      END;
-      Quotation.add name Quotation.DynAst.expr_tag expand_expr;
-      Quotation.add name Quotation.DynAst.patt_tag expand_patt;
-      Quotation.add name Quotation.DynAst.str_item_tag expand_str_item;
-    };
-
-  add_quotation "sig_item" sig_item_quot ME.meta_sig_item MP.meta_sig_item;
-  add_quotation "str_item" str_item_quot ME.meta_str_item MP.meta_str_item;
-  add_quotation "ctyp" ctyp_quot ME.meta_ctyp MP.meta_ctyp;
-  add_quotation "patt" patt_quot ME.meta_patt MP.meta_patt;
-  add_quotation "expr" expr_quot ME.meta_expr MP.meta_expr;
-  add_quotation "module_type" module_type_quot ME.meta_module_type MP.meta_module_type;
-  add_quotation "module_expr" module_expr_quot ME.meta_module_expr MP.meta_module_expr;
-  add_quotation "class_type" class_type_quot ME.meta_class_type MP.meta_class_type;
-  add_quotation "class_expr" class_expr_quot ME.meta_class_expr MP.meta_class_expr;
-  add_quotation "class_sig_item"
-                class_sig_item_quot ME.meta_class_sig_item MP.meta_class_sig_item;
-  add_quotation "class_str_item"
-                class_str_item_quot ME.meta_class_str_item MP.meta_class_str_item;
-  add_quotation "with_constr" with_constr_quot ME.meta_with_constr MP.meta_with_constr;
-  add_quotation "binding" binding_quot ME.meta_binding MP.meta_binding;
-  add_quotation "rec_binding" rec_binding_quot ME.meta_rec_binding MP.meta_rec_binding;
-  add_quotation "match_case" match_case_quot ME.meta_match_case MP.meta_match_case;
-  add_quotation "module_binding"
-                module_binding_quot ME.meta_module_binding MP.meta_module_binding;
-  add_quotation "ident" ident_quot ME.meta_ident MP.meta_ident;
-  add_quotation "rec_flag" rec_flag_quot ME.meta_rec_flag MP.meta_rec_flag;
-  add_quotation "private_flag" private_flag_quot ME.meta_private_flag MP.meta_private_flag;
-  add_quotation "row_var_flag" row_var_flag_quot ME.meta_row_var_flag MP.meta_row_var_flag;
-  add_quotation "mutable_flag" mutable_flag_quot ME.meta_mutable_flag MP.meta_mutable_flag;
-  add_quotation "virtual_flag" virtual_flag_quot ME.meta_virtual_flag MP.meta_virtual_flag;
-  add_quotation "override_flag" override_flag_quot ME.meta_override_flag MP.meta_override_flag;
-  add_quotation "direction_flag" direction_flag_quot ME.meta_direction_flag MP.meta_direction_flag;
-
-end;
+(* module Id = struct
+ *   value name = "Camlp4QuotationCommon";
+ *   value version = Sys.ocaml_version;
+ * end;
+ * 
+ * module Make (Syntax : Sig.Camlp4Syntax)
+ *             (TheAntiquotSyntax : (Sig.Parser Syntax.Ast).SIMPLE)
+ * = struct
+ *   open Sig;
+ *   include Syntax; (\* Be careful an AntiquotSyntax module appears here *\)
+ * 
+ *   module MetaLocHere = Ast.Meta.MetaLoc;
+ *   module MetaLoc = struct
+ *     module Ast = Ast;
+ *     value loc_name = ref None;
+ *     value meta_loc_expr _loc loc =
+ *       match loc_name.val with
+ *       [ None -> <:expr< $lid:Loc.name.val$ >>
+ *       | Some "here" -> MetaLocHere.meta_loc_expr _loc loc
+ *       | Some x -> <:expr< $lid:x$ >> ];
+ *     value meta_loc_patt _loc _ = <:patt< _ >>;
+ *   end;
+ *   module MetaAst = Ast.Meta.Make MetaLoc;
+ *   module ME = MetaAst.Expr;
+ *   module MP = MetaAst.Patt;
+ * 
+ *   value is_antiquot s =
+ *     let len = String.length s in
+ *     len > 2 && s.[0] = '\\' && s.[1] = '$';
+ * 
+ *   value handle_antiquot_in_string s term parse loc decorate =
+ *     if is_antiquot s then
+ *       let pos = String.index s ':' in
+ *       let name = String.sub s 2 (pos - 2)
+ *       and code = String.sub s (pos + 1) (String.length s - pos - 1) in
+ *       decorate name (parse loc code)
+ *     else term;
+ * 
+ *   value antiquot_expander = object
+ *     inherit Ast.map as super;
+ *     method patt = fun
+ *       [ <:patt@_loc< $anti:s$ >> | <:patt@_loc< $str:s$ >> as p ->
+ *           let mloc _loc = MetaLoc.meta_loc_patt _loc _loc in
+ *           handle_antiquot_in_string s p TheAntiquotSyntax.parse_patt _loc (fun n p ->
+ *             match n with
+ *             [ "antisig_item" -> <:patt< Ast.SgAnt $mloc _loc$ $p$ >>
+ *             | "antistr_item" -> <:patt< Ast.StAnt $mloc _loc$ $p$ >>
+ *             | "antictyp" -> <:patt< Ast.TyAnt $mloc _loc$ $p$ >>
+ *             | "antipatt" -> <:patt< Ast.PaAnt $mloc _loc$ $p$ >>
+ *             | "antiexpr" -> <:patt< Ast.ExAnt $mloc _loc$ $p$ >>
+ *             | "antimodule_type" -> <:patt< Ast.MtAnt $mloc _loc$ $p$ >>
+ *             | "antimodule_expr" -> <:patt< Ast.MeAnt $mloc _loc$ $p$ >>
+ *             | "anticlass_type" -> <:patt< Ast.CtAnt $mloc _loc$ $p$ >>
+ *             | "anticlass_expr" -> <:patt< Ast.CeAnt $mloc _loc$ $p$ >>
+ *             | "anticlass_sig_item" -> <:patt< Ast.CgAnt $mloc _loc$ $p$ >>
+ *             | "anticlass_str_item" -> <:patt< Ast.CrAnt $mloc _loc$ $p$ >>
+ *             | "antiwith_constr" -> <:patt< Ast.WcAnt $mloc _loc$ $p$ >>
+ *             | "antibinding" -> <:patt< Ast.BiAnt $mloc _loc$ $p$ >>
+ *             | "antirec_binding" -> <:patt< Ast.RbAnt $mloc _loc$ $p$ >>
+ *             | "antimatch_case" -> <:patt< Ast.McAnt $mloc _loc$ $p$ >>
+ *             | "antimodule_binding" -> <:patt< Ast.MbAnt $mloc _loc$ $p$ >>
+ *             | "antiident" -> <:patt< Ast.IdAnt $mloc _loc$ $p$ >>
+ *             | _ -> p ])
+ *       | p -> super#patt p ];
+ *     method expr = fun
+ *       [ <:expr@_loc< $anti:s$ >> | <:expr@_loc< $str:s$ >> as e ->
+ *           let mloc _loc = MetaLoc.meta_loc_expr _loc _loc in
+ *           handle_antiquot_in_string s e TheAntiquotSyntax.parse_expr _loc (fun n e ->
+ *             match n with
+ *             [ "`int" -> <:expr< string_of_int $e$ >>
+ *             | "`int32" -> <:expr< Int32.to_string $e$ >>
+ *             | "`int64" -> <:expr< Int64.to_string $e$ >>
+ *             | "`nativeint" -> <:expr< Nativeint.to_string $e$ >>
+ *             | "`flo" -> <:expr< Camlp4_import.Oprint.float_repres $e$ >>
+ *             | "`str" -> <:expr< Ast.safe_string_escaped $e$ >>
+ *             | "`chr" -> <:expr< Char.escaped $e$ >>
+ *             | "`bool" -> <:expr< Ast.IdUid $mloc _loc$ (if $e$ then "True" else "False") >>
+ *             | "liststr_item" -> <:expr< Ast.stSem_of_list $e$ >>
+ *             | "listsig_item" -> <:expr< Ast.sgSem_of_list $e$ >>
+ *             | "listclass_sig_item" -> <:expr< Ast.cgSem_of_list $e$ >>
+ *             | "listclass_str_item" -> <:expr< Ast.crSem_of_list $e$ >>
+ *             | "listmodule_expr" -> <:expr< Ast.meApp_of_list $e$ >>
+ *             | "listmodule_type" -> <:expr< Ast.mtApp_of_list $e$ >>
+ *             | "listmodule_binding" -> <:expr< Ast.mbAnd_of_list $e$ >>
+ *             | "listbinding" -> <:expr< Ast.biAnd_of_list $e$ >>
+ *             | "listbinding;" -> <:expr< Ast.biSem_of_list $e$ >>
+ *             | "listrec_binding" -> <:expr< Ast.rbSem_of_list $e$ >>
+ *             | "listclass_type" -> <:expr< Ast.ctAnd_of_list $e$ >>
+ *             | "listclass_expr" -> <:expr< Ast.ceAnd_of_list $e$ >>
+ *             | "listident" -> <:expr< Ast.idAcc_of_list $e$ >>
+ *             | "listctypand" -> <:expr< Ast.tyAnd_of_list $e$ >>
+ *             | "listctyp;" -> <:expr< Ast.tySem_of_list $e$ >>
+ *             | "listctyp*" -> <:expr< Ast.tySta_of_list $e$ >>
+ *             | "listctyp|" -> <:expr< Ast.tyOr_of_list $e$ >>
+ *             | "listctyp," -> <:expr< Ast.tyCom_of_list $e$ >>
+ *             | "listctyp&" -> <:expr< Ast.tyAmp_of_list $e$ >>
+ *             | "listwith_constr" -> <:expr< Ast.wcAnd_of_list $e$ >>
+ *             | "listmatch_case" -> <:expr< Ast.mcOr_of_list $e$ >>
+ *             | "listpatt," -> <:expr< Ast.paCom_of_list $e$ >>
+ *             | "listpatt;" -> <:expr< Ast.paSem_of_list $e$ >>
+ *             | "listexpr," -> <:expr< Ast.exCom_of_list $e$ >>
+ *             | "listexpr;" -> <:expr< Ast.exSem_of_list $e$ >>
+ *             | "antisig_item" -> <:expr< Ast.SgAnt $mloc _loc$ $e$ >>
+ *             | "antistr_item" -> <:expr< Ast.StAnt $mloc _loc$ $e$ >>
+ *             | "antictyp" -> <:expr< Ast.TyAnt $mloc _loc$ $e$ >>
+ *             | "antipatt" -> <:expr< Ast.PaAnt $mloc _loc$ $e$ >>
+ *             | "antiexpr" -> <:expr< Ast.ExAnt $mloc _loc$ $e$ >>
+ *             | "antimodule_type" -> <:expr< Ast.MtAnt $mloc _loc$ $e$ >>
+ *             | "antimodule_expr" -> <:expr< Ast.MeAnt $mloc _loc$ $e$ >>
+ *             | "anticlass_type" -> <:expr< Ast.CtAnt $mloc _loc$ $e$ >>
+ *             | "anticlass_expr" -> <:expr< Ast.CeAnt $mloc _loc$ $e$ >>
+ *             | "anticlass_sig_item" -> <:expr< Ast.CgAnt $mloc _loc$ $e$ >>
+ *             | "anticlass_str_item" -> <:expr< Ast.CrAnt $mloc _loc$ $e$ >>
+ *             | "antiwith_constr" -> <:expr< Ast.WcAnt $mloc _loc$ $e$ >>
+ *             | "antibinding" -> <:expr< Ast.BiAnt $mloc _loc$ $e$ >>
+ *             | "antirec_binding" -> <:expr< Ast.RbAnt $mloc _loc$ $e$ >>
+ *             | "antimatch_case" -> <:expr< Ast.McAnt $mloc _loc$ $e$ >>
+ *             | "antimodule_binding" -> <:expr< Ast.MbAnt $mloc _loc$ $e$ >>
+ *             | "antiident" -> <:expr< Ast.IdAnt $mloc _loc$ $e$ >>
+ *             | _ -> e ])
+ *       | e -> super#expr e ];
+ *   end;
+ * 
+ *   value add_quotation name entry mexpr mpatt =
+ *     let entry_eoi = Gram.Entry.mk (Gram.Entry.name entry) in
+ *     let parse_quot_string entry loc s =
+ *       let q = Camlp4_config.antiquotations.val in
+ *       let () = Camlp4_config.antiquotations.val := True in
+ *       let res = Gram.parse_string entry loc s in
+ *       let () = Camlp4_config.antiquotations.val := q in
+ *       res in
+ *     let expand_expr loc loc_name_opt s =
+ *       let ast = parse_quot_string entry_eoi loc s in
+ *       let () = MetaLoc.loc_name.val := loc_name_opt in
+ *       let meta_ast = mexpr loc ast in
+ *       let exp_ast = antiquot_expander#expr meta_ast in
+ *       exp_ast in
+ *     let expand_str_item loc loc_name_opt s =
+ *       let exp_ast = expand_expr loc loc_name_opt s in
+ *       <:str_item@loc< $exp:exp_ast$ >> in
+ *     let expand_patt _loc loc_name_opt s =
+ *       let ast = parse_quot_string entry_eoi _loc s in
+ *       let meta_ast = mpatt _loc ast in
+ *       let exp_ast = antiquot_expander#patt meta_ast in
+ *       match loc_name_opt with
+ *       [ None -> exp_ast
+ *       | Some name ->
+ *         let rec subst_first_loc =
+ *           fun
+ *           [ <:patt@_loc< Ast.$uid:u$ $_$ >> -> <:patt< Ast.$uid:u$ $lid:name$ >>
+ *           | <:patt@_loc< $a$ $b$ >> -> <:patt< $subst_first_loc a$ $b$ >>
+ *           | p -> p ] in
+ *         subst_first_loc exp_ast ] in
+ *     do {
+ *       EXTEND Gram
+ *         entry_eoi:
+ *           [ [ x = entry; `EOI -> x ] ]
+ *         ;
+ *       END;
+ *       Quotation.add name Quotation.DynAst.expr_tag expand_expr;
+ *       Quotation.add name Quotation.DynAst.patt_tag expand_patt;
+ *       Quotation.add name Quotation.DynAst.str_item_tag expand_str_item;
+ *     };
+ * 
+ *   add_quotation "sig_item" sig_item_quot ME.meta_sig_item MP.meta_sig_item;
+ *   add_quotation "str_item" str_item_quot ME.meta_str_item MP.meta_str_item;
+ *   add_quotation "ctyp" ctyp_quot ME.meta_ctyp MP.meta_ctyp;
+ *   add_quotation "patt" patt_quot ME.meta_patt MP.meta_patt;
+ *   add_quotation "expr" expr_quot ME.meta_expr MP.meta_expr;
+ *   add_quotation "module_type" module_type_quot ME.meta_module_type MP.meta_module_type;
+ *   add_quotation "module_expr" module_expr_quot ME.meta_module_expr MP.meta_module_expr;
+ *   add_quotation "class_type" class_type_quot ME.meta_class_type MP.meta_class_type;
+ *   add_quotation "class_expr" class_expr_quot ME.meta_class_expr MP.meta_class_expr;
+ *   add_quotation "class_sig_item"
+ *                 class_sig_item_quot ME.meta_class_sig_item MP.meta_class_sig_item;
+ *   add_quotation "class_str_item"
+ *                 class_str_item_quot ME.meta_class_str_item MP.meta_class_str_item;
+ *   add_quotation "with_constr" with_constr_quot ME.meta_with_constr MP.meta_with_constr;
+ *   add_quotation "binding" binding_quot ME.meta_binding MP.meta_binding;
+ *   add_quotation "rec_binding" rec_binding_quot ME.meta_rec_binding MP.meta_rec_binding;
+ *   add_quotation "match_case" match_case_quot ME.meta_match_case MP.meta_match_case;
+ *   add_quotation "module_binding"
+ *                 module_binding_quot ME.meta_module_binding MP.meta_module_binding;
+ *   add_quotation "ident" ident_quot ME.meta_ident MP.meta_ident;
+ *   add_quotation "rec_flag" rec_flag_quot ME.meta_rec_flag MP.meta_rec_flag;
+ *   add_quotation "private_flag" private_flag_quot ME.meta_private_flag MP.meta_private_flag;
+ *   add_quotation "row_var_flag" row_var_flag_quot ME.meta_row_var_flag MP.meta_row_var_flag;
+ *   add_quotation "mutable_flag" mutable_flag_quot ME.meta_mutable_flag MP.meta_mutable_flag;
+ *   add_quotation "virtual_flag" virtual_flag_quot ME.meta_virtual_flag MP.meta_virtual_flag;
+ *   add_quotation "override_flag" override_flag_quot ME.meta_override_flag MP.meta_override_flag;
+ *   add_quotation "direction_flag" direction_flag_quot ME.meta_direction_flag MP.meta_direction_flag;
+ * 
+ * end; *)

camlp4/Camlp4Parsers/Camlp4QuotationExpander.ml

  *)
 
 
-module Id = struct
-  value name = "Camlp4QuotationExpander";
-  value version = Sys.ocaml_version;
-end;
-
-module Make (Syntax : Sig.Camlp4Syntax)
-= struct
-  module M = Camlp4QuotationCommon.Make Syntax Syntax.AntiquotSyntax;
-  include M;
-end;
-
-let module M = Register.OCamlSyntaxExtension Id Make in ();
+open Camlp4Parsers;
+pa_q (module Register);

camlp4/Camlp4Printers/Camlp4AutoPrinter.ml

  * - Nicolas Pouillard: initial version
  *)
 
-open Camlp4.Register;
+(* open Camlp4;
+ * Register.enable_auto (fun () -> Unix.isatty Unix.stdout); *)
 
-if Unix.isatty Unix.stdout then
-  enable_ocaml_printer ()
-else
-  enable_dump_ocaml_ast_printer ();
+open MakeCamlp4Bin;
+
+Camlp4.Register.enable_auto (fun () -> Unix.isatty Unix.stdout);
+<Camlp4Parsers>:include
+<Camlp4Filters>:include
+# true:include_unix
+# <boot/camlp4boot.byte>:use_unix

camlp4/boot/Camlp4.ml

           
         val enable_dump_camlp4_ast_printer : unit -> unit
           
+        val enable_auto : (unit -> bool) -> unit
+          
       end
       
     module Make (Syntax : Sig.FilterSyntax) : S with module Loc = Syntax.Loc
         let enable_null_printer () =
           let module M = Printer(PP.Null.Id)(PP.Null.Make) in ()
           
+        let enable_auto isatty =
+          if isatty ()
+          then enable_ocaml_printer ()
+          else enable_dump_ocaml_ast_printer ()
+          
       end
       
   end
       
   end
   
-module MakeCamlp4Bin =
-  struct
-    open Format
-      
-    module Camlp4Bin
-      (Loc : Sig.Loc) (PreCast : MakePreCast.S with module Loc = Loc)
-      (Register : MakeRegister.S with module Loc = Loc
-        and module Ast = PreCast.Ast) =
-      struct
-        open PreCast
-          
-        module CleanAst = Struct.CleanAst.Make(PreCast.Ast)
-          
-        module SSet = Set.Make(String)
-          
-        let pa_r = "Camlp4OCamlRevisedParser"
-          
-        let pa_rr = "Camlp4OCamlReloadedParser"
-          
-        let pa_o = "Camlp4OCamlParser"
-          
-        let pa_rp = "Camlp4OCamlRevisedParserParser"
-          
-        let pa_op = "Camlp4OCamlParserParser"
-          
-        let pa_g = "Camlp4GrammarParser"
-          
-        let pa_m = "Camlp4MacroParser"
-          
-        let pa_qb = "Camlp4QuotationCommon"
-          
-        let pa_q = "Camlp4QuotationExpander"
-          
-        let pa_rq = "Camlp4OCamlRevisedQuotationExpander"
-          
-        let pa_oq = "Camlp4OCamlOriginalQuotationExpander"
-          
-        let pa_l = "Camlp4ListComprehension"
-          
-        let dyn_loader =
-          ref
-            (fun _ ->
-               raise
-                 (Match_failure ("./camlp4/Camlp4/MakeCamlp4Bin.ml", 29, 24)))
-          
-        let rcall_callback = ref (fun () -> ())
-          
-        let loaded_modules = ref SSet.empty
-          
-        let add_to_loaded_modules name =
-          loaded_modules := SSet.add name !loaded_modules
-          
-        let (objext, libext) =
-          if PreCast.DynLoader.is_native
-          then (".cmxs", ".cmxs")
-          else (".cmo", ".cma")
-          
-        let rewrite_and_load n x =
-          let dyn_loader = !dyn_loader () in
-          let find_in_path = PreCast.DynLoader.find_in_path dyn_loader in
-          let real_load name =
-            (add_to_loaded_modules name;
-             PreCast.DynLoader.load dyn_loader name) in
-          let load =
-            List.iter
-              (fun n ->
-                 if
-                   (SSet.mem n !loaded_modules) ||
-                     (List.mem n !Register.loaded_modules)
-                 then ()
-                 else
-                   (add_to_loaded_modules n;
-                    PreCast.DynLoader.load dyn_loader (n ^ objext)))
-          in
-            ((match (n, (String.lowercase x)) with
-              | (("Parsers" | ""),
-                 ("pa_r.cmo" | "r" | "ocamlr" | "ocamlrevised" |
-                    "camlp4ocamlrevisedparser.cmo"))
-                  -> load [ pa_r ]
-              | (("Parsers" | ""),
-                 ("rr" | "reloaded" | "ocamlreloaded" |
-                    "camlp4ocamlreloadedparser.cmo"))
-                  -> load [ pa_rr ]
-              | (("Parsers" | ""),
-                 ("pa_o.cmo" | "o" | "ocaml" | "camlp4ocamlparser.cmo")) ->
-                  load [ pa_r; pa_o ]
-              | (("Parsers" | ""),
-                 ("pa_rp.cmo" | "rp" | "rparser" |
-                    "camlp4ocamlrevisedparserparser.cmo"))
-                  -> load [ pa_r; pa_rp ]
-              | (("Parsers" | ""),
-                 ("pa_op.cmo" | "op" | "parser" |
-                    "camlp4ocamlparserparser.cmo"))
-                  -> load [ pa_r; pa_o; pa_rp; pa_op ]
-              | (("Parsers" | ""),
-                 ("pa_extend.cmo" | "pa_extend_m.cmo" | "g" | "grammar" |
-                    "camlp4grammarparser.cmo"))
-                  -> load [ pa_g ]
-              | (("Parsers" | ""),
-                 ("pa_macro.cmo" | "m" | "macro" | "camlp4macroparser.cmo"))
-                  -> load [ pa_m ]
-              | (("Parsers" | ""), ("q" | "camlp4quotationexpander.cmo")) ->
-                  load [ pa_qb; pa_q ]
-              | (("Parsers" | ""),
-                 ("q_mlast.cmo" | "rq" |
-                    "camlp4ocamlrevisedquotationexpander.cmo"))
-                  -> load [ pa_qb; pa_rq ]
-              | (("Parsers" | ""),
-                 ("oq" | "camlp4ocamloriginalquotationexpander.cmo")) ->
-                  load [ pa_r; pa_o; pa_qb; pa_oq ]
-              | (("Parsers" | ""), "rf") ->
-                  load [ pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m ]
-              | (("Parsers" | ""), "of") ->
-                  load
-                    [ pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_q; pa_g; pa_l; pa_m ]
-              | (("Parsers" | ""), ("comp" | "camlp4listcomprehension.cmo"))
-                  -> load [ pa_l ]
-              | (("Filters" | ""), ("lift" | "camlp4astlifter.cmo")) ->
-                  load [ "Camlp4AstLifter" ]
-              | (("Filters" | ""), ("exn" | "camlp4exceptiontracer.cmo")) ->
-                  load [ "Camlp4ExceptionTracer" ]
-              | (("Filters" | ""), ("prof" | "camlp4profiler.cmo")) ->
-                  load [ "Camlp4Profiler" ]
-              | (("Filters" | ""), ("map" | "camlp4mapgenerator.cmo")) ->
-                  load [ "Camlp4FoldGenerator" ]
-              | (("Filters" | ""), ("fold" | "camlp4foldgenerator.cmo")) ->
-                  load [ "Camlp4FoldGenerator" ]
-              | (("Filters" | ""), ("meta" | "camlp4metagenerator.cmo")) ->
-                  load [ "Camlp4MetaGenerator" ]
-              | (("Filters" | ""), ("trash" | "camlp4trashremover.cmo")) ->
-                  load [ "Camlp4TrashRemover" ]
-              | (("Filters" | ""),
-                 ("striploc" | "camlp4locationstripper.cmo")) ->
-                  load [ "Camlp4LocationStripper" ]
-              | (("Printers" | ""),
-                 ("pr_r.cmo" | "r" | "ocamlr" |
-                    "camlp4ocamlrevisedprinter.cmo"))
-                  -> Register.enable_ocamlr_printer ()
-              | (("Printers" | ""),
-                 ("pr_o.cmo" | "o" | "ocaml" | "camlp4ocamlprinter.cmo")) ->
-                  Register.enable_ocaml_printer ()
-              | (("Printers" | ""),
-                 ("pr_dump.cmo" | "p" | "dumpocaml" |
-                    "camlp4ocamlastdumper.cmo"))
-                  -> Register.enable_dump_ocaml_ast_printer ()
-              | (("Printers" | ""),
-                 ("d" | "dumpcamlp4" | "camlp4astdumper.cmo")) ->
-                  Register.enable_dump_camlp4_ast_printer ()
-              | (("Printers" | ""), ("a" | "auto" | "camlp4autoprinter.cmo"))
-                  -> load [ "Camlp4AutoPrinter" ]
-              | _ ->
-                  let y = "Camlp4" ^ (n ^ ("/" ^ (x ^ objext)))
-                  in real_load (try find_in_path y with | Not_found -> x));
-             !rcall_callback ())
-          
-        let print_warning = eprintf "%a:\n%s@." PreCast.Loc.print
-          
-        let rec parse_file dyn_loader name pa getdir =
-          let directive_handler =
-            Some
-              (fun ast ->
-                 match getdir ast with
-                 | Some x ->
-                     (match x with
-                      | (_, "load", s) -> (rewrite_and_load "" s; None)
-                      | (_, "directory", s) ->
-                          (PreCast.DynLoader.include_dir dyn_loader s; None)
-                      | (_, "use", s) ->
-                          Some (parse_file dyn_loader s pa getdir)
-                      | (_, "default_quotation", s) ->
-                          (PreCast.Quotation.default := s; None)
-                      | (loc, _, _) ->
-                          PreCast.Loc.raise loc
-                            (Stream.Error "bad directive"))
-                 | None -> None) in
-          let loc = PreCast.Loc.mk name
-          in
-            (PreCast.Syntax.current_warning := print_warning;
-             let ic = if name = "-" then stdin else open_in_bin name in
-             let cs = Stream.of_channel ic in
-             let clear () = if name = "-" then () else close_in ic in
-             let phr =
-               try pa ?directive_handler loc cs
-               with | x -> (clear (); raise x)
-             in (clear (); phr))
-          
-        let output_file = ref None
-          
-        let process dyn_loader name pa pr clean fold_filters getdir =
-          let ast = parse_file dyn_loader name pa getdir in
-          let ast = fold_filters (fun t filter -> filter t) ast in
-          let ast = clean ast
-          in pr ?input_file: (Some name) ?output_file: !output_file ast
-          
-        let gind =
-          function
-          | Ast.SgDir (loc, n, (Ast.ExStr (_, s))) -> Some ((loc, n, s))
-          | _ -> None
-          
-        let gimd =
-          function
-          | Ast.StDir (loc, n, (Ast.ExStr (_, s))) -> Some ((loc, n, s))
-          | _ -> None
-          
-        let process_intf dyn_loader name =
-          process dyn_loader name Register.CurrentParser.parse_interf
-            Register.CurrentPrinter.print_interf
-            (new CleanAst.clean_ast)#sig_item AstFilters.fold_interf_filters
-            gind
-          
-        let process_impl dyn_loader name =
-          process dyn_loader name Register.CurrentParser.parse_implem
-            Register.CurrentPrinter.print_implem
-            (new CleanAst.clean_ast)#str_item AstFilters.fold_implem_filters
-            gimd
-          
-        let just_print_the_version () =
-          (printf "%s@." Camlp4_config.version; exit 0)
-          
-        let print_version () =
-          (eprintf "Camlp4 version %s@." Camlp4_config.version; exit 0)
-          
-        let print_stdlib () =
-          (printf "%s@." Camlp4_config.camlp4_standard_library; exit 0)
-          
-        let usage ini_sl ext_sl =
-          (eprintf
-             "\
-Usage: camlp4 [load-options] [--] [other-options]\n\
-Options:\n\
-<file>.ml        Parse this implementation file\n\
-<file>.mli       Parse this interface file\n\
-<file>.%s Load this module inside the Camlp4 core@."
-             (if DynLoader.is_native then "cmxs     " else "(cmo|cma)");
-           Options.print_usage_list ini_sl;
-           if ext_sl <> []
-           then
-             (eprintf "Options added by loaded object files:@.";
-              Options.print_usage_list ext_sl)
-           else ())
-          
-        let warn_noassert () =
-          eprintf
-            "\
-camlp4 warning: option -noassert is obsolete\n\
-You should give the -noassert option to the ocaml compiler instead.@."
-          
-        type file_kind =
-          | Intf of string
-          | Impl of string
-          | Str of string
-          | ModuleImpl of string
-          | IncludeDir of string
-        
-        let search_stdlib = ref true
-          
-        let print_loaded_modules = ref false
-          
-        let (task, do_task) =
-          let t = ref None in
-          let task f x =
-            let () = Camlp4_config.current_input_file := x
-            in
-              t :=
-                Some
-                  (if !t = None
-                   then (fun _ -> f x)
-                   else (fun usage -> usage ())) in
-          let do_task usage = match !t with | Some f -> f usage | None -> ()
-          in (task, do_task)
-          
-        let input_file x =
-          let dyn_loader = !dyn_loader ()
-          in
-            (!rcall_callback ();
-             (match x with
-              | Intf file_name -> task (process_intf dyn_loader) file_name
-              | Impl file_name -> task (process_impl dyn_loader) file_name
-              | Str s ->
-                  let (f, o) = Filename.open_temp_file "from_string" ".ml"
-                  in
-                    (output_string o s;
-                     close_out o;
-                     task (process_impl dyn_loader) f;
-                     at_exit (fun () -> Sys.remove f))
-              | ModuleImpl file_name -> rewrite_and_load "" file_name
-              | IncludeDir dir -> DynLoader.include_dir dyn_loader dir);
-             !rcall_callback ())
-          
-        let initial_spec_list =
-          [ ("-I", (Arg.String (fun x -> input_file (IncludeDir x))),
-             "<directory>  Add directory in search patch for object files.");
-            ("-where", (Arg.Unit print_stdlib),
-             "Print camlp4 library directory and exit.");
-            ("-nolib", (Arg.Clear search_stdlib),
-             "No automatic search for object files in library directory.");
-            ("-intf", (Arg.String (fun x -> input_file (Intf x))),
-             "<file>  Parse <file> as an interface, whatever its extension.");
-            ("-impl", (Arg.String (fun x -> input_file (Impl x))),
-             "<file>  Parse <file> as an implementation, whatever its extension.");
-            ("-str", (Arg.String (fun x -> input_file (Str x))),
-             "<string>  Parse <string> as an implementation.");
-            ("-unsafe", (Arg.Set Camlp4_config.unsafe),
-             "Generate unsafe accesses to array and strings.");
-            ("-noassert", (Arg.Unit warn_noassert),
-             "Obsolete, do not use this option.");
-            ("-verbose", (Arg.Set Camlp4_config.verbose),
-             "More verbose in parsing errors.");
-            ("-loc", (Arg.Set_string Loc.name),
-             ("<name>   Name of the location variable (default: " ^
-                (!Loc.name ^ ").")));
-            ("-QD", (Arg.String (fun x -> Quotation.dump_file := Some x)),
-             "<file> Dump quotation expander result in case of syntax error.");
-            ("-o", (Arg.String (fun x -> output_file := Some x)),
-             "<file> Output on <file> instead of standard output.");
-            ("-v", (Arg.Unit print_version),
-             "Print Camlp4 version and exit.");
-            ("-version", (Arg.Unit just_print_the_version),
-             "Print Camlp4 version number and exit.");
-            ("-vnum", (Arg.Unit just_print_the_version),
-             "Print Camlp4 version number and exit.");
-            ("-no_quot", (Arg.Clear Camlp4_config.quotations),
-             "Don't parse quotations, allowing to use, e.g. \"<:>\" as token.");
-            ("-loaded-modules", (Arg.Set print_loaded_modules),
-             "Print the list of loaded modules.");
-            ("-parser", (Arg.String (rewrite_and_load "Parsers")),
-             "<name>  Load the parser Camlp4Parsers/<name>.cm(o|a|xs)");
-            ("-printer", (Arg.String (rewrite_and_load "Printers")),
-             "<name>  Load the printer Camlp4Printers/<name>.cm(o|a|xs)");
-            ("-filter", (Arg.String (rewrite_and_load "Filters")),
-             "<name>  Load the filter Camlp4Filters/<name>.cm(o|a|xs)");
-            ("-ignore", (Arg.String ignore), "ignore the next argument");
-            ("--", (Arg.Unit ignore), "Deprecated, does nothing") ]
-          
-        let _ = Options.init initial_spec_list
-          
-        let anon_fun name =
-          input_file
-            (if Filename.check_suffix name ".mli"
-             then Intf name
-             else
-               if Filename.check_suffix name ".ml"
-               then Impl name
-               else
-                 if Filename.check_suffix name objext
-                 then ModuleImpl name
-                 else
-                   if Filename.check_suffix name libext
-                   then ModuleImpl name
-                   else
-                     raise (Arg.Bad ("don't know what to do with " ^ name)))
-          
-        let main argv =
-          let usage () =
-            (usage initial_spec_list (Options.ext_spec_list ()); exit 0)
-          in
-            try
-              let dynloader =
-                DynLoader.mk ~ocaml_stdlib: !search_stdlib
-                  ~camlp4_stdlib: !search_stdlib ()
-              in
-                (dyn_loader := (fun () -> dynloader);
-                 let call_callback () =
-                   Register.iter_and_take_callbacks
-                     (fun (name, module_callback) ->
-                        let () = add_to_loaded_modules name
-                        in module_callback ())
-                 in
-                   (call_callback ();
-                    rcall_callback := call_callback;
-                    (match Options.parse anon_fun argv with
-                     | [] -> ()
-                     | ("-help" | "--help" | "-h" | "-?") :: _ -> usage ()
-                     | s :: _ ->
-                         (eprintf "%s: unknown or misused option\n" s;
-                          eprintf "Use option -help for usage@.";
-                          exit 2));
-                    do_task usage;
-                    call_callback ();
-                    if !print_loaded_modules
-                    then SSet.iter (eprintf "%s@.") !loaded_modules
-                    else ()))
-            with
-            | Arg.Bad s ->
-                (eprintf "Error: %s\n" s;
-                 eprintf "Use option -help for usage@.";
-                 exit 2)
-            | Arg.Help _ -> usage ()
-            | exc -> (eprintf "@[<v0>%a@]@." ErrorHandler.print exc; exit 2)
-          
-        let _ = main Sys.argv
-          
-      end
-      
-  end
-  
 module PreCast :
   sig module Id : Sig.Id
          include MakePreCast.S with module Loc = Struct.Loc

camlp4/boot/Camlp4.ml4

 module OCamlInitSyntax = struct INCLUDE "camlp4/Camlp4/OCamlInitSyntax.ml"; end;
 module MakeRegister = struct INCLUDE "camlp4/Camlp4/MakeRegister.ml"; end;
 module MakePreCast = struct INCLUDE "camlp4/Camlp4/MakePreCast.ml"; end;
-module MakeCamlp4Bin = struct INCLUDE "camlp4/Camlp4/MakeCamlp4Bin.ml"; end;
 module PreCast : sig INCLUDE "camlp4/Camlp4/PreCast.mli"; end = struct INCLUDE "camlp4/Camlp4/PreCast.ml"; end;
 
 module Register = struct INCLUDE "camlp4/Camlp4/Register.ml"; end;

camlp4/boot/camlp4boot.ml

           
       end
       
-    module IdOCamlParserParser : Sig.Id =
+    module IdParserParser : Sig.Id =
       struct
         let name = "Camlp4OCamlParserParser"
           
           
       end
       
-    module MakeOCamlParserParser (Syntax : Sig.Camlp4Syntax) =
+    module MakeParserParser (Syntax : Sig.Camlp4Syntax) =
       struct
         open Sig
           
           
       end
       
-  end
-  
-module Camlp4Filters =
-  struct
-    open Camlp4
-      
-    module IdAstLifter =
-      struct let name = "Camlp4AstLifter"
-                let version = Sys.ocaml_version
-                   end
+    module IdQuotationCommon =
+      struct
+        (* FIXME unused here *)
+        let name = "Camlp4QuotationCommon"
+          
+        let version = Sys.ocaml_version
+          
+      end
       
-    module MakeAstLifter (AstFilters : Camlp4.Sig.AstFilters) =
+    module MakeQuotationCommon
+      (Syntax : Sig.Camlp4Syntax)
+      (TheAntiquotSyntax : Sig.Parser(Syntax.Ast).SIMPLE) =
       struct
-        open AstFilters
+        open Sig
+          
+        include Syntax
+          
+        (* Be careful an AntiquotSyntax module appears here *)
+        module MetaLocHere = Ast.Meta.MetaLoc
           
         module MetaLoc =
           struct
             module Ast = Ast
               
-            let meta_loc_patt _loc _ =
-              Ast.PaId (_loc, (Ast.IdLid (_loc, "loc")))
+            let loc_name = ref None
               
-            let meta_loc_expr _loc _ =
-              Ast.ExId (_loc, (Ast.IdLid (_loc, "loc")))
+            let meta_loc_expr _loc loc =
+              match !loc_name with
+              | None -> Ast.ExId (_loc, (Ast.IdLid (_loc, !Loc.name)))
+              | Some "here" -> MetaLocHere.meta_loc_expr _loc loc
+              | Some x -> Ast.ExId (_loc, (Ast.IdLid (_loc, x)))
+              
+            let meta_loc_patt _loc _ = Ast.PaAny _loc
               
           end
           
         module MetaAst = Ast.Meta.Make(MetaLoc)