1 (***********************************************************************)
4 (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
6 (* Copyright 2007 Institut National de Recherche en Informatique et *)
7 (* en Automatique. All rights reserved. This file is distributed *)
8 (* under the terms of the Q Public License version 1.0. *)
10 (***********************************************************************)
13 (* Original author: Nicolas Pouillard *)
16 open Pathname.Operators
19 | Arch_dir
of string * 'a
* 'a arch list
20 | Arch_dir_pack
of string * 'a
* 'a arch list
21 | Arch_file
of string * 'a
23 let dir name contents
= Arch_dir
(name
, (), contents
)
24 let dir_pack name contents
= Arch_dir_pack
(name
, (), contents
)
25 let file name
= Arch_file
(name
, ())
29 current_path
: string;
30 include_dirs
: string list
;
34 let join_pack parent base
=
35 if parent
= "" then base
else parent ^
"." ^ base
38 let rec self arch acc
=
40 | Arch_dir_pack
(name
, _
, contents
) ->
41 let acc = { (acc) with for_pack
= join_pack acc.for_pack name
} in
42 let (_
, _
, i
, new_contents
) = self_contents name contents
acc in
43 ([], Arch_dir_pack
(name
, i
, List.rev new_contents
))
44 | Arch_dir
(name
, _
, contents
) ->
45 let (current_path
, include_dirs
, i
, new_contents
) = self_contents name contents
acc in
46 (current_path
:: include_dirs
, Arch_dir
(name
, i
, List.rev new_contents
))
47 | Arch_file
(name
, _
) ->
48 ([], Arch_file
(name
, acc))
49 and self_contents name contents
acc =
50 let current_path = acc.current_path/name
in
51 let include_dirs = if current_path = "" then acc.include_dirs else current_path :: acc.include_dirs in
52 let i = { (acc) with current_path = current_path; include_dirs = include_dirs } in
53 let (include_dirs, new_contents
) =
54 List.fold_left
begin fun (include_dirs, new_contents
) x
->
55 let j = { (i) with include_dirs = include_dirs @ i.include_dirs } in
56 let (include_dirs'
, x'
) = self x
j in
57 (include_dirs @ include_dirs'
, x'
:: new_contents
)
58 end ([], []) contents
in
59 (current_path, include_dirs, i, new_contents
) in
60 let init = { current_path = ""; include_dirs = []; for_pack
= "" } in
63 let rec print print_info f
=
64 let rec print_contents f
=
67 | x
:: xs
-> Format.fprintf f
"@ %a%a" (print print_info
) x
print_contents xs
in
69 | Arch_dir
(name
, info
, contents
) ->
70 Format.fprintf f
"@[<v2>dir %S%a%a@]" name print_info info
print_contents contents
71 | Arch_dir_pack
(name
, info
, contents
) ->
72 Format.fprintf f
"@[<v2>dir_pack %S%a%a@]" name print_info info
print_contents contents
73 | Arch_file
(name
, info
) ->
74 Format.fprintf f
"@[<2>file %S%a@]" name print_info info
76 let print_include_dirs = List.print String.print
79 Format.fprintf f
"@ @[<v2>{ @[<2>current_path =@ %S@];@\
80 \ @[<2>include_dirs =@ %a@];@\
81 \ @[<2>for_pack =@ %S@] }@]"
82 i.current_path print_include_dirs i.include_dirs i.for_pack
86 | Arch_dir_pack
(_
, i, xs
) | Arch_dir
(_
, i, xs
) ->
87 f
i; List.iter
(iter_info f
) xs
88 | Arch_file
(_
, i) -> f
i
90 let rec fold_info f arch
acc =
92 | Arch_dir_pack
(_
, i, xs
) | Arch_dir
(_
, i, xs
) ->
93 List.fold_right
(fold_info f
) xs
(f
i acc)
94 | Arch_file
(_
, i) -> f
i acc
96 module SS
= Set.Make
(String
)
98 let iter_include_dirs arch
=
99 let set = fold_info (fun i -> List.fold_right
SS.add
i.include_dirs) arch
SS.empty
in
100 fun f
-> SS.iter f
set
102 let forpack_flags_of_pathname = ref (fun _
-> N
)
104 let print_table print_value f table
=
105 Format.fprintf f
"@[<hv0>{:@[<hv0>";
106 Hashtbl.iter
begin fun k v
->
108 Format.fprintf f
"@ @[<2>%S =>@ %a@];" k print_value v
;
110 Format.fprintf f
"@]@ :}@]"
112 let print_tables f
(include_dirs_table
, for_pack_table
) =
113 Format.fprintf f
"@[<2>@[<2>include_dirs_table:@ %a@];@ @[<2>for_pack_table: %a@]@]"
114 (print_table (List.print String.print)) include_dirs_table
115 (print_table String.print) for_pack_table
118 let include_dirs_table = Hashtbl.create
17
119 and for_pack_table
= Hashtbl.create
17 in
120 iter_info begin fun i ->
121 Hashtbl.replace
include_dirs_table i.current_path i.include_dirs;
122 Hashtbl.replace for_pack_table
i.current_path i.for_pack
124 let previous_forpack_flags_of_pathname = !forpack_flags_of_pathname in
125 forpack_flags_of_pathname := begin fun m
->
126 let m'
= Pathname.dirname
m in
128 let for_pack = Hashtbl.find for_pack_table
m'
in
129 if for_pack = "" then N
else S
[A
"-for-pack"; A
for_pack]
130 with Not_found
-> previous_forpack_flags_of_pathname m
132 (* Format.eprintf "@[<2>%a@]@." print_tables (include_dirs_table, for_pack_table); *)
133 (include_dirs_table, for_pack_table
)
135 let forpack_flags_of_pathname m = !forpack_flags_of_pathname m