package / ocaml-base-compiler.4.10.0 / driver / pparse.ml
231 lines | 7819 chars
1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 2002 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 open Format
17
18 type error =
19 | CannotRun of string
20 | WrongMagic of string
21
22 exception Error of error
23
24 (* Optionally preprocess a source file *)
25
26 let call_external_preprocessor sourcefile pp =
27 let tmpfile = Filename.temp_file "ocamlpp" "" in
28 let comm = Printf.sprintf "%s %s > %s"
29 pp (Filename.quote sourcefile) tmpfile
30 in
31 if Ccomp.command comm <> 0 then begin
32 Misc.remove_file tmpfile;
33 raise (Error (CannotRun comm));
34 end;
35 tmpfile
36
37 let preprocess sourcefile =
38 match !Clflags.preprocessor with
39 None -> sourcefile
40 | Some pp ->
41 Profile.record "-pp"
42 (call_external_preprocessor sourcefile) pp
43
44
45 let remove_preprocessed inputfile =
46 match !Clflags.preprocessor with
47 None -> ()
48 | Some _ -> Misc.remove_file inputfile
49
50 type 'a ast_kind =
51 | Structure : Parsetree.structure ast_kind
52 | Signature : Parsetree.signature ast_kind
53
54 let magic_of_kind : type a . a ast_kind -> string = function
55 | Structure -> Config.ast_impl_magic_number
56 | Signature -> Config.ast_intf_magic_number
57
58 (* Note: some of the functions here should go to Ast_mapper instead,
59 which would encapsulate the "binary AST" protocol. *)
60
61 let write_ast (type a) (kind : a ast_kind) fn (ast : a) =
62 let oc = open_out_bin fn in
63 output_string oc (magic_of_kind kind);
64 output_value oc (!Location.input_name : string);
65 output_value oc (ast : a);
66 close_out oc
67
68 let apply_rewriter kind fn_in ppx =
69 let magic = magic_of_kind kind in
70 let fn_out = Filename.temp_file "camlppx" "" in
71 let comm =
72 Printf.sprintf "%s %s %s" ppx (Filename.quote fn_in) (Filename.quote fn_out)
73 in
74 let ok = Ccomp.command comm = 0 in
75 Misc.remove_file fn_in;
76 if not ok then begin
77 Misc.remove_file fn_out;
78 raise (Error (CannotRun comm));
79 end;
80 if not (Sys.file_exists fn_out) then
81 raise (Error (WrongMagic comm));
82 (* check magic before passing to the next ppx *)
83 let ic = open_in_bin fn_out in
84 let buffer =
85 try really_input_string ic (String.length magic) with End_of_file -> "" in
86 close_in ic;
87 if buffer <> magic then begin
88 Misc.remove_file fn_out;
89 raise (Error (WrongMagic comm));
90 end;
91 fn_out
92
93 let read_ast (type a) (kind : a ast_kind) fn : a =
94 let ic = open_in_bin fn in
95 Misc.try_finally
96 ~always:(fun () -> close_in ic; Misc.remove_file fn)
97 (fun () ->
98 let magic = magic_of_kind kind in
99 let buffer = really_input_string ic (String.length magic) in
100 assert(buffer = magic); (* already checked by apply_rewriter *)
101 Location.input_name := (input_value ic : string);
102 (input_value ic : a)
103 )
104
105 let rewrite kind ppxs ast =
106 let fn = Filename.temp_file "camlppx" "" in
107 write_ast kind fn ast;
108 let fn = List.fold_left (apply_rewriter kind) fn (List.rev ppxs) in
109 read_ast kind fn
110
111 let apply_rewriters_str ?(restore = true) ~tool_name ast =
112 match !Clflags.all_ppx with
113 | [] -> ast
114 | ppxs ->
115 let ast =
116 ast
117 |> Ast_mapper.add_ppx_context_str ~tool_name
118 |> rewrite Structure ppxs
119 |> Ast_mapper.drop_ppx_context_str ~restore
120 in
121 Ast_invariants.structure ast; ast
122
123 let apply_rewriters_sig ?(restore = true) ~tool_name ast =
124 match !Clflags.all_ppx with
125 | [] -> ast
126 | ppxs ->
127 let ast =
128 ast
129 |> Ast_mapper.add_ppx_context_sig ~tool_name
130 |> rewrite Signature ppxs
131 |> Ast_mapper.drop_ppx_context_sig ~restore
132 in
133 Ast_invariants.signature ast; ast
134
135 let apply_rewriters ?restore ~tool_name
136 (type a) (kind : a ast_kind) (ast : a) : a =
137 match kind with
138 | Structure ->
139 apply_rewriters_str ?restore ~tool_name ast
140 | Signature ->
141 apply_rewriters_sig ?restore ~tool_name ast
142
143 (* Parse a file or get a dumped syntax tree from it *)
144
145 exception Outdated_version
146
147 let open_and_check_magic inputfile ast_magic =
148 let ic = open_in_bin inputfile in
149 let is_ast_file =
150 try
151 let buffer = really_input_string ic (String.length ast_magic) in
152 if buffer = ast_magic then true
153 else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
154 raise Outdated_version
155 else false
156 with
157 Outdated_version ->
158 Misc.fatal_error "OCaml and preprocessor have incompatible versions"
159 | _ -> false
160 in
161 (ic, is_ast_file)
162
163 let parse (type a) (kind : a ast_kind) lexbuf : a =
164 match kind with
165 | Structure -> Parse.implementation lexbuf
166 | Signature -> Parse.interface lexbuf
167
168 let file_aux ~tool_name inputfile (type a) parse_fun invariant_fun
169 (kind : a ast_kind) : a =
170 let ast_magic = magic_of_kind kind in
171 let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in
172 let ast =
173 try
174 if is_ast_file then begin
175 Location.input_name := (input_value ic : string);
176 if !Clflags.unsafe then
177 Location.prerr_warning (Location.in_file !Location.input_name)
178 Warnings.Unsafe_without_parsing;
179 let ast = (input_value ic : a) in
180 if !Clflags.all_ppx = [] then invariant_fun ast;
181 (* if all_ppx <> [], invariant_fun will be called by apply_rewriters *)
182 ast
183 end else begin
184 seek_in ic 0;
185 let lexbuf = Lexing.from_channel ic in
186 Location.init lexbuf inputfile;
187 Location.input_lexbuf := Some lexbuf;
188 Profile.record_call "parser" (fun () -> parse_fun lexbuf)
189 end
190 with x -> close_in ic; raise x
191 in
192 close_in ic;
193 Profile.record_call "-ppx" (fun () ->
194 apply_rewriters ~restore:false ~tool_name kind ast
195 )
196
197 let file ~tool_name inputfile parse_fun ast_kind =
198 file_aux ~tool_name inputfile parse_fun ignore ast_kind
199
200 let report_error ppf = function
201 | CannotRun cmd ->
202 fprintf ppf "Error while running external preprocessor@.\
203 Command line: %s@." cmd
204 | WrongMagic cmd ->
205 fprintf ppf "External preprocessor does not produce a valid file@.\
206 Command line: %s@." cmd
207
208 let () =
209 Location.register_error_of_exn
210 (function
211 | Error err -> Some (Location.error_of_printer_file report_error err)
212 | _ -> None
213 )
214
215 let parse_file ~tool_name invariant_fun parse kind sourcefile =
216 Location.input_name := sourcefile;
217 let inputfile = preprocess sourcefile in
218 Misc.try_finally
219 (fun () ->
220 Profile.record_call "parsing" @@ fun () ->
221 file_aux ~tool_name inputfile parse invariant_fun kind)
222 ~always:(fun () -> remove_preprocessed inputfile)
223
224 let parse_implementation ~tool_name sourcefile =
225 parse_file ~tool_name Ast_invariants.structure
226 (parse Structure) Structure sourcefile
227
228 let parse_interface ~tool_name sourcefile =
229 parse_file ~tool_name Ast_invariants.signature
230 (parse Signature) Signature sourcefile
231