configure.ml

   1 #load "unix.cma";;
   2 let (<|) = fun f g x -> f (g x)
   3 and (|>) = fun f g x -> g (f x)
   4 module Char
   5  = struct
   6         include Char
   7         let decimal
   8                 = function
   9                 | '0'..'9' -> true
  10                 | _ -> false
  11         let white
  12                 = function
  13                 | ' '|'\n'|'\r'|'\t' -> true
  14                 | _ -> false
  15  end
  16 module String
  17  = struct
  18         include String
  19         module Split
  20          = struct
  21                 let t
  22                  ~(acc:'acc)
  23                  ~(next:string -> int -> int -> (int * int))
  24                  ~(sub:acc:'acc -> skip: int -> string -> int -> int -> 'acc)
  25                  string =
  26                         let bgn = ref 0
  27                         and siz = String.length string
  28                         and last_skip = ref 0
  29                         and acc = ref acc in
  30                         while !bgn < siz || !last_skip <> 0 do
  31                                 let pos = !bgn in
  32                                 let keep, skip = next string pos (siz - pos) in
  33                                 let inc = keep + skip in
  34                                 assert (inc <> 0 || (inc = 0 && !last_skip <> 0));
  35                                 acc := sub ~acc:!acc ~skip string pos keep;
  36                                 last_skip := skip;
  37                                 bgn := pos + inc;
  38                          done;
  39                         !acc
  40                 let char
  41                  = fun char string ->
  42                         t string ~acc: []
  43                          ~sub: (fun ~acc ~skip string pos siz ->
  44                                 let pos = String.length string - pos - siz in
  45                                 String.sub string pos siz::acc)
  46                          ~next: (fun string pos siz ->
  47                                 let keep = ref 0
  48                                 and pos  = String.length string - pos - 1 in
  49                                 while let keep = !keep
  50                                         in keep < siz
  51                                         && not (char (String.unsafe_get string (pos - keep)))
  52                                 do incr keep done;
  53                                 (!keep, if !keep = siz then 0 else 1))
  54                 let char_with_separators_glued
  55                  = fun char string ->
  56                         t string ~acc: []
  57                          ~sub: (fun ~acc ~skip string pos siz ->
  58                                 let pos = String.length string - pos - siz in
  59                                 let acc = String.sub string pos siz::acc in
  60                                 if skip > 0
  61                                 then String.sub string (pos - skip) skip::acc
  62                                 else acc)
  63                          ~next: (fun string pos siz ->
  64                                 let keep = ref 0
  65                                 and skip = ref 0
  66                                 and pos  = String.length string - pos - 1 in
  67                                 while let keep = !keep
  68                                         in keep < siz
  69                                         && not (char (String.unsafe_get string (pos - keep)))
  70                                 do incr keep done;
  71                                 let keep = !keep in
  72                                 let pos  = pos - keep
  73                                 and siz  = siz - keep in
  74                                 while let skip = !skip
  75                                         in skip < siz
  76                                         && char (String.unsafe_get string (pos - skip))
  77                                 do incr skip done;
  78                                 let skip = !skip in
  79                                 (keep, skip))
  80          end
  81         let chomp
  82          = fun string ->
  83                 let len = String.length string in
  84                 let rec loop
  85                         = function
  86                         | 0 -> ""
  87                         | curr ->
  88                                 match String.unsafe_get string (pred curr) with
  89                                 | ' '|'\n'|'\r'|'\t' -> loop (pred curr)
  90                                 | _ when curr = len -> string
  91                                 | _ -> String.sub string 0 curr
  92                  in
  93                 loop len
  94         let macrofy
  95          = fun string ->
  96                 let string = copy string in
  97                 for pos = 0 to pred (length string)
  98                  do match unsafe_get string pos with
  99                         | 'a'..'z' | 'A'..'Z' | '_' -> ()
 100                         | '0'..'9' when pos > 0 -> ()
 101                         | _ -> unsafe_set string pos '_'
 102                  done;
 103                 string
 104         let uidentify
 105          = fun string ->
 106                 let string = copy string in
 107                 for pos = 0 to min 0 (pred (length string))
 108                  do match unsafe_get string pos with
 109                         | 'a'..'z' | 'A'..'Z' | '_' -> ()
 110                         | _ -> unsafe_set string pos '_'
 111                  done;
 112                 string
 113  end
 114 module Path
 115  = struct
 116         type t = string
 117         let (//) = Filename.concat
 118         let char =
 119                 match Sys.os_type with
 120                 | "Win32" -> ';'
 121                 | _       -> ':'
 122  end
 123 module File
 124  = struct
 125         let rm
 126          = fun t ->
 127                 try Sys.remove t
 128                 with exn ->
 129                         Pervasives.prerr_endline
 130                          ("File.rm: " ^ Printexc.to_string exn);
 131                         ()
 132         let tmp
 133          = fun ?(prefix="tmp") ?(suffix="tmp") fct ->
 134                 let (file, chan) = Filename.open_temp_file prefix suffix in
 135                 let clean
 136                  = fun () ->
 137                         rm file
 138                  in
 139                 try let t = fct ~file ~chan in clean (); t
 140                 with exn -> clean (); raise exn
 141  end
 142 module Out
 143  = struct
 144         type t =
 145          { close  : unit -> unit
 146          ; format : 'a. ('a, Pervasives.out_channel, unit) format -> 'a
 147          }
 148         let t
 149                 = function
 150                 | "" ->
 151                         { close  = Pervasives.ignore
 152                         ; format = (fun format -> Printf.ifprintf Pervasives.stderr format)
 153                         }
 154                 | file ->
 155                         let chan = Pervasives.open_out file in
 156                         { close  = (fun _ -> Pervasives.close_out chan)
 157                         ; format = (fun format -> Printf.fprintf chan format)
 158                         }
 159  end
 160 module Env
 161  = struct
 162         module Path
 163          = struct
 164                 let split
 165                  = String.Split.char ((=) Path.char)
 166                 let list
 167                  = fun name ->
 168                         try split (Sys.getenv name)
 169                         with Not_found -> []
 170          end
 171         let string
 172          = fun name ->
 173                 try Some (Sys.getenv name)
 174                 with Not_found -> None
 175  end
 176 module Context
 177  = struct
 178         module Param
 179          = struct
 180                 let self   = Sys.argv.(0)
 181                 let c      = ref (self^".h")
 182                 and caml   = ref (self^".ml")
 183                 and camlpp = ref (self^".mlp")
 184                 and make   = ref (self^".make")
 185                 and log    = ref (self^".log")
 186          end
 187         type t =
 188          { c      : Out.t
 189          ; caml   : Out.t
 190          ; camlpp : Out.t
 191          ; make   : Out.t
 192          ; log    : Path.t
 193          }
 194         let t
 195          = fun fct ->
 196                 let c      = !Param.c
 197                 and caml   = !Param.caml
 198                 and camlpp = !Param.camlpp
 199                 and make   = !Param.make
 200                 and log    = !Param.log in
 201                 try
 202                         let c      = Out.t c
 203                         and caml   = Out.t caml
 204                         and camlpp = Out.t camlpp
 205                         and make   = Out.t make
 206                         and c_def  = String.macrofy c in
 207                         c.Out.format "\
 208                                 #ifndef %s\n\
 209                                 #define %s\n\
 210                          "
 211                          c_def
 212                          c_def;
 213                         if Sys.file_exists log
 214                         then File.rm log;
 215                         let t = fct {c=c; caml=caml; camlpp=camlpp; make=make; log=log} in
 216                         c.Out.format "\
 217                                 #endif /* %s */\n\
 218                          "
 219                          c_def;
 220                         c     .Out.close ();
 221                         caml  .Out.close ();
 222                         camlpp.Out.close ();
 223                         make  .Out.close ();
 224                         t
 225                 with exn ->
 226                         File.rm c;
 227                         File.rm caml;
 228                         File.rm camlpp;
 229                         File.rm make;
 230                         raise exn
 231  end
 232 module Emit
 233  = struct
 234         let bool
 235          = fun ~context:{Context.c=c; caml=caml; camlpp=camlpp; make=make} name bool ->
 236                 match name with
 237                 | "" -> ()
 238                 | _ ->
 239                         match bool with
 240                         | true ->
 241                                 c      .Out.format "#define %s\n" name;
 242                                 caml   .Out.format "let _%s = true\n" name;
 243                                 camlpp .Out.format "DEFINE %s\n" name;
 244                                 make   .Out.format "%s := true\n" name
 245                         | false ->
 246                                 c      .Out.format "#undef %s\n" name;
 247                                 caml   .Out.format "let _%s = false\n" name;
 248                                 camlpp .Out.format "(* DEFINE %s *)\n" name;
 249                                 make   .Out.format "%s := \n" name
 250         let string
 251          = fun ~context:{Context.c=c; caml=caml; camlpp=camlpp; make=make} name string ->
 252                 match name with
 253                 | "" -> ()
 254                 | _ ->
 255                         c      .Out.format "#define %s = %S\n" name string;
 256                         caml   .Out.format "let _%s = %S\n"    name string;
 257                         camlpp .Out.format "DEFINE %s = %S\n"  name string;
 258                         make   .Out.format "%s := \"%s\"\n"    name string
 259  end
 260 module Trace
 261  = struct
 262         let format
 263          = Printf.eprintf
 264  end
 265 module Log
 266  = struct
 267         let t
 268          = fun ~context:{Context.log=log} string ->
 269                 match log with
 270                 | "" -> ()
 271                 | _ ->
 272                         let log = Pervasives.open_out_gen
 273                          [Open_wronly; Open_append; Open_creat; Open_text] 0o660 log in
 274                         Pervasives.output_string log string;
 275                         Pervasives.close_out log;
 276  end
 277 module Shell
 278  = struct
 279         let t
 280          = fun ~context ->
 281                 Printf.ksprintf
 282                  (fun string ->
 283                         Log.t ~context (Printf.sprintf "$ %s\n" string);
 284                         let sh
 285                          = fun string ->
 286                                 if 0 = Sys.command string
 287                                 then ()
 288                                 else raise Not_found
 289                          in
 290                         match context.Context.log with
 291                         | "" -> sh string
 292                         | log ->
 293                                 Printf.ksprintf sh
 294                                  "{ %s ; } >>%s 2>&1"
 295                                  string (Filename.quote log))
 296         let buffer_size = ref 2048
 297         exception Exit of int * string
 298         let string
 299          = fun ~context ->
 300                 Printf.ksprintf
 301                  (fun string ->
 302                         Log.t ~context (Printf.sprintf "$ %s\n" string);
 303                         let sh
 304                          = fun cmd ->
 305                                 let size   = !buffer_size in
 306                                 let chan   = Unix.open_process_in cmd
 307                                 and buf    = Buffer.create size
 308                                 and string = String.create size
 309                                 and read   = ref 1 in
 310                                 while !read <> 0 do
 311                                         read := Pervasives.input chan string 0 size;
 312                                         Buffer.add_substring buf string 0 !read
 313                                  done;
 314                                 let string = Buffer.contents buf in
 315                                 Log.t ~context string;
 316                                 match Unix.close_process_in chan with
 317                                 | Unix.WEXITED   0   -> string
 318                                 | Unix.WEXITED   int -> raise (Exit (int, string))
 319                                 | Unix.WSIGNALED int
 320                                 | Unix.WSTOPPED  int ->
 321                                         Pervasives.failwith
 322                                          (Printf.sprintf
 323                                                  "command received signal %i: %s"
 324                                                  int cmd) in
 325                         match context.Context.log with
 326                         | "" -> sh string
 327                         | log -> Printf.ksprintf sh "{ %s ; } 2>&1" string)
 328  end
 329 module Compile
 330  = struct
 331         module Param
 332          = struct
 333                 let ocamlc     = ref "ocamlfind ocamlc"
 334                 and ext_obj    = ref ".o"
 335                 and ccomp_type = ref "cc"
 336          end
 337         module Path
 338          = struct
 339                 type t =
 340                  { inc : Path.t
 341                  ; lib : Path.t
 342                  }
 343                 let (//) = Path.(//)
 344                 let default =
 345                         List.map
 346                          (fun dir -> {inc=dir//"include"; lib=dir//"lib"})
 347                          [ "/usr/local"
 348                          ; "/opt/local"
 349                          ; "/usr"
 350                          ; "/opt"
 351                          ; "/sw"
 352                          ; "/mingw"
 353                          ]
 354          end
 355         module Header
 356          = struct
 357                 module Search
 358                  = struct
 359                         open Path
 360                         let list =
 361                                 List.flatten
 362                                  [ List.map (fun dir -> {inc=dir; lib=dir//".."//"lib"})
 363                                          (Env.Path.list "C_INCLUDE_PATH")
 364                                  ; List.map (fun dir -> {inc=dir//".." //"include"; lib=dir})
 365                                          (Env.Path.list "LIBRARY_PATH")
 366                                  ; default
 367                                  ]
 368                         let t
 369                          = fun ~context h ->
 370                                 Log.t ~context (Printf.sprintf "# searching for %s .. " h);
 371                                 let rec loop
 372                                         = function
 373                                         | [] ->
 374                                                 Log.t ~context (Printf.sprintf "found NOTHING; \
 375                                                  you may use environment variables: \
 376                                                  C_INCLUDE_PATH and LIBRARY_PATH\n");
 377                                                 None
 378                                         | {inc=inc; lib=lib}::list ->
 379                                                 match Sys.file_exists (inc//h) with
 380                                                 | false -> loop list
 381                                                 | true ->
 382                                                         Log.t ~context (Printf.sprintf "found include:%s lib:%s\n" inc lib);
 383                                                         Some {inc=inc; lib=lib}
 384                                  in
 385                                 loop list
 386                  end
 387          end
 388         module Flags
 389          = struct
 390                 let t
 391                  = fun ~context ~name ~default ->
 392                         let (inc, lib) =
 393                                 match
 394                                  ( Env.Path.list ("CFLAGS_" ^ name)
 395                                  , Env.Path.list ("LIBS_" ^ name)
 396                                  ) with
 397                                 | (_::_ as opt), (_::_ as lib) -> (opt, lib)
 398                                 | t ->
 399                                         let opt, lib = default () in
 400                                         match t with
 401                                         | (_::_ as opt), []     -> (opt, lib)
 402                                         | []    , (_::_ as lib) -> (opt, lib)
 403                                         | []    , []            -> (opt, lib)
 404                                         | _ -> assert false in
 405                         let {Context.make=make} = context in
 406                         make.Out.format "CFLAGS_%s := %s\n" name (String.concat " " inc);
 407                         make.Out.format "LIBS_%s := %s\n" name (String.concat " " lib);
 408                         (inc, lib)
 409          end
 410         module Caml
 411          = struct
 412                 let t
 413                  = fun string fct ->
 414                         File.tmp ~prefix: "configure_ml_" ~suffix: ".ml"
 415                          (fun ~file ~chan ->
 416                                 Pervasives.output_string chan string;
 417                                 Pervasives.close_out chan;
 418                                 let clean
 419                                  = fun () ->
 420                                         File.rm (Filename.chop_extension file ^ ".cmi");
 421                                         File.rm (Filename.chop_extension file ^ ".cmo");
 422                                         File.rm (Filename.chop_extension file ^ ".byte");
 423                                  in
 424                                 try let t = fct ~ml:file in clean (); t
 425                                 with exn -> clean (); raise exn
 426                          )
 427          end
 428         module C
 429          = struct
 430                 let t
 431                  = fun string fct ->
 432                         File.tmp ~prefix: "configure_c_" ~suffix: ".c"
 433                          (fun ~file ~chan ->
 434                                 Pervasives.output_string chan string;
 435                                 Pervasives.close_out chan;
 436                                 let clean
 437                                  = fun () ->
 438                                         File.rm (Filename.chop_extension file ^ !Param.ext_obj);
 439                                  in
 440                                 try let t = fct ~c:file in clean (); t
 441                                 with exn -> clean (); raise exn
 442                          )
 443          end
 444         let t
 445          = fun ~context (opt, lib) c ->
 446                 Caml.t "\
 447                         external t : unit -> unit = \"t\"\n\
 448                         let () = t ()\n\
 449                  "
 450                  (fun ~ml -> C.t c
 451                          (fun ~c -> Shell.t ~context
 452                                  "cd %s && %s -o %s -verbose -custom %s %s %s %s"
 453                                  (Filename.quote (Filename.dirname c))
 454                                  !Param.ocamlc
 455                                  (Filename.quote ((Filename.chop_extension ml) ^ ".byte"))
 456                                  (String.concat " " (List.map (fun t -> Printf.sprintf "-ccopt %s" (Filename.quote t)) opt))
 457                                  (String.concat " " (List.map (fun t -> Printf.sprintf "-cclib %s" (Filename.quote t)) lib))
 458                                  (Filename.quote c)
 459                                  (Filename.quote ml)))
 460  end
 461 module Version
 462  = struct
 463         type i =
 464          | Int    of int
 465          | String of string
 466         type t = i list
 467         module String
 468          = struct
 469                 let t'
 470                  = fun string ->
 471                         List.map
 472                          (fun string ->
 473                                 try Int (Pervasives.int_of_string string)
 474                                 with Failure "int_of_string" -> String string)
 475                          (String.Split.char_with_separators_glued
 476                                  ((not) <| Char.decimal) string)
 477                 let t
 478                  = fun t ->
 479                         String.concat ""
 480                          (List.map
 481                                  (function
 482                                  | Int int -> Pervasives.string_of_int int
 483                                  | String string -> string) t)
 484          end
 485         let t = String.t'
 486         let string = String.t
 487         module Constraint
 488          = struct
 489                 type v = t
 490                 type t =
 491                  | EQ  of v * v
 492                  | LT  of v * v
 493                  | LE  of v * v
 494                  | GT  of v * v
 495                  | GE  of v * v
 496                  | NOT of t
 497                  | AND of t * t
 498                  | OR  of t * t
 499                 let rec bool
 500                         = function
 501                         | NOT (t)     -> not (bool t)
 502                         | AND (t, tt) -> bool t && bool tt
 503                         | OR  (t, tt) -> bool t || bool tt
 504                         | EQ  (v, vv) -> v =  vv
 505                         | LT  (v, vv) -> v <  vv
 506                         | LE  (v, vv) -> v <= vv
 507                         | GT  (v, vv) -> v >  vv
 508                         | GE  (v, vv) -> v >= vv
 509                 let rec string
 510                         = function
 511                         | NOT (t)     -> Printf.sprintf "(not %s)"   (string t)
 512                         | AND (t, tt) -> Printf.sprintf "(%s && %s)" (string t)   (string tt)
 513                         | OR  (t, tt) -> Printf.sprintf "(%s || %s)" (string t)   (string tt)
 514                         | EQ  (v, vv) -> Printf.sprintf "(%s = %s)"  (String.t v) (String.t vv)
 515                         | LT  (v, vv) -> Printf.sprintf "(%s < %s)"  (String.t v) (String.t vv)
 516                         | LE  (v, vv) -> Printf.sprintf "(%s <= %s)" (String.t v) (String.t vv)
 517                         | GT  (v, vv) -> Printf.sprintf "(%s > %s)"  (String.t v) (String.t vv)
 518                         | GE  (v, vv) -> Printf.sprintf "(%s >= %s)" (String.t v) (String.t vv)
 519          end
 520         exception Constraint of t * Constraint.t
 521  end
 522 exception Check
 523 module Check
 524  = struct
 525         let t
 526          = fun ~context ?(enable=true) ?(optional=false) ?(mem=ref None)
 527          ~descr ?(info=fun _ -> "") ?(info_exn=fun _ -> "")
 528          ~macro test ->
 529                 match !mem with
 530                 | Some mem ->
 531                         (match mem with
 532                         | Some _ -> mem
 533                         | None ->
 534                                 (match optional with
 535                                 | true -> None
 536                                 | false -> raise Check))
 537                 | None ->
 538                         Log.t ~context (Printf.sprintf "# checking %s\n" descr);
 539                         Trace.format "checking %s %!" descr;
 540                         let line = (String.make (45 - String.length descr) '.') in
 541                         match enable with
 542                         | false ->
 543                                 Trace.format "%s skip\n%!" line;
 544                                 Emit.bool ~context macro enable;
 545                                 None
 546                         | true ->
 547                                 match (try Some (test ~context), Not_found
 548                                  with exn -> None, exn) with
 549                                 | Some t as option, _ ->
 550                                         let info = info t in
 551                                         Trace.format "%s ok %s\n%!" line info;
 552                                         Emit.bool ~context macro true;
 553                                         mem := Some option;
 554                                         option
 555                                 | None, exn ->
 556                                         Trace.format "%s KO" line;
 557                                         Emit.bool ~context macro false;
 558                                         mem := Some None;
 559                                         match optional with
 560                                         | true ->
 561                                                 Trace.format " (optional) %s\n%!" (info_exn exn);
 562                                                 None
 563                                         | false ->
 564                                                 Trace.format " (NOT optional) %s\n%!" (info_exn exn);
 565                                                 raise Check
 566         module Version
 567          = struct
 568                 let t
 569                  = fun ?optional ?enable ?(mem=ref None) ?(info_exn=fun _ -> "")
 570                  ~context ~descr ~macro
 571                  ?(constraint_=fun t -> Version.Constraint.EQ (t, t))
 572                  version ->
 573                         let old_mem = !mem in
 574                         match t ~context ?optional ?enable ~mem ~descr ~macro
 575                                  ~info: (fun t -> Printf.sprintf "(version %s)" (Version.string t))
 576                                  ~info_exn: (function
 577                                         | Version.Constraint (v, c) ->
 578                                                 Printf.sprintf "(version %s MUST satisfy: %s)"
 579                                                  (Version.string v)
 580                                                  (Version.Constraint.string c)
 581                                         | exn -> info_exn exn)
 582                                  (fun ~context ->
 583                                         let v = version ~context in
 584                                         let c = constraint_ v in
 585                                         if not (Version.Constraint.bool c)
 586                                         then raise (Version.Constraint (v, c))
 587                                         else v)
 588                          with
 589                         | Some version as option ->
 590                                 if old_mem = None
 591                                 then (
 592                                         let version = Version.string version in
 593                                         Emit.string ~context (String.macrofy ("VERSION_" ^ macro)) version;
 594                                         Emit.bool   ~context (String.macrofy ("VERSION_" ^ macro ^ "_" ^ version)) true;
 595                                  );
 596                                 option
 597                         | None -> None
 598          end
 599  end
 600 module Ocamlfind
 601  = struct
 602         module Check
 603          = struct
 604                 module Super = Check
 605                 type t =
 606                  { ocamlc   : Version.t option
 607                  ; ocamlopt : Version.t option
 608                  }
 609                 let mem          = ref None
 610                 and mem_ocamlc   = ref None
 611                 and mem_ocamlopt = ref None
 612                 let t
 613                  = fun ~context ?optional
 614                  ?version_ocamlc ?version_ocamlopt
 615                  () ->
 616                         match Check.t ~context ~descr: "ocamlfind"
 617                                  ~macro: "HAVE_ocamlfind" ?optional ~mem
 618                                  (Shell.t "ocamlfind printconf")
 619                          with
 620                         | None -> None
 621                         | Some () ->
 622                                 let ocamlc =
 623                                         Check.Version.t ~context ~descr: "ocamlc"   ~macro: "OCAMLC"
 624                                          ~optional: false ?constraint_:version_ocamlc ~mem: mem_ocamlc
 625                                          (fun ~context -> Version.t (String.chomp
 626                                                  (Shell.string ~context "ocamlfind ocamlc -version 2>/dev/null"))) in
 627                                 let ocamlopt =
 628                                         Check.Version.t ~context ~descr: "ocamlopt" ~macro: "OCAMLOPT"
 629                                          ~optional: true  ?constraint_:version_ocamlopt ~mem: mem_ocamlopt
 630                                          (fun ~context -> Version.t (String.chomp
 631                                                  (Shell.string ~context "ocamlfind ocamlopt -version 2>/dev/null"))) in
 632                                 Some
 633                                  { ocamlc   = ocamlc
 634                                  ; ocamlopt = ocamlopt
 635                                  }
 636          end
 637         module Package
 638          = struct
 639                 module Check
 640                  = struct
 641                         let t
 642                          = fun ~context: ({Context.c=c; caml=caml; camlpp=camlpp; make=make} as context)
 643                          ?optional ?enable ?mem ?version
 644                          name ->
 645                                 assert (None <> Check.t () ~context ~optional: false);
 646                                 Check.Super.Version.t ~context ?optional ?enable ?mem ?constraint_:version
 647                                  ~descr: ("ocamlfind package " ^ name)
 648                                  ~macro: (String.macrofy ("PACKAGE_" ^ name))
 649                                  (fun ~context -> Version.t (String.chomp
 650                                          (Shell.string ~context "ocamlfind query -format '%%v' %s 2>/dev/null" name)))
 651                  end
 652          end
 653  end
 654 module Arg
 655  = struct
 656         include Arg
 657         let bool
 658          = fun t ->
 659                 Arg.Symbol
 660                  ( ["true"; "false"]
 661                  , function
 662                  | "false" -> t := false
 663                  | "true"  -> t := true
 664                  | _ -> assert false )
 665         let unit
 666          = fun t ->
 667                 Arg.Unit
 668                  (fun _ -> t := true)
 669         module Bool_auto
 670          = struct
 671                 module String
 672                  = struct
 673                         let t
 674                                 = function
 675                                 | None       -> "auto"
 676                                 | Some false -> "false"
 677                                 | Some true  -> "true"
 678                         let t'
 679                                 = function
 680                                 | "auto"  -> None
 681                                 | "false" -> Some false
 682                                 | "true"  -> Some true
 683                                 | _ -> assert false
 684                  end
 685                 let string = String.t
 686                 let t
 687                  = fun t ->
 688                         Arg.Symbol
 689                          ( ["auto"; "false"; "true"]
 690                          , ((:=) t <| String.t') )
 691          end
 692         module Path
 693          = struct
 694                 module String
 695                  = struct
 696                         let t
 697                                 = String.concat (String.make 1 Path.char)
 698                         let t'
 699                                 = String.Split.char ((=) Path.char)
 700                  end
 701                 let t
 702                  = fun fct ->
 703                         Arg.String
 704                          (fct <| String.t')
 705          end
 706  end
 707 module Link
 708  = struct
 709         module Mode
 710          = struct
 711                 type t =
 712                  [ `Auto
 713                  | `Static
 714                  | `Dynamic
 715                  ]
 716                 module Arg
 717                  = struct
 718                         let t
 719                          = fun t ->
 720                                 Arg.Symbol
 721                                  ( ["auto"; "dynamic"; "static"]
 722                                  , function
 723                                  | "auto"    -> t := `Auto
 724                                  | "static"  -> t := `Static
 725                                  | "dynamic" -> t := `Dynamic
 726                                  | _ -> assert false)
 727                  end
 728                 let string
 729                         = function
 730                         | `Auto    -> "auto"
 731                         | `Static  -> "static"
 732                         | `Dynamic -> "dynamic"
 733          end
 734         module Param
 735          = struct
 736                 let mode : Mode.t ref = ref `Auto
 737          end
 738         module Emit
 739          = struct
 740                 let t
 741                  = fun ~context:{Context.make=make} ->
 742                         match !Param.mode with
 743                         | `Auto    -> make.Out.format "export LINKING_MODE := \n"
 744                         | `Static  -> make.Out.format "export LINKING_MODE := static\n"
 745                         | `Dynamic -> make.Out.format "export LINKING_MODE := dynamic\n"
 746          end
 747  end
 748 module Debug
 749  = struct
 750         type t =
 751          bool
 752         let string
 753                 = function
 754                 | true  -> "true"
 755                 | false -> "false"
 756         module Param
 757          = struct
 758                 let bool : t ref = ref false
 759          end
 760         module Emit
 761          = struct
 762                 let t
 763                  = fun ~context:{Context.make=make} ->
 764                         match !Param.bool with
 765                         | true  -> make.Out.format "export DEBUG := true\n";
 766                         | false -> make.Out.format "export DEBUG := \n";
 767          end
 768  end
 769 module OS
 770  = struct
 771         module Type
 772          = struct
 773                 type t =
 774                  [ `Unix
 775                  | `Win32
 776                  | `Cygwin
 777                  ]
 778                 module String
 779                  = struct
 780                         let t
 781                                 = function
 782                                 | `Unix   -> "Unix"
 783                                 | `Win32  -> "Win32"
 784                                 | `Cygwin -> "Cygwin"
 785                         let t'
 786                                 = function
 787                                 | "Unix"   -> `Unix
 788                                 | "Win32"  -> `Win32
 789                                 | "Cygwin" -> `Cygwin
 790                                 | _ -> assert false
 791                  end
 792                 let string = String.t
 793                 module Arg
 794                  = struct
 795                         let t
 796                          = fun t ->
 797                                 Arg.Symbol
 798                                  ( ["Unix"; "Win32"; "Cygwin"]
 799                                  , ((:=) t <| String.t') )
 800                  end
 801          end
 802         module Param
 803          = struct
 804                 let type_ : Type.t ref = ref (Type.String.t' Sys.os_type)
 805          end
 806         module Emit
 807          = struct
 808                 let t
 809                  = fun ~context:{Context.camlpp=camlpp} ->
 810                         let type_ = Type.string !Param.type_ in
 811                         camlpp.Out.format "DEFINE OS_TYPE = \"%s\"\n" type_;
 812                         camlpp.Out.format "DEFINE %s\n" (String.uidentify type_)
 813          end
 814  end
 815 module Argv
 816  = struct
 817         let list = ref
 818          [ "--debug"     , Arg.unit Debug.Param.bool              , Printf.sprintf "  activate debug (DEFAULT: %s)" (Debug.string !Debug.Param.bool)
 819          ; "--link-mode" , Link.Mode.Arg.t Link.Param.mode        , Printf.sprintf "  link mode (DEFAULT: %s)" (Link.Mode.string !Link.Param.mode)
 820          ; "--os-type"   , OS.Type.Arg.t OS.Param.type_           , Printf.sprintf "  type of the target OS (DEFAULT: %s)" (OS.Type.string !OS.Param.type_)
 821          ; "--ocamlc"    , Arg.Set_string Compile.Param.ocamlc    , Printf.sprintf "<command>  ocamlc command (DEFAULT: %s)" !Compile.Param.ocamlc
 822          ; "--ext-obj"   , Arg.Set_string Compile.Param.ext_obj   , Printf.sprintf "<ext>  C object files extension (DEFAULT: %s)" !Compile.Param.ext_obj
 823          ; "--ccomp-type", Arg.Set_string Compile.Param.ccomp_type, Printf.sprintf "<name>  C compiler type (DEFAULT: %s)" !Compile.Param.ccomp_type
 824          ; "--c"         , Arg.Set_string Context.Param.c         , Printf.sprintf "<file>  C output (DEFAULT: %s)" !Context.Param.c
 825          ; "--caml"      , Arg.Set_string Context.Param.caml      , Printf.sprintf "<file>  OCaml output (DEFAULT: %s)" !Context.Param.caml
 826          ; "--camlpp"    , Arg.Set_string Context.Param.camlpp    , Printf.sprintf "<file>  OCaml Pa_macro output (DEFAULT: %s)" !Context.Param.camlpp
 827          ; "--make"      , Arg.Set_string Context.Param.make      , Printf.sprintf "<file>  Makefile output (DEFAULT: %s)" !Context.Param.make
 828          ; "--log"       , Arg.Set_string Context.Param.log       , Printf.sprintf "<file>  shell log output (DEFAULT: %s)" !Context.Param.log
 829          ]
 830  end
 831 let t
 832  = fun ?(env="") ~argv fct ->
 833         Arg.parse
 834          ( argv
 835          @ !Argv.list
 836          ) Pervasives.ignore
 837          (Printf.sprintf
 838                  "check prerequisites and generate %s.* files\n\
 839                  ENVIRONMENT\n\
 840                  \  C_INCLUDE_PATH colon-separated paths to search C headers\n\
 841                  \  LIBRARY_PATH   colon-separated paths to search libraries\n\
 842                  \  CFLAGS_<name>  compile-time flags for <name>\n\
 843                  \  LIBS_<name>    link-time flags for <name>\n\
 844                  %s\
 845                  OPTIONS" Context.Param.self env);
 846         Context.t
 847          (fun ({Context.make=make} as context) ->
 848                 Debug.Emit.t ~context;
 849                 Link.Emit.t ~context;
 850                 OS.Emit.t ~context;
 851                 let t = fct ~context in
 852                 t
 853          )