Commit ab96537d authored by POTTIER Francois's avatar POTTIER Francois

Remove generator/stdlib, which I think was unused.

parent 35aff7d9
This diff is collapsed.
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Damien Doligez, projet Para, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the GNU Library General Public License, with *)
(* the special exception on linking described in file ../LICENSE. *)
(* *)
(***********************************************************************)
(* $Id: arg.ml 8768 2008-01-11 16:13:18Z doligez $ *)
type key = string
type doc = string
type usage_msg = string
type anon_fun = (string -> unit)
type spec =
| Unit of (unit -> unit) (* Call the function with unit argument *)
| Bool of (bool -> unit) (* Call the function with a bool argument *)
| Set of bool ref (* Set the reference to true *)
| Clear of bool ref (* Set the reference to false *)
| String of (string -> unit) (* Call the function with a string argument *)
| Set_string of string ref (* Set the reference to the string argument *)
| Int of (int -> unit) (* Call the function with an int argument *)
| Set_int of int ref (* Set the reference to the int argument *)
| Float of (float -> unit) (* Call the function with a float argument *)
| Set_float of float ref (* Set the reference to the float argument *)
| Tuple of spec list (* Take several arguments according to the
spec list *)
| Symbol of string list * (string -> unit)
(* Take one of the symbols as argument and
call the function with the symbol. *)
| Rest of (string -> unit) (* Stop interpreting keywords and call the
function with each remaining argument *)
exception Bad of string
exception Help of string
type error =
| Unknown of string
| Wrong of string * string * string (* option, actual, expected *)
| Missing of string
| Message of string
exception Stop of error;; (* used internally *)
open Printf
let rec assoc3 x l =
match l with
| [] -> raise Not_found
| (y1, y2, y3) :: t when y1 = x -> y2
| _ :: t -> assoc3 x t
;;
let make_symlist prefix sep suffix l =
match l with
| [] -> "<none>"
| h::t -> (List.fold_left (fun x y -> x ^ sep ^ y) (prefix ^ h) t) ^ suffix
;;
let print_spec buf (key, spec, doc) =
match spec with
| Symbol (l, _) -> bprintf buf " %s %s%s\n" key (make_symlist "{" "|" "}" l)
doc
| _ -> bprintf buf " %s %s\n" key doc
;;
let help_action () = raise (Stop (Unknown "-help"));;
let add_help speclist =
let add1 =
try ignore (assoc3 "-help" speclist); []
with Not_found ->
["-help", Unit help_action, " Display this list of options"]
and add2 =
try ignore (assoc3 "--help" speclist); []
with Not_found ->
["--help", Unit help_action, " Display this list of options"]
in
speclist @ (add1 @ add2)
;;
let usage_b buf speclist errmsg =
bprintf buf "%s\n" errmsg;
List.iter (print_spec buf) (add_help speclist);
;;
let usage speclist errmsg =
let b = Buffer.create 200 in
usage_b b speclist errmsg;
eprintf "%s" (Buffer.contents b);
;;
let current = ref 0;;
let parse_argv ?(current=current) argv speclist anonfun errmsg =
let l = Array.length argv in
let b = Buffer.create 200 in
let initpos = !current in
let stop error =
let progname = if initpos < l then argv.(initpos) else "(?)" in
begin match error with
| Unknown "-help" -> ()
| Unknown "--help" -> ()
| Unknown s ->
bprintf b "%s: unknown option `%s'.\n" progname s
| Missing s ->
bprintf b "%s: option `%s' needs an argument.\n" progname s
| Wrong (opt, arg, expected) ->
bprintf b "%s: wrong argument `%s'; option `%s' expects %s.\n"
progname arg opt expected
| Message s ->
bprintf b "%s: %s.\n" progname s
end;
usage_b b speclist errmsg;
if error = Unknown "-help" || error = Unknown "--help"
then raise (Help (Buffer.contents b))
else raise (Bad (Buffer.contents b))
in
incr current;
while !current < l do
let s = argv.(!current) in
if String.length s >= 1 && String.get s 0 = '-' then begin
let action =
try assoc3 s speclist
with Not_found -> stop (Unknown s)
in
begin try
let rec treat_action = function
| Unit f -> f ();
| Bool f when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try f (bool_of_string arg)
with Invalid_argument "bool_of_string" ->
raise (Stop (Wrong (s, arg, "a boolean")))
end;
incr current;
| Set r -> r := true;
| Clear r -> r := false;
| String f when !current + 1 < l ->
f argv.(!current + 1);
incr current;
| Symbol (symb, f) when !current + 1 < l ->
let arg = argv.(!current + 1) in
if List.mem arg symb then begin
f argv.(!current + 1);
incr current;
end else begin
raise (Stop (Wrong (s, arg, "one of: "
^ (make_symlist "" " " "" symb))))
end
| Set_string r when !current + 1 < l ->
r := argv.(!current + 1);
incr current;
| Int f when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try f (int_of_string arg)
with Failure "int_of_string" ->
raise (Stop (Wrong (s, arg, "an integer")))
end;
incr current;
| Set_int r when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try r := (int_of_string arg)
with Failure "int_of_string" ->
raise (Stop (Wrong (s, arg, "an integer")))
end;
incr current;
| Float f when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try f (float_of_string arg);
with Failure "float_of_string" ->
raise (Stop (Wrong (s, arg, "a float")))
end;
incr current;
| Set_float r when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try r := (float_of_string arg);
with Failure "float_of_string" ->
raise (Stop (Wrong (s, arg, "a float")))
end;
incr current;
| Tuple specs ->
List.iter treat_action specs;
| Rest f ->
while !current < l - 1 do
f argv.(!current + 1);
incr current;
done;
| _ -> raise (Stop (Missing s))
in
treat_action action
with Bad m -> stop (Message m);
| Stop e -> stop e;
end;
incr current;
end else begin
(try anonfun s with Bad m -> stop (Message m));
incr current;
end;
done;
;;
let parse l f msg =
try
parse_argv Sys.argv l f msg;
with
| Bad msg -> eprintf "%s" msg; exit 2;
| Help msg -> printf "%s" msg; exit 0;
;;
let rec second_word s =
let len = String.length s in
let rec loop n =
if n >= len then len
else if s.[n] = ' ' then loop (n+1)
else n
in
try loop (String.index s ' ')
with Not_found -> len
;;
let max_arg_len cur (kwd, spec, doc) =
match spec with
| Symbol _ -> max cur (String.length kwd)
| _ -> max cur (String.length kwd + second_word doc)
;;
let add_padding len ksd =
match ksd with
| (kwd, (Symbol (l, _) as spec), msg) ->
let cutcol = second_word msg in
let spaces = String.make (len - cutcol + 3) ' ' in
(kwd, spec, "\n" ^ spaces ^ msg)
| (kwd, spec, msg) ->
let cutcol = second_word msg in
let spaces = String.make (len - String.length kwd - cutcol) ' ' in
let prefix = String.sub msg 0 cutcol in
let suffix = String.sub msg cutcol (String.length msg - cutcol) in
(kwd, spec, prefix ^ spaces ^ suffix)
;;
let align speclist =
let completed = add_help speclist in
let len = List.fold_left max_arg_len 0 completed in
List.map (add_padding len) completed
;;
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Damien Doligez, projet Para, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the GNU Library General Public License, with *)
(* the special exception on linking described in file ../LICENSE. *)
(* *)
(***********************************************************************)
(* $Id: arg.mli 8768 2008-01-11 16:13:18Z doligez $ *)
(** Parsing of command line arguments.
This module provides a general mechanism for extracting options and
arguments from the command line to the program.
Syntax of command lines:
A keyword is a character string starting with a [-].
An option is a keyword alone or followed by an argument.
The types of keywords are: [Unit], [Bool], [Set], [Clear],
[String], [Set_string], [Int], [Set_int], [Float], [Set_float],
[Tuple], [Symbol], and [Rest].
[Unit], [Set] and [Clear] keywords take no argument. A [Rest]
keyword takes the remaining of the command line as arguments.
Every other keyword takes the following word on the command line
as argument.
Arguments not preceded by a keyword are called anonymous arguments.
Examples ([cmd] is assumed to be the command name):
- [cmd -flag ](a unit option)
- [cmd -int 1 ](an int option with argument [1])
- [cmd -string foobar ](a string option with argument ["foobar"])
- [cmd -float 12.34 ](a float option with argument [12.34])
- [cmd a b c ](three anonymous arguments: ["a"], ["b"], and ["c"])
- [cmd a b -- c d ](two anonymous arguments and a rest option with
two arguments)
*)
type spec =
| Unit of (unit -> unit) (** Call the function with unit argument *)
| Bool of (bool -> unit) (** Call the function with a bool argument *)
| Set of bool ref (** Set the reference to true *)
| Clear of bool ref (** Set the reference to false *)
| String of (string -> unit) (** Call the function with a string argument *)
| Set_string of string ref (** Set the reference to the string argument *)
| Int of (int -> unit) (** Call the function with an int argument *)
| Set_int of int ref (** Set the reference to the int argument *)
| Float of (float -> unit) (** Call the function with a float argument *)
| Set_float of float ref (** Set the reference to the float argument *)
| Tuple of spec list (** Take several arguments according to the
spec list *)
| Symbol of string list * (string -> unit)
(** Take one of the symbols as argument and
call the function with the symbol *)
| Rest of (string -> unit) (** Stop interpreting keywords and call the
function with each remaining argument *)
(** The concrete type describing the behavior associated
with a keyword. *)
type key = string
type doc = string
type usage_msg = string
type anon_fun = (string -> unit)
val parse :
(key * spec * doc) list -> anon_fun -> usage_msg -> unit
(** [Arg.parse speclist anon_fun usage_msg] parses the command line.
[speclist] is a list of triples [(key, spec, doc)].
[key] is the option keyword, it must start with a ['-'] character.
[spec] gives the option type and the function to call when this option
is found on the command line.
[doc] is a one-line description of this option.
[anon_fun] is called on anonymous arguments.
The functions in [spec] and [anon_fun] are called in the same order
as their arguments appear on the command line.
If an error occurs, [Arg.parse] exits the program, after printing
an error message as follows:
- The reason for the error: unknown option, invalid or missing argument, etc.
- [usage_msg]
- The list of options, each followed by the corresponding [doc] string.
For the user to be able to specify anonymous arguments starting with a
[-], include for example [("-", String anon_fun, doc)] in [speclist].
By default, [parse] recognizes two unit options, [-help] and [--help],
which will display [usage_msg] and the list of options, and exit
the program. You can override this behaviour by specifying your
own [-help] and [--help] options in [speclist].
*)
val parse_argv : ?current: int ref -> string array ->
(key * spec * doc) list -> anon_fun -> usage_msg -> unit
(** [Arg.parse_argv ~current args speclist anon_fun usage_msg] parses
the array [args] as if it were the command line. It uses and updates
the value of [~current] (if given), or [Arg.current]. You must set
it before calling [parse_argv]. The initial value of [current]
is the index of the program name (argument 0) in the array.
If an error occurs, [Arg.parse_argv] raises [Arg.Bad] with
the error message as argument. If option [-help] or [--help] is
given, [Arg.parse_argv] raises [Arg.Help] with the help message
as argument.
*)
exception Help of string
(** Raised by [Arg.parse_argv] when the user asks for help. *)
exception Bad of string
(** Functions in [spec] or [anon_fun] can raise [Arg.Bad] with an error
message to reject invalid arguments.
[Arg.Bad] is also raised by [Arg.parse_argv] in case of an error. *)
val usage : (key * spec * doc) list -> usage_msg -> unit
(** [Arg.usage speclist usage_msg] prints an error message including
the list of valid options. This is the same message that
{!Arg.parse} prints in case of error.
[speclist] and [usage_msg] are the same as for [Arg.parse]. *)
val align: (key * spec * doc) list -> (key * spec * doc) list;;
(** Align the documentation strings by inserting spaces at the first
space, according to the length of the keyword. Use a
space as the first character in a doc string if you want to
align the whole string. The doc strings corresponding to
[Symbol] arguments are aligned on the next line. *)
val current : int ref
(** Position (in {!Sys.argv}) of the argument being processed. You can
change this value, e.g. to force {!Arg.parse} to skip some arguments.
{!Arg.parse} uses the initial value of {!Arg.current} as the index of
argument 0 (the program name) and starts parsing arguments
at the next element. *)
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the GNU Library General Public License, with *)
(* the special exception on linking described in file ../LICENSE. *)
(* *)
(***********************************************************************)
(* $Id: array.ml 10482 2010-05-31 12:46:27Z doligez $ *)
(* Array operations *)
external length : 'a array -> int = "%array_length"
external get: 'a array -> int -> 'a = "%array_safe_get"
external set: 'a array -> int -> 'a -> unit = "%array_safe_set"
external unsafe_get: 'a array -> int -> 'a = "%array_unsafe_get"
external unsafe_set: 'a array -> int -> 'a -> unit = "%array_unsafe_set"
external make: int -> 'a -> 'a array = "caml_make_vect"
external create: int -> 'a -> 'a array = "caml_make_vect"
let init l f =
if l = 0 then [||] else
let res = create l (f 0) in
for i = 1 to pred l do
unsafe_set res i (f i)
done;
res
let make_matrix sx sy init =
let res = create sx [||] in
for x = 0 to pred sx do
unsafe_set res x (create sy init)
done;
res
let create_matrix = make_matrix
let copy a =
let l = length a in
if l = 0 then [||] else begin
let res = create l (unsafe_get a 0) in
for i = 1 to pred l do
unsafe_set res i (unsafe_get a i)
done;
res
end
let append a1 a2 =
let l1 = length a1 and l2 = length a2 in
if l1 = 0 && l2 = 0 then [||] else begin
let r = create (l1 + l2) (unsafe_get (if l1 > 0 then a1 else a2) 0) in
for i = 0 to l1 - 1 do unsafe_set r i (unsafe_get a1 i) done;
for i = 0 to l2 - 1 do unsafe_set r (i + l1) (unsafe_get a2 i) done;
r
end
let concat_aux init al =
let rec size accu = function
| [] -> accu
| h::t -> size (accu + length h) t
in
let res = create (size 0 al) init in
let rec fill pos = function
| [] -> ()
| h::t ->
for i = 0 to length h - 1 do
unsafe_set res (pos + i) (unsafe_get h i);
done;
fill (pos + length h) t;
in
fill 0 al;
res
;;
let concat al =
let rec find_init aa =
match aa with
| [] -> [||]
| a :: rem ->
if length a > 0 then concat_aux (unsafe_get a 0) aa else find_init rem
in find_init al
let sub a ofs len =
if ofs < 0 || len < 0 || ofs > length a - len then invalid_arg "Array.sub"
else if len = 0 then [||]
else begin
let r = create len (unsafe_get a ofs) in
for i = 1 to len - 1 do unsafe_set r i (unsafe_get a (ofs + i)) done;
r
end
let fill a ofs len v =
if ofs < 0 || len < 0 || ofs > length a - len
then invalid_arg "Array.fill"
else for i = ofs to ofs + len - 1 do unsafe_set a i v done
let blit a1 ofs1 a2 ofs2 len =
if len < 0 || ofs1 < 0 || ofs1 > length a1 - len
|| ofs2 < 0 || ofs2 > length a2 - len
then invalid_arg "Array.blit"
else if ofs1 < ofs2 then
(* Top-down copy *)
for i = len - 1 downto 0 do
unsafe_set a2 (ofs2 + i) (unsafe_get a1 (ofs1 + i))
done
else
(* Bottom-up copy *)
for i = 0 to len - 1 do
unsafe_set a2 (ofs2 + i) (unsafe_get a1 (ofs1 + i))
done
let iter f a =
for i = 0 to length a - 1 do f(unsafe_get a i) done
let map f a =
let l = length a in
if l = 0 then [||] else begin
let r = create l (f(unsafe_get a 0)) in
for i = 1 to l - 1 do
unsafe_set r i (f(unsafe_get a i))
done;
r
end
let iteri f a =
for i = 0 to length a - 1 do f i (unsafe_get a i) done
let mapi f a =
let l = length a in
if l = 0 then [||] else begin
let r = create l (f 0 (unsafe_get a 0)) in
for i = 1 to l - 1 do
unsafe_set r i (f i (unsafe_get a i))
done;
r
end
let to_list a =
let rec tolist i res =
if i < 0 then res else tolist (i - 1) (unsafe_get a i :: res) in
tolist (length a - 1) []
(* Cannot use List.length here because the List module depends on Array. *)
let rec list_length accu = function
| [] -> accu
| h::t -> list_length (succ accu) t
;;
let of_list = function
[] -> [||]
| hd::tl as l ->
let a = create (list_length 0 l) hd in
let rec fill i = function
[] -> a
| hd::tl -> unsafe_set a i hd; fill (i+1) tl in
fill 1 tl
let fold_left f x a =
let r = ref x in
for i = 0 to length a - 1 do
r := f !r (unsafe_get a i)
done;
!r
let fold_right f a x =
let r = ref x in
for i = length a - 1 downto 0 do
r := f (unsafe_get a i) !r
done;
!r
exception Bottom of int;;
let sort cmp a =
let maxson l i =
let i31 = i+i+i+1 in
let x = ref i31 in
if i31+2 < l then begin
if cmp (get a i31) (get a (i31+1)) < 0 then x := i31+1;
if cmp (get a !x) (get a (i31+2)) < 0 then x := i31+2;
!x
end else
if i31+1 < l && cmp (get a i31) (get a (i31+1)) < 0
then i31+1
else if i31 < l then i31 else raise (Bottom i)
in
let rec trickledown l i e =
let j = maxson l i in
if cmp (get a j) e > 0 then begin
set a i (get a j);
trickledown l j e;
end else begin
set a i e;
end;
in
let rec trickle l i e = try trickledown l i e with Bottom i -> set a i e in
let rec bubbledown l i =
let j = maxson l i in
set a i (get a j);
bubbledown l j
in
let bubble l i = try bubbledown l i with Bottom i -> i in
let rec trickleup i e =
let father = (i - 1) / 3 in
assert (i <> father);
if cmp (get a father) e < 0 then begin
set a i (get a father);
if father > 0 then trickleup father e else set a 0 e;
end else begin
set a i e;
end;
in
let l = length a in
for i = (l + 1) / 3 - 1 downto 0 do trickle l i (get a i); done;
for i = l - 1 downto 2 do
let e = (get a i) in
set a i (get a 0);
trickleup (bubble i 0) e;
done;
if l > 1 then (let e = (get a 1) in set a 1 (get a 0); set a 0 e);
;;
let cutoff = 5;;
let stable_sort cmp a =
let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
let rec loop i1 s1 i2 s2 d =
if cmp s1 s2 <= 0 then begin
set dst d s1;
let i1 = i1 + 1 in
if i1 < src1r then
loop i1 (get a i1) i2 s2 (d + 1)
else
blit src2 i2 dst (d + 1) (src2r - i2)
end else begin
set dst d s2;
let i2 = i2 + 1 in
if i2 < src2r then
loop i1 s1 i2 (get src2 i2) (d + 1)
else
blit a i1 dst (d + 1) (src1r - i1)
end
in loop src1ofs (get a src1ofs) src2ofs (get src2 src2ofs) dstofs;
in
let isortto srcofs dst dstofs len =
for i = 0 to len - 1 do
let e = (get a (srcofs + i)) in
let j = ref (dstofs + i - 1) in
while (!j >= dstofs && cmp (get dst !j) e > 0) do
set dst (!j + 1) (get dst !j);
decr j;
done;
set dst (!j + 1) e;
done;
in
let rec sortto srcofs dst dstofs len =
if len <= cutoff then isortto srcofs dst dstofs len else begin
let l1 = len / 2 in
let l2 = len - l1 in
sortto (srcofs + l1) dst (dstofs + l1) l2;
sortto srcofs a (srcofs + l2) l1;
merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
end;
in
let l = length a in
if l <= cutoff then isortto 0 a 0 l else begin
let l1 = l / 2 in
let l2 = l - l1 in
let t = make l2 (get a 0) in
sortto l1 t 0 l2;
sortto 0 a l2 l1;
merge l2 l1 t 0 l2 a 0;
end;
;;
let fast_sort = stable_sort;;
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)