Skip to content
Newer
Older
100644 791 lines (646 sloc) 24.1 KB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
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 (* Please cf mli first *)
19 (* todo: continue to hoist base *)
20 (* once Base is hoisted and clean enough, let's restart open Base *)
21 module String = Base.String
22 module List = Base.List
23 module Format = Base.Format
24 let (@**) f g x y = f (g x) (g y)
25
26 (* The map storing all possible conditions defined in WarningClass *)
27 let cond_map = ref StringMap.empty
28
29 (* The map storing all possible printers *)
30 let printer_map = ref StringMap.empty
31
32 (* The map storing all possible trackers *)
33 let tracker_map = ref StringMap.empty
34
35 (************************************************)
36 (* Options **************************************)
37 module Arg = struct
38 open Base
39 let split =
40 String.split (function ',' -> true | _ -> false)
41
42 let add_strs ?ids str set =
43 let () =
44 match ids with
45 | None -> (* no check are perform *) ()
46 | Some (name, help, possible) ->
47 if not (StringMap.mem str possible)
48 then
49 OManager.error (
50 "The %s @{<bright>%s@} is not defined !@\n"^^
51 "Check the list of available %s with the option @{<bright>%s@}@\n"^^
52 "%a"
53 )
54 name str
55 name help
56 (HintUtils.pp_suggestion (StringMap.keys possible)) str
57 in
58 match set with
59 | None -> None
60 | Some set ->
61 Some (List.fold_left
62 (fun set pass -> StringSet.add pass set)
63 set (split str))
64
65 (* Checks *************************************)
66 let checks = ref (Some StringSet.empty)
67
68 let check_all () = checks := None
69
70 let add_check_pass str = checks := add_strs str !checks
71
72 let add_check_conds str =
73 let ids = "condition", "--check-help", !cond_map in
74 checks := add_strs ~ids str !checks
75
76 (* Tracks *************************************)
77 (*
78 None means everything, <=> Some (infinity)
79 *)
80 let tracks = ref (Some StringSet.empty)
81
82 let track_all () = tracks := None
83
84 let add_tracker str =
85 let ids = "tracker", "--track-help", !tracker_map in
86 tracks := add_strs ~ids str !tracks
87
88 let add_track_pass str = tracks := add_strs str !tracks
89
90 (* Prints *************************************)
91 (*
92 None means everything, <=> Some (infinity)
93 *)
94 let prints = ref (Some StringSet.empty)
95
96 let print_all () = prints := None
97
98 let add_printer str =
99 let ids = "printer", "--print-help", !printer_map in
100 prints := add_strs ~ids str !prints
101
102 let add_print_pass str = prints := add_strs str !prints
103
104 (* Compilation shorcuts ***********************)
105 let marshals = ref (Some StringSet.empty)
106 let marshal_all () = marshals := None
107 let add_marshal_pass str = marshals := add_strs str !marshals
108 let unmarshal = ref None
109 let set_unmarshal s = unmarshal := Some s
110
111 (* Consistency ********************************)
112 let consistency = ref false
113
114 let check_consistency () = consistency := true
115
116 (* Helps **************************************)
117 let help_factory name map =
118 OManager.printf "List of available %ss :@\n" name ;
119 let _ =
120 StringMap.fold
121 (fun k _ a ->
122 OManager.printf "%s%s" a k;
123 ", ")
124 map "" in
125 OManager.printf "@\n";
126 exit 0
127
128 let help_checker () = help_factory "condition" !cond_map
129 let help_printer () = help_factory "printer" !printer_map
130 let help_tracker () = help_factory "tracker" !tracker_map
131
132 (* Options ************************************)
133 let (!>) = Format.sprintf
134
135 (* following guidelines about arguments, as in bslregister.ml, bslbrowser.ml *)
136 let options = [
137
138
139 (* c *)
140
141
142 "--check",
143 Arg.String add_check_conds,
144 "\"cond1,cond2,...\" Check all specified preconditions and postconditions" ;
145
146
147 "--check-all",
148 Arg.Unit check_all,
149 " Check all preconditions and postconditions on all passes" ;
150
151
152 "--check-consistency",
153 Arg.Unit check_consistency,
154 " Check if the pre/post conditions are consistent" ;
155
156
157 "--check-help",
158 Arg.Unit help_checker,
159 " Print the list of conditions" ;
160
161
162 "--check-pass",
163 Arg.String add_check_pass,
164 "\"pass1,pass2,...\" Check all preconditions and postconditions for specified passes" ;
165
166
167 (* m *)
168
169
170 "--marshal-all",
171 Arg.Unit marshal_all,
172 " Marshal all the environments" ;
173
174
175 "--marshal-pass",
176 Arg.String add_marshal_pass,
177 " Marshal the environment BEFORE the pass" ;
178
179
180 (* p *)
181
182
183 "--print",
184 Arg.String add_printer,
185 "\"prt1,prt2,...\" Print specified printer (like code,size,...)" ;
186
187
188 "--print-all",
189 Arg.Unit print_all,
190 " Print all printers on all passes" ;
191
192
193 "--print-pass",
194 Arg.String add_print_pass,
195 "\"pass1,pass2,...\" Print all printers at specified passes" ;
196
197
198 "--print-help",
199 Arg.Unit help_printer,
200 " Print the list of printers" ;
201
202
203 (* t *)
204
205 "--track",
206 Arg.String add_tracker,
207 "\"prt1,prt2,...\" Print specified tracker" ;
208
209
210 "--track-all",
211 Arg.Unit track_all,
212 " Track all passes" ;
213
214
215 "--track-dir",
216 Arg.String PassTracker.set_directory,
217 !>
218 "<dir> Specify the output directory for tracking (def is %s)" (PassTracker.get_directory ());
219
220
221 "--track-pass",
222 Arg.String add_track_pass,
223 "\"pass1,pass2,...\" Track specified passes" ;
224
225
226 "--track-help",
227 Arg.Unit help_tracker,
228 " Print the list of trackers" ;
229
230
231 (* u *)
232
233
234 "--unmarshal-pass",
235 Arg.String set_unmarshal,
236 " Read the previously marshalled environment to shortcut the compilation and go directly to the pass" ;
237 (* most useful to profile just one pass, and not the whole compiler *)
238
239
240 ]
241
242 end
243
244 (************************************************)
245 (* Environments *********************************)
246 type passname = string
247 type 'env printer = 'env PassTracker.printer
248 type 'env tracker = PassTracker.iter_tracker -> 'env -> unit
249
250 type printer_id = PassTracker.printer_id
251 type tracker_id = PassTracker.tracker_id
252
253 type ('opt, 'env) one_env = {
254 env : 'env;
255 options : 'opt;
256 printers : 'opt -> (printer_id * 'env printer) list;
257 trackers : 'opt -> (tracker_id * 'env tracker) list;
258 }
259
260 let make_env
261 ?(printers = fun _ -> [])
262 ?(trackers = fun _ -> [])
263 options env =
264 {
265 env = env;
266 options = options;
267 printers = printers;
268 trackers = trackers;
269 }
270
271 let title = ref "Pass"
272
273 let set_title ti = title := ti
274
275 module RegisterPrinter =
276 struct
277 let printers = ref []
278 let register printer = printers := Obj.magic printer :: !printers
279 let retrieve passname =
280 let rec aux = function
281 | [] -> fun _ -> []
282 | h :: t ->
283 match h passname with
284 | None -> aux t
285 | Some real_printer -> Obj.magic real_printer in
286 aux !printers
287 end
288
289 (************************************************)
290 (* Conditions ***********************************)
291 type cond_id = string
292 type 'env cond = cond_id * ('env -> unit)
293
294 let compose_fun_condition (f : 'a -> 'b) ( (cond_id, g) : 'b cond) : 'a cond =
295 (cond_id, (fun env -> g (f env)))
296
297 external cond_id : cond_id -> string = "%identity"
298
299 (* Internal exception, does not escape out of this module *)
300 exception CompilerInternalError of (cond_id option * string) HdList.t
301
302 (* Sometime for a checker it is more convenient to use an error function *)
303 exception CheckCondition
304
305 let _ =
306 Printexc.register_printer
307 (function
308 | CompilerInternalError hdl -> Some (
309 String.concat_map "\n\n\t"
310 (fun (id, msg) ->
311 match id with
312 | Some id -> Printf.sprintf "The condition '%s' is violated\n%s\n" id msg
313 | None -> msg)
314 (HdList.unwrap hdl)
315 )
316 | CheckCondition -> Some "CheckCondition"
317 | _ -> None)
318
319
320 let define_factory ?(uniq=true) name ref_map id elt =
321 if uniq && StringMap.mem id !ref_map
322 then
323 invalid_arg (Printf.sprintf "%s %s is already defined" name id)
324 else (
325 ref_map := StringMap.add id elt !ref_map ;
326 id
327 )
328
329 let define_cond wclass =
330 let cond_id = WarningClass.get_name wclass in
331 define_factory "Condition" cond_map cond_id wclass
332
333 let define_printer id = define_factory ~uniq:false "Printer" printer_map id ()
334 let define_tracker id = define_factory ~uniq:false "Tracker" tracker_map id ()
335
336 external printer_id : printer_id -> string = "%identity"
337 external tracker_id : tracker_id -> string = "%identity"
338
339 let make_condition name f = (name, f)
340
341 let compose_condition conds =
342 let name = fst (List.hd conds) in
343 make_condition name
344 (fun env ->
345 List.iter
346 (fun (n, f) ->
347 assert (n=name);
348 f env) conds)
349
350 let and_if lif =
351 fun ~options env ->
352 List.for_all (fun if_ -> if_ ~options env) lif
353
354 let or_if lif =
355 fun ~options env ->
356 List.exists (fun if_ -> if_ ~options env) lif
357
358 let check_condition env (_, check) =
359 check env
360
361 let check_cond env (name, check) =
362 OManager.printf "Checking condition : '@{<bright>%s@}'@\n" name;
363 try
364 check_condition env (name, check)
365 with
366 | CheckCondition -> ()
367 (*
368 The check_fail calls done by the checker has produced warnings.
369 If the warnings are activated, they have been printed already.
370 If the warnings are errors, exceptions has been caught already.
371 *)
372
373 let check_conds env conds = List.iter (check_cond env) conds
374
375 (************************************************)
376 (* Invariants ***********************************)
377 type ('env, 'env2) invariant = {
378 id : cond_id;
379 pre : 'env cond;
380 post : 'env2 cond;
381 }
382
383 let compose_fun_invariant f g i = {
384 id = i.id;
385 pre = compose_fun_condition f i.pre;
386 post = compose_fun_condition g i.post
387 }
388
389 let make_invariant cond1 cond2 =
390 if not ((fst cond1) = (fst cond2)) then
391 invalid_arg (
392 Printf.sprintf
393 "Try to make invariant with not equals conditions : %s != %s"
394 (fst cond1) (fst cond2)
395 )
396 else
397 {
398 id = (fst cond1);
399 pre = cond1;
400 post = cond2;
401 }
402
403 let make_cons_invariant cond = make_invariant cond cond
404
405 (************************************************)
406 (* Errors ***************************************)
407 (* support for multi errors: do not crash at the first error if possible *)
408 let pending_internal_errors = ref []
409 let push_internal_error ie = pending_internal_errors := ie :: !pending_internal_errors
410 let raise_internal_error ie =
411 let all = ie :: !pending_internal_errors in
412 pending_internal_errors := [];
413 raise (CompilerInternalError (HdList.wrap (List.rev all)))
414 let flush_internal_errors () =
415 match !pending_internal_errors with
416 | [] -> ()
417 | ies ->
418 pending_internal_errors := [];
419 raise (CompilerInternalError (HdList.wrap (List.rev ies)))
420
421 let sinternal_error cont printer cond_id context fmt =
422 let k message =
423 let printer oc context =
424 Format.fprintf oc "@{<red>Internal Error@}@\n%a@\n%s@\n" printer context message in
425 (* Do not print everything, the function handler does thing too *)
426 (* By having some code there, we can print the context is the file system *)
427 (* (if not, the Exception should have a type variable in its type !) *)
428 PassTracker.internal ~filename:(Option.default "internal_error" cond_id) printer context;
429 let message = Format.sprintf "%a" printer context in
430 push_internal_error (cond_id, message);
431 cont ()
432 in
433 Format.ksprintf k fmt
434
435 let scond_violation printer cond_id = sinternal_error ignore printer (Some cond_id)
436 let i_serror p = sinternal_error ignore p
437
438 let internal_error p =
439 let k _ = flush_internal_errors (); assert false (* will necessarly do a raise during sinternal_error *) in
440 sinternal_error k p
441
442 let cond_violation printer cond_id = internal_error printer (Some cond_id)
443 let i_error = internal_error
444
445 let cont_check_fail cont ~full:full_printer ~console:reduced_printer cond_id context fmt =
446 let k message =
447 let full_printer oc context =
448 Format.fprintf oc "@{<red>Check Failed@}: %s@\n%a@[<2>@\n%s@]@\n" cond_id full_printer context message in
449 let wclass =
450 match StringMap.find_opt cond_id !cond_map with
451 | None -> assert false (* all cond_id are create by using define_cond *)
452 | Some wclass -> wclass in
453 OManager.printf "@{<red>Internal Error@}, a condition check is broken: '@{<bright>%s@}'@\n" cond_id;
454 OManager.printf "The full context is being stored (opatrack) ...@.";
455 PassTracker.check_fail ~filename:cond_id full_printer context;
456 OManager.printf "Here is a reduced context (use opatrack for full context):@\n";
457 reduced_printer OManager.oformatter.contents context;
458 OManager.warning ~wclass "%s" message ;
459 cont ()
460 in
461 Format.ksprintf k fmt
462
463 let scheck_fail ~full = cont_check_fail ignore ~full
464 let check_fail ~full = cont_check_fail (fun _ -> raise CheckCondition) ~full
465
466 (************************************************)
467 (* Passes & Handlers ****************************)
468 type ('opt, 'opt2, 'env, 'env2) pass = {
469 invariant : ('env, 'env2) invariant list;
470 precond : 'env cond list;
471 postcond : 'env2 cond list;
472 f : ('opt, 'env) one_env -> ('opt2, 'env2) one_env;
473 }
474
475 type ('opt, 'env, 'env2) old_pass = options:'opt -> 'env -> 'env2
476
477 let make_pass ?(invariant = []) ?(precond=[]) ?(postcond=[]) f = {
478 f = f;
479 invariant = invariant;
480 precond = precond;
481 postcond = postcond;
482 }
483
484 let init = make_env () ()
485
486 (* New handlers *********************************)
487
488 (* Current conditions, used for check consistency *)
489 let current_conds = ref StringSet.empty
490
491 (* Keep in mind post cond of prev pass *)
492 let prev_post_cond = ref StringSet.empty
493
494 let handler ?(count_time=true) passname pass env =
495 (* common filter for conds and prints *)
496 let common_filter set list =
497 match set with
498 | None -> list
499 | Some set ->
500 if StringSet.mem passname set then list
501 else List.filter
502 (fun (str, _) ->
503 (StringSet.mem str set)
504 || StringSet.exists (fun elt -> String.is_prefix elt str) set)
505 list in
506
507 (* Keep in mind what is checked *)
508 let checked_conds = Hashtbl.create 32 in
509
510 (* checks conditions to check *)
511 let perform_conds str env conds =
512 let conds = common_filter !Arg.checks conds in
513 if conds != [] then (
514 List.iter (fun (id, _) -> Hashtbl.add checked_conds id ()) conds;
515 OManager.printf "%sconditions check.@\n" str;
516 check_conds env.env conds
517 ) else () in
518
519 (* extra print env *)
520 let perform_print env =
521 let printers = common_filter !Arg.prints (env.printers env.options) in
522 List.iter
523 (fun (printer_id, printer) ->
524 PassTracker.print ~passname ~printer_id printer env.env)
525 printers
526 in
527
528 (* track pass *)
529 let perform_track env =
530 let trackers = common_filter !Arg.tracks (env.trackers env.options) in
531 List.iter
532 (fun (tracker_id, tracker) ->
533 PassTracker.track ~passname ~tracker_id tracker env.env)
534 trackers
535 in
536
537 (* Get invariant to check *)
538 let get_invariants =
539 let inv =
540 ref (
541 List.filter
542 (fun iv -> StringSet.mem iv.id !prev_post_cond)
543 pass.invariant)
544 in fun _ -> !inv
545 in
546
547 (* Checking invariant on input env - Maybe useless but two check
548 worth better than one...*)
549 let pre_perform_invariant env =
550 let ivs = List.map (fun iv -> iv.pre) (get_invariants ()) in
551 let ivs = common_filter !Arg.checks ivs in
552 if ivs != [] then (
553 OManager.printf "Preinvariants check.@\n";
554 check_conds env.env ivs
555 ) else ()
556 in
557
558 (* Checking invariant on output env *)
559 let post_perform_invariant env =
560 let ivs = List.map (fun iv -> iv.post) (get_invariants ()) in
561 let ivs = common_filter !Arg.checks ivs in
562 if ivs != [] then (
563 OManager.printf "Postinvariants check.@\n";
564 check_conds env.env ivs
565 ) else ();
566 prev_post_cond :=
567 List.fold_left (fun a (id, _) -> StringSet.add id a)
568 StringSet.empty pass.postcond;
569 prev_post_cond :=
570 List.fold_left (fun a (id, _) -> StringSet.add id a)
571 !prev_post_cond ivs
572 in
573
574 (* Check consistency *)
575 let consistency () =
576 if !Arg.consistency then
577 let unconsistent =
578 List.filter
579 (fun (id, _) -> not (StringSet.mem id !current_conds))
580 pass.precond in
581 if unconsistent != [] then
582 OManager.warning ~wclass:WarningClass.phandler_consistency
583 "The following conditions are inconsistent : %s"
584 (fst
585 (List.fold_left
586 (fun (s, p) (id, _) ->
587 (Printf.sprintf "%s%s%s" s p id), ", ")
588 ("", "") unconsistent
589 ));
590 current_conds :=
591 StringSet.filter
592 (fun id -> not (List.exists (fun iv -> iv.id = id) pass.invariant))
593 !current_conds;
594 current_conds :=
595 List.fold_left
596 (fun acc pcond -> StringSet.add (fst pcond) acc)
597 !current_conds
598 pass.postcond;
599 in
600
601 (* Store passname for tracking specific interal logs *)
602 PassTracker.set_current_passname passname;
603
604 let run =
605 match !Arg.unmarshal with
606 | Some passname' when passname = passname' ->
607 (* loading the environment from the disk *)
608 OManager.verbose "%s: unmarshalling env for @{<bright>%s@}" !title passname;
609 let env,options = PassTracker.unmarshal ~passname in
610 let printers = RegisterPrinter.retrieve passname in
611 `run ({env = env; options=options; printers=printers; trackers = (fun _ -> [])})
612 | Some _ ->
613 (* we are loading one pass, but not this one *)
614 `skip
615 | None ->
616 (* normal compilation *)
617 (match !Arg.marshals with
618 | None -> PassTracker.marshal ~passname (env.env,env.options)
619 | Some set ->
620 if StringSet.mem passname set then
621 PassTracker.marshal ~passname (env.env,env.options));
622 `run env in
623
624 match run with
625 | `skip ->
626 OManager.verbose "%s: skipping @{<bright>%s@}" !title passname;
627 Obj.magic env
628 | `run env -> (
629
630 (* Pre traitment *)
631 if not BuildInfos.is_release && not (passname = "") then
632 OManager.verbose "%s: %s" !title passname;
633 consistency ();
634 pre_perform_invariant env;
635 perform_conds "Pre" env pass.precond;
636 OManager.flush_errors ();
637
638 (* Pass *)
639 let chrono = Chrono.make () in
640 Chrono.start chrono;
641 let env2 =
642 let save_bck, get_bck =
643 let bck = ref "No backtrace" in
644 ((fun () -> bck := (Printexc.get_backtrace ())),
645 (fun _ -> !bck)) in
646 try (
647 try let env = pass.f env in flush_internal_errors (); env with
648 | (CompilerInternalError internal_errors) as e ->
649 save_bck ();
650 let internal_errors = HdList.unwrap internal_errors in
651 OManager.printf "An internal error has occurred@\n";
652 List.iter
653 (function (_, msg) ->
654 OManager.printf "Message:@\n@{<magenta>%s@}@\n" msg) internal_errors;
655 let internal_errors = List.uniq_unsorted ~cmp:(Pervasives.compare @** fst) internal_errors in
656 List.iter (fun (id, _) ->
657 begin
658 match id with
659 | Some id ->
660 OManager.printf (
661 "The condition '@{<bright>%s@}' has been declared violated by @{<bright>%s@}@\n"
662 ) id passname;
663 (match List.find_opt (fun (s , _) -> id = s ) pass.precond with
664 | None ->
665 OManager.printf "'@{<bright>%s@}' is not a precondition of '@{<bright>%s@}'@\n This pass is incoherent !!@\n" id passname
666 | Some precond ->
667 let is_warn_error = Option.default_map false (fun w -> WarningClass.is_warn w && WarningClass.is_warn_error w)
668 (StringMap.find_opt id !cond_map) in
669 let fatal_inconsistency () = OManager.printf (
670 "No error during the execution of the condition checker.@\n"^^
671 "The corresponding '@{<bright>--warn-error @{<red>%s@}@}' was activated.@\n"^^
672 "@{<red>FATAL INCONSISTENCY !@}@\n"^^
673 "@[<2>@{<bright>Hint@}:@\nPlease fix the coherence between the check impl., the pass impl., and the cond semantic.@]@\n" )
674 id
675 in
676 if Hashtbl.mem checked_conds id
677 then
678 begin
679 OManager.printf "'%s' has already been tested as precondition of pass '%s'@\n" id passname;
680 if is_warn_error
681 then fatal_inconsistency ()
682 end
683 else
684 begin
685 OManager.printf "Checking %s@\n" id;
686 check_cond env.env precond;
687 if is_warn_error && not (List.exists (fun w -> String.compare id (WarningClass.get_name w) = 0) (OManager.warn_error_status ()))
688 then fatal_inconsistency ()
689 end
690 )
691 | None -> ()
692 end;
693 ) internal_errors;
694 raise e
695 | e ->
696 save_bck ();
697 OManager.serror "An internal error has occurred during the pass @{<bright>%s@}" passname;
698 raise e )
699 with
700 | e ->
701 (* Print all that is possible - TODO add the possibility to
702 make filter *)
703 (match e with CompilerInternalError _ -> () | _ -> OManager.printf "@[<2>Uncaught Exception:@\n@{<magenta>%s@}@]@\n" (Printexc.to_string e));
704 OManager.printf "@[<2>Backtrace:@\n%s@]@\n" (get_bck ());
705 PassTracker.internal ~filename:"backtrace" (fun fmt _ -> Format.fprintf fmt "%s@\nBacktrace:\n%s@\n" (Printexc.to_string e) (get_bck ())) ();
706 OManager.printf "Saving the current environment for report (opatrack) ...@.";
707 Arg.prints := None;
708 perform_print env;
709 Arg.tracks := None;
710 perform_track env;
711 OManager.flush_errors ();
712 exit 1
713 in
714 Chrono.stop chrono;
715 let c = Chrono.read chrono in
716 let () =
717 if not BuildInfos.is_release && count_time then PassTracker.time ~passname c
718 in
719
720 (* Post traitment *)
721 perform_print env2;
722 perform_track env2;
723 post_perform_invariant env2;
724 perform_conds "Post" env2 pass.postcond;
725 OManager.flush_errors ();
726 #<If:TESTING> ()
727 #<Else>
728 if not BuildInfos.is_release && count_time && c > 0.2 then
729 OManager.verbose "duration %s" (Date.pretty_duration c)
730 #<End>;
731 env2
732 )
733
734 let (|+>) env (passname, pass) = handler passname pass env
735
736 let if_handler
737 ?(if_ = fun ~options:_ _ -> true)
738 name pass env =
739 if if_ ~options:env.options env.env then
740 handler name pass env
741 else env
742
743 let (|?>) env (if_, passname, pass) =
744 if_handler ~if_ passname pass env
745
746 let alt_handler if_ (name1, pass1) (name2, pass2) env =
747 if if_ ~options:env.options env.env then
748 handler name1 pass1 env
749 else
750 handler name2 pass2 env
751
752 let (<?>) env (if_, (name1, pass1), (name2, pass2)) =
753 alt_handler if_ (name1, pass1) (name2, pass2) env
754
755 let return env = env.env
756
757 let (|>) = InfixOperator.(|>)
758
759 let register_printer = RegisterPrinter.register
760
761 (* Old handlers *********************************)
762 let old_if_handler
763 ?(if_ = fun ~options:_ _ -> true)
764 ?(precond = []) ?(postcond = [])
765 name pass env =
766 if if_ ~options:env.options env.env then
767 let pass =
768 make_pass ~precond ~postcond
769 (fun env ->
770 { env with
771 env = pass ~options:env.options env.env })
772 in
773 handler name pass env
774 else env
775
776 (* This handler should be no used because create env with default
777 printer... *)
778 let old_handler
779 ?(precond = []) ?(postcond = [])
780 name pass env =
781 let pass =
782 make_pass ~precond ~postcond
783 (fun e ->
784 make_env e.options (pass ~options:e.options e.env)) in
785 handler name pass env
786
787
788 let (&) if1 if2 = fun ~options env -> if1 ~options env && if2 ~options env
789 let (or) if1 if2 = fun ~options env -> if1 ~options env || if2 ~options env
790 let neg if_ = fun ~options env -> not (if_ ~options env)
Something went wrong with that request. Please try again.