snapshot

Author: bobzhang

lib/4.06.1/unstable/all_ounit_tests.ml

@@ -9594,6 +9594,8 @@ val read_ast : 'a kind -> in_channel -> 'a
 
 val write_ast :
    'a kind -> string -> 'a -> out_channel -> unit
+
+val magic_of_kind : 'a kind -> string   
 end = struct
 #1 "ml_binary.ml"
 (* Copyright (C) 2015-2016 Bloomberg Finance L.P.
@@ -9647,6 +9649,12 @@ let write_ast (type t) (kind : t kind)
   output_string oc magic ;
   output_value oc fname;
   output_value oc pt
+
+let magic_of_kind : type a . a kind -> string = function
+  | Ml -> Config.ast_impl_magic_number
+  | Mli -> Config.ast_intf_magic_number
+
+  
 end
 module Ast_extract : sig 
 #1 "ast_extract.mli"

lib/4.06.1/unstable/bspack.ml

@@ -12067,6 +12067,8 @@ val read_ast : 'a kind -> in_channel -> 'a
 
 val write_ast :
    'a kind -> string -> 'a -> out_channel -> unit
+
+val magic_of_kind : 'a kind -> string   
 end = struct
 #1 "ml_binary.ml"
 (* Copyright (C) 2015-2016 Bloomberg Finance L.P.
@@ -12120,6 +12122,12 @@ let write_ast (type t) (kind : t kind)
   output_string oc magic ;
   output_value oc fname;
   output_value oc pt
+
+let magic_of_kind : type a . a kind -> string = function
+  | Ml -> Config.ast_impl_magic_number
+  | Mli -> Config.ast_intf_magic_number
+
+  
 end
 module Ast_extract : sig 
 #1 "ast_extract.mli"

lib/4.06.1/whole_compiler.ml

@@ -365064,6 +365064,8 @@ val read_ast : 'a kind -> in_channel -> 'a
 
 val write_ast :
    'a kind -> string -> 'a -> out_channel -> unit
+
+val magic_of_kind : 'a kind -> string   
 end = struct
 #1 "ml_binary.ml"
 (* Copyright (C) 2015-2016 Bloomberg Finance L.P.
@@ -365117,6 +365119,12 @@ let write_ast (type t) (kind : t kind)
   output_string oc magic ;
   output_value oc fname;
   output_value oc pt
+
+let magic_of_kind : type a . a kind -> string = function
+  | Ml -> Config.ast_impl_magic_number
+  | Mli -> Config.ast_intf_magic_number
+
+  
 end
 module Ast_extract : sig 
 #1 "ast_extract.mli"
@@ -403474,6 +403482,125 @@ let lambda_as_module
     However, use filename instead of {!Env.current_unit} is more honest, since node-js module system is coupled with the file name 
 *)
 
+end
+module Cmd_ast_exception
+= struct
+#1 "cmd_ast_exception.ml"
+type error =
+  | CannotRun of string
+  | WrongMagic of string
+
+exception Error of error
+
+
+let report_error ppf = function
+  | CannotRun cmd ->
+      Format.fprintf ppf "Error while running external preprocessor@.\
+                   Command line: %s@." cmd
+  | WrongMagic cmd ->
+      Format.fprintf ppf "External preprocessor does not produce a valid file@.\
+                   Command line: %s@." cmd
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
+
+let cannot_run comm = 
+  raise (Error (CannotRun comm))    
+
+let wrong_magic magic = 
+    raise (Error (WrongMagic magic))  
+end
+module Cmd_ppx_apply
+= struct
+#1 "cmd_ppx_apply.ml"
+
+
+(* Note: some of the functions here should go to Ast_mapper instead,
+   which would encapsulate the "binary AST" protocol. *)
+
+let write_ast (type a) (kind : a Ml_binary.kind) fn (ast : a) =
+  let oc = open_out_bin fn in
+  output_string oc (Ml_binary.magic_of_kind kind);
+  output_value oc (!Location.input_name : string);
+  output_value oc (ast : a);
+  close_out oc
+
+let apply_rewriter kind fn_in ppx =
+  let magic = Ml_binary.magic_of_kind kind in
+  let fn_out = Filename.temp_file "camlppx" "" in
+  let comm =
+    Printf.sprintf "%s %s %s" ppx (Filename.quote fn_in) (Filename.quote fn_out)
+  in
+  let ok = Ccomp.command comm = 0 in
+  Misc.remove_file fn_in;
+  if not ok then begin
+    Misc.remove_file fn_out;
+    Cmd_ast_exception.cannot_run comm
+  end;
+  if not (Sys.file_exists fn_out) then
+    Cmd_ast_exception.cannot_run comm;
+  (* check magic before passing to the next ppx *)
+  let ic = open_in_bin fn_out in
+  let buffer =
+    try really_input_string ic (String.length magic) with End_of_file -> "" in
+  close_in ic;
+  if buffer <> magic then begin
+    Misc.remove_file fn_out;
+    Cmd_ast_exception.wrong_magic buffer;
+  end;
+  fn_out
+
+let read_ast (type a) (kind : a Ml_binary.kind) fn : a =
+  let ic = open_in_bin fn in
+  try
+    let magic = Ml_binary.magic_of_kind kind in
+    let buffer = really_input_string ic (String.length magic) in
+    assert(buffer = magic); (* already checked by apply_rewriter *)
+    Location.set_input_name @@ (input_value ic : string);
+    let ast = (input_value ic : a) in
+    close_in ic;
+    Misc.remove_file fn;
+    ast
+  with exn ->
+    close_in ic;
+    Misc.remove_file fn;
+    raise exn
+let rewrite kind ppxs ast =
+  let fn = Filename.temp_file "camlppx" "" in
+  write_ast kind fn ast;
+  let fn = List.fold_left (apply_rewriter kind) fn (List.rev ppxs) in
+  read_ast kind fn
+
+let apply_rewriters_str ?(restore = true) ~tool_name ast =
+  match !Clflags.all_ppx with
+  | [] -> ast
+  | ppxs ->
+    ast
+    |> Ast_mapper.add_ppx_context_str ~tool_name
+    |> rewrite Ml ppxs
+    |> Ast_mapper.drop_ppx_context_str ~restore
+
+let apply_rewriters_sig ?(restore = true) ~tool_name ast =
+  match !Clflags.all_ppx with
+  | [] -> ast
+  | ppxs ->
+    ast
+    |> Ast_mapper.add_ppx_context_sig ~tool_name
+    |> rewrite Mli ppxs
+    |> Ast_mapper.drop_ppx_context_sig ~restore
+
+let apply_rewriters ?restore ~tool_name
+    (type a) (kind : a Ml_binary.kind) (ast : a) : a =
+  match kind with
+  | Ml_binary.Ml ->
+    apply_rewriters_str ?restore ~tool_name ast
+  | Ml_binary.Mli ->
+    apply_rewriters_sig ?restore ~tool_name ast
+
 end
 module Parse : sig 
 #1 "parse.mli"
@@ -403592,11 +403719,6 @@ end = struct
 #1 "pparse_driver.ml"
 
 
-type error =
-  | CannotRun of string
-  | WrongMagic of string
-
-exception Error of error
 
 (* Optionally preprocess a source file *)
 
@@ -403607,7 +403729,7 @@ let call_external_preprocessor sourcefile pp =
       in
       if Ccomp.command comm <> 0 then begin
         Misc.remove_file tmpfile;
-        raise (Error (CannotRun comm));
+        Cmd_ast_exception.cannot_run comm
       end;
       tmpfile
 
@@ -403623,126 +403745,30 @@ let remove_preprocessed inputfile =
     None -> ()
   | Some _ -> Misc.remove_file inputfile
 
-type 'a ast_kind =
-| Structure : Parsetree.structure ast_kind
-| Signature : Parsetree.signature ast_kind
-
-let magic_of_kind : type a . a ast_kind -> string = function
-  | Structure -> Config.ast_impl_magic_number
-  | Signature -> Config.ast_intf_magic_number
-
-(* Note: some of the functions here should go to Ast_mapper instead,
-   which would encapsulate the "binary AST" protocol. *)
-
-let write_ast (type a) (kind : a ast_kind) fn (ast : a) =
-  let oc = open_out_bin fn in
-  output_string oc (magic_of_kind kind);
-  output_value oc (!Location.input_name : string);
-  output_value oc (ast : a);
-  close_out oc
-
-let apply_rewriter kind fn_in ppx =
-  let magic = magic_of_kind kind in
-  let fn_out = Filename.temp_file "camlppx" "" in
-  let comm =
-    Printf.sprintf "%s %s %s" ppx (Filename.quote fn_in) (Filename.quote fn_out)
-  in
-  let ok = Ccomp.command comm = 0 in
-  Misc.remove_file fn_in;
-  if not ok then begin
-    Misc.remove_file fn_out;
-    raise (Error (CannotRun comm));
-  end;
-  if not (Sys.file_exists fn_out) then
-    raise (Error (WrongMagic comm));
-  (* check magic before passing to the next ppx *)
-  let ic = open_in_bin fn_out in
-  let buffer =
-    try really_input_string ic (String.length magic) with End_of_file -> "" in
-  close_in ic;
-  if buffer <> magic then begin
-    Misc.remove_file fn_out;
-    raise (Error (WrongMagic comm));
-  end;
-  fn_out
-
-let read_ast (type a) (kind : a ast_kind) fn : a =
-  let ic = open_in_bin fn in
-  try
-    let magic = magic_of_kind kind in
-    let buffer = really_input_string ic (String.length magic) in
-    assert(buffer = magic); (* already checked by apply_rewriter *)
-    Location.set_input_name @@ (input_value ic : string);
-    let ast = (input_value ic : a) in
-    close_in ic;
-    Misc.remove_file fn;
-    ast
-  with exn ->
-    close_in ic;
-    Misc.remove_file fn;
-    raise exn
 
-let rewrite kind ppxs ast =
-  let fn = Filename.temp_file "camlppx" "" in
-  write_ast kind fn ast;
-  let fn = List.fold_left (apply_rewriter kind) fn (List.rev ppxs) in
-  read_ast kind fn
 
-let apply_rewriters_str ?(restore = true) ~tool_name ast =
-  match !Clflags.all_ppx with
-  | [] -> ast
-  | ppxs ->
-      ast
-      |> Ast_mapper.add_ppx_context_str ~tool_name
-      |> rewrite Structure ppxs
-      |> Ast_mapper.drop_ppx_context_str ~restore
 
-let apply_rewriters_sig ?(restore = true) ~tool_name ast =
-  match !Clflags.all_ppx with
-  | [] -> ast
-  | ppxs ->
-      ast
-      |> Ast_mapper.add_ppx_context_sig ~tool_name
-      |> rewrite Signature ppxs
-      |> Ast_mapper.drop_ppx_context_sig ~restore
 
-let apply_rewriters ?restore ~tool_name
-    (type a) (kind : a ast_kind) (ast : a) : a =
-  match kind with
-  | Structure ->
-      apply_rewriters_str ?restore ~tool_name ast
-  | Signature ->
-      apply_rewriters_sig ?restore ~tool_name ast
 
 (* Parse a file or get a dumped syntax tree from it *)
 
-exception Outdated_version
+let parse (type a) (kind : a Ml_binary.kind) lexbuf : a =
+  match kind with
+  | Ml_binary.Ml -> Parse.implementation lexbuf
+  | Ml_binary.Mli -> Parse.interface lexbuf
 
-let open_and_check_magic inputfile ast_magic =
+let file_aux ppf  inputfile (type a) (parse_fun  : _ -> a)
+             (kind : a Ml_binary.kind) : a  =
+  let ast_magic = Ml_binary.magic_of_kind kind in
   let ic = open_in_bin inputfile in
   let is_ast_file =
-    try
-      let buffer = really_input_string ic (String.length ast_magic) in
+    match really_input_string ic (String.length ast_magic) with 
+    | exception _ -> false 
+    |  buffer ->
       if buffer = ast_magic then true
-      else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
-        raise Outdated_version
-      else false
-    with
-      Outdated_version ->
-        Misc.fatal_error "OCaml and preprocessor have incompatible versions"
-    | _ -> false
-  in
-  (ic, is_ast_file)
-
-let parse (type a) (kind : a ast_kind) lexbuf : a =
-  match kind with
-  | Structure -> Parse.implementation lexbuf
-  | Signature -> Parse.interface lexbuf
-
-let file_aux ppf  inputfile (type a) (parse_fun  : _ -> a)
-             (kind : a ast_kind) : a  =
-  let ast_magic = magic_of_kind kind in
-  let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in
+      else if Ext_string.starts_with buffer "Caml1999" then
+        Cmd_ast_exception.wrong_magic buffer
+      else false in 
   let ast =
     try
       if is_ast_file then begin
@@ -403764,20 +403790,7 @@ let file_aux ppf  inputfile (type a) (parse_fun  : _ -> a)
 
 
 
-let report_error ppf = function
-  | CannotRun cmd ->
-      Format.fprintf ppf "Error while running external preprocessor@.\
-                   Command line: %s@." cmd
-  | WrongMagic cmd ->
-      Format.fprintf ppf "External preprocessor does not produce a valid file@.\
-                   Command line: %s@." cmd
 
-let () =
-  Location.register_error_of_exn
-    (function
-      | Error err -> Some (Location.error_of_printer_file report_error err)
-      | _ -> None
-    )
 
 let parse_file kind ppf sourcefile =
   Location.set_input_name  sourcefile;
@@ -403795,11 +403808,11 @@ let parse_file kind ppf sourcefile =
 
 
 let parse_implementation ppf ~tool_name sourcefile =  
-  apply_rewriters ~restore:false ~tool_name Structure  (parse_file 
-       Structure ppf sourcefile)
+  Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name Ml  (parse_file 
+       Ml ppf sourcefile)
 let parse_interface ppf ~tool_name sourcefile =
-  apply_rewriters ~restore:false ~tool_name Signature (parse_file 
-       Signature ppf sourcefile)
+  Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name Mli (parse_file 
+       Mli ppf sourcefile)
 
 end
 module Pprintast : sig