Merge branch 'master' into identifier-macros

bignum.c

@@ -999,8 +999,8 @@ sexp sexp_complex_sub (sexp ctx, sexp a, sexp b) {
   sexp_gc_var2(res, tmp);
   sexp_gc_preserve2(ctx, res, tmp);
   tmp = sexp_complex_copy(ctx, b);
-  sexp_negate(sexp_complex_real(tmp));
+  sexp_negate_maybe_ratio(sexp_complex_real(tmp));
-  sexp_negate(sexp_complex_imag(tmp));
+  sexp_negate_maybe_ratio(sexp_complex_imag(tmp));
   res = sexp_complex_add(ctx, a, tmp);
   sexp_gc_release2(ctx);
   return res;
@@ -1453,11 +1453,7 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
     sexp_negate_exact(sexp_ratio_numerator(tmp2));
     r = sexp_ratio_add(ctx, a, tmp2);
     if (negatep) {
-      if (sexp_ratiop(r)) {
+      sexp_negate_maybe_ratio(r);
-        sexp_negate_exact(sexp_ratio_numerator(r));
-      } else {
-        sexp_negate_exact(r);
-      }
     }
     break;
 #endif
@@ -1489,10 +1485,10 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
     if (negatep) {
       if (sexp_complexp(r)) {
         r = sexp_complex_copy(ctx, r);
-        sexp_negate(sexp_complex_real(r));
+        sexp_negate_maybe_ratio(sexp_complex_real(r));
-        sexp_negate(sexp_complex_imag(r));
+        sexp_negate_maybe_ratio(sexp_complex_imag(r));
       } else {
-        sexp_negate(r);
+        sexp_negate_maybe_ratio(r);
       }
     }
     break;
@@ -1886,12 +1882,13 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
       r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b));
       break;
     case SEXP_NUM_FIX_FLO:
-      f = sexp_fixnum_to_double(a);
+      if (isinf(sexp_flonum_value(b))) {
-      g = sexp_flonum_value(b);
+        r = sexp_flonum_value(b) > 0 ? SEXP_NEG_ONE : SEXP_ONE;
-      if (isnan(g))
+      } else if (isnan(sexp_flonum_value(b))) {
         r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", b);
-      else
+      } else {
-        r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
+        r = sexp_compare(ctx, a, tmp=sexp_inexact_to_exact(ctx, NULL, 1, b));
+      }
       break;
     case SEXP_NUM_FIX_BIG:
       if ((sexp_bignum_hi(b) > 1) ||
@@ -1933,8 +1930,7 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
       } else if (isnan(f)) {
         r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", a);
       } else {
-        g = sexp_ratio_to_double(ctx, b);
+        r = sexp_compare(ctx, tmp=sexp_inexact_to_exact(ctx, NULL, 1, a), b);
-        r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
       }
       break;
     case SEXP_NUM_FIX_RAT:

doc/chibi.scrbl

@@ -684,7 +684,9 @@ need to check manually before applying the predicate.
 \item{\ccode{sexp_fixnump(obj)} - \var{obj} is an immediate integer}
 \item{\ccode{sexp_flonump(obj)} - \var{obj} is an inexact real}
 \item{\ccode{sexp_bignump(obj)} - \var{obj} is a heap-allocated integer}
-\item{\ccode{sexp_integerp(obj)} - \var{obj} is an integer}
+\item{\ccode{sexp_integerp(obj)} - \var{obj} is an integer (or flonum truncating without loss)}
+\item{\ccode{sexp_ratiop(obj)} - \var{obj} is an exact rational (with SEXP_USE_RATIOS)}
+\item{\ccode{sexp_complexp(obj)} - \var{obj} is a complex number (with SEXP_USE_COMPLEX)}
 \item{\ccode{sexp_numberp(obj)} - \var{obj} is any kind of number}
 \item{\ccode{sexp_charp(obj)} - \var{obj} is a character}
 \item{\ccode{sexp_stringp(obj)} - \var{obj} is a string}
@@ -780,6 +782,8 @@ once.
 \item{\ccode{sexp_unbox_boolean(obj)} - 1 if \var{obj} is \scheme{#t}, 0 otherwise}
 \item{\ccode{sexp_make_fixnum(n)} - creates a new fixnum representing int \var{n}}
 \item{\ccode{sexp_unbox_fixnum(obj)} - converts a fixnum to a C integer}
+\item{\ccode{sexp_make_flonum(sexp ctx, float f)} - creates a new floating point value}
+\item{\ccode{sexp_flonum_value(obj)} - converts a flonum to a C float}
 \item{\ccode{sexp_make_character(ch)} - creates a new character representing char \var{ch}}
 \item{\ccode{sexp_unbox_character(obj)} - converts a character to a C char}
 \item{\ccode{sexp sexp_make_string_cursor(int offset)} - creates a string cursor for the given byte offset}
@@ -812,6 +816,7 @@ Any of these may fail and return the OOM exception object.
 \item{\ccode{sexp_cons(sexp ctx, sexp obj1, sexp obj2)} - create a new pair whose car is \var{obj1} and whose cdr is \var{obj2}}
 \item{\ccode{sexp_list1(sexp ctx, sexp obj)} - alias for sexp_cons(ctx, obj, SEXP_NULL)}
 \item{\ccode{sexp_list2(sexp ctx, sexp obj1, sexp obj2)} - create a list of two elements}
+\item{\ccode{sexp_list3(sexp ctx, sexp obj1, sexp obj2, sexp obj3)} - create a list of three elements}
 \item{\ccode{sexp_make_string(sexp ctx, sexp len, sexp ch)} - create a new Scheme string of \var{len} characters, all initialized to \var{ch}}
 \item{\ccode{sexp_c_string(sexp ctx, const char* str, int len)} - create a new Scheme string copying the first \var{len} characters of the C string \var{str}.  If \var{len} is -1, uses strlen(\var{str}).}
 \item{\ccode{sexp_intern(sexp ctx, const char* str, int len)} - interns a symbol from the first \var{len} characters of the C string \var{str}.  If \var{len} is -1, uses strlen(\var{str}).}
@@ -850,7 +855,7 @@ Any of these may fail and return the OOM exception object.
 \item{\ccode{sexp_assq(sexp ctx, sexp x, sexp ls)} - \scheme{assq}}
 \item{\ccode{sexp_reverse(sexp ctx, sexp ls)} - \scheme{reverse}}
 \item{\ccode{sexp_nreverse(sexp ctx, sexp ls)} - \scheme{reverse!}}
-\item{\ccode{sexp_append2(sexp ctx, sexp ls)} - \scheme{append} for two arguments}
+\item{\ccode{sexp_append2(sexp ctx, sexp ls1, sexp ls2)} - \scheme{append} for two arguments}
 \item{\ccode{sexp_copy_list(sexp ctx, sexp ls)} - return a shallow copy of \var{ls}}
 \item{\ccode{sexp_list_to_vector(sexp ctx, sexp ls)} - \scheme{list->vector}}
 \item{\ccode{sexp_symbol_to_string(sexp ctx, sexp sym)} - \scheme{symbol->string}}

gc.c

@@ -37,7 +37,7 @@ static sexp_heap sexp_heap_last (sexp_heap h) {
   return h;
 }
 
-#if !SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
+#if !SEXP_USE_FIXED_CHUNK_SIZE_HEAPS && !SEXP_USE_MALLOC
 static size_t sexp_heap_total_size (sexp_heap h) {
   size_t total_size = 0;
   for (; h; h=h->next)
@@ -696,6 +696,7 @@ int sexp_find_fixed_chunk_heap_usage(sexp ctx, size_t size, size_t* sum_freed, s
 }
 #endif
 
+#if ! SEXP_USE_MALLOC
 void* sexp_alloc (sexp ctx, size_t size) {
   void *res;
   size_t max_freed, sum_freed, total_size=0;
@@ -741,6 +742,7 @@ void* sexp_alloc (sexp ctx, size_t size) {
 #endif
   return res;
 }
+#endif
 
 
 void sexp_gc_init (void) {

include/chibi/eval.h

@@ -129,6 +129,7 @@ SEXP_API sexp sexp_make_lit (sexp ctx, sexp value);
 SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
 SEXP_API sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags, sexp num_args, sexp bc, sexp vars);
 SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data);
+SEXP_API sexp sexp_define_foreign_proc_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data);
 SEXP_API sexp sexp_register_optimization(sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp i);
 #if SEXP_USE_AUTO_FORCE
 SEXP_API sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val);
@@ -194,6 +195,8 @@ SEXP_API sexp sexp_define_foreign_param_aux(sexp ctx, sexp env, const char *name
 #define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(const char*)#f,(sexp_proc1)f,NULL)
 #define sexp_define_foreign_param(c,e,s,n,f,p) sexp_define_foreign_param_aux(c,e,s,n,(const char*)#f,(sexp_proc1)f,p)
 #define sexp_define_foreign_opt(c,e,s,n,f,p) sexp_define_foreign_aux(c,e,s,n,1,(const char*)#f,(sexp_proc1)f,p)
+#define sexp_define_foreign_proc(c,e,s,n,f) sexp_define_foreign_proc_aux(c,e,s,n,SEXP_PROC_NONE,(const char*)#f,(sexp_proc1)f,NULL)
+#define sexp_define_foreign_proc_rest(c,e,s,n,f) sexp_define_foreign_proc_aux(c,e,s,n,SEXP_PROC_VARIADIC,(const char*)#f,(sexp_proc1)f,NULL)
 
 #define sexp_env_key(x) sexp_car(x)
 #define sexp_env_value(x) sexp_cdr(x)

include/chibi/features.h

@@ -324,6 +324,15 @@
 #define SEXP_MAX_ANALYZE_DEPTH 8192
 #endif
 
+/* The size of flexible arrays (empty arrays at the end of a struct */
+/* representing the trailing data), when compiled with C++.  Technically */
+/* 0 is an illegal value here, and the C++ idiom is to use 1, but this */
+/* breaks compatibility with C when computing the size of structs, and */
+/* in practice all of the major C++ compilers support 0. */
+#ifndef SEXP_FLEXIBLE_ARRAY_SIZE
+#define SEXP_FLEXIBLE_ARRAY_SIZE 0
+#endif
+
 /************************************************************************/
 /*         DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE            */
 /************************************************************************/

include/chibi/sexp.h

@@ -1,5 +1,5 @@
 /*  sexp.h -- header for sexp library                         */
-/*  Copyright (c) 2009-2015 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2022 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 #ifndef SEXP_H
@@ -7,7 +7,7 @@
 
 #ifdef __cplusplus
 extern "C" {
-#define SEXP_FLEXIBLE_ARRAY [1]
+#define SEXP_FLEXIBLE_ARRAY [SEXP_FLEXIBLE_ARRAY_SIZE]
 #else
 #define SEXP_FLEXIBLE_ARRAY []
 #endif
@@ -523,7 +523,6 @@ struct sexp_struct {
       sexp parent;
       sexp_uint_t length;
       void *value;
-      char body SEXP_FLEXIBLE_ARRAY;
     } cpointer;
     /* runtime types */
     struct {
@@ -1082,6 +1081,13 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
   else                                                  \
     sexp_negate_exact(x)
 
+#define sexp_negate_maybe_ratio(x)                      \
+  if (sexp_ratiop(x)) {                                 \
+    sexp_negate_exact(sexp_ratio_numerator(x));         \
+  } else {                                              \
+    sexp_negate(x);                                     \
+  }
+
 #if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS
 
 #if SEXP_64_BIT
@@ -1258,7 +1264,6 @@ enum sexp_uniform_vector_type {
 
 #define sexp_cpointer_freep(x)      (sexp_freep(x))
 #define sexp_cpointer_length(x)     (sexp_cpointer_field(x, length))
-#define sexp_cpointer_body(x)       (sexp_cpointer_field(x, body))
 #define sexp_cpointer_parent(x)     (sexp_cpointer_field(x, parent))
 #define sexp_cpointer_value(x)      (sexp_cpointer_field(x, value))
 #define sexp_cpointer_maybe_null_value(x) (sexp_not(x) ? NULL : sexp_cpointer_value(x))
@@ -1760,6 +1765,7 @@ SEXP_API sexp sexp_file_exception (sexp ctx, sexp self, const char *msg, sexp x)
 SEXP_API sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x);
 SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x);
 SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end);
+SEXP_API sexp sexp_get_stack_trace (sexp ctx);
 SEXP_API sexp sexp_print_exception_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out);
 SEXP_API sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out);
 SEXP_API sexp sexp_print_exception_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out);

lib/chibi/test.scm

@@ -689,25 +689,6 @@
         (cond ((current-test-group)
                => test-group-indent-width)
               (else 0)))))
-  ;; update group info
-  (cond
-   ((current-test-group)
-    => (lambda (group)
-         (if (not (eq? 'SKIP status))
-             (test-group-inc! group 'count))
-         (test-group-inc! group status)
-         ;; maybe wrap long status lines
-         (let ((width (max (- (current-column-width)
-                              (test-group-indent-width group))
-                           (current-group-indent)))
-               (column
-                (+ (string-length (test-group-name group))
-                   (test-group-ref group 'count 0)
-                   1)))
-           (if (and (zero? (modulo column width))
-                    (not (test-group-ref group 'verbose)))
-               (display
-                (string-copy indent (current-group-indent))))))))
   ;; update global failure count for exit status
   (cond
    ((or (eq? status 'FAIL) (eq? status 'ERROR))
@@ -730,6 +711,25 @@
            (test-group-push! group 'failures (list indent status info)))))
     (cond ((current-test-group)
            => (lambda (group) (test-group-set! group 'trailing #t))))))
+  ;; update group info
+  (cond
+   ((current-test-group)
+    => (lambda (group)
+         (if (not (eq? 'SKIP status))
+             (test-group-inc! group 'count))
+         (test-group-inc! group status)
+         ;; maybe wrap long status lines
+         (let ((width (max (- (current-column-width)
+                              (test-group-indent-width group))
+                           (current-group-indent)))
+               (column
+                (+ (string-length (test-group-name group))
+                   (test-group-ref group 'count 0)
+                   1)))
+           (when (and (zero? (modulo column width))
+                      (not (test-group-ref group 'verbose)))
+             (newline)
+             (display (string-copy indent (current-group-indent))))))))
   (flush-output-port)
   status)
 

lib/init-7.scm

@@ -873,8 +873,8 @@
       (set! count (+ count 1))
       (rename (string->symbol (string-append s (%number->string count)))))
     (define (expand-pattern pat tmpl)
-      (let lp ((p pat)
+      (let lp ((p (if (pair? pat) (cdr pat) pat))
-               (x _expr)
+               (x (if (pair? pat) (list _cdr _expr) _expr))
                (dim 0)
                (vars '())
                (k (lambda (vars)

lib/srfi/95/qsort.c

@@ -82,9 +82,9 @@ static int sexp_isymbol_compare (sexp ctx, sexp a, sexp b) {
 #define sexp_non_immediate_ordered_numberp(x) 0
 #endif
 
-static int sexp_object_compare (sexp ctx, sexp a, sexp b, int depth) {
+static sexp_sint_t sexp_object_compare (sexp ctx, sexp a, sexp b, int depth) {
   sexp ls1, ls2;
-  int i, res, len;
+  sexp_sint_t i, res, len;
   if (a == b)
     return 0;
   if (sexp_pointerp(a)) {

lib/srfi/95/test.sld

@@ -122,8 +122,8 @@
       (test "sort various mixed" '(3 3.14 355/113 22/7 4)
         (sort '(355/113 4 22/7 3 3.14)))
 
-      (test "sort complex" '(3 3.14 355/113 22/7 3.14+0.0i 3.14+3.14i)
+      ;; (test "sort complex" '(3 3.14 355/113 22/7 3.14+0.0i 3.14+3.14i)
-        (sort '(3.14+3.14i 355/113 3 22/7 3.14+0.0i 3.14)))
+      ;;   (sort '(3.14+3.14i 355/113 3 22/7 3.14+0.0i 3.14)))
 
       (test "sort stable" '((0 2) (0 3) (0 4) (1 1) (1 2) (1 3) (2 1) (2 2))
         (sort '((1 1) (0 2) (1 2) (2 1) (0 3) (2 2) (0 4) (1 3)) < car))

main.c

@@ -560,7 +560,7 @@ sexp run_main (int argc, char **argv) {
       sym=sexp_intern(ctx, sexp_raw_script_file_symbol, -1), tmp);
     for (j=argc-1; j>=i; j--)
       args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args);
-    if (main_symbol)
+    if (main_module)
       args = sexp_cons(ctx, tmp=sexp_c_string(ctx,main_symbol,-1), args);
     if (args == SEXP_NULL)
       args = sexp_cons(ctx, tmp=sexp_c_string(ctx,"",-1), args);

sexp.c

@@ -3634,9 +3634,9 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) {
 #if SEXP_USE_COMPLEX
           if (sexp_complexp(res)) {
             if (sexp_complex_real(res) == SEXP_ZERO) {
-              sexp_negate(sexp_complex_imag(res));
+              sexp_negate_maybe_ratio(sexp_complex_imag(res));
             } else {
-              sexp_negate(sexp_complex_real(res));
+              sexp_negate_maybe_ratio(sexp_complex_real(res));
             }
           } else
 #endif
@@ -3753,7 +3753,7 @@ sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len) {
 
 sexp sexp_string_to_number_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp b) {
   int base;
-  sexp_gc_var1(in);
+  sexp_gc_var2(in, res);
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
   sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, b);
   if (((base=sexp_unbox_fixnum(b)) < 2) || (base > 36))
@@ -3761,20 +3761,22 @@ sexp sexp_string_to_number_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sex
   if (sexp_string_data(str)[0]=='\0'
       || (sexp_string_data(str)[1]=='\0' && !sexp_isxdigit((unsigned char)(sexp_string_data(str)[0]))))
     return SEXP_FALSE;
-  sexp_gc_preserve1(ctx, in);
+  sexp_gc_preserve2(ctx, in, res);
   in = sexp_open_input_string(ctx, str);
   if (sexp_string_data(str)[0] == '+') {
     if (sexp_isdigit((unsigned char)(sexp_string_data(str)[1]))
         || sexp_string_data(str)[1] == '.' || sexp_string_data(str)[1] == '#')
       sexp_read_char(ctx, in);
   }
-  in = ((sexp_string_data(str)[0] == '#' &&
+  res = ((sexp_string_data(str)[0] == '#' &&
           sexp_tolower((unsigned char)sexp_string_data(str)[1]) != 'e' &&
           sexp_tolower((unsigned char)sexp_string_data(str)[1]) != 'i')
          || base == 10 ? sexp_read(ctx, in) :
          sexp_read_number(ctx, in, base, 0));
-  sexp_gc_release1(ctx);
+  if (!sexp_numberp(res) || sexp_peek_char(ctx, in) != EOF)
-  return sexp_numberp(in) ? in : SEXP_FALSE;
+    res = SEXP_FALSE;
+  sexp_gc_release2(ctx);
+  return res;
 }
 
 sexp sexp_write_to_string (sexp ctx, sexp obj) {

tests/r7rs-tests.scm

@@ -798,6 +798,7 @@
 (test #f (< +nan.0 0.0))
 (test #f (> +nan.0 0.0))
 (test '(#t #f) (list (<= 1 1 2) (<= 2 1 3)))
+(test #f (= 9007199254740992.0 9007199254740993))
 
 ;; From R7RS 6.2.6 Numerical operations:
 ;;
@@ -888,6 +889,8 @@
 (test -1 (- 3 4))
 (test -6 (- 3 4 5))
 (test -3 (- 3))
+(test -3/2 (- 3/2))
+(test -3/2-i (- 3/2+i))
 (test 3/20 (/ 3 4 5))
 (test 1/3 (/ 3))
 
@@ -1025,6 +1028,7 @@
 (test 100 (string->number "100"))
 (test 256 (string->number "100" 16))
 (test 100.0 (string->number "1e2"))
+(test #f (string->number "1 2"))
 
 (test-end)
 

vm.c

@@ -787,18 +787,19 @@ static sexp make_param_list (sexp ctx, sexp_uint_t i) {
   return res;
 }
 
-static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
+static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i, sexp_sint_t flags) {
+  int j = i+(flags & SEXP_PROC_VARIADIC);
   sexp ls, res, env;
   sexp_gc_var6(bc, params, ref, refs, lambda, ctx2);
-  if (i == sexp_opcode_num_args(op)) { /* return before preserving */
+  if (j == sexp_opcode_num_args(op)) { /* return before preserving */
     if (sexp_opcode_proc(op)) return sexp_opcode_proc(op);
-  } else if (i < sexp_opcode_num_args(op)) {
+  } else if (j < sexp_opcode_num_args(op)) {
     return sexp_compile_error(ctx, "not enough args for opcode", op);
   } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */
     return sexp_compile_error(ctx, "too many args for opcode", op);
   }
   sexp_gc_preserve6(ctx, bc, params, ref, refs, lambda, ctx2);
-  params = make_param_list(ctx, i);
+  params = make_param_list(ctx, j);
   lambda = sexp_make_lambda(ctx, params);
   ctx2 = sexp_make_child_context(ctx, lambda);
   env = sexp_extend_env(ctx2, sexp_context_env(ctx), params, lambda);
@@ -819,8 +820,8 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
       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);
+      res=sexp_make_procedure(ctx2, sexp_make_fixnum(flags), sexp_make_fixnum(i), bc, SEXP_VOID);
-      if (i == sexp_opcode_num_args(op))
+      if (j == sexp_opcode_num_args(op))
         sexp_opcode_proc(op) = res;
     }
   }
@@ -828,6 +829,28 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
   return res;
 }
 
+sexp sexp_make_foreign_proc(sexp ctx, const char *name, int num_args, int flags,
+                            const char *fname, sexp_proc1 f) {
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = sexp_make_foreign (ctx, name, num_args+((flags & SEXP_PROC_VARIADIC)>0), 0, fname, f, NULL);
+  if (!sexp_exceptionp(res))
+    res = make_opcode_procedure (ctx, res, num_args, flags);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+sexp sexp_define_foreign_proc_aux (sexp ctx, sexp env, const char *name,int num_args,
+                                   int flags, const char *fname, sexp_proc1 f, sexp data) {
+  sexp_gc_var2(sym, res);
+  sexp_gc_preserve2(ctx, sym, res);
+  res = sexp_make_foreign_proc(ctx, name, num_args, flags, fname, f);
+  if (!sexp_exceptionp(res))
+    sexp_env_define(ctx, env, sym = sexp_intern(ctx, name, -1), res);
+  sexp_gc_release2(ctx);
+  return res;
+}
+
 /*********************** the virtual machine **************************/
 
 sexp sexp_make_trampoline (sexp ctx, sexp proc, sexp args) {
@@ -1274,7 +1297,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
     sexp_context_top(ctx) = top;
     if (sexp_opcodep(tmp1)) {
       /* compile non-inlined opcode applications on the fly */
-      tmp1 = make_opcode_procedure(ctx, tmp1, i);
+      tmp1 = make_opcode_procedure(ctx, tmp1, i, SEXP_PROC_NONE);
       if (sexp_exceptionp(tmp1)) {
         _ARG1 = tmp1;
         goto call_error_handler;