Back to index

plt-scheme  4.2.1
catch.c
Go to the documentation of this file.
00001 /* 
00002    MzScheme extension example that catches exceptions and extracts
00003    error messages.
00004 
00005    The defined function is `eval-string/catch-error', which takes a
00006    string and evaluates it, returning either the value, a string for
00007    the error message, and a non-exn value raised by the expression.
00008 
00009   > (eval-string/catch-error "10")
00010   10
00011 
00012   > (eval-string/catch-error "(+ 'a)")
00013   "+: expects argument of type <number>; given a"
00014 
00015   > (eval-string/catch-error "(raise 'ack)")
00016   ack
00017 
00018 */
00019 
00020 #include "escheme.h"
00021 
00022 /*********************************************************************/
00023 /* Exception-catching code                                           */
00024 /*********************************************************************/
00025 
00026 /* These must be registered with the memory manager: */
00027 static Scheme_Object *exn_catching_apply, *exn_p, *exn_message;
00028 
00029 static void init_exn_catching_apply()
00030 {
00031   if (!exn_catching_apply) {
00032     Scheme_Env *env;
00033     char *e = 
00034       "(lambda (thunk) "
00035        "(with-handlers ([void (lambda (exn) (cons #f exn))]) "
00036          "(cons #t (thunk))))";
00037 
00038     /* make sure we have a namespace with the standard bindings: */
00039     env = (Scheme_Env *)scheme_make_namespace(0, NULL);
00040 
00041     scheme_register_extension_global(&exn_catching_apply, sizeof(Scheme_Object *));
00042     scheme_register_extension_global(&exn_p, sizeof(Scheme_Object *));
00043     scheme_register_extension_global(&exn_message, sizeof(Scheme_Object *));
00044     
00045     exn_catching_apply = scheme_eval_string(e, env);
00046     exn_p = scheme_lookup_global(scheme_intern_symbol("exn?"), env);
00047     exn_message = scheme_lookup_global(scheme_intern_symbol("exn-message"), env);
00048   }
00049 }
00050 
00051 /* This function applies a thunk, returning the Scheme value if there's no exception, 
00052    otherwise returning NULL and setting *exn to the raised value (usually an exn 
00053    structure). */
00054 Scheme_Object *_apply_thunk_catch_exceptions(Scheme_Object *f, Scheme_Object **exn)
00055 {
00056   Scheme_Object *v;
00057 
00058   init_exn_catching_apply();
00059   
00060   v = _scheme_apply(exn_catching_apply, 1, &f);
00061   /* v is a pair: (cons #t value) or (cons #f exn) */
00062 
00063   if (SCHEME_TRUEP(SCHEME_CAR(v)))
00064     return SCHEME_CDR(v);
00065   else {
00066     *exn = SCHEME_CDR(v);
00067     return NULL;
00068   }
00069 }
00070 
00071 Scheme_Object *extract_exn_message(Scheme_Object *v)
00072 {
00073   init_exn_catching_apply();
00074 
00075   if (SCHEME_TRUEP(_scheme_apply(exn_p, 1, &v)))
00076     return _scheme_apply(exn_message, 1, &v);
00077   else
00078     return NULL; /* Not an exn structure */
00079 }
00080 
00081 /*********************************************************************/
00082 /* Use of example exception-catching code                            */
00083 /*********************************************************************/
00084 
00085 static Scheme_Object *do_eval(void *s, int noargc, Scheme_Object **noargv)
00086 {
00087   return scheme_eval_string((char *)s, scheme_get_env(NULL));
00088 }
00089 
00090 static Scheme_Object *eval_string_or_get_exn_message(char *s)
00091 {
00092   Scheme_Object *v, *exn;
00093 
00094   v = _apply_thunk_catch_exceptions(scheme_make_closed_prim(do_eval, s), &exn);
00095   /* Got a value? */
00096   if (v)
00097     return v;
00098 
00099   v = extract_exn_message(exn);
00100   /* Got an exn? */
00101   if (v)
00102     return v;
00103 
00104   /* `raise' was called on some arbitrary value */
00105   return exn;
00106 }
00107 
00108 static Scheme_Object *catch_eval_error(int argc, Scheme_Object **argv)
00109 {
00110   Scheme_Object *bs;
00111 
00112   if (!SCHEME_CHAR_STRINGP(argv[0]))
00113     scheme_wrong_type("eval-string/catch-error", "string", 0, argc, argv);
00114 
00115   bs = scheme_char_string_to_byte_string(argv[0]);
00116   
00117   return eval_string_or_get_exn_message(SCHEME_BYTE_STR_VAL(bs));
00118 }
00119 
00120 /*********************************************************************/
00121 /* Initialization                                                    */
00122 /*********************************************************************/
00123 
00124 Scheme_Object *scheme_reload(Scheme_Env *env)
00125 {
00126   scheme_add_global("eval-string/catch-error",
00127                   scheme_make_prim_w_arity(catch_eval_error,
00128                                         "eval-string/catch-error", 
00129                                         1, 1),
00130                   env);
00131 
00132   return scheme_void;
00133 }
00134 
00135 Scheme_Object *scheme_initialize(Scheme_Env *env)
00136 {
00137   /* First load is same as every load: */
00138   return scheme_reload(env);
00139 }
00140 
00141 Scheme_Object *scheme_module_name()
00142 {
00143   /* This extension doesn't define a module: */
00144   return scheme_false;
00145 }