├── .gitignore ├── AUTHORS.txt ├── INSTALL.txt ├── LICENSE ├── Makefile ├── README.markdown ├── README.txt ├── _oasis ├── _tags ├── configure ├── myocamlbuild.ml ├── setup.ml └── src ├── META ├── rbmap.ml ├── rbmap.mli ├── rbset.ml ├── rbset.mli ├── rbtrees.mllib └── rbtrees.odocl /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | rbtrees.docdir 3 | setup.data 4 | -------------------------------------------------------------------------------- /AUTHORS.txt: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: 9366e62aea9f40d4417d7ee52b3e9b21) *) 3 | Authors of ocaml-rbtrees 4 | Benedikt Meurer 5 | (* OASIS_STOP *) 6 | -------------------------------------------------------------------------------- /INSTALL.txt: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: 1540ad8d44b8c9184de31d2526bc233e) *) 3 | This is the INSTALL file for the ocaml-rbtrees distribution. 4 | 5 | This package uses OASIS to generate its build system. See section OASIS for 6 | full information. 7 | 8 | Dependencies 9 | ============ 10 | 11 | In order to compile this package, you will need: 12 | * ocaml for all, doc rbtrees 13 | * findlib 14 | 15 | Installing 16 | ========== 17 | 18 | 1. Uncompress source directory and got to the root of the package 19 | 2. Run 'ocaml setup.ml -configure' 20 | 3. Run 'ocaml setup.ml -build' 21 | 4. Run 'ocaml setup.ml -install' 22 | 23 | Uninstalling 24 | ============ 25 | 26 | 1. Go to the root of the package 27 | 2. Run 'ocaml setup.ml -uninstall' 28 | 29 | OASIS 30 | ===== 31 | 32 | OASIS is a software that helps to write setup.ml using a simple '_oasis' 33 | configuration file. The generated setup only depends on standard OCaml 34 | installation, no additional library is required. 35 | 36 | (* OASIS_STOP *) 37 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2007-2011 Benedikt Meurer. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a 4 | copy of this software and associated documentation files (the "Software"), 5 | to deal in the Software without restriction, including without limitation 6 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 7 | and/or sell copies of the Software, and to permit persons to whom the 8 | Software is furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 14 | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 16 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 18 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 19 | IN THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: bc1e05bfc8b39b664f29dae8dbd3ebbb) 3 | 4 | SETUP = ocaml setup.ml 5 | 6 | build: setup.data 7 | $(SETUP) -build $(BUILDFLAGS) 8 | 9 | doc: setup.data build 10 | $(SETUP) -doc $(DOCFLAGS) 11 | 12 | test: setup.data build 13 | $(SETUP) -test $(TESTFLAGS) 14 | 15 | all: 16 | $(SETUP) -all $(ALLFLAGS) 17 | 18 | install: setup.data 19 | $(SETUP) -install $(INSTALLFLAGS) 20 | 21 | uninstall: setup.data 22 | $(SETUP) -uninstall $(UNINSTALLFLAGS) 23 | 24 | reinstall: setup.data 25 | $(SETUP) -reinstall $(REINSTALLFLAGS) 26 | 27 | clean: 28 | $(SETUP) -clean $(CLEANFLAGS) 29 | 30 | distclean: 31 | $(SETUP) -distclean $(DISTCLEANFLAGS) 32 | 33 | setup.data: 34 | $(SETUP) -configure $(CONFIGUREFLAGS) 35 | 36 | .PHONY: build doc test all install uninstall reinstall clean distclean configure 37 | 38 | # OASIS_STOP 39 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # Red-Black Trees for OCaml 2 | 3 | This is my implementation of Red-Black Trees for OCaml. It is based upon [_Red-Black Trees in a Functional Setting_](http://www.eecs.usma.edu/webs/people/okasaki/pubs.html#jfp99) by [Chris Okasaki](http://www.eecs.usma.edu/webs/people/okasaki/) in _Journal of Functional Programming_, 9(4):471-477, July 1999. 4 | 5 | The Red-Black Trees are exposed via a map and a set API, which is designed to be compatible with the Map and Set modules in the OCaml standard library (which are implemented using AVL trees). You can use the [Rbmap](https://github.com/bmeurer/ocaml-rbtrees/blob/master/src/rbmap.ml) and [Rbset](https://github.com/bmeurer/ocaml-rbtrees/blob/master/src/rbset.ml) modules as drop-in replacement for the Map and Set modules. 6 | 7 | 8 | ## License 9 | 10 | This implementation is licensed under the [MIT License](http://www.opensource.org/licenses/mit-license.php). See the [LICENSE](http://github.com/bmeurer/ocaml-rbtress/raw/master/LICENSE) file for details. 11 | 12 | 13 | ## Bug Reports 14 | 15 | If you come across any problems, please [create a ticket](http://github.com/bmeurer/ocaml-rbtrees/issues) and we will try to get it fixed as soon as possible. 16 | 17 | 18 | ## Contributing 19 | 20 | Once you've made your commits: 21 | 22 | 1. [Fork](http://help.github.com/fork-a-repo/ "Fork a repo") ocaml-rbtrees. 23 | 2. Create a topic branch - `git checkout -b my_branch`. 24 | 3. Push to your topic branch - `git push origin my_branch`. 25 | 4. Create a [Pull Request](http://help.github.com/pull-requests/ "Send pull requests") from your topic branch. 26 | 5. That's it! 27 | 28 | 29 | ## Authors 30 | 31 | Benedikt Meurer :: benedikt.meurer@googlemail.com :: [@bmeurer](http://twitter.com/bmeurer) 32 | 33 | 34 | ## Copyright 35 | 36 | Copyright (c) 2007-2011 Benedikt Meurer. See the [License](http://github.com/bmeurer/ocaml-rbtrees/raw/master/LICENSE) file for details. 37 | 38 | -------------------------------------------------------------------------------- /README.txt: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: 0172573a9fe88116311359991eb3a846) *) 3 | This is the README file for the ocaml-rbtrees distribution. 4 | 5 | (c) 2007-2011 Benedikt Meurer 6 | 7 | An implementation of Red-Black Trees for OCaml 8 | 9 | This is my implementation of Red-Black Trees for OCaml. It is based upon the 10 | implementation described in the paper "Red-Black Trees in a Functional 11 | Setting" by Chris Okasaki published in "Journal of Functional Programming", 12 | 9(4):471-477, July 1999. 13 | 14 | The Red-Black Trees are exposed via a map and a set API, which is designed to 15 | be compatible with the Map and Set modules in the OCaml standard library 16 | (which are implemented using AVL trees). You can use the Rbmap and Rbset 17 | modules as drop-in replacement for the Map and Set modules. 18 | 19 | See the files INSTALL.txt for building and installation instructions. See the 20 | file LICENSE for copying conditions. 21 | 22 | Home page: https://github.com/bmeurer/ocaml-rbtrees/ 23 | 24 | 25 | (* OASIS_STOP *) 26 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | OASISFormat: 0.2 2 | Name: ocaml-rbtrees 3 | Version: 0.2.0+dev 4 | LicenseFile: LICENSE 5 | License: MIT 6 | BuildType: ocamlbuild (0.2) 7 | Authors: Benedikt Meurer 8 | Copyrights: (c) 2007-2011 Benedikt Meurer 9 | Homepage: https://github.com/bmeurer/ocaml-rbtrees/ 10 | Plugins: META (0.2), DevFiles (0.2), StdFiles (0.2) 11 | BuildTools: ocamlbuild 12 | 13 | Synopsis: An implementation of Red-Black Trees for OCaml 14 | Description: 15 | This is my implementation of Red-Black Trees for OCaml. It is based upon 16 | the implementation described in the paper "Red-Black Trees in a Functional 17 | Setting" by Chris Okasaki published in "Journal of Functional Programming", 18 | 9(4):471-477, July 1999. 19 | . 20 | The Red-Black Trees are exposed via a map and a set API, which is designed 21 | to be compatible with the Map and Set modules in the OCaml standard library 22 | (which are implemented using AVL trees). You can use the Rbmap and Rbset 23 | modules as drop-in replacement for the Map and Set modules. 24 | 25 | Library "rbtrees" 26 | Path: src 27 | Modules: Rbmap, Rbset 28 | 29 | Document "rbtrees" 30 | Title: API reference for rbtrees 31 | Type: ocamlbuild (0.2) 32 | InstallDir: $htmldir 33 | BuildTools: ocamldoc 34 | XOCamlbuildPath: src 35 | XOCamlbuildLibraries: rbtrees 36 | 37 | SourceRepository master 38 | Type: git 39 | Branch: master 40 | Browser: https://github.com/bmeurer/ocaml-rbtrees 41 | Location: git://github.com/bmeurer/ocaml-rbtrees.git 42 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 2a2754c277de2590d211c2fd4def4a27) 3 | # Library rbtrees 4 | "src": include 5 | # OASIS_STOP 6 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # OASIS_START 4 | # DO NOT EDIT (digest: ed33e59fe00e48bc31edf413bbc8b8d6) 5 | set -e 6 | 7 | ocaml setup.ml -configure $* 8 | # OASIS_STOP 9 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: 355f8746f6e2fa5246e9e19298d60eff) *) 3 | module OASISGettext = struct 4 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISGettext.ml" 5 | 6 | let ns_ str = 7 | str 8 | 9 | let s_ str = 10 | str 11 | 12 | let f_ (str : ('a, 'b, 'c, 'd) format4) = 13 | str 14 | 15 | let fn_ fmt1 fmt2 n = 16 | if n = 1 then 17 | fmt1^^"" 18 | else 19 | fmt2^^"" 20 | 21 | let init = 22 | [] 23 | 24 | end 25 | 26 | module OASISExpr = struct 27 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISExpr.ml" 28 | 29 | 30 | 31 | open OASISGettext 32 | 33 | type test = string 34 | 35 | type flag = string 36 | 37 | type t = 38 | | EBool of bool 39 | | ENot of t 40 | | EAnd of t * t 41 | | EOr of t * t 42 | | EFlag of flag 43 | | ETest of test * string 44 | 45 | 46 | type 'a choices = (t * 'a) list 47 | 48 | let eval var_get t = 49 | let rec eval' = 50 | function 51 | | EBool b -> 52 | b 53 | 54 | | ENot e -> 55 | not (eval' e) 56 | 57 | | EAnd (e1, e2) -> 58 | (eval' e1) && (eval' e2) 59 | 60 | | EOr (e1, e2) -> 61 | (eval' e1) || (eval' e2) 62 | 63 | | EFlag nm -> 64 | let v = 65 | var_get nm 66 | in 67 | assert(v = "true" || v = "false"); 68 | (v = "true") 69 | 70 | | ETest (nm, vl) -> 71 | let v = 72 | var_get nm 73 | in 74 | (v = vl) 75 | in 76 | eval' t 77 | 78 | let choose ?printer ?name var_get lst = 79 | let rec choose_aux = 80 | function 81 | | (cond, vl) :: tl -> 82 | if eval var_get cond then 83 | vl 84 | else 85 | choose_aux tl 86 | | [] -> 87 | let str_lst = 88 | if lst = [] then 89 | s_ "" 90 | else 91 | String.concat 92 | (s_ ", ") 93 | (List.map 94 | (fun (cond, vl) -> 95 | match printer with 96 | | Some p -> p vl 97 | | None -> s_ "") 98 | lst) 99 | in 100 | match name with 101 | | Some nm -> 102 | failwith 103 | (Printf.sprintf 104 | (f_ "No result for the choice list '%s': %s") 105 | nm str_lst) 106 | | None -> 107 | failwith 108 | (Printf.sprintf 109 | (f_ "No result for a choice list: %s") 110 | str_lst) 111 | in 112 | choose_aux (List.rev lst) 113 | 114 | end 115 | 116 | 117 | module BaseEnvLight = struct 118 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseEnvLight.ml" 119 | 120 | module MapString = Map.Make(String) 121 | 122 | type t = string MapString.t 123 | 124 | let default_filename = 125 | Filename.concat 126 | (Sys.getcwd ()) 127 | "setup.data" 128 | 129 | let load ?(allow_empty=false) ?(filename=default_filename) () = 130 | if Sys.file_exists filename then 131 | begin 132 | let chn = 133 | open_in_bin filename 134 | in 135 | let st = 136 | Stream.of_channel chn 137 | in 138 | let line = 139 | ref 1 140 | in 141 | let st_line = 142 | Stream.from 143 | (fun _ -> 144 | try 145 | match Stream.next st with 146 | | '\n' -> incr line; Some '\n' 147 | | c -> Some c 148 | with Stream.Failure -> None) 149 | in 150 | let lexer = 151 | Genlex.make_lexer ["="] st_line 152 | in 153 | let rec read_file mp = 154 | match Stream.npeek 3 lexer with 155 | | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> 156 | Stream.junk lexer; 157 | Stream.junk lexer; 158 | Stream.junk lexer; 159 | read_file (MapString.add nm value mp) 160 | | [] -> 161 | mp 162 | | _ -> 163 | failwith 164 | (Printf.sprintf 165 | "Malformed data file '%s' line %d" 166 | filename !line) 167 | in 168 | let mp = 169 | read_file MapString.empty 170 | in 171 | close_in chn; 172 | mp 173 | end 174 | else if allow_empty then 175 | begin 176 | MapString.empty 177 | end 178 | else 179 | begin 180 | failwith 181 | (Printf.sprintf 182 | "Unable to load environment, the file '%s' doesn't exist." 183 | filename) 184 | end 185 | 186 | let var_get name env = 187 | let rec var_expand str = 188 | let buff = 189 | Buffer.create ((String.length str) * 2) 190 | in 191 | Buffer.add_substitute 192 | buff 193 | (fun var -> 194 | try 195 | var_expand (MapString.find var env) 196 | with Not_found -> 197 | failwith 198 | (Printf.sprintf 199 | "No variable %s defined when trying to expand %S." 200 | var 201 | str)) 202 | str; 203 | Buffer.contents buff 204 | in 205 | var_expand (MapString.find name env) 206 | 207 | let var_choose lst env = 208 | OASISExpr.choose 209 | (fun nm -> var_get nm env) 210 | lst 211 | end 212 | 213 | 214 | module MyOCamlbuildFindlib = struct 215 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" 216 | 217 | (** OCamlbuild extension, copied from 218 | * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild 219 | * by N. Pouillard and others 220 | * 221 | * Updated on 2009/02/28 222 | * 223 | * Modified by Sylvain Le Gall 224 | *) 225 | open Ocamlbuild_plugin 226 | 227 | (* these functions are not really officially exported *) 228 | let run_and_read = 229 | Ocamlbuild_pack.My_unix.run_and_read 230 | 231 | let blank_sep_strings = 232 | Ocamlbuild_pack.Lexers.blank_sep_strings 233 | 234 | let split s ch = 235 | let x = 236 | ref [] 237 | in 238 | let rec go s = 239 | let pos = 240 | String.index s ch 241 | in 242 | x := (String.before s pos)::!x; 243 | go (String.after s (pos + 1)) 244 | in 245 | try 246 | go s 247 | with Not_found -> !x 248 | 249 | let split_nl s = split s '\n' 250 | 251 | let before_space s = 252 | try 253 | String.before s (String.index s ' ') 254 | with Not_found -> s 255 | 256 | (* this lists all supported packages *) 257 | let find_packages () = 258 | List.map before_space (split_nl & run_and_read "ocamlfind list") 259 | 260 | (* this is supposed to list available syntaxes, but I don't know how to do it. *) 261 | let find_syntaxes () = ["camlp4o"; "camlp4r"] 262 | 263 | (* ocamlfind command *) 264 | let ocamlfind x = S[A"ocamlfind"; x] 265 | 266 | let dispatch = 267 | function 268 | | Before_options -> 269 | (* by using Before_options one let command line options have an higher priority *) 270 | (* on the contrary using After_options will guarantee to have the higher priority *) 271 | (* override default commands by ocamlfind ones *) 272 | Options.ocamlc := ocamlfind & A"ocamlc"; 273 | Options.ocamlopt := ocamlfind & A"ocamlopt"; 274 | Options.ocamldep := ocamlfind & A"ocamldep"; 275 | Options.ocamldoc := ocamlfind & A"ocamldoc"; 276 | Options.ocamlmktop := ocamlfind & A"ocamlmktop" 277 | 278 | | After_rules -> 279 | 280 | (* When one link an OCaml library/binary/package, one should use -linkpkg *) 281 | flag ["ocaml"; "link"; "program"] & A"-linkpkg"; 282 | 283 | (* For each ocamlfind package one inject the -package option when 284 | * compiling, computing dependencies, generating documentation and 285 | * linking. *) 286 | List.iter 287 | begin fun pkg -> 288 | flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; 289 | flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; 290 | flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; 291 | flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; 292 | flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg]; 293 | end 294 | (find_packages ()); 295 | 296 | (* Like -package but for extensions syntax. Morover -syntax is useless 297 | * when linking. *) 298 | List.iter begin fun syntax -> 299 | flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 300 | flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 301 | flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 302 | flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 303 | end (find_syntaxes ()); 304 | 305 | (* The default "thread" tag is not compatible with ocamlfind. 306 | * Indeed, the default rules add the "threads.cma" or "threads.cmxa" 307 | * options when using this tag. When using the "-linkpkg" option with 308 | * ocamlfind, this module will then be added twice on the command line. 309 | * 310 | * To solve this, one approach is to add the "-thread" option when using 311 | * the "threads" package using the previous plugin. 312 | *) 313 | flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); 314 | flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); 315 | flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]) 316 | 317 | | _ -> 318 | () 319 | 320 | end 321 | 322 | module MyOCamlbuildBase = struct 323 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" 324 | 325 | (** Base functions for writing myocamlbuild.ml 326 | @author Sylvain Le Gall 327 | *) 328 | 329 | 330 | 331 | open Ocamlbuild_plugin 332 | 333 | type dir = string 334 | type file = string 335 | type name = string 336 | type tag = string 337 | 338 | # 55 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" 339 | 340 | type t = 341 | { 342 | lib_ocaml: (name * dir list) list; 343 | lib_c: (name * dir * file list) list; 344 | flags: (tag list * (spec OASISExpr.choices)) list; 345 | } 346 | 347 | let env_filename = 348 | Pathname.basename 349 | BaseEnvLight.default_filename 350 | 351 | let dispatch_combine lst = 352 | fun e -> 353 | List.iter 354 | (fun dispatch -> dispatch e) 355 | lst 356 | 357 | let dispatch t e = 358 | let env = 359 | BaseEnvLight.load 360 | ~filename:env_filename 361 | ~allow_empty:true 362 | () 363 | in 364 | match e with 365 | | Before_options -> 366 | let no_trailing_dot s = 367 | if String.length s >= 1 && s.[0] = '.' then 368 | String.sub s 1 ((String.length s) - 1) 369 | else 370 | s 371 | in 372 | List.iter 373 | (fun (opt, var) -> 374 | try 375 | opt := no_trailing_dot (BaseEnvLight.var_get var env) 376 | with Not_found -> 377 | Printf.eprintf "W: Cannot get variable %s" var) 378 | [ 379 | Options.ext_obj, "ext_obj"; 380 | Options.ext_lib, "ext_lib"; 381 | Options.ext_dll, "ext_dll"; 382 | ] 383 | 384 | | After_rules -> 385 | (* Declare OCaml libraries *) 386 | List.iter 387 | (function 388 | | lib, [] -> 389 | ocaml_lib lib; 390 | | lib, dir :: tl -> 391 | ocaml_lib ~dir:dir lib; 392 | List.iter 393 | (fun dir -> 394 | flag 395 | ["ocaml"; "use_"^lib; "compile"] 396 | (S[A"-I"; P dir])) 397 | tl) 398 | t.lib_ocaml; 399 | 400 | (* Declare C libraries *) 401 | List.iter 402 | (fun (lib, dir, headers) -> 403 | (* Handle C part of library *) 404 | flag ["link"; "library"; "ocaml"; "byte"; "use_lib"^lib] 405 | (S[A"-dllib"; A("-l"^lib); A"-cclib"; A("-l"^lib)]); 406 | 407 | flag ["link"; "library"; "ocaml"; "native"; "use_lib"^lib] 408 | (S[A"-cclib"; A("-l"^lib)]); 409 | 410 | flag ["link"; "program"; "ocaml"; "byte"; "use_lib"^lib] 411 | (S[A"-dllib"; A("dll"^lib)]); 412 | 413 | (* When ocaml link something that use the C library, then one 414 | need that file to be up to date. 415 | *) 416 | dep ["link"; "ocaml"; "use_lib"^lib] 417 | [dir/"lib"^lib^"."^(!Options.ext_lib)]; 418 | 419 | (* TODO: be more specific about what depends on headers *) 420 | (* Depends on .h files *) 421 | dep ["compile"; "c"] 422 | headers; 423 | 424 | (* Setup search path for lib *) 425 | flag ["link"; "ocaml"; "use_"^lib] 426 | (S[A"-I"; P(dir)]); 427 | ) 428 | t.lib_c; 429 | 430 | (* Add flags *) 431 | List.iter 432 | (fun (tags, cond_specs) -> 433 | let spec = 434 | BaseEnvLight.var_choose cond_specs env 435 | in 436 | flag tags & spec) 437 | t.flags 438 | | _ -> 439 | () 440 | 441 | let dispatch_default t = 442 | dispatch_combine 443 | [ 444 | dispatch t; 445 | MyOCamlbuildFindlib.dispatch; 446 | ] 447 | 448 | end 449 | 450 | 451 | open Ocamlbuild_plugin;; 452 | let package_default = 453 | { 454 | MyOCamlbuildBase.lib_ocaml = [("src/rbtrees", ["src"])]; 455 | lib_c = []; 456 | flags = []; 457 | } 458 | ;; 459 | 460 | let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; 461 | 462 | (* OASIS_STOP *) 463 | Ocamlbuild_plugin.dispatch dispatch_default;; 464 | -------------------------------------------------------------------------------- /setup.ml: -------------------------------------------------------------------------------- 1 | (* setup.ml generated for the first time by OASIS v0.2.0 *) 2 | 3 | (* OASIS_START *) 4 | (* DO NOT EDIT (digest: b34ddcde722c96bca34fe0ed2104c226) *) 5 | (* 6 | Regenerated by OASIS v0.2.0 7 | Visit http://oasis.forge.ocamlcore.org for more information and 8 | documentation about functions used in this file. 9 | *) 10 | module OASISGettext = struct 11 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISGettext.ml" 12 | 13 | let ns_ str = 14 | str 15 | 16 | let s_ str = 17 | str 18 | 19 | let f_ (str : ('a, 'b, 'c, 'd) format4) = 20 | str 21 | 22 | let fn_ fmt1 fmt2 n = 23 | if n = 1 then 24 | fmt1^^"" 25 | else 26 | fmt2^^"" 27 | 28 | let init = 29 | [] 30 | 31 | end 32 | 33 | module OASISContext = struct 34 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISContext.ml" 35 | 36 | open OASISGettext 37 | 38 | type level = 39 | [ `Debug 40 | | `Info 41 | | `Warning 42 | | `Error] 43 | 44 | type t = 45 | { 46 | verbose: bool; 47 | debug: bool; 48 | ignore_plugins: bool; 49 | printf: level -> string -> unit; 50 | } 51 | 52 | let printf lvl str = 53 | let beg = 54 | match lvl with 55 | | `Error -> s_ "E: " 56 | | `Warning -> s_ "W: " 57 | | `Info -> s_ "I: " 58 | | `Debug -> s_ "D: " 59 | in 60 | match lvl with 61 | | `Error -> 62 | prerr_endline (beg^str) 63 | | _ -> 64 | print_endline (beg^str) 65 | 66 | let default = 67 | ref 68 | { 69 | verbose = true; 70 | debug = false; 71 | ignore_plugins = false; 72 | printf = printf; 73 | } 74 | 75 | let quiet = 76 | {!default with 77 | verbose = false; 78 | debug = false; 79 | } 80 | 81 | 82 | let args () = 83 | ["-quiet", 84 | Arg.Unit (fun () -> default := {!default with verbose = false}), 85 | (s_ " Run quietly"); 86 | 87 | "-debug", 88 | Arg.Unit (fun () -> default := {!default with debug = true}), 89 | (s_ " Output debug message")] 90 | end 91 | 92 | module OASISUtils = struct 93 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISUtils.ml" 94 | 95 | module MapString = Map.Make(String) 96 | 97 | let map_string_of_assoc assoc = 98 | List.fold_left 99 | (fun acc (k, v) -> MapString.add k v acc) 100 | MapString.empty 101 | assoc 102 | 103 | module SetString = Set.Make(String) 104 | 105 | let set_string_add_list st lst = 106 | List.fold_left 107 | (fun acc e -> SetString.add e acc) 108 | st 109 | lst 110 | 111 | let set_string_of_list = 112 | set_string_add_list 113 | SetString.empty 114 | 115 | 116 | let compare_csl s1 s2 = 117 | String.compare (String.lowercase s1) (String.lowercase s2) 118 | 119 | module HashStringCsl = 120 | Hashtbl.Make 121 | (struct 122 | type t = string 123 | 124 | let equal s1 s2 = 125 | (String.lowercase s1) = (String.lowercase s2) 126 | 127 | let hash s = 128 | Hashtbl.hash (String.lowercase s) 129 | end) 130 | 131 | let split sep str = 132 | let str_len = 133 | String.length str 134 | in 135 | let rec split_aux acc pos = 136 | if pos < str_len then 137 | ( 138 | let pos_sep = 139 | try 140 | String.index_from str pos sep 141 | with Not_found -> 142 | str_len 143 | in 144 | let part = 145 | String.sub str pos (pos_sep - pos) 146 | in 147 | let acc = 148 | part :: acc 149 | in 150 | if pos_sep >= str_len then 151 | ( 152 | (* Nothing more in the string *) 153 | List.rev acc 154 | ) 155 | else if pos_sep = (str_len - 1) then 156 | ( 157 | (* String end with a separator *) 158 | List.rev ("" :: acc) 159 | ) 160 | else 161 | ( 162 | split_aux acc (pos_sep + 1) 163 | ) 164 | ) 165 | else 166 | ( 167 | List.rev acc 168 | ) 169 | in 170 | split_aux [] 0 171 | 172 | 173 | let varname_of_string ?(hyphen='_') s = 174 | if String.length s = 0 then 175 | begin 176 | invalid_arg "varname_of_string" 177 | end 178 | else 179 | begin 180 | let buff = 181 | Buffer.create (String.length s) 182 | in 183 | (* Start with a _ if digit *) 184 | if '0' <= s.[0] && s.[0] <= '9' then 185 | Buffer.add_char buff hyphen; 186 | 187 | String.iter 188 | (fun c -> 189 | if ('a' <= c && c <= 'z') 190 | || 191 | ('A' <= c && c <= 'Z') 192 | || 193 | ('0' <= c && c <= '9') then 194 | Buffer.add_char buff c 195 | else 196 | Buffer.add_char buff hyphen) 197 | s; 198 | 199 | String.lowercase (Buffer.contents buff) 200 | end 201 | 202 | let varname_concat ?(hyphen='_') p s = 203 | let p = 204 | let p_len = 205 | String.length p 206 | in 207 | if p_len > 0 && p.[p_len - 1] = hyphen then 208 | String.sub p 0 (p_len - 1) 209 | else 210 | p 211 | in 212 | let s = 213 | let s_len = 214 | String.length s 215 | in 216 | if s_len > 0 && s.[0] = hyphen then 217 | String.sub s 1 (s_len - 1) 218 | else 219 | s 220 | in 221 | Printf.sprintf "%s%c%s" p hyphen s 222 | 223 | 224 | let is_varname str = 225 | str = varname_of_string str 226 | 227 | let failwithf1 fmt a = 228 | failwith (Printf.sprintf fmt a) 229 | 230 | let failwithf2 fmt a b = 231 | failwith (Printf.sprintf fmt a b) 232 | 233 | let failwithf3 fmt a b c = 234 | failwith (Printf.sprintf fmt a b c) 235 | 236 | let failwithf4 fmt a b c d = 237 | failwith (Printf.sprintf fmt a b c d) 238 | 239 | let failwithf5 fmt a b c d e = 240 | failwith (Printf.sprintf fmt a b c d e) 241 | 242 | end 243 | 244 | module PropList = struct 245 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/PropList.ml" 246 | 247 | open OASISGettext 248 | 249 | type name = string 250 | 251 | exception Not_set of name * string option 252 | exception No_printer of name 253 | exception Unknown_field of name * name 254 | 255 | let string_of_exception = 256 | function 257 | | Not_set (nm, Some rsn) -> 258 | Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn 259 | | Not_set (nm, None) -> 260 | Printf.sprintf (f_ "Field '%s' is not set") nm 261 | | No_printer nm -> 262 | Printf.sprintf (f_ "No default printer for value %s") nm 263 | | Unknown_field (nm, schm) -> 264 | Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm 265 | | e -> 266 | raise e 267 | 268 | module Data = 269 | struct 270 | 271 | type t = 272 | (name, unit -> unit) Hashtbl.t 273 | 274 | let create () = 275 | Hashtbl.create 13 276 | 277 | let clear t = 278 | Hashtbl.clear t 279 | 280 | # 59 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/PropList.ml" 281 | end 282 | 283 | module Schema = 284 | struct 285 | 286 | type ('ctxt, 'extra) value = 287 | { 288 | get: Data.t -> string; 289 | set: Data.t -> ?context:'ctxt -> string -> unit; 290 | help: (unit -> string) option; 291 | extra: 'extra; 292 | } 293 | 294 | type ('ctxt, 'extra) t = 295 | { 296 | name: name; 297 | fields: (name, ('ctxt, 'extra) value) Hashtbl.t; 298 | order: name Queue.t; 299 | name_norm: string -> string; 300 | } 301 | 302 | let create ?(case_insensitive=false) nm = 303 | { 304 | name = nm; 305 | fields = Hashtbl.create 13; 306 | order = Queue.create (); 307 | name_norm = 308 | (if case_insensitive then 309 | String.lowercase 310 | else 311 | fun s -> s); 312 | } 313 | 314 | let add t nm set get extra help = 315 | let key = 316 | t.name_norm nm 317 | in 318 | 319 | if Hashtbl.mem t.fields key then 320 | failwith 321 | (Printf.sprintf 322 | (f_ "Field '%s' is already defined in schema '%s'") 323 | nm t.name); 324 | Hashtbl.add 325 | t.fields 326 | key 327 | { 328 | set = set; 329 | get = get; 330 | help = help; 331 | extra = extra; 332 | }; 333 | Queue.add nm t.order 334 | 335 | let mem t nm = 336 | Hashtbl.mem t.fields nm 337 | 338 | let find t nm = 339 | try 340 | Hashtbl.find t.fields (t.name_norm nm) 341 | with Not_found -> 342 | raise (Unknown_field (nm, t.name)) 343 | 344 | let get t data nm = 345 | (find t nm).get data 346 | 347 | let set t data nm ?context x = 348 | (find t nm).set 349 | data 350 | ?context 351 | x 352 | 353 | let fold f acc t = 354 | Queue.fold 355 | (fun acc k -> 356 | let v = 357 | find t k 358 | in 359 | f acc k v.extra v.help) 360 | acc 361 | t.order 362 | 363 | let iter f t = 364 | fold 365 | (fun () -> f) 366 | () 367 | t 368 | 369 | let name t = 370 | t.name 371 | end 372 | 373 | module Field = 374 | struct 375 | 376 | type ('ctxt, 'value, 'extra) t = 377 | { 378 | set: Data.t -> ?context:'ctxt -> 'value -> unit; 379 | get: Data.t -> 'value; 380 | sets: Data.t -> ?context:'ctxt -> string -> unit; 381 | gets: Data.t -> string; 382 | help: (unit -> string) option; 383 | extra: 'extra; 384 | } 385 | 386 | let new_id = 387 | let last_id = 388 | ref 0 389 | in 390 | fun () -> incr last_id; !last_id 391 | 392 | let create ?schema ?name ?parse ?print ?default ?update ?help extra = 393 | (* Default value container *) 394 | let v = 395 | ref None 396 | in 397 | 398 | (* If name is not given, create unique one *) 399 | let nm = 400 | match name with 401 | | Some s -> s 402 | | None -> Printf.sprintf "_anon_%d" (new_id ()) 403 | in 404 | 405 | (* Last chance to get a value: the default *) 406 | let default () = 407 | match default with 408 | | Some d -> d 409 | | None -> raise (Not_set (nm, Some (s_ "no default value"))) 410 | in 411 | 412 | (* Get data *) 413 | let get data = 414 | (* Get value *) 415 | try 416 | (Hashtbl.find data nm) (); 417 | match !v with 418 | | Some x -> x 419 | | None -> default () 420 | with Not_found -> 421 | default () 422 | in 423 | 424 | (* Set data *) 425 | let set data ?context x = 426 | let x = 427 | match update with 428 | | Some f -> 429 | begin 430 | try 431 | f ?context (get data) x 432 | with Not_set _ -> 433 | x 434 | end 435 | | None -> 436 | x 437 | in 438 | Hashtbl.replace 439 | data 440 | nm 441 | (fun () -> v := Some x) 442 | in 443 | 444 | (* Parse string value, if possible *) 445 | let parse = 446 | match parse with 447 | | Some f -> 448 | f 449 | | None -> 450 | fun ?context s -> 451 | failwith 452 | (Printf.sprintf 453 | (f_ "Cannot parse field '%s' when setting value %S") 454 | nm 455 | s) 456 | in 457 | 458 | (* Set data, from string *) 459 | let sets data ?context s = 460 | set ?context data (parse ?context s) 461 | in 462 | 463 | (* Output value as string, if possible *) 464 | let print = 465 | match print with 466 | | Some f -> 467 | f 468 | | None -> 469 | fun _ -> raise (No_printer nm) 470 | in 471 | 472 | (* Get data, as a string *) 473 | let gets data = 474 | print (get data) 475 | in 476 | 477 | begin 478 | match schema with 479 | | Some t -> 480 | Schema.add t nm sets gets extra help 481 | | None -> 482 | () 483 | end; 484 | 485 | { 486 | set = set; 487 | get = get; 488 | sets = sets; 489 | gets = gets; 490 | help = help; 491 | extra = extra; 492 | } 493 | 494 | let fset data t ?context x = 495 | t.set data ?context x 496 | 497 | let fget data t = 498 | t.get data 499 | 500 | let fsets data t ?context s = 501 | t.sets data ?context s 502 | 503 | let fgets data t = 504 | t.gets data 505 | 506 | end 507 | 508 | module FieldRO = 509 | struct 510 | 511 | let create ?schema ?name ?parse ?print ?default ?update ?help extra = 512 | let fld = 513 | Field.create ?schema ?name ?parse ?print ?default ?update ?help extra 514 | in 515 | fun data -> Field.fget data fld 516 | 517 | end 518 | end 519 | 520 | module OASISMessage = struct 521 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISMessage.ml" 522 | 523 | 524 | open OASISGettext 525 | open OASISContext 526 | 527 | let generic_message ~ctxt lvl fmt = 528 | let cond = 529 | match lvl with 530 | | `Debug -> ctxt.debug 531 | | _ -> ctxt.verbose 532 | in 533 | Printf.ksprintf 534 | (fun str -> 535 | if cond then 536 | begin 537 | ctxt.printf lvl str 538 | end) 539 | fmt 540 | 541 | let debug ~ctxt fmt = 542 | generic_message ~ctxt `Debug fmt 543 | 544 | let info ~ctxt fmt = 545 | generic_message ~ctxt `Info fmt 546 | 547 | let warning ~ctxt fmt = 548 | generic_message ~ctxt `Warning fmt 549 | 550 | let error ~ctxt fmt = 551 | generic_message ~ctxt `Error fmt 552 | 553 | 554 | let string_of_exception e = 555 | try 556 | PropList.string_of_exception e 557 | with 558 | | Failure s -> 559 | s 560 | | e -> 561 | Printexc.to_string e 562 | 563 | (* TODO 564 | let register_exn_printer f = 565 | *) 566 | 567 | end 568 | 569 | module OASISVersion = struct 570 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISVersion.ml" 571 | 572 | open OASISGettext 573 | 574 | 575 | 576 | type s = string 577 | 578 | type t = string 579 | 580 | type comparator = 581 | | VGreater of t 582 | | VGreaterEqual of t 583 | | VEqual of t 584 | | VLesser of t 585 | | VLesserEqual of t 586 | | VOr of comparator * comparator 587 | | VAnd of comparator * comparator 588 | 589 | 590 | (* Range of allowed characters *) 591 | let is_digit c = 592 | '0' <= c && c <= '9' 593 | 594 | let is_alpha c = 595 | ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') 596 | 597 | let is_special = 598 | function 599 | | '.' | '+' | '-' | '~' -> true 600 | | _ -> false 601 | 602 | let rec version_compare v1 v2 = 603 | if v1 <> "" || v2 <> "" then 604 | begin 605 | (* Compare ascii string, using special meaning for version 606 | * related char 607 | *) 608 | let val_ascii c = 609 | if c = '~' then -1 610 | else if is_digit c then 0 611 | else if c = '\000' then 0 612 | else if is_alpha c then Char.code c 613 | else (Char.code c) + 256 614 | in 615 | 616 | let len1 = String.length v1 in 617 | let len2 = String.length v2 in 618 | 619 | let p = ref 0 in 620 | 621 | (** Compare ascii part *) 622 | let compare_vascii () = 623 | let cmp = ref 0 in 624 | while !cmp = 0 && 625 | !p < len1 && !p < len2 && 626 | not (is_digit v1.[!p] && is_digit v2.[!p]) do 627 | cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); 628 | incr p 629 | done; 630 | if !cmp = 0 && !p < len1 && !p = len2 then 631 | val_ascii v1.[!p] 632 | else if !cmp = 0 && !p = len1 && !p < len2 then 633 | - (val_ascii v2.[!p]) 634 | else 635 | !cmp 636 | in 637 | 638 | (** Compare digit part *) 639 | let compare_digit () = 640 | let extract_int v p = 641 | let start_p = !p in 642 | while !p < String.length v && is_digit v.[!p] do 643 | incr p 644 | done; 645 | match String.sub v start_p (!p - start_p) with 646 | | "" -> 0, 647 | v 648 | | s -> int_of_string s, 649 | String.sub v !p ((String.length v) - !p) 650 | in 651 | let i1, tl1 = extract_int v1 (ref !p) in 652 | let i2, tl2 = extract_int v2 (ref !p) in 653 | i1 - i2, tl1, tl2 654 | in 655 | 656 | match compare_vascii () with 657 | | 0 -> 658 | begin 659 | match compare_digit () with 660 | | 0, tl1, tl2 -> 661 | if tl1 <> "" && is_digit tl1.[0] then 662 | 1 663 | else if tl2 <> "" && is_digit tl2.[0] then 664 | -1 665 | else 666 | version_compare tl1 tl2 667 | | n, _, _ -> 668 | n 669 | end 670 | | n -> 671 | n 672 | end 673 | else 674 | begin 675 | 0 676 | end 677 | 678 | 679 | let version_of_string str = 680 | String.iter 681 | (fun c -> 682 | if is_alpha c || is_digit c || is_special c then 683 | () 684 | else 685 | failwith 686 | (Printf.sprintf 687 | (f_ "Char %C is not allowed in version '%s'") 688 | c str)) 689 | str; 690 | str 691 | 692 | let string_of_version t = 693 | t 694 | 695 | let chop t = 696 | try 697 | let pos = 698 | String.rindex t '.' 699 | in 700 | String.sub t 0 pos 701 | with Not_found -> 702 | t 703 | 704 | let rec comparator_apply v op = 705 | match op with 706 | | VGreater cv -> 707 | (version_compare v cv) > 0 708 | | VGreaterEqual cv -> 709 | (version_compare v cv) >= 0 710 | | VLesser cv -> 711 | (version_compare v cv) < 0 712 | | VLesserEqual cv -> 713 | (version_compare v cv) <= 0 714 | | VEqual cv -> 715 | (version_compare v cv) = 0 716 | | VOr (op1, op2) -> 717 | (comparator_apply v op1) || (comparator_apply v op2) 718 | | VAnd (op1, op2) -> 719 | (comparator_apply v op1) && (comparator_apply v op2) 720 | 721 | let rec string_of_comparator = 722 | function 723 | | VGreater v -> "> "^(string_of_version v) 724 | | VEqual v -> "= "^(string_of_version v) 725 | | VLesser v -> "< "^(string_of_version v) 726 | | VGreaterEqual v -> ">= "^(string_of_version v) 727 | | VLesserEqual v -> "<= "^(string_of_version v) 728 | | VOr (c1, c2) -> 729 | (string_of_comparator c1)^" || "^(string_of_comparator c2) 730 | | VAnd (c1, c2) -> 731 | (string_of_comparator c1)^" && "^(string_of_comparator c2) 732 | 733 | let rec varname_of_comparator = 734 | let concat p v = 735 | OASISUtils.varname_concat 736 | p 737 | (OASISUtils.varname_of_string 738 | (string_of_version v)) 739 | in 740 | function 741 | | VGreater v -> concat "gt" v 742 | | VLesser v -> concat "lt" v 743 | | VEqual v -> concat "eq" v 744 | | VGreaterEqual v -> concat "ge" v 745 | | VLesserEqual v -> concat "le" v 746 | | VOr (c1, c2) -> 747 | (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) 748 | | VAnd (c1, c2) -> 749 | (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) 750 | 751 | end 752 | 753 | module OASISLicense = struct 754 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISLicense.ml" 755 | 756 | (** License for _oasis fields 757 | @author Sylvain Le Gall 758 | *) 759 | 760 | 761 | 762 | type license = string 763 | 764 | type license_exception = string 765 | 766 | type license_version = 767 | | Version of OASISVersion.t 768 | | VersionOrLater of OASISVersion.t 769 | | NoVersion 770 | 771 | 772 | type license_dep_5 = 773 | { 774 | license: license; 775 | exceptions: license_exception list; 776 | version: license_version; 777 | } 778 | 779 | type t = 780 | | DEP5License of license_dep_5 781 | | OtherLicense of string (* URL *) 782 | 783 | 784 | end 785 | 786 | module OASISExpr = struct 787 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISExpr.ml" 788 | 789 | 790 | 791 | open OASISGettext 792 | 793 | type test = string 794 | 795 | type flag = string 796 | 797 | type t = 798 | | EBool of bool 799 | | ENot of t 800 | | EAnd of t * t 801 | | EOr of t * t 802 | | EFlag of flag 803 | | ETest of test * string 804 | 805 | 806 | type 'a choices = (t * 'a) list 807 | 808 | let eval var_get t = 809 | let rec eval' = 810 | function 811 | | EBool b -> 812 | b 813 | 814 | | ENot e -> 815 | not (eval' e) 816 | 817 | | EAnd (e1, e2) -> 818 | (eval' e1) && (eval' e2) 819 | 820 | | EOr (e1, e2) -> 821 | (eval' e1) || (eval' e2) 822 | 823 | | EFlag nm -> 824 | let v = 825 | var_get nm 826 | in 827 | assert(v = "true" || v = "false"); 828 | (v = "true") 829 | 830 | | ETest (nm, vl) -> 831 | let v = 832 | var_get nm 833 | in 834 | (v = vl) 835 | in 836 | eval' t 837 | 838 | let choose ?printer ?name var_get lst = 839 | let rec choose_aux = 840 | function 841 | | (cond, vl) :: tl -> 842 | if eval var_get cond then 843 | vl 844 | else 845 | choose_aux tl 846 | | [] -> 847 | let str_lst = 848 | if lst = [] then 849 | s_ "" 850 | else 851 | String.concat 852 | (s_ ", ") 853 | (List.map 854 | (fun (cond, vl) -> 855 | match printer with 856 | | Some p -> p vl 857 | | None -> s_ "") 858 | lst) 859 | in 860 | match name with 861 | | Some nm -> 862 | failwith 863 | (Printf.sprintf 864 | (f_ "No result for the choice list '%s': %s") 865 | nm str_lst) 866 | | None -> 867 | failwith 868 | (Printf.sprintf 869 | (f_ "No result for a choice list: %s") 870 | str_lst) 871 | in 872 | choose_aux (List.rev lst) 873 | 874 | end 875 | 876 | module OASISTypes = struct 877 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISTypes.ml" 878 | 879 | 880 | 881 | 882 | type name = string 883 | type package_name = string 884 | type url = string 885 | type unix_dirname = string 886 | type unix_filename = string 887 | type host_dirname = string 888 | type host_filename = string 889 | type prog = string 890 | type arg = string 891 | type args = string list 892 | type command_line = (prog * arg list) 893 | 894 | type findlib_name = string 895 | type findlib_full = string 896 | 897 | type compiled_object = 898 | | Byte 899 | | Native 900 | | Best 901 | 902 | 903 | type dependency = 904 | | FindlibPackage of findlib_full * OASISVersion.comparator option 905 | | InternalLibrary of name 906 | 907 | 908 | type tool = 909 | | ExternalTool of name 910 | | InternalExecutable of name 911 | 912 | 913 | type vcs = 914 | | Darcs 915 | | Git 916 | | Svn 917 | | Cvs 918 | | Hg 919 | | Bzr 920 | | Arch 921 | | Monotone 922 | | OtherVCS of url 923 | 924 | 925 | type plugin_kind = 926 | [ `Configure 927 | | `Build 928 | | `Doc 929 | | `Test 930 | | `Install 931 | | `Extra 932 | ] 933 | 934 | type plugin_data_purpose = 935 | [ `Configure 936 | | `Build 937 | | `Install 938 | | `Clean 939 | | `Distclean 940 | | `Install 941 | | `Uninstall 942 | | `Test 943 | | `Doc 944 | | `Extra 945 | | `Other of string 946 | ] 947 | 948 | type 'a plugin = 'a * name * OASISVersion.t option 949 | 950 | type all_plugin = plugin_kind plugin 951 | 952 | type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list 953 | 954 | # 102 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISTypes.ml" 955 | 956 | type 'a conditional = 'a OASISExpr.choices 957 | 958 | type custom = 959 | { 960 | pre_command: (command_line option) conditional; 961 | post_command: (command_line option) conditional; 962 | } 963 | 964 | 965 | type common_section = 966 | { 967 | cs_name: name; 968 | cs_data: PropList.Data.t; 969 | cs_plugin_data: plugin_data; 970 | } 971 | 972 | 973 | type build_section = 974 | { 975 | bs_build: bool conditional; 976 | bs_install: bool conditional; 977 | bs_path: unix_dirname; 978 | bs_compiled_object: compiled_object; 979 | bs_build_depends: dependency list; 980 | bs_build_tools: tool list; 981 | bs_c_sources: unix_filename list; 982 | bs_data_files: (unix_filename * unix_filename option) list; 983 | bs_ccopt: args conditional; 984 | bs_cclib: args conditional; 985 | bs_dlllib: args conditional; 986 | bs_dllpath: args conditional; 987 | bs_byteopt: args conditional; 988 | bs_nativeopt: args conditional; 989 | } 990 | 991 | 992 | type library = 993 | { 994 | lib_modules: string list; 995 | lib_internal_modules: string list; 996 | lib_findlib_parent: findlib_name option; 997 | lib_findlib_name: findlib_name option; 998 | lib_findlib_containers: findlib_name list; 999 | } 1000 | 1001 | type executable = 1002 | { 1003 | exec_custom: bool; 1004 | exec_main_is: unix_filename; 1005 | } 1006 | 1007 | type flag = 1008 | { 1009 | flag_description: string option; 1010 | flag_default: bool conditional; 1011 | } 1012 | 1013 | type source_repository = 1014 | { 1015 | src_repo_type: vcs; 1016 | src_repo_location: url; 1017 | src_repo_browser: url option; 1018 | src_repo_module: string option; 1019 | src_repo_branch: string option; 1020 | src_repo_tag: string option; 1021 | src_repo_subdir: unix_filename option; 1022 | } 1023 | 1024 | type test = 1025 | { 1026 | test_type: [`Test] plugin; 1027 | test_command: command_line conditional; 1028 | test_custom: custom; 1029 | test_working_directory: unix_filename option; 1030 | test_run: bool conditional; 1031 | test_tools: tool list; 1032 | } 1033 | 1034 | type doc_format = 1035 | | HTML of unix_filename 1036 | | DocText 1037 | | PDF 1038 | | PostScript 1039 | | Info of unix_filename 1040 | | DVI 1041 | | OtherDoc 1042 | 1043 | 1044 | type doc = 1045 | { 1046 | doc_type: [`Doc] plugin; 1047 | doc_custom: custom; 1048 | doc_build: bool conditional; 1049 | doc_install: bool conditional; 1050 | doc_install_dir: unix_filename; 1051 | doc_title: string; 1052 | doc_authors: string list; 1053 | doc_abstract: string option; 1054 | doc_format: doc_format; 1055 | doc_data_files: (unix_filename * unix_filename option) list; 1056 | doc_build_tools: tool list; 1057 | } 1058 | 1059 | type section = 1060 | | Library of common_section * build_section * library 1061 | | Executable of common_section * build_section * executable 1062 | | Flag of common_section * flag 1063 | | SrcRepo of common_section * source_repository 1064 | | Test of common_section * test 1065 | | Doc of common_section * doc 1066 | 1067 | 1068 | type package = 1069 | { 1070 | oasis_version: OASISVersion.t; 1071 | ocaml_version: OASISVersion.comparator option; 1072 | findlib_version: OASISVersion.comparator option; 1073 | name: package_name; 1074 | version: OASISVersion.t; 1075 | license: OASISLicense.t; 1076 | license_file: unix_filename option; 1077 | copyrights: string list; 1078 | maintainers: string list; 1079 | authors: string list; 1080 | homepage: url option; 1081 | synopsis: string; 1082 | description: string option; 1083 | categories: url list; 1084 | 1085 | conf_type: [`Configure] plugin; 1086 | conf_custom: custom; 1087 | 1088 | build_type: [`Build] plugin; 1089 | build_custom: custom; 1090 | 1091 | install_type: [`Install] plugin; 1092 | install_custom: custom; 1093 | uninstall_custom: custom; 1094 | 1095 | clean_custom: custom; 1096 | distclean_custom: custom; 1097 | 1098 | files_ab: unix_filename list; 1099 | sections: section list; 1100 | plugins: [`Extra] plugin list; 1101 | schema_data: PropList.Data.t; 1102 | plugin_data: plugin_data; 1103 | } 1104 | 1105 | end 1106 | 1107 | module OASISUnixPath = struct 1108 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISUnixPath.ml" 1109 | 1110 | type unix_filename = string 1111 | type unix_dirname = string 1112 | 1113 | type host_filename = string 1114 | type host_dirname = string 1115 | 1116 | let current_dir_name = "." 1117 | 1118 | let parent_dir_name = ".." 1119 | 1120 | let concat f1 f2 = 1121 | if f1 = current_dir_name then 1122 | f2 1123 | else if f2 = current_dir_name then 1124 | f1 1125 | else 1126 | f1^"/"^f2 1127 | 1128 | let make = 1129 | function 1130 | | hd :: tl -> 1131 | List.fold_left 1132 | (fun f p -> concat f p) 1133 | hd 1134 | tl 1135 | | [] -> 1136 | invalid_arg "OASISUnixPath.make" 1137 | 1138 | let dirname f = 1139 | try 1140 | String.sub f 0 (String.rindex f '/') 1141 | with Not_found -> 1142 | current_dir_name 1143 | 1144 | let basename f = 1145 | try 1146 | let pos_start = 1147 | (String.rindex f '/') + 1 1148 | in 1149 | String.sub f pos_start ((String.length f) - pos_start) 1150 | with Not_found -> 1151 | f 1152 | 1153 | let chop_extension f = 1154 | try 1155 | let last_dot = 1156 | String.rindex f '.' 1157 | in 1158 | let sub = 1159 | String.sub f 0 last_dot 1160 | in 1161 | try 1162 | let last_slash = 1163 | String.rindex f '/' 1164 | in 1165 | if last_slash < last_dot then 1166 | sub 1167 | else 1168 | f 1169 | with Not_found -> 1170 | sub 1171 | 1172 | with Not_found -> 1173 | f 1174 | 1175 | end 1176 | 1177 | module OASISSection = struct 1178 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISSection.ml" 1179 | 1180 | (** Manipulate section 1181 | @author Sylvain Le Gall 1182 | *) 1183 | 1184 | open OASISTypes 1185 | 1186 | type section_kind = 1187 | | KLibrary 1188 | | KExecutable 1189 | | KFlag 1190 | | KSrcRepo 1191 | | KTest 1192 | | KDoc 1193 | 1194 | (** Extract generic information 1195 | *) 1196 | let section_kind_common = 1197 | function 1198 | | Library (cs, _, _) -> 1199 | KLibrary, cs 1200 | | Executable (cs, _, _) -> 1201 | KExecutable, cs 1202 | | Flag (cs, _) -> 1203 | KFlag, cs 1204 | | SrcRepo (cs, _) -> 1205 | KSrcRepo, cs 1206 | | Test (cs, _) -> 1207 | KTest, cs 1208 | | Doc (cs, _) -> 1209 | KDoc, cs 1210 | 1211 | (** Common section of a section 1212 | *) 1213 | let section_common sct = 1214 | snd (section_kind_common sct) 1215 | 1216 | (** Key used to identify section 1217 | *) 1218 | let section_id sct = 1219 | let k, cs = 1220 | section_kind_common sct 1221 | in 1222 | k, cs.cs_name 1223 | 1224 | let string_of_section sct = 1225 | let k, nm = 1226 | section_id sct 1227 | in 1228 | (match k with 1229 | | KLibrary -> "library" 1230 | | KExecutable -> "executable" 1231 | | KFlag -> "flag" 1232 | | KSrcRepo -> "src repository" 1233 | | KTest -> "test" 1234 | | KDoc -> "doc") 1235 | ^" "^nm 1236 | 1237 | end 1238 | 1239 | module OASISBuildSection = struct 1240 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISBuildSection.ml" 1241 | 1242 | end 1243 | 1244 | module OASISExecutable = struct 1245 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISExecutable.ml" 1246 | 1247 | open OASISTypes 1248 | 1249 | let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = 1250 | let dir = 1251 | OASISUnixPath.concat 1252 | bs.bs_path 1253 | (OASISUnixPath.dirname exec.exec_main_is) 1254 | in 1255 | let is_native_exec = 1256 | match bs.bs_compiled_object with 1257 | | Native -> true 1258 | | Best -> is_native () 1259 | | Byte -> false 1260 | in 1261 | 1262 | OASISUnixPath.concat 1263 | dir 1264 | (cs.cs_name^(suffix_program ())), 1265 | 1266 | if not is_native_exec && 1267 | not exec.exec_custom && 1268 | bs.bs_c_sources <> [] then 1269 | Some (dir^"/dll"^cs.cs_name^(ext_dll ())) 1270 | else 1271 | None 1272 | 1273 | end 1274 | 1275 | module OASISLibrary = struct 1276 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISLibrary.ml" 1277 | 1278 | open OASISTypes 1279 | open OASISUtils 1280 | open OASISGettext 1281 | 1282 | type library_name = name 1283 | 1284 | let generated_unix_files ~ctxt (cs, bs, lib) 1285 | source_file_exists is_native ext_lib ext_dll = 1286 | (* The headers that should be compiled along *) 1287 | let headers = 1288 | List.fold_left 1289 | (fun hdrs modul -> 1290 | try 1291 | let base_fn = 1292 | List.find 1293 | (fun fn -> 1294 | source_file_exists (fn^".ml") || 1295 | source_file_exists (fn^".mli") || 1296 | source_file_exists (fn^".mll") || 1297 | source_file_exists (fn^".mly")) 1298 | (List.map 1299 | (OASISUnixPath.concat bs.bs_path) 1300 | [modul; 1301 | String.uncapitalize modul; 1302 | String.capitalize modul]) 1303 | in 1304 | [base_fn^".cmi"] :: hdrs 1305 | with Not_found -> 1306 | OASISMessage.warning 1307 | ~ctxt 1308 | (f_ "Cannot find source file matching \ 1309 | module '%s' in library %s") 1310 | modul cs.cs_name; 1311 | (List.map (OASISUnixPath.concat bs.bs_path) 1312 | [modul^".cmi"; 1313 | String.uncapitalize modul ^ ".cmi"; 1314 | String.capitalize modul ^ ".cmi"]) 1315 | :: hdrs) 1316 | [] 1317 | lib.lib_modules 1318 | in 1319 | 1320 | let acc_nopath = 1321 | [] 1322 | in 1323 | 1324 | (* Compute what libraries should be built *) 1325 | let acc_nopath = 1326 | let byte acc = 1327 | [cs.cs_name^".cma"] :: acc 1328 | in 1329 | let native acc = 1330 | [cs.cs_name^".cmxa"] :: [cs.cs_name^(ext_lib ())] :: acc 1331 | in 1332 | match bs.bs_compiled_object with 1333 | | Native -> 1334 | byte (native acc_nopath) 1335 | | Best when is_native () -> 1336 | byte (native acc_nopath) 1337 | | Byte | Best -> 1338 | byte acc_nopath 1339 | in 1340 | 1341 | (* Add C library to be built *) 1342 | let acc_nopath = 1343 | if bs.bs_c_sources <> [] then 1344 | begin 1345 | ["lib"^cs.cs_name^(ext_lib ())] 1346 | :: 1347 | ["dll"^cs.cs_name^(ext_dll ())] 1348 | :: 1349 | acc_nopath 1350 | end 1351 | else 1352 | acc_nopath 1353 | in 1354 | 1355 | (* All the files generated *) 1356 | List.rev_append 1357 | (List.rev_map 1358 | (List.rev_map 1359 | (OASISUnixPath.concat bs.bs_path)) 1360 | acc_nopath) 1361 | headers 1362 | 1363 | 1364 | type group_t = 1365 | | Container of findlib_name * (group_t list) 1366 | | Package of (findlib_name * 1367 | common_section * 1368 | build_section * 1369 | library * 1370 | (group_t list)) 1371 | 1372 | let group_libs pkg = 1373 | (** Associate a name with its children *) 1374 | let children = 1375 | List.fold_left 1376 | (fun mp -> 1377 | function 1378 | | Library (cs, bs, lib) -> 1379 | begin 1380 | match lib.lib_findlib_parent with 1381 | | Some p_nm -> 1382 | begin 1383 | let children = 1384 | try 1385 | MapString.find p_nm mp 1386 | with Not_found -> 1387 | [] 1388 | in 1389 | MapString.add p_nm ((cs, bs, lib) :: children) mp 1390 | end 1391 | | None -> 1392 | mp 1393 | end 1394 | | _ -> 1395 | mp) 1396 | MapString.empty 1397 | pkg.sections 1398 | in 1399 | 1400 | (* Compute findlib name of a single node *) 1401 | let findlib_name (cs, _, lib) = 1402 | match lib.lib_findlib_name with 1403 | | Some nm -> nm 1404 | | None -> cs.cs_name 1405 | in 1406 | 1407 | (** Build a package tree *) 1408 | let rec tree_of_library containers ((cs, bs, lib) as acc) = 1409 | match containers with 1410 | | hd :: tl -> 1411 | Container (hd, [tree_of_library tl acc]) 1412 | | [] -> 1413 | (* TODO: allow merging containers with the same 1414 | * name 1415 | *) 1416 | Package 1417 | (findlib_name acc, cs, bs, lib, 1418 | (try 1419 | List.rev_map 1420 | (fun ((_, _, child_lib) as child_acc) -> 1421 | tree_of_library 1422 | child_lib.lib_findlib_containers 1423 | child_acc) 1424 | (MapString.find cs.cs_name children) 1425 | with Not_found -> 1426 | [])) 1427 | in 1428 | 1429 | (* TODO: check that libraries are unique *) 1430 | List.fold_left 1431 | (fun acc -> 1432 | function 1433 | | Library (cs, bs, lib) when lib.lib_findlib_parent = None -> 1434 | (tree_of_library lib.lib_findlib_containers (cs, bs, lib)) :: acc 1435 | | _ -> 1436 | acc) 1437 | [] 1438 | pkg.sections 1439 | 1440 | (** Compute internal to findlib library matchings, including subpackage 1441 | and return a map of it. 1442 | *) 1443 | let findlib_name_map pkg = 1444 | 1445 | (* Compute names in a tree *) 1446 | let rec findlib_names_aux path mp grp = 1447 | let fndlb_nm, children, mp = 1448 | match grp with 1449 | | Container (fndlb_nm, children) -> 1450 | fndlb_nm, children, mp 1451 | 1452 | | Package (fndlb_nm, {cs_name = nm}, _, _, children) -> 1453 | fndlb_nm, children, (MapString.add nm (path, fndlb_nm) mp) 1454 | in 1455 | let fndlb_nm_full = 1456 | (match path with 1457 | | Some pth -> pth^"." 1458 | | None -> "")^ 1459 | fndlb_nm 1460 | in 1461 | List.fold_left 1462 | (findlib_names_aux (Some fndlb_nm_full)) 1463 | mp 1464 | children 1465 | in 1466 | 1467 | List.fold_left 1468 | (findlib_names_aux None) 1469 | MapString.empty 1470 | (group_libs pkg) 1471 | 1472 | 1473 | let findlib_of_name ?(recurse=false) map nm = 1474 | try 1475 | let (path, fndlb_nm) = 1476 | MapString.find nm map 1477 | in 1478 | match path with 1479 | | Some pth when recurse -> pth^"."^fndlb_nm 1480 | | _ -> fndlb_nm 1481 | 1482 | with Not_found -> 1483 | failwithf1 1484 | (f_ "Unable to translate internal library '%s' to findlib name") 1485 | nm 1486 | 1487 | let name_findlib_map pkg = 1488 | let mp = 1489 | findlib_name_map pkg 1490 | in 1491 | MapString.fold 1492 | (fun nm _ acc -> 1493 | let fndlb_nm_full = 1494 | findlib_of_name 1495 | ~recurse:true 1496 | mp 1497 | nm 1498 | in 1499 | MapString.add fndlb_nm_full nm acc) 1500 | mp 1501 | MapString.empty 1502 | 1503 | let findlib_of_group = 1504 | function 1505 | | Container (fndlb_nm, _) 1506 | | Package (fndlb_nm, _, _, _, _) -> fndlb_nm 1507 | 1508 | let root_of_group grp = 1509 | let rec root_lib_aux = 1510 | function 1511 | | Container (_, children) -> 1512 | root_lib_lst children 1513 | | Package (_, cs, bs, lib, children) -> 1514 | if lib.lib_findlib_parent = None then 1515 | cs, bs, lib 1516 | else 1517 | root_lib_lst children 1518 | and root_lib_lst = 1519 | function 1520 | | [] -> 1521 | raise Not_found 1522 | | hd :: tl -> 1523 | try 1524 | root_lib_aux hd 1525 | with Not_found -> 1526 | root_lib_lst tl 1527 | in 1528 | try 1529 | root_lib_aux grp 1530 | with Not_found -> 1531 | failwithf1 1532 | (f_ "Unable to determine root library of findlib library '%s'") 1533 | (findlib_of_group grp) 1534 | 1535 | 1536 | end 1537 | 1538 | module OASISFlag = struct 1539 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISFlag.ml" 1540 | 1541 | end 1542 | 1543 | module OASISPackage = struct 1544 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISPackage.ml" 1545 | 1546 | end 1547 | 1548 | module OASISSourceRepository = struct 1549 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISSourceRepository.ml" 1550 | 1551 | end 1552 | 1553 | module OASISTest = struct 1554 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISTest.ml" 1555 | 1556 | end 1557 | 1558 | module OASISDocument = struct 1559 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/oasis/OASISDocument.ml" 1560 | 1561 | end 1562 | 1563 | 1564 | module BaseEnvLight = struct 1565 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseEnvLight.ml" 1566 | 1567 | module MapString = Map.Make(String) 1568 | 1569 | type t = string MapString.t 1570 | 1571 | let default_filename = 1572 | Filename.concat 1573 | (Sys.getcwd ()) 1574 | "setup.data" 1575 | 1576 | let load ?(allow_empty=false) ?(filename=default_filename) () = 1577 | if Sys.file_exists filename then 1578 | begin 1579 | let chn = 1580 | open_in_bin filename 1581 | in 1582 | let st = 1583 | Stream.of_channel chn 1584 | in 1585 | let line = 1586 | ref 1 1587 | in 1588 | let st_line = 1589 | Stream.from 1590 | (fun _ -> 1591 | try 1592 | match Stream.next st with 1593 | | '\n' -> incr line; Some '\n' 1594 | | c -> Some c 1595 | with Stream.Failure -> None) 1596 | in 1597 | let lexer = 1598 | Genlex.make_lexer ["="] st_line 1599 | in 1600 | let rec read_file mp = 1601 | match Stream.npeek 3 lexer with 1602 | | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> 1603 | Stream.junk lexer; 1604 | Stream.junk lexer; 1605 | Stream.junk lexer; 1606 | read_file (MapString.add nm value mp) 1607 | | [] -> 1608 | mp 1609 | | _ -> 1610 | failwith 1611 | (Printf.sprintf 1612 | "Malformed data file '%s' line %d" 1613 | filename !line) 1614 | in 1615 | let mp = 1616 | read_file MapString.empty 1617 | in 1618 | close_in chn; 1619 | mp 1620 | end 1621 | else if allow_empty then 1622 | begin 1623 | MapString.empty 1624 | end 1625 | else 1626 | begin 1627 | failwith 1628 | (Printf.sprintf 1629 | "Unable to load environment, the file '%s' doesn't exist." 1630 | filename) 1631 | end 1632 | 1633 | let var_get name env = 1634 | let rec var_expand str = 1635 | let buff = 1636 | Buffer.create ((String.length str) * 2) 1637 | in 1638 | Buffer.add_substitute 1639 | buff 1640 | (fun var -> 1641 | try 1642 | var_expand (MapString.find var env) 1643 | with Not_found -> 1644 | failwith 1645 | (Printf.sprintf 1646 | "No variable %s defined when trying to expand %S." 1647 | var 1648 | str)) 1649 | str; 1650 | Buffer.contents buff 1651 | in 1652 | var_expand (MapString.find name env) 1653 | 1654 | let var_choose lst env = 1655 | OASISExpr.choose 1656 | (fun nm -> var_get nm env) 1657 | lst 1658 | end 1659 | 1660 | 1661 | module BaseContext = struct 1662 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseContext.ml" 1663 | 1664 | open OASISContext 1665 | 1666 | let args = args 1667 | 1668 | let default = default 1669 | 1670 | end 1671 | 1672 | module BaseMessage = struct 1673 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseMessage.ml" 1674 | 1675 | (** Message to user, overrid for Base 1676 | @author Sylvain Le Gall 1677 | *) 1678 | open OASISMessage 1679 | open BaseContext 1680 | 1681 | let debug fmt = debug ~ctxt:!default fmt 1682 | 1683 | let info fmt = info ~ctxt:!default fmt 1684 | 1685 | let warning fmt = warning ~ctxt:!default fmt 1686 | 1687 | let error fmt = error ~ctxt:!default fmt 1688 | 1689 | let string_of_exception = string_of_exception 1690 | 1691 | end 1692 | 1693 | module BaseFilePath = struct 1694 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseFilePath.ml" 1695 | 1696 | 1697 | open Filename 1698 | 1699 | module Unix = OASISUnixPath 1700 | 1701 | let make = 1702 | function 1703 | | [] -> 1704 | invalid_arg "BaseFilename.make" 1705 | | hd :: tl -> 1706 | List.fold_left Filename.concat hd tl 1707 | 1708 | let of_unix ufn = 1709 | if Sys.os_type = "Unix" then 1710 | ufn 1711 | else 1712 | make 1713 | (List.map 1714 | (fun p -> 1715 | if p = Unix.current_dir_name then 1716 | current_dir_name 1717 | else if p = Unix.parent_dir_name then 1718 | parent_dir_name 1719 | else 1720 | p) 1721 | (OASISUtils.split '/' ufn)) 1722 | 1723 | end 1724 | 1725 | module BaseEnv = struct 1726 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseEnv.ml" 1727 | 1728 | open OASISTypes 1729 | open OASISGettext 1730 | open OASISUtils 1731 | open PropList 1732 | 1733 | module MapString = BaseEnvLight.MapString 1734 | 1735 | type origin_t = 1736 | | ODefault 1737 | | OGetEnv 1738 | | OFileLoad 1739 | | OCommandLine 1740 | 1741 | type cli_handle_t = 1742 | | CLINone 1743 | | CLIAuto 1744 | | CLIWith 1745 | | CLIEnable 1746 | | CLIUser of (Arg.key * Arg.spec * Arg.doc) list 1747 | 1748 | type definition_t = 1749 | { 1750 | hide: bool; 1751 | dump: bool; 1752 | cli: cli_handle_t; 1753 | arg_help: string option; 1754 | group: string option; 1755 | } 1756 | 1757 | let schema = 1758 | Schema.create "environment" 1759 | 1760 | (* Environment data *) 1761 | let env = 1762 | Data.create () 1763 | 1764 | (* Environment data from file *) 1765 | let env_from_file = 1766 | ref MapString.empty 1767 | 1768 | (* Lexer for var *) 1769 | let var_lxr = 1770 | Genlex.make_lexer [] 1771 | 1772 | let rec var_expand str = 1773 | let buff = 1774 | Buffer.create ((String.length str) * 2) 1775 | in 1776 | Buffer.add_substitute 1777 | buff 1778 | (fun var -> 1779 | try 1780 | (* TODO: this is a quick hack to allow calling Test.Command 1781 | * without defining executable name really. I.e. if there is 1782 | * an exec Executable toto, then $(toto) should be replace 1783 | * by its real name. It is however useful to have this function 1784 | * for other variable that depend on the host and should be 1785 | * written better than that. 1786 | *) 1787 | let st = 1788 | var_lxr (Stream.of_string var) 1789 | in 1790 | match Stream.npeek 3 st with 1791 | | [Genlex.Ident "utoh"; Genlex.Ident nm] -> 1792 | BaseFilePath.of_unix (var_get nm) 1793 | | [Genlex.Ident "utoh"; Genlex.String s] -> 1794 | BaseFilePath.of_unix s 1795 | | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> 1796 | String.escaped (var_get nm) 1797 | | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> 1798 | String.escaped s 1799 | | [Genlex.Ident nm] -> 1800 | var_get nm 1801 | | _ -> 1802 | failwithf2 1803 | (f_ "Unknown expression '%s' in variable expansion of %s.") 1804 | var 1805 | str 1806 | with 1807 | | Unknown_field (_, _) -> 1808 | failwithf2 1809 | (f_ "No variable %s defined when trying to expand %S.") 1810 | var 1811 | str 1812 | | Stream.Error e -> 1813 | failwithf3 1814 | (f_ "Syntax error when parsing '%s' when trying to \ 1815 | expand %S: %s") 1816 | var 1817 | str 1818 | e) 1819 | str; 1820 | Buffer.contents buff 1821 | 1822 | and var_get name = 1823 | let vl = 1824 | try 1825 | Schema.get schema env name 1826 | with Unknown_field _ as e -> 1827 | begin 1828 | try 1829 | MapString.find name !env_from_file 1830 | with Not_found -> 1831 | raise e 1832 | end 1833 | in 1834 | var_expand vl 1835 | 1836 | let var_choose ?printer ?name lst = 1837 | OASISExpr.choose 1838 | ?printer 1839 | ?name 1840 | var_get 1841 | lst 1842 | 1843 | let var_protect vl = 1844 | let buff = 1845 | Buffer.create (String.length vl) 1846 | in 1847 | String.iter 1848 | (function 1849 | | '$' -> Buffer.add_string buff "\\$" 1850 | | c -> Buffer.add_char buff c) 1851 | vl; 1852 | Buffer.contents buff 1853 | 1854 | let var_define 1855 | ?(hide=false) 1856 | ?(dump=true) 1857 | ?short_desc 1858 | ?(cli=CLINone) 1859 | ?arg_help 1860 | ?group 1861 | name (* TODO: type constraint on the fact that name must be a valid OCaml 1862 | id *) 1863 | dflt = 1864 | 1865 | let default = 1866 | [ 1867 | OFileLoad, lazy (MapString.find name !env_from_file); 1868 | ODefault, dflt; 1869 | OGetEnv, lazy (Sys.getenv name); 1870 | ] 1871 | in 1872 | 1873 | let extra = 1874 | { 1875 | hide = hide; 1876 | dump = dump; 1877 | cli = cli; 1878 | arg_help = arg_help; 1879 | group = group; 1880 | } 1881 | in 1882 | 1883 | (* Try to find a value that can be defined 1884 | *) 1885 | let var_get_low lst = 1886 | let errors, res = 1887 | List.fold_left 1888 | (fun (errors, res) (_, v) -> 1889 | if res = None then 1890 | begin 1891 | try 1892 | errors, Some (Lazy.force v) 1893 | with 1894 | | Not_found -> 1895 | errors, res 1896 | | Failure rsn -> 1897 | (rsn :: errors), res 1898 | | e -> 1899 | (Printexc.to_string e) :: errors, res 1900 | end 1901 | else 1902 | errors, res) 1903 | ([], None) 1904 | (List.sort 1905 | (fun (o1, _) (o2, _) -> 1906 | if o1 < o2 then 1907 | 1 1908 | else if o1 = o2 then 1909 | 0 1910 | else 1911 | -1) 1912 | lst) 1913 | in 1914 | match res, errors with 1915 | | Some v, _ -> 1916 | v 1917 | | None, [] -> 1918 | raise (Not_set (name, None)) 1919 | | None, lst -> 1920 | raise (Not_set (name, Some (String.concat (s_ ", ") lst))) 1921 | in 1922 | 1923 | let help = 1924 | match short_desc with 1925 | | Some fs -> Some fs 1926 | | None -> None 1927 | in 1928 | 1929 | let var_get_lst = 1930 | FieldRO.create 1931 | ~schema 1932 | ~name 1933 | ~parse:(fun ?(context=ODefault) s -> [context, lazy s]) 1934 | ~print:var_get_low 1935 | ~default 1936 | ~update:(fun ?context x old_x -> x @ old_x) 1937 | ?help 1938 | extra 1939 | in 1940 | 1941 | fun () -> 1942 | var_expand (var_get_low (var_get_lst env)) 1943 | 1944 | let var_redefine 1945 | ?hide 1946 | ?dump 1947 | ?short_desc 1948 | ?cli 1949 | ?arg_help 1950 | ?group 1951 | name 1952 | dflt = 1953 | if Schema.mem schema name then 1954 | begin 1955 | Schema.set schema env ~context:ODefault name (Lazy.force dflt); 1956 | fun () -> var_get name 1957 | end 1958 | else 1959 | begin 1960 | var_define 1961 | ?hide 1962 | ?dump 1963 | ?short_desc 1964 | ?cli 1965 | ?arg_help 1966 | ?group 1967 | name 1968 | dflt 1969 | end 1970 | 1971 | let var_ignore (e : unit -> string) = 1972 | () 1973 | 1974 | let print_hidden = 1975 | var_define 1976 | ~hide:true 1977 | ~dump:false 1978 | ~cli:CLIAuto 1979 | ~arg_help:"Print even non-printable variable. (debug)" 1980 | "print_hidden" 1981 | (lazy "false") 1982 | 1983 | let var_all () = 1984 | List.rev 1985 | (Schema.fold 1986 | (fun acc nm def _ -> 1987 | if not def.hide || bool_of_string (print_hidden ()) then 1988 | nm :: acc 1989 | else 1990 | acc) 1991 | [] 1992 | schema) 1993 | 1994 | let default_filename = 1995 | BaseEnvLight.default_filename 1996 | 1997 | let load ?allow_empty ?filename () = 1998 | env_from_file := BaseEnvLight.load ?allow_empty ?filename () 1999 | 2000 | let unload () = 2001 | (* TODO: reset lazy values *) 2002 | env_from_file := MapString.empty; 2003 | Data.clear env 2004 | 2005 | let dump ?(filename=default_filename) () = 2006 | let chn = 2007 | open_out_bin filename 2008 | in 2009 | Schema.iter 2010 | (fun nm def _ -> 2011 | if def.dump then 2012 | begin 2013 | try 2014 | let value = 2015 | Schema.get 2016 | schema 2017 | env 2018 | nm 2019 | in 2020 | Printf.fprintf chn "%s = %S\n" nm value 2021 | with Not_set _ -> 2022 | () 2023 | end) 2024 | schema; 2025 | close_out chn 2026 | 2027 | let print () = 2028 | let printable_vars = 2029 | Schema.fold 2030 | (fun acc nm def short_descr_opt -> 2031 | if not def.hide || bool_of_string (print_hidden ()) then 2032 | begin 2033 | try 2034 | let value = 2035 | Schema.get 2036 | schema 2037 | env 2038 | nm 2039 | in 2040 | let txt = 2041 | match short_descr_opt with 2042 | | Some s -> s () 2043 | | None -> nm 2044 | in 2045 | (txt, value) :: acc 2046 | with Not_set _ -> 2047 | acc 2048 | end 2049 | else 2050 | acc) 2051 | [] 2052 | schema 2053 | in 2054 | let max_length = 2055 | List.fold_left max 0 2056 | (List.rev_map String.length 2057 | (List.rev_map fst printable_vars)) 2058 | in 2059 | let dot_pad str = 2060 | String.make ((max_length - (String.length str)) + 3) '.' 2061 | in 2062 | 2063 | print_newline (); 2064 | print_endline "Configuration: "; 2065 | print_newline (); 2066 | List.iter 2067 | (fun (name,value) -> 2068 | Printf.printf "%s: %s %s\n" name (dot_pad name) value) 2069 | printable_vars; 2070 | Printf.printf "%!"; 2071 | print_newline () 2072 | 2073 | let args () = 2074 | let arg_concat = 2075 | OASISUtils.varname_concat ~hyphen:'-' 2076 | in 2077 | [ 2078 | "--override", 2079 | Arg.Tuple 2080 | ( 2081 | let rvr = ref "" 2082 | in 2083 | let rvl = ref "" 2084 | in 2085 | [ 2086 | Arg.Set_string rvr; 2087 | Arg.Set_string rvl; 2088 | Arg.Unit 2089 | (fun () -> 2090 | Schema.set 2091 | schema 2092 | env 2093 | ~context:OCommandLine 2094 | !rvr 2095 | !rvl) 2096 | ] 2097 | ), 2098 | "var+val Override any configuration variable."; 2099 | 2100 | ] 2101 | @ 2102 | List.flatten 2103 | (Schema.fold 2104 | (fun acc name def short_descr_opt -> 2105 | let var_set s = 2106 | Schema.set 2107 | schema 2108 | env 2109 | ~context:OCommandLine 2110 | name 2111 | s 2112 | in 2113 | 2114 | let arg_name = 2115 | OASISUtils.varname_of_string ~hyphen:'-' name 2116 | in 2117 | 2118 | let hlp = 2119 | match short_descr_opt with 2120 | | Some txt -> txt () 2121 | | None -> "" 2122 | in 2123 | 2124 | let arg_hlp = 2125 | match def.arg_help with 2126 | | Some s -> s 2127 | | None -> "str" 2128 | in 2129 | 2130 | let default_value = 2131 | try 2132 | Printf.sprintf 2133 | (f_ " [%s]") 2134 | (Schema.get 2135 | schema 2136 | env 2137 | name) 2138 | with Not_set _ -> 2139 | "" 2140 | in 2141 | 2142 | let args = 2143 | match def.cli with 2144 | | CLINone -> 2145 | [] 2146 | | CLIAuto -> 2147 | [ 2148 | arg_concat "--" arg_name, 2149 | Arg.String var_set, 2150 | Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value 2151 | ] 2152 | | CLIWith -> 2153 | [ 2154 | arg_concat "--with-" arg_name, 2155 | Arg.String var_set, 2156 | Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value 2157 | ] 2158 | | CLIEnable -> 2159 | [ 2160 | arg_concat "--enable-" arg_name, 2161 | Arg.Unit (fun () -> var_set "true"), 2162 | Printf.sprintf (f_ " %s%s") hlp 2163 | (if default_value = " [true]" then 2164 | (s_ " [default]") 2165 | else 2166 | ""); 2167 | 2168 | arg_concat "--disable-" arg_name, 2169 | Arg.Unit (fun () -> var_set "false"), 2170 | Printf.sprintf (f_ " %s%s") hlp 2171 | (if default_value = " [false]" then 2172 | (s_ " [default]") 2173 | else 2174 | ""); 2175 | ] 2176 | | CLIUser lst -> 2177 | lst 2178 | in 2179 | args :: acc) 2180 | [] 2181 | schema) 2182 | end 2183 | 2184 | module BaseExec = struct 2185 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseExec.ml" 2186 | 2187 | open OASISGettext 2188 | open OASISUtils 2189 | open BaseMessage 2190 | 2191 | let run ?f_exit_code cmd args = 2192 | let cmdline = 2193 | String.concat " " (cmd :: args) 2194 | in 2195 | info (f_ "Running command '%s'") cmdline; 2196 | match f_exit_code, Sys.command cmdline with 2197 | | None, 0 -> () 2198 | | None, i -> 2199 | failwithf2 2200 | (f_ "Command '%s' terminated with error code %d") 2201 | cmdline i 2202 | | Some f, i -> 2203 | f i 2204 | 2205 | let run_read_output cmd args = 2206 | let fn = 2207 | Filename.temp_file "oasis-" ".txt" 2208 | in 2209 | let () = 2210 | try 2211 | run cmd (args @ [">"; Filename.quote fn]) 2212 | with e -> 2213 | Sys.remove fn; 2214 | raise e 2215 | in 2216 | let chn = 2217 | open_in fn 2218 | in 2219 | let routput = 2220 | ref [] 2221 | in 2222 | ( 2223 | try 2224 | while true do 2225 | routput := (input_line chn) :: !routput 2226 | done 2227 | with End_of_file -> 2228 | () 2229 | ); 2230 | close_in chn; 2231 | Sys.remove fn; 2232 | List.rev !routput 2233 | 2234 | let run_read_one_line cmd args = 2235 | match run_read_output cmd args with 2236 | | [fst] -> 2237 | fst 2238 | | lst -> 2239 | failwithf1 2240 | (f_ "Command return unexpected output %S") 2241 | (String.concat "\n" lst) 2242 | end 2243 | 2244 | module BaseFileUtil = struct 2245 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseFileUtil.ml" 2246 | 2247 | open OASISGettext 2248 | 2249 | let find_file paths exts = 2250 | 2251 | (* Cardinal product of two list *) 2252 | let ( * ) lst1 lst2 = 2253 | List.flatten 2254 | (List.map 2255 | (fun a -> 2256 | List.map 2257 | (fun b -> a,b) 2258 | lst2) 2259 | lst1) 2260 | in 2261 | 2262 | let rec combined_paths lst = 2263 | match lst with 2264 | | p1 :: p2 :: tl -> 2265 | let acc = 2266 | (List.map 2267 | (fun (a,b) -> Filename.concat a b) 2268 | (p1 * p2)) 2269 | in 2270 | combined_paths (acc :: tl) 2271 | | [e] -> 2272 | e 2273 | | [] -> 2274 | [] 2275 | in 2276 | 2277 | let alternatives = 2278 | List.map 2279 | (fun (p,e) -> 2280 | if String.length e > 0 && e.[0] <> '.' then 2281 | p ^ "." ^ e 2282 | else 2283 | p ^ e) 2284 | ((combined_paths paths) * exts) 2285 | in 2286 | List.find 2287 | Sys.file_exists 2288 | alternatives 2289 | 2290 | let which prg = 2291 | let path_sep = 2292 | match Sys.os_type with 2293 | | "Win32" -> 2294 | ';' 2295 | | _ -> 2296 | ':' 2297 | in 2298 | let path_lst = 2299 | OASISUtils.split 2300 | path_sep 2301 | (Sys.getenv "PATH") 2302 | in 2303 | let exec_ext = 2304 | match Sys.os_type with 2305 | | "Win32" -> 2306 | "" 2307 | :: 2308 | (OASISUtils.split 2309 | path_sep 2310 | (Sys.getenv "PATHEXT")) 2311 | | _ -> 2312 | [""] 2313 | in 2314 | find_file [path_lst; [prg]] exec_ext 2315 | 2316 | (**/**) 2317 | let rec fix_dir dn = 2318 | (* Windows hack because Sys.file_exists "src\\" = false when 2319 | * Sys.file_exists "src" = true 2320 | *) 2321 | let ln = 2322 | String.length dn 2323 | in 2324 | if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then 2325 | fix_dir (String.sub dn 0 (ln - 1)) 2326 | else 2327 | dn 2328 | 2329 | let q = Filename.quote 2330 | (**/**) 2331 | 2332 | let cp src tgt = 2333 | BaseExec.run 2334 | (match Sys.os_type with 2335 | | "Win32" -> "copy" 2336 | | _ -> "cp") 2337 | [q src; q tgt] 2338 | 2339 | let mkdir tgt = 2340 | BaseExec.run 2341 | (match Sys.os_type with 2342 | | "Win32" -> "md" 2343 | | _ -> "mkdir") 2344 | [q tgt] 2345 | 2346 | let rec mkdir_parent f tgt = 2347 | let tgt = 2348 | fix_dir tgt 2349 | in 2350 | if Sys.file_exists tgt then 2351 | begin 2352 | if not (Sys.is_directory tgt) then 2353 | OASISUtils.failwithf1 2354 | (f_ "Cannot create directory '%s', a file of the same name already \ 2355 | exists") 2356 | tgt 2357 | end 2358 | else 2359 | begin 2360 | mkdir_parent f (Filename.dirname tgt); 2361 | if not (Sys.file_exists tgt) then 2362 | begin 2363 | f tgt; 2364 | mkdir tgt 2365 | end 2366 | end 2367 | 2368 | let rmdir tgt = 2369 | if Sys.readdir tgt = [||] then 2370 | begin 2371 | match Sys.os_type with 2372 | | "Win32" -> 2373 | BaseExec.run "rd" [q tgt] 2374 | | _ -> 2375 | BaseExec.run "rm" ["-r"; q tgt] 2376 | end 2377 | 2378 | let glob fn = 2379 | let basename = 2380 | Filename.basename fn 2381 | in 2382 | if String.length basename >= 2 && 2383 | basename.[0] = '*' && 2384 | basename.[1] = '.' then 2385 | begin 2386 | let ext_len = 2387 | (String.length basename) - 2 2388 | in 2389 | let ext = 2390 | String.sub basename 2 ext_len 2391 | in 2392 | let dirname = 2393 | Filename.dirname fn 2394 | in 2395 | Array.fold_left 2396 | (fun acc fn -> 2397 | try 2398 | let fn_ext = 2399 | String.sub 2400 | fn 2401 | ((String.length fn) - ext_len) 2402 | ext_len 2403 | in 2404 | if fn_ext = ext then 2405 | (Filename.concat dirname fn) :: acc 2406 | else 2407 | acc 2408 | with Invalid_argument _ -> 2409 | acc) 2410 | [] 2411 | (Sys.readdir dirname) 2412 | end 2413 | else 2414 | begin 2415 | if Sys.file_exists fn then 2416 | [fn] 2417 | else 2418 | [] 2419 | end 2420 | end 2421 | 2422 | module BaseArgExt = struct 2423 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseArgExt.ml" 2424 | 2425 | open OASISUtils 2426 | open OASISGettext 2427 | 2428 | let parse argv args = 2429 | (* Simulate command line for Arg *) 2430 | let current = 2431 | ref 0 2432 | in 2433 | 2434 | try 2435 | Arg.parse_argv 2436 | ~current:current 2437 | (Array.concat [[|"none"|]; argv]) 2438 | (Arg.align args) 2439 | (failwithf1 (f_ "Don't know what to do with arguments: '%s'")) 2440 | (s_ "configure options:") 2441 | with 2442 | | Arg.Help txt -> 2443 | print_endline txt; 2444 | exit 0 2445 | | Arg.Bad txt -> 2446 | prerr_endline txt; 2447 | exit 1 2448 | end 2449 | 2450 | module BaseCheck = struct 2451 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseCheck.ml" 2452 | 2453 | open BaseEnv 2454 | open BaseMessage 2455 | open OASISUtils 2456 | open OASISGettext 2457 | 2458 | let prog_best prg prg_lst = 2459 | var_redefine 2460 | prg 2461 | (lazy 2462 | (let alternate = 2463 | List.fold_left 2464 | (fun res e -> 2465 | match res with 2466 | | Some _ -> 2467 | res 2468 | | None -> 2469 | try 2470 | Some (BaseFileUtil.which e) 2471 | with Not_found -> 2472 | None) 2473 | None 2474 | prg_lst 2475 | in 2476 | match alternate with 2477 | | Some prg -> prg 2478 | | None -> raise Not_found)) 2479 | 2480 | let prog prg = 2481 | prog_best prg [prg] 2482 | 2483 | let prog_opt prg = 2484 | prog_best prg [prg^".opt"; prg] 2485 | 2486 | let ocamlfind = 2487 | prog "ocamlfind" 2488 | 2489 | let version 2490 | var_prefix 2491 | cmp 2492 | fversion 2493 | () = 2494 | (* Really compare version provided *) 2495 | let var = 2496 | var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) 2497 | in 2498 | var_redefine 2499 | ~hide:true 2500 | var 2501 | (lazy 2502 | (let version_str = 2503 | match fversion () with 2504 | | "[Distributed with OCaml]" -> 2505 | begin 2506 | try 2507 | (var_get "ocaml_version") 2508 | with Not_found -> 2509 | warning 2510 | (f_ "Variable ocaml_version not defined, fallback \ 2511 | to default"); 2512 | Sys.ocaml_version 2513 | end 2514 | | res -> 2515 | res 2516 | in 2517 | let version = 2518 | OASISVersion.version_of_string version_str 2519 | in 2520 | if OASISVersion.comparator_apply version cmp then 2521 | version_str 2522 | else 2523 | failwithf3 2524 | (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") 2525 | var_prefix 2526 | (OASISVersion.string_of_comparator cmp) 2527 | version_str)) 2528 | () 2529 | 2530 | let package_version pkg = 2531 | BaseExec.run_read_one_line 2532 | (ocamlfind ()) 2533 | ["query"; "-format"; "%v"; pkg] 2534 | 2535 | let package ?version_comparator pkg () = 2536 | let var = 2537 | OASISUtils.varname_concat 2538 | "pkg_" 2539 | (OASISUtils.varname_of_string pkg) 2540 | in 2541 | let findlib_dir pkg = 2542 | let dir = 2543 | BaseExec.run_read_one_line 2544 | (ocamlfind ()) 2545 | ["query"; "-format"; "%d"; pkg] 2546 | in 2547 | if Sys.file_exists dir && Sys.is_directory dir then 2548 | dir 2549 | else 2550 | failwithf2 2551 | (f_ "When looking for findlib package %s, \ 2552 | directory %s return doesn't exist") 2553 | pkg dir 2554 | in 2555 | let vl = 2556 | var_redefine 2557 | var 2558 | (lazy (findlib_dir pkg)) 2559 | () 2560 | in 2561 | ( 2562 | match version_comparator with 2563 | | Some ver_cmp -> 2564 | ignore 2565 | (version 2566 | var 2567 | ver_cmp 2568 | (fun _ -> package_version pkg) 2569 | ()) 2570 | | None -> 2571 | () 2572 | ); 2573 | vl 2574 | end 2575 | 2576 | module BaseOCamlcConfig = struct 2577 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseOCamlcConfig.ml" 2578 | 2579 | 2580 | open BaseEnv 2581 | open OASISUtils 2582 | open OASISGettext 2583 | 2584 | module SMap = Map.Make(String) 2585 | 2586 | let ocamlc = 2587 | BaseCheck.prog_opt "ocamlc" 2588 | 2589 | let ocamlc_config_map = 2590 | (* Map name to value for ocamlc -config output 2591 | (name ^": "^value) 2592 | *) 2593 | let rec split_field mp lst = 2594 | match lst with 2595 | | line :: tl -> 2596 | let mp = 2597 | try 2598 | let pos_semicolon = 2599 | String.index line ':' 2600 | in 2601 | if pos_semicolon > 1 then 2602 | ( 2603 | let name = 2604 | String.sub line 0 pos_semicolon 2605 | in 2606 | let linelen = 2607 | String.length line 2608 | in 2609 | let value = 2610 | if linelen > pos_semicolon + 2 then 2611 | String.sub 2612 | line 2613 | (pos_semicolon + 2) 2614 | (linelen - pos_semicolon - 2) 2615 | else 2616 | "" 2617 | in 2618 | SMap.add name value mp 2619 | ) 2620 | else 2621 | ( 2622 | mp 2623 | ) 2624 | with Not_found -> 2625 | ( 2626 | mp 2627 | ) 2628 | in 2629 | split_field mp tl 2630 | | [] -> 2631 | mp 2632 | in 2633 | 2634 | var_redefine 2635 | "ocamlc_config_map" 2636 | ~hide:true 2637 | ~dump:false 2638 | (lazy 2639 | (var_protect 2640 | (Marshal.to_string 2641 | (split_field 2642 | SMap.empty 2643 | (BaseExec.run_read_output 2644 | (ocamlc ()) ["-config"])) 2645 | []))) 2646 | 2647 | let var_define nm = 2648 | (* Extract data from ocamlc -config *) 2649 | let avlbl_config_get () = 2650 | Marshal.from_string 2651 | (ocamlc_config_map ()) 2652 | 0 2653 | in 2654 | let nm_config = 2655 | match nm with 2656 | | "ocaml_version" -> "version" 2657 | | _ -> nm 2658 | in 2659 | var_redefine 2660 | nm 2661 | (lazy 2662 | (try 2663 | let map = 2664 | avlbl_config_get () 2665 | in 2666 | let value = 2667 | SMap.find nm_config map 2668 | in 2669 | value 2670 | with Not_found -> 2671 | failwithf2 2672 | (f_ "Cannot find field '%s' in '%s -config' output") 2673 | nm 2674 | (ocamlc ()))) 2675 | 2676 | end 2677 | 2678 | module BaseStandardVar = struct 2679 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseStandardVar.ml" 2680 | 2681 | 2682 | open OASISGettext 2683 | open OASISTypes 2684 | open OASISExpr 2685 | open BaseCheck 2686 | open BaseEnv 2687 | 2688 | let ocamlfind = BaseCheck.ocamlfind 2689 | let ocamlc = BaseOCamlcConfig.ocamlc 2690 | let ocamlopt = prog_opt "ocamlopt" 2691 | let ocamlbuild = prog "ocamlbuild" 2692 | 2693 | 2694 | (**/**) 2695 | let rpkg = 2696 | ref None 2697 | 2698 | let pkg_get () = 2699 | match !rpkg with 2700 | | Some pkg -> pkg 2701 | | None -> failwith (s_ "OASIS Package is not set") 2702 | (**/**) 2703 | 2704 | let pkg_name = 2705 | var_define 2706 | ~short_desc:(fun () -> s_ "Package name") 2707 | "pkg_name" 2708 | (lazy (pkg_get ()).name) 2709 | 2710 | let pkg_version = 2711 | var_define 2712 | ~short_desc:(fun () -> s_ "Package version") 2713 | "pkg_version" 2714 | (lazy 2715 | (OASISVersion.string_of_version (pkg_get ()).version)) 2716 | 2717 | let c = BaseOCamlcConfig.var_define 2718 | 2719 | let os_type = c "os_type" 2720 | let system = c "system" 2721 | let architecture = c "architecture" 2722 | let ccomp_type = c "ccomp_type" 2723 | let ocaml_version = c "ocaml_version" 2724 | 2725 | (* TODO: Check standard variable presence at runtime *) 2726 | 2727 | let standard_library_default = c "standard_library_default" 2728 | let standard_library = c "standard_library" 2729 | let standard_runtime = c "standard_runtime" 2730 | let bytecomp_c_compiler = c "bytecomp_c_compiler" 2731 | let native_c_compiler = c "native_c_compiler" 2732 | let model = c "model" 2733 | let ext_obj = c "ext_obj" 2734 | let ext_asm = c "ext_asm" 2735 | let ext_lib = c "ext_lib" 2736 | let ext_dll = c "ext_dll" 2737 | let default_executable_name = c "default_executable_name" 2738 | let systhread_supported = c "systhread_supported" 2739 | 2740 | 2741 | (**/**) 2742 | let p name hlp dflt = 2743 | var_define 2744 | ~short_desc:hlp 2745 | ~cli:CLIAuto 2746 | ~arg_help:"dir" 2747 | name 2748 | dflt 2749 | 2750 | let (/) a b = 2751 | if os_type () = Sys.os_type then 2752 | Filename.concat a b 2753 | else if os_type () = "Unix" then 2754 | BaseFilePath.Unix.concat a b 2755 | else 2756 | OASISUtils.failwithf1 2757 | (f_ "Cannot handle os_type %s filename concat") 2758 | (os_type ()) 2759 | (**/**) 2760 | 2761 | let prefix = 2762 | p "prefix" 2763 | (fun () -> s_ "Install architecture-independent files dir") 2764 | (lazy 2765 | (match os_type () with 2766 | | "Win32" -> 2767 | let program_files = 2768 | Sys.getenv "PROGRAMFILES" 2769 | in 2770 | program_files/(pkg_name ()) 2771 | | _ -> 2772 | "/usr/local")) 2773 | 2774 | let exec_prefix = 2775 | p "exec_prefix" 2776 | (fun () -> s_ "Install architecture-dependent files in dir") 2777 | (lazy "$prefix") 2778 | 2779 | let bindir = 2780 | p "bindir" 2781 | (fun () -> s_ "User executables") 2782 | (lazy ("$exec_prefix"/"bin")) 2783 | 2784 | let sbindir = 2785 | p "sbindir" 2786 | (fun () -> s_ "System admin executables") 2787 | (lazy ("$exec_prefix"/"sbin")) 2788 | 2789 | let libexecdir = 2790 | p "libexecdir" 2791 | (fun () -> s_ "Program executables") 2792 | (lazy ("$exec_prefix"/"libexec")) 2793 | 2794 | let sysconfdir = 2795 | p "sysconfdir" 2796 | (fun () -> s_ "Read-only single-machine data") 2797 | (lazy ("$prefix"/"etc")) 2798 | 2799 | let sharedstatedir = 2800 | p "sharedstatedir" 2801 | (fun () -> s_ "Modifiable architecture-independent data") 2802 | (lazy ("$prefix"/"com")) 2803 | 2804 | let localstatedir = 2805 | p "localstatedir" 2806 | (fun () -> s_ "Modifiable single-machine data") 2807 | (lazy ("$prefix"/"var")) 2808 | 2809 | let libdir = 2810 | p "libdir" 2811 | (fun () -> s_ "Object code libraries") 2812 | (lazy ("$exec_prefix"/"lib")) 2813 | 2814 | let datarootdir = 2815 | p "datarootdir" 2816 | (fun () -> s_ "Read-only arch-independent data root") 2817 | (lazy ("$prefix"/"share")) 2818 | 2819 | let datadir = 2820 | p "datadir" 2821 | (fun () -> s_ "Read-only architecture-independent data") 2822 | (lazy ("$datarootdir")) 2823 | 2824 | let infodir = 2825 | p "infodir" 2826 | (fun () -> s_ "Info documentation") 2827 | (lazy ("$datarootdir"/"info")) 2828 | 2829 | let localedir = 2830 | p "localedir" 2831 | (fun () -> s_ "Locale-dependent data") 2832 | (lazy ("$datarootdir"/"locale")) 2833 | 2834 | let mandir = 2835 | p "mandir" 2836 | (fun () -> s_ "Man documentation") 2837 | (lazy ("$datarootdir"/"man")) 2838 | 2839 | let docdir = 2840 | p "docdir" 2841 | (fun () -> s_ "Documentation root") 2842 | (lazy ("$datarootdir"/"doc"/"$pkg_name")) 2843 | 2844 | let htmldir = 2845 | p "htmldir" 2846 | (fun () -> s_ "HTML documentation") 2847 | (lazy ("$docdir")) 2848 | 2849 | let dvidir = 2850 | p "dvidir" 2851 | (fun () -> s_ "DVI documentation") 2852 | (lazy ("$docdir")) 2853 | 2854 | let pdfdir = 2855 | p "pdfdir" 2856 | (fun () -> s_ "PDF documentation") 2857 | (lazy ("$docdir")) 2858 | 2859 | let psdir = 2860 | p "psdir" 2861 | (fun () -> s_ "PS documentation") 2862 | (lazy ("$docdir")) 2863 | 2864 | let destdir = 2865 | p "destdir" 2866 | (fun () -> s_ "Prepend a path when installing package") 2867 | (lazy 2868 | (raise 2869 | (PropList.Not_set 2870 | ("destdir", 2871 | Some (s_ "undefined by construct"))))) 2872 | 2873 | let findlib_version = 2874 | var_define 2875 | "findlib_version" 2876 | (lazy 2877 | (BaseCheck.package_version "findlib")) 2878 | 2879 | let is_native = 2880 | var_define 2881 | "is_native" 2882 | (lazy 2883 | (try 2884 | let _s : string = 2885 | ocamlopt () 2886 | in 2887 | "true" 2888 | with PropList.Not_set _ -> 2889 | let _s : string = 2890 | ocamlc () 2891 | in 2892 | "false")) 2893 | 2894 | let ext_program = 2895 | var_define 2896 | "suffix_program" 2897 | (lazy 2898 | (match os_type () with 2899 | | "Win32" -> ".exe" 2900 | | _ -> "" 2901 | )) 2902 | 2903 | let rm = 2904 | var_define 2905 | ~short_desc:(fun () -> s_ "Remove a file.") 2906 | "rm" 2907 | (lazy 2908 | (match os_type () with 2909 | | "Win32" -> "del" 2910 | | _ -> "rm -f")) 2911 | 2912 | let rmdir = 2913 | var_define 2914 | ~short_desc:(fun () -> s_ "Remove a directory.") 2915 | "rmdir" 2916 | (lazy 2917 | (match os_type () with 2918 | | "Win32" -> "rd" 2919 | | _ -> "rm -rf")) 2920 | 2921 | let debug = 2922 | var_define 2923 | ~short_desc:(fun () -> s_ "Compile with ocaml debug flag on.") 2924 | "debug" 2925 | (lazy "true") 2926 | 2927 | let profile = 2928 | var_define 2929 | ~short_desc:(fun () -> s_ "Compile with ocaml profile flag on.") 2930 | "profile" 2931 | (lazy "false") 2932 | 2933 | let init pkg = 2934 | rpkg := Some pkg 2935 | 2936 | end 2937 | 2938 | module BaseFileAB = struct 2939 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseFileAB.ml" 2940 | 2941 | open BaseEnv 2942 | open OASISGettext 2943 | open BaseMessage 2944 | 2945 | let to_filename fn = 2946 | let fn = 2947 | BaseFilePath.of_unix fn 2948 | in 2949 | if not (Filename.check_suffix fn ".ab") then 2950 | warning 2951 | (f_ "File '%s' doesn't have '.ab' extension") 2952 | fn; 2953 | Filename.chop_extension fn 2954 | 2955 | let replace fn_lst = 2956 | let buff = 2957 | Buffer.create 13 2958 | in 2959 | List.iter 2960 | (fun fn -> 2961 | let fn = 2962 | BaseFilePath.of_unix fn 2963 | in 2964 | let chn_in = 2965 | open_in fn 2966 | in 2967 | let chn_out = 2968 | open_out (to_filename fn) 2969 | in 2970 | ( 2971 | try 2972 | while true do 2973 | Buffer.add_string buff (var_expand (input_line chn_in)); 2974 | Buffer.add_char buff '\n' 2975 | done 2976 | with End_of_file -> 2977 | () 2978 | ); 2979 | Buffer.output_buffer chn_out buff; 2980 | Buffer.clear buff; 2981 | close_in chn_in; 2982 | close_out chn_out) 2983 | fn_lst 2984 | end 2985 | 2986 | module BaseLog = struct 2987 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseLog.ml" 2988 | 2989 | open OASISUtils 2990 | 2991 | let default_filename = 2992 | Filename.concat 2993 | (Filename.dirname BaseEnv.default_filename) 2994 | "setup.log" 2995 | 2996 | module SetTupleString = 2997 | Set.Make 2998 | (struct 2999 | type t = string * string 3000 | let compare (s11, s12) (s21, s22) = 3001 | match String.compare s11 s21 with 3002 | | 0 -> String.compare s12 s22 3003 | | n -> n 3004 | end) 3005 | 3006 | let load () = 3007 | if Sys.file_exists default_filename then 3008 | begin 3009 | let chn = 3010 | open_in default_filename 3011 | in 3012 | let scbuf = 3013 | Scanf.Scanning.from_file default_filename 3014 | in 3015 | let rec read_aux (st, lst) = 3016 | if not (Scanf.Scanning.end_of_input scbuf) then 3017 | begin 3018 | let acc = 3019 | try 3020 | Scanf.bscanf scbuf "%S %S@\n" 3021 | (fun e d -> 3022 | let t = 3023 | e, d 3024 | in 3025 | if SetTupleString.mem t st then 3026 | st, lst 3027 | else 3028 | SetTupleString.add t st, 3029 | t :: lst) 3030 | with Scanf.Scan_failure _ -> 3031 | failwith 3032 | (Scanf.bscanf scbuf 3033 | "%l" 3034 | (fun line -> 3035 | Printf.sprintf 3036 | "Malformed log file '%s' at line %d" 3037 | default_filename 3038 | line)) 3039 | in 3040 | read_aux acc 3041 | end 3042 | else 3043 | begin 3044 | close_in chn; 3045 | List.rev lst 3046 | end 3047 | in 3048 | read_aux (SetTupleString.empty, []) 3049 | end 3050 | else 3051 | begin 3052 | [] 3053 | end 3054 | 3055 | let register event data = 3056 | let chn_out = 3057 | open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename 3058 | in 3059 | Printf.fprintf chn_out "%S %S\n" event data; 3060 | close_out chn_out 3061 | 3062 | let unregister event data = 3063 | if Sys.file_exists default_filename then 3064 | begin 3065 | let lst = 3066 | load () 3067 | in 3068 | let chn_out = 3069 | open_out default_filename 3070 | in 3071 | let write_something = 3072 | ref false 3073 | in 3074 | List.iter 3075 | (fun (e, d) -> 3076 | if e <> event || d <> data then 3077 | begin 3078 | write_something := true; 3079 | Printf.fprintf chn_out "%S %S\n" e d 3080 | end) 3081 | lst; 3082 | close_out chn_out; 3083 | if not !write_something then 3084 | Sys.remove default_filename 3085 | end 3086 | 3087 | let filter events = 3088 | let st_events = 3089 | List.fold_left 3090 | (fun st e -> 3091 | SetString.add e st) 3092 | SetString.empty 3093 | events 3094 | in 3095 | List.filter 3096 | (fun (e, _) -> SetString.mem e st_events) 3097 | (load ()) 3098 | 3099 | let exists event data = 3100 | List.exists 3101 | (fun v -> (event, data) = v) 3102 | (load ()) 3103 | end 3104 | 3105 | module BaseBuilt = struct 3106 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseBuilt.ml" 3107 | 3108 | open OASISTypes 3109 | open OASISGettext 3110 | open BaseStandardVar 3111 | open BaseMessage 3112 | 3113 | type t = 3114 | | BExec (* Executable *) 3115 | | BExecLib (* Library coming with executable *) 3116 | | BLib (* Library *) 3117 | | BDoc (* Document *) 3118 | 3119 | let to_log_event_file t nm = 3120 | "built_"^ 3121 | (match t with 3122 | | BExec -> "exec" 3123 | | BExecLib -> "exec_lib" 3124 | | BLib -> "lib" 3125 | | BDoc -> "doc")^ 3126 | "_"^nm 3127 | 3128 | let to_log_event_done t nm = 3129 | "is_"^(to_log_event_file t nm) 3130 | 3131 | let register t nm lst = 3132 | BaseLog.register 3133 | (to_log_event_done t nm) 3134 | "true"; 3135 | List.iter 3136 | (fun alt -> 3137 | let registered = 3138 | List.fold_left 3139 | (fun registered fn -> 3140 | if Sys.file_exists fn then 3141 | begin 3142 | BaseLog.register 3143 | (to_log_event_file t nm) 3144 | (if Filename.is_relative fn then 3145 | Filename.concat (Sys.getcwd ()) fn 3146 | else 3147 | fn); 3148 | true 3149 | end 3150 | else 3151 | registered) 3152 | false 3153 | alt 3154 | in 3155 | if not registered then 3156 | warning 3157 | (f_ "Cannot find an existing alternative files among: %s") 3158 | (String.concat (s_ ", ") alt)) 3159 | lst 3160 | 3161 | let unregister t nm = 3162 | List.iter 3163 | (fun (e, d) -> 3164 | BaseLog.unregister e d) 3165 | (BaseLog.filter 3166 | [to_log_event_file t nm; 3167 | to_log_event_done t nm]) 3168 | 3169 | let fold t nm f acc = 3170 | List.fold_left 3171 | (fun acc (_, fn) -> 3172 | if Sys.file_exists fn then 3173 | begin 3174 | f acc fn 3175 | end 3176 | else 3177 | begin 3178 | warning 3179 | (f_ "File '%s' has been marked as built \ 3180 | for %s but doesn't exist") 3181 | fn 3182 | (Printf.sprintf 3183 | (match t with 3184 | | BExec | BExecLib -> 3185 | (f_ "executable %s") 3186 | | BLib -> 3187 | (f_ "library %s") 3188 | | BDoc -> 3189 | (f_ "documentation %s")) 3190 | nm); 3191 | acc 3192 | end) 3193 | acc 3194 | (BaseLog.filter 3195 | [to_log_event_file t nm]) 3196 | 3197 | let is_built t nm = 3198 | List.fold_left 3199 | (fun is_built (_, d) -> 3200 | (try 3201 | bool_of_string d 3202 | with _ -> 3203 | false)) 3204 | false 3205 | (BaseLog.filter 3206 | [to_log_event_done t nm]) 3207 | 3208 | let of_executable ffn (cs, bs, exec) = 3209 | let unix_exec_is, unix_dll_opt = 3210 | OASISExecutable.unix_exec_is 3211 | (cs, bs, exec) 3212 | (fun () -> 3213 | bool_of_string 3214 | (is_native ())) 3215 | ext_dll 3216 | ext_program 3217 | in 3218 | let evs = 3219 | (BExec, cs.cs_name, [[ffn unix_exec_is]]) 3220 | :: 3221 | (match unix_dll_opt with 3222 | | Some fn -> 3223 | [BExecLib, cs.cs_name, [[ffn fn]]] 3224 | | None -> 3225 | []) 3226 | in 3227 | evs, 3228 | unix_exec_is, 3229 | unix_dll_opt 3230 | 3231 | let of_library ffn (cs, bs, lib) = 3232 | let unix_lst = 3233 | OASISLibrary.generated_unix_files 3234 | ~ctxt:!BaseContext.default 3235 | (cs, bs, lib) 3236 | (fun fn -> 3237 | Sys.file_exists (BaseFilePath.of_unix fn)) 3238 | (fun () -> 3239 | bool_of_string (is_native ())) 3240 | ext_lib 3241 | ext_dll 3242 | in 3243 | let evs = 3244 | [BLib, 3245 | cs.cs_name, 3246 | List.map (List.map ffn) unix_lst] 3247 | in 3248 | evs, unix_lst 3249 | 3250 | end 3251 | 3252 | module BaseCustom = struct 3253 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseCustom.ml" 3254 | 3255 | open BaseEnv 3256 | open BaseMessage 3257 | open OASISTypes 3258 | open OASISGettext 3259 | 3260 | let run cmd args extra_args = 3261 | BaseExec.run 3262 | (var_expand cmd) 3263 | (List.map 3264 | var_expand 3265 | (args @ (Array.to_list extra_args))) 3266 | 3267 | let hook ?(failsafe=false) cstm f e = 3268 | let optional_command lst = 3269 | let printer = 3270 | function 3271 | | Some (cmd, args) -> String.concat " " (cmd :: args) 3272 | | None -> s_ "No command" 3273 | in 3274 | match 3275 | var_choose 3276 | ~name:(s_ "Pre/Post Command") 3277 | ~printer 3278 | lst with 3279 | | Some (cmd, args) -> 3280 | begin 3281 | try 3282 | run cmd args [||] 3283 | with e when failsafe -> 3284 | warning 3285 | (f_ "Command '%s' fail with error: %s") 3286 | (String.concat " " (cmd :: args)) 3287 | (match e with 3288 | | Failure msg -> msg 3289 | | e -> Printexc.to_string e) 3290 | end 3291 | | None -> 3292 | () 3293 | in 3294 | let res = 3295 | optional_command cstm.pre_command; 3296 | f e 3297 | in 3298 | optional_command cstm.post_command; 3299 | res 3300 | end 3301 | 3302 | module BaseDynVar = struct 3303 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseDynVar.ml" 3304 | 3305 | 3306 | open OASISTypes 3307 | open OASISGettext 3308 | open BaseEnv 3309 | open BaseBuilt 3310 | 3311 | let init pkg = 3312 | List.iter 3313 | (function 3314 | | Executable (cs, bs, exec) -> 3315 | var_ignore 3316 | (var_redefine 3317 | (* We don't save this variable *) 3318 | ~dump:false 3319 | ~short_desc:(fun () -> 3320 | Printf.sprintf 3321 | (f_ "Filename of executable '%s'") 3322 | cs.cs_name) 3323 | cs.cs_name 3324 | (lazy 3325 | (let fn_opt = 3326 | fold 3327 | BExec cs.cs_name 3328 | (fun _ fn -> Some fn) 3329 | None 3330 | in 3331 | match fn_opt with 3332 | | Some fn -> fn 3333 | | None -> 3334 | raise 3335 | (PropList.Not_set 3336 | (cs.cs_name, 3337 | Some (Printf.sprintf 3338 | (f_ "Executable '%s' not yet built.") 3339 | cs.cs_name)))))) 3340 | 3341 | | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> 3342 | ()) 3343 | pkg.sections 3344 | end 3345 | 3346 | module BaseTest = struct 3347 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseTest.ml" 3348 | 3349 | open BaseEnv 3350 | open BaseMessage 3351 | open OASISTypes 3352 | open OASISExpr 3353 | open OASISGettext 3354 | 3355 | let test lst pkg extra_args = 3356 | 3357 | let one_test (failure, n) (test_plugin, cs, test) = 3358 | if var_choose 3359 | ~name:(Printf.sprintf 3360 | (f_ "test %s run") 3361 | cs.cs_name) 3362 | ~printer:string_of_bool 3363 | test.test_run then 3364 | begin 3365 | let () = 3366 | info (f_ "Running test '%s'") cs.cs_name 3367 | in 3368 | let back_cwd = 3369 | match test.test_working_directory with 3370 | | Some dir -> 3371 | let cwd = 3372 | Sys.getcwd () 3373 | in 3374 | let chdir d = 3375 | info (f_ "Changing directory to '%s'") d; 3376 | Sys.chdir d 3377 | in 3378 | chdir dir; 3379 | fun () -> chdir cwd 3380 | 3381 | | None -> 3382 | fun () -> () 3383 | in 3384 | try 3385 | let failure_percent = 3386 | BaseCustom.hook 3387 | test.test_custom 3388 | (test_plugin pkg (cs, test)) 3389 | extra_args 3390 | in 3391 | back_cwd (); 3392 | (failure_percent +. failure, n + 1) 3393 | with e -> 3394 | begin 3395 | back_cwd (); 3396 | raise e 3397 | end 3398 | end 3399 | else 3400 | begin 3401 | info (f_ "Skipping test '%s'") cs.cs_name; 3402 | (failure, n) 3403 | end 3404 | in 3405 | let (failed, n) = 3406 | List.fold_left 3407 | one_test 3408 | (0.0, 0) 3409 | lst 3410 | in 3411 | let failure_percent = 3412 | if n = 0 then 3413 | 0.0 3414 | else 3415 | failed /. (float_of_int n) 3416 | in 3417 | let msg = 3418 | Printf.sprintf 3419 | (f_ "Tests had a %.2f%% failure rate") 3420 | (100. *. failure_percent) 3421 | in 3422 | if failure_percent > 0.0 then 3423 | failwith msg 3424 | else 3425 | info "%s" msg 3426 | end 3427 | 3428 | module BaseDoc = struct 3429 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseDoc.ml" 3430 | 3431 | open BaseEnv 3432 | open BaseMessage 3433 | open OASISTypes 3434 | open OASISGettext 3435 | 3436 | let doc lst pkg extra_args = 3437 | 3438 | let one_doc (doc_plugin, cs, doc) = 3439 | if var_choose 3440 | ~name:(Printf.sprintf 3441 | (f_ "documentation %s build") 3442 | cs.cs_name) 3443 | ~printer:string_of_bool 3444 | doc.doc_build then 3445 | begin 3446 | info (f_ "Building documentation '%s'") cs.cs_name; 3447 | BaseCustom.hook 3448 | doc.doc_custom 3449 | (doc_plugin pkg (cs, doc)) 3450 | extra_args 3451 | end 3452 | in 3453 | List.iter 3454 | one_doc 3455 | lst 3456 | end 3457 | 3458 | module BaseSetup = struct 3459 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseSetup.ml" 3460 | 3461 | open BaseEnv 3462 | open BaseMessage 3463 | open OASISTypes 3464 | open OASISSection 3465 | open OASISGettext 3466 | open OASISUtils 3467 | 3468 | type std_args_fun = 3469 | package -> string array -> unit 3470 | 3471 | type ('a, 'b) section_args_fun = 3472 | name * (package -> (common_section * 'a) -> string array -> 'b) 3473 | 3474 | type t = 3475 | { 3476 | configure: std_args_fun; 3477 | build: std_args_fun; 3478 | doc: ((doc, unit) section_args_fun) list; 3479 | test: ((test, float) section_args_fun) list; 3480 | install: std_args_fun; 3481 | uninstall: std_args_fun; 3482 | clean: std_args_fun list; 3483 | clean_doc: (doc, unit) section_args_fun list; 3484 | clean_test: (test, unit) section_args_fun list; 3485 | distclean: std_args_fun list; 3486 | distclean_doc: (doc, unit) section_args_fun list; 3487 | distclean_test: (test, unit) section_args_fun list; 3488 | package: package; 3489 | version: string; 3490 | } 3491 | 3492 | (* Associate a plugin function with data from package *) 3493 | let join_plugin_sections filter_map lst = 3494 | List.rev 3495 | (List.fold_left 3496 | (fun acc sct -> 3497 | match filter_map sct with 3498 | | Some e -> 3499 | e :: acc 3500 | | None -> 3501 | acc) 3502 | [] 3503 | lst) 3504 | 3505 | (* Search for plugin data associated with a section name *) 3506 | let lookup_plugin_section plugin action nm lst = 3507 | try 3508 | List.assoc nm lst 3509 | with Not_found -> 3510 | failwithf3 3511 | (f_ "Cannot find plugin %s matching section %s for %s action") 3512 | plugin 3513 | nm 3514 | action 3515 | 3516 | let configure t args = 3517 | (* Run configure *) 3518 | BaseCustom.hook 3519 | t.package.conf_custom 3520 | (t.configure t.package) 3521 | args; 3522 | 3523 | (* Reload environment *) 3524 | unload (); 3525 | load (); 3526 | 3527 | (* Replace data in file *) 3528 | BaseFileAB.replace t.package.files_ab 3529 | 3530 | let build t args = 3531 | BaseCustom.hook 3532 | t.package.build_custom 3533 | (t.build t.package) 3534 | args 3535 | 3536 | let doc t args = 3537 | BaseDoc.doc 3538 | (join_plugin_sections 3539 | (function 3540 | | Doc (cs, e) -> 3541 | Some 3542 | (lookup_plugin_section 3543 | "documentation" 3544 | (s_ "build") 3545 | cs.cs_name 3546 | t.doc, 3547 | cs, 3548 | e) 3549 | | _ -> 3550 | None) 3551 | t.package.sections) 3552 | t.package 3553 | args 3554 | 3555 | let test t args = 3556 | BaseTest.test 3557 | (join_plugin_sections 3558 | (function 3559 | | Test (cs, e) -> 3560 | Some 3561 | (lookup_plugin_section 3562 | "test" 3563 | (s_ "run") 3564 | cs.cs_name 3565 | t.test, 3566 | cs, 3567 | e) 3568 | | _ -> 3569 | None) 3570 | t.package.sections) 3571 | t.package 3572 | args 3573 | 3574 | let all t args = 3575 | let rno_doc = 3576 | ref false 3577 | in 3578 | let rno_test = 3579 | ref false 3580 | in 3581 | Arg.parse_argv 3582 | ~current:(ref 0) 3583 | (Array.of_list 3584 | ((Sys.executable_name^" all") :: 3585 | (Array.to_list args))) 3586 | [ 3587 | "-no-doc", 3588 | Arg.Set rno_doc, 3589 | s_ "Don't run doc target"; 3590 | 3591 | "-no-test", 3592 | Arg.Set rno_test, 3593 | s_ "Don't run test target"; 3594 | ] 3595 | (failwithf1 (f_ "Don't know what to do with '%s'")) 3596 | ""; 3597 | 3598 | info "Running configure step"; 3599 | configure t [||]; 3600 | 3601 | info "Running build step"; 3602 | build t [||]; 3603 | 3604 | (* Load setup.log dynamic variables *) 3605 | BaseDynVar.init t.package; 3606 | 3607 | if not !rno_doc then 3608 | begin 3609 | info "Running doc step"; 3610 | doc t [||]; 3611 | end 3612 | else 3613 | begin 3614 | info "Skipping doc step" 3615 | end; 3616 | 3617 | if not !rno_test then 3618 | begin 3619 | info "Running test step"; 3620 | test t [||] 3621 | end 3622 | else 3623 | begin 3624 | info "Skipping test step" 3625 | end 3626 | 3627 | let install t args = 3628 | BaseCustom.hook 3629 | t.package.install_custom 3630 | (t.install t.package) 3631 | args 3632 | 3633 | let uninstall t args = 3634 | BaseCustom.hook 3635 | t.package.uninstall_custom 3636 | (t.uninstall t.package) 3637 | args 3638 | 3639 | let reinstall t args = 3640 | uninstall t args; 3641 | install t args 3642 | 3643 | let clean, distclean = 3644 | let failsafe f a = 3645 | try 3646 | f a 3647 | with e -> 3648 | warning 3649 | (f_ "Action fail with error: %s") 3650 | (match e with 3651 | | Failure msg -> msg 3652 | | e -> Printexc.to_string e) 3653 | in 3654 | 3655 | let generic_clean t cstm mains docs tests args = 3656 | BaseCustom.hook 3657 | ~failsafe:true 3658 | cstm 3659 | (fun () -> 3660 | (* Clean section *) 3661 | List.iter 3662 | (function 3663 | | Test (cs, test) -> 3664 | let f = 3665 | try 3666 | List.assoc cs.cs_name tests 3667 | with Not_found -> 3668 | fun _ _ _ -> () 3669 | in 3670 | failsafe 3671 | (f t.package (cs, test)) 3672 | args 3673 | | Doc (cs, doc) -> 3674 | let f = 3675 | try 3676 | List.assoc cs.cs_name docs 3677 | with Not_found -> 3678 | fun _ _ _ -> () 3679 | in 3680 | failsafe 3681 | (f t.package (cs, doc)) 3682 | args 3683 | | Library _ 3684 | | Executable _ 3685 | | Flag _ 3686 | | SrcRepo _ -> 3687 | ()) 3688 | t.package.sections; 3689 | (* Clean whole package *) 3690 | List.iter 3691 | (fun f -> 3692 | failsafe 3693 | (f t.package) 3694 | args) 3695 | mains) 3696 | () 3697 | in 3698 | 3699 | let clean t args = 3700 | generic_clean 3701 | t 3702 | t.package.clean_custom 3703 | t.clean 3704 | t.clean_doc 3705 | t.clean_test 3706 | args 3707 | in 3708 | 3709 | let distclean t args = 3710 | (* Call clean *) 3711 | clean t args; 3712 | 3713 | (* Remove generated file *) 3714 | List.iter 3715 | (fun fn -> 3716 | if Sys.file_exists fn then 3717 | begin 3718 | info (f_ "Remove '%s'") fn; 3719 | Sys.remove fn 3720 | end) 3721 | (BaseEnv.default_filename 3722 | :: 3723 | BaseLog.default_filename 3724 | :: 3725 | (List.rev_map BaseFileAB.to_filename t.package.files_ab)); 3726 | 3727 | (* Call distclean code *) 3728 | generic_clean 3729 | t 3730 | t.package.distclean_custom 3731 | t.distclean 3732 | t.distclean_doc 3733 | t.distclean_test 3734 | args 3735 | in 3736 | 3737 | clean, distclean 3738 | 3739 | let version t _ = 3740 | print_endline t.version 3741 | 3742 | let setup t = 3743 | let catch_exn = 3744 | ref true 3745 | in 3746 | try 3747 | let act_ref = 3748 | ref (fun _ -> 3749 | failwithf2 3750 | (f_ "No action defined, run '%s %s -help'") 3751 | Sys.executable_name 3752 | Sys.argv.(0)) 3753 | 3754 | in 3755 | let extra_args_ref = 3756 | ref [] 3757 | in 3758 | let allow_empty_env_ref = 3759 | ref false 3760 | in 3761 | let arg_handle ?(allow_empty_env=false) act = 3762 | Arg.Tuple 3763 | [ 3764 | Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); 3765 | 3766 | Arg.Unit 3767 | (fun () -> 3768 | allow_empty_env_ref := allow_empty_env; 3769 | act_ref := act); 3770 | ] 3771 | in 3772 | 3773 | Arg.parse 3774 | (Arg.align 3775 | [ 3776 | "-configure", 3777 | arg_handle ~allow_empty_env:true configure, 3778 | s_ "[options*] Configure the whole build process."; 3779 | 3780 | "-build", 3781 | arg_handle build, 3782 | s_ "[options*] Build executables and libraries."; 3783 | 3784 | "-doc", 3785 | arg_handle doc, 3786 | s_ "[options*] Build documents."; 3787 | 3788 | "-test", 3789 | arg_handle test, 3790 | s_ "[options*] Run tests."; 3791 | 3792 | "-all", 3793 | arg_handle ~allow_empty_env:true all, 3794 | s_ "[options*] Run configure, build, doc and test targets."; 3795 | 3796 | "-install", 3797 | arg_handle install, 3798 | s_ "[options*] Install libraries, data, executables \ 3799 | and documents."; 3800 | 3801 | "-uninstall", 3802 | arg_handle uninstall, 3803 | s_ "[options*] Uninstall libraries, data, executables \ 3804 | and documents."; 3805 | 3806 | "-reinstall", 3807 | arg_handle reinstall, 3808 | s_ "[options*] Uninstall and install libraries, data, \ 3809 | executables and documents."; 3810 | 3811 | "-clean", 3812 | arg_handle ~allow_empty_env:true clean, 3813 | s_ "[options*] Clean files generated by a build."; 3814 | 3815 | "-distclean", 3816 | arg_handle ~allow_empty_env:true distclean, 3817 | s_ "[options*] Clean files generated by a build and configure."; 3818 | 3819 | "-version", 3820 | arg_handle ~allow_empty_env:true version, 3821 | s_ " Display version of OASIS used to generate this setup.ml."; 3822 | 3823 | "-no-catch-exn", 3824 | Arg.Clear catch_exn, 3825 | s_ " Don't catch exception, useful for debugging."; 3826 | ] 3827 | @ (BaseContext.args ())) 3828 | (failwithf1 (f_ "Don't know what to do with '%s'")) 3829 | (s_ "Setup and run build process current package\n"); 3830 | 3831 | (* Build initial environment *) 3832 | load ~allow_empty:!allow_empty_env_ref (); 3833 | 3834 | (** Initialize flags *) 3835 | List.iter 3836 | (function 3837 | | Flag (cs, {flag_description = hlp; 3838 | flag_default = choices}) -> 3839 | begin 3840 | let apply ?short_desc () = 3841 | var_ignore 3842 | (var_define 3843 | ~cli:CLIEnable 3844 | ?short_desc 3845 | (OASISUtils.varname_of_string cs.cs_name) 3846 | (lazy (string_of_bool 3847 | (var_choose 3848 | ~name:(Printf.sprintf 3849 | (f_ "default value of flag %s") 3850 | cs.cs_name) 3851 | ~printer:string_of_bool 3852 | choices)))) 3853 | in 3854 | match hlp with 3855 | | Some hlp -> 3856 | apply ~short_desc:(fun () -> hlp) () 3857 | | None -> 3858 | apply () 3859 | end 3860 | | _ -> 3861 | ()) 3862 | t.package.sections; 3863 | 3864 | BaseStandardVar.init t.package; 3865 | 3866 | BaseDynVar.init t.package; 3867 | 3868 | !act_ref t (Array.of_list (List.rev !extra_args_ref)) 3869 | 3870 | with e when !catch_exn -> 3871 | error "%s" (string_of_exception e); 3872 | exit 1 3873 | 3874 | end 3875 | 3876 | module BaseDev = struct 3877 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/base/BaseDev.ml" 3878 | 3879 | 3880 | 3881 | open OASISGettext 3882 | open BaseMessage 3883 | 3884 | type t = 3885 | { 3886 | oasis_cmd: string; 3887 | } 3888 | 3889 | let update_and_run t = 3890 | (* Command line to run setup-dev *) 3891 | let oasis_args = 3892 | "setup-dev" :: "-run" :: 3893 | Sys.executable_name :: 3894 | (Array.to_list Sys.argv) 3895 | in 3896 | 3897 | let exit_on_child_error = 3898 | function 3899 | | 0 -> () 3900 | | 2 -> 3901 | (* Bad CLI arguments *) 3902 | error 3903 | (f_ "The command '%s %s' exit with code 2. It often means that we \ 3904 | don't use the right command-line arguments, rerun \ 3905 | 'oasis setup-dev'.") 3906 | t.oasis_cmd 3907 | (String.concat " " oasis_args) 3908 | 3909 | | 127 -> 3910 | (* Cannot find OASIS *) 3911 | error 3912 | (f_ "Cannot find executable '%s', check where 'oasis' is located \ 3913 | and rerun 'oasis setup-dev'") 3914 | t.oasis_cmd 3915 | 3916 | | i -> 3917 | exit i 3918 | in 3919 | 3920 | let () = 3921 | (* Run OASIS to generate a temporary setup.ml 3922 | *) 3923 | BaseExec.run 3924 | ~f_exit_code:exit_on_child_error 3925 | t.oasis_cmd 3926 | oasis_args 3927 | in 3928 | 3929 | () 3930 | 3931 | end 3932 | 3933 | 3934 | module InternalConfigurePlugin = struct 3935 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/plugins/internal/InternalConfigurePlugin.ml" 3936 | 3937 | (** Configure using internal scheme 3938 | @author Sylvain Le Gall 3939 | *) 3940 | 3941 | open BaseEnv 3942 | open OASISTypes 3943 | open OASISUtils 3944 | open OASISGettext 3945 | open BaseMessage 3946 | 3947 | (** Configure build using provided series of check to be done 3948 | * and then output corresponding file. 3949 | *) 3950 | let configure pkg argv = 3951 | let var_ignore_eval var = 3952 | let _s : string = 3953 | var () 3954 | in 3955 | () 3956 | in 3957 | 3958 | let errors = 3959 | ref SetString.empty 3960 | in 3961 | 3962 | let buff = 3963 | Buffer.create 13 3964 | in 3965 | 3966 | let add_errors fmt = 3967 | Printf.kbprintf 3968 | (fun b -> 3969 | errors := SetString.add (Buffer.contents b) !errors; 3970 | Buffer.clear b) 3971 | buff 3972 | fmt 3973 | in 3974 | 3975 | let warn_exception e = 3976 | warning "%s" (string_of_exception e) 3977 | in 3978 | 3979 | (* Check tools *) 3980 | let check_tools lst = 3981 | List.iter 3982 | (function 3983 | | ExternalTool tool -> 3984 | begin 3985 | try 3986 | var_ignore_eval (BaseCheck.prog tool) 3987 | with e -> 3988 | warn_exception e; 3989 | add_errors (f_ "Cannot find external tool '%s'") tool 3990 | end 3991 | | InternalExecutable nm1 -> 3992 | (* Check that matching tool is built *) 3993 | List.iter 3994 | (function 3995 | | Executable ({cs_name = nm2}, 3996 | {bs_build = build}, 3997 | _) when nm1 = nm2 -> 3998 | if not (var_choose build) then 3999 | add_errors 4000 | (f_ "Cannot find buildable internal executable \ 4001 | '%s' when checking build depends") 4002 | nm1 4003 | | _ -> 4004 | ()) 4005 | pkg.sections) 4006 | lst 4007 | in 4008 | 4009 | let build_checks sct bs = 4010 | if var_choose bs.bs_build then 4011 | begin 4012 | if bs.bs_compiled_object = Native then 4013 | begin 4014 | try 4015 | var_ignore_eval BaseStandardVar.ocamlopt 4016 | with e -> 4017 | warn_exception e; 4018 | add_errors 4019 | (f_ "Section %s requires native compilation") 4020 | (OASISSection.string_of_section sct) 4021 | end; 4022 | 4023 | (* Check tools *) 4024 | check_tools bs.bs_build_tools; 4025 | 4026 | (* Check depends *) 4027 | List.iter 4028 | (function 4029 | | FindlibPackage (findlib_pkg, version_comparator) -> 4030 | begin 4031 | try 4032 | var_ignore_eval 4033 | (BaseCheck.package ?version_comparator findlib_pkg) 4034 | with e -> 4035 | warn_exception e; 4036 | match version_comparator with 4037 | | None -> 4038 | add_errors 4039 | (f_ "Cannot find findlib package %s") 4040 | findlib_pkg 4041 | | Some ver_cmp -> 4042 | add_errors 4043 | (f_ "Cannot find findlib package %s (%s)") 4044 | findlib_pkg 4045 | (OASISVersion.string_of_comparator ver_cmp) 4046 | end 4047 | | InternalLibrary nm1 -> 4048 | (* Check that matching library is built *) 4049 | List.iter 4050 | (function 4051 | | Library ({cs_name = nm2}, 4052 | {bs_build = build}, 4053 | _) when nm1 = nm2 -> 4054 | if not (var_choose build) then 4055 | add_errors 4056 | (f_ "Cannot find buildable internal library \ 4057 | '%s' when checking build depends") 4058 | nm1 4059 | | _ -> 4060 | ()) 4061 | pkg.sections) 4062 | bs.bs_build_depends 4063 | end 4064 | in 4065 | 4066 | (* Parse command line *) 4067 | BaseArgExt.parse argv (BaseEnv.args ()); 4068 | 4069 | (* OCaml version *) 4070 | begin 4071 | match pkg.ocaml_version with 4072 | | Some ver_cmp -> 4073 | begin 4074 | try 4075 | var_ignore_eval 4076 | (BaseCheck.version 4077 | "ocaml" 4078 | ver_cmp 4079 | BaseStandardVar.ocaml_version) 4080 | with e -> 4081 | warn_exception e; 4082 | add_errors 4083 | (f_ "OCaml version %s doesn't match version constraint %s") 4084 | (BaseStandardVar.ocaml_version ()) 4085 | (OASISVersion.string_of_comparator ver_cmp) 4086 | end 4087 | | None -> 4088 | () 4089 | end; 4090 | 4091 | (* Findlib version *) 4092 | begin 4093 | match pkg.findlib_version with 4094 | | Some ver_cmp -> 4095 | begin 4096 | try 4097 | var_ignore_eval 4098 | (BaseCheck.version 4099 | "findlib" 4100 | ver_cmp 4101 | BaseStandardVar.findlib_version) 4102 | with e -> 4103 | warn_exception e; 4104 | add_errors 4105 | (f_ "Findlib version %s doesn't match version constraint %s") 4106 | (BaseStandardVar.findlib_version ()) 4107 | (OASISVersion.string_of_comparator ver_cmp) 4108 | end 4109 | | None -> 4110 | () 4111 | end; 4112 | 4113 | (* Check build depends *) 4114 | List.iter 4115 | (function 4116 | | Executable (_, bs, _) 4117 | | Library (_, bs, _) as sct -> 4118 | build_checks sct bs 4119 | | Doc (_, doc) -> 4120 | if var_choose doc.doc_build then 4121 | check_tools doc.doc_build_tools 4122 | | Test (_, test) -> 4123 | if var_choose test.test_run then 4124 | check_tools test.test_tools 4125 | | _ -> 4126 | ()) 4127 | pkg.sections; 4128 | 4129 | (* Save and print environment *) 4130 | if SetString.empty = !errors then 4131 | begin 4132 | dump (); 4133 | print () 4134 | end 4135 | else 4136 | begin 4137 | List.iter 4138 | (fun e -> error "%s" e) 4139 | (SetString.elements !errors); 4140 | failwithf1 4141 | (fn_ 4142 | "%d configuration error" 4143 | "%d configuration errors" 4144 | (SetString.cardinal !errors)) 4145 | (SetString.cardinal !errors) 4146 | end 4147 | 4148 | end 4149 | 4150 | module InternalInstallPlugin = struct 4151 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/plugins/internal/InternalInstallPlugin.ml" 4152 | 4153 | (** Install using internal scheme 4154 | @author Sylvain Le Gall 4155 | *) 4156 | 4157 | open BaseEnv 4158 | open BaseStandardVar 4159 | open BaseMessage 4160 | open OASISTypes 4161 | open OASISLibrary 4162 | open OASISGettext 4163 | open OASISUtils 4164 | 4165 | let exec_hook = 4166 | ref (fun (cs, bs, exec) -> cs, bs, exec) 4167 | 4168 | let lib_hook = 4169 | ref (fun (cs, bs, lib) -> cs, bs, lib, []) 4170 | 4171 | let doc_hook = 4172 | ref (fun (cs, doc) -> cs, doc) 4173 | 4174 | let install_file_ev = 4175 | "install-file" 4176 | 4177 | let install_dir_ev = 4178 | "install-dir" 4179 | 4180 | let install_findlib_ev = 4181 | "install-findlib" 4182 | 4183 | let install pkg argv = 4184 | 4185 | let in_destdir = 4186 | try 4187 | let destdir = 4188 | destdir () 4189 | in 4190 | (* Practically speaking destdir is prepended 4191 | * at the beginning of the target filename 4192 | *) 4193 | fun fn -> destdir^fn 4194 | with PropList.Not_set _ -> 4195 | fun fn -> fn 4196 | in 4197 | 4198 | let install_file src_file envdir = 4199 | let tgt_dir = 4200 | in_destdir (envdir ()) 4201 | in 4202 | let tgt_file = 4203 | Filename.concat 4204 | tgt_dir 4205 | (Filename.basename src_file) 4206 | in 4207 | (* Create target directory if needed *) 4208 | BaseFileUtil.mkdir_parent 4209 | (fun dn -> 4210 | info (f_ "Creating directory '%s'") dn; 4211 | BaseLog.register install_dir_ev dn) 4212 | tgt_dir; 4213 | 4214 | (* Really install files *) 4215 | info (f_ "Copying file '%s' to '%s'") src_file tgt_file; 4216 | BaseFileUtil.cp src_file tgt_file; 4217 | BaseLog.register install_file_ev tgt_file 4218 | in 4219 | 4220 | (* Install data into defined directory *) 4221 | let install_data srcdir lst tgtdir = 4222 | let tgtdir = 4223 | BaseFilePath.of_unix (var_expand tgtdir) 4224 | in 4225 | List.iter 4226 | (fun (src, tgt_opt) -> 4227 | let real_srcs = 4228 | BaseFileUtil.glob 4229 | (Filename.concat srcdir src) 4230 | in 4231 | if real_srcs = [] then 4232 | failwithf1 4233 | (f_ "Wildcard '%s' doesn't match any files") 4234 | src; 4235 | List.iter 4236 | (fun fn -> 4237 | install_file 4238 | fn 4239 | (fun () -> 4240 | match tgt_opt with 4241 | | Some s -> 4242 | BaseFilePath.of_unix (var_expand s) 4243 | | None -> 4244 | tgtdir)) 4245 | real_srcs) 4246 | lst 4247 | in 4248 | 4249 | (** Install all libraries *) 4250 | let install_libs pkg = 4251 | 4252 | let files_of_library (f_data, acc) data_lib = 4253 | let cs, bs, lib, lib_extra = 4254 | !lib_hook data_lib 4255 | in 4256 | if var_choose bs.bs_install && 4257 | BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then 4258 | begin 4259 | let acc = 4260 | (* Start with acc + lib_extra *) 4261 | List.rev_append lib_extra acc 4262 | in 4263 | let acc = 4264 | (* Add uncompiled header from the source tree *) 4265 | let path = 4266 | BaseFilePath.of_unix bs.bs_path 4267 | in 4268 | List.fold_left 4269 | (fun acc modul -> 4270 | try 4271 | List.find 4272 | Sys.file_exists 4273 | (List.map 4274 | (Filename.concat path) 4275 | [modul^".mli"; 4276 | modul^".ml"; 4277 | String.uncapitalize modul^".mli"; 4278 | String.capitalize modul^".mli"; 4279 | String.uncapitalize modul^".ml"; 4280 | String.capitalize modul^".ml"]) 4281 | :: acc 4282 | with Not_found -> 4283 | begin 4284 | warning 4285 | (f_ "Cannot find source header for module %s \ 4286 | in library %s") 4287 | modul cs.cs_name; 4288 | acc 4289 | end) 4290 | acc 4291 | lib.lib_modules 4292 | in 4293 | 4294 | let acc = 4295 | (* Get generated files *) 4296 | BaseBuilt.fold 4297 | BaseBuilt.BLib 4298 | cs.cs_name 4299 | (fun acc fn -> fn :: acc) 4300 | acc 4301 | in 4302 | 4303 | let f_data () = 4304 | (* Install data associated with the library *) 4305 | install_data 4306 | bs.bs_path 4307 | bs.bs_data_files 4308 | (Filename.concat 4309 | (datarootdir ()) 4310 | pkg.name); 4311 | f_data () 4312 | in 4313 | 4314 | (f_data, acc) 4315 | end 4316 | else 4317 | begin 4318 | (f_data, acc) 4319 | end 4320 | in 4321 | 4322 | (* Install one group of library *) 4323 | let install_group_lib grp = 4324 | (* Iterate through all group nodes *) 4325 | let rec install_group_lib_aux data_and_files grp = 4326 | let data_and_files, children = 4327 | match grp with 4328 | | Container (_, children) -> 4329 | data_and_files, children 4330 | | Package (_, cs, bs, lib, children) -> 4331 | files_of_library data_and_files (cs, bs, lib), children 4332 | in 4333 | List.fold_left 4334 | install_group_lib_aux 4335 | data_and_files 4336 | children 4337 | in 4338 | 4339 | (* Findlib name of the root library *) 4340 | let findlib_name = 4341 | findlib_of_group grp 4342 | in 4343 | 4344 | (* Determine root library *) 4345 | let root_lib = 4346 | root_of_group grp 4347 | in 4348 | 4349 | (* All files to install for this library *) 4350 | let f_data, files = 4351 | install_group_lib_aux (ignore, []) grp 4352 | in 4353 | 4354 | (* Really install, if there is something to install *) 4355 | if files = [] then 4356 | begin 4357 | warning 4358 | (f_ "Nothing to install for findlib library '%s'") 4359 | findlib_name 4360 | end 4361 | else 4362 | begin 4363 | let meta = 4364 | (* Search META file *) 4365 | let (_, bs, _) = 4366 | root_lib 4367 | in 4368 | let res = 4369 | Filename.concat bs.bs_path "META" 4370 | in 4371 | if not (Sys.file_exists res) then 4372 | failwithf2 4373 | (f_ "Cannot find file '%s' for findlib library %s") 4374 | res 4375 | findlib_name; 4376 | res 4377 | in 4378 | info 4379 | (f_ "Installing findlib library '%s'") 4380 | findlib_name; 4381 | BaseExec.run 4382 | (ocamlfind ()) 4383 | ("install" :: findlib_name :: meta :: files); 4384 | BaseLog.register install_findlib_ev findlib_name 4385 | end; 4386 | 4387 | (* Install data files *) 4388 | f_data (); 4389 | 4390 | in 4391 | 4392 | (* We install libraries in groups *) 4393 | List.iter 4394 | install_group_lib 4395 | (group_libs pkg) 4396 | in 4397 | 4398 | let install_execs pkg = 4399 | let install_exec data_exec = 4400 | let (cs, bs, exec) = 4401 | !exec_hook data_exec 4402 | in 4403 | if var_choose bs.bs_install && 4404 | BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then 4405 | begin 4406 | let exec_libdir () = 4407 | Filename.concat 4408 | (libdir ()) 4409 | pkg.name 4410 | in 4411 | BaseBuilt.fold 4412 | BaseBuilt.BExec 4413 | cs.cs_name 4414 | (fun () fn -> 4415 | install_file 4416 | fn 4417 | bindir) 4418 | (); 4419 | BaseBuilt.fold 4420 | BaseBuilt.BExecLib 4421 | cs.cs_name 4422 | (fun () fn -> 4423 | install_file 4424 | fn 4425 | exec_libdir) 4426 | (); 4427 | install_data 4428 | bs.bs_path 4429 | bs.bs_data_files 4430 | (Filename.concat 4431 | (datarootdir ()) 4432 | pkg.name) 4433 | end 4434 | in 4435 | List.iter 4436 | (function 4437 | | Executable (cs, bs, exec)-> 4438 | install_exec (cs, bs, exec) 4439 | | _ -> 4440 | ()) 4441 | pkg.sections 4442 | in 4443 | 4444 | let install_docs pkg = 4445 | let install_doc data = 4446 | let (cs, doc) = 4447 | !doc_hook data 4448 | in 4449 | if var_choose doc.doc_install && 4450 | BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then 4451 | begin 4452 | let tgt_dir = 4453 | BaseFilePath.of_unix (var_expand doc.doc_install_dir) 4454 | in 4455 | BaseBuilt.fold 4456 | BaseBuilt.BDoc 4457 | cs.cs_name 4458 | (fun () fn -> 4459 | install_file 4460 | fn 4461 | (fun () -> tgt_dir)) 4462 | (); 4463 | install_data 4464 | Filename.current_dir_name 4465 | doc.doc_data_files 4466 | doc.doc_install_dir 4467 | end 4468 | in 4469 | List.iter 4470 | (function 4471 | | Doc (cs, doc) -> 4472 | install_doc (cs, doc) 4473 | | _ -> 4474 | ()) 4475 | pkg.sections 4476 | in 4477 | 4478 | install_libs pkg; 4479 | install_execs pkg; 4480 | install_docs pkg 4481 | 4482 | (* Uninstall already installed data *) 4483 | let uninstall _ argv = 4484 | List.iter 4485 | (fun (ev, data) -> 4486 | if ev = install_file_ev then 4487 | begin 4488 | if Sys.file_exists data then 4489 | begin 4490 | info 4491 | (f_ "Removing file '%s'") 4492 | data; 4493 | Sys.remove data 4494 | end 4495 | else 4496 | begin 4497 | warning 4498 | (f_ "File '%s' doesn't exist anymore") 4499 | data 4500 | end 4501 | end 4502 | else if ev = install_dir_ev then 4503 | begin 4504 | if Sys.file_exists data && Sys.is_directory data then 4505 | begin 4506 | if Sys.readdir data = [||] then 4507 | begin 4508 | info 4509 | (f_ "Removing directory '%s'") 4510 | data; 4511 | BaseFileUtil.rmdir data 4512 | end 4513 | else 4514 | begin 4515 | warning 4516 | (f_ "Directory '%s' is not empty (%s)") 4517 | data 4518 | (String.concat 4519 | ", " 4520 | (Array.to_list 4521 | (Sys.readdir data))) 4522 | end 4523 | end 4524 | else 4525 | begin 4526 | warning 4527 | (f_ "Directory '%s' doesn't exist anymore") 4528 | data 4529 | end 4530 | end 4531 | else if ev = install_findlib_ev then 4532 | begin 4533 | info (f_ "Removing findlib library '%s'") data; 4534 | BaseExec.run (ocamlfind ()) ["remove"; data] 4535 | end 4536 | else 4537 | failwithf1 (f_ "Unknown log event '%s'") ev; 4538 | BaseLog.unregister ev data) 4539 | (* We process event in reverse order *) 4540 | (List.rev 4541 | (BaseLog.filter 4542 | [install_file_ev; 4543 | install_dir_ev; 4544 | install_findlib_ev;])) 4545 | 4546 | end 4547 | 4548 | 4549 | module OCamlbuildCommon = struct 4550 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" 4551 | 4552 | (** Functions common to OCamlbuild build and doc plugin 4553 | *) 4554 | 4555 | open OASISGettext 4556 | open BaseEnv 4557 | open BaseStandardVar 4558 | 4559 | let ocamlbuild_clean_ev = 4560 | "ocamlbuild-clean" 4561 | 4562 | let ocamlbuildflags = 4563 | var_define 4564 | ~short_desc:(fun () -> "OCamlbuild additional flags") 4565 | "ocamlbuildflags" 4566 | (lazy "") 4567 | 4568 | (** Fix special arguments depending on environment *) 4569 | let fix_args args extra_argv = 4570 | List.flatten 4571 | [ 4572 | if (os_type ()) = "Win32" then 4573 | [ 4574 | "-classic-display"; 4575 | "-no-log"; 4576 | "-no-links"; 4577 | "-install-lib-dir"; 4578 | (Filename.concat (standard_library ()) "ocamlbuild") 4579 | ] 4580 | else 4581 | []; 4582 | 4583 | if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then 4584 | [ 4585 | "-byte-plugin" 4586 | ] 4587 | else 4588 | []; 4589 | args; 4590 | 4591 | if bool_of_string (debug ()) then 4592 | ["-tag"; "debug"] 4593 | else 4594 | []; 4595 | 4596 | if bool_of_string (profile ()) then 4597 | ["-tag"; "profile"] 4598 | else 4599 | []; 4600 | 4601 | OASISUtils.split ' ' (ocamlbuildflags ()); 4602 | 4603 | Array.to_list extra_argv; 4604 | ] 4605 | 4606 | (** Run 'ocamlbuild -clean' if not already done *) 4607 | let run_clean extra_argv = 4608 | let extra_cli = 4609 | String.concat " " (Array.to_list extra_argv) 4610 | in 4611 | (* Run if never called with these args *) 4612 | if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then 4613 | begin 4614 | BaseExec.run (ocamlbuild ()) (fix_args ["-clean"] extra_argv); 4615 | BaseLog.register ocamlbuild_clean_ev extra_cli; 4616 | at_exit 4617 | (fun () -> 4618 | try 4619 | BaseLog.unregister ocamlbuild_clean_ev extra_cli 4620 | with _ -> 4621 | ()) 4622 | end 4623 | 4624 | (** Run ocamlbuild, unregister all clean events *) 4625 | let run_ocamlbuild args extra_argv = 4626 | (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html 4627 | *) 4628 | BaseExec.run (ocamlbuild ()) (fix_args args extra_argv); 4629 | (* Remove any clean event, we must run it again *) 4630 | List.iter 4631 | (fun (e, d) -> BaseLog.unregister e d) 4632 | (BaseLog.filter [ocamlbuild_clean_ev]) 4633 | 4634 | (** Determine real build directory *) 4635 | let build_dir extra_argv = 4636 | let rec search_args dir = 4637 | function 4638 | | "-build-dir" :: dir :: tl -> 4639 | search_args dir tl 4640 | | _ :: tl -> 4641 | search_args dir tl 4642 | | [] -> 4643 | dir 4644 | in 4645 | search_args "_build" (fix_args [] extra_argv) 4646 | 4647 | end 4648 | 4649 | module OCamlbuildPlugin = struct 4650 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" 4651 | 4652 | (** Build using ocamlbuild 4653 | @author Sylvain Le Gall 4654 | *) 4655 | 4656 | open OASISTypes 4657 | open OASISGettext 4658 | open OASISUtils 4659 | open BaseEnv 4660 | open OCamlbuildCommon 4661 | open BaseStandardVar 4662 | open BaseMessage 4663 | 4664 | type target = 4665 | | Std of string list 4666 | | StdRename of string * string 4667 | 4668 | let cond_targets_hook = 4669 | ref (fun lst -> lst) 4670 | 4671 | let build pkg argv = 4672 | 4673 | (* Return the filename in build directory *) 4674 | let in_build_dir fn = 4675 | Filename.concat 4676 | (build_dir argv) 4677 | fn 4678 | in 4679 | 4680 | (* Return the unix filename in host build directory *) 4681 | let in_build_dir_of_unix fn = 4682 | in_build_dir (BaseFilePath.of_unix fn) 4683 | in 4684 | 4685 | let cond_targets = 4686 | List.fold_left 4687 | (fun acc -> 4688 | function 4689 | | Library (cs, bs, lib) when var_choose bs.bs_build -> 4690 | begin 4691 | let evs, unix_files = 4692 | BaseBuilt.of_library 4693 | in_build_dir_of_unix 4694 | (cs, bs, lib) 4695 | in 4696 | 4697 | let ends_with nd fn = 4698 | let nd_len = 4699 | String.length nd 4700 | in 4701 | (String.length fn >= nd_len) 4702 | && 4703 | (String.sub 4704 | fn 4705 | (String.length fn - nd_len) 4706 | nd_len) = nd 4707 | in 4708 | 4709 | let tgts = 4710 | List.filter 4711 | (fun l -> l <> []) 4712 | (List.map 4713 | (List.filter 4714 | (fun fn -> 4715 | ends_with ".cma" fn || 4716 | ends_with ".cmxa" fn || 4717 | ends_with (ext_lib ()) fn || 4718 | ends_with (ext_dll ()) fn)) 4719 | unix_files) 4720 | in 4721 | 4722 | match tgts with 4723 | | hd :: tl -> 4724 | (evs, Std hd) 4725 | :: 4726 | (List.map (fun tgts -> [], Std tgts) tl) 4727 | @ 4728 | acc 4729 | | [] -> 4730 | failwithf2 4731 | (f_ "No possible ocamlbuild targets \ 4732 | in generated files %s for library %s") 4733 | (String.concat (s_ ", " ) (List.map (String.concat (s_ ", ")) tgts)) 4734 | cs.cs_name 4735 | end 4736 | 4737 | | Executable (cs, bs, exec) when var_choose bs.bs_build -> 4738 | begin 4739 | let evs, unix_exec_is, unix_dll_opt = 4740 | BaseBuilt.of_executable 4741 | in_build_dir_of_unix 4742 | (cs, bs, exec) 4743 | in 4744 | 4745 | let host_exec_is = 4746 | in_build_dir_of_unix unix_exec_is 4747 | in 4748 | 4749 | let target ext = 4750 | let unix_tgt = 4751 | (BaseFilePath.Unix.concat 4752 | bs.bs_path 4753 | (BaseFilePath.Unix.chop_extension 4754 | exec.exec_main_is))^ext 4755 | in 4756 | 4757 | evs, 4758 | (if unix_tgt = unix_exec_is then 4759 | Std [unix_tgt] 4760 | else 4761 | StdRename (unix_tgt, host_exec_is)) 4762 | in 4763 | 4764 | (* Add executable *) 4765 | let acc = 4766 | match bs.bs_compiled_object with 4767 | | Native -> 4768 | (target ".native") :: acc 4769 | | Best when bool_of_string (is_native ()) -> 4770 | (target ".native") :: acc 4771 | | Byte 4772 | | Best -> 4773 | (target ".byte") :: acc 4774 | in 4775 | acc 4776 | end 4777 | 4778 | | Library _ | Executable _ | Test _ 4779 | | SrcRepo _ | Flag _ | Doc _ -> 4780 | acc) 4781 | [] 4782 | (* Keep the pkg.sections ordered *) 4783 | (List.rev pkg.sections); 4784 | in 4785 | 4786 | (* Check and register built files *) 4787 | let check_and_register (bt, bnm, lst) = 4788 | List.iter 4789 | (fun fns -> 4790 | if not (List.exists Sys.file_exists fns) then 4791 | failwithf1 4792 | (f_ "No one of expected built files %s exists") 4793 | (String.concat (s_ ", ") (List.map (Printf.sprintf "'%s'") fns))) 4794 | lst; 4795 | (BaseBuilt.register bt bnm lst) 4796 | in 4797 | 4798 | (* Run a list of target + post process *) 4799 | let run_ocamlbuild rtargets = 4800 | run_ocamlbuild 4801 | (List.rev_map snd rtargets) 4802 | argv; 4803 | List.iter 4804 | check_and_register 4805 | (List.flatten (List.rev_map fst rtargets)) 4806 | in 4807 | 4808 | (* Compare two files, return true if they differ *) 4809 | let diff fn1 fn2 = 4810 | if Sys.file_exists fn1 && Sys.file_exists fn2 then 4811 | begin 4812 | let chn1 = open_in fn1 in 4813 | let chn2 = open_in fn2 in 4814 | let res = 4815 | if in_channel_length chn1 = in_channel_length chn2 then 4816 | begin 4817 | let len = 4818 | 4096 4819 | in 4820 | let str1 = 4821 | String.make len '\000' 4822 | in 4823 | let str2 = 4824 | String.copy str1 4825 | in 4826 | try 4827 | while (String.compare str1 str2) = 0 do 4828 | really_input chn1 str1 0 len; 4829 | really_input chn2 str2 0 len 4830 | done; 4831 | true 4832 | with End_of_file -> 4833 | false 4834 | end 4835 | else 4836 | true 4837 | in 4838 | close_in chn1; close_in chn2; 4839 | res 4840 | end 4841 | else 4842 | true 4843 | in 4844 | 4845 | let last_rtargets = 4846 | List.fold_left 4847 | (fun acc (built, tgt) -> 4848 | match tgt with 4849 | | Std nms -> 4850 | (built, List.hd nms) :: acc 4851 | | StdRename (src, tgt) -> 4852 | begin 4853 | (* We run with a fake list for event registering *) 4854 | run_ocamlbuild (([], src) :: acc); 4855 | 4856 | (* And then copy and register *) 4857 | begin 4858 | let src_fn = 4859 | in_build_dir_of_unix src 4860 | in 4861 | if diff src_fn tgt then 4862 | BaseFileUtil.cp src_fn tgt 4863 | else 4864 | info 4865 | (f_ "No need to copy file '%s' to '%s', same content") 4866 | src_fn tgt 4867 | end; 4868 | List.iter check_and_register built; 4869 | [] 4870 | end) 4871 | [] 4872 | (!cond_targets_hook cond_targets) 4873 | in 4874 | if last_rtargets <> [] then 4875 | run_ocamlbuild last_rtargets 4876 | 4877 | let clean pkg extra_args = 4878 | run_clean extra_args; 4879 | List.iter 4880 | (function 4881 | | Library (cs, _, _) -> 4882 | BaseBuilt.unregister BaseBuilt.BLib cs.cs_name 4883 | | Executable (cs, _, _) -> 4884 | BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; 4885 | BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name 4886 | | _ -> 4887 | ()) 4888 | pkg.sections 4889 | 4890 | end 4891 | 4892 | module OCamlbuildDocPlugin = struct 4893 | # 21 "/opt/local/var/macports/build/_Users_bmeurer_Desktop_Projects_MacPorts_ports_devel_caml-oasis/caml-oasis/work/oasis-0.2.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" 4894 | 4895 | (* Create documentation using ocamlbuild .odocl files 4896 | @author Sylvain Le Gall 4897 | *) 4898 | 4899 | open OASISTypes 4900 | open OASISGettext 4901 | open OASISMessage 4902 | open OCamlbuildCommon 4903 | open BaseStandardVar 4904 | 4905 | 4906 | 4907 | let doc_build path pkg (cs, doc) argv = 4908 | let index_html = 4909 | BaseFilePath.Unix.make 4910 | [ 4911 | path; 4912 | cs.cs_name^".docdir"; 4913 | "index.html"; 4914 | ] 4915 | in 4916 | let tgt_dir = 4917 | BaseFilePath.make 4918 | [ 4919 | build_dir argv; 4920 | BaseFilePath.of_unix path; 4921 | cs.cs_name^".docdir"; 4922 | ] 4923 | in 4924 | run_ocamlbuild [index_html] argv; 4925 | List.iter 4926 | (fun glb -> 4927 | BaseBuilt.register 4928 | BaseBuilt.BDoc 4929 | cs.cs_name 4930 | [BaseFileUtil.glob 4931 | (Filename.concat tgt_dir glb)]) 4932 | ["*.html"; "*.css"] 4933 | 4934 | let doc_clean t pkg (cs, doc) argv = 4935 | run_clean argv; 4936 | BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name 4937 | 4938 | end 4939 | 4940 | 4941 | open OASISTypes;; 4942 | 4943 | let setup_t = 4944 | { 4945 | BaseSetup.configure = InternalConfigurePlugin.configure; 4946 | build = OCamlbuildPlugin.build; 4947 | test = []; 4948 | doc = [("rbtrees", OCamlbuildDocPlugin.doc_build "src")]; 4949 | install = InternalInstallPlugin.install; 4950 | uninstall = InternalInstallPlugin.uninstall; 4951 | clean = [OCamlbuildPlugin.clean]; 4952 | clean_test = []; 4953 | clean_doc = [("rbtrees", OCamlbuildDocPlugin.doc_clean "src")]; 4954 | distclean = []; 4955 | distclean_test = []; 4956 | distclean_doc = []; 4957 | package = 4958 | { 4959 | oasis_version = "0.2"; 4960 | ocaml_version = None; 4961 | findlib_version = None; 4962 | name = "ocaml-rbtrees"; 4963 | version = "0.2.0+dev"; 4964 | license = 4965 | OASISLicense.DEP5License 4966 | { 4967 | OASISLicense.license = "MIT"; 4968 | exceptions = []; 4969 | version = OASISLicense.NoVersion; 4970 | }; 4971 | license_file = Some "LICENSE"; 4972 | copyrights = ["(c) 2007-2011 Benedikt Meurer"]; 4973 | maintainers = []; 4974 | authors = ["Benedikt Meurer "]; 4975 | homepage = Some "https://github.com/bmeurer/ocaml-rbtrees/"; 4976 | synopsis = "An implementation of Red-Black Trees for OCaml"; 4977 | description = 4978 | Some 4979 | "This is my implementation of Red-Black Trees for OCaml. It is based upon\nthe implementation described in the paper \"Red-Black Trees in a Functional\nSetting\" by Chris Okasaki published in \"Journal of Functional Programming\",\n9(4):471-477, July 1999.\n\nThe Red-Black Trees are exposed via a map and a set API, which is designed\nto be compatible with the Map and Set modules in the OCaml standard library\n(which are implemented using AVL trees). You can use the Rbmap and Rbset\nmodules as drop-in replacement for the Map and Set modules."; 4980 | categories = []; 4981 | conf_type = (`Configure, "internal", Some "0.2"); 4982 | conf_custom = 4983 | { 4984 | pre_command = [(OASISExpr.EBool true, None)]; 4985 | post_command = [(OASISExpr.EBool true, None)]; 4986 | }; 4987 | build_type = (`Build, "ocamlbuild", Some "0.2"); 4988 | build_custom = 4989 | { 4990 | pre_command = [(OASISExpr.EBool true, None)]; 4991 | post_command = [(OASISExpr.EBool true, None)]; 4992 | }; 4993 | install_type = (`Install, "internal", Some "0.2"); 4994 | install_custom = 4995 | { 4996 | pre_command = [(OASISExpr.EBool true, None)]; 4997 | post_command = [(OASISExpr.EBool true, None)]; 4998 | }; 4999 | uninstall_custom = 5000 | { 5001 | pre_command = [(OASISExpr.EBool true, None)]; 5002 | post_command = [(OASISExpr.EBool true, None)]; 5003 | }; 5004 | clean_custom = 5005 | { 5006 | pre_command = [(OASISExpr.EBool true, None)]; 5007 | post_command = [(OASISExpr.EBool true, None)]; 5008 | }; 5009 | distclean_custom = 5010 | { 5011 | pre_command = [(OASISExpr.EBool true, None)]; 5012 | post_command = [(OASISExpr.EBool true, None)]; 5013 | }; 5014 | files_ab = []; 5015 | sections = 5016 | [ 5017 | Doc 5018 | ({ 5019 | cs_name = "rbtrees"; 5020 | cs_data = PropList.Data.create (); 5021 | cs_plugin_data = []; 5022 | }, 5023 | { 5024 | doc_type = (`Doc, "ocamlbuild", Some "0.2"); 5025 | doc_custom = 5026 | { 5027 | pre_command = [(OASISExpr.EBool true, None)]; 5028 | post_command = [(OASISExpr.EBool true, None)]; 5029 | }; 5030 | doc_build = [(OASISExpr.EBool true, true)]; 5031 | doc_install = [(OASISExpr.EBool true, true)]; 5032 | doc_install_dir = "$htmldir"; 5033 | doc_title = "API reference for rbtrees"; 5034 | doc_authors = []; 5035 | doc_abstract = None; 5036 | doc_format = OtherDoc; 5037 | doc_data_files = []; 5038 | doc_build_tools = 5039 | [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; 5040 | }); 5041 | Library 5042 | ({ 5043 | cs_name = "rbtrees"; 5044 | cs_data = PropList.Data.create (); 5045 | cs_plugin_data = []; 5046 | }, 5047 | { 5048 | bs_build = [(OASISExpr.EBool true, true)]; 5049 | bs_install = [(OASISExpr.EBool true, true)]; 5050 | bs_path = "src"; 5051 | bs_compiled_object = Best; 5052 | bs_build_depends = []; 5053 | bs_build_tools = [ExternalTool "ocamlbuild"]; 5054 | bs_c_sources = []; 5055 | bs_data_files = []; 5056 | bs_ccopt = [(OASISExpr.EBool true, [])]; 5057 | bs_cclib = [(OASISExpr.EBool true, [])]; 5058 | bs_dlllib = [(OASISExpr.EBool true, [])]; 5059 | bs_dllpath = [(OASISExpr.EBool true, [])]; 5060 | bs_byteopt = [(OASISExpr.EBool true, [])]; 5061 | bs_nativeopt = [(OASISExpr.EBool true, [])]; 5062 | }, 5063 | { 5064 | lib_modules = ["Rbmap"; "Rbset"]; 5065 | lib_internal_modules = []; 5066 | lib_findlib_parent = None; 5067 | lib_findlib_name = None; 5068 | lib_findlib_containers = []; 5069 | }); 5070 | SrcRepo 5071 | ({ 5072 | cs_name = "master"; 5073 | cs_data = PropList.Data.create (); 5074 | cs_plugin_data = []; 5075 | }, 5076 | { 5077 | src_repo_type = Git; 5078 | src_repo_location = 5079 | "git://github.com/bmeurer/ocaml-rbtrees.git"; 5080 | src_repo_browser = 5081 | Some "https://github.com/bmeurer/ocaml-rbtrees"; 5082 | src_repo_module = None; 5083 | src_repo_branch = Some "master"; 5084 | src_repo_tag = None; 5085 | src_repo_subdir = None; 5086 | }) 5087 | ]; 5088 | plugins = 5089 | [ 5090 | (`Extra, "META", Some "0.2"); 5091 | (`Extra, "DevFiles", Some "0.2"); 5092 | (`Extra, "StdFiles", Some "0.2") 5093 | ]; 5094 | schema_data = PropList.Data.create (); 5095 | plugin_data = []; 5096 | }; 5097 | version = "0.2.0"; 5098 | };; 5099 | 5100 | let setup () = BaseSetup.setup setup_t;; 5101 | 5102 | (* OASIS_STOP *) 5103 | let () = setup ();; 5104 | -------------------------------------------------------------------------------- /src/META: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: a3382b6674aeaf763babbbbb959ad591) 3 | version = "0.2.0+dev" 4 | description = "An implementation of Red-Black Trees for OCaml" 5 | archive(byte) = "rbtrees.cma" 6 | archive(native) = "rbtrees.cmxa" 7 | exists_if = "rbtrees.cma" 8 | # OASIS_STOP 9 | 10 | -------------------------------------------------------------------------------- /src/rbmap.ml: -------------------------------------------------------------------------------- 1 | (*- 2 | * Copyright (c) 2007, Benedikt Meurer 3 | * 4 | * Permission is hereby granted, free of charge, to any person obtaining a 5 | * copy of this software and associated documentation files (the "Software"), 6 | * to deal in the Software without restriction, including without limitation 7 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 8 | * and/or sell copies of the Software, and to permit persons to whom the 9 | * Software is furnished to do so, subject to the following conditions: 10 | * 11 | * The above copyright notice and this permission notice shall be included in 12 | * all copies or substantial portions of the Software. 13 | * 14 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 15 | * OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 17 | * THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 19 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 20 | * IN THE SOFTWARE. 21 | *) 22 | 23 | (* This is my implementation of Red-Black Trees for OCaml. It is based upon 24 | * "Red-Black Trees in a Functional Setting", Chris Okasaki in "Functional 25 | * Pearls". 26 | * Red-Black Trees are exposed via a map and a set API, which is designed to 27 | * be compatible with the Map and Set modules in the OCaml standard library 28 | * (which are implemented using AVL trees). You can use the Rbmap and Rbset 29 | * modules as drop-in replacement for the Map and Set modules. 30 | *) 31 | 32 | module type OrderedType = 33 | sig 34 | type t 35 | val compare: t -> t -> int 36 | end 37 | 38 | module type S = 39 | sig 40 | type key 41 | type +'a t 42 | val empty: 'a t 43 | val is_empty: 'a t -> bool 44 | val add: key -> 'a -> 'a t -> 'a t 45 | val find: key -> 'a t -> 'a 46 | val remove: key -> 'a t -> 'a t 47 | val mem: key -> 'a t -> bool 48 | val iter: (key -> 'a -> unit) -> 'a t -> unit 49 | val map: ('a -> 'b) -> 'a t -> 'b t 50 | val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t 51 | val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b 52 | val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int 53 | val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool 54 | end 55 | 56 | module Make(Ord: OrderedType) = 57 | struct 58 | type key = Ord.t 59 | 60 | type 'a t = 61 | | Black of 'a t * key * 'a * 'a t 62 | | Red of 'a t * key * 'a * 'a t 63 | | Empty 64 | 65 | type 'a enum = 66 | | End 67 | | More of key * 'a * 'a t * 'a enum 68 | 69 | let rec enum m e = 70 | match m with 71 | | Empty -> e 72 | | Black(l, k, x, r) | Red(l, k, x, r) -> enum l (More(k, x, r, e)) 73 | 74 | let blackify = function 75 | | Red(l, k, x, r) -> Black(l, k, x, r), false 76 | | m -> m, true 77 | 78 | let empty = Empty 79 | 80 | let is_empty = function 81 | | Empty -> true 82 | | _ -> false 83 | 84 | let balance_left l kx x r = 85 | match l, kx, x, r with 86 | | Red(Red(a, kx, x, b), ky, y, c), kz, z, d 87 | | Red(a, kx, x, Red(b, ky, y, c)), kz, z, d -> 88 | Red(Black(a, kx, x, b), ky, y, Black(c, kz, z, d)) 89 | | l, kx, x, r -> 90 | Black(l, kx, x, r) 91 | 92 | let balance_right l kx x r = 93 | match l, kx, x, r with 94 | | a, kx, x, Red(Red(b, ky, y, c), kz, z, d) 95 | | a, kx, x, Red(b, ky, y, Red(c, kz, z, d)) -> 96 | Red(Black(a, kx, x, b), ky, y, Black(c, kz, z, d)) 97 | | l, kx, x, r -> 98 | Black(l, kx, x, r) 99 | 100 | let add kx x m = 101 | let rec add_aux = function 102 | | Empty -> 103 | Red(Empty, kx, x, Empty) 104 | | Red(l, ky, y, r) -> 105 | let c = Ord.compare kx ky in 106 | if c < 0 then 107 | Red(add_aux l, ky, y, r) 108 | else if c > 0 then 109 | Red(l, ky, y, add_aux r) 110 | else 111 | Red(l, kx, x, r) 112 | | Black(l, ky, y, r) -> 113 | let c = Ord.compare kx ky in 114 | if c < 0 then 115 | balance_left (add_aux l) ky y r 116 | else if c > 0 then 117 | balance_right l ky y (add_aux r) 118 | else 119 | Black(l, kx, x, r) 120 | in fst (blackify (add_aux m)) 121 | 122 | let rec find k = function 123 | | Empty -> 124 | raise Not_found 125 | | Red(l, kx, x, r) 126 | | Black(l, kx, x, r) -> 127 | let c = Ord.compare k kx in 128 | if c < 0 then find k l 129 | else if c > 0 then find k r 130 | else x 131 | 132 | let unbalanced_left = function 133 | | Red(Black(a, kx, x, b), ky, y, c) -> 134 | balance_left (Red(a, kx, x, b)) ky y c, false 135 | | Black(Black(a, kx, x, b), ky, y, c) -> 136 | balance_left (Red(a, kx, x, b)) ky y c, true 137 | | Black(Red(a, kx, x, Black(b, ky, y, c)), kz, z, d) -> 138 | Black(a, kx, x, balance_left (Red(b, ky, y, c)) kz z d), false 139 | | _ -> 140 | assert false 141 | 142 | let unbalanced_right = function 143 | | Red(a, kx, x, Black(b, ky, y, c)) -> 144 | balance_right a kx x (Red(b, ky, y, c)), false 145 | | Black(a, kx, x, Black(b, ky, y, c)) -> 146 | balance_right a kx x (Red(b, ky, y, c)), true 147 | | Black(a, kx, x, Red(Black(b, ky, y, c), kz, z, d)) -> 148 | Black(balance_right a kx x (Red(b, ky, y, c)), kz, z, d), false 149 | | _ -> 150 | assert false 151 | 152 | let rec remove_min = function 153 | | Empty 154 | | Black(Empty, _, _, Black(_)) -> 155 | assert false 156 | | Black(Empty, kx, x, Empty) -> 157 | Empty, kx, x, true 158 | | Black(Empty, kx, x, Red(l, ky, y, r)) -> 159 | Black(l, ky, y, r), kx, x, false 160 | | Red(Empty, kx, x, r) -> 161 | r, kx, x, false 162 | | Black(l, kx, x, r) -> 163 | let l, ky, y, d = remove_min l in 164 | let m = Black(l, kx, x, r) in 165 | if d then 166 | let m, d = unbalanced_right m in m, ky, y, d 167 | else 168 | m, ky, y, false 169 | | Red(l, kx, x, r) -> 170 | let l, ky, y, d = remove_min l in 171 | let m = Red(l, kx, x, r) in 172 | if d then 173 | let m, d = unbalanced_right m in m, ky, y, d 174 | else 175 | m, ky, y, false 176 | 177 | let remove k m = 178 | let rec remove_aux = function 179 | | Empty -> 180 | Empty, false 181 | | Black(l, kx, x, r) -> 182 | let c = Ord.compare k kx in 183 | if c < 0 then 184 | let l, d = remove_aux l in 185 | let m = Black(l, kx, x, r) in 186 | if d then unbalanced_right m else m, false 187 | else if c > 0 then 188 | let r, d = remove_aux r in 189 | let m = Black(l, kx, x, r) in 190 | if d then unbalanced_left m else m, false 191 | else 192 | begin match r with 193 | | Empty -> 194 | blackify l 195 | | _ -> 196 | let r, kx, x, d = remove_min r in 197 | let m = Black(l, kx, x, r) in 198 | if d then unbalanced_left m else m, false 199 | end 200 | | Red(l, kx, x, r) -> 201 | let c = Ord.compare k kx in 202 | if c < 0 then 203 | let l, d = remove_aux l in 204 | let m = Red(l, kx, x, r) in 205 | if d then unbalanced_right m else m, false 206 | else if c > 0 then 207 | let r, d = remove_aux r in 208 | let m = Red(l, kx, x, r) in 209 | if d then unbalanced_left m else m, false 210 | else 211 | begin match r with 212 | | Empty -> 213 | l, false 214 | | _ -> 215 | let r, kx, x, d = remove_min r in 216 | let m = Red(l, kx, x, r) in 217 | if d then unbalanced_left m else m, false 218 | end 219 | in fst (remove_aux m) 220 | 221 | let rec mem k = function 222 | | Empty -> 223 | false 224 | | Red(l, kx, x, r) 225 | | Black(l, kx, x, r) -> 226 | let c = Ord.compare k kx in 227 | if c < 0 then mem k l 228 | else if c > 0 then mem k r 229 | else true 230 | 231 | let rec iter f = function 232 | | Empty -> () 233 | | Red(l, k, x, r) | Black(l, k, x, r) -> iter f l; f k x; iter f r 234 | 235 | let rec map f = function 236 | | Empty -> Empty 237 | | Red(l, k, x, r) -> Red(map f l, k, f x, map f r) 238 | | Black(l, k, x, r) -> Black(map f l, k, f x, map f r) 239 | 240 | let rec mapi f = function 241 | | Empty -> Empty 242 | | Red(l, k, x, r) -> Red(mapi f l, k, f k x, mapi f r) 243 | | Black(l, k, x, r) -> Black(mapi f l, k, f k x, mapi f r) 244 | 245 | let rec fold f m accu = 246 | match m with 247 | | Empty -> accu 248 | | Red(l, k, x, r) | Black(l, k, x, r) -> fold f r (f k x (fold f l accu)) 249 | 250 | let compare cmp m1 m2 = 251 | let rec compare_aux e1 e2 = 252 | match e1, e2 with 253 | | End, End -> 254 | 0 255 | | End, _ -> 256 | -1 257 | | _, End -> 258 | 1 259 | | More(k1, x1, r1, e1), More(k2, x2, r2, e2) -> 260 | let c = Ord.compare k1 k2 in 261 | if c <> 0 then c 262 | else 263 | let c = cmp x1 x2 in 264 | if c <> 0 then c 265 | else compare_aux (enum r1 e1) (enum r2 e2) 266 | in compare_aux (enum m1 End) (enum m2 End) 267 | 268 | let equal cmp m1 m2 = 269 | let rec equal_aux e1 e2 = 270 | match e1, e2 with 271 | | End, End -> 272 | true 273 | | End, _ 274 | | _, End -> 275 | false 276 | | More(k1, x1, r1, e1), More(k2, x2, r2, e2) -> 277 | (Ord.compare k1 k2 = 0 278 | && cmp x1 x2 279 | && equal_aux (enum r1 e1) (enum r2 e2)) 280 | in equal_aux (enum m1 End) (enum m2 End) 281 | end 282 | -------------------------------------------------------------------------------- /src/rbmap.mli: -------------------------------------------------------------------------------- 1 | (*- 2 | * Copyright (c) 2007, Benedikt Meurer 3 | * 4 | * Permission is hereby granted, free of charge, to any person obtaining a 5 | * copy of this software and associated documentation files (the "Software"), 6 | * to deal in the Software without restriction, including without limitation 7 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 8 | * and/or sell copies of the Software, and to permit persons to whom the 9 | * Software is furnished to do so, subject to the following conditions: 10 | * 11 | * The above copyright notice and this permission notice shall be included in 12 | * all copies or substantial portions of the Software. 13 | * 14 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 15 | * OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 17 | * THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 19 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 20 | * IN THE SOFTWARE. 21 | *) 22 | 23 | (* This is my implementation of Red-Black Trees for OCaml. It is based upon 24 | * "Red-Black Trees in a Functional Setting", Chris Okasaki in "Functional 25 | * Pearls". 26 | * Red-Black Trees are exposed via a map and a set API, which is designed to 27 | * be compatible with the Map and Set modules in the OCaml standard library 28 | * (which are implemented using AVL trees). You can use the Rbmap and Rbset 29 | * modules as drop-in replacement for the Map and Set modules. 30 | *) 31 | 32 | module type OrderedType = 33 | sig 34 | type t 35 | (** The type of the map keys. *) 36 | val compare : t -> t -> int 37 | (** A total ordering function over the keys. 38 | This is a two-argument function [f] such that 39 | [f e1 e2] is zero if the keys [e1] and [e2] are equal, 40 | [f e1 e2] is strictly negative if [e1] is smaller than [e2], 41 | and [f e1 e2] is strictly positive if [e1] is greater than [e2]. 42 | Example: a suitable ordering function is the generic structural 43 | comparison function {!Pervasives.compare}. *) 44 | end 45 | (** Input signature of the functor {!Map.Make}. *) 46 | 47 | module type S = 48 | sig 49 | type key 50 | (** The type of the map keys. *) 51 | 52 | type (+'a) t 53 | (** The type of maps from type [key] to type ['a]. *) 54 | 55 | val empty: 'a t 56 | (** The empty map. *) 57 | 58 | val is_empty: 'a t -> bool 59 | (** Test whether a map is empty or not. *) 60 | 61 | val add: key -> 'a -> 'a t -> 'a t 62 | (** [add x y m] returns a map containing the same bindings as 63 | [m], plus a binding of [x] to [y]. If [x] was already bound 64 | in [m], its previous binding disappears. *) 65 | 66 | val find: key -> 'a t -> 'a 67 | (** [find x m] returns the current binding of [x] in [m], 68 | or raises [Not_found] if no such binding exists. *) 69 | 70 | val remove: key -> 'a t -> 'a t 71 | (** [remove x m] returns a map containing the same bindings as 72 | [m], except for [x] which is unbound in the returned map. *) 73 | 74 | val mem: key -> 'a t -> bool 75 | (** [mem x m] returns [true] if [m] contains a binding for [x], 76 | and [false] otherwise. *) 77 | 78 | val iter: (key -> 'a -> unit) -> 'a t -> unit 79 | (** [iter f m] applies [f] to all bindings in map [m]. 80 | [f] receives the key as first argument, and the associated value 81 | as second argument. The bindings are passed to [f] in increasing 82 | order with respect to the ordering over the type of the keys. *) 83 | 84 | val map: ('a -> 'b) -> 'a t -> 'b t 85 | (** [map f m] returns a map with same domain as [m], where the 86 | associated value [a] of all bindings of [m] has been 87 | replaced by the result of the application of [f] to [a]. 88 | The bindings are passed to [f] in increasing order 89 | with respect to the ordering over the type of the keys. *) 90 | 91 | val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t 92 | (** Same as {!Map.S.map}, but the function receives as arguments both the 93 | key and the associated value for each binding of the map. *) 94 | 95 | val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b 96 | (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], 97 | where [k1 ... kN] are the keys of all bindings in [m] 98 | (in increasing order), and [d1 ... dN] are the associated data. *) 99 | 100 | val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int 101 | (** Total ordering between maps. The first argument is a total ordering 102 | used to compare data associated with equal keys in the two maps. *) 103 | 104 | val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool 105 | (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are 106 | equal, that is, contain equal keys and associate them with 107 | equal data. [cmp] is the equality predicate used to compare 108 | the data associated with the keys. *) 109 | 110 | end 111 | (** Output signature of the functor {!Map.Make}. *) 112 | 113 | module Make (Ord: OrderedType): S with type key = Ord.t 114 | (** Functor building an implementation of the map structure 115 | given a totally ordered type. *) 116 | -------------------------------------------------------------------------------- /src/rbset.ml: -------------------------------------------------------------------------------- 1 | (*- 2 | * Copyright (c) 2007, Benedikt Meurer 3 | * 4 | * Permission is hereby granted, free of charge, to any person obtaining a 5 | * copy of this software and associated documentation files (the "Software"), 6 | * to deal in the Software without restriction, including without limitation 7 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 8 | * and/or sell copies of the Software, and to permit persons to whom the 9 | * Software is furnished to do so, subject to the following conditions: 10 | * 11 | * The above copyright notice and this permission notice shall be included in 12 | * all copies or substantial portions of the Software. 13 | * 14 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 15 | * OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 17 | * THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 19 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 20 | * IN THE SOFTWARE. 21 | *) 22 | 23 | (* This is my implementation of Red-Black Trees for OCaml. It is based upon 24 | * "Red-Black Trees in a Functional Setting", Chris Okasaki in "Functional 25 | * Pearls". 26 | * Red-Black Trees are exposed via a map and a set API, which is designed to 27 | * be compatible with the Map and Set modules in the OCaml standard library 28 | * (which are implemented using AVL trees). You can use the Rbmap and Rbset 29 | * modules as drop-in replacement for the Map and Set modules. 30 | *) 31 | 32 | module type OrderedType = 33 | sig 34 | type t 35 | val compare: t -> t -> int 36 | end 37 | 38 | module type S = 39 | sig 40 | type elt 41 | type t 42 | val empty: t 43 | val is_empty: t -> bool 44 | val mem: elt -> t -> bool 45 | val add: elt -> t -> t 46 | val singleton: elt -> t 47 | val remove: elt -> t -> t 48 | val union: t -> t -> t 49 | val inter: t -> t -> t 50 | val diff: t -> t -> t 51 | val compare: t -> t -> int 52 | val equal: t -> t -> bool 53 | val subset: t -> t -> bool 54 | val iter: (elt -> unit) -> t -> unit 55 | val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a 56 | val for_all: (elt -> bool) -> t -> bool 57 | val exists: (elt -> bool) -> t -> bool 58 | val filter: (elt -> bool) -> t -> t 59 | val partition: (elt -> bool) -> t -> t * t 60 | val cardinal: t -> int 61 | val elements: t -> elt list 62 | val min_elt: t -> elt 63 | val max_elt: t -> elt 64 | val choose: t -> elt 65 | val split: elt -> t -> t * bool * t 66 | end 67 | 68 | module Make(Ord: OrderedType) = 69 | struct 70 | type elt = Ord.t 71 | 72 | type t = 73 | | Black of t * elt * t 74 | | Red of t * elt * t 75 | | Empty 76 | 77 | type enum = 78 | | End 79 | | More of elt * t * enum 80 | 81 | let rec enum s e = 82 | match s with 83 | | Empty -> e 84 | | Black(l, x, r) | Red(l, x, r) -> enum l (More(x, r, e)) 85 | 86 | let blackify = function 87 | | Red(l, x, r) -> Black(l, x, r), false 88 | | s -> s, true 89 | 90 | let empty = Empty 91 | 92 | let is_empty = function 93 | | Empty -> true 94 | | _ -> false 95 | 96 | let rec mem x = function 97 | | Empty -> 98 | false 99 | | Red(l, y, r) 100 | | Black(l, y, r) -> 101 | let c = Ord.compare x y in 102 | if c < 0 then mem x l 103 | else if c > 0 then mem x r 104 | else true 105 | 106 | let balance_left l x r = 107 | match l, x, r with 108 | | Red(Red(a, x, b), y, c), z, d 109 | | Red(a, x, Red(b, y, c)), z, d -> 110 | Red(Black(a, x, b), y, Black(c, z, d)) 111 | | l, x, r -> 112 | Black(l, x, r) 113 | 114 | let balance_right l x r = 115 | match l, x, r with 116 | | a, x, Red(Red(b, y, c), z, d) 117 | | a, x, Red(b, y, Red(c, z, d)) -> 118 | Red(Black(a, x, b), y, Black(c, z, d)) 119 | | l, x, r -> 120 | Black(l, x, r) 121 | 122 | let add x s = 123 | let rec add_aux = function 124 | | Empty -> 125 | Red(Empty, x, Empty) 126 | | Red(l, y, r) as s -> 127 | let c = Ord.compare x y in 128 | if c < 0 then 129 | Red(add_aux l, y, r) 130 | else if c > 0 then 131 | Red(l, y, add_aux r) 132 | else 133 | s 134 | | Black(l, y, r) as s -> 135 | let c = Ord.compare x y in 136 | if c < 0 then 137 | balance_left (add_aux l) y r 138 | else if c > 0 then 139 | balance_right l y (add_aux r) 140 | else 141 | s 142 | in fst (blackify (add_aux s)) 143 | 144 | let singleton x = 145 | Black(Empty, x, Empty) 146 | 147 | let unbalanced_left = function 148 | | Red(Black(a, x, b), y, c) -> balance_left (Red(a, x, b)) y c, false 149 | | Black(Black(a, x, b), y, c) -> balance_left (Red(a, x, b)) y c, true 150 | | Black(Red(a, x, Black(b, y, c)), z, d) -> Black(a, x, balance_left (Red(b, y, c)) z d), false 151 | | _ -> assert false 152 | 153 | let unbalanced_right = function 154 | | Red(a, x, Black(b, y, c)) -> balance_right a x (Red(b, y, c)), false 155 | | Black(a, x, Black(b, y, c)) -> balance_right a x (Red(b, y, c)), true 156 | | Black(a, x, Red(Black(b, y, c), z, d)) -> Black(balance_right a x (Red(b, y, c)), z, d), false 157 | | _ -> assert false 158 | 159 | let rec remove_min = function 160 | | Empty 161 | | Black(Empty, _, Black(_)) -> 162 | assert false 163 | | Black(Empty, x, Empty) -> 164 | Empty, x, true 165 | | Black(Empty, x, Red(l, y, r)) -> 166 | Black(l, y, r), x, false 167 | | Red(Empty, x, r) -> 168 | r, x, false 169 | | Black(l, x, r) -> 170 | let l, y, d = remove_min l in 171 | let s = Black(l, x, r) in 172 | if d then 173 | let s, d = unbalanced_right s in s, y, d 174 | else 175 | s, y, false 176 | | Red(l, x, r) -> 177 | let l, y, d = remove_min l in 178 | let s = Red(l, x, r) in 179 | if d then 180 | let s, d = unbalanced_right s in s, y, d 181 | else 182 | s, y, false 183 | 184 | let remove x s = 185 | let rec remove_aux = function 186 | | Empty -> 187 | Empty, false 188 | | Black(l, y, r) -> 189 | let c = Ord.compare x y in 190 | if c < 0 then 191 | let l, d = remove_aux l in 192 | let s = Black(l, y, r) in 193 | if d then unbalanced_right s else s, false 194 | else if c > 0 then 195 | let r, d = remove_aux r in 196 | let s = Black(l, y, r) in 197 | if d then unbalanced_left s else s, false 198 | else 199 | begin match r with 200 | | Empty -> 201 | blackify l 202 | | _ -> 203 | let r, y, d = remove_min r in 204 | let s = Black(l, y, r) in 205 | if d then unbalanced_left s else s, false 206 | end 207 | | Red(l, y, r) -> 208 | let c = Ord.compare x y in 209 | if c < 0 then 210 | let l, d = remove_aux l in 211 | let s = Red(l, y, r) in 212 | if d then unbalanced_right s else s, false 213 | else if c > 0 then 214 | let r, d = remove_aux r in 215 | let s = Red(l, y, r) in 216 | if d then unbalanced_left s else s, false 217 | else 218 | begin match r with 219 | | Empty -> 220 | l, false 221 | | _ -> 222 | let r, y, d = remove_min r in 223 | let s = Red(l, y, r) in 224 | if d then unbalanced_left s else s, false 225 | end 226 | in fst (remove_aux s) 227 | 228 | let union s1 s2 = 229 | let rec union_aux e1 e2 accu = 230 | match e1, e2 with 231 | | End, End -> 232 | accu 233 | | End, More(x, r, e) 234 | | More(x, r, e), End -> 235 | union_aux End (enum r e) (add x accu) 236 | | (More(x1, r1, e1) as e1'), (More(x2, r2, e2) as e2') -> 237 | let c = Ord.compare x1 x2 in 238 | if c < 0 then union_aux (enum r1 e1) e2' (add x1 accu) 239 | else if c > 0 then union_aux e1' (enum r2 e2) (add x2 accu) 240 | else union_aux (enum r1 e1) (enum r2 e2) (add x1 accu) 241 | in union_aux (enum s1 End) (enum s2 End) Empty 242 | 243 | let inter s1 s2 = 244 | let rec inter_aux e1 e2 accu = 245 | match e1, e2 with 246 | | End, _ 247 | | _, End -> 248 | accu 249 | | (More(x1, r1, e1) as e1'), (More(x2, r2, e2) as e2') -> 250 | let c = Ord.compare x1 x2 in 251 | if c < 0 then inter_aux (enum r1 e1) e2' accu 252 | else if c > 0 then inter_aux e1' (enum r2 e2) accu 253 | else inter_aux (enum r1 e1) (enum r2 e2) (add x1 accu) 254 | in inter_aux (enum s1 End) (enum s2 End) Empty 255 | 256 | let diff s1 s2 = 257 | let rec diff_aux e1 e2 accu = 258 | match e1, e2 with 259 | | End, _ -> 260 | accu 261 | | More(x, r, e), End -> 262 | diff_aux (enum r e) End (add x accu) 263 | | (More(x1, r1, e1) as e1'), (More(x2, r2, e2) as e2') -> 264 | let c = Ord.compare x1 x2 in 265 | if c < 0 then diff_aux (enum r1 e1) e2' (add x1 accu) 266 | else if c > 0 then diff_aux e1' (enum r2 e2) accu 267 | else diff_aux (enum r1 e1) (enum r2 e2) accu 268 | in diff_aux (enum s1 End) (enum s2 End) Empty 269 | 270 | let compare s1 s2 = 271 | let rec compare_aux e1 e2 = 272 | match e1, e2 with 273 | | End, End -> 274 | 0 275 | | End, _ -> 276 | -1 277 | | _, End -> 278 | 1 279 | | More(x1, r1, e1), More(x2, r2, e2) -> 280 | let c = Ord.compare x1 x2 in 281 | if c <> 0 then c else compare_aux (enum r1 e1) (enum r2 e2) 282 | in compare_aux (enum s1 End) (enum s2 End) 283 | 284 | let equal s1 s2 = 285 | compare s1 s2 = 0 286 | 287 | let rec subset s1 s2 = 288 | match s1, s2 with 289 | | Empty, _ -> 290 | true 291 | | _, Empty -> 292 | false 293 | | (Black(l1, x1, r1) | Red(l1, x1, r1)), ((Black(l2, x2, r2) | Red(l2, x2, r2)) as s2) -> 294 | let c = Ord.compare x1 x2 in 295 | if c = 0 then 296 | subset l1 l2 && subset r1 r2 297 | else if c < 0 then 298 | subset (Black(l1, x1, Empty)) l2 && subset r1 s2 299 | else 300 | subset (Black(Empty, x1, r1)) r2 && subset l1 s2 301 | 302 | let rec iter f = function 303 | | Empty -> () 304 | | Black(l, x, r) | Red(l, x, r) -> iter f l; f x; iter f r 305 | 306 | let rec fold f s accu = 307 | match s with 308 | | Empty -> accu 309 | | Black(l, x, r) | Red(l, x, r) -> fold f r (f x (fold f l accu)) 310 | 311 | let rec for_all p = function 312 | | Empty -> true 313 | | Black(l, x, r) | Red(l, x, r) -> p x && (for_all p l && for_all p r) 314 | 315 | let rec exists p = function 316 | | Empty -> false 317 | | Black(l, x, r) | Red(l, x, r) -> p x || (exists p l || exists p r) 318 | 319 | let filter p s = 320 | let rec filter_aux accu = function 321 | | Empty -> accu 322 | | Black(l, x, r) | Red(l, x, r) -> filter_aux (filter_aux (if p x then add x accu else accu) l) r 323 | in filter_aux Empty s 324 | 325 | let partition p s = 326 | let rec partition_aux (t, f as accu) = function 327 | | Empty -> 328 | accu 329 | | Black(l, x, r) | Red(l, x, r) -> 330 | partition_aux (partition_aux (if p x then (add x t, f) else (t, add x f)) l) r 331 | in partition_aux (Empty, Empty) s 332 | 333 | let rec cardinal = function 334 | | Empty -> 0 335 | | Black(l, x, r) | Red(l, x, r) -> 1 + cardinal l + cardinal r 336 | 337 | let rec elements_aux accu = function 338 | | Empty -> accu 339 | | Black(l, x, r) | Red(l, x, r) -> elements_aux (x :: elements_aux accu r) l 340 | 341 | let elements s = 342 | elements_aux [] s 343 | 344 | let rec min_elt = function 345 | | Empty -> raise Not_found 346 | | Black(Empty, x, _) | Red(Empty, x, _) -> x 347 | | Black(l, _, _) | Red(l, _, _) -> min_elt l 348 | 349 | let rec max_elt = function 350 | | Empty -> raise Not_found 351 | | Black(_, x, Empty) | Red(_, x, Empty) -> x 352 | | Black(_, _, r) | Red(_, _, r) -> max_elt r 353 | 354 | let choose = function 355 | | Empty -> raise Not_found 356 | | Black(_, x, _) | Red(_, x, _) -> x 357 | 358 | let split x s = 359 | let rec split_aux y (l, b, r) = 360 | let c = Ord.compare x y in 361 | if c < 0 then l, b, add x r 362 | else if c > 0 then add x l, b, r 363 | else l, true, r 364 | in fold split_aux s (Empty, false, Empty) 365 | end 366 | -------------------------------------------------------------------------------- /src/rbset.mli: -------------------------------------------------------------------------------- 1 | (*- 2 | * Copyright (c) 2007, Benedikt Meurer 3 | * 4 | * Permission is hereby granted, free of charge, to any person obtaining a 5 | * copy of this software and associated documentation files (the "Software"), 6 | * to deal in the Software without restriction, including without limitation 7 | * the rights to use, copy, modify, merge, publish, distribute, sublicense, 8 | * and/or sell copies of the Software, and to permit persons to whom the 9 | * Software is furnished to do so, subject to the following conditions: 10 | * 11 | * The above copyright notice and this permission notice shall be included in 12 | * all copies or substantial portions of the Software. 13 | * 14 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 15 | * OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 17 | * THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 19 | * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 20 | * IN THE SOFTWARE. 21 | *) 22 | 23 | (* This is my implementation of Red-Black Trees for OCaml. It is based upon 24 | * "Red-Black Trees in a Functional Setting", Chris Okasaki in "Functional 25 | * Pearls". 26 | * Red-Black Trees are exposed via a map and a set API, which is designed to 27 | * be compatible with the Map and Set modules in the OCaml standard library 28 | * (which are implemented using AVL trees). You can use the Rbmap and Rbset 29 | * modules as drop-in replacement for the Map and Set modules. 30 | *) 31 | 32 | module type OrderedType = 33 | sig 34 | type t 35 | (** The type of the set elements. *) 36 | 37 | val compare: t -> t -> int 38 | (** A total ordering function over the set elements. 39 | This is a two-argument function [f] such that 40 | [f e1 e2] is zero if the elements [e1] and [e2] are equal, 41 | [f e1 e2] is strictly negative if [e1] is smaller than [e2], 42 | and [f e1 e2] is strictly positive if [e1] is greater than [e2]. 43 | Example: a suitable ordering function is the generic structural 44 | comparison function {!Pervasives.compare}. *) 45 | end 46 | (** Input signature of the functor {!Rbset.Make}. *) 47 | 48 | module type S = 49 | sig 50 | type elt 51 | (** The type of the set elements. *) 52 | 53 | type t 54 | (** The type of sets. *) 55 | 56 | val empty: t 57 | (** The empty set. *) 58 | 59 | val is_empty: t -> bool 60 | (** Test whether a set is empty or not. *) 61 | 62 | val mem: elt -> t -> bool 63 | (** [mem x s] tests whether [x] belongs to the set [s]. *) 64 | 65 | val add: elt -> t -> t 66 | (** [add x s] returns a set containing all elements of [s], 67 | plus [x]. If [x] was already in [s], [s] is returned unchanged. *) 68 | 69 | val singleton: elt -> t 70 | (** [singleton x] returns the one-element set containing only [x]. *) 71 | 72 | val remove: elt -> t -> t 73 | (** [remove x s] returns a set containing all elements of [s], 74 | except [x]. If [x] was not in [s], [s] is returned unchanged. *) 75 | 76 | val union: t -> t -> t 77 | (** Set union. *) 78 | 79 | val inter: t -> t -> t 80 | (** Set intersection. *) 81 | 82 | (** Set difference. *) 83 | val diff: t -> t -> t 84 | 85 | val compare: t -> t -> int 86 | (** Total ordering between sets. Can be used as the ordering function 87 | for doing sets of sets. *) 88 | 89 | val equal: t -> t -> bool 90 | (** [equal s1 s2] tests whether the sets [s1] and [s2] are 91 | equal, that is, contain equal elements. *) 92 | 93 | val subset: t -> t -> bool 94 | (** [subset s1 s2] tests whether the set [s1] is a subset of 95 | the set [s2]. *) 96 | 97 | val iter: (elt -> unit) -> t -> unit 98 | (** [iter f s] applies [f] in turn to all elements of [s]. 99 | The elements of [s] are presented to [f] in increasing order 100 | with respect to the ordering over the type of the elements. *) 101 | 102 | val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a 103 | (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], 104 | where [x1 ... xN] are the elements of [s], in increasing order. *) 105 | 106 | val for_all: (elt -> bool) -> t -> bool 107 | (** [for_all p s] checks if all elements of the set 108 | satisfy the predicate [p]. *) 109 | 110 | val exists: (elt -> bool) -> t -> bool 111 | (** [exists p s] checks if at least one element of 112 | the set satisfies the predicate [p]. *) 113 | 114 | val filter: (elt -> bool) -> t -> t 115 | (** [filter p s] returns the set of all elements in [s] 116 | that satisfy predicate [p]. *) 117 | 118 | val partition: (elt -> bool) -> t -> t * t 119 | (** [partition p s] returns a pair of sets [(s1, s2)], where 120 | [s1] is the set of all the elements of [s] that satisfy the 121 | predicate [p], and [s2] is the set of all the elements of 122 | [s] that do not satisfy [p]. *) 123 | 124 | val cardinal: t -> int 125 | (** Return the number of elements of a set. *) 126 | 127 | val elements: t -> elt list 128 | (** Return the list of all elements of the given set. 129 | The returned list is sorted in increasing order with respect 130 | to the ordering [Ord.compare], where [Ord] is the argument 131 | given to {!Set.Make}. *) 132 | 133 | val min_elt: t -> elt 134 | (** Return the smallest element of the given set 135 | (with respect to the [Ord.compare] ordering), or raise 136 | [Not_found] if the set is empty. *) 137 | 138 | val max_elt: t -> elt 139 | (** Same as {!Set.S.min_elt}, but returns the largest element of the 140 | given set. *) 141 | 142 | val choose: t -> elt 143 | (** Return one element of the given set, or raise [Not_found] if 144 | the set is empty. Which element is chosen is unspecified, 145 | but equal elements will be chosen for equal sets. *) 146 | 147 | val split: elt -> t -> t * bool * t 148 | (** [split x s] returns a triple [(l, present, r)], where 149 | [l] is the set of elements of [s] that are 150 | strictly less than [x]; 151 | [r] is the set of elements of [s] that are 152 | strictly greater than [x]; 153 | [present] is [false] if [s] contains no element equal to [x], 154 | or [true] if [s] contains an element equal to [x]. *) 155 | end 156 | (** Output signature of the functor {!Set.Make}. *) 157 | 158 | module Make (Ord: OrderedType): S with type elt = Ord.t 159 | (** Functor building an implementation of the set structure 160 | given a totally ordered type. *) 161 | -------------------------------------------------------------------------------- /src/rbtrees.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 1cd0b56a77251d5302c4124c81f4afdf) 3 | Rbmap 4 | Rbset 5 | # OASIS_STOP 6 | -------------------------------------------------------------------------------- /src/rbtrees.odocl: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 1cd0b56a77251d5302c4124c81f4afdf) 3 | Rbmap 4 | Rbset 5 | # OASIS_STOP 6 | --------------------------------------------------------------------------------