Source

ocaml / camlp4 / MakeCamlp4Bin.ml

Full commit
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416


(* open Camlp4Filters; *)
(* open Camlp4Parsers; *)
open Format;
open Camlp4;
open Camlp4Parsers;
open Camlp4Filters;


module type PRINTER_PLUGIN = sig
  value apply : (module MakeRegister.S) -> unit;
end ;
value printers : Hashtbl.t string (module PRINTER_PLUGIN) = Hashtbl.create 30; 
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;


      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 plugins = Hashtbl.create 50;      *)
      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
        (* no dynamic loading for built in parser any more, possible
            inconsistent behavior is that no duplicated check any more *)
        let load =  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")
            -> begin
              pa_r (module Register) ;
            end
          | ("Parsers"|"",
             "rr" | "reloaded" | "ocamlreloaded"| "camlp4ocamlreloadedparser.cmo")
            -> begin
              pa_rr (module Register) ;
          end 
          | ("Parsers"|"",
             "pa_o.cmo"| "o"| "ocaml" | "camlp4ocamlparser.cmo") ->
               begin
                 pa_r (module Register);
                 pa_o (module Register);
               end 
          | ("Parsers"|"",
             "pa_rp.cmo" | "rp" | "rparser" | "camlp4ocamlrevisedparserparser.cmo")
            -> begin
              pa_r (module Register);
              pa_rp (module Register);
            end 
          | ("Parsers"|"",
             "pa_op.cmo"| "op" | "parser" | "camlp4ocamlparserparser.cmo")
            -> begin
              pa_r (module Register);
              pa_o (module Register) ;
              pa_rp (module Register) ;
              pa_op (module Register);
            end 
          | ("Parsers"|"",
             "pa_extend.cmo" | "pa_extend_m.cmo" | "g" | "grammar" | "camlp4grammarparser.cmo")
            -> begin
              pa_g (module Register);
            end 
          | ("Parsers"|"",
             "pa_macro.cmo"  | "m"  | "macro" | "camlp4macroparser.cmo") -> begin
               pa_m (module Register);
             end 
          | ("Parsers"|"", "q" | "camlp4quotationexpander.cmo") -> begin
              pa_q (module Register); (* no pa_qb any more*)
          end 
          | ("Parsers"|"",
             "q_mlast.cmo" | "rq" | "camlp4ocamlrevisedquotationexpander.cmo")
            -> begin (* no pa_qb any more *)
              pa_rq (module Register) (module PreCast);
            end
          | ("Parsers"|"",
             "oq" | "camlp4ocamloriginalquotationexpander.cmo")
            ->  begin
              pa_r (module Register);
              pa_o (module Register);
              (* pa_qb;*)
              pa_oq (module Register) (module PreCast) ;
            end 
          | ("Parsers"|"", "rf") -> begin
              pa_r (module Register);
              pa_rp (module Register);
              (* pa_qb; *)
              pa_q (module Register);
              pa_g (module Register);
              pa_l (module Register);
              pa_m (module Register);
          end 
          | ("Parsers"|"", "of")
            -> begin
              pa_r (module Register);
              pa_o (module Register);
              pa_rp (module Register);
              pa_op (module Register);
              (* pa_qb; *)
              pa_q (module Register);
              pa_g (module Register);
              pa_l (module Register);
              pa_m (module Register);
            end
          | ("Parsers"|"",
             "comp" | "camlp4listcomprehension.cmo") ->
               begin
                 pa_l (module Register);
               end 
          | ("Filters"|"",
             "lift" | "camlp4astlifter.cmo") -> begin
               f_lift (module Register);
             end

          | ("Filters"|"",
             "exn" | "camlp4exceptiontracer.cmo") -> begin
               f_exn (module Register);
             end 
          | ("Filters"|"",
             "prof" | "camlp4profiler.cmo") -> begin 
               f_prof (module Register);
             end 
          (* map is now an alias of fold since fold handles map too *)
          | ("Filters"|"",
             "map" | "camlp4mapgenerator.cmo") -> begin
               f_fold (module Register);
             end 
          | ("Filters"|"", 
             "fold" | "camlp4foldgenerator.cmo") -> begin
               f_fold (module Register);
             end 
          | ("Filters"|"",
             "meta" | "camlp4metagenerator.cmo") -> begin
               f_meta (module Register);
             end 
          | ("Filters"|"",
             "trash" | "camlp4trashremover.cmo") -> begin
               f_trash (module Register);
             end 
          | ("Filters"|"",
             "striploc" | "camlp4locationstripper.cmo") -> begin
               f_striploc (module Register);
             end
          | ("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") ->
               (* FIXME introduced dependency on Unix *)
               (* Register.enable_auto (fun [ () -> Unix.isatty Unix.stdout]) *)
               begin
                 load "Camlp4Autoprinter";
                 let (module P ) = Hashtbl.find printers "camlp4autoprinter" in
                 P.apply (module Register);
               end
          | _ ->
            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;
            
            
    end ;