blob: 4b2553f2724757bff93169a398d87b76fa0c0021 (
plain)
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
|
(***********************************************************************)
(* *)
(* 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
(* Optionally preprocess a source file *)
let preprocess sourcefile =
match !Clflags.preprocessor with
None -> sourcefile
| Some pp ->
let tmpfile = Filename.temp_file "ocamlpp" "" in
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 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 file ppf ~tool_name inputfile parse_fun 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
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
|
