Source file code.ml

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
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133

(* This file is free software, part of dolmen. See file "LICENSE" for more information *)

(* Exit codes *)
(* ************************************************************************* *)

type t = {
  mutable code : int;
  (* codes are set later (to accomodate users of the lib choosing error codes
     that do not conflict with theirs), and should be unique for each exit code *)
  descr : string;
  category : string;
  mutable abort : bool;
}

let hash t = t.code
let equal t t' = t.code = t'.code
let compare t t' = compare t.code t'.code

let descr t = t.code, t.descr
let category t = t.category

(* Setting exact return codes *)
(* ************************************************************************* *)

(* cmdliner uses codes 123, 124 and 125, and codes greater then 125 are
   usually reserved for the shells. *)
let max_code = 122
let all_errors = ref []
let code_array = Array.make (max_code + 1) None

let code_used code =
  code <= 0 || code > max_code ||
  match code_array.(code) with
  | Some _ -> true
  | None -> false

let find_code () =
  let i = ref 1 in
  while !i <= max_code && code_used !i do i := !i + 1 done;
  if !i > max_code
  then assert false (* no available error code *)
  else !i

let set_retcode (t, code) =
  assert (t.code = -1);
  assert (not (code_used code));
  code_array.(code) <- Some t;
  t.code <- code;
  ()

let init ?(full=false) l =
  List.iter set_retcode l;
  List.iter (fun t ->
      if t.code < 0 then begin
        if full then failwith "partial retcode init"
        else begin
          let code = find_code () in
          set_retcode (t, code)
        end
      end) (List.rev !all_errors)


(* Exit with a code and code status *)
(* ************************************************************************* *)

let is_abort t = t.abort
let abort t = t.abort <- true
let error t = t.abort <- false

let exit t =
  if t.code < 0 then failwith "missing retcode"
  else if t.abort then (Unix.kill (Unix.getpid ()) Sys.sigabrt; assert false)
  else exit t.code


(* Manipulation *)
(* ************************************************************************* *)

(* The create function should only be used for error exit codes,
   the ok exit code (i.e. [0]) is create manually and not included
   in the errors list. *)
let create ~category ~descr =
  let t = {
    code = -1;
    abort = false;
    descr;
    category;
  } in
  all_errors := t :: !all_errors;
  t

(*  *)
let errors () =
  List.rev !all_errors

(* Special values *)
(* ************************************************************************* *)

let ok = {
  code = 0;
  descr = "the success exit code";
  category = "N/A";
  abort = false;
}

let bug = {
  code = 125;
  descr = "on unexpected internal errors (bugs)";
  category = "Internal";
  abort = false;
}

(* Predefined values *)
(* ************************************************************************* *)

let generic =
  create
    ~category:"Generic"
    ~descr:"on generic error"
let limit =
  create
    ~category:"Limits"
    ~descr:"upon reaching limits (time, memory, etc..)"
let parsing =
  create
    ~category:"Parsing"
    ~descr:"on parsing errors"
let typing =
  create
    ~category:"Typing"
    ~descr:"on typing errors"