CristalCaveGem » LustreC

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

(* OASIS_START *)

(* DO NOT EDIT (digest: cbef9780a942e499729218b6c22c21f0) *)

(*

   Regenerated by OASIS v0.3.0

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

   documentation about functions used in this file.

*)

module OASISGettext = struct

(* # 21 "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 "src/oasis/OASISContext.ml" *)

  open OASISGettext

  type level =

    [ `Debug

    | `Info

    | `Warning

    | `Error]

  type t =

    {

      quiet:                 bool;

      info:                  bool;

      debug:                 bool;

      ignore_plugins:        bool;

      ignore_unknown_fields: 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

      prerr_endline (beg^str)

  let default =

    ref

      {

        quiet                 = false;

        info                  = false;

        debug                 = false;

        ignore_plugins        = false;

        ignore_unknown_fields = false;

        printf                = printf;

      }

  let quiet =

    {!default with quiet = true}

  let args () =

    ["-quiet",

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

     (s_ " Run quietly");

     "-info",

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

     (s_ " Display information message");

     "-debug",

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

     (s_ " Output debug message")]

end

module OASISString = struct

(* # 1 "src/oasis/OASISString.ml" *)

  (** Various string utilities.

      Mostly inspired by extlib and batteries ExtString and BatString libraries.

      @author Sylvain Le Gall

    *)

  let nsplitf str f =

    if str = "" then

      []

    else

      let buf = Buffer.create 13 in

      let lst = ref [] in

      let push () =

        lst := Buffer.contents buf :: !lst;

        Buffer.clear buf

      in

      let str_len = String.length str in

        for i = 0 to str_len - 1 do

          if f str.[i] then

            push ()

          else

            Buffer.add_char buf str.[i]

        done;

        push ();

        List.rev !lst

  (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the

      separator.

    *)

  let nsplit str c =

    nsplitf str ((=) c)

  let find ~what ?(offset=0) str =

    let what_idx = ref 0 in

    let str_idx = ref offset in 

      while !str_idx < String.length str && 

            !what_idx < String.length what do

        if str.[!str_idx] = what.[!what_idx] then

          incr what_idx

        else

          what_idx := 0;

        incr str_idx

      done;

      if !what_idx <> String.length what then

        raise Not_found

      else 

        !str_idx - !what_idx

  let sub_start str len = 

    let str_len = String.length str in

    if len >= str_len then

      ""

    else

      String.sub str len (str_len - len)

  let sub_end ?(offset=0) str len =

    let str_len = String.length str in

    if len >= str_len then

      ""

    else

      String.sub str 0 (str_len - len)

  let starts_with ~what ?(offset=0) str =

    let what_idx = ref 0 in

    let str_idx = ref offset in

    let ok = ref true in

      while !ok &&

            !str_idx < String.length str && 

            !what_idx < String.length what do

        if str.[!str_idx] = what.[!what_idx] then

          incr what_idx

        else

          ok := false;

        incr str_idx

      done;

      if !what_idx = String.length what then

        true

      else 

        false

  let strip_starts_with ~what str =

    if starts_with ~what str then

      sub_start str (String.length what)

    else

      raise Not_found

  let ends_with ~what ?(offset=0) str =

    let what_idx = ref ((String.length what) - 1) in

    let str_idx = ref ((String.length str) - 1) in

    let ok = ref true in

      while !ok &&

            offset <= !str_idx && 

            0 <= !what_idx do

        if str.[!str_idx] = what.[!what_idx] then

          decr what_idx

        else

          ok := false;

        decr str_idx

      done;

      if !what_idx = -1 then

        true

      else 

        false

  let strip_ends_with ~what str =

    if ends_with ~what str then

      sub_end str (String.length what)

    else

      raise Not_found

  let replace_chars f s =

    let buf = String.make (String.length s) 'X' in

      for i = 0 to String.length s - 1 do

        buf.[i] <- f s.[i]

      done;

      buf

end

module OASISUtils = struct

(* # 21 "src/oasis/OASISUtils.ml" *)

  open OASISGettext

  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 varname_of_string ?(hyphen='_') s =

    if String.length s = 0 then

      begin

        invalid_arg "varname_of_string"

      end

    else

      begin

        let buf =

          OASISString.replace_chars

            (fun c ->

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

                 ||

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

                 ||

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

                 c

               else

                 hyphen)

            s;

        in

        let buf =

          (* Start with a _ if digit *)

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

            "_"^buf

          else

            buf

        in

          String.lowercase buf

      end

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

    let what = String.make 1 hyphen in

    let p =

      try

        OASISString.strip_ends_with ~what p

      with Not_found ->

        p

    in

    let s =

      try

        OASISString.strip_starts_with ~what s

      with Not_found ->

        s

    in

      p^what^s

  let is_varname str =

    str = varname_of_string str

  let failwithf fmt = Printf.ksprintf failwith fmt

end

module PropList = struct

(* # 21 "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 () =

    Printexc.register_printer

      (function

         | Not_set (nm, Some rsn) ->

             Some 

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

         | Not_set (nm, None) ->

             Some 

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

         | No_printer nm ->

             Some

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

         | Unknown_field (nm, schm) ->

             Some 

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

         | _ ->

             None)

  module Data =

  struct

    type t =

        (name, unit -> unit) Hashtbl.t

    let create () =

      Hashtbl.create 13

    let clear t =

      Hashtbl.clear t

(* # 71 "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 "src/oasis/OASISMessage.ml" *)

  open OASISGettext

  open OASISContext

  let generic_message ~ctxt lvl fmt =

    let cond =

      if ctxt.quiet then

        false

      else

        match lvl with

          | `Debug -> ctxt.debug

          | `Info  -> ctxt.info

          | _ -> true

    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

end

module OASISVersion = struct

(* # 21 "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;

              let substr = 

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

              in 

              let res = 

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

                  | "" -> 0

                  | s -> int_of_string s

              in

                res, substr

          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 = 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)

  let version_0_3_or_after t =

    comparator_apply t (VGreaterEqual (string_of_version "0.3"))

end

module OASISLicense = struct

(* # 21 "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_unit =

    {

      license:   license;

      excption:  license_exception option;

      version:   license_version;

    }

  type license_dep_5 =

    | DEP5Unit of license_dep_5_unit

    | DEP5Or of license_dep_5 list

    | DEP5And of license_dep_5 list

  type t =

    | DEP5License of license_dep_5

    | OtherLicense of string (* URL *)

end

module OASISExpr = struct

(* # 21 "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")