-
Notifications
You must be signed in to change notification settings - Fork 465
/
Copy pathbspp.ml
5793 lines (5179 loc) · 222 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 Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* 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 bytecomp_c_compiler: string
(* The C compiler to use for compiling C files
with the bytecode compiler *)
val bytecomp_c_libraries: string
(* The C libraries to link with custom runtimes *)
val native_c_compiler: string
(* The C compiler to use for compiling C files
with the native-code compiler *)
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 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 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;;
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 Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(***********************************************************************)
(** **)
(** WARNING WARNING WARNING **)
(** **)
(** When you change this file, you must make the parallel change **)
(** in config.mlbuild **)
(** **)
(***********************************************************************)
(* The main OCaml version string has moved to ../VERSION *)
let version = "4.02.3+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"(*dont care: cc or msvc*)
let bytecomp_c_compiler = "gcc -O -Wall -D_FILE_OFFSET_BITS=64 -D_REENTRANT -O" (*dont care*)
let bytecomp_c_libraries = "-lcurses -lpthread" (*dont care*)
let native_c_compiler = "gcc -O -D_FILE_OFFSET_BITS=64 -D_REENTRANT" (*dont care*)
let native_c_libraries = ""(*dont care*)
let native_pack_linker = "ld -r -arch x86_64 -o"(*dont care*)
let ranlib = "ranlib"(*dont care*)
let ar = ""(*dont care*)
let cc_profile = "-pg"(*dont care*)
let mkdll = ""(*dont care*)
let mkexe = ""(*dont care*)
let mkmaindll = ""(*dont care*)
let exec_magic_number = "Caml1999X011"
and cmi_magic_number = "Caml1999I017"
and cmo_magic_number = "Caml1999O010"
and cma_magic_number = "Caml1999A011"
and cmx_magic_number = "Caml1999Y014"
and cmxa_magic_number = "Caml1999Z013"
and ast_impl_magic_number = "Caml1999M016"
and ast_intf_magic_number = "Caml1999N015"
and cmxs_magic_number = "Caml2007D002"
and cmt_magic_number = "Caml2012T004"
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 architecture = "amd64" (*dont care*)
let model = "default"(*dont care*)
let system = "macosx"
let asm = "clang -arch x86_64 -c"
let asm_cfi_supported = false (*dont care*)
let with_frame_pointers = false (*dontcare*)
let ext_obj = ".o" (*dont care*)
let ext_asm = ".s" (*dont care*)
let ext_lib = ".a" (*dont caer*)
let ext_dll = ".a" (*dont care*)
let host = "%%HOST%%"
let target = "%%TARGET%%"
let default_executable_name =
match Sys.os_type with
"Unix" -> "a.out"
| "Win32" | "Cygwin" -> "camlprog.exe"
| _ -> "camlprog"
let systhread_supported = false (*dontcare*);;
let print_config oc =
let p name valu = Printf.fprintf oc "%s: %s\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 "bytecomp_c_compiler" bytecomp_c_compiler;
p "bytecomp_c_libraries" bytecomp_c_libraries;
p "native_c_compiler" native_c_compiler;
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 "system" system;
p "asm" asm;
p_bool "asm_cfi_supported" asm_cfi_supported;
p_bool "with_frame_pointers" with_frame_pointers;
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;
(* 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 Clflags : sig
#1 "clflags.mli"
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2005 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. *)
(* *)
(***********************************************************************)
val objfiles : string list ref
val ccobjs : string list ref
val dllibs : string list ref
val compile_only : bool ref
val output_name : string option ref
val include_dirs : string list ref
val no_std_include : bool ref
val print_types : bool ref
val make_archive : bool ref
val debug : bool ref
val fast : bool ref
val link_everything : bool ref
val custom_runtime : bool ref
val no_check_prims : bool ref
val bytecode_compatible_32 : bool ref
val output_c_object : bool ref
val output_complete_object : bool ref
val all_ccopts : string list ref
val classic : bool ref
val nopervasives : bool ref
val open_modules : string list ref
val preprocessor : string option ref
val all_ppx : string list ref
val annotations : bool ref
val binary_annotations : bool ref
val use_threads : bool ref
val use_vmthreads : bool ref
val noassert : bool ref
val verbose : bool ref
val noprompt : bool ref
val nopromptcont : bool ref
val init_file : string option ref
val noinit : bool ref
val use_prims : string ref
val use_runtime : string ref
val principal : bool ref
val real_paths : bool ref
val recursive_types : bool ref
val strict_sequence : bool ref
val strict_formats : bool ref
val applicative_functors : bool ref
val make_runtime : bool ref
val gprofile : bool ref
val c_compiler : string option ref
val no_auto_link : bool ref
val dllpaths : string list ref
val make_package : bool ref
val for_package : string option ref
val error_size : int ref
val float_const_prop : bool ref
val transparent_modules : bool ref
val dump_source : bool ref
val dump_parsetree : bool ref
val dump_typedtree : bool ref
val dump_rawlambda : bool ref
val dump_lambda : bool ref
val dump_clambda : bool ref
val dump_instr : bool ref
val keep_asm_file : bool ref
val optimize_for_speed : bool ref
val dump_cmm : bool ref
val dump_selection : bool ref
val dump_cse : bool ref
val dump_live : bool ref
val dump_spill : bool ref
val dump_split : bool ref
val dump_interf : bool ref
val dump_prefer : bool ref
val dump_regalloc : bool ref
val dump_reload : bool ref
val dump_scheduling : bool ref
val dump_linear : bool ref
val keep_startup_file : bool ref
val dump_combine : bool ref
val native_code : bool ref
val inline_threshold : int ref
val dont_write_files : bool ref
val std_include_flag : string -> string
val std_include_dir : unit -> string list
val shared : bool ref
val dlcode : bool ref
val runtime_variant : string ref
val force_slash : bool ref
val keep_docs : bool ref
val keep_locs : bool ref
val unsafe_string : bool ref
val opaque : bool ref
type mli_status = Mli_na | Mli_exists | Mli_non_exists
val no_implicit_current_dir : bool ref
val assume_no_mli : mli_status ref
val record_event_when_debug : bool ref
val bs_vscode : bool
val dont_record_crc_unit : string option ref
val bs_only : bool ref (* set true on bs top*)
val no_assert_false : bool ref
type color_setting = Auto | Always | Never
val parse_color_setting : string -> color_setting option
val color : color_setting ref
end = struct
#1 "clflags.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 Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* Command-line parameters *)
let objfiles = ref ([] : string list) (* .cmo and .cma files *)
and ccobjs = ref ([] : string list) (* .o, .a, .so and -cclib -lxxx *)
and dllibs = ref ([] : string list) (* .so and -dllib -lxxx *)
let compile_only = ref false (* -c *)
and output_name = ref (None : string option) (* -o *)
and include_dirs = ref ([] : string list)(* -I *)
and no_std_include = ref false (* -nostdlib *)
and print_types = ref false (* -i *)
and make_archive = ref false (* -a *)
and debug = ref false (* -g *)
and fast = ref false (* -unsafe *)
and link_everything = ref false (* -linkall *)
and custom_runtime = ref false (* -custom *)
and no_check_prims = ref false (* -no-check-prims *)
and bytecode_compatible_32 = ref false (* -compat-32 *)
and output_c_object = ref false (* -output-obj *)
and output_complete_object = ref false (* -output-complete-obj *)
and all_ccopts = ref ([] : string list) (* -ccopt *)
and classic = ref false (* -nolabels *)
and nopervasives = ref false (* -nopervasives *)
and preprocessor = ref(None : string option) (* -pp *)
and all_ppx = ref ([] : string list) (* -ppx *)
let annotations = ref false (* -annot *)
let binary_annotations = ref false (* -annot *)
and use_threads = ref false (* -thread *)
and use_vmthreads = ref false (* -vmthread *)
and noassert = ref false (* -noassert *)
and verbose = ref false (* -verbose *)
and noprompt = ref false (* -noprompt *)
and nopromptcont = ref false (* -nopromptcont *)
and init_file = ref (None : string option) (* -init *)
and noinit = ref false (* -noinit *)
and open_modules = ref [] (* -open *)
and use_prims = ref "" (* -use-prims ... *)
and use_runtime = ref "" (* -use-runtime ... *)
and principal = ref false (* -principal *)
and real_paths = ref true (* -short-paths *)
and recursive_types = ref false (* -rectypes *)
and strict_sequence = ref false (* -strict-sequence *)
and strict_formats = ref false (* -strict-formats *)
and applicative_functors = ref true (* -no-app-funct *)
and make_runtime = ref false (* -make-runtime *)
and gprofile = ref false (* -p *)
and c_compiler = ref (None: string option) (* -cc *)
and no_auto_link = ref false (* -noautolink *)
and dllpaths = ref ([] : string list) (* -dllpath *)
and make_package = ref false (* -pack *)
and for_package = ref (None: string option) (* -for-pack *)
and error_size = ref 500 (* -error-size *)
and float_const_prop = ref true (* -no-float-const-prop *)
and transparent_modules = ref false (* -trans-mod *)
let dump_source = ref false (* -dsource *)
let dump_parsetree = ref false (* -dparsetree *)
and dump_typedtree = ref false (* -dtypedtree *)
and dump_rawlambda = ref false (* -drawlambda *)
and dump_lambda = ref false (* -dlambda *)
and dump_clambda = ref false (* -dclambda *)
and dump_instr = ref false (* -dinstr *)
let keep_asm_file = ref false (* -S *)
let optimize_for_speed = ref true (* -compact *)
and opaque = ref false (* -opaque *)
and dump_cmm = ref false (* -dcmm *)
let dump_selection = ref false (* -dsel *)
let dump_cse = ref false (* -dcse *)
let dump_live = ref false (* -dlive *)
let dump_spill = ref false (* -dspill *)
let dump_split = ref false (* -dsplit *)
let dump_interf = ref false (* -dinterf *)
let dump_prefer = ref false (* -dprefer *)
let dump_regalloc = ref false (* -dalloc *)
let dump_reload = ref false (* -dreload *)
let dump_scheduling = ref false (* -dscheduling *)
let dump_linear = ref false (* -dlinear *)
let keep_startup_file = ref false (* -dstartup *)
let dump_combine = ref false (* -dcombine *)
let native_code = ref false (* set to true under ocamlopt *)
let inline_threshold = ref 10
let force_slash = ref false (* for ocamldep *)
let dont_write_files = ref false (* set to true under ocamldoc *)
let std_include_flag prefix =
if !no_std_include then ""
else (prefix ^ (Filename.quote Config.standard_library))
;;
let std_include_dir () =
if !no_std_include then [] else [Config.standard_library]
;;
let shared = ref false (* -shared *)
let dlcode = ref true (* not -nodynlink *)
let runtime_variant = ref "";; (* -runtime-variant *)
let keep_docs = ref false (* -keep-docs *)
let keep_locs = ref false (* -keep-locs *)
let unsafe_string = ref true;; (* -safe-string / -unsafe-string *)
type mli_status = Mli_na | Mli_exists | Mli_non_exists
let no_implicit_current_dir = ref false
let assume_no_mli = ref Mli_na
let record_event_when_debug = ref true (* turned off in BuckleScript*)
let bs_vscode =
try ignore @@ Sys.getenv "BS_VSCODE" ; true with _ -> false
(* We get it from environment variable mostly due to
we don't want to rebuild when flip on or off
*)
let dont_record_crc_unit : string option ref = ref None
let bs_only = ref false
let no_assert_false = ref false
type color_setting = Auto | Always | Never
let parse_color_setting = function
| "auto" -> Some Auto
| "always" -> Some Always
| "never" -> Some Never
| _ -> None
let color = ref Auto ;; (* -color *)
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 Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* Miscellaneous useful types and functions *)
val fatal_error: string -> '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 samelist: ('a -> 'a -> bool) -> 'a list -> 'a list -> bool
(* Like [List.for_all2] but returns [false] if the two
lists have different length. *)
val may: ('a -> unit) -> 'a option -> unit
val may_map: ('a -> 'b) -> 'a option -> 'b option
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 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_add n1 n2] returns [true] if the computation of
[n1 - n2] does not overflow. *)
val no_overflow_lsl: int -> bool
(* [no_overflow_add n] returns [true] if the computation of
[n lsl 1] does not overflow. *)
val chop_extension_if_any: string -> string
(* Like Filename.chop_extension but returns the initial file
name if it has no extension *)
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
(* [search_substring ~before ~after str] replaces all occurences
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 return
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 split : string -> char -> string list
(** [String.split string char] splits the string [string] at every char
[char], and returns the list of sub-strings between the chars.
[String.concat (String.make 1 c) (String.split s c)] is the identity.
@since 4.01
*)
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
*)
(* 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
val setup : Clflags.color_setting -> 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
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 Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* Errors *)
exception Fatal_error
let fatal_error msg =
prerr_string ">> Fatal error: "; prerr_endline msg; raise Fatal_error
(* Exceptions *)
let try_finally work cleanup =
let result = (try work () with e -> cleanup (); raise e) in
cleanup ();
result
;;
(* 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
[] -> []
| hd :: tl ->
if hd = x then tl else hd :: list_remove x tl
let rec split_last = function
[] -> assert false
| [x] -> ([], x)
| hd :: tl ->
let (lst, last) = split_last tl in
(hd :: lst, last)
let rec samelist pred l1 l2 =
match (l1, l2) with
| ([], []) -> true
| (hd1 :: tl1, hd2 :: tl2) -> pred hd1 hd2 && samelist pred tl1 tl2
| (_, _) -> false
(* Options *)
let may f = function
Some x -> f x
| None -> ()
let may_map f = function
Some x -> Some (f x)
| None -> None
(* File functions *)
let find_in_path path name =
if not (Filename.is_implicit name) then
if Sys.file_exists name then name else raise Not_found
else begin
let rec try_dir = function
[] -> raise Not_found
| dir::rem ->
let fullname = Filename.concat dir name in
if Sys.file_exists fullname then fullname else try_dir rem
in try_dir path
end
let find_in_path_rel path name =
let rec simplify s =
let open Filename in
let base = basename s in
let dir = dirname s in
if dir = s then dir
else if base = current_dir_name then simplify dir
else concat (simplify dir) base
in
let rec try_dir = function
[] -> raise Not_found
| dir::rem ->
let fullname = simplify (Filename.concat dir name) in
if Sys.file_exists fullname then fullname else try_dir rem
in try_dir path
let find_in_path_uncap path name =
let uname = String.uncapitalize name in
let rec try_dir = function
[] -> raise Not_found
| dir::rem ->
let fullname = Filename.concat dir name
and ufullname = Filename.concat dir uname in
if Sys.file_exists ufullname then ufullname
else if Sys.file_exists fullname then fullname
else try_dir rem
in try_dir path
let remove_file filename =
try
Sys.remove filename
with Sys_error msg ->
()
(* Expand a -I option: if it starts with +, make it relative to the standard
library directory *)
let expand_directory alt s =
if String.length s > 0 && s.[0] = '+'
then Filename.concat alt
(String.sub s 1 (String.length s - 1))
else s
(* Hashtable functions *)
let create_hashtable size init =
let tbl = Hashtbl.create size in
List.iter (fun (key, data) -> Hashtbl.add tbl key data) init;
tbl
(* File copy *)
let copy_file ic oc =
let buff = Bytes.create 0x1000 in
let rec copy () =
let n = input ic buff 0 0x1000 in
if n = 0 then () else (output oc buff 0 n; copy())
in copy()
let copy_file_chunk ic oc len =
let buff = Bytes.create 0x1000 in
let rec copy n =
if n <= 0 then () else begin
let r = input ic buff 0 (min n 0x1000) in
if r = 0 then raise End_of_file else (output oc buff 0 r; copy(n-r))
end
in copy len
let string_of_file ic =
let b = Buffer.create 0x10000 in
let buff = Bytes.create 0x1000 in
let rec copy () =
let n = input ic buff 0 0x1000 in
if n = 0 then Buffer.contents b else
(Buffer.add_subbytes b buff 0 n; copy())
in copy()
(* Integer operations *)
let rec log2 n =
if n <= 1 then 0 else 1 + log2(n asr 1)
let align n a =
if n >= 0 then (n + a - 1) land (-a) else n land (-a)
let no_overflow_add a b = (a lxor b) lor (a lxor (lnot (a+b))) < 0
let no_overflow_sub a b = (a lxor (lnot b)) lor (b lxor (a-b)) < 0
let no_overflow_lsl a = min_int asr 1 <= a && a <= max_int asr 1
(* String operations *)
let chop_extension_if_any fname =
try Filename.chop_extension fname with Invalid_argument _ -> fname
let chop_extensions file =
let dirname = Filename.dirname file and basename = Filename.basename file in
try
let pos = String.index basename '.' in
let basename = String.sub basename 0 pos in
if Filename.is_implicit file && dirname = Filename.current_dir_name then
basename
else
Filename.concat dirname basename
with Not_found -> file
let search_substring pat str start =
let rec search i j =
if j >= String.length pat then i
else if i + j >= String.length str then raise Not_found
else if str.[i + j] = pat.[j] then search i (j+1)
else search (i+1) 0
in search start 0
let replace_substring ~before ~after str =
let rec search acc curr =
match search_substring before str curr with
| next ->
let prefix = String.sub str curr (next - curr) in
search (prefix :: acc) (next + String.length before)
| exception Not_found ->
let suffix = String.sub str curr (String.length str - curr) in
List.rev (suffix :: acc)
in String.concat after (search [] 0)
let rev_split_words s =
let rec split1 res i =
if i >= String.length s then res else begin
match s.[i] with
' ' | '\t' | '\r' | '\n' -> split1 res (i+1)
| _ -> split2 res i (i+1)
end
and split2 res i j =
if j >= String.length s then String.sub s i (j-i) :: res else begin
match s.[j] with
' ' | '\t' | '\r' | '\n' -> split1 (String.sub s i (j-i) :: res) (j+1)
| _ -> split2 res i (j+1)
end
in split1 [] 0
let get_ref r =
let v = !r in
r := []; v
let fst3 (x, _, _) = x
let snd3 (_,x,_) = x
let thd3 (_,_,x) = x
let fst4 (x, _, _, _) = x
let snd4 (_,x,_, _) = x
let thd4 (_,_,x,_) = x
let for4 (_,_,_,x) = x