Additional OOM checks - harder but still not impossible to segfault on OOM.

eval.c

@@ -244,6 +244,7 @@ void sexp_shrink_bcode (sexp ctx, sexp_uint_t i) {
   sexp tmp;
   if (sexp_bytecode_length(sexp_context_bc(ctx)) != i) {
     tmp = sexp_alloc_bytecode(ctx, i);
+    if (!sexp_exceptionp(tmp)) {
       sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx));
       sexp_bytecode_length(tmp) = i;
       sexp_bytecode_literals(tmp)
@@ -256,12 +257,16 @@ void sexp_shrink_bcode (sexp ctx, sexp_uint_t i) {
       sexp_context_bc(ctx) = tmp;
     }
   }
+}
 
 void sexp_expand_bcode (sexp ctx, sexp_uint_t size) {
   sexp tmp;
   if (sexp_bytecode_length(sexp_context_bc(ctx))
       < (sexp_unbox_fixnum(sexp_context_pos(ctx)))+size) {
     tmp=sexp_alloc_bytecode(ctx, sexp_bytecode_length(sexp_context_bc(ctx))*2);
+    if (sexp_exceptionp(tmp)) {
+      sexp_context_exception(ctx) = tmp;
+    } else {
       sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx));
       sexp_bytecode_length(tmp)
         = sexp_bytecode_length(sexp_context_bc(ctx))*2;
@@ -275,9 +280,12 @@ void sexp_expand_bcode (sexp ctx, sexp_uint_t size) {
       sexp_context_bc(ctx) = tmp;
     }
   }
+}
 
 void sexp_emit (sexp ctx, unsigned char c)  {
   sexp_expand_bcode(ctx, 1);
+  if (sexp_exceptionp(sexp_context_exception(ctx)))
+    return;
   sexp_bytecode_data(sexp_context_bc(ctx))[sexp_unbox_fixnum(sexp_context_pos(ctx))] = c;
   sexp_context_pos(ctx) = sexp_fx_add(sexp_context_pos(ctx), SEXP_ONE);
 }
@@ -294,6 +302,8 @@ sexp sexp_complete_bytecode (sexp ctx) {
       sexp_cdr(sexp_bytecode_literals(bc)) = sexp_cadr(sexp_bytecode_literals(bc));
     else
       sexp_bytecode_literals(bc) = sexp_list_to_vector(ctx, sexp_bytecode_literals(bc));
+    if (sexp_exceptionp(sexp_bytecode_literals(bc)))
+      return sexp_bytecode_literals(bc);
   }
   sexp_bytecode_max_depth(bc) = sexp_unbox_fixnum(sexp_context_max_depth(ctx));
 #if SEXP_USE_FULL_SOURCE_INFO
@@ -303,6 +313,8 @@ sexp sexp_complete_bytecode (sexp ctx) {
   }
 #endif
   sexp_bless_bytecode(ctx, bc);
+  if (sexp_exceptionp(sexp_context_exception(ctx)))
+    return sexp_context_exception(ctx);
   return bc;
 }
 
@@ -450,7 +462,11 @@ sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size, s
   sexp_context_lambda(res) = SEXP_FALSE;
   sexp_context_fv(res) = SEXP_NULL;
   sexp_context_bc(res) = sexp_alloc_bytecode(res, SEXP_INIT_BCODE_SIZE);
-  if (sexp_exceptionp(sexp_context_bc(res))) {
+  if (sexp_exceptionp(sexp_context_env(res))) {
+    res = sexp_context_env(res);
+  } else if (sexp_exceptionp(sexp_context_specific(res))) {
+    res = sexp_context_specific(res);
+  } else if (sexp_exceptionp(sexp_context_bc(res))) {
     res = sexp_context_bc(res);
   } else {
     sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE;
@@ -671,14 +687,17 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
       sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x));
   /* build lambda and analyze body */
   res = sexp_make_lambda(ctx, tmp=sexp_copy_list(ctx, sexp_cadr(x)));
+  if (sexp_exceptionp(res)) sexp_return(res, res);
   sexp_lambda_source(res) = sexp_pair_source(x);
   if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res))))
     sexp_lambda_source(res) = sexp_pair_source(sexp_cdr(x));
   if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res))))
     sexp_lambda_source(res) = sexp_pair_source(sexp_cddr(x));
   ctx2 = sexp_make_child_context(ctx, res);
+  if (sexp_exceptionp(ctx2)) sexp_return(res, ctx2);
   tmp = sexp_flatten_dot(ctx2, sexp_lambda_params(res));
   sexp_context_env(ctx2) = sexp_extend_env(ctx2, sexp_context_env(ctx2), tmp, res);
+  if (sexp_exceptionp(sexp_context_env(ctx2))) sexp_return(res, sexp_context_env(ctx2));
   sexp_env_lambda(sexp_context_env(ctx2)) = res;
   body = analyze_seq(ctx2, sexp_cddr(x));
   if (sexp_exceptionp(body)) sexp_return(res, body);
@@ -700,8 +719,11 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
     }
     if (sexp_exceptionp(value)) sexp_return(res, value);
     if (sexp_lambdap(value)) sexp_lambda_name(value) = name;
-    sexp_push(ctx3, defs,
+    tmp = analyze_var_ref(ctx3, name, NULL);
-              sexp_make_set(ctx3, analyze_var_ref(ctx3, name, NULL), value));
+    if (sexp_exceptionp(tmp)) sexp_return(res, tmp);
+    tmp = sexp_make_set(ctx3, tmp, value);
+    if (sexp_exceptionp(tmp)) sexp_return(res, tmp);
+    sexp_push(ctx3, defs, tmp);
     if (!sexp_lambdap(value)) trailing_non_procs = 1;
     if (trailing_non_procs || !SEXP_USE_UNBOXED_LOCALS)
       sexp_insert(ctx3, sexp_lambda_sv(res), name);
@@ -713,8 +735,10 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
       body = tmp;
     }
     sexp_seq_ls(body) = sexp_append2(ctx2, defs, sexp_seq_ls(body));
+    if (sexp_exceptionp(sexp_seq_ls(body))) sexp_return(res, sexp_seq_ls(body));
   }
-  sexp_lambda_body(res) = body;
+  if (sexp_exceptionp(body)) res = body;
+  else sexp_lambda_body(res) = body;
  cleanup:
   sexp_gc_release6(ctx);
   return res;
@@ -801,9 +825,9 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
         mac = sexp_env_ref(sexp_context_env(eval_ctx), sexp_cadar(ls), SEXP_FALSE);
       else
         mac = sexp_eval(eval_ctx, sexp_cadar(ls), NULL);
-      if (sexp_procedurep(mac)) {
+      if (sexp_procedurep(mac))
         mac = sexp_make_macro(eval_ctx, mac, sexp_context_env(bind_ctx));
-      } else if (!(sexp_macrop(mac)||sexp_corep(mac))) {
+      if (!(sexp_macrop(mac)||sexp_corep(mac))) {
         res = (sexp_exceptionp(mac) ? mac
                : sexp_compile_error(eval_ctx, "non-procedure macro", mac));
         break;
@@ -825,7 +849,7 @@ static sexp analyze_define_syntax (sexp ctx, sexp x) {
   sexp_gc_var1(tmp);
   sexp_gc_preserve1(ctx, tmp);
   tmp = sexp_list1(ctx, sexp_cdr(x));
-  res = analyze_bind_syntax(tmp, ctx, ctx);
+  res = sexp_exceptionp(tmp) ? tmp : analyze_bind_syntax(tmp, ctx, ctx);
   sexp_gc_release1(ctx);
   return res;
 }
@@ -917,7 +941,8 @@ static sexp analyze (sexp ctx, sexp object) {
           tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL);
           tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp);
           tmp = sexp_cons(ctx, x, tmp);
-          x = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
+          x = sexp_exceptionp(tmp) ? tmp : sexp_make_child_context(ctx, sexp_context_lambda(ctx));
+          if (!sexp_exceptionp(x) && !sexp_exceptionp(sexp_context_exception(ctx)))
             x = sexp_apply(x, sexp_macro_proc(op), tmp);
           if (sexp_exceptionp(x) && sexp_not(sexp_exception_source(x)))
             sexp_exception_source(x) = sexp_pair_source(sexp_car(tmp));
@@ -1218,7 +1243,7 @@ sexp sexp_load_op (sexp ctx, sexp self, sexp_sint_t n, sexp source, sexp env) {
   } else {
     sexp_port_sourcep(in) = 1;
     while ((x=sexp_read(ctx, in)) != (sexp) SEXP_EOF) {
-      res = sexp_eval(ctx2, x, env);
+      res = sexp_exceptionp(x) ? x : sexp_eval(ctx2, x, env);
       if (sexp_exceptionp(res))
         break;
     }
@@ -2125,17 +2150,23 @@ sexp sexp_compile_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp env) {
       res = ast;
     } else {
       res = sexp_global(ctx2, SEXP_G_OPTIMIZATIONS);
-      for ( ; sexp_pairp(res); res=sexp_cdr(res))
+      for ( ; sexp_pairp(res) && !sexp_exceptionp(ast); res=sexp_cdr(res))
         ast = sexp_apply1(ctx2, sexp_cdar(res), ast);
+      if (sexp_exceptionp(ast)) {
+        res = ast;
+      } else {
         sexp_free_vars(ctx2, ast, SEXP_NULL);    /* should return SEXP_NULL */
         sexp_emit_enter(ctx2);
         sexp_generate(ctx2, 0, 0, 0, ast);
         res = sexp_complete_bytecode(ctx2);
+        if (!sexp_exceptionp(res)) {
           sexp_context_specific(ctx2) = SEXP_FALSE;
           vec = sexp_make_vector(ctx2, 0, SEXP_VOID);
           if (sexp_exceptionp(vec)) res = vec;
           else res = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, vec);
         }
+      }
+    }
     sexp_context_child(ctx) = SEXP_FALSE;
     sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2);
   }
@@ -2155,7 +2186,7 @@ sexp sexp_eval_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp env) {
   sexp_context_params(ctx) = SEXP_NULL;
   ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), env, 0, 0);
   sexp_context_child(ctx) = ctx2;
-  res = sexp_compile_op(ctx2, self, n, obj, env);
+  res = sexp_exceptionp(ctx2) ? ctx2 : sexp_compile_op(ctx2, self, n, obj, env);
   if (! sexp_exceptionp(res))
     res = sexp_apply(ctx2, res, SEXP_NULL);
   sexp_context_child(ctx) = SEXP_FALSE;

include/chibi/features.h

@@ -368,6 +368,10 @@
 #define SEXP_USE_SAFE_ACCESSORS 0
 #endif
 
+#ifndef SEXP_USE_SAFE_VECTOR_ACCESSORS
+#define SEXP_USE_SAFE_VECTOR_ACCESSORS 0
+#endif
+
 #ifndef SEXP_USE_GLOBAL_HEAP
 #if SEXP_USE_BOEHM || SEXP_USE_MALLOC
 #define SEXP_USE_GLOBAL_HEAP 1
@@ -601,6 +605,10 @@
 #define SEXP_USE_IMAGE_LOADING SEXP_USE_DL && !SEXP_USE_GLOBAL_HEAP && !SEXP_USE_BOEHM && !SEXP_USE_NO_FEATURES
 #endif
 
+#ifndef SEXP_USE_UNSAFE_PUSH
+#define SEXP_USE_UNSAFE_PUSH 0
+#endif
+
 #ifndef SEXP_USE_MAIN_HELP
 #define SEXP_USE_MAIN_HELP ! SEXP_USE_NO_FEATURES
 #endif

include/chibi/sexp.h

@@ -832,7 +832,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_vector_length(x) (sexp_field(x, vector, SEXP_VECTOR, length))
 #define sexp_vector_data(x)   (sexp_field(x, vector, SEXP_VECTOR, data))
 
-#if SEXP_USE_SAFE_ACCESSORS
+#if SEXP_USE_SAFE_VECTOR_ACCESSORS
 #define sexp_vector_ref(x,i)   (sexp_unbox_fixnum(i)>=0 && sexp_unbox_fixnum(i)<sexp_vector_length(x) ? sexp_vector_data(x)[sexp_unbox_fixnum(i)] : (fprintf(stderr, "vector-ref length out of range %s on line %d: vector %p (length %lu): %ld\n", __FILE__, __LINE__, x, sexp_vector_length(x), sexp_unbox_fixnum(i)), SEXP_VOID))
 #define sexp_vector_set(x,i,v) (sexp_unbox_fixnum(i)>=0 && sexp_unbox_fixnum(i)<sexp_vector_length(x) ? sexp_vector_data(x)[sexp_unbox_fixnum(i)]=(v) : (fprintf(stderr, "vector-set! length out of range in %s on line %d: vector %p (length %lu): %ld\n", __FILE__, __LINE__, x, sexp_vector_length(x), sexp_unbox_fixnum(i)), SEXP_VOID))
 #else
@@ -1209,7 +1209,13 @@ enum sexp_context_globals {
 
 #define sexp_list1(x,a)        sexp_cons((x), (a), SEXP_NULL)
 
+SEXP_API sexp sexp_push_op(sexp ctx, sexp* loc, sexp x);
+
+#if SEXP_USE_UNSAFE_PUSH
 #define sexp_push(ctx, ls, x)    ((ls) = sexp_cons((ctx), (x), (ls)))
+#else
+#define sexp_push(ctx, ls, x)    (sexp_push_op((ctx), &(ls), (x)))
+#endif
 #define sexp_insert(ctx, ls, x)  ((sexp_memq(ctx, (x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ctx), (ls), (x)))
 
 #define sexp_pair_source(x) (sexp_field(x, pair, SEXP_PAIR, source))

sexp.c

@@ -52,6 +52,15 @@ int sexp_is_separator(int c) {
 sexp sexp_symbol_table[SEXP_SYMBOL_TABLE_SIZE];
 #endif
 
+#if ! SEXP_USE_UNSAFE_PUSH
+sexp sexp_push_op(sexp ctx, sexp* loc, sexp x) {
+  sexp tmp = sexp_cons(ctx, x, *loc);
+  if (sexp_exceptionp(tmp)) return *loc;
+  *loc = tmp;
+  return tmp;
+}
+#endif
+
 sexp sexp_alloc_tagged_aux(sexp ctx, size_t size, sexp_uint_t tag sexp_current_source_param) {
   sexp res = (sexp) sexp_alloc(ctx, size);
   if (res && ! sexp_exceptionp(res)) {

vm.c

@@ -103,6 +103,8 @@ static void bytecode_preserve (sexp ctx, sexp obj) {
 static void sexp_emit_word (sexp ctx, sexp_uint_t val)  {
   unsigned char *data;
   sexp_expand_bcode(ctx, sizeof(sexp));
+  if (sexp_exceptionp(sexp_context_exception(ctx)))
+    return;
   data = sexp_bytecode_data(sexp_context_bc(ctx));
   sexp_context_align_pos(ctx);
   *((sexp_uint_t*)(&(data[sexp_unbox_fixnum(sexp_context_pos(ctx))]))) = val;
@@ -152,6 +154,7 @@ static sexp_sint_t sexp_context_make_label (sexp ctx) {
 static void sexp_context_patch_label (sexp ctx, sexp_sint_t label) {
   sexp bc = sexp_context_bc(ctx);
   unsigned char *data = sexp_bytecode_data(bc)+label;
+  if (!sexp_exceptionp(sexp_context_exception(ctx)))
     *((sexp_sint_t*)data) = sexp_unbox_fixnum(sexp_context_pos(ctx))-label;
 }
 
@@ -529,6 +532,8 @@ static int generate_lambda_locals (sexp ctx, sexp name, sexp loc, sexp lam, sexp
 static int generate_lambda_body (sexp ctx, sexp name, sexp loc, sexp lam, sexp x, sexp prev_lam) {
   sexp_uint_t k, updatep, tailp;
   sexp ls, ref, fv, prev_fv;
+  if (sexp_exceptionp(sexp_context_exception(ctx)))
+    return 0;
   if (sexp_seqp(x)) {
     tailp = sexp_context_tailp(ctx);
     sexp_context_tailp(ctx) = 0;
@@ -587,12 +592,18 @@ static void generate_lambda (sexp ctx, sexp name, sexp loc, sexp lam, sexp lambd
   sexp ctx2, fv, ls, flags, len, ref, prev_lambda, prev_fv;
   sexp_sint_t k;
   sexp_gc_var2(tmp, bc);
-  sexp_gc_preserve2(ctx, tmp, bc);
+  if (sexp_exceptionp(sexp_context_exception(ctx)))
+    return;
   prev_lambda = sexp_context_lambda(ctx);
   prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL;
   fv = sexp_lambda_fv(lambda);
   ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0, 0);
+  if (sexp_exceptionp(ctx2)) {
+    sexp_context_exception(ctx) = ctx2;
+    return;
+  }
   sexp_context_lambda(ctx2) = lambda;
+  sexp_gc_preserve2(ctx, tmp, bc);
   tmp = sexp_cons(ctx2, SEXP_ZERO, sexp_lambda_source(lambda));
   /* allocate space for local vars */
   k = sexp_unbox_fixnum(sexp_length(ctx, sexp_lambda_locals(lambda)));
@@ -630,6 +641,9 @@ static void generate_lambda (sexp ctx, sexp name, sexp loc, sexp lam, sexp lambd
                            : SEXP_PROC_NONE);
   len = sexp_length(ctx2, sexp_lambda_params(lambda));
   bc = sexp_complete_bytecode(ctx2);
+  if (sexp_exceptionp(bc)) {
+    sexp_context_exception(ctx) = bc;
+  } else {
   sexp_bytecode_name(bc) = sexp_lambda_name(lambda);
 #if ! SEXP_USE_FULL_SOURCE_INFO
   sexp_bytecode_source(bc) = sexp_lambda_source(lambda);
@@ -663,10 +677,13 @@ static void generate_lambda (sexp ctx, sexp name, sexp loc, sexp lam, sexp lambd
     sexp_emit_word(ctx, (sexp_uint_t)bc);
     bytecode_preserve(ctx, bc);
   }
+  }
   sexp_gc_release2(ctx);
 }
 
 void sexp_generate (sexp ctx, sexp name, sexp loc, sexp lam, sexp x) {
+  if (sexp_exceptionp(sexp_context_exception(ctx)))
+    return;
   if (sexp_pointerp(x)) {
     switch (sexp_pointer_tag(x)) {
     case SEXP_PAIR:   generate_app(ctx, name, loc, lam, x); break;
@@ -708,19 +725,28 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
   lambda = sexp_make_lambda(ctx, params);
   ctx2 = sexp_make_child_context(ctx, lambda);
   env = sexp_extend_env(ctx2, sexp_context_env(ctx), params, lambda);
+  if (sexp_exceptionp(env)) {
+    res = env;
+  } else {
     sexp_context_env(ctx2) = env;
     for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) {
       ref = sexp_make_ref(ctx2, sexp_car(ls), sexp_env_cell(env, sexp_car(ls), 0));
-    sexp_push(ctx2, refs, ref);
+      if (!sexp_exceptionp(ref)) sexp_push(ctx2, refs, ref);
     }
+    if (!sexp_exceptionp(refs))
       refs = sexp_reverse(ctx2, refs);
     refs = sexp_cons(ctx2, op, refs);
+    if (sexp_exceptionp(refs)) {
+      res = refs;
+    } else {
       generate_opcode_app(ctx2, refs);
       bc = sexp_complete_bytecode(ctx2);
       sexp_bytecode_name(bc) = sexp_opcode_name(op);
       res=sexp_make_procedure(ctx2, SEXP_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID);
       if (i == sexp_opcode_num_args(op))
         sexp_opcode_proc(op) = res;
+    }
+  }
   sexp_gc_release6(ctx);
   return res;
 }