forked from alokmenghrajani/opalang
-
Notifications
You must be signed in to change notification settings - Fork 0
/
pprocess.ml
356 lines (323 loc) · 11.1 KB
/
pprocess.ml
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
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
module StringMap = Map.Make(
struct
type t = string
let compare = String.compare
end)
(* Environment **********************************)
type env = string StringMap.t
let empty_env = StringMap.empty
let add_env = StringMap.add
let fill_with_sysenv t =
Array.fold_left
(fun t s ->
match Str.split (Str.regexp "=") s with
| var::values ->
let value = String.concat " " values in
add_env var value t
| _ -> assert false)
t (Unix.environment ())
(* Options **************************************)
type options = {
env : env;
output_suffix : string option (**Destination file*);
force_static : bool;
}
let default_options env = {
env = env;
output_suffix = None;
force_static = false;
}
(* Preprocess functions *************************)
exception PPParse_error of string
type lang_description = {
open_com : string;
close_com : string;
open_block : string;
close_block : string;
debug_module : string;
}
type cond =
| Test of string * string * string
| Set of string
(* Represent an if *)
type pp_if = {
cond : cond;
if_ : pp_expr list;
else_ : pp_expr list option;
}
(* Represent an pp expr *)
and pp_expr =
| Normal of string
| Ifstatic of pp_if
| If of pp_if
(* Print code *)
let print_code ?(doeval=false) ?(eval=fun _ -> true) description buf code =
let doeval = ref doeval in
let open_com ~comment =
if comment then Buffer.add_string buf description.open_com;
in
let close_com ~comment =
if comment then Buffer.add_string buf description.close_com in
let open_block () =
Buffer.add_string buf description.open_block in
let close_block () =
Buffer.add_string buf description.close_block in
let dmodule = description.debug_module in
let rec print_expr ~comment = function
| Normal x ->
open_com ~comment;
Buffer.add_string buf x;
close_com ~comment;
| Ifstatic if_ ->
open_com ~comment;
print_if ~comment `static if_;
close_com ~comment;
| If if_ ->
print_if ~comment `dyn if_;
and print_lexpr ~block ~comment l =
open_com ~comment;
if block then open_block ();
List.iter (print_expr ~comment:false) l;
if block then close_block ();
close_com ~comment
and print_if_cond ~comment s cond =
match s with
| `static ->
let str =
(match cond with
| Set c -> Printf.sprintf "#<Ifstatic:%s>" c
| Test (_, c1, c2) -> Printf.sprintf "#<Ifstatic:%s %s>" c1 c2) in
open_com ~comment;
Buffer.add_string buf str;
close_com ~comment;
| `dyn ->
let dyntest =
(match cond with
| Set c ->
Printf.sprintf " if (%s.default) %s.%s then " dmodule dmodule
(String.lowercase c);
| Test (t, c1, c2) ->
Printf.sprintf " if (%s.%s %s) %s.%s then " dmodule t c2 dmodule
(String.lowercase c1)) in
let pptest =
(match cond with
| Set c ->
Printf.sprintf "#<If:%s>" c;
| Test (t, c1, c2) ->
Printf.sprintf "#<If:%s$%s %s>" c1 t c2 ) in
open_com ~comment:!doeval;
Buffer.add_string buf pptest;
close_com ~comment:!doeval;
if !doeval then Buffer.add_string buf dyntest;
and print_if ~comment s if_ =
ignore (comment);
let evaluated = eval if_.cond in
print_if_cond ~comment:!doeval s if_.cond;
let sv = !doeval in
doeval := sv && evaluated;
print_lexpr ~block:(`static != s) ~comment:(if s = `static then sv && not evaluated else false) if_.if_;
doeval := sv && not evaluated;
(let comment = if s = `static then sv && evaluated else false in
match if_.else_ with
| Some else_ ->
if (s = `dyn) then Buffer.add_string buf " else ";
open_com ~comment:sv;
Buffer.add_string buf "#<Else>";
close_com ~comment:sv;
print_lexpr ~block:(s = `dyn) ~comment else_;
| None -> ());
doeval := sv;
open_com ~comment:!doeval;
Buffer.add_string buf "#<End>";
close_com ~comment:!doeval;
()
in
print_lexpr ~block:false ~comment:false code
(* Parse a string *)
let parse content options =
let set_debugvar, get_debugvar =
let dvar = ref None in
(fun str -> dvar := Some str),
(fun () ->
match !dvar with
| None -> failwith ("The debug variable doesn't exists")
| Some s -> s) in
let content =
Str.full_split (Str.regexp "#<[^<>]*>") content in
let if_regexp = Str.regexp "#<\\([^ :]*\\):\\([^>]*\\)>" in
let cond1_regexp = Str.regexp "\\([^ ]*\\)\\$\\([^ ]*\\) \\([^ ]*\\)" in
let cond2_regexp = Str.regexp "\\$\\([^ ]*\\) \\([^ ]*\\)" in
let cond3_regexp = Str.regexp "\\([^ ]*\\) \\([^ ]*\\)" in
let dvar_regexp = Str.regexp "#<Debugvar: *\\([^ ]*\\) *" in
let rec aux (result, lst) =
match lst with
| Str.Delim "#<Else>"::_
| Str.Delim "#<End>"::_ -> (List.rev result), lst
| Str.Delim tag::queue ->
(try
let error i =
raise (PPParse_error
(Printf.sprintf "Error (%d) on pptag \"%s\" : Bad formatted" i tag))
in
if Str.string_match dvar_regexp tag 0 then (
set_debugvar (Str.matched_group 1 tag);
aux (result, queue)
) else if tag = "#<If>" || Str.string_match if_regexp tag 0 then (
let typif_ =
if options.force_static then `static
else if tag = "#<If>" || Str.matched_group 1 tag = "If" then
`dyn
else if tag = "#<Ifstatic>" || Str.matched_group 1 tag = "Ifstatic" then
`static
else error 1
in
let cond =
if tag = "#<If>" || tag = "#<Ifstatic>"then(
Set (get_debugvar ())
)else
let cond = Str.matched_group 2 tag in
if Str.string_match cond1_regexp cond 0 then(
Test (Str.matched_group 2 cond,
Str.matched_group 1 cond,
Str.matched_group 3 cond)
)else if Str.string_match cond2_regexp cond 0 then(
Test (Str.matched_group 1 cond,
get_debugvar (),
Str.matched_group 2 cond)
)else if Str.string_match cond3_regexp cond 0 then(
Test ("",
Str.matched_group 1 cond,
Str.matched_group 2 cond)
)else(
Set cond)
in
let if_, queue = aux ([], queue) in
let else_, queue =
match queue with
| Str.Delim "#<Else>"::queue ->
let else_, queue = aux ([], queue) in
Some else_, queue
| _ -> None, queue in
(* End if *)
(match queue with
| Str.Delim "#<End>"::queue ->
let result =
let if_ = {cond = cond; if_ = if_; else_ = else_} in
(match typif_ with
|`static -> Ifstatic if_
|`dyn -> If if_)::result
in
aux (result, queue)
| _ -> failwith ("Error expected end"))
) else error 2
with | PPParse_error _ -> aux (result, (Str.Text tag)::queue)
)
| Str.Text normal::queue ->
aux (Normal normal::result, queue)
| _ -> (List.rev result), lst
in match aux ([], content) with
| content, [] -> content
| _, t::_ ->
(match t with
| Str.Delim r
| Str.Text r -> failwith (Printf.sprintf "Error on \"%s\"" r))
(* Process *)
let process description options content =
(* Parsing *)
let content = parse content options in
(* Eval function *)
let eval cond =
try
match cond with
| Set name ->
StringMap.mem name options.env
| Test (_, name, value) ->
let v = StringMap.find name options.env in
v = value
with Not_found -> false in
(* Print and eval *)
let buf = Buffer.create 1024 in
print_code ~doeval:true ~eval description buf content;
Buffer.contents buf
(* Generic executable *)
module Exe = struct
let files = ref []
let options = ref (default_options StringMap.empty)
let speclist = [
("--force-static",
Arg.Unit (fun() -> options := {!options with force_static = true}),
"Force all if to be static");
("--output-suffix",
Arg.String (fun s -> options := {!options with output_suffix = Some s}),
"Output to files using the given suffix instead of stdout")
]
let parse () =
Arg.parse speclist
(fun file -> files := file::!files)
"pprocess"
(* Get a file content (cc from File) *)
let content f =
let stat = Unix.stat f in
match stat.Unix.st_kind with
| Unix.S_DIR -> failwith (Printf.sprintf "%S is a directory" f)
| Unix.S_LNK -> assert false (* stat goes through symbolic links *)
| Unix.S_CHR (* Character device *)
| Unix.S_BLK (* Block device *)
| Unix.S_FIFO (* Named pipe *)
| Unix.S_SOCK (* Socket *) ->
(* for these kind of files, the size information is meaningless *)
let ic = open_in_bin f in
let len = 10000 in
let str = String.create len in
let buf = Buffer.create 10000 in
let rec aux () =
let read = input ic str 0 len in
if read <> 0 then (
Buffer.add_substring buf str 0 read;
aux ()
) in
aux ();
close_in ic;
Buffer.contents buf
| Unix.S_REG (* Regular file *) ->
let size = stat.Unix.st_size in
assert (size <= Sys.max_string_length) ;
let ic = open_in_bin f
and buf = String.create size in
really_input ic buf 0 size ;
close_in ic ;
buf
let run description =
parse ();
let options =
let options = !options in
{ options with env = fill_with_sysenv options.env } in
let rec aux files =
match files with
| t::q ->
begin
let result = process description options (content t) in
match options.output_suffix with
| None -> output_string stdout result
| Some s ->
let out = open_out (t^s) in
output_string out result;
close_out out;
aux q
end
| [] -> ()
in aux (List.rev !files)
end