Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 388 lines (351 sloc) 12.57 kb
fccc685 Initial open-source release
MLstate authored
1 (*
f4bd094 @OpaOnWindowsNow [fix] preprocessing,error: add file and line position
OpaOnWindowsNow authored
2 Copyright © 2011, 2012 MLstate
fccc685 Initial open-source release
MLstate authored
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 module StringMap = Map.Make(
19 struct
20 type t = string
21 let compare = String.compare
22 end)
23
24 (* Environment **********************************)
25 type env = string StringMap.t
26
27 let empty_env = StringMap.empty
28
29 let add_env = StringMap.add
30
31 let fill_with_sysenv t =
32 Array.fold_left
33 (fun t s ->
34 match Str.split (Str.regexp "=") s with
35 | var::values ->
36 let value = String.concat " " values in
37 add_env var value t
38 | _ -> assert false)
39 t (Unix.environment ())
40
41
42 (* Options **************************************)
43 type options = {
44 env : env;
45 output_suffix : string option (**Destination file*);
46 force_static : bool;
47 }
48
49 let default_options env = {
50 env = env;
51 output_suffix = None;
52 force_static = false;
53 }
54
55 (* Preprocess functions *************************)
56 exception PPParse_error of string
57
58 type lang_description = {
59 open_com : string;
60 close_com : string;
61 open_block : string;
62 close_block : string;
63 debug_module : string;
64 }
65
66 type cond =
67 | Test of string * string * string
68 | Set of string
69
70 (* Represent an if *)
71 type pp_if = {
72 cond : cond;
73 if_ : pp_expr list;
74 else_ : pp_expr list option;
75 }
76
77 (* Represent an pp expr *)
78 and pp_expr =
79 | Normal of string
80 | Ifstatic of pp_if
81 | If of pp_if
82
83 (* Print code *)
84 let print_code ?(doeval=false) ?(eval=fun _ -> true) description buf code =
85 let doeval = ref doeval in
86 let open_com ~comment =
87 if comment then Buffer.add_string buf description.open_com;
88 in
89 let close_com ~comment =
90 if comment then Buffer.add_string buf description.close_com in
91 let open_block () =
92 Buffer.add_string buf description.open_block in
93 let close_block () =
94 Buffer.add_string buf description.close_block in
95 let dmodule = description.debug_module in
96
97 let rec print_expr ~comment = function
98 | Normal x ->
99 open_com ~comment;
100 Buffer.add_string buf x;
101 close_com ~comment;
102 | Ifstatic if_ ->
103 open_com ~comment;
104 print_if ~comment `static if_;
105 close_com ~comment;
106 | If if_ ->
107 print_if ~comment `dyn if_;
108
109 and print_lexpr ~block ~comment l =
110 open_com ~comment;
111 if block then open_block ();
112 List.iter (print_expr ~comment:false) l;
113 if block then close_block ();
114 close_com ~comment
115
116 and print_if_cond ~comment s cond =
117 match s with
118 | `static ->
119 let str =
120 (match cond with
121 | Set c -> Printf.sprintf "#<Ifstatic:%s>" c
122 | Test (_, c1, c2) -> Printf.sprintf "#<Ifstatic:%s %s>" c1 c2) in
123 open_com ~comment;
124 Buffer.add_string buf str;
125 close_com ~comment;
126 | `dyn ->
127 let dyntest =
128 (match cond with
129 | Set c ->
130 Printf.sprintf " if (%s.default) %s.%s then " dmodule dmodule
131 (String.lowercase c);
132 | Test (t, c1, c2) ->
133 Printf.sprintf " if (%s.%s %s) %s.%s then " dmodule t c2 dmodule
134 (String.lowercase c1)) in
135 let pptest =
136 (match cond with
137 | Set c ->
138 Printf.sprintf "#<If:%s>" c;
139 | Test (t, c1, c2) ->
140 Printf.sprintf "#<If:%s$%s %s>" c1 t c2 ) in
141 open_com ~comment:!doeval;
142 Buffer.add_string buf pptest;
143 close_com ~comment:!doeval;
144 if !doeval then Buffer.add_string buf dyntest;
145
146 and print_if ~comment s if_ =
147 ignore (comment);
148 let evaluated = eval if_.cond in
149 print_if_cond ~comment:!doeval s if_.cond;
150 let sv = !doeval in
151 doeval := sv && evaluated;
152 print_lexpr ~block:(`static != s) ~comment:(if s = `static then sv && not evaluated else false) if_.if_;
153 doeval := sv && not evaluated;
154 (let comment = if s = `static then sv && evaluated else false in
155 match if_.else_ with
156 | Some else_ ->
157 if (s = `dyn) then Buffer.add_string buf " else ";
158 open_com ~comment:sv;
159 Buffer.add_string buf "#<Else>";
160 close_com ~comment:sv;
161 print_lexpr ~block:(s = `dyn) ~comment else_;
162 | None -> ());
163 doeval := sv;
164 open_com ~comment:!doeval;
165 Buffer.add_string buf "#<End>";
166 close_com ~comment:!doeval;
167 ()
168 in
169 print_lexpr ~block:false ~comment:false code
170
f4bd094 @OpaOnWindowsNow [fix] preprocessing,error: add file and line position
OpaOnWindowsNow authored
171 (* we avoid the dependency to libbase *)
172 let rec compute_line content pos pos_line line pos_max =
173 let len = min pos_max (String.length content) in
174 if pos < len then
175 if
176 content.[pos] = '\n' ||
177 content.[pos] = '\r' && ( ( (pos<len-1) && content.[pos+1]<>'\n' ) ||
178 ( (pos>1 ) && content.[pos-1]<>'\n' ) )
179 then
180 compute_line content (pos+1) (pos+1) (line+1) pos_max
181 else
182 compute_line content (pos+1) pos_line line pos_max
183 else
184 (line, pos-pos_line)
185
fccc685 Initial open-source release
MLstate authored
186 (* Parse a string *)
f4bd094 @OpaOnWindowsNow [fix] preprocessing,error: add file and line position
OpaOnWindowsNow authored
187 let parse filename content options =
188 let pp_pos remain =
189 let remain_size =
190 List.fold_left (fun acc e ->
191 match e with
192 | Str.Delim s | Str.Text s -> acc+String.length(s)
193 ) 0 remain
194 in
195 let pos_max = (String.length content) - remain_size in
196 let (line, pos) = compute_line content 0 0 0 pos_max in
197 Printf.sprintf "File \"%s\", line %d, character %d (%d:%d-%d:%d)" filename line pos line pos line pos
198 in
fccc685 Initial open-source release
MLstate authored
199 let set_debugvar, get_debugvar =
200 let dvar = ref None in
201 (fun str -> dvar := Some str),
202 (fun () ->
203 match !dvar with
204 | None -> failwith ("The debug variable doesn't exists")
205 | Some s -> s) in
206 let content =
207 Str.full_split (Str.regexp "#<[^<>]*>") content in
208
209 let if_regexp = Str.regexp "#<\\([^ :]*\\):\\([^>]*\\)>" in
210 let cond1_regexp = Str.regexp "\\([^ ]*\\)\\$\\([^ ]*\\) \\([^ ]*\\)" in
211 let cond2_regexp = Str.regexp "\\$\\([^ ]*\\) \\([^ ]*\\)" in
212 let cond3_regexp = Str.regexp "\\([^ ]*\\) \\([^ ]*\\)" in
213 let dvar_regexp = Str.regexp "#<Debugvar: *\\([^ ]*\\) *" in
214
f4bd094 @OpaOnWindowsNow [fix] preprocessing,error: add file and line position
OpaOnWindowsNow authored
215 let error i lst =
216 raise (PPParse_error (Format.sprintf "Error %s.\n%s" i (pp_pos lst)))
217 in
218 let unknown tag lst =
219 error ("Unknown preprocessing directive "^tag^" (authorized only #<{If,Ifstatic,Else,End}>)") lst
220 in
221
fccc685 Initial open-source release
MLstate authored
222 let rec aux (result, lst) =
223 match lst with
224 | Str.Delim "#<Else>"::_
225 | Str.Delim "#<End>"::_ -> (List.rev result), lst
226 | Str.Delim tag::queue ->
227 (try
228 if Str.string_match dvar_regexp tag 0 then (
229 set_debugvar (Str.matched_group 1 tag);
230 aux (result, queue)
231 ) else if tag = "#<If>" || Str.string_match if_regexp tag 0 then (
232 let typif_ =
233 if options.force_static then `static
234 else if tag = "#<If>" || Str.matched_group 1 tag = "If" then
235 `dyn
236 else if tag = "#<Ifstatic>" || Str.matched_group 1 tag = "Ifstatic" then
237 `static
f4bd094 @OpaOnWindowsNow [fix] preprocessing,error: add file and line position
OpaOnWindowsNow authored
238 else unknown tag lst
fccc685 Initial open-source release
MLstate authored
239 in
240 let cond =
241 if tag = "#<If>" || tag = "#<Ifstatic>"then(
242 Set (get_debugvar ())
243 )else
244 let cond = Str.matched_group 2 tag in
245 if Str.string_match cond1_regexp cond 0 then(
246 Test (Str.matched_group 2 cond,
247 Str.matched_group 1 cond,
248 Str.matched_group 3 cond)
249 )else if Str.string_match cond2_regexp cond 0 then(
250 Test (Str.matched_group 1 cond,
251 get_debugvar (),
252 Str.matched_group 2 cond)
253 )else if Str.string_match cond3_regexp cond 0 then(
254 Test ("",
255 Str.matched_group 1 cond,
256 Str.matched_group 2 cond)
257 )else(
258 Set cond)
259 in
260 let if_, queue = aux ([], queue) in
261 let else_, queue =
262 match queue with
263 | Str.Delim "#<Else>"::queue ->
264 let else_, queue = aux ([], queue) in
265 Some else_, queue
266 | _ -> None, queue in
267 (* End if *)
268 (match queue with
269 | Str.Delim "#<End>"::queue ->
270 let result =
271 let if_ = {cond = cond; if_ = if_; else_ = else_} in
272 (match typif_ with
273 |`static -> Ifstatic if_
274 |`dyn -> If if_)::result
275 in
276 aux (result, queue)
f4bd094 @OpaOnWindowsNow [fix] preprocessing,error: add file and line position
OpaOnWindowsNow authored
277 | _ -> error "Expected end" lst)
278 ) else unknown tag lst
fccc685 Initial open-source release
MLstate authored
279 with | PPParse_error _ -> aux (result, (Str.Text tag)::queue)
280 )
281
282 | Str.Text normal::queue ->
283 aux (Normal normal::result, queue)
284 | _ -> (List.rev result), lst
285 in match aux ([], content) with
286 | content, [] -> content
f4bd094 @OpaOnWindowsNow [fix] preprocessing,error: add file and line position
OpaOnWindowsNow authored
287 | _, (t::_ as lst) ->
fccc685 Initial open-source release
MLstate authored
288 (match t with
f4bd094 @OpaOnWindowsNow [fix] preprocessing,error: add file and line position
OpaOnWindowsNow authored
289 | Str.Delim _r
290 | Str.Text _r -> error "Unfinished parsing" lst)
fccc685 Initial open-source release
MLstate authored
291
292 (* Process *)
f4bd094 @OpaOnWindowsNow [fix] preprocessing,error: add file and line position
OpaOnWindowsNow authored
293 let process ~name description options content =
fccc685 Initial open-source release
MLstate authored
294 (* Parsing *)
f4bd094 @OpaOnWindowsNow [fix] preprocessing,error: add file and line position
OpaOnWindowsNow authored
295 let content = parse name content options in
fccc685 Initial open-source release
MLstate authored
296 (* Eval function *)
297 let eval cond =
298 try
299 match cond with
300 | Set name ->
301 StringMap.mem name options.env
302 | Test (_, name, value) ->
303 let v = StringMap.find name options.env in
304 v = value
305 with Not_found -> false in
306 (* Print and eval *)
307 let buf = Buffer.create 1024 in
308 print_code ~doeval:true ~eval description buf content;
309 Buffer.contents buf
310
311 (* Generic executable *)
312 module Exe = struct
313
314 let files = ref []
315
316 let options = ref (default_options StringMap.empty)
317
318 let speclist = [
319 ("--force-static",
320 Arg.Unit (fun() -> options := {!options with force_static = true}),
321 "Force all if to be static");
322 ("--output-suffix",
323 Arg.String (fun s -> options := {!options with output_suffix = Some s}),
324 "Output to files using the given suffix instead of stdout")
325 ]
326
9a4a8ee [enhance] help/manpages: global pass for improving help messages of Opa ...
Mathieu Baudet authored
327 let usage_msg = Printf.sprintf "%s: Simple preprocessor for the needs of the Opa compiler \nUsage: %s [options] <files>\n" Sys.argv.(0) Sys.argv.(0)
328
fccc685 Initial open-source release
MLstate authored
329 let parse () =
330 Arg.parse speclist
331 (fun file -> files := file::!files)
9a4a8ee [enhance] help/manpages: global pass for improving help messages of Opa ...
Mathieu Baudet authored
332 (usage_msg^"Options:")
fccc685 Initial open-source release
MLstate authored
333
334 (* Get a file content (cc from File) *)
335 let content f =
336 let stat = Unix.stat f in
337 match stat.Unix.st_kind with
338 | Unix.S_DIR -> failwith (Printf.sprintf "%S is a directory" f)
339 | Unix.S_LNK -> assert false (* stat goes through symbolic links *)
340 | Unix.S_CHR (* Character device *)
341 | Unix.S_BLK (* Block device *)
342 | Unix.S_FIFO (* Named pipe *)
343 | Unix.S_SOCK (* Socket *) ->
344 (* for these kind of files, the size information is meaningless *)
345 let ic = open_in_bin f in
346 let len = 10000 in
347 let str = String.create len in
348 let buf = Buffer.create 10000 in
349 let rec aux () =
350 let read = input ic str 0 len in
351 if read <> 0 then (
352 Buffer.add_substring buf str 0 read;
353 aux ()
354 ) in
355 aux ();
356 close_in ic;
357 Buffer.contents buf
358 | Unix.S_REG (* Regular file *) ->
359 let size = stat.Unix.st_size in
360 assert (size <= Sys.max_string_length) ;
361 let ic = open_in_bin f
362 and buf = String.create size in
363 really_input ic buf 0 size ;
364 close_in ic ;
365 buf
366
367 let run description =
368 parse ();
369 let options =
370 let options = !options in
371 { options with env = fill_with_sysenv options.env } in
372 let rec aux files =
373 match files with
374 | t::q ->
375 begin
f4bd094 @OpaOnWindowsNow [fix] preprocessing,error: add file and line position
OpaOnWindowsNow authored
376 let result = process ~name:t description options (content t) in
fccc685 Initial open-source release
MLstate authored
377 match options.output_suffix with
378 | None -> output_string stdout result
379 | Some s ->
380 let out = open_out (t^s) in
381 output_string out result;
382 close_out out;
383 aux q
384 end
385 | [] -> ()
386 in aux (List.rev !files)
387 end
Something went wrong with that request. Please try again.