exceptions.c 13 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521
  1. /* Copyright 1995-1998,2000-2001,2003-2004,2006,2008,2009-2014,2017-2019
  2. Free Software Foundation, Inc.
  3. This file is part of Guile.
  4. Guile is free software: you can redistribute it and/or modify it
  5. under the terms of the GNU Lesser General Public License as published
  6. by the Free Software Foundation, either version 3 of the License, or
  7. (at your option) any later version.
  8. Guile is distributed in the hope that it will be useful, but WITHOUT
  9. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  10. FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
  11. License for more details.
  12. You should have received a copy of the GNU Lesser General Public
  13. License along with Guile. If not, see
  14. <https://www.gnu.org/licenses/>. */
  15. #ifdef HAVE_CONFIG_H
  16. # include <config.h>
  17. #endif
  18. #include <alloca.h>
  19. #include <stdio.h>
  20. #include <unistdio.h>
  21. #include "boolean.h"
  22. #include "control.h"
  23. #include "eq.h"
  24. #include "eval.h"
  25. #include "fluids.h"
  26. #include "gsubr.h"
  27. #include "init.h"
  28. #include "keywords.h"
  29. #include "list.h"
  30. #include "modules.h"
  31. #include "numbers.h"
  32. #include "pairs.h"
  33. #include "ports.h"
  34. #include "smob.h"
  35. #include "stackchk.h"
  36. #include "stacks.h"
  37. #include "strings.h"
  38. #include "symbols.h"
  39. #include "variable.h"
  40. #include "exceptions.h"
  41. /* Pleasantly enough, the guts of exception handling are defined in
  42. Scheme, in terms of prompt, abort, and the %exception-handler fluid.
  43. Check boot-9 for the definitions.
  44. Still, it's useful to be able to raise unwind-only exceptions from C,
  45. for example so that we can recover from stack overflow. We also need
  46. to have implementations of with-exception-handler and raise handy
  47. before boot time. For that reason we have a parallel implementation
  48. of with-exception-handler that uses the same fluids here. Exceptions
  49. raised from C still call out to Scheme though, so that pre-unwind
  50. handlers can be run. */
  51. /* First, some support for C bodies and exception handlers. */
  52. static scm_t_bits tc16_thunk;
  53. static scm_t_bits tc16_exception_handler;
  54. SCM
  55. scm_c_make_thunk (scm_t_thunk thunk, void *data)
  56. {
  57. SCM_RETURN_NEWSMOB2 (tc16_thunk, thunk, data);
  58. }
  59. SCM
  60. scm_c_make_exception_handler (scm_t_exception_handler handler, void *data)
  61. {
  62. SCM_RETURN_NEWSMOB2 (tc16_exception_handler, handler, data);
  63. }
  64. static SCM
  65. call_thunk (SCM clo)
  66. {
  67. scm_t_thunk thunk = (void*)SCM_SMOB_DATA (clo);
  68. void *data = (void*)SCM_SMOB_DATA_2 (clo);
  69. return thunk (data);
  70. }
  71. static SCM
  72. call_exception_handler (SCM clo, SCM exn)
  73. {
  74. scm_t_exception_handler handler = (void*)SCM_SMOB_DATA (clo);
  75. void *data = (void*)SCM_SMOB_DATA_2 (clo);
  76. return handler (data, exn);
  77. }
  78. /* Now, the implementation of with-exception-handler used internally to
  79. Guile at boot-time. */
  80. SCM_KEYWORD (kw_unwind_p, "unwind?");
  81. SCM_KEYWORD (kw_unwind_for_type, "unwind-for-type");
  82. static SCM exception_handler_fluid;
  83. static SCM active_exception_handlers_fluid;
  84. static SCM with_exception_handler_var;
  85. static SCM raise_exception_var;
  86. SCM
  87. scm_c_with_exception_handler (SCM type, scm_t_exception_handler handler,
  88. void *handler_data,
  89. scm_t_thunk thunk, void *thunk_data)
  90. {
  91. if (!scm_is_eq (type, SCM_BOOL_T) && !scm_is_symbol (type))
  92. scm_wrong_type_arg ("%with-exception-handler", 1, type);
  93. SCM prompt_tag = scm_cons (SCM_INUM0, SCM_EOL);
  94. scm_thread *t = SCM_I_CURRENT_THREAD;
  95. scm_t_dynstack *dynstack = &t->dynstack;
  96. scm_t_dynamic_state *dynamic_state = t->dynamic_state;
  97. jmp_buf registers;
  98. jmp_buf *prev_registers;
  99. ptrdiff_t saved_stack_depth;
  100. uint8_t *mra = NULL;
  101. prev_registers = t->vm.registers;
  102. saved_stack_depth = t->vm.stack_top - t->vm.sp;
  103. /* Push the prompt and exception handler onto the dynamic stack. */
  104. scm_dynstack_push_prompt (dynstack,
  105. SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
  106. prompt_tag,
  107. t->vm.stack_top - t->vm.fp,
  108. saved_stack_depth,
  109. t->vm.ip,
  110. mra,
  111. &registers);
  112. scm_dynstack_push_fluid (dynstack, exception_handler_fluid,
  113. scm_cons (prompt_tag, type),
  114. dynamic_state);
  115. if (setjmp (registers))
  116. {
  117. /* A non-local return. */
  118. SCM args;
  119. t->vm.registers = prev_registers;
  120. scm_gc_after_nonlocal_exit ();
  121. /* FIXME: We know where the args will be on the stack; we could
  122. avoid consing them. */
  123. args = scm_i_prompt_pop_abort_args_x (&t->vm, saved_stack_depth);
  124. /* The first abort arg is the continuation, which is #f. The
  125. second and final arg is the exception. */
  126. args = scm_cdr (args);
  127. SCM exn = scm_car (args);
  128. if (!scm_is_null (scm_cdr (args)))
  129. abort ();
  130. return handler (handler_data, exn);
  131. }
  132. SCM res = thunk (thunk_data);
  133. scm_dynstack_unwind_fluid (dynstack, dynamic_state);
  134. scm_dynstack_pop (dynstack);
  135. return res;
  136. }
  137. SCM
  138. scm_with_exception_handler (SCM type, SCM handler, SCM thunk)
  139. {
  140. return scm_call_6 (scm_variable_ref (with_exception_handler_var),
  141. handler, thunk, kw_unwind_p, SCM_BOOL_T,
  142. kw_unwind_for_type, type);
  143. }
  144. SCM
  145. scm_with_pre_unwind_exception_handler (SCM handler, SCM thunk)
  146. {
  147. return scm_call_2 (scm_variable_ref (with_exception_handler_var),
  148. handler, thunk);
  149. }
  150. SCM_SYMBOL (sys_exception_sym, "%exception");
  151. /* Note that these record types are marked as non-extensible, so their
  152. type predicate is a simple vtable comparison. */
  153. static SCM compound_exception;
  154. static SCM exception_with_kind_and_args;
  155. static SCM quit_exception;
  156. static SCM
  157. extract_exception (SCM obj, SCM non_extensible_vtable)
  158. {
  159. if (!SCM_STRUCTP (obj)) {
  160. return SCM_BOOL_F;
  161. }
  162. if (scm_is_eq (SCM_STRUCT_VTABLE (obj), non_extensible_vtable)) {
  163. return obj;
  164. }
  165. if (!scm_is_eq (SCM_STRUCT_VTABLE (obj), compound_exception)) {
  166. return SCM_BOOL_F;
  167. }
  168. SCM exns = SCM_STRUCT_SLOT_REF (obj, 0);
  169. while (!scm_is_null (exns)) {
  170. SCM exn = scm_car (exns);
  171. if (scm_is_eq (SCM_STRUCT_VTABLE (exn), non_extensible_vtable)) {
  172. return exn;
  173. }
  174. exns = scm_cdr (exns);
  175. }
  176. return SCM_BOOL_F;
  177. }
  178. SCM
  179. scm_exception_kind (SCM obj)
  180. {
  181. SCM exn = extract_exception (obj, exception_with_kind_and_args);
  182. if (scm_is_false (exn)) {
  183. return sys_exception_sym;
  184. }
  185. return SCM_STRUCT_SLOT_REF (exn, 0);
  186. }
  187. SCM
  188. scm_exception_args (SCM obj)
  189. {
  190. SCM exn = extract_exception (obj, exception_with_kind_and_args);
  191. if (scm_is_false (exn)) {
  192. return scm_list_1 (obj);
  193. }
  194. return SCM_STRUCT_SLOT_REF (exn, 1);
  195. }
  196. static int
  197. exception_has_type (SCM exn, SCM type)
  198. {
  199. return scm_is_eq (type, SCM_BOOL_T) ||
  200. scm_is_eq (type, scm_exception_kind (exn));
  201. }
  202. void
  203. scm_dynwind_throw_handler (void)
  204. {
  205. scm_dynwind_fluid (active_exception_handlers_fluid, SCM_BOOL_F);
  206. }
  207. /* Default exception handlers. */
  208. /* Derive the an exit status from the arguments to (quit ...). */
  209. int
  210. scm_exit_status (SCM args)
  211. {
  212. if (scm_is_pair (args))
  213. {
  214. SCM cqa = SCM_CAR (args);
  215. if (scm_is_integer (cqa))
  216. return scm_to_int (cqa);
  217. else if (scm_is_false (cqa))
  218. return EXIT_FAILURE;
  219. else
  220. return EXIT_SUCCESS;
  221. }
  222. else if (scm_is_null (args))
  223. return EXIT_SUCCESS;
  224. else
  225. /* A type error. Strictly speaking we shouldn't get here. */
  226. return EXIT_FAILURE;
  227. }
  228. static SCM
  229. get_quit_exception (SCM obj)
  230. {
  231. return extract_exception (obj, quit_exception);
  232. }
  233. static int
  234. quit_exception_code (SCM exn)
  235. {
  236. return scm_to_int (SCM_STRUCT_SLOT_REF (exn, 0));
  237. }
  238. static void
  239. scm_display_exception (SCM port, SCM exn)
  240. {
  241. // FIXME: Make a good exception printer.
  242. scm_puts ("key: ", port);
  243. scm_write (scm_exception_kind (exn), port);
  244. scm_puts (", args: ", port);
  245. scm_write (scm_exception_args (exn), port);
  246. scm_newline (port);
  247. }
  248. static void
  249. default_exception_handler (SCM exn)
  250. {
  251. static int error_printing_error = 0;
  252. static int error_printing_fallback = 0;
  253. if (error_printing_fallback)
  254. fprintf (stderr, "\nFailed to print exception.\n");
  255. else if (error_printing_error)
  256. {
  257. fprintf (stderr, "\nError while printing exception:\n");
  258. error_printing_fallback = 1;
  259. scm_write (exn, scm_current_error_port ());
  260. scm_newline (scm_current_error_port ());
  261. }
  262. else if (scm_is_true (get_quit_exception (exn)))
  263. {
  264. exit (quit_exception_code (get_quit_exception (exn)));
  265. }
  266. else
  267. {
  268. SCM port = scm_current_error_port ();
  269. error_printing_error = 1;
  270. scm_puts ("Uncaught exception:\n", port);
  271. scm_display_exception (port, exn);
  272. scm_i_pthread_exit (NULL);
  273. }
  274. /* We fall through here for the error-printing-error cases. */
  275. fprintf (stderr, "Aborting.\n");
  276. abort ();
  277. }
  278. static SCM
  279. default_exception_handler_wrapper (void *data, SCM exn)
  280. {
  281. default_exception_handler (exn);
  282. return SCM_UNDEFINED;
  283. }
  284. SCM
  285. scm_c_with_default_exception_handler (scm_t_thunk thunk, void *data)
  286. {
  287. return scm_c_with_exception_handler (SCM_BOOL_T,
  288. default_exception_handler_wrapper, NULL,
  289. thunk, data);
  290. }
  291. /* An implementation of "raise" for use during boot and in
  292. resource-exhaustion situations. */
  293. static void
  294. emergency_raise (SCM exn, const char *reason)
  295. {
  296. size_t depth = 0;
  297. /* This function is not only the boot implementation of "raise", it is
  298. also called in response to resource allocation failures such as
  299. stack-overflow or out-of-memory. For that reason we need to be
  300. careful to avoid allocating memory. */
  301. while (1)
  302. {
  303. SCM eh = scm_fluid_ref_star (exception_handler_fluid,
  304. scm_from_size_t (depth++));
  305. if (scm_is_false (eh)) {
  306. default_exception_handler (exn);
  307. abort ();
  308. }
  309. if (!scm_is_pair (eh)) {
  310. fprintf (stderr, "Warning: Unwind-only %s exception; "
  311. "skipping pre-unwind handler.\n", reason);
  312. } else {
  313. SCM prompt_tag = scm_car (eh);
  314. SCM type = scm_cdr (eh);
  315. if (exception_has_type (exn, type)) {
  316. SCM tag_and_exn[] = { prompt_tag, exn };
  317. scm_i_vm_emergency_abort (tag_and_exn, 2);
  318. /* Unreachable. */
  319. abort ();
  320. }
  321. }
  322. }
  323. }
  324. static SCM
  325. pre_boot_raise (SCM exn)
  326. {
  327. emergency_raise (exn, "pre-boot");
  328. return SCM_UNDEFINED;
  329. }
  330. SCM
  331. scm_raise_exception (SCM exn)
  332. {
  333. scm_call_1 (scm_variable_ref (raise_exception_var), exn);
  334. /* Should not be reached. */
  335. abort ();
  336. }
  337. SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");
  338. SCM_SYMBOL (scm_out_of_memory_key, "out-of-memory");
  339. static SCM stack_overflow_exn = SCM_BOOL_F;
  340. static SCM out_of_memory_exn = SCM_BOOL_F;
  341. /* Since these two functions may be called in response to resource
  342. exhaustion, we have to avoid allocating memory. */
  343. void
  344. scm_report_stack_overflow (void)
  345. {
  346. if (scm_is_false (stack_overflow_exn))
  347. abort ();
  348. emergency_raise (stack_overflow_exn, "stack overflow");
  349. /* Not reached. */
  350. abort ();
  351. }
  352. void
  353. scm_report_out_of_memory (void)
  354. {
  355. if (scm_is_false (out_of_memory_exn))
  356. abort ();
  357. emergency_raise (out_of_memory_exn, "out of memory");
  358. /* Not reached. */
  359. abort ();
  360. }
  361. static SCM
  362. make_scm_exception (SCM type, SCM subr, SCM message, SCM args, SCM rest)
  363. {
  364. return scm_make_struct_simple
  365. (exception_with_kind_and_args,
  366. scm_list_2 (type,
  367. scm_list_4 (subr, message, args, rest)));
  368. }
  369. static SCM
  370. sys_init_exceptions_x (SCM compound_exception_type,
  371. SCM exception_with_kind_and_args_type,
  372. SCM quit_exception_type)
  373. {
  374. compound_exception = compound_exception_type;
  375. exception_with_kind_and_args = exception_with_kind_and_args_type;
  376. quit_exception = quit_exception_type;
  377. /* Arguments as if from:
  378. scm_error (stack-overflow, NULL, "Stack overflow", #f, #f);
  379. We build the arguments manually to avoid allocating memory in
  380. emergency circumstances. */
  381. stack_overflow_exn = make_scm_exception
  382. (scm_stack_overflow_key, SCM_BOOL_F,
  383. scm_from_latin1_string ("Stack overflow"), SCM_BOOL_F, SCM_BOOL_F);
  384. out_of_memory_exn = make_scm_exception
  385. (scm_out_of_memory_key, SCM_BOOL_F,
  386. scm_from_latin1_string ("Out of memory"), SCM_BOOL_F, SCM_BOOL_F);
  387. return SCM_UNDEFINED;
  388. }
  389. /* Initialization. */
  390. void
  391. scm_init_exceptions ()
  392. {
  393. tc16_thunk = scm_make_smob_type ("thunk", 0);
  394. scm_set_smob_apply (tc16_thunk, call_thunk, 0, 0, 0);
  395. tc16_exception_handler = scm_make_smob_type ("exception-handler", 0);
  396. scm_set_smob_apply (tc16_exception_handler, call_exception_handler, 1, 0, 0);
  397. exception_handler_fluid = scm_make_thread_local_fluid (SCM_BOOL_F);
  398. active_exception_handlers_fluid = scm_make_thread_local_fluid (SCM_BOOL_F);
  399. /* These binding are later removed when the Scheme definitions of
  400. raise and with-exception-handler are created in boot-9.scm. */
  401. scm_c_define ("%exception-handler", exception_handler_fluid);
  402. scm_c_define ("%active-exception-handlers", active_exception_handlers_fluid);
  403. with_exception_handler_var =
  404. scm_c_define ("with-exception-handler", SCM_BOOL_F);
  405. raise_exception_var =
  406. scm_c_define ("raise-exception",
  407. scm_c_make_gsubr ("raise-exception", 1, 0, 0,
  408. (scm_t_subr) pre_boot_raise));
  409. scm_c_define ("%init-exceptions!",
  410. scm_c_make_gsubr ("%init-exceptions!", 3, 0, 0,
  411. (scm_t_subr) sys_init_exceptions_x));
  412. #include "exceptions.x"
  413. }