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/fail.h"
24 #include "caml/io.h"
25 #include "caml/gc.h"
26 #include "caml/memory.h"
27 #include "caml/mlvalues.h"
28 #include "caml/printexc.h"
29 #include "caml/signals.h"
30 #include "caml/stack.h"
31 #include "caml/roots.h"
32 #include "caml/callback.h"
33
34 /* The globals holding predefined exceptions */
35
36 typedef value caml_generated_constant[1];
37
38 extern caml_generated_constant
39 caml_exn_Out_of_memory,
40 caml_exn_Sys_error,
41 caml_exn_Failure,
42 caml_exn_Invalid_argument,
43 caml_exn_End_of_file,
44 caml_exn_Division_by_zero,
45 caml_exn_Not_found,
46 caml_exn_Match_failure,
47 caml_exn_Sys_blocked_io,
48 caml_exn_Stack_overflow,
49 caml_exn_Assert_failure,
50 caml_exn_Undefined_recursive_module;
51
52 /* Exception raising */
53
54 CAMLnoreturn_start
55 extern void caml_raise_exception (value bucket)
56 CAMLnoreturn_end;
57
58 char * caml_exception_pointer = NULL;
59
caml_raise(value v)60 void caml_raise(value v)
61 {
62 Unlock_exn();
63 if (caml_exception_pointer == NULL) caml_fatal_uncaught_exception(v);
64
65 #ifndef Stack_grows_upwards
66 #define PUSHED_AFTER <
67 #else
68 #define PUSHED_AFTER >
69 #endif
70 while (caml_local_roots != NULL &&
71 (char *) caml_local_roots PUSHED_AFTER caml_exception_pointer) {
72 caml_local_roots = caml_local_roots->next;
73 }
74 #undef PUSHED_AFTER
75
76 caml_raise_exception(v);
77 }
78
caml_raise_constant(value tag)79 void caml_raise_constant(value tag)
80 {
81 caml_raise(tag);
82 }
83
caml_raise_with_arg(value tag,value arg)84 void caml_raise_with_arg(value tag, value arg)
85 {
86 CAMLparam2 (tag, arg);
87 CAMLlocal1 (bucket);
88
89 bucket = caml_alloc_small (2, 0);
90 Field(bucket, 0) = tag;
91 Field(bucket, 1) = arg;
92 caml_raise(bucket);
93 CAMLnoreturn;
94 }
95
caml_raise_with_args(value tag,int nargs,value args[])96 void caml_raise_with_args(value tag, int nargs, value args[])
97 {
98 CAMLparam1 (tag);
99 CAMLxparamN (args, nargs);
100 value bucket;
101 int i;
102
103 Assert(1 + nargs <= Max_young_wosize);
104 bucket = caml_alloc_small (1 + nargs, 0);
105 Field(bucket, 0) = tag;
106 for (i = 0; i < nargs; i++) Field(bucket, 1 + i) = args[i];
107 caml_raise(bucket);
108 CAMLnoreturn;
109 }
110
caml_raise_with_string(value tag,char const * msg)111 void caml_raise_with_string(value tag, char const *msg)
112 {
113 CAMLparam1(tag);
114 value v_msg = caml_copy_string(msg);
115 caml_raise_with_arg(tag, v_msg);
116 CAMLnoreturn;
117 }
118
caml_failwith(char const * msg)119 void caml_failwith (char const *msg)
120 {
121 caml_raise_with_string((value) caml_exn_Failure, msg);
122 }
123
caml_failwith_value(value msg)124 void caml_failwith_value (value msg)
125 {
126 caml_raise_with_arg((value) caml_exn_Failure, msg);
127 }
128
caml_invalid_argument(char const * msg)129 void caml_invalid_argument (char const *msg)
130 {
131 caml_raise_with_string((value) caml_exn_Invalid_argument, msg);
132 }
133
caml_invalid_argument_value(value msg)134 void caml_invalid_argument_value (value msg)
135 {
136 caml_raise_with_arg((value) caml_exn_Invalid_argument, msg);
137 }
138
caml_raise_out_of_memory(void)139 void caml_raise_out_of_memory(void)
140 {
141 caml_raise_constant((value) caml_exn_Out_of_memory);
142 }
143
caml_raise_stack_overflow(void)144 void caml_raise_stack_overflow(void)
145 {
146 caml_raise_constant((value) caml_exn_Stack_overflow);
147 }
148
caml_raise_sys_error(value msg)149 void caml_raise_sys_error(value msg)
150 {
151 caml_raise_with_arg((value) caml_exn_Sys_error, msg);
152 }
153
caml_raise_end_of_file(void)154 void caml_raise_end_of_file(void)
155 {
156 caml_raise_constant((value) caml_exn_End_of_file);
157 }
158
caml_raise_zero_divide(void)159 void caml_raise_zero_divide(void)
160 {
161 caml_raise_constant((value) caml_exn_Division_by_zero);
162 }
163
caml_raise_not_found(void)164 void caml_raise_not_found(void)
165 {
166 caml_raise_constant((value) caml_exn_Not_found);
167 }
168
caml_raise_sys_blocked_io(void)169 void caml_raise_sys_blocked_io(void)
170 {
171 caml_raise_constant((value) caml_exn_Sys_blocked_io);
172 }
173
174 /* We use a pre-allocated exception because we can't
175 do a GC before the exception is raised (lack of stack descriptors
176 for the ccall to [caml_array_bound_error]). */
177
178 static value * caml_array_bound_error_exn = NULL;
179
caml_array_bound_error(void)180 void caml_array_bound_error(void)
181 {
182 if (caml_array_bound_error_exn == NULL) {
183 caml_array_bound_error_exn =
184 caml_named_value("Pervasives.array_bound_error");
185 if (caml_array_bound_error_exn == NULL) {
186 fprintf(stderr, "Fatal error: exception "
187 "Invalid_argument(\"index out of bounds\")\n");
188 exit(2);
189 }
190 }
191 caml_raise(*caml_array_bound_error_exn);
192 }
193
caml_is_special_exception(value exn)194 int caml_is_special_exception(value exn) {
195 return exn == (value) caml_exn_Match_failure
196 || exn == (value) caml_exn_Assert_failure
197 || exn == (value) caml_exn_Undefined_recursive_module;
198 }
199