exceptions don't print by default

eval.c

@@ -337,6 +337,8 @@ static sexp analyze_var_ref (sexp x, sexp context) {
       cell = env_cell_create(sexp_context_env(context), x, SEXP_UNDEF);
     }
   }
+  if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell)))
+    return sexp_compile_error("invalid use of syntax as value", sexp_list1(x));
   return sexp_make_ref(x, cell);
 }
 
@@ -437,8 +439,10 @@ static sexp analyze_define_syntax (sexp x, sexp context) {
     return sexp_compile_error("non-top-level define-syntax", sexp_list1(x));
   proc = eval_in_context(sexp_caddr(x), context);
   analyze_check_exception(proc);
+  if (sexp_procedurep(proc)) {
     cell = env_cell_create(sexp_context_env(context), name, SEXP_VOID);
     sexp_cdr(cell) = sexp_make_macro(proc, sexp_context_env(context));
+  }
   return SEXP_VOID;
 }
 
@@ -447,6 +451,7 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
   for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
     proc = eval_in_context(sexp_cadar(ls), eval_ctx);
     analyze_check_exception(proc);
+    if (sexp_procedurep(proc))
       sexp_push(sexp_env_bindings(sexp_context_env(bind_ctx)),
                 sexp_cons(sexp_caar(ls),
                           sexp_make_macro(proc, sexp_context_env(eval_ctx))));
@@ -497,7 +502,7 @@ static sexp analyze (sexp x, sexp context) {
         case CORE_IF:
           res = analyze_if(x, context); break;
         case CORE_BEGIN:
-          res = analyze_seq(x, context); break;
+          res = analyze_seq(sexp_cdr(x), context); break;
         case CORE_QUOTE:
           res = sexp_make_lit(sexp_cadr(x)); break;
         case CORE_DEFINE_SYNTAX:
@@ -1014,16 +1019,17 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
     break;
   case OP_ERROR:
   call_error_handler:
-    tmp1 = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE);
-    sexp_print_exception(_ARG1, tmp1);
-    self = env_global_ref(env, the_err_handler_symbol, SEXP_FALSE);
     stack[top] = (sexp) 1;
     stack[top+1] = sexp_make_integer(ip+4);
     stack[top+2] = self;
-    top += 3;
+    stack[top+3] = sexp_make_integer(fp);
+    top += 4;
+    self = env_global_ref(env, the_err_handler_symbol, SEXP_FALSE);
     bc = sexp_procedure_code(self);
     ip = sexp_bytecode_data(bc);
     cp = sexp_procedure_vars(self);
+    fp = top-4;
+    /* sexp_print_stack(stack, top, fp, tmp1); */
     break;
   case OP_RESUMECC:
     tmp1 = stack[fp-1];
@@ -1327,6 +1333,8 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
     top--;
     break;
   case OP_DIV:
+    if (_ARG2 == sexp_make_integer(0))
+      sexp_raise("divide by zero", SEXP_NULL);
     if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2))
       _ARG2 = sexp_fp_div(sexp_integer_to_flonum(_ARG1),
                           sexp_integer_to_flonum(_ARG2));
@@ -1343,7 +1351,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
     break;
   case OP_QUOTIENT:
     if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) {
-      if (_ARG1 == sexp_make_integer(0))
+      if (_ARG2 == sexp_make_integer(0))
         sexp_raise("divide by zero", SEXP_NULL);
       _ARG2 = sexp_fx_div(_ARG1, _ARG2);
       top--;
@@ -1352,7 +1360,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) {
     break;
   case OP_REMAINDER:
     if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) {
-      if (_ARG1 == sexp_make_integer(0))
+      if (_ARG2 == sexp_make_integer(0))
         sexp_raise("divide by zero", SEXP_NULL);
       tmp1 = sexp_fx_rem(_ARG1, _ARG2);
       top--;
@@ -1559,9 +1567,14 @@ static void sexp_warn_undefs (sexp from, sexp to, sexp out) {
 
 sexp sexp_load (sexp source, sexp env) {
   sexp x, res, in, tmp, out, context = sexp_make_context(NULL, env);
+  out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE);
   tmp = sexp_env_bindings(env);
   sexp_context_tailp(context) = 0;
   in = sexp_open_input_file(source);
+  if (sexp_exceptionp(in)) {
+    sexp_print_exception(in, out);
+    return in;
+  }
   while ((x=sexp_read(in)) != (sexp) SEXP_EOF) {
     res = eval_in_context(x, context);
     if (sexp_exceptionp(res))
@@ -1571,7 +1584,6 @@ sexp sexp_load (sexp source, sexp env) {
     res = SEXP_VOID;
   sexp_close_port(in);
 #ifdef USE_WARN_UNDEFS
-  out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE);
   if (sexp_oportp(out))
     sexp_warn_undefs(sexp_env_bindings(env), tmp, out);
 #endif
@@ -1770,7 +1782,7 @@ sexp eval_in_context (sexp obj, sexp context) {
     sexp_print_exception(thunk, env_global_ref(sexp_context_env(context),
                                                the_cur_err_symbol,
                                                SEXP_FALSE));
-    return SEXP_VOID;
+    return thunk;
   }
   return apply(thunk, SEXP_NULL, context);
 }

main.c

@@ -31,13 +31,24 @@ void repl (sexp context) {
 }
 
 void run_main (int argc, char **argv) {
-  sexp env, obj, out=NULL, res, context, err_handler;
+  sexp env, out=NULL, res, context, perr_cell, err_cell, err_handler;
   sexp_uint_t i, quit=0, init_loaded=0;
 
   env = sexp_make_standard_env(sexp_make_integer(5));
   env_define(env, the_interaction_env_symbol, env);
+  out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE);
+  err_cell = env_cell(env, the_cur_err_symbol);
+  perr_cell = env_cell(env, sexp_intern("print-exception"));
   context = sexp_make_context(NULL, env);
   sexp_context_tailp(context) = 0;
+  if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) {
+    emit(OP_GLOBAL_KNOWN_REF, context);
+    emit_word((sexp_uint_t)err_cell, context);
+    emit(OP_LOCAL_REF, context);
+    emit_word(0, context);
+    emit(OP_FCALL2, context);
+    emit_word((sexp_uint_t)sexp_opcode_data(sexp_cdr(perr_cell)), context);
+  }
   emit_push(SEXP_VOID, context);
   emit(OP_DONE, context);
   err_handler = sexp_make_procedure(sexp_make_integer(0),
@@ -54,11 +65,12 @@ void run_main (int argc, char **argv) {
     case 'p':
       if (! init_loaded++)
         sexp_load(sexp_c_string(sexp_init_file), env);
-      obj = sexp_read_from_string(argv[i+1]);
+      res = sexp_read_from_string(argv[i+1]);
-      res = eval_in_context(obj, context);
+      if (! sexp_exceptionp(res))
-      if (argv[i][1] == 'p') {
+        res = eval_in_context(res, context);
-        if (! out)
+      if (sexp_exceptionp(res)) {
-          out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE);
+        sexp_print_exception(res, out);
+      } else if (argv[i][1] == 'p') {
         sexp_write(res, out);
         sexp_write_char('\n', out);
       }

opcodes.c

@@ -82,6 +82,7 @@ _FN1(SEXP_OPORT, "close-output-port", 0, sexp_close_port),
 _FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env),
 _FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env),
 _FN2(SEXP_STRING, SEXP_ENV, "%load", 0, sexp_load),
+_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception),
 _FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string),
 _FN2(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp),
 _FN2(SEXP_STRING, SEXP_STRING, "string-cmp-ci", 0, sexp_string_cmp_ci),

sexp.c

@@ -760,44 +760,48 @@ void sexp_write (sexp obj, sexp out) {
 
 char* sexp_read_string(sexp in) {
   char *buf, *tmp, *res;
-  int c, len, size=128;
+  int c, i=0, size=128;
 
-  buf = sexp_alloc(size);       /* XXXX grow! */
+  buf = sexp_alloc(size);
-  tmp = buf;
 
   for (c=sexp_read_char(in); c != '"'; c=sexp_read_char(in)) {
     if (c == EOF) {
       sexp_free(buf);
       return NULL;
-    } else if (c == '\\') {
+    }
+    if (c == '\\') {
       c=sexp_read_char(in);
       switch (c) {
       case 'n': c = '\n'; break;
       case 't': c = '\t'; break;
       }
-      *tmp++ = c;
+      buf[i++] = c;
     } else {
-      *tmp++ = c;
+      buf[i++] = c;
+    }
+    if (i >= size) {
+      tmp = sexp_alloc(2*size);
+      memcpy(tmp, buf, i);
+      sexp_free(buf);
+      buf = tmp;
     }
   }
 
-  *tmp++ = '\0';
+  buf[i] = '\0';
-  len = tmp - buf;
+  res = sexp_alloc(i);
-  res = sexp_alloc(len);
+  memcpy(res, buf, i);
-  memcpy(res, buf, len);
   sexp_free(buf);
   return res;
 }
 
 char* sexp_read_symbol(sexp in, int init) {
   char *buf, *tmp, *res;
-  int c, len, size=128;
+  int c, i=0, size=128;
 
   buf = sexp_alloc(size);
-  tmp = buf;
 
   if (init != EOF)
-    *tmp++ = init;
+    buf[i++] = init;
 
   while (1) {
     c=sexp_read_char(in);
@@ -805,13 +809,18 @@ char* sexp_read_symbol(sexp in, int init) {
       sexp_push_char(c, in);
       break;
     }
-    *tmp++ = c;
+    buf[i++] = c;
+    if (i >= size) {
+      tmp = sexp_alloc(2*size);
+      memcpy(tmp, buf, i);
+      sexp_free(buf);
+      buf = tmp;
+    }
   }
 
-  *tmp++ = '\0';
+  buf[i] = '\0';
-  len = tmp - buf;
+  res = sexp_alloc(i);
-  res = sexp_alloc(len);
+  memcpy(res, buf, i);
-  memcpy(res, buf, len);
   sexp_free(buf);
   return res;
 }
@@ -916,6 +925,9 @@ sexp sexp_read_raw (sexp in) {
     break;
   case '"':
     str = sexp_read_string(in);
+    if (! str)
+      res = sexp_read_error("premature end of string", SEXP_NULL, in);
+    else
       res = sexp_c_string(str);
     sexp_free(str);
     break;