l4/pkg/ocaml/contrib/camlp4/Camlp4Bin.ml

   1 (* camlp4r *)
   2 (****************************************************************************)
   3 (*                                                                          *)
   4 (*                              Objective Caml                              *)
   5 (*                                                                          *)
   6 (*                            INRIA Rocquencourt                            *)
   7 (*                                                                          *)
   8 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
   9 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
  10 (*  the terms of the GNU Library General Public License, with the special   *)
  11 (*  exception on linking described in LICENSE at the top of the Objective   *)
  12 (*  Caml source tree.                                                       *)
  13 (*                                                                          *)
  14 (****************************************************************************)
  15
  16 (* Authors:
  17  * - Daniel de Rauglaudre: initial version
  18  * - Nicolas Pouillard: refactoring
  19  *)
  20
  21
  22
  23 open Camlp4;
  24 open PreCast.Syntax;
  25 open PreCast;
  26 open Format;
  27 module CleanAst = Camlp4.Struct.CleanAst.Make Ast;
  28 module SSet = Set.Make String;
  29
  30 value pa_r  = "Camlp4OCamlRevisedParser";
  31 value pa_rr = "Camlp4OCamlReloadedParser";
  32 value pa_o  = "Camlp4OCamlParser";
  33 value pa_rp = "Camlp4OCamlRevisedParserParser";
  34 value pa_op = "Camlp4OCamlParserParser";
  35 value pa_g  = "Camlp4GrammarParser";
  36 value pa_m  = "Camlp4MacroParser";
  37 value pa_qb = "Camlp4QuotationCommon";
  38 value pa_q  = "Camlp4QuotationExpander";
  39 value pa_rq = "Camlp4OCamlRevisedQuotationExpander";
  40 value pa_oq = "Camlp4OCamlOriginalQuotationExpander";
  41 value pa_l  = "Camlp4ListComprehension";
  42
  43 open Register;
  44
  45 value dyn_loader = ref (fun []);
  46 value rcall_callback = ref (fun () -> ());
  47 value loaded_modules = ref SSet.empty;
  48 value add_to_loaded_modules name =
  49   loaded_modules.val := SSet.add name loaded_modules.val;
  50
  51 value (objext,libext) =
  52   if DynLoader.is_native then (".cmxs",".cmxs")
  53   else (".cmo",".cma");
  54
  55 value rewrite_and_load n x =
  56   let dyn_loader = dyn_loader.val () in
  57   let find_in_path = DynLoader.find_in_path dyn_loader in
  58   let real_load name = do {
  59     add_to_loaded_modules name;
  60     DynLoader.load dyn_loader name
  61   } in
  62   let load = List.iter begin fun n ->
  63     if SSet.mem n loaded_modules.val || List.mem n Register.loaded_modules.val then ()
  64     else begin
  65       add_to_loaded_modules n;
  66       DynLoader.load dyn_loader (n ^ objext);
  67     end
  68   end in
  69   do {
  70     match (n, String.lowercase x) with
  71     [ ("Parsers"|"", "pa_r.cmo"      | "r"  | "ocamlr" | "ocamlrevised" | "camlp4ocamlrevisedparser.cmo") -> load [pa_r]
  72     | ("Parsers"|"", "rr" | "reloaded" | "ocamlreloaded" | "camlp4ocamlreloadedparser.cmo") -> load [pa_rr]
  73     | ("Parsers"|"", "pa_o.cmo"      | "o"  | "ocaml" | "camlp4ocamlparser.cmo") -> load [pa_r; pa_o]
  74     | ("Parsers"|"", "pa_rp.cmo"     | "rp" | "rparser" | "camlp4ocamlrevisedparserparser.cmo") -> load [pa_r; pa_o; pa_rp]
  75     | ("Parsers"|"", "pa_op.cmo"     | "op" | "parser" | "camlp4ocamlparserparser.cmo") -> load [pa_r; pa_o; pa_rp; pa_op]
  76     | ("Parsers"|"", "pa_extend.cmo" | "pa_extend_m.cmo" | "g" | "grammar" | "camlp4grammarparser.cmo") -> load [pa_g]
  77     | ("Parsers"|"", "pa_macro.cmo"  | "m"  | "macro" | "camlp4macroparser.cmo") -> load [pa_m]
  78     | ("Parsers"|"", "q" | "camlp4quotationexpander.cmo") -> load [pa_qb; pa_q]
  79     | ("Parsers"|"", "q_mlast.cmo" | "rq" | "camlp4ocamlrevisedquotationexpander.cmo") -> load [pa_qb; pa_rq]
  80     | ("Parsers"|"", "oq" | "camlp4ocamloriginalquotationexpander.cmo") -> load [pa_r; pa_o; pa_qb; pa_oq]
  81     | ("Parsers"|"", "rf") -> load [pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m]
  82     | ("Parsers"|"", "of") -> load [pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_rq; pa_g; pa_l; pa_m]
  83     | ("Parsers"|"", "comp" | "camlp4listcomprehension.cmo") -> load [pa_l]
  84     | ("Filters"|"", "lift" | "camlp4astlifter.cmo") -> load ["Camlp4AstLifter"]
  85     | ("Filters"|"", "exn" | "camlp4exceptiontracer.cmo") -> load ["Camlp4ExceptionTracer"]
  86     | ("Filters"|"", "prof" | "camlp4profiler.cmo") -> load ["Camlp4Profiler"]
  87     (* map is now an alias of fold since fold handles map too *)
  88     | ("Filters"|"", "map" | "camlp4mapgenerator.cmo") -> load ["Camlp4FoldGenerator"]
  89     | ("Filters"|"", "fold" | "camlp4foldgenerator.cmo") -> load ["Camlp4FoldGenerator"]
  90     | ("Filters"|"", "meta" | "camlp4metagenerator.cmo") -> load ["Camlp4MetaGenerator"]
  91     | ("Filters"|"", "trash" | "camlp4trashremover.cmo") -> load ["Camlp4TrashRemover"]
  92     | ("Filters"|"", "striploc" | "camlp4locationstripper.cmo") -> load ["Camlp4LocationStripper"]
  93     | ("Printers"|"", "pr_r.cmo" | "r" | "ocamlr" | "camlp4ocamlrevisedprinter.cmo") ->
  94         Register.enable_ocamlr_printer ()
  95     | ("Printers"|"", "pr_o.cmo" | "o" | "ocaml" | "camlp4ocamlprinter.cmo") ->
  96         Register.enable_ocaml_printer ()
  97     | ("Printers"|"", "pr_dump.cmo" | "p" | "dumpocaml" | "camlp4ocamlastdumper.cmo") ->
  98         Register.enable_dump_ocaml_ast_printer ()
  99     | ("Printers"|"", "d" | "dumpcamlp4" | "camlp4astdumper.cmo") ->
 100         Register.enable_dump_camlp4_ast_printer ()
 101     | ("Printers"|"", "a" | "auto" | "camlp4autoprinter.cmo") ->
 102         load ["Camlp4AutoPrinter"]
 103     | _ ->
 104       let y = "Camlp4"^n^"/"^x^objext in
 105       real_load (try find_in_path y with [ Not_found -> x ]) ];
 106     rcall_callback.val ();
 107   };
 108
 109 value print_warning = eprintf "%a:\n%s@." Loc.print;
 110
 111 value rec parse_file dyn_loader name pa getdir =
 112   let directive_handler = Some (fun ast ->
 113     match getdir ast with
 114     [ Some x ->
 115         match x with
 116         [ (_, "load", s) -> do { rewrite_and_load "" s; None }
 117         | (_, "directory", s) -> do { DynLoader.include_dir dyn_loader s; None }
 118         | (_, "use", s) -> Some (parse_file dyn_loader s pa getdir)
 119         | (_, "default_quotation", s) -> do { Quotation.default.val := s; None }
 120         | (loc, _, _) -> Loc.raise loc (Stream.Error "bad directive") ]
 121     | None -> None ]) in
 122   let loc = Loc.mk name
 123   in do {
 124     current_warning.val := print_warning;
 125     let ic = if name = "-" then stdin else open_in_bin name;
 126     let cs = Stream.of_channel ic;
 127     let clear () = if name = "-" then () else close_in ic;
 128     let phr =
 129       try pa ?directive_handler loc cs
 130       with x -> do { clear (); raise x };
 131     clear ();
 132     phr
 133   };
 134
 135 value output_file = ref None;
 136
 137 value process dyn_loader name pa pr clean fold_filters getdir =
 138   let ast = parse_file dyn_loader name pa getdir in
 139   let ast = fold_filters (fun t filter -> filter t) ast in
 140   let ast = clean ast in
 141   pr ?input_file:(Some name) ?output_file:output_file.val ast;
 142
 143 value gind =
 144   fun
 145   [ <:sig_item@loc< # $n$ $str:s$ >> -> Some (loc, n, s)
 146   | _ -> None ];
 147
 148 value gimd =
 149   fun
 150   [ <:str_item@loc< # $n$ $str:s$ >> -> Some (loc, n, s)
 151   | _ -> None ];
 152
 153 value process_intf dyn_loader name =
 154   process dyn_loader name CurrentParser.parse_interf CurrentPrinter.print_interf
 155           (new CleanAst.clean_ast)#sig_item
 156           AstFilters.fold_interf_filters gind;
 157 value process_impl dyn_loader name =
 158   process dyn_loader name CurrentParser.parse_implem CurrentPrinter.print_implem
 159           (new CleanAst.clean_ast)#str_item
 160           AstFilters.fold_implem_filters gimd;
 161
 162 value just_print_the_version () =
 163   do { printf "%s@." Camlp4_config.version; exit 0 };
 164
 165 value print_version () =
 166   do { eprintf "Camlp4 version %s@." Camlp4_config.version; exit 0 };
 167
 168 value print_stdlib () =
 169   do { printf "%s@." Camlp4_config.camlp4_standard_library; exit 0 };
 170
 171 value usage ini_sl ext_sl =
 172   do {
 173     eprintf "\
 174 Usage: camlp4 [load-options] [--] [other-options]
 175 Options:
 176 <file>.ml        Parse this implementation file
 177 <file>.mli       Parse this interface file
 178 <file>.%s Load this module inside the Camlp4 core@."
 179 (if DynLoader.is_native then "cmxs     " else "(cmo|cma)")
 180 ;
 181     Options.print_usage_list ini_sl;
 182     (* loop (ini_sl @ ext_sl) where rec loop =
 183       fun
 184       [ [(y, _, _) :: _] when y = "-help" -> ()
 185       | [_ :: sl] -> loop sl
 186       | [] -> eprintf "  -help         Display this list of options.@." ];    *)
 187     if ext_sl <> [] then do {
 188       eprintf "Options added by loaded object files:@.";
 189       Options.print_usage_list ext_sl;
 190     }
 191     else ();
 192   };
 193
 194 value warn_noassert () =
 195   do {
 196     eprintf "\
 197 camlp4 warning: option -noassert is obsolete
 198 You should give the -noassert option to the ocaml compiler instead.@.";
 199   };
 200
 201 type file_kind =
 202   [ Intf of string
 203   | Impl of string
 204   | Str of string
 205   | ModuleImpl of string
 206   | IncludeDir of string ];
 207
 208 value search_stdlib = ref True;
 209 value print_loaded_modules = ref False;
 210 value (task, do_task) =
 211   let t = ref None in
 212   let task f x =
 213     let () = Camlp4_config.current_input_file.val := x in
 214     t.val := Some (if t.val = None then (fun _ -> f x)
 215                    else (fun usage -> usage ())) in
 216   let do_task usage = match t.val with [ Some f -> f usage | None -> () ] in
 217   (task, do_task);
 218 value input_file x =
 219   let dyn_loader = dyn_loader.val () in
 220   do {
 221     rcall_callback.val ();
 222     match x with
 223     [ Intf file_name -> task (process_intf dyn_loader) file_name
 224     | Impl file_name -> task (process_impl dyn_loader) file_name
 225     | Str s ->
 226         begin
 227           let (f, o) = Filename.open_temp_file "from_string" ".ml";
 228           output_string o s;
 229           close_out o;
 230           task (process_impl dyn_loader) f;
 231           at_exit (fun () -> Sys.remove f);
 232         end
 233     | ModuleImpl file_name -> rewrite_and_load "" file_name
 234     | IncludeDir dir -> DynLoader.include_dir dyn_loader dir ];
 235     rcall_callback.val ();
 236   };
 237
 238 value initial_spec_list =
 239   [("-I", Arg.String (fun x -> input_file (IncludeDir x)),
 240     "<directory>  Add directory in search patch for object files.");
 241   ("-where", Arg.Unit print_stdlib,
 242     "Print camlp4 library directory and exit.");
 243   ("-nolib", Arg.Clear search_stdlib,
 244     "No automatic search for object files in library directory.");
 245   ("-intf", Arg.String (fun x -> input_file (Intf x)),
 246     "<file>  Parse <file> as an interface, whatever its extension.");
 247   ("-impl", Arg.String (fun x -> input_file (Impl x)),
 248     "<file>  Parse <file> as an implementation, whatever its extension.");
 249   ("-str", Arg.String (fun x -> input_file (Str x)),
 250     "<string>  Parse <string> as an implementation.");
 251   ("-unsafe", Arg.Set Camlp4_config.unsafe,
 252     "Generate unsafe accesses to array and strings.");
 253   ("-noassert", Arg.Unit warn_noassert,
 254     "Obsolete, do not use this option.");
 255   ("-verbose", Arg.Set Camlp4_config.verbose,
 256     "More verbose in parsing errors.");
 257   ("-loc", Arg.Set_string Loc.name,
 258     "<name>   Name of the location variable (default: " ^ Loc.name.val ^ ").");
 259   ("-QD", Arg.String (fun x -> Quotation.dump_file.val := Some x),
 260     "<file> Dump quotation expander result in case of syntax error.");
 261   ("-o", Arg.String (fun x -> output_file.val := Some x),
 262     "<file> Output on <file> instead of standard output.");
 263   ("-v", Arg.Unit print_version,
 264     "Print Camlp4 version and exit.");
 265   ("-version", Arg.Unit just_print_the_version,
 266     "Print Camlp4 version number and exit.");
 267   ("-no_quot", Arg.Clear Camlp4_config.quotations,
 268     "Don't parse quotations, allowing to use, e.g. \"<:>\" as token.");
 269   ("-loaded-modules", Arg.Set print_loaded_modules, "Print the list of loaded modules.");
 270   ("-parser", Arg.String (rewrite_and_load "Parsers"),
 271     "<name>  Load the parser Camlp4Parsers/<name>.cm(o|a|xs)");
 272   ("-printer", Arg.String (rewrite_and_load "Printers"),
 273     "<name>  Load the printer Camlp4Printers/<name>.cm(o|a|xs)");
 274   ("-filter", Arg.String (rewrite_and_load "Filters"),
 275     "<name>  Load the filter Camlp4Filters/<name>.cm(o|a|xs)");
 276   ("-ignore", Arg.String ignore, "ignore the next argument");
 277   ("--", Arg.Unit ignore, "Deprecated, does nothing")
 278 ];
 279
 280 Options.init initial_spec_list;
 281
 282 value anon_fun name =
 283   input_file
 284   (if Filename.check_suffix name ".mli" then Intf name
 285     else if Filename.check_suffix name ".ml" then Impl name
 286     else if Filename.check_suffix name objext then ModuleImpl name
 287     else if Filename.check_suffix name libext then ModuleImpl name
 288     else raise (Arg.Bad ("don't know what to do with " ^ name)));
 289
 290 value main argv =
 291   let usage () = do { usage initial_spec_list (Options.ext_spec_list ()); exit 0 } in
 292   try do {
 293     let dynloader = DynLoader.mk ~ocaml_stdlib:search_stdlib.val
 294                                  ~camlp4_stdlib:search_stdlib.val ();
 295     dyn_loader.val := fun () -> dynloader;
 296     let call_callback () =
 297       Register.iter_and_take_callbacks
 298         (fun (name, module_callback) ->
 299            let () = add_to_loaded_modules name in
 300            module_callback ());
 301     call_callback ();
 302     rcall_callback.val := call_callback;
 303     match Options.parse anon_fun argv with
 304     [ [] -> ()
 305     | ["-help"|"--help"|"-h"|"-?" :: _] -> usage ()
 306     | [s :: _] ->
 307         do { eprintf "%s: unknown or misused option\n" s;
 308             eprintf "Use option -help for usage@.";
 309             exit 2 } ];
 310     do_task usage;
 311     call_callback ();
 312     if print_loaded_modules.val then do {
 313       SSet.iter (eprintf "%s@.") loaded_modules.val;
 314     } else ()
 315   }
 316   with
 317   [ Arg.Bad s -> do { eprintf "Error: %s\n" s;
 318                       eprintf "Use option -help for usage@.";
 319                       exit 2 }
 320   | Arg.Help _ -> usage ()
 321   | exc -> do { eprintf "@[<v0>%a@]@." ErrorHandler.print exc; exit 2 } ];
 322
 323 main Sys.argv;