1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
|
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
(* $Id$ *)
type spec =
| Unit of (unit -> unit) (* Call the function with no 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 *)
| Int of (int -> unit) (* Call the function with an int argument *)
| Float of (float -> unit) (* Call the function with a float argument *)
exception Bad of string
type error =
| Unknown of string
| Wrong of string * string * string (* option, actual, expected *)
| Missing of string
| Message of string
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 usage speclist errmsg =
eprintf "%s\n" errmsg;
List.iter (function (key, _, doc) -> eprintf " %s %s\n" key doc) speclist
;;
let parse speclist anonfun errmsg =
let stop error =
let progname =
if Array.length Sys.argv > 0 then Sys.argv.(0) else "(?)" in
begin match error with
| Unknown s when s = "-help" -> ()
| Unknown s ->
eprintf "%s: unknown option `%s'.\n" progname s
| Missing s ->
eprintf "%s: option `%s' needs an argument.\n" progname s
| Wrong (opt, arg, expected) ->
eprintf "%s: wrong argument `%s'; option `%s' expects %s.\n"
progname arg opt expected
| Message s ->
eprintf "%s: %s.\n" progname s
end;
usage speclist errmsg;
exit 2
in
let rec p = function
| [] -> ()
| s :: t ->
if String.length s >= 1 & String.get s 0 = '-'
then do_key s t
else begin try (anonfun s); p t with Bad m -> stop (Message m) end
and do_key s l =
let action =
try assoc3 s speclist
with Not_found -> stop (Unknown s) in
try
match (action, l) with
| (Unit f, l) -> f (); p l
| (Set r, l) -> r := true; p l
| (Clear r, l) -> r := false; p l
| (String f, arg::t) -> f arg; p t
| (Int f, arg::t) ->
begin try f (int_of_string arg)
with Failure "int_of_string" -> stop (Wrong (s, arg, "an integer"))
end;
p t
| (Float f, arg::t) -> f (float_of_string arg); p t
| (_, []) -> stop (Missing s)
with Bad m -> stop (Message m)
in
match Array.to_list Sys.argv with
| [] -> ()
| a::l -> p l
|
