1 /**************************************************************************/
2 /* */
3 /* OCaml */
4 /* */
5 /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
6 /* */
7 /* Copyright 1996 Institut National de Recherche en Informatique et */
8 /* en Automatique. */
9 /* */
10 /* All rights reserved. This file is distributed under the terms of */
11 /* the GNU Lesser General Public License version 2.1, with the */
12 /* special exception on linking described in the file LICENSE. */
13 /* */
14 /**************************************************************************/
15
16 #define CAML_INTERNALS
17
18 /* Raising exceptions from C. */
19
20 #include <stdio.h>
21 #include <signal.h>
22 #include "caml/alloc.h"
23 #include "caml/domain.h"
24 #include "caml/fail.h"
25 #include "caml/io.h"
26 #include "caml/gc.h"
27 #include "caml/memory.h"
28 #include "caml/mlvalues.h"
29 #include "caml/printexc.h"
30 #include "caml/signals.h"
31 #include "caml/stack.h"
32 #include "caml/roots.h"
33 #include "caml/callback.h"
34
35 /* The globals holding predefined exceptions */
36
37 typedef value caml_generated_constant[1];
38
39 extern caml_generated_constant
40 caml_exn_Out_of_memory,
41 caml_exn_Sys_error,
42 caml_exn_Failure,
43 caml_exn_Invalid_argument,
44 caml_exn_End_of_file,
45 caml_exn_Division_by_zero,
46 caml_exn_Not_found,
47 caml_exn_Match_failure,
48 caml_exn_Sys_blocked_io,
49 caml_exn_Stack_overflow,
50 caml_exn_Assert_failure,
51 caml_exn_Undefined_recursive_module;
52
53 /* Exception raising */
54
55 CAMLnoreturn_start
56 extern void caml_raise_exception (caml_domain_state* state, value bucket)
57 CAMLnoreturn_end;
58
59 /* Used by the stack overflow handler -> deactivate ASAN (see
60 segv_handler in signals_nat.c). */
61 CAMLno_asan
62 void caml_raise(value v)
63 {
64 Unlock_exn();
65 if (Caml_state->exception_pointer == NULL) caml_fatal_uncaught_exception(v);
66
67 while (Caml_state->local_roots != NULL &&
68 (char *) Caml_state->local_roots < Caml_state->exception_pointer) {
69 Caml_state->local_roots = Caml_state->local_roots->next;
70 }
71
72 caml_raise_exception(Caml_state, v);
73 }
74
75 /* Used by the stack overflow handler -> deactivate ASAN (see
76 segv_handler in signals_nat.c). */
77 CAMLno_asan
78 void caml_raise_constant(value tag)
79 {
80 caml_raise(tag);
81 }
82
83 void caml_raise_with_arg(value tag, value arg)
84 {
85 CAMLparam2 (tag, arg);
86 CAMLlocal1 (bucket);
87
88 bucket = caml_alloc_small (2, 0);
89 Field(bucket, 0) = tag;
90 Field(bucket, 1) = arg;
91 caml_raise(bucket);
92 CAMLnoreturn;
93 }
94
95 void caml_raise_with_args(value tag, int nargs, value args[])
96 {
97 CAMLparam1 (tag);
98 CAMLxparamN (args, nargs);
99 value bucket;
100 int i;
101
102 CAMLassert(1 + nargs <= Max_young_wosize);
103 bucket = caml_alloc_small (1 + nargs, 0);
104 Field(bucket, 0) = tag;
105 for (i = 0; i < nargs; i++) Field(bucket, 1 + i) = args[i];
106 caml_raise(bucket);
107 CAMLnoreturn;
108 }
109
110 void caml_raise_with_string(value tag, char const *msg)
111 {
112 CAMLparam1(tag);
113 value v_msg = caml_copy_string(msg);
114 caml_raise_with_arg(tag, v_msg);
115 CAMLnoreturn;
116 }
117
118 void caml_failwith (char const *msg)
119 {
120 caml_raise_with_string((value) caml_exn_Failure, msg);
121 }
122
123 void caml_failwith_value (value msg)
124 {
125 caml_raise_with_arg((value) caml_exn_Failure, msg);
126 }
127
128 void caml_invalid_argument (char const *msg)
129 {
130 caml_raise_with_string((value) caml_exn_Invalid_argument, msg);
131 }
132
133 void caml_invalid_argument_value (value msg)
134 {
135 caml_raise_with_arg((value) caml_exn_Invalid_argument, msg);
136 }
137
138 void caml_raise_out_of_memory(void)
139 {
140 caml_raise_constant((value) caml_exn_Out_of_memory);
141 }
142
143 /* Used by the stack overflow handler -> deactivate ASAN (see
144 segv_handler in signals_nat.c). */
145 CAMLno_asan
146 void caml_raise_stack_overflow(void)
147 {
148 caml_raise_constant((value) caml_exn_Stack_overflow);
149 }
150
151 void caml_raise_sys_error(value msg)
152 {
153 caml_raise_with_arg((value) caml_exn_Sys_error, msg);
154 }
155
156 void caml_raise_end_of_file(void)
157 {
158 caml_raise_constant((value) caml_exn_End_of_file);
159 }
160
161 void caml_raise_zero_divide(void)
162 {
163 caml_raise_constant((value) caml_exn_Division_by_zero);
164 }
165
166 void caml_raise_not_found(void)
167 {
168 caml_raise_constant((value) caml_exn_Not_found);
169 }
170
171 void caml_raise_sys_blocked_io(void)
172 {
173 caml_raise_constant((value) caml_exn_Sys_blocked_io);
174 }
175
176 value caml_raise_if_exception(value res)
177 {
178 if (Is_exception_result(res)) caml_raise(Extract_exception(res));
179 return res;
180 }
181
182 /* We use a pre-allocated exception because we can't
183 do a GC before the exception is raised (lack of stack descriptors
184 for the ccall to [caml_array_bound_error]). */
185
186 static const value * caml_array_bound_error_exn = NULL;
187
188 void caml_array_bound_error(void)
189 {
190 if (caml_array_bound_error_exn == NULL) {
191 caml_array_bound_error_exn =
192 caml_named_value("Pervasives.array_bound_error");
193 if (caml_array_bound_error_exn == NULL) {
194 fprintf(stderr, "Fatal error: exception "
195 "Invalid_argument(\"index out of bounds\")\n");
196 exit(2);
197 }
198 }
199 caml_raise(*caml_array_bound_error_exn);
200 }
201
202 int caml_is_special_exception(value exn) {
203 return exn == (value) caml_exn_Match_failure
204 || exn == (value) caml_exn_Assert_failure
205 || exn == (value) caml_exn_Undefined_recursive_module;
206 }
207