-
Notifications
You must be signed in to change notification settings - Fork 125
/
objectFiles.ml
2151 lines (1945 loc) · 83.5 KB
/
objectFiles.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
(*
Copyright © 2011, 2012 MLstate
This file is part of Opa.
Opa is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
Opa is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with Opa. If not, see <http://www.gnu.org/licenses/>.
*)
(**
A package foo is stored into the directory foo.opx
It may have several object files, each in a separate file
The files themselves just contain one line with the git hash of
libqml and opa, you won't try to marshal old datastructures
(and segfault doing so)
The rest of the file is just the programmer information, marshalled
*)
#<Debugvar:OBJECT_DEBUG>
(* depends *)
module List = Base.List
module String = Base.String
module Format = Base.Format
module Hashtbl = Base.Hashtbl
(* -- *)
type package_name = string (* foo *)
type filename = string (* path/foo.opx *)
type basename = string (* foo.opx *)
type hash = string
type content = string
type regexp = string
type 'code_elt parsed_code = (filename * content * 'code_elt list) list
(*
Convention for unit storing.
All package object files are saved in one directory for each package.
In this directory, each pass can store a object file nammed like the pass.
We store also in a special directory all the compiled object files from
the (pass final compilation), with a object file index which contains the ordered
list of files contained in this directory.
*)
module Name =
struct
let plugin_ext = "opp"
let object_ext = "opx" (* pronounced opix *)
let bin_directory = "bin"
let index_bin = "index" (* stored in bin/index *)
end
module Package =
struct
type t = package_name * FilePos.pos (* FIXME should be a list, to have the positions of successives imports *)
let name = fst
let pos = snd
let compare ((n1,_):t) ((n2,_):t) = compare n1 n2
let compare_opt = Option.make_compare compare
let equal ((n1,_):t) ((n2,_):t) = n1 = n2
let equal_opt o1 o2 =
match o1, o2 with
| None, None -> true
| Some p1, Some p2 -> equal p1 p2
| _ -> false
let hash ((n,_):t) = Hashtbl.hash n
let pp f ((s,_):t) = Format.pp_print_string f s
let pp_full f ((s,pos) : t) = Format.fprintf f "%s at %a" s FilePos.pp_pos pos
let pp_option f = function
| None -> Format.fprintf f "None"
| Some p -> Format.fprintf f "Some %a" pp p
let pp_field sep ppa fmt f t =
pp fmt f;
Format.fprintf fmt sep;
ppa fmt t
let pp_2 ppa ppb f (a,b) =
Format.fprintf f "(%a, %a)" ppa a ppb b
end
module PackageTbl = Hashtbl.Make(Package)
module PackageAssoc = List.MakeAssoc(Package)
module ListPackageMap = ListMap.Make(Package)
type package = Package.t
(*
Configuration files. They are used in case of refactoring big projects,
for expliciting the package organization for files which does not precise
a package. Loading conf files leads to a side effect on this table.
*)
let conftable : (filename, package) Hashtbl.t = Hashtbl.create 10
let conf_opa_files_state = ref ([] : string list)
(*
Extra import specified in conf files
*)
let confimport : (package_name, package) ListHashtbl.t = ListHashtbl.create 10
(*
In a conf file, a line can be a package definition :
{[
mypackage:
]}
or a infos
{[
import package
toto/titi.opa
/tmp/myfile.opa
$ENVAR/myfile.opa
]}
*)
type conf_line =
| Package of package_name
| Infos of (filename list * string list) (* filenames, and imported packages *)
let conf_split s = String.slice_chars " \t" s
let process_line ~position line =
let line =
match String.findi '#' line with
| None -> line
| Some i -> String.sub line 0 i
in
let line = String.trim line in
let length = String.length line in
if length = 0
then None
else
if line.[pred length] = ':'
then
let package_name = String.sub line 0 (pred length) in
let package_name = String.trim package_name in
Some (Package package_name)
else
let words = conf_split line in
let filenames, imported =
let rec aux ((filenames, imported) as acc) = function
| [] -> acc
| "import" :: tl -> (
match tl with
| [] ->
OManager.error (
"%a@\n" ^^
"@{<bright>import@} should be followed by a package name on the same line."
)
FilePos.pp_pos position
| package :: tl ->
aux (filenames, package::imported) tl
)
| hd :: tl ->
aux (hd::filenames, imported) tl
in
aux ([], []) words
in
Some (Infos (filenames, imported))
(*
Solving the env:
+ resolve path
+ resolve env vars
*)
let solve_env conffile prefix filename =
let find s =
try Sys.getenv s with Not_found -> s in
let filename =
try
let b = Buffer.create 124 in
let _ = Buffer.add_substitute b find filename in
Buffer.contents b
with
| Not_found -> filename in
let filename =
if Filename.is_relative filename
then
File.simplify_path (Filename.concat prefix filename)
else
filename in
if not (File.is_regular filename) then
OManager.serror "%s: file %s is not a regular file."
conffile filename;
filename
let load_conf conffile =
let () =
if not (File.is_regular conffile) then
OManager.error "I/O error: @{<bright>%S@} -> No such file" conffile
in
let () =
let content =
match File.content_opt conffile with
| Some content -> content
| None ->
OManager.error "I/O error: cannot read conf file @{<bright>%S@}" conffile
in
FilePos.add_file conffile content
in
(* the path in a conf file is relative to the location of the conf file *)
let prefix = Filename.dirname conffile in
let process_line package line _i offset =
let position = FilePos.make_pos conffile offset (offset + String.length line) in
match process_line ~position line with
| None -> package
| Some (Package package_name) ->
if package_name = ""
then
OManager.error (
"%a@\n" ^^
"The package name @{<bright>%S@} is invalid"
)
FilePos.pp_pos position
package_name
else
Some package_name
| Some (Infos (filenames, imported)) -> (
match package with
| Some package_name ->
List.iter (
fun filename ->
(* solving the env *)
let filename = solve_env conffile prefix filename in
let _ =
#<If$minlevel 10>
Printf.printf "add conf : file:%S --> pack:%S\n%!" filename package_name
#<End>
in
Hashtbl.add conftable filename (package_name, position) ;
conf_opa_files_state := filename :: (!conf_opa_files_state) ;
) filenames ;
List.iter (
fun import ->
ListHashtbl.add confimport package_name (import, position) ;
) imported ;
package
| None ->
let context =
let filename = String.concat " " filenames in
let import = String.concat " " imported in
let files =
match filenames with
| [] -> ""
| _ -> Printf.sprintf "file(s) %s" filename
in
let imported =
match imported with
| [] -> ""
| _ -> Printf.sprintf "imported package(s) %s" import
in
match files with
| "" -> imported
| _ -> Printf.sprintf "%s and %s" files imported
in
OManager.error (
"%a@\n" ^^
"You should supply a @{<bright>package@} for @{<bright>%s@}@\n"^^
"@[<2>@{<bright>Hint@}:@\nAdd a package declaration in a line before, using this syntax:@\n" ^^
"@[<2>mypackage:@\n" ^^
"%s@]@]@\n"
)
FilePos.pp_pos position
context
line
)
in
let _ = File.lines_foldi_offset process_line None conffile in
()
let conf_opa_files () = List.rev (!conf_opa_files_state)
(*------------------------------*)
(*---- command line options ----*)
(*------------------------------*)
(* a *)
let autobuild : bool option ref = ref (Some true) (* the bool says is we need to link *)
(* c *)
type compilation_mode = [
| `prelude
| `init
| `linking
| `compilation
]
let compilation_mode_state = ref `prelude
let compilation_mode () = !compilation_mode_state
let compiler_packages = MutableList.create ()
(* m *)
let more_import_package_names = MutableList.create ()
let more_link_package_names = MutableList.create ()
(* o *)
let opadep = ref false
let opadep_all = ref false
(* r *)
let rebuild = ref false
(* s *)
let default_separated = `full
let separated = ref default_separated
let turn_separated_on () =
match !separated with
| `partial | `full -> ()
| `no -> separated := default_separated
let turn_separated_off () =
separated := `no
(* v *)
let verbose_build = ref false
(* utility function on command line arguments *)
let is_separated () = !separated <> `no
(*-------------------------*)
(*----- a few utils -------*)
(*-------------------------*)
(* for simplicity, every time the compiler changes, the object files are invalid *)
let this_file_version = BuildInfos.opa_git_sha
let opxdir = ref "."
let unprefixed_dirname (package:package_name) : filename = package ^ "." ^ Name.object_ext
let dirname (package:package_name) : filename = Filename.concat !opxdir (unprefixed_dirname package)
let unprefixed_dirname_plugin (package:package_name) : filename = package ^ "." ^ Name.plugin_ext
let dirname_plugin (package:package_name) : filename = Filename.concat !opxdir (unprefixed_dirname_plugin package)
let dirname_from_package ((package_name,_):package) = dirname package_name
let undirname filename : package_name = Filename.chop_suffix (Filename.basename filename) ("."^Name.object_ext)
let undirname_plugin filename : package_name = Filename.chop_suffix (Filename.basename filename) ("."^Name.plugin_ext)
let filename_from_dir dir pass = Filename.concat dir pass
let filename_from_package package pass = filename_from_dir (dirname_from_package package) pass
let fst3 (a,_,_) = a
let fst_snd3 (a,b,_) = (a,b)
module MakeMemo(S:Hashtbl.HashedType) : sig
val memo : (S.t -> 'a) -> (S.t -> 'a) * (S.t -> [ `value of 'a | `exn of exn ] -> unit) * (S.t -> unit)
val memo_but_exn : (S.t -> 'a) -> (S.t -> 'a) * (S.t -> 'a -> unit) * (S.t -> unit)
end =
struct
module H = Hashtbl.Make(S)
let memo f =
let h = H.create 10 in
let get =
fun x ->
try
match H.find h x with
| `exn e -> raise e
| `value v -> v
with Not_found ->
try
let v = f x in
H.add h x (`value v);
v
with e ->
H.add h x (`exn e);
raise e in
let set k v = H.add h k v in
let unset k = H.remove h k in
get, set, unset
let memo_but_exn f = (* doesn't memoize the result when an exception is thrown *)
let h = H.create 10 in
let get =
fun x ->
try H.find h x
with Not_found ->
let v = f x in
H.add h x v;
v in
let set k v = H.replace h k v in
let unset k = H.remove h k in
get, set, unset
end
(* a few utils so that you can choose whether functions exit
* or throw exception
* this should somehow be merged with omanager, not sure how, though *)
exception No_exit of string
let raise_exn = ref false
let with_exn f =
let b = !raise_exn in
raise_exn := true;
try let r = f () in
raise_exn := b;
r
with e ->
raise_exn := b;
raise e
let error fmt =
if !raise_exn then Format.ksprintf (fun s -> raise (No_exit s)) fmt
else OManager.error fmt
let serror fmt =
if !raise_exn then Format.ksprintf (fun s -> raise (No_exit s)) fmt
else OManager.serror fmt
let verbose fmt =
let fmt = "[objects] " ^^ fmt in
if !verbose_build then
OManager.printf fmt
else
OManager.ifprintf fmt
(*----------------------------------*)
(*- info about the current package -*)
(*----------------------------------*)
let linking_package : package = ("",FilePos.nopos "ObjectFiles.dummy")
let current_package = ref linking_package (* foo, not foo.opx *)
let package_names = ref ([]:package list) (* foo, bar *)
let package_deep_names = ref ([]:package list) (* for transitive deps *)
let package_deep_names_and_more_deeps_names = ref ([] : package list) (* for transitive deps of the package + of the --packages *)
let package_names_and_more_names = ref ([] : package list) (* for direct deps + --packages *)
let after_end_of_separate_compilation = ref false
let no_init = ref false
let global_compilation () = not (is_separated ()) || !after_end_of_separate_compilation
let get_current_package () = !current_package
let get_current_package_name () = fst !current_package
let end_of_separate_compilation () = after_end_of_separate_compilation := true
let last_pass = "pass_end_of_separate_compilation"
(* characters valid in identifiers in js and ml
* !! do not put the special_char of string_to_valid_ident in here
*)
let accepted_char = function
| 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' -> true
| _ -> false
(* returns a valid ml ident, or maybe "" (when s was "") *)
let get_package_name_as_a_valid_ident ?(will_be_prefixed=false) s =
let special_char = '_' in
let s = String.escape ~valid_chars:accepted_char ~escape_char:special_char s in
if will_be_prefixed then
s
else
if s = "" then "l" else "c" ^ s
let get_package_as_a_valid_ident ?will_be_prefixed (package_name,_) =
get_package_name_as_a_valid_ident ?will_be_prefixed package_name
let get_current_package_name_as_a_valid_ident ?will_be_prefixed () = get_package_name_as_a_valid_ident ?will_be_prefixed (get_current_package_name ())
let prefix_by_mlstatelibs s =
let mlstatelibs = Lazy.force InstallDir.getenv in
Filename.concat mlstatelibs s
let defaultpaths =
(*
need to delay the compuation until after options, so
that InstallDir is not computed if unsed (--help, --version, etc.)
*)
lazy (
let dirplug = prefix_by_mlstatelibs InstallDir.opa_packages in
let dirplug = if File.exists dirplug then [dirplug] else [] in
!opxdir :: prefix_by_mlstatelibs InstallDir.lib_opa :: dirplug
)
let relative_stdlib = ref ""
let defaultpaths_for_stdlib =
(* need to delay the computation until after options have been parsed
* or else the --quiet option wouldn't have been set yet *)
lazy (let dirname = prefix_by_mlstatelibs (Filename.concat InstallDir.opa_packages !relative_stdlib) in
let formula =
Filename.concat (Printf.sprintf "$%s" InstallDir.name) InstallDir.opa_packages
in
try
if Sys.is_directory dirname then
[dirname]
else (
if is_separated () then
OManager.unquiet "%s (=%s) is not a directory. It won't be used as a default included directory."
formula dirname;
[]
)
with Sys_error _ ->
if is_separated () then
OManager.unquiet "%s (=%s) doesn't exist. It won't be used as a default included directory."
formula dirname;
[])
let extrapaths = ref []
let bsl_plugins = ref []
(*----------------------------------*)
(*----- the initial loading --------*)
(*----------------------------------*)
let wclass_load =
WarningClass.create
~public:true
~name:"load-opx"
~doc:"Warn if you use a package that has several corresponding object files in the -I paths"
~err:false
~enable:true
()
let wclass_import = (* warn for instance on the code [import schtroumpf.*] *)
WarningClass.create
~public:true
~name:"load-import"
~doc:"Warn if you make in import declaration that doesn't import anything"
~err:true
~enable:true
()
let warning_set =
WarningClass.Set.create_from_list [
wclass_load;
wclass_import;
]
(* find the dir where the package 'foo' is located
* the search paths are the ones given with -I to the compiler,
* plus the default ones *)
let find_dir_no_memo ((package_name, pos) : package) : filename =
let r =
File.get_one_location
~dir:true
~missing_file:(fun _dirs _fname ->
error (
"%a@\n Cannot find any object file for package @{<bright>%s@}.@\n" ^^
"@[<2>@{<bright>Hint@}:@\nPerhaps some included directories are missing (option -I)@]"
)
FilePos.pp_pos pos package_name
)
~many_files:(fun _dirs _fname l ->
let choice = List.hd l in
OManager.warning ~wclass:wclass_load
"@[<v2>Found several object files for package %s:@ %a@]@\nDefaulting to @{<bright>%s@}"
package_name (Format.pp_list "@ " Format.pp_print_string) l choice;
choice)
!extrapaths
(unprefixed_dirname package_name) in
#<If$minlevel 5>
Printf.printf "find_dir: %s -> %s\n%!" package_name r
#<End>;
r
let find_dir, set_find_dir, unset_dir =
let module M = MakeMemo(Package) in
M.memo_but_exn find_dir_no_memo
let find_js_file_no_memo (js_file:basename) =
File.get_one_location
~missing_file:(fun _dirs _fname ->
error (
"Cannot find the js file @{<bright>%s@}.@\n" ^^
"@[<2>@{<bright>Hint@}:@\nPerhaps some included directories are missing (option -I)@\n%a@]"
)
js_file
(Format.pp_list "@ " Format.pp_print_string) !extrapaths
)
~many_files:(fun _dirs _fname l ->
let choice = List.hd l in
OManager.warning ~wclass:wclass_load
"@[<v2>Found several files with name %s:@ %a@]@\nDefaulting to @{<bright>%s@}"
js_file (Format.pp_list "@ " Format.pp_print_string) l choice;
choice)
!extrapaths
js_file
let find_js_file, _set_find_js_file, _unset_find_js_file =
let module M = MakeMemo(String) in
M.memo find_js_file_no_memo
let find_js_file_content_digest, _, _unset_find_js_file_content_digest =
let module M = MakeMemo(String) in
M.memo (fun js_file ->
let path = find_js_file js_file in
let content = File.content path in
let digest = Digest.string content in
path, content, digest
)
let exists_dir package =
try
ignore (with_exn (fun () -> find_dir package));
true
with No_exit _s ->
false
(*
* syntax: * is a glob shell -> .* for Str
* {alt1,alt2,alt3} for alternatives -> \(alt1\|alt2\|alt3\) for Str
* anything except '*', '{', '}', ',' is literal and you have no escapes sequences
* even if the input is malformed, the output is well formed
* (to avoid receiving exceptions from Str.regexp)
*)
let matching pos beg end_ sep s index : (int * string list) =
let len = String.length s in
let rec aux depth last acc i =
if i = len then (
OManager.warning ~wclass:wclass_import "%a@\n An opening %C has no matching %C."
FilePos.pp_pos pos
beg end_;
let s = String.sub s last (i - last) in
let acc = s :: acc in
(i-1,List.rev acc)
) else if s.[i] = beg then (
aux (depth+1) last acc (i+1)
) else if s.[i] = end_ then (
if depth = 0 then
let s = String.sub s last (i - last) in
let acc = s :: acc in
(i,List.rev acc)
else
aux (depth-1) last acc (i+1)
) else if s.[i] = sep then (
if depth = 0 then
let s = String.sub s last (i - last) in
let acc = s :: acc in
aux depth (i+1) acc (i+1)
else
aux depth last acc (i+1)
) else
aux depth last acc (i+1) in
aux 0 index [] index
let rec brace_expansion_aux pos s : char list list =
let len = String.length s in
let rec aux accs i =
if i = len then
accs
else (
match s.[i] with
| '{' ->
let beg = i + 1 in
let (end_,choices) = matching pos '{' '}' ',' s beg in
let regexps : char list list = brace_expansions pos choices in
let accs = List.rectangle_map (fun acc regexp -> regexp @ acc) accs regexps in
aux accs (end_+1)
| '}' | ',' as c ->
OManager.warning ~wclass:wclass_import "%a@\n Illegal %C in import declaration."
FilePos.pp_pos pos c;
aux accs (i+1)
| c -> aux (List.map (fun l -> c :: l) accs) (i+1)
) in
aux [[]] 0
and brace_expansions pos (sl : string list) : char list list =
List.concat_map (brace_expansion_aux pos) sl
(* This function performs brace expansion
* for instance "abc{1,2,3}def" -> ["abc1def","abc2def","abc3def"]
*)
let brace_expansion (s,pos) =
let charss = brace_expansion_aux pos s in
List.map (fun x -> String.of_chars (List.rev x)) charss
let regexp_of_glob s =
let len = String.length s in
let b = Buffer.create (String.length s * 2) in
for i = 0 to len - 1 do
match s.[i] with
| '*' -> Buffer.add_string b ".*"
| '\\' | '[' | ']' | (*'*' |*) '.' | '?' | '+' | '^' | '$' as c ->
Buffer.add_char b '\\';
Buffer.add_char b c;
| c ->
Buffer.add_char b c
done;
Buffer.contents b
let exists_package ?(extrapath=[]) package =
let extrapaths = extrapath @ (!extrapaths) in
let package_opx = package^".opx" in
File.get_locations_regexp ~dir:true extrapaths package_opx <> []
let expand_glob ?(mode = (`package : [`package|`plugin])) names (package_name,pos) =
let package_keyword, import_keyword, unprefixed_dirname =
match mode with
| `package ->
"package", "import", unprefixed_dirname
| `plugin ->
"plugin", "import-plugin", unprefixed_dirname_plugin
in
let globs = brace_expansion (unprefixed_dirname package_name,pos) in
let results =
List.concat_map
(fun glob -> (* glob has the form [.*\.opx] *)
let string_regexp = regexp_of_glob glob in
let l = File.get_locations_regexp ~dir:true !extrapaths string_regexp in
(* we can possibly have duplicates as path1/a.opx and path2/a.opx
* since we manipulate only package names, we will transform it to ["a";"a"]
* later when we call find_dir on "a", we will have a proper warning
* because it will find the two occurrences of */a.opx *)
let l = List.map (fun x -> undirname x, pos) l in
let regexp = Str.regexp (string_regexp^"$") in
let l = l @ List.filter (fun (s,_pos) -> Str.string_match regexp (unprefixed_dirname s) 0) names in
if l = [] then (
let glob_without_ext = undirname glob in
OManager.warning ~wclass:wclass_import (
"%a@\n@[<2> Cannot find any %s that matches the %s %s%s.@]@\n"^^
"@[<2>Hint:@\nPerhaps you forgot to include some directories (-I option).@]"
)
FilePos.pp_pos pos
package_keyword
import_keyword
glob_without_ext
(if "{" ^ glob_without_ext ^ "}" = package_name then "" else Printf.sprintf " (from %s)" package_name)
);
l
) globs in
let results = List.uniq_unsorted ~cmp:Package.compare results in
if String.contains package_name '*' then
verbose "Glob expansion of %s: %a@."
package_name
(Format.pp_list ";" Package.pp) results;
results
let get_compilation_directory () =
if is_separated ()
&& compilation_mode () = `compilation (* no saving in linking mode *)
&& not !after_end_of_separate_compilation
then Some (dirname_from_package !current_package)
else None
let get_compilation_directory_or_current_dir () =
match get_compilation_directory () with
| None -> Filename.current_dir_name
| Some s -> s
let compilation_has_started = ref false
let successfull_compilation = ref false
let reset_successfull_compilation () = successfull_compilation := false
let compilation_is_successfull () = successfull_compilation := true
let clean_up_object =
let pwd = Sys.getcwd () in
fun () ->
Sys.chdir pwd;
match get_compilation_directory () with
| Some d when not !successfull_compilation && !compilation_has_started ->
(* before compilation has started, we haven't created any package
* and it is possible that the package name is not yet defined
* so we can't suppress files *)
(* deletes partial packages *)
if BuildInfos.is_release then
File.remove_rec d
else (
let d_broken = d ^ ".broken" in
try File.remove_rec d_broken;
Unix.rename d d_broken
with _ -> ()
)
| _ ->
()
let () = at_exit clean_up_object
let () = Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ -> exit 2))
let get_deps ?(packages=false) ?(deep=false) () =
match compilation_mode () with
| `init ->
if packages && deep then
List.uniq_unsorted ~cmp:Package.compare
(!package_deep_names_and_more_deeps_names)
else
[]
| `compilation | `linking | `prelude ->
if !after_end_of_separate_compilation then
[]
else
List.uniq_unsorted ~cmp:Package.compare
(match packages, deep with
| true, true -> !package_deep_names_and_more_deeps_names
| true, false -> !package_names_and_more_names
| false, true -> !package_deep_names
| false, false -> !package_names)
let fold_dir_name ?packages ?deep f acc =
List.fold_left (fun acc package -> f acc (find_dir package) package) acc (get_deps ?packages ?deep ())
let iter_dir_name ?packages ?deep f =
List.iter (fun package -> f (find_dir package) package) (get_deps ?packages ?deep ())
let fold_dir ?packages ?deep f acc =
fold_dir_name ?packages ?deep (fun acc dir _package -> f acc dir) acc
let iter_dir ?packages ?deep f =
iter_dir_name ?packages ?deep (fun dir _package -> f dir)
let fold_name ?packages ?deep f acc =
fold_dir_name ?packages ?deep (fun acc _dir package -> f acc package) acc
let iter_name ?packages ?deep f =
iter_dir_name ?packages ?deep (fun _dir package -> f package)
(*--------------------------------------*)
(*--- interacting with object files ----*)
(*--------------------------------------*)
let show_list = ref ([] : (package -> unit) list)
let show_package package =
List.iter (fun f -> f package) !show_list
module type S =
sig
type t
val pass : string
val pp : Format.formatter -> t -> unit
end
module type Raw =
sig
type t
type 'a wrapper
val load1 : package -> t wrapper
val load1_exn : package -> t wrapper
val unset_load1 : package -> unit wrapper
end
module type R =
sig
type 'a wrapper
type t
val iter_with_name : (?optional:bool -> ?packages:bool -> ?deep:bool -> (package -> t -> unit) -> unit) wrapper
val fold_with_name : (?optional:bool -> ?packages:bool -> ?deep:bool -> (package -> 'a -> t -> 'a) -> 'a -> 'a) wrapper
val iter_with_dir : (?optional:bool -> ?packages:bool -> ?deep:bool -> (filename -> t -> unit) -> unit) wrapper
val fold_with_dir : (?optional:bool -> ?packages:bool -> ?deep:bool -> (filename -> 'a -> t -> 'a) -> 'a -> 'a) wrapper
val iter : (?optional:bool -> ?packages:bool -> ?deep:bool -> (t -> unit) -> unit) wrapper
val fold : (?optional:bool -> ?packages:bool -> ?deep:bool -> ('a -> t -> 'a) -> 'a -> 'a) wrapper
val save : ?overwrite:bool -> (t -> unit) wrapper
end
module MakeRaw(S:S) : Raw with type t = S.t and type 'a wrapper = 'a =
struct
type t = S.t
type 'a wrapper = 'a
(* return the content of one package *)
let load1_no_memo ((package_name,pos) as package) =
let name = filename_from_dir (find_dir package) S.pass in
try
if not(File.exists name) then raise Not_found else
let channel = open_in_bin name in
let l1 = input_line channel in
#<If$contains "noerror"> () #<Else>
if l1 <> this_file_version then
error "The package %s was compiled with a different version of the compiler.\n%s : %s vs %s" package_name name l1 this_file_version
#<End>;
let v = (Marshal.from_channel channel : t) in
close_in channel;
v
with
| e ->
error "%a@\n@[<2> An error occurred while trying to read package %s[%s]: %s.@]"
FilePos.pp_pos pos
package_name
name
(Printexc.to_string e)
module M = MakeMemo(Package)
let (load1 : package -> t), _set_load1, unset_load1 = M.memo_but_exn load1_no_memo
let load1_exn x = with_exn (fun () -> load1 x)
end
module Make(S:S) :
sig
include R with type t = S.t and type 'a wrapper = 'a
(* these fields are meant for internal use of this module *)
val load1 : package -> t
val load1_exn : package -> t
val unset_load1 : package -> unit
end =
struct
include MakeRaw(S)
let ref_for_partial_sep = ref None
let load_values ?(optional=false) ?packages ?deep () =
let deps = (get_deps ?packages ?deep ()) in
let load=
match optional with
| true -> List.filter_map
(fun (package_pos) -> try Some (package_pos, load1_exn package_pos) with No_exit _ -> None)
| false -> List.map (fun (package_pos) -> (package_pos, load1 package_pos)) in
let l = load deps in
match compilation_mode () with
| `init ->
(match !ref_for_partial_sep with
| None -> l
| Some v -> l @ [(linking_package,v)])
| `linking | `compilation | `prelude -> l
let iter_with_name ?optional ?packages ?deep f =
List.iter (fun (package_name, value) -> f package_name value) (load_values ?optional ?packages ?deep ())
let iter_with_dir ?optional ?packages ?deep f =
assert (compilation_mode () <> `init);
iter_with_name ?optional ?packages ?deep (fun package value -> f (find_dir package) value)
let iter ?optional ?packages ?deep f =
List.iter (fun (_, value) -> f value) (load_values ?optional ?packages ?deep ())
let fold_with_name ?optional ?packages ?deep f acc =
List.fold_left (fun acc (package_name,value) -> f package_name acc value) acc (load_values ?optional ?packages ?deep ())
let fold_with_dir ?optional ?packages ?deep f acc =
assert (compilation_mode () <> `init);
fold_with_name ?optional ?packages ?deep (fun package acc value -> f (find_dir package) acc value) acc
let fold ?optional ?packages ?deep f acc =
List.fold_left (fun acc (_,value) -> f acc value) acc (load_values ?optional ?packages ?deep ())
(* save the given content in the current package, or raise SaveError if it failed
* (because you have no 'write' rights for instance) *)
let save ?(overwrite=false) t =
match compilation_mode () with
| `linking | `prelude ->
assert (!ref_for_partial_sep = None);
ref_for_partial_sep := Some t
| `init -> ()
| `compilation ->
#<If$minlevel 3>Printf.printf "Saving pass:%s\n%!" S.pass#<End>;
assert(fst !current_package <> ""); (* asserting that the current package has been initialized *)
let file = dirname_from_package !current_package in
let filename = filename_from_package !current_package S.pass in
if not (File.check_create_path filename) then
OManager.error "An error occurred while trying to create the object file %s." file;
if not overwrite then assert (not (File.exists filename));
(* this would break only if the compiler doesn't clean an existing
* object file before compiling it or if someone tries to
* save several times for the same pass *)
let channel = open_out_bin filename in
try
Printf.fprintf channel "%s\n" this_file_version;
Marshal.to_channel channel t [] ;
flush channel ;
close_out channel ;
()
with e ->
OManager.error "An error occurred while outputting to the object file %s: %s" file (Printexc.to_string e)
let show package =
try
let v = load1_exn package in
Format.printf "@[<2>%s:@\n%a@]@\n" S.pass S.pp v
with No_exit _s ->
Format.printf "@[<2>%s:@\nAn error occurred@]@\n" S.pass
let () = show_list := show :: !show_list
end
module MakeRaw0ClientServer(S:S)
= struct
type 'a wrapper = side:[`client|`server] -> 'a
type t = S.t
module SClient = struct
type t = S.t
let pass = S.pass ^ "_client"
let pp = S.pp
end
module SServer = struct
type t = S.t
let pass = S.pass ^ "_server"
let pp = S.pp
end
(* specialized interfaces *)
module Client = Make(SClient)
module Server = Make(SServer)
let select = function
| `client -> (fun client _server -> client)
| `server -> (fun _client server -> server)
let load1 package ~side =
(select side (Client.load1) (Server.load1)) package
let load1_exn package ~side =
(select side (Client.load1_exn) (Server.load1_exn)) package
let unset_load1 package ~side =
(select side (Client.unset_load1) (Server.unset_load1)) package
(* generic interface*)
let iter_with_name ~side = select side Client.iter_with_name Server.iter_with_name
let fold_with_name ~side = select side Client.fold_with_name Server.fold_with_name
let iter_with_dir ~side = select side Client.iter_with_dir Server.iter_with_dir
let fold_with_dir ~side = select side Client.fold_with_dir Server.fold_with_dir
let iter ~side = select side Client.iter Server.iter
let fold ~side = select side Client.fold Server.fold
let save ?overwrite ~side = select side (Client.save ?overwrite) (Server.save ?overwrite)
end
module MakeClientServer(S:S) : R with type t = S.t and type 'a wrapper = side:[`client | `server] -> 'a
= MakeRaw0ClientServer(S)
module MakeRawClientServer(S:S) : Raw with type t = S.t and type 'a wrapper = side:[`client | `server] -> 'a
= MakeRaw0ClientServer(S)