-
Notifications
You must be signed in to change notification settings - Fork 465
/
Copy pathbspp.ml
10063 lines (8887 loc) · 375 KB
/
bspp.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
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
module Config_whole_compiler : sig
#1 "config_whole_compiler.mli"
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* System configuration *)
val version: string
(* The current version number of the system *)
val standard_library: string
(* The directory containing the standard libraries *)
val standard_runtime: string
(* The full path to the standard bytecode interpreter ocamlrun *)
val ccomp_type: string
(* The "kind" of the C compiler, assembler and linker used: one of
"cc" (for Unix-style C compilers)
"msvc" (for Microsoft Visual C++ and MASM) *)
val c_compiler: string
(* The compiler to use for compiling C files *)
val c_output_obj: string
(* Name of the option of the C compiler for specifying the output file *)
val ocamlc_cflags : string
(* The flags ocamlc should pass to the C compiler *)
val ocamlc_cppflags : string
(* The flags ocamlc should pass to the C preprocessor *)
val ocamlopt_cflags : string
(* The flags ocamlopt should pass to the C compiler *)
val ocamlopt_cppflags : string
(* The flags ocamlopt should pass to the C preprocessor *)
val bytecomp_c_libraries: string
(* The C libraries to link with custom runtimes *)
val native_c_libraries: string
(* The C libraries to link with native-code programs *)
val native_pack_linker: string
(* The linker to use for packaging (ocamlopt -pack) and for partial
links (ocamlopt -output-obj). *)
val mkdll: string
(* The linker command line to build dynamic libraries. *)
val mkexe: string
(* The linker command line to build executables. *)
val mkmaindll: string
(* The linker command line to build main programs as dlls. *)
val ranlib: string
(* Command to randomize a library, or "" if not needed *)
val ar: string
(* Name of the ar command, or "" if not needed (MSVC) *)
val cc_profile : string
(* The command line option to the C compiler to enable profiling. *)
val load_path: string list ref
(* Directories in the search path for .cmi and .cmo files *)
val interface_suffix: string ref
(* Suffix for interface file names *)
val exec_magic_number: string
(* Magic number for bytecode executable files *)
val cmi_magic_number: string
(* Magic number for compiled interface files *)
val cmo_magic_number: string
(* Magic number for object bytecode files *)
val cma_magic_number: string
(* Magic number for archive files *)
val cmx_magic_number: string
(* Magic number for compilation unit descriptions *)
val cmxa_magic_number: string
(* Magic number for libraries of compilation unit descriptions *)
val ast_intf_magic_number: string
(* Magic number for file holding an interface syntax tree *)
val ast_impl_magic_number: string
(* Magic number for file holding an implementation syntax tree *)
val cmxs_magic_number: string
(* Magic number for dynamically-loadable plugins *)
val cmt_magic_number: string
(* Magic number for compiled interface files *)
val max_tag: int
(* Biggest tag that can be stored in the header of a regular block. *)
val lazy_tag : int
(* Normally the same as Obj.lazy_tag. Separate definition because
of technical reasons for bootstrapping. *)
val max_young_wosize: int
(* Maximal size of arrays that are directly allocated in the
minor heap *)
val stack_threshold: int
(* Size in words of safe area at bottom of VM stack,
see byterun/config.h *)
val stack_safety_margin: int
(* Size in words of the safety margin between the bottom of
the stack and the stack pointer. This margin can be used by
intermediate computations of some instructions, or the event
handler. *)
val architecture: string
(* Name of processor type for the native-code compiler *)
val model: string
(* Name of processor submodel for the native-code compiler *)
val system: string
(* Name of operating system for the native-code compiler *)
val asm: string
(* The assembler (and flags) to use for assembling
ocamlopt-generated code. *)
val asm_cfi_supported: bool
(* Whether assembler understands CFI directives *)
val with_frame_pointers : bool
(* Whether assembler should maintain frame pointers *)
val ext_obj: string
(* Extension for object files, e.g. [.o] under Unix. *)
val ext_asm: string
(* Extension for assembler files, e.g. [.s] under Unix. *)
val ext_lib: string
(* Extension for library files, e.g. [.a] under Unix. *)
val ext_dll: string
(* Extension for dynamically-loaded libraries, e.g. [.so] under Unix.*)
val default_executable_name: string
(* Name of executable produced by linking if none is given with -o,
e.g. [a.out] under Unix. *)
val systhread_supported : bool
(* Whether the system thread library is implemented *)
val flexdll_dirs : string list
(* Directories needed for the FlexDLL objects *)
val host : string
(* Whether the compiler is a cross-compiler *)
val target : string
(* Whether the compiler is a cross-compiler *)
val print_config : out_channel -> unit;;
val profiling : bool
(* Whether profiling with gprof is supported on this platform *)
val flambda : bool
(* Whether the compiler was configured for flambda *)
val spacetime : bool
(* Whether the compiler was configured for Spacetime profiling *)
val enable_call_counts : bool
(* Whether call counts are to be available when Spacetime profiling *)
val profinfo : bool
(* Whether the compiler was configured for profiling *)
val profinfo_width : int
(* How many bits are to be used in values' headers for profiling
information *)
val libunwind_available : bool
(* Whether the libunwind library is available on the target *)
val libunwind_link_flags : string
(* Linker flags to use libunwind *)
val safe_string: bool
(* Whether the compiler was configured with -force-safe-string;
in that case, the -unsafe-string compile-time option is unavailable
@since 4.05.0 *)
val default_safe_string: bool
(* Whether the compiler was configured to use the -safe-string
or -unsafe-string compile-time option by default.
@since 4.06.0 *)
val flat_float_array : bool
(* Whether the compiler and runtime automagically flatten float
arrays *)
val windows_unicode: bool
(* Whether Windows Unicode runtime is enabled *)
val afl_instrument : bool
(* Whether afl-fuzz instrumentation is generated by default *)
end = struct
#1 "config_whole_compiler.ml"
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* The main OCaml version string has moved to ../VERSION *)
let version = "4.06.1+BS"
let standard_library =
Filename.concat (Filename.dirname Sys.executable_name) "ocaml"
let standard_library_default = standard_library
let standard_runtime = "ocamlrun" (*dont care:path to ocamlrun*)
let ccomp_type = "cc"
let c_compiler = "gcc"
let c_output_obj = "-o "
let ocamlc_cflags = "-O2 -fno-strict-aliasing -fwrapv "
let ocamlc_cppflags = "-D_FILE_OFFSET_BITS=64 -D_REENTRANT"
let ocamlopt_cflags = "-O2 -fno-strict-aliasing -fwrapv"
let ocamlopt_cppflags = "-D_FILE_OFFSET_BITS=64 -D_REENTRANT"
let bytecomp_c_libraries = "-lcurses -lpthread "
(* bytecomp_c_compiler and native_c_compiler have been supported for a
long time and are retained for backwards compatibility.
For programs that don't need compatibility with older OCaml releases
the recommended approach is to use the constituent variables
c_compiler, ocamlc_cflags, ocamlc_cppflags etc., directly.
*)
let bytecomp_c_compiler =
""
let native_c_compiler =
""
let native_c_libraries = ""
let native_pack_linker = "ld -r -arch x86_64 -o\ "
let ranlib = "ranlib"
let ar = "ar"
let cc_profile = "-pg"
let mkdll = ""
let mkexe = ""
let mkmaindll = ""
let profiling = true
let flambda = false
let safe_string = false
let default_safe_string = true
let windows_unicode = 0 != 0
let flat_float_array = true
let afl_instrument = false
let exec_magic_number = "Caml1999X011"
and cmi_magic_number = "Caml1999I022"
and cmo_magic_number = "Caml1999O022"
and cma_magic_number = "Caml1999A022"
and cmx_magic_number =
(* if flambda then
"Caml1999y022"
else *)
"Caml1999Y022"
and cmxa_magic_number =
(* if flambda then
"Caml1999z022"
else *)
"Caml1999Z022"
and ast_impl_magic_number = "Caml1999M022"
and ast_intf_magic_number = "Caml1999N022"
and cmxs_magic_number = "Caml1999D022"
(* cmxs_magic_number is duplicated in otherlibs/dynlink/natdynlink.ml *)
and cmt_magic_number = "Caml1999T022"
let load_path = ref ([] : string list)
let interface_suffix = ref ".mli"
let max_tag = 245
(* This is normally the same as in obj.ml, but we have to define it
separately because it can differ when we're in the middle of a
bootstrapping phase. *)
let lazy_tag = 246
let max_young_wosize = 256
let stack_threshold = 256 (* see byterun/config.h *)
let stack_safety_margin = 60
let architecture = "amd64"
let model = "default"
let system = "macosx"
let asm = "clang -arch x86_64 -Wno-trigraphs -c"
let asm_cfi_supported = true
let with_frame_pointers = false
let spacetime = false
let enable_call_counts = true
let libunwind_available = false
let libunwind_link_flags = ""
let profinfo = false
let profinfo_width = 0
let ext_exe = ""
let ext_obj = ".o"
let ext_asm = ".s"
let ext_lib = ".a"
let ext_dll = ".so"
let host = "x86_64-apple-darwin17.7.0"
let target = "x86_64-apple-darwin17.7.0"
let default_executable_name =
""
let systhread_supported = false;;
let flexdll_dirs = [];;
let print_config oc =
let p name valu = Printf.fprintf oc "%s: %s\n" name valu in
let p_int name valu = Printf.fprintf oc "%s: %d\n" name valu in
let p_bool name valu = Printf.fprintf oc "%s: %B\n" name valu in
p "version" version;
p "standard_library_default" standard_library_default;
p "standard_library" standard_library;
p "standard_runtime" standard_runtime;
p "ccomp_type" ccomp_type;
p "c_compiler" c_compiler;
p "ocamlc_cflags" ocamlc_cflags;
p "ocamlc_cppflags" ocamlc_cppflags;
p "ocamlopt_cflags" ocamlopt_cflags;
p "ocamlopt_cppflags" ocamlopt_cppflags;
p "bytecomp_c_compiler" bytecomp_c_compiler;
p "native_c_compiler" native_c_compiler;
p "bytecomp_c_libraries" bytecomp_c_libraries;
p "native_c_libraries" native_c_libraries;
p "native_pack_linker" native_pack_linker;
p "ranlib" ranlib;
p "cc_profile" cc_profile;
p "architecture" architecture;
p "model" model;
p_int "int_size" Sys.int_size;
p_int "word_size" Sys.word_size;
p "system" system;
p "asm" asm;
p_bool "asm_cfi_supported" asm_cfi_supported;
p_bool "with_frame_pointers" with_frame_pointers;
p "ext_exe" ext_exe;
p "ext_obj" ext_obj;
p "ext_asm" ext_asm;
p "ext_lib" ext_lib;
p "ext_dll" ext_dll;
p "os_type" Sys.os_type;
p "default_executable_name" default_executable_name;
p_bool "systhread_supported" systhread_supported;
p "host" host;
p "target" target;
p_bool "profiling" profiling;
p_bool "flambda" flambda;
p_bool "spacetime" spacetime;
p_bool "safe_string" safe_string;
p_bool "default_safe_string" default_safe_string;
p_bool "flat_float_array" flat_float_array;
p_bool "afl_instrument" afl_instrument;
p_bool "windows_unicode" windows_unicode;
(* print the magic number *)
p "exec_magic_number" exec_magic_number;
p "cmi_magic_number" cmi_magic_number;
p "cmo_magic_number" cmo_magic_number;
p "cma_magic_number" cma_magic_number;
p "cmx_magic_number" cmx_magic_number;
p "cmxa_magic_number" cmxa_magic_number;
p "ast_impl_magic_number" ast_impl_magic_number;
p "ast_intf_magic_number" ast_intf_magic_number;
p "cmxs_magic_number" cmxs_magic_number;
p "cmt_magic_number" cmt_magic_number;
flush oc;
;;
end
module Config = Config_whole_compiler
module Arg_helper : sig
#1 "arg_helper.mli"
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2015--2016 OCamlPro SAS *)
(* Copyright 2015--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(** Decipher command line arguments of the form
<value> | <key>=<value>[,...]
(as used for example for the specification of inlining parameters
varying by simplification round).
*)
module Make (S : sig
module Key : sig
type t
(** The textual representation of a key must not contain '=' or ','. *)
val of_string : string -> t
module Map : Map.S with type key = t
end
module Value : sig
type t
(** The textual representation of a value must not contain ','. *)
val of_string : string -> t
end
end) : sig
type parsed
val default : S.Value.t -> parsed
val set_base_default : S.Value.t -> parsed -> parsed
val add_base_override : S.Key.t -> S.Value.t -> parsed -> parsed
val reset_base_overrides : parsed -> parsed
val set_user_default : S.Value.t -> parsed -> parsed
val add_user_override : S.Key.t -> S.Value.t -> parsed -> parsed
val parse : string -> string -> parsed ref -> unit
type parse_result =
| Ok
| Parse_failed of exn
val parse_no_error : string -> parsed ref -> parse_result
val get : key:S.Key.t -> parsed -> S.Value.t
end
end = struct
#1 "arg_helper.ml"
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2015--2016 OCamlPro SAS *)
(* Copyright 2015--2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
let fatal err =
prerr_endline err;
exit 2
module Make (S : sig
module Key : sig
type t
val of_string : string -> t
module Map : Map.S with type key = t
end
module Value : sig
type t
val of_string : string -> t
end
end) = struct
type parsed = {
base_default : S.Value.t;
base_override : S.Value.t S.Key.Map.t;
user_default : S.Value.t option;
user_override : S.Value.t S.Key.Map.t;
}
let default v =
{ base_default = v;
base_override = S.Key.Map.empty;
user_default = None;
user_override = S.Key.Map.empty; }
let set_base_default value t =
{ t with base_default = value }
let add_base_override key value t =
{ t with base_override = S.Key.Map.add key value t.base_override }
let reset_base_overrides t =
{ t with base_override = S.Key.Map.empty }
let set_user_default value t =
{ t with user_default = Some value }
let add_user_override key value t =
{ t with user_override = S.Key.Map.add key value t.user_override }
exception Parse_failure of exn
let parse_exn str ~update =
(* Is the removal of empty chunks really relevant here? *)
(* (It has been added to mimic the old Misc.String.split.) *)
let values = String.split_on_char ',' str |> List.filter ((<>) "") in
let parsed =
List.fold_left (fun acc value ->
match String.index value '=' with
| exception Not_found ->
begin match S.Value.of_string value with
| value -> set_user_default value acc
| exception exn -> raise (Parse_failure exn)
end
| equals ->
let key_value_pair = value in
let length = String.length key_value_pair in
assert (equals >= 0 && equals < length);
if equals = 0 then begin
raise (Parse_failure (
Failure "Missing key in argument specification"))
end;
let key =
let key = String.sub key_value_pair 0 equals in
try S.Key.of_string key
with exn -> raise (Parse_failure exn)
in
let value =
let value =
String.sub key_value_pair (equals + 1) (length - equals - 1)
in
try S.Value.of_string value
with exn -> raise (Parse_failure exn)
in
add_user_override key value acc)
!update
values
in
update := parsed
let parse str help_text update =
match parse_exn str ~update with
| () -> ()
| exception (Parse_failure exn) ->
fatal (Printf.sprintf "%s: %s" (Printexc.to_string exn) help_text)
type parse_result =
| Ok
| Parse_failed of exn
let parse_no_error str update =
match parse_exn str ~update with
| () -> Ok
| exception (Parse_failure exn) -> Parse_failed exn
let get ~key parsed =
match S.Key.Map.find key parsed.user_override with
| value -> value
| exception Not_found ->
match parsed.user_default with
| Some value -> value
| None ->
match S.Key.Map.find key parsed.base_override with
| value -> value
| exception Not_found -> parsed.base_default
end
end
module Misc : sig
#1 "misc.mli"
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* Miscellaneous useful types and functions *)
val fatal_error: string -> 'a
val fatal_errorf: ('a, Format.formatter, unit, 'b) format4 -> 'a
exception Fatal_error
val try_finally : (unit -> 'a) -> (unit -> unit) -> 'a;;
val map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list
(* [map_end f l t] is [map f l @ t], just more efficient. *)
val map_left_right: ('a -> 'b) -> 'a list -> 'b list
(* Like [List.map], with guaranteed left-to-right evaluation order *)
val for_all2: ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
(* Same as [List.for_all] but for a binary predicate.
In addition, this [for_all2] never fails: given two lists
with different lengths, it returns false. *)
val replicate_list: 'a -> int -> 'a list
(* [replicate_list elem n] is the list with [n] elements
all identical to [elem]. *)
val list_remove: 'a -> 'a list -> 'a list
(* [list_remove x l] returns a copy of [l] with the first
element equal to [x] removed. *)
val split_last: 'a list -> 'a list * 'a
(* Return the last element and the other elements of the given list. *)
val may: ('a -> unit) -> 'a option -> unit
val may_map: ('a -> 'b) -> 'a option -> 'b option
type ref_and_value = R : 'a ref * 'a -> ref_and_value
val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a
(** [protect_refs l f] temporarily sets [r] to [v] for each [R (r, v)] in [l]
while executing [f]. The previous contents of the references is restored
even if [f] raises an exception. *)
module Stdlib : sig
module List : sig
type 'a t = 'a list
val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
(** The lexicographic order supported by the provided order.
There is no constraint on the relative lengths of the lists. *)
val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
(** Returns [true] iff the given lists have the same length and content
with respect to the given equality function. *)
val filter_map : ('a -> 'b option) -> 'a t -> 'b t
(** [filter_map f l] applies [f] to every element of [l], filters
out the [None] elements and returns the list of the arguments of
the [Some] elements. *)
val some_if_all_elements_are_some : 'a option t -> 'a t option
(** If all elements of the given list are [Some _] then [Some xs]
is returned with the [xs] being the contents of those [Some]s, with
order preserved. Otherwise return [None]. *)
val map2_prefix : ('a -> 'b -> 'c) -> 'a t -> 'b t -> ('c t * 'b t)
(** [let r1, r2 = map2_prefix f l1 l2]
If [l1] is of length n and [l2 = h2 @ t2] with h2 of length n,
r1 is [List.map2 f l1 h1] and r2 is t2. *)
val split_at : int -> 'a t -> 'a t * 'a t
(** [split_at n l] returns the pair [before, after] where [before] is
the [n] first elements of [l] and [after] the remaining ones.
If [l] has less than [n] elements, raises Invalid_argument. *)
end
module Option : sig
type 'a t = 'a option
val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
val iter : ('a -> unit) -> 'a t -> unit
val map : ('a -> 'b) -> 'a t -> 'b t
val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val value_default : ('a -> 'b) -> default:'b -> 'a t -> 'b
end
module Array : sig
val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
(* Same as [Array.exists], but for a two-argument predicate. Raise
Invalid_argument if the two arrays are determined to have
different lengths. *)
end
end
val find_in_path: string list -> string -> string
(* Search a file in a list of directories. *)
val find_in_path_rel: string list -> string -> string
(* Search a relative file in a list of directories. *)
val find_in_path_uncap: string list -> string -> string
(* Same, but search also for uncapitalized name, i.e.
if name is Foo.ml, allow /path/Foo.ml and /path/foo.ml
to match. *)
val remove_file: string -> unit
(* Delete the given file if it exists. Never raise an error. *)
val expand_directory: string -> string -> string
(* [expand_directory alt file] eventually expands a [+] at the
beginning of file into [alt] (an alternate root directory) *)
val create_hashtable: int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t
(* Create a hashtable of the given size and fills it with the
given bindings. *)
val copy_file: in_channel -> out_channel -> unit
(* [copy_file ic oc] reads the contents of file [ic] and copies
them to [oc]. It stops when encountering EOF on [ic]. *)
val copy_file_chunk: in_channel -> out_channel -> int -> unit
(* [copy_file_chunk ic oc n] reads [n] bytes from [ic] and copies
them to [oc]. It raises [End_of_file] when encountering
EOF on [ic]. *)
val string_of_file: in_channel -> string
(* [string_of_file ic] reads the contents of file [ic] and copies
them to a string. It stops when encountering EOF on [ic]. *)
val output_to_file_via_temporary:
?mode:open_flag list -> string -> (string -> out_channel -> 'a) -> 'a
(* Produce output in temporary file, then rename it
(as atomically as possible) to the desired output file name.
[output_to_file_via_temporary filename fn] opens a temporary file
which is passed to [fn] (name + output channel). When [fn] returns,
the channel is closed and the temporary file is renamed to
[filename]. *)
val log2: int -> int
(* [log2 n] returns [s] such that [n = 1 lsl s]
if [n] is a power of 2*)
val align: int -> int -> int
(* [align n a] rounds [n] upwards to a multiple of [a]
(a power of 2). *)
val no_overflow_add: int -> int -> bool
(* [no_overflow_add n1 n2] returns [true] if the computation of
[n1 + n2] does not overflow. *)
val no_overflow_sub: int -> int -> bool
(* [no_overflow_sub n1 n2] returns [true] if the computation of
[n1 - n2] does not overflow. *)
val no_overflow_mul: int -> int -> bool
(* [no_overflow_mul n1 n2] returns [true] if the computation of
[n1 * n2] does not overflow. *)
val no_overflow_lsl: int -> int -> bool
(* [no_overflow_lsl n k] returns [true] if the computation of
[n lsl k] does not overflow. *)
module Int_literal_converter : sig
val int : string -> int
val int32 : string -> int32
val int64 : string -> int64
val nativeint : string -> nativeint
end
val chop_extensions: string -> string
(* Return the given file name without its extensions. The extensions
is the longest suffix starting with a period and not including
a directory separator, [.xyz.uvw] for instance.
Return the given name if it does not contain an extension. *)
val search_substring: string -> string -> int -> int
(* [search_substring pat str start] returns the position of the first
occurrence of string [pat] in string [str]. Search starts
at offset [start] in [str]. Raise [Not_found] if [pat]
does not occur. *)
val replace_substring: before:string -> after:string -> string -> string
(* [replace_substring ~before ~after str] replaces all
occurrences of [before] with [after] in [str] and returns
the resulting string. *)
val rev_split_words: string -> string list
(* [rev_split_words s] splits [s] in blank-separated words, and returns
the list of words in reverse order. *)
val get_ref: 'a list ref -> 'a list
(* [get_ref lr] returns the content of the list reference [lr] and reset
its content to the empty list. *)
val fst3: 'a * 'b * 'c -> 'a
val snd3: 'a * 'b * 'c -> 'b
val thd3: 'a * 'b * 'c -> 'c
val fst4: 'a * 'b * 'c * 'd -> 'a
val snd4: 'a * 'b * 'c * 'd -> 'b
val thd4: 'a * 'b * 'c * 'd -> 'c
val for4: 'a * 'b * 'c * 'd -> 'd
module LongString :
sig
type t = bytes array
val create : int -> t
val length : t -> int
val get : t -> int -> char
val set : t -> int -> char -> unit
val blit : t -> int -> t -> int -> int -> unit
val output : out_channel -> t -> int -> int -> unit
val unsafe_blit_to_bytes : t -> int -> bytes -> int -> int -> unit
val input_bytes : in_channel -> int -> t
end
val edit_distance : string -> string -> int -> int option
(** [edit_distance a b cutoff] computes the edit distance between
strings [a] and [b]. To help efficiency, it uses a cutoff: if the
distance [d] is smaller than [cutoff], it returns [Some d], else
[None].
The distance algorithm currently used is Damerau-Levenshtein: it
computes the number of insertion, deletion, substitution of
letters, or swapping of adjacent letters to go from one word to the
other. The particular algorithm may change in the future.
*)
val spellcheck : string list -> string -> string list
(** [spellcheck env name] takes a list of names [env] that exist in
the current environment and an erroneous [name], and returns a
list of suggestions taken from [env], that are close enough to
[name] that it may be a typo for one of them. *)
val did_you_mean : Format.formatter -> (unit -> string list) -> unit
(** [did_you_mean ppf get_choices] hints that the user may have meant
one of the option returned by calling [get_choices]. It does nothing
if the returned list is empty.
The [unit -> ...] thunking is meant to delay any potentially-slow
computation (typically computing edit-distance with many things
from the current environment) to when the hint message is to be
printed. You should print an understandable error message before
calling [did_you_mean], so that users get a clear notification of
the failure even if producing the hint is slow.
*)
val cut_at : string -> char -> string * string
(** [String.cut_at s c] returns a pair containing the sub-string before
the first occurrence of [c] in [s], and the sub-string after the
first occurrence of [c] in [s].
[let (before, after) = String.cut_at s c in
before ^ String.make 1 c ^ after] is the identity if [s] contains [c].
Raise [Not_found] if the character does not appear in the string
@since 4.01
*)
module StringSet: Set.S with type elt = string
module StringMap: Map.S with type key = string
(* TODO: replace all custom instantiations of StringSet/StringMap in various
compiler modules with this one. *)
(* Color handling *)
module Color : sig
type color =
| Black
| Red
| Green
| Yellow
| Blue
| Magenta
| Cyan
| White
;;
type style =
| FG of color (* foreground *)
| BG of color (* background *)
| Bold
| Reset
| Dim
val ansi_of_style_l : style list -> string
(* ANSI escape sequence for the given style *)
type styles = {
error: style list;
warning: style list;
loc: style list;
}
val default_styles: styles
val get_styles: unit -> styles
val set_styles: styles -> unit
type setting = Auto | Always | Never
val setup : setting option -> unit
(* [setup opt] will enable or disable color handling on standard formatters
according to the value of color setting [opt].
Only the first call to this function has an effect. *)
val set_color_tag_handling : Format.formatter -> unit
(* adds functions to support color tags to the given formatter. *)
end
val normalise_eol : string -> string
(** [normalise_eol s] returns a fresh copy of [s] with any '\r' characters
removed. Intended for pre-processing text which will subsequently be printed
on a channel which performs EOL transformations (i.e. Windows) *)
val delete_eol_spaces : string -> string
(** [delete_eol_spaces s] returns a fresh copy of [s] with any end of
line spaces removed. Intended to normalize the output of the
toplevel for tests. *)
(** {1 Hook machinery}
Hooks machinery:
[add_hook name f] will register a function that will be called on the
argument of a later call to [apply_hooks]. Hooks are applied in the
lexicographical order of their names.
*)
type hook_info = {
sourcefile : string;
}
exception HookExnWrapper of
{
error: exn;
hook_name: string;
hook_info: hook_info;
}
(** An exception raised by a hook will be wrapped into a
[HookExnWrapper] constructor by the hook machinery. *)
val raise_direct_hook_exn: exn -> 'a
(** A hook can use [raise_unwrapped_hook_exn] to raise an exception that will
not be wrapped into a {!HookExnWrapper}. *)
module type HookSig = sig
type t
val add_hook : string -> (hook_info -> t -> t) -> unit
val apply_hooks : hook_info -> t -> t
end
module MakeHooks : functor (M : sig type t end) -> HookSig with type t = M.t
end = struct
#1 "misc.ml"
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* Errors *)
exception Fatal_error
let fatal_error msg =
prerr_string ">> Fatal error: "; prerr_endline msg; raise Fatal_error
let fatal_errorf fmt = Format.kasprintf fatal_error fmt
(* Exceptions *)
let try_finally work cleanup =
let result = (try work () with e -> cleanup (); raise e) in
cleanup ();
result
;;
type ref_and_value = R : 'a ref * 'a -> ref_and_value
let protect_refs =
let set_refs l = List.iter (fun (R (r, v)) -> r := v) l in
fun refs f ->
let backup = List.map (fun (R (r, _)) -> R (r, !r)) refs in
set_refs refs;
match f () with
| x -> set_refs backup; x
| exception e -> set_refs backup; raise e
(* List functions *)
let rec map_end f l1 l2 =
match l1 with
[] -> l2
| hd::tl -> f hd :: map_end f tl l2
let rec map_left_right f = function
[] -> []
| hd::tl -> let res = f hd in res :: map_left_right f tl
let rec for_all2 pred l1 l2 =
match (l1, l2) with
([], []) -> true
| (hd1::tl1, hd2::tl2) -> pred hd1 hd2 && for_all2 pred tl1 tl2
| (_, _) -> false
let rec replicate_list elem n =
if n <= 0 then [] else elem :: replicate_list elem (n-1)
let rec list_remove x = function
[] -> []