1 /*
2 Racket extension example that catches exceptions and extracts
3 error messages.
4
5 The defined function is `eval-string/catch-error', which takes a
6 string and evaluates it, returning either the value, a string for
7 the error message, and a non-exn value raised by the expression.
8
9 > (eval-string/catch-error "10")
10 10
11
12 > (eval-string/catch-error "(+ 'a)")
13 "+: expects argument of type <number>; given a"
14
15 > (eval-string/catch-error "(raise 'ack)")
16 ack
17
18 */
19
20 #include "escheme.h"
21
22 /*********************************************************************/
23 /* Exception-catching code */
24 /*********************************************************************/
25
26 /* These must be registered with the memory manager: */
27 static Scheme_Object *exn_catching_apply, *exn_p, *exn_message;
28
init_exn_catching_apply()29 static void init_exn_catching_apply()
30 {
31 if (!exn_catching_apply) {
32 Scheme_Env *env;
33 char *e =
34 "(lambda (thunk) "
35 "(with-handlers ([void (lambda (exn) (cons #f exn))]) "
36 "(cons #t (thunk))))";
37
38 /* make sure we have a namespace with the standard bindings: */
39 env = (Scheme_Env *)scheme_make_namespace(0, NULL);
40
41 scheme_register_extension_global(&exn_catching_apply, sizeof(Scheme_Object *));
42 scheme_register_extension_global(&exn_p, sizeof(Scheme_Object *));
43 scheme_register_extension_global(&exn_message, sizeof(Scheme_Object *));
44
45 exn_catching_apply = scheme_eval_string(e, env);
46 exn_p = scheme_lookup_global(scheme_intern_symbol("exn?"), env);
47 exn_message = scheme_lookup_global(scheme_intern_symbol("exn-message"), env);
48 }
49 }
50
51 /* This function applies a thunk, returning the Scheme value if there's no exception,
52 otherwise returning NULL and setting *exn to the raised value (usually an exn
53 structure). */
_apply_thunk_catch_exceptions(Scheme_Object * f,Scheme_Object ** exn)54 Scheme_Object *_apply_thunk_catch_exceptions(Scheme_Object *f, Scheme_Object **exn)
55 {
56 Scheme_Object *v;
57
58 init_exn_catching_apply();
59
60 v = _scheme_apply(exn_catching_apply, 1, &f);
61 /* v is a pair: (cons #t value) or (cons #f exn) */
62
63 if (SCHEME_TRUEP(SCHEME_CAR(v)))
64 return SCHEME_CDR(v);
65 else {
66 *exn = SCHEME_CDR(v);
67 return NULL;
68 }
69 }
70
extract_exn_message(Scheme_Object * v)71 Scheme_Object *extract_exn_message(Scheme_Object *v)
72 {
73 init_exn_catching_apply();
74
75 if (SCHEME_TRUEP(_scheme_apply(exn_p, 1, &v)))
76 return _scheme_apply(exn_message, 1, &v);
77 else
78 return NULL; /* Not an exn structure */
79 }
80
81 /*********************************************************************/
82 /* Use of example exception-catching code */
83 /*********************************************************************/
84
do_eval(void * s,int noargc,Scheme_Object ** noargv)85 static Scheme_Object *do_eval(void *s, int noargc, Scheme_Object **noargv)
86 {
87 return scheme_eval_string((char *)s, scheme_get_env(NULL));
88 }
89
eval_string_or_get_exn_message(char * s)90 static Scheme_Object *eval_string_or_get_exn_message(char *s)
91 {
92 Scheme_Object *v, *exn;
93
94 v = _apply_thunk_catch_exceptions(scheme_make_closed_prim(do_eval, s), &exn);
95 /* Got a value? */
96 if (v)
97 return v;
98
99 v = extract_exn_message(exn);
100 /* Got an exn? */
101 if (v)
102 return v;
103
104 /* `raise' was called on some arbitrary value */
105 return exn;
106 }
107
catch_eval_error(int argc,Scheme_Object ** argv)108 static Scheme_Object *catch_eval_error(int argc, Scheme_Object **argv)
109 {
110 Scheme_Object *bs;
111
112 if (!SCHEME_CHAR_STRINGP(argv[0]))
113 scheme_wrong_type("eval-string/catch-error", "string", 0, argc, argv);
114
115 bs = scheme_char_string_to_byte_string(argv[0]);
116
117 return eval_string_or_get_exn_message(SCHEME_BYTE_STR_VAL(bs));
118 }
119
120 /*********************************************************************/
121 /* Initialization */
122 /*********************************************************************/
123
scheme_reload(Scheme_Env * env)124 Scheme_Object *scheme_reload(Scheme_Env *env)
125 {
126 scheme_add_global("eval-string/catch-error",
127 scheme_make_prim_w_arity(catch_eval_error,
128 "eval-string/catch-error",
129 1, 1),
130 env);
131
132 return scheme_void;
133 }
134
scheme_initialize(Scheme_Env * env)135 Scheme_Object *scheme_initialize(Scheme_Env *env)
136 {
137 /* First load is same as every load: */
138 return scheme_reload(env);
139 }
140
scheme_module_name()141 Scheme_Object *scheme_module_name()
142 {
143 /* This extension doesn't define a module: */
144 return scheme_false;
145 }
146