CristalCaveGem » LustreC

(* setup.ml generated for the first time by OASIS v0.2.0 *)

(* OASIS_START *)

(* DO NOT EDIT (digest: 288c7853541e9b001252c37919a5ce7b) *)

(*

   Regenerated by OASIS v0.2.0

   Visit http://oasis.forge.ocamlcore.org for more information and

   documentation about functions used in this file.

*)

module OASISGettext = struct

# 21 "/build/buildd/oasis-0.2.0/src/oasis/OASISGettext.ml"

  let ns_ str = 

    str

  let s_ str = 

    str

  let f_ (str : ('a, 'b, 'c, 'd) format4) =

    str

  let fn_ fmt1 fmt2 n =

    if n = 1 then

      fmt1^^""

    else

      fmt2^^""

  let init = 

    []

end

module OASISContext = struct

# 21 "/build/buildd/oasis-0.2.0/src/oasis/OASISContext.ml"

  open OASISGettext 

  type level =

    [ `Debug

    | `Info 

    | `Warning

    | `Error]

  type t =

    {

      verbose:        bool;

      debug:          bool;

      ignore_plugins: bool;

      printf:         level -> string -> unit; 

    }

  let printf lvl str = 

    let beg = 

      match lvl with 

        | `Error -> s_ "E: "

        | `Warning -> s_ "W: "

        | `Info  -> s_ "I: "

        | `Debug -> s_ "D: "

    in

      match lvl with 

        | `Error ->

            prerr_endline (beg^str)

        | _ ->

            print_endline (beg^str)

  let default =

    ref 

      {

        verbose        = true;

        debug          = false;

        ignore_plugins = false;

        printf         = printf;

      }

  let quiet = 

    {!default with 

         verbose = false;

         debug   = false;

    }

  let args () =

    ["-quiet",

     Arg.Unit (fun () -> default := {!default with verbose = false}),

     (s_ " Run quietly");

     "-debug",

     Arg.Unit (fun () -> default := {!default with debug = true}),

     (s_ " Output debug message")]

end

module OASISUtils = struct

# 21 "/build/buildd/oasis-0.2.0/src/oasis/OASISUtils.ml"

  module MapString = Map.Make(String)

  let map_string_of_assoc assoc =

    List.fold_left

      (fun acc (k, v) -> MapString.add k v acc)

      MapString.empty

      assoc

  module SetString = Set.Make(String)

  let set_string_add_list st lst =

    List.fold_left 

      (fun acc e -> SetString.add e acc)

      st

      lst

  let set_string_of_list =

    set_string_add_list

      SetString.empty

  let compare_csl s1 s2 = 

    String.compare (String.lowercase s1) (String.lowercase s2)

  module HashStringCsl = 

    Hashtbl.Make

      (struct

         type t = string

         let equal s1 s2 = 

             (String.lowercase s1) = (String.lowercase s2)

         let hash s =

           Hashtbl.hash (String.lowercase s)

       end)

  let split sep str =

    let str_len =

      String.length str

    in

    let rec split_aux acc pos =

      if pos < str_len then

        (

          let pos_sep = 

            try

              String.index_from str pos sep

            with Not_found ->

              str_len

          in

          let part = 

            String.sub str pos (pos_sep - pos) 

          in

          let acc = 

            part :: acc

          in

            if pos_sep >= str_len then

              (

                (* Nothing more in the string *)

                List.rev acc

              )

            else if pos_sep = (str_len - 1) then

              (

                (* String end with a separator *)

                List.rev ("" :: acc)

              )

            else

              (

                split_aux acc (pos_sep + 1)

              )

        )

      else

        (

          List.rev acc

        )

    in

      split_aux [] 0

  let varname_of_string ?(hyphen='_') s = 

    if String.length s = 0 then

      begin

        invalid_arg "varname_of_string" 

      end

    else

      begin

        let buff = 

          Buffer.create (String.length s)

        in

          (* Start with a _ if digit *)

          if '0' <= s.[0] && s.[0] <= '9' then

            Buffer.add_char buff hyphen;

          String.iter

            (fun c ->

               if ('a' <= c && c <= 'z') 

                 || 

                  ('A' <= c && c <= 'Z') 

                 || 

                  ('0' <= c && c <= '9') then

                 Buffer.add_char buff c

               else

                 Buffer.add_char buff hyphen)

            s;

          String.lowercase (Buffer.contents buff)

      end

  let varname_concat ?(hyphen='_') p s = 

    let p = 

      let p_len =

        String.length p

      in

        if p_len > 0 && p.[p_len - 1] = hyphen then

          String.sub p 0 (p_len - 1)

        else

          p

    in

    let s = 

      let s_len =

        String.length s

      in

        if s_len > 0 && s.[0] = hyphen then

          String.sub s 1 (s_len - 1)

        else

          s

    in

      Printf.sprintf "%s%c%s" p hyphen s

  let is_varname str = 

    str = varname_of_string str

  let failwithf1 fmt a =

    failwith (Printf.sprintf fmt a)

  let failwithf2 fmt a b =

    failwith (Printf.sprintf fmt a b)

  let failwithf3 fmt a b c =

    failwith (Printf.sprintf fmt a b c)

  let failwithf4 fmt a b c d =

    failwith (Printf.sprintf fmt a b c d)

  let failwithf5 fmt a b c d e =

    failwith (Printf.sprintf fmt a b c d e)

end

module PropList = struct

# 21 "/build/buildd/oasis-0.2.0/src/oasis/PropList.ml"

  open OASISGettext

  type name = string

  exception Not_set of name * string option 

  exception No_printer of name

  exception Unknown_field of name * name

  let string_of_exception =

    function

      | Not_set (nm, Some rsn) ->

          Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn

      | Not_set (nm, None) ->

          Printf.sprintf (f_ "Field '%s' is not set") nm

      | No_printer nm ->

          Printf.sprintf (f_ "No default printer for value %s") nm

      | Unknown_field (nm, schm) ->

          Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm

      | e ->

          raise e

  module Data =

  struct

    type t = 

        (name, unit -> unit) Hashtbl.t

    let create () =

      Hashtbl.create 13

    let clear t =

      Hashtbl.clear t

# 59 "/build/buildd/oasis-0.2.0/src/oasis/PropList.ml"

  end

  module Schema = 

  struct

    type ('ctxt, 'extra) value =

        {

          get:   Data.t -> string;

          set:   Data.t -> ?context:'ctxt -> string -> unit;

          help:  (unit -> string) option;

          extra: 'extra;

        }

    type ('ctxt, 'extra) t =

        {

          name:      name;

          fields:    (name, ('ctxt, 'extra) value) Hashtbl.t;

          order:     name Queue.t;

          name_norm: string -> string;

        }

    let create ?(case_insensitive=false) nm = 

      {

        name      = nm;

        fields    = Hashtbl.create 13;

        order     = Queue.create ();

        name_norm = 

          (if case_insensitive then 

             String.lowercase

           else

             fun s -> s);

      }

    let add t nm set get extra help = 

      let key = 

        t.name_norm nm

      in

        if Hashtbl.mem t.fields key then

          failwith

            (Printf.sprintf 

               (f_ "Field '%s' is already defined in schema '%s'")

               nm t.name);

        Hashtbl.add 

          t.fields 

          key 

          {

            set   = set; 

            get   = get; 

            help  = help;

            extra = extra;

          };

        Queue.add nm t.order 

    let mem t nm =

      Hashtbl.mem t.fields nm 

    let find t nm = 

      try

        Hashtbl.find t.fields (t.name_norm nm)

      with Not_found ->

        raise (Unknown_field (nm, t.name))

    let get t data nm =

      (find t nm).get data

    let set t data nm ?context x =

      (find t nm).set 

        data 

        ?context 

        x

    let fold f acc t =

      Queue.fold 

        (fun acc k ->

           let v =

             find t k

           in

             f acc k v.extra v.help)

        acc 

        t.order

    let iter f t =

      fold 

        (fun () -> f)

        ()

        t

    let name t = 

      t.name

  end

  module Field =

  struct

    type ('ctxt, 'value, 'extra) t =

        {

          set:    Data.t -> ?context:'ctxt -> 'value -> unit;

          get:    Data.t -> 'value;

          sets:   Data.t -> ?context:'ctxt -> string -> unit;

          gets:   Data.t -> string;

          help:   (unit -> string) option;

          extra:  'extra;

        }

    let new_id = 

      let last_id =

        ref 0

      in

        fun () -> incr last_id; !last_id

    let create ?schema ?name ?parse ?print ?default ?update ?help extra =

      (* Default value container *)

      let v = 

        ref None 

      in

      (* If name is not given, create unique one *)

      let nm = 

        match name with 

          | Some s -> s

          | None -> Printf.sprintf "_anon_%d" (new_id ())

      in

      (* Last chance to get a value: the default *)

      let default () = 

        match default with 

          | Some d -> d

          | None -> raise (Not_set (nm, Some (s_ "no default value")))

      in

      (* Get data *)

      let get data =

        (* Get value *)

        try 

          (Hashtbl.find data nm) ();

          match !v with 

            | Some x -> x 

            | None -> default ()

        with Not_found ->

          default ()

      in

      (* Set data *)

      let set data ?context x = 

        let x = 

          match update with 

            | Some f ->

                begin

                  try 

                    f ?context (get data) x

                  with Not_set _ ->

                    x

                end

            | None ->

                x

        in

          Hashtbl.replace 

            data 

            nm 

            (fun () -> v := Some x) 

      in

      (* Parse string value, if possible *)

      let parse =

        match parse with 

          | Some f -> 

              f

          | None ->

              fun ?context s ->

                failwith 

                  (Printf.sprintf 

                     (f_ "Cannot parse field '%s' when setting value %S")

                     nm

                     s)

      in

      (* Set data, from string *)

      let sets data ?context s =

        set ?context data (parse ?context s)

      in

      (* Output value as string, if possible *)

      let print =

        match print with

          | Some f ->

              f

          | None ->

              fun _ -> raise (No_printer nm)

      in

      (* Get data, as a string *)

      let gets data =

        print (get data)

      in

        begin 

          match schema with 

            | Some t ->

                Schema.add t nm sets gets extra help

            | None ->

                ()

        end;

        {

          set   = set;

          get   = get;

          sets  = sets;

          gets  = gets;

          help  = help;

          extra = extra;

        }

    let fset data t ?context x = 

      t.set data ?context x

    let fget data t =

      t.get data

    let fsets data t ?context s =

      t.sets data ?context s

    let fgets data t =

      t.gets data 

  end

  module FieldRO =

  struct

    let create ?schema ?name ?parse ?print ?default ?update ?help extra =

      let fld = 

        Field.create ?schema ?name ?parse ?print ?default ?update ?help extra

      in

        fun data -> Field.fget data fld

  end

end

module OASISMessage = struct

# 21 "/build/buildd/oasis-0.2.0/src/oasis/OASISMessage.ml"

  open OASISGettext

  open OASISContext

  let generic_message ~ctxt lvl fmt =

    let cond = 

      match lvl with 

        | `Debug -> ctxt.debug

        | _ -> ctxt.verbose

    in

      Printf.ksprintf 

        (fun str -> 

           if cond then

             begin

               ctxt.printf lvl str

             end)

        fmt

  let debug ~ctxt fmt =

    generic_message ~ctxt `Debug fmt

  let info ~ctxt fmt = 

    generic_message ~ctxt `Info fmt

  let warning ~ctxt fmt =

    generic_message ~ctxt `Warning fmt

  let error ~ctxt fmt =

    generic_message ~ctxt `Error fmt

  let string_of_exception e = 

    try 

      PropList.string_of_exception e

    with 

      | Failure s ->

          s

      | e ->

          Printexc.to_string e

  (* TODO

  let register_exn_printer f =

   *)

end

module OASISVersion = struct

# 21 "/build/buildd/oasis-0.2.0/src/oasis/OASISVersion.ml"

  open OASISGettext

  type s = string

  type t = string 

  type comparator = 

    | VGreater of t

    | VGreaterEqual of t

    | VEqual of t

    | VLesser of t

    | VLesserEqual of t

    | VOr of  comparator * comparator

    | VAnd of comparator * comparator

  (* Range of allowed characters *)

  let is_digit c =

    '0' <= c && c <= '9'

  let is_alpha c =

    ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z')

  let is_special =

    function 

      | '.' | '+' | '-' | '~' -> true

      | _ -> false

  let rec version_compare v1 v2 =

    if v1 <> "" || v2 <> "" then

      begin

        (* Compare ascii string, using special meaning for version 

         * related char

         *)

        let val_ascii c = 

          if c = '~' then -1

          else if is_digit c then 0

          else if c = '\000' then 0

          else if is_alpha c then Char.code c

          else (Char.code c) + 256

        in

        let len1 = String.length v1 in

        let len2 = String.length v2 in

        let p = ref 0 in

        (** Compare ascii part *)

        let compare_vascii () = 

          let cmp = ref 0 in

          while !cmp = 0 && 

                !p < len1 && !p < len2 && 

                not (is_digit v1.[!p] && is_digit v2.[!p]) do 

            cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]);

            incr p

          done;

          if !cmp = 0 && !p < len1 && !p = len2 then

            val_ascii v1.[!p] 

          else if !cmp = 0 && !p = len1 && !p < len2 then

            - (val_ascii v2.[!p])

          else

            !cmp

        in

        (** Compare digit part *)

        let compare_digit () = 

          let extract_int v p =

            let start_p = !p in

              while !p < String.length v && is_digit v.[!p] do 

                incr p

              done;

              match String.sub v start_p (!p - start_p) with 

                | "" -> 0, 

                        v

                | s -> int_of_string s, 

                       String.sub v !p ((String.length v) - !p)

          in

          let i1, tl1 = extract_int v1 (ref !p) in

          let i2, tl2 = extract_int v2 (ref !p) in

            i1 - i2, tl1, tl2

        in

          match compare_vascii () with

            | 0 ->

                begin

                  match compare_digit () with 

                    | 0, tl1, tl2 ->

                        if tl1 <> "" && is_digit tl1.[0] then

                          1

                        else if tl2 <> "" && is_digit tl2.[0] then

                          -1

                        else

                          version_compare tl1 tl2

                    | n, _, _ ->

                        n

                end

            | n ->

                n

      end

    else

      begin

        0

      end

  let version_of_string str =

    String.iter 

      (fun c ->

         if is_alpha c || is_digit c || is_special c then

           ()

         else

           failwith

             (Printf.sprintf 

                (f_ "Char %C is not allowed in version '%s'")

                c str))

      str;

    str

  let string_of_version t =

    t

  let chop t = 

    try 

      let pos = 

        String.rindex t '.' 

      in

        String.sub t 0 pos

    with Not_found ->

      t

  let rec comparator_apply v op =

    match op with

      | VGreater cv ->

          (version_compare v cv) > 0

      | VGreaterEqual cv ->

          (version_compare v cv) >= 0

      | VLesser cv ->

          (version_compare v cv) < 0

      | VLesserEqual cv ->

          (version_compare v cv) <= 0

      | VEqual cv ->

          (version_compare v cv) = 0

      | VOr (op1, op2) ->

          (comparator_apply v op1) || (comparator_apply v op2)

      | VAnd (op1, op2) ->

          (comparator_apply v op1) && (comparator_apply v op2)

  let rec string_of_comparator =

    function 

      | VGreater v  -> "> "^(string_of_version v)

      | VEqual v    -> "= "^(string_of_version v)

      | VLesser v   -> "< "^(string_of_version v)

      | VGreaterEqual v -> ">= "^(string_of_version v)

      | VLesserEqual v  -> "<= "^(string_of_version v)

      | VOr (c1, c2)  -> 

          (string_of_comparator c1)^" || "^(string_of_comparator c2)

      | VAnd (c1, c2) -> 

          (string_of_comparator c1)^" && "^(string_of_comparator c2)

  let rec varname_of_comparator =

    let concat p v = 

      OASISUtils.varname_concat

        p 

        (OASISUtils.varname_of_string 

           (string_of_version v))

    in

      function 

        | VGreater v -> concat "gt" v

        | VLesser v  -> concat "lt" v

        | VEqual v   -> concat "eq" v

        | VGreaterEqual v -> concat "ge" v

        | VLesserEqual v  -> concat "le" v

        | VOr (c1, c2) ->

            (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2)

        | VAnd (c1, c2) ->

            (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2)

end

module OASISLicense = struct

# 21 "/build/buildd/oasis-0.2.0/src/oasis/OASISLicense.ml"

  (** License for _oasis fields

      @author Sylvain Le Gall

    *)

  type license = string 

  type license_exception = string 

  type license_version = 

    | Version of OASISVersion.t

    | VersionOrLater of OASISVersion.t

    | NoVersion

  type license_dep_5 = 

      {

        license:    license;

        exceptions: license_exception list;

        version:    license_version;

      } 

  type t =

    | DEP5License of license_dep_5

    | OtherLicense of string (* URL *)

end

module OASISExpr = struct

# 21 "/build/buildd/oasis-0.2.0/src/oasis/OASISExpr.ml"

  open OASISGettext

  type test = string 

  type flag = string 

  type t =

    | EBool of bool

    | ENot of t

    | EAnd of t * t

    | EOr of t * t

    | EFlag of flag

    | ETest of test * string

  type 'a choices = (t * 'a) list 

  let eval var_get t =

    let rec eval' = 

      function

        | EBool b ->

            b

        | ENot e -> 

            not (eval' e)

        | EAnd (e1, e2) ->

            (eval' e1) && (eval' e2)

        | EOr (e1, e2) -> 

            (eval' e1) || (eval' e2)

        | EFlag nm ->

            let v =

              var_get nm

            in

              assert(v = "true" || v = "false");

              (v = "true")

        | ETest (nm, vl) ->

            let v =

              var_get nm

            in

              (v = vl)

    in

      eval' t

  let choose ?printer ?name var_get lst =

    let rec choose_aux = 

      function

        | (cond, vl) :: tl ->

            if eval var_get cond then 

              vl 

            else

              choose_aux tl

        | [] ->

            let str_lst = 

              if lst = [] then

                s_ "<empty>"

              else

                String.concat 

                  (s_ ", ")

                  (List.map

                     (fun (cond, vl) ->

                        match printer with

                          | Some p -> p vl

                          | None -> s_ "<no printer>")

                     lst)

            in

              match name with 

                | Some nm ->

                    failwith

                      (Printf.sprintf 

                         (f_ "No result for the choice list '%s': %s")

                         nm str_lst)

                | None ->

                    failwith

                      (Printf.sprintf

                         (f_ "No result for a choice list: %s")

                         str_lst)

    in

      choose_aux (List.rev lst)

end

module OASISTypes = struct

# 21 "/build/buildd/oasis-0.2.0/src/oasis/OASISTypes.ml"

  type name          = string 

  type package_name  = string 

  type url           = string 

  type unix_dirname  = string 

  type unix_filename = string 

  type host_dirname  = string 

  type host_filename = string 

  type prog          = string 

  type arg           = string 

  type args          = string list 

  type command_line  = (prog * arg list) 

  type findlib_name = string 

  type findlib_full = string 

  type compiled_object =

    | Byte

    | Native

    | Best

  type dependency = 

    | FindlibPackage of findlib_full * OASISVersion.comparator option

    | InternalLibrary of name

  type tool =

    | ExternalTool of name