Temporarily Catching Error Escapes

When implementing new primitive procedure, it is sometimes useful to catch and handle errors that occur in evaluating subexpressions. One way to do this is the following: first copy scheme_error_buf to a temporary variable, invoke scheme_setjmp(scheme_error_buf), perform the function's work, and then restore scheme_error_buf before returning a value.

However, beware that the invocation of an escaping continuation looks like a primitive error escape, but the special indicator flag scheme_jumping_to_continuation is non-zero (instead of its normal zero value); this situation is only visible when implementing a new primitive procedure. Honor the escape request by chaining to the previously saved error buffer; otherwise, call scheme_clear_escape.

  mz_jmp_buf save;
  memcpy(&save, &scheme_error_buf, sizeof(mz_jmp_buf));
  if (scheme_setjmp(scheme_error_buf)) {
    /* There was an error or continuation invokcation */
    if (scheme_jumping_to_continuation) {
      /* It was a continuation jump */
      scheme_longjmp(save, 1);
      /* To block the jump, instead: scheme_clear_escape(); */
    } else {
      /* It was a primitive error escape */
    }
  } else {
    scheme_eval_string("x", scheme_env);
  }
  memcpy(&scheme_error_buf, &save, sizeof(mz_jmp_buf));

This solution works fine as long as the procedure implementation only calls top-level evaluation functions (scheme_eval, scheme_eval, etc., as opposed to _scheme_eval, _scheme_apply, etc.). Otherwise, use scheme_dynamic_wind to protect your code against full continuation jumps in the same way that dynamic-wind is used in Scheme.

The above solution simply traps the escape; it doesn't report the reason that the escape occurred. To catch exceptions and obtain information about the exception, the simplest route is to mix Scheme code with C-implemented thunks. The code below can be used to catch exceptions in a variety of situations. It implements the function _apply_catch_exceptions, which catches exceptions during the application of a thunk. (This code is in plt/src/mzscheme/dynsrc/oe.c in the source code distribution.)

static Scheme_Object *exn_catching_apply, *exn_p, *exn_message;

static void init_exn_catching_apply()
{
  if (!exn_catching_apply) {
    char *e = 
      "(#%lambda (thunk) "
        "(#%with-handlers ([#%void (#%lambda (exn) (#%cons #f exn))]) "
          "(#%cons #t (thunk))))";
    /* make sure we have a namespace with the standard syntax: */
    Scheme_Env *env = (Scheme_Env *)scheme_make_namespace(0, NULL);

#if !SCHEME_DIRECT_EMBEDDED
    scheme_register_extension_global(&exn_catching_apply, sizeof(Scheme_Object *));
    scheme_register_extension_global(&exn_p, sizeof(Scheme_Object *));
    scheme_register_extension_global(&exn_message, sizeof(Scheme_Object *));
#endif
    
    exn_catching_apply = scheme_eval_string(e, env);
    exn_p = scheme_lookup_global(scheme_intern_symbol("exn?"), env);
    exn_message = scheme_lookup_global(scheme_intern_symbol("exn-message"), env);
  }
}

/* This function applies a thunk, returning the Scheme value if there's no exception, 
   otherwise returning NULL and setting *exn to the raised value (usually an exn 
   structure). */
Scheme_Object *_apply_thunk_catch_exceptions(Scheme_Object *f, Scheme_Object **exn)
{
  Scheme_Object *v;

  init_exn_catching_apply();
  
  v = _scheme_apply(exn_catching_apply, 1, &f);
  /* v is a pair: (cons #t value) or (cons #f exn) */

  if (SCHEME_TRUEP(SCHEME_CAR(v)))
    return SCHEME_CDR(v);
  else {
    *exn = SCHEME_CDR(v);
    return NULL;
  }
}

Scheme_Object *extract_exn_message(Scheme_Object *v)
{
  init_exn_catching_apply();

  if (SCHEME_TRUEP(_scheme_apply(exn_p, 1, &v)))
    return _scheme_apply(exn_message, 1, &v);
  else
    return NULL; /* Not an exn structure */
}

In the following example, the above code is used to catch exceptions that occur during while evaluating source code from a string.

static Scheme_Object *do_eval(void *s, int noargc, Scheme_Object **noargv)
{
  return scheme_eval_string((char *)s, scheme_get_env(scheme_config));
}

static Scheme_Object *eval_string_or_get_exn_message(char *s)
{
  Scheme_Object *v, *exn;

  v = _apply_thunk_catch_exceptions(scheme_make_closed_prim(do_eval, s), &exn);
  /* Got a value? */
  if (v)
    return v;

  v = extract_exn_message(exn);
  /* Got an exn? */
  if (v)
    return v;

  /* `raise' was called on some arbitrary value */
  return exn;
}