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
|
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2002 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
open Format
type error =
| CannotRun of string
| WrongMagic of string
exception Error of error
external open_desc: string -> open_flag list -> int -> int = "caml_sys_open"
external close_desc: int -> unit = "caml_sys_close"
(* Optionally preprocess a source file *)
let call_external_preprocessor sourcefile pp =
(* do not use Filename.temp_file as the resulting temporary file name will be
* recorded in the debug output of the resulting binary and thus make the
* output random and unreproducible *)
let temp_dir = Filename.get_temp_dir_name () in
let hash = Digest.to_hex (Digest.string (sourcefile^pp)) in
let tmpfile = Filename.concat temp_dir ("ocamlpp"^hash) in
close_desc(open_desc tmpfile [Open_wronly; Open_creat; Open_excl] 0o600);
let comm = Printf.sprintf "%s %s > %s"
pp (Filename.quote sourcefile) tmpfile
in
if Ccomp.command comm <> 0 then begin
Misc.remove_file tmpfile;
raise (Error (CannotRun comm));
end;
tmpfile
let preprocess sourcefile =
match !Clflags.preprocessor with
None -> sourcefile
| Some pp -> call_external_preprocessor sourcefile pp
let remove_preprocessed inputfile =
match !Clflags.preprocessor with
None -> ()
| Some _ -> Misc.remove_file inputfile
(* Note: some of the functions here should go to Ast_mapper instead,
which would encapsulate the "binary AST" protocol. *)
let write_ast magic ast =
let fn = Filename.temp_file "camlppx" "" in
let oc = open_out_bin fn in
output_string oc magic;
output_value oc !Location.input_name;
output_value oc ast;
close_out oc;
fn
let apply_rewriter magic fn_in ppx =
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 magic fn =
let ic = open_in_bin fn in
try
let buffer = really_input_string ic (String.length magic) in
assert(buffer = magic); (* already checked by apply_rewriter *)
Location.input_name := input_value ic;
let ast = input_value ic in
close_in ic;
Misc.remove_file fn;
ast
with exn ->
close_in ic;
Misc.remove_file fn;
raise exn
let rewrite magic ast ppxs =
read_ast magic
(List.fold_left (apply_rewriter magic) (write_ast magic ast)
(List.rev ppxs))
let apply_rewriters_str ?(restore = true) ~tool_name ast =
match !Clflags.all_ppx with
| [] -> ast
| ppxs ->
let ast = Ast_mapper.add_ppx_context_str ~tool_name ast in
let ast = rewrite Config.ast_impl_magic_number ast ppxs in
Ast_mapper.drop_ppx_context_str ~restore ast
let apply_rewriters_sig ?(restore = true) ~tool_name ast =
match !Clflags.all_ppx with
| [] -> ast
| ppxs ->
let ast = Ast_mapper.add_ppx_context_sig ~tool_name ast in
let ast = rewrite Config.ast_intf_magic_number ast ppxs in
Ast_mapper.drop_ppx_context_sig ~restore ast
let apply_rewriters ?restore ~tool_name magic ast =
if magic = Config.ast_impl_magic_number then
Obj.magic (apply_rewriters_str ?restore ~tool_name (Obj.magic ast))
else if magic = Config.ast_intf_magic_number then
Obj.magic (apply_rewriters_sig ?restore ~tool_name (Obj.magic ast))
else
assert false
(* Parse a file or get a dumped syntax tree from it *)
exception Outdated_version
let open_and_check_magic inputfile ast_magic =
let ic = open_in_bin inputfile in
let is_ast_file =
try
let buffer = really_input_string ic (String.length ast_magic) in
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 file ppf ~tool_name inputfile parse_fun ast_magic =
let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in
let ast =
try
if is_ast_file then begin
if !Clflags.fast then
(* FIXME make this a proper warning *)
fprintf ppf "@[Warning: %s@]@."
"option -unsafe used with a preprocessor returning a syntax tree";
Location.input_name := input_value ic;
input_value ic
end else begin
seek_in ic 0;
Location.input_name := inputfile;
let lexbuf = Lexing.from_channel ic in
Location.init lexbuf inputfile;
parse_fun lexbuf
end
with x -> close_in ic; raise x
in
close_in ic;
apply_rewriters ~restore:false ~tool_name ast_magic ast
let report_error ppf = function
| CannotRun cmd ->
fprintf ppf "Error while running external preprocessor@.\
Command line: %s@." cmd
| WrongMagic cmd ->
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_all ~tool_name parse_fun magic ppf sourcefile =
Location.input_name := sourcefile;
let inputfile = preprocess sourcefile in
let ast =
try file ppf ~tool_name inputfile parse_fun magic
with exn ->
remove_preprocessed inputfile;
raise exn
in
remove_preprocessed inputfile;
ast
let parse_implementation ppf ~tool_name sourcefile =
parse_all ~tool_name Parse.implementation
Config.ast_impl_magic_number ppf sourcefile
let parse_interface ppf ~tool_name sourcefile =
parse_all ~tool_name Parse.interface
Config.ast_intf_magic_number ppf sourcefile
|