adding import-immutable to minimize heap usage

Makefile

@@ -112,7 +112,7 @@ chibi-scheme$(EXE): main.o libchibi-scheme$(SO)
 chibi-scheme-static$(EXE): main.o eval.o sexp.o
 	$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS)
 
-%.c: %.stub chibi-scheme$(EXE) $(GENSTUBS)
+%.c: %.stub $(GENSTUBS)
 	LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) $(GENSTUBS) $<
 
 lib/%$(SO): lib/%.c $(INCLUDES)

eval.c

@@ -36,56 +36,83 @@ static sexp sexp_compile_error (sexp ctx, char *message, sexp obj) {
 
 /********************** environment utilities ***************************/
 
-sexp sexp_env_cell (sexp e, sexp key) {
+static sexp sexp_env_cell_loc (sexp env, sexp key, sexp *varenv) {
   sexp ls;
 
   do {
-    for (ls=sexp_env_bindings(e); sexp_pairp(ls); ls=sexp_cdr(ls))
+    for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_cdr(ls))
-      if (sexp_caar(ls) == key)
+      if (sexp_caar(ls) == key) {
+        if (varenv) *varenv = env;
         return sexp_car(ls);
-    e = sexp_env_parent(e);
+      }
-  } while (e);
+    env = sexp_env_parent(env);
+  } while (env);
 
   return NULL;
 }
 
-static sexp sexp_env_cell_create (sexp ctx, sexp e, sexp key, sexp value) {
+sexp sexp_env_cell (sexp env, sexp key) {
+  return sexp_env_cell_loc(env, key, NULL);
+}
+
+static sexp sexp_env_cell_create_loc (sexp ctx, sexp env, sexp key,
+                                      sexp value, sexp *varenv) {
   sexp_gc_var1(cell);
-  cell = sexp_env_cell(e, key);
+  cell = sexp_env_cell_loc(env, key, varenv);
   if (! cell) {
     sexp_gc_preserve1(ctx, cell);
     cell = sexp_cons(ctx, key, value);
-    while (sexp_env_parent(e))
+    while (sexp_env_lambda(env) || sexp_env_syntactic_p(env))
-      e = sexp_env_parent(e);
+      env = sexp_env_parent(env);
-    sexp_env_bindings(e) = sexp_cons(ctx, cell, sexp_env_bindings(e));
+    sexp_env_bindings(env) = sexp_cons(ctx, cell, sexp_env_bindings(env));
+    if (varenv) *varenv = env;
     sexp_gc_release1(ctx);
   }
   return cell;
 }
 
-sexp sexp_env_global_ref (sexp e, sexp key, sexp dflt) {
+static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key, sexp value) {
+  return sexp_env_cell_create_loc(ctx, env, key, value, NULL);
+}
+
+sexp sexp_env_global_ref (sexp env, sexp key, sexp dflt) {
   sexp cell;
-  while (sexp_env_parent(e))
+  while (sexp_env_parent(env))
-    e = sexp_env_parent(e);
+    env = sexp_env_parent(env);
-  cell = sexp_env_cell(e, key);
+  cell = sexp_env_cell(env, key);
   return (cell ? sexp_cdr(cell) : dflt);
 }
 
-void sexp_env_define (sexp ctx, sexp e, sexp key, sexp value) {
+sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) {
-  sexp cell = sexp_assq(ctx, key, sexp_env_bindings(e));
+  sexp cell = sexp_assq(ctx, key, sexp_env_bindings(env)), res=SEXP_VOID;
   sexp_gc_var1(tmp);
-  if (sexp_immutablep(e)) {
+  if (sexp_immutablep(env)) {
-    fprintf(stderr, "ERROR: immutable environment\n");
+    res = sexp_type_exception(ctx, "immutable binding", key);
   } else {
     sexp_gc_preserve1(ctx, tmp);
-    if (sexp_truep(cell))
+    if (sexp_truep(cell)) {
-      sexp_cdr(cell) = value;
+      if (sexp_immutablep(cell))
-    else {
+        res = sexp_type_exception(ctx, "immutable binding", key);
+      else
+        sexp_cdr(cell) = value;
+    } else {
       tmp = sexp_cons(ctx, key, value);
-      sexp_push(ctx, sexp_env_bindings(e), tmp);
+      sexp_push(ctx, sexp_env_bindings(env), tmp);
     }
     sexp_gc_release1(ctx);
   }
+  return res;
+}
+
+sexp sexp_env_exports (sexp ctx, sexp env) {
+  sexp ls;
+  sexp_gc_var1(res);
+  sexp_gc_preserve1(ctx, res);
+  res = SEXP_NULL;
+  for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_cdr(ls))
+    sexp_push(ctx, res, sexp_caar(ls));
+  sexp_gc_release1(ctx);
+  return res;
 }
 
 sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) {
@@ -430,11 +457,11 @@ static sexp analyze_seq (sexp ctx, sexp ls) {
   return res;
 }
 
-static sexp analyze_var_ref (sexp ctx, sexp x) {
+static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) {
   sexp env = sexp_context_env(ctx), res;
   sexp_gc_var1(cell);
   sexp_gc_preserve1(ctx, cell);
-  cell = sexp_env_cell(env, x);
+  cell = sexp_env_cell_loc(env, x, varenv);
   if (! cell) {
     if (sexp_synclop(x)) {
       if (sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_context_fv(ctx)))
@@ -442,7 +469,7 @@ static sexp analyze_var_ref (sexp ctx, sexp x) {
         env = sexp_synclo_env(x);
       x = sexp_synclo_expr(x);
     }
-    cell = sexp_env_cell_create(ctx, env, x, SEXP_UNDEF);
+    cell = sexp_env_cell_create_loc(ctx, env, x, SEXP_UNDEF, varenv);
   }
   if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell)))
     res = sexp_compile_error(ctx, "invalid use of syntax as value", x);
@@ -453,14 +480,14 @@ static sexp analyze_var_ref (sexp ctx, sexp x) {
 }
 
 static sexp analyze_set (sexp ctx, sexp x) {
-  sexp res;
+  sexp res, varenv;
   sexp_gc_var2(ref, value);
   sexp_gc_preserve2(ctx, ref, value);
   if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))
          && sexp_nullp(sexp_cdddr(x)) && sexp_idp(sexp_cadr(x)))) {
     res = sexp_compile_error(ctx, "bad set! syntax", x);
   } else {
-    ref = analyze_var_ref(ctx, sexp_cadr(x));
+    ref = analyze_var_ref(ctx, sexp_cadr(x), &varenv);
     if (sexp_lambdap(sexp_ref_loc(ref)))
       sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref));
     value = analyze(ctx, sexp_caddr(x));
@@ -468,6 +495,9 @@ static sexp analyze_set (sexp ctx, sexp x) {
       res = ref;
     else if (sexp_exceptionp(value))
       res = value;
+    else if (sexp_immutablep(sexp_ref_cell(ref))
+             || (varenv && sexp_immutablep(varenv)))
+      res = sexp_compile_error(ctx, "immutable binding", sexp_cadr(x));
     else
       res = sexp_make_set(ctx, ref, value);
   }
@@ -511,7 +541,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
     }
     if (sexp_exceptionp(value)) sexp_return(res, value);
     sexp_push(ctx2, defs,
-              sexp_make_set(ctx2, analyze_var_ref(ctx2, name), value));
+              sexp_make_set(ctx2, analyze_var_ref(ctx2, name, NULL), value));
   }
   if (sexp_pairp(defs)) {
     if (! sexp_seqp(body)) {
@@ -546,7 +576,7 @@ static sexp analyze_if (sexp ctx, sexp x) {
 }
 
 static sexp analyze_define (sexp ctx, sexp x) {
-  sexp name, res;
+  sexp name, res, varenv;
   sexp_gc_var4(ref, value, tmp, env);
   sexp_gc_preserve4(ctx, ref, value, tmp, env);
   env = sexp_context_env(ctx);
@@ -574,11 +604,13 @@ static sexp analyze_define (sexp ctx, sexp x) {
         value = analyze_lambda(ctx, tmp);
       } else
         value = analyze(ctx, sexp_caddr(x));
-      ref = analyze_var_ref(ctx, name);
+      ref = analyze_var_ref(ctx, name, &varenv);
       if (sexp_exceptionp(ref))
         res = ref;
       else if (sexp_exceptionp(value))
         res = value;
+      else if (varenv && sexp_immutablep(varenv))
+        res = sexp_compile_error(ctx, "immutable binding", name);
       else
         res = sexp_make_set(ctx, ref, value);
     }
@@ -736,15 +768,13 @@ static sexp analyze (sexp ctx, sexp object) {
       res = sexp_compile_error(ctx, "invalid operand in application", x);
     }
   } else if (sexp_idp(x)) {
-    res = analyze_var_ref(ctx, x);
+    res = analyze_var_ref(ctx, x, NULL);
   } else if (sexp_synclop(x)) {
     tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
     sexp_context_env(tmp) = sexp_synclo_env(x);
     sexp_context_fv(tmp) = sexp_append2(tmp,
                                         sexp_synclo_free_vars(x),
                                         sexp_context_fv(tmp));
-    if (sexp_pairp(sexp_synclo_free_vars(x)))
-      sexp_debug(ctx, "free vars: ", sexp_context_fv(tmp));
     x = sexp_synclo_expr(x);
     res = analyze(tmp, x);
   } else {
@@ -2535,13 +2565,21 @@ sexp sexp_make_standard_env (sexp ctx, sexp version) {
   return env;
 }
 
-sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls) {
+sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls, sexp immutp) {
   sexp oldname, newname, value, out;
   if (! sexp_envp(to)) to = sexp_context_env(ctx);
   if (! sexp_envp(from)) from = sexp_context_env(ctx);
   if (sexp_not(ls)) {
-    for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_cdr(ls))
+    if (sexp_truep(immutp)) {
-      sexp_env_define(ctx, to, sexp_caar(ls), sexp_cdar(ls));
+      value = sexp_make_env(ctx);
+      sexp_env_parent(value) = sexp_env_parent(to);
+      sexp_env_parent(to) = value;
+      sexp_immutablep(value) = 1;
+      sexp_env_bindings(value) = sexp_env_bindings(from);
+    } else {
+      for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_cdr(ls))
+        sexp_env_define(ctx, to, sexp_caar(ls), sexp_cdar(ls));
+    }
   } else {
     for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
       if (sexp_pairp(sexp_car(ls))) {

include/chibi/config.h

@@ -52,6 +52,9 @@
 /*   and are thus thread-safe and independant. */
 /* #define SEXP_USE_GLOBAL_HEAP 1 */
 
+/* uncomment this to make type definitions common to all contexts */
+/* #define SEXP_USE_GLOBAL_TYPES 1 */
+
 /* uncomment this to make the symbol table common to all contexts */
 /*   Will still be restricted to all contexts sharing the same */
 /*   heap, of course. */
@@ -194,6 +197,10 @@
 #endif
 #endif
 
+#ifndef SEXP_USE_GLOBAL_TYPES
+#define SEXP_USE_GLOBAL_TYPES (! SEXP_USE_TYPE_DEFS)
+#endif
+
 #ifndef SEXP_USE_GLOBAL_SYMBOLS
 #if SEXP_USE_BOEHM || SEXP_USE_MALLOC
 #define SEXP_USE_GLOBAL_SYMBOLS 1

include/chibi/eval.h

@@ -137,8 +137,8 @@ SEXP_API sexp sexp_find_module_file (sexp ctx, char *file);
 SEXP_API sexp sexp_load_module_file (sexp ctx, char *file, sexp env);
 SEXP_API sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp);
 SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value);
-SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls);
+SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls, sexp immutp);
-SEXP_API void sexp_env_define (sexp context, sexp env, sexp sym, sexp val);
+SEXP_API sexp sexp_env_define (sexp context, sexp env, sexp sym, sexp val);
 SEXP_API sexp sexp_env_cell (sexp env, sexp sym);
 SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt);
 SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out);

include/chibi/sexp.h

@@ -644,6 +644,12 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x);
 #define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS))
 #endif
 
+#if SEXP_USE_GLOBAL_TYPES
+#define sexp_context_types(ctx) sexp_type_specs
+#else
+#define sexp_context_types(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES))
+#endif
+
 #define sexp_context_top(x)     (sexp_stack_top(sexp_context_stack(x)))
 
 #define sexp_type_tag(x)               ((x)->value.type.tag)
@@ -683,6 +689,9 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x);
 enum sexp_context_globals {
 #if ! SEXP_USE_GLOBAL_SYMBOLS
   SEXP_G_SYMBOLS,
+#endif
+#if ! SEXP_USE_GLOBAL_TYPES
+  SEXP_G_TYPES,
 #endif
   SEXP_G_OOM_ERROR,             /* out of memory exception object */
   SEXP_G_OOS_ERROR,             /* out of stack exception object */

lib/chibi/loop.module

@@ -4,6 +4,6 @@
           listing listing-reverse appending appending-reverse
           summing multiplying in-string in-string-reverse
           in-vector in-vector-reverse)
-  (import (scheme))
+  (import-immutable (scheme))
   (include "loop/loop.scm"))
 

lib/chibi/macroexpand.module

@@ -1,6 +1,6 @@
 
 (define-module (chibi macroexpand)
-  (import (scheme))
+  (import-immutable (scheme))
   (import (chibi ast))
   (export macroexpand)
   (include "macroexpand.scm"))

lib/chibi/match.module

@@ -1,6 +1,6 @@
 
 (define-module (chibi match)
   (export match match-lambda match-lambda* match-let match-letrec match-let*)
-  (import (scheme))
+  (import-immutable (scheme))
   (include "match/match.scm"))
 

lib/chibi/net.module

@@ -1,9 +1,9 @@
 
 (define-module (chibi net)
-  (export sockaddr? addressinfo? get-address-info socket connect with-net-io
+  (export sockaddr? address-info? get-address-info socket connect with-net-io
           address-info-family address-info-socket-type address-info-protocol
           address-info-address address-info-address-length address-info-next)
-  (import (scheme))
+  (import-immutable (scheme))
   (import (chibi posix))
   (include-shared "net")
   (include "net.scm"))

lib/chibi/pathname.module

@@ -3,5 +3,5 @@
   (export path-strip-directory path-directory path-extension-pos
           path-extension path-strip-extension path-replace-extension
           path-absolute? path-relative? path-normalize make-path)
-  (import (scheme))
+  (import-immutable (scheme))
   (include "pathname.scm"))

lib/chibi/posix.module

@@ -1,12 +1,12 @@
 
 (define-module (chibi posix)
-  (export open-input-fd open-output-fd
+  (export open-input-fd open-output-fd pipe
-          delete-file link-file symbolic-link rename-file
+          delete-file link-file symbolic-link-file rename-file
           directory-files create-directory delete-directory
           current-seconds
           exit
           )
-  (import (scheme))
+  (import-immutable (scheme))
   (include-shared "posix")
   (include "posix.scm"))
 

lib/chibi/posix.scm

@@ -1,7 +1,10 @@
 
-(define (directory-files path)
+(define (directory-fold dir kons knil)
-  (let ((dir (opendir path)))
+  (let ((dir (opendir dir)))
-    (let lp ((res '()))
+    (let lp ((res knil))
       (let ((file (readdir dir)))
-        (if file (lp (cons (dirent-name file) res)) res)))))
+        (if file (lp (kons (dirent-name file) res)) res)))))
+
+(define (directory-files dir)
+  (directory-fold dir cons '()))
 

lib/chibi/posix.stub

@@ -10,29 +10,29 @@
 (define-c-struct dirent
   (string d_name dirent-name))
 
-(define-c input-port (open-input-fd fdopen) (int (value "r")))
+(define-c input-port (open-input-fd "fdopen") (int (value "r" string)))
-(define-c output-port (open-output-fd fdopen) (int (value "w")))
+(define-c output-port (open-output-fd "fdopen") (int (value "w" string)))
 
-(define-c errno (delete-file unlink) (string))
+(define-c errno (delete-file "unlink") (string))
-(define-c errno (link-file link) (string string))
+(define-c errno (link-file "link") (string string))
-(define-c errno (symbolic-link-file symlink) (string string))
+(define-c errno (symbolic-link-file "symlink") (string string))
-(define-c errno (rename-file rename) (string string))
+(define-c errno (rename-file "rename") (string string))
 
-;; (define-c string (current-directory getcwd) ())
+;;(define-c string (current-directory "getcwd") ((value (array char)) int))
-(define-c errno (create-directory mkdir) (string int))
+(define-c errno (create-directory "mkdir") (string int))
-(define-c errno (delete-directory rmdir) (string))
+(define-c errno (delete-directory "rmdir") (string))
 
 (define-c (free DIR) opendir (string))
 (define-c dirent readdir (DIR))
 
-(define-c int (duplicate-fd dup) (int))
+(define-c int (duplicate-fd "dup") (int))
 
 (define-c pid_t fork ())
 ;; (define-c pid_t wait ((result pointer int)))
 (define-c void exit (int))
-;;(define-c int (execute execvp) (string (array string null)))
+(define-c int (execute execvp) (string (array string null)))
 
-;;(define-c errno pipe ((result (array int 2))))
+(define-c errno pipe ((result (array int 2))))
 
-(define-c time_t (current-seconds time) ((value NULL)))
+(define-c time_t (current-seconds "time") ((value NULL)))
 

lib/chibi/uri.module

@@ -5,6 +5,6 @@
           uri-with-scheme uri-with-user uri-with-host uri-with-path
           uri-with-query uri-with-fragment
           uri-encode uri-decode uri-query->alist uri-alist->query)
-  (import (scheme)
+  (import-immutable (scheme)
-          (srfi 9))
+                    (srfi 9))
   (include "uri.scm"))

lib/config.scm

@@ -2,15 +2,16 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; modules
 
-(define *modules* '())
 (define *this-module* '())
 
 (define (make-module exports env meta) (vector exports env meta))
-(define (module-exports mod) (vector-ref mod 0))
 (define (module-env mod) (vector-ref mod 1))
 (define (module-meta-data mod) (vector-ref mod 2))
 (define (module-env-set! mod env) (vector-set! mod 1 env))
 
+(define (module-exports mod)
+  (or (vector-ref mod 0) (env-exports (module-env mod))))
+
 (define (module-name->strings ls res)
   (if (null? ls)
       res
@@ -55,13 +56,22 @@
    ((not (and (pair? x) (list? x)))
     (error "invalid module syntax" x))
    ((and (pair? (cdr x)) (pair? (cadr x)))
-    (if (memq (car x) '(only except renams))
+    (if (memq (car x) '(only except rename))
         (let* ((mod-name+imports (resolve-import (cadr x)))
-               (imp-ids (cdr mod-name+imports)))
+               (imp-ids (cdr mod-name+imports))
+               (imp-ids (if (and (not imp-ids) (not (eq? 'only (car x))))
+                            (begin
+                              (set-cdr! mod-name+imports
+                                        (module-exports
+                                         (find-module (car mod-name+imports))))
+                              (cdr mod-name+imports))
+                            imp-ids)))
           (cons (car mod-name+imports)
                 (case (car x)
                   ((only)
-                   (id-filter (lambda (i) (memq i (cddr x))) imp-ids))
+                   (if (not imp-ids)
+                       (cddr x)
+                       (id-filter (lambda (i) (memq i (cddr x))) imp-ids)))
                   ((except)
                    (id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids))
                   ((rename)
@@ -78,7 +88,7 @@
                          (if (pair? i) (cdr i) i)))
                  (cdr mod-name+imports)))))
    ((find-module x)
-    => (lambda (mod) (cons x (module-exports mod))))
+    => (lambda (mod) (cons x #f)))
    (else
     (error "couldn't find import" x))))
 
@@ -88,12 +98,13 @@
     (for-each
      (lambda (x)
        (case (and (pair? x) (car x))
-         ((import)
+         ((import import-immutable)
           (for-each
-           (lambda (x)
+           (lambda (m)
-             (let* ((mod2-name+imports (resolve-import x))
+             (let* ((mod2-name+imports (resolve-import m))
                     (mod2 (load-module (car mod2-name+imports))))
-               (%env-copy! env (module-env mod2) (cdr mod2-name+imports))))
+               (%env-copy! env (module-env mod2) (cdr mod2-name+imports)
+                           (eq? (car x) 'import-immutable))))
            (cdr x)))
          ((include include-shared)
           (for-each
@@ -142,58 +153,15 @@
            `(set! *this-module* (cons ',expr *this-module*))))))))
 
 (define-config-primitive import)
+(define-config-primitive import-immutable)
 (define-config-primitive export)
 (define-config-primitive include)
 (define-config-primitive include-shared)
 (define-config-primitive body)
 
-(let ((exports
+(define *modules*
-       '(define set! let let* letrec lambda if cond case delay
+  (list (cons '(scheme) (make-module #f (interaction-environment) '()))
-         and or begin do quote quasiquote
+        (cons '(srfi 0) (make-module (list 'cond-expand)
-         define-syntax let-syntax letrec-syntax syntax-rules eqv? eq? equal?
+                                     (interaction-environment)
-         not boolean? number? complex? real? rational? integer? exact? inexact?
+                                     (list (list 'export 'cond-expand))))))
-         = < > <= >= zero? positive? negative? odd? even? max min + * - / abs
-         quotient remainder modulo gcd lcm numerator denominator floor ceiling
-         truncate round exp log sin cos tan asin acos atan sqrt
-         expt real-part imag-part magnitude angle
-         exact->inexact inexact->exact number->string string->number pair? cons
-         car cdr set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar caddr
-         cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr
-         caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
-         null? list? list length append reverse reverse!
-         list-tail list-ref memq memv
-         member assq assv assoc symbol? symbol->string string->symbol char?
-         char=? char<? char>? char<=? char>=? char-ci=? char-ci<? char-ci>?
-         char-ci<=? char-ci>=? char-alphabetic? char-numeric? char-whitespace?
-         char-upper-case? char-lower-case? char->integer integer->char
-         char-upcase char-downcase string? make-string string string-length
-         string-ref string-set! string=? string-ci=? string<? string>?
-         string<=? string>=? string-ci<? string-ci>? string-ci<=? string-ci>=?
-         substring string-append string->list list->string string-copy
-         string-fill! vector? make-vector vector vector-length vector-ref
-         vector-set! vector->list list->vector vector-fill! procedure? apply
-         map for-each force call-with-current-continuation values
-         call-with-values interaction-environment scheme-report-environment
-         null-environment call-with-input-file call-with-output-file
-         input-port? output-port? current-input-port current-output-port
-         with-input-from-file with-output-to-file open-input-file
-         open-output-file close-input-port close-output-port read read-char
-         peek-char eof-object? char-ready? write display newline write-char
-         load eval
-         *current-input-port* *current-output-port* *current-error-port*
-         error current-error-port file-exists? string-concatenate
-         open-input-string open-output-string get-output-string
-         sc-macro-transformer rsc-macro-transformer er-macro-transformer
-         identifier? identifier=? identifier->symbol make-syntactic-closure
-         syntax-quote
-         register-simple-type make-constructor make-type-predicate
-         make-getter make-setter
-         )))
-  (set! *modules*
-        (list (cons '(scheme) (make-module exports
-                                           (interaction-environment)
-                                           (list (cons 'export exports))))
-              (cons '(srfi 0) (make-module (list 'cond-expand)
-                                           (interaction-environment)
-                                           (list (list 'export 'cond-expand)))))))
 

lib/init.scm

@@ -766,7 +766,8 @@
                            (vector-ref
                             (eval '(load-module ',(car mod+imps)) *config-env*)
                             1)
-                           ',(cdr mod+imps))
+                           ',(cdr mod+imps)
+                           #f)
                          res))
                (error "couldn't find module" (car ls))))))))))
 

lib/srfi/1.module

@@ -18,7 +18,7 @@
    lset<= lset= lset-adjoin lset-union lset-union! lset-intersection
    lset-intersection! lset-difference lset-difference! lset-xor lset-xor!
    lset-diff+intersection lset-diff+intersection!)
-  (import (scheme))
+  (import-immutable (scheme))
   (include "1/predicates.scm"
            "1/selectors.scm"
            "1/search.scm"

lib/srfi/11.module

@@ -1,7 +1,7 @@
 
 (define-module (srfi 11)
   (export let-values let*-values)
-  (import (scheme))
+  (import-immutable (scheme))
   (body
    (define-syntax let*-values
      (syntax-rules ()

lib/srfi/16.module

@@ -1,7 +1,7 @@
 
 (define-module (srfi 16)
   (export case-lambda)
-  (import (scheme))
+  (import-immutable (scheme))
   (body
    (define-syntax %case
      (syntax-rules ()

lib/srfi/2.module

@@ -1,7 +1,7 @@
 
 (define-module (srfi 2)
   (export and-let*)
-  (import (scheme))
+  (import-immutable (scheme))
   (body
    (define-syntax and-let*
      (syntax-rules ()

lib/srfi/26.module

@@ -1,7 +1,7 @@
 
 (define-module (srfi 26)
   (export cut cute)
-  (import (scheme))
+  (import-immutable (scheme))
   (body
    (define-syntax %cut
      (syntax-rules (<> <...>)

lib/srfi/27.module

@@ -5,7 +5,7 @@
           random-source-state-ref random-source-state-set!
           random-source-randomize! random-source-pseudo-randomize!
           random-source-make-integers random-source-make-reals)
-  (import (scheme))
+  (import-immutable (scheme))
   (include-shared "27/rand")
   (include "27/constructors.scm"))
 

lib/srfi/33.module

@@ -12,6 +12,6 @@
           first-set-bit
           extract-bit-field test-bit-field? clear-bit-field 
           replace-bit-field  copy-bit-field)
-  (import (scheme))
+  (import-immutable (scheme))
   (include-shared "33/bit")
   (include "33/bitwise.scm"))

lib/srfi/6.module

@@ -1,5 +1,5 @@
 
 (define-module (srfi 6)
   (export open-input-string open-output-string get-output-string)
-  (import (scheme)))
+  (import-immutable (scheme)))
 

lib/srfi/69.module

@@ -10,8 +10,8 @@
    hash-table-walk hash-table-fold hash-table->alist
    hash-table-copy hash-table-merge!
    hash string-hash string-ci-hash hash-by-identity)
-  (import (scheme))
+  (import-immutable (scheme)
-  (import (srfi 9))
+                    (srfi 9))
   (include-shared "69/hash")
   (include "69/type.scm" "69/interface.scm"))
 

lib/srfi/8.module

@@ -1,7 +1,7 @@
 
 (define-module (srfi 8)
   (export receive)
-  (import (scheme))
+  (import-immutable (scheme))
   (body
    (define-syntax receive
      (syntax-rules ()

lib/srfi/9.module

@@ -1,7 +1,7 @@
 
 (define-module (srfi 9)
   (export define-record-type)
-  (import (scheme))
+  (import-immutable (scheme))
   (body
    (define-syntax define-record-type
      (er-macro-transformer

opcodes.c

@@ -92,7 +92,7 @@ _FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env),
 _FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env),
 _FN2OPTP(0, SEXP_ENV, "eval", (sexp)"*interaction-environment*", sexp_eval),
 _FN2OPTP(SEXP_STRING, SEXP_ENV, "load", (sexp)"*interaction-environment*", sexp_load),
-_FN3(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy),
+_FN4(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy),
 _FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception),
 _FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func),
 _FN5(SEXP_SYMBOL, SEXP_STRING, "make-exception", 0, sexp_make_exception),
@@ -144,6 +144,7 @@ _FN2OPTP(SEXP_PROCEDURE, SEXP_OPORT, "disasm", (sexp)"*current-error-port*", sex
 #endif
 _FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p),
 #if SEXP_USE_MODULES
+_FN1(SEXP_ENV, "env-exports", 0, sexp_env_exports),
 _FN1(SEXP_STRING, "find-module-file", 0, sexp_find_module_file_op),
 _FN2(SEXP_STRING, SEXP_ENV, "load-module-file", 0, sexp_load_module_file_op),
 _FN2(SEXP_STRING, SEXP_BOOLEAN, "add-module-directory", 0, sexp_add_module_directory),

tools/genstubs.scm

@@ -1,8 +1,181 @@
 #! chibi-scheme -s
 
+;; Simple C FFI.  "genstubs.scm file.stub" will read in the C function
+;; FFI definitions from file.stub and output the appropriate C
+;; wrappers into file.c.  You can then compile that file with:
+;;
+;;   cc -fPIC -shared file.c -lchibi-scheme
+;;
+;; (or using whatever flags are appropriate to generate shared libs on
+;; your platform) and then the generated .so file can be loaded
+;; directly with load, or portably using (include-shared "file") in a
+;; module definition (note that include-shared uses no suffix).
+
+;; The goal of this interface is to make access to C types and
+;; functions easy, without requiring the user to write any C code.
+;; That means the stubber needs to be intelligent about various C
+;; calling conventions and idioms, such as return values passed in
+;; actual parameters.  Writing C by hand is still possible, and
+;; several of the core modules provide C interfaces directly without
+;; using the stubber.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Struct Interface
+;;
+;; (define-c-struct struct-name
+;;   [predicate: predicate-name]
+;;   [constructor: constructor-name]
+;;   [finalizer: c_finalizer_name]
+;;   (type c_field_name getter-name setter-name) ...)
+;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Function Interface
+;;
+;; (define-c return-type name-spec (arg-type ...))
+;;
+;; where name-space is either a symbol name, or a list of
+;; (scheme-name c_name).  If just a symbol, the C name is taken
+;; to be the same with -'s replaced by _'s.
+;;
+;; arg-type is a type suitable for input validation and conversion.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Types
+;;
+;; Types
+;;
+;; Basic Types
+;;   void
+;;   boolean
+;;   char
+;;
+;; Integer Types:
+;;   short int long
+;;   unsigned-short unsigned-int unsigned-long size_t pid_t
+;;   time_t (in seconds, but using the chibi epoch of 2010/01/01)
+;;   errno (as a return type returns #f on error)
+;;
+;; Float Types:
+;;   float double long-double
+;;
+;; String Types:
+;;   string (a null-terminated char*)
+;;
+;; Port Types:
+;;   input-port output-port
+;;
+;; Struct Types:
+;;
+;; Struct types are by default just referred to by the bare
+;; struct-name from define-c-struct, and it is assumed you want a
+;; pointer to that type.  To refer to the full struct, use the struct
+;; modifier, as in (struct struct-name).
+
+;; Type modifiers
+;;
+;; Any type may also be written as a list of modifiers followed by the
+;; type itself.  The supported modifiers are:
+;;
+;; const: prepends the "const" C type modifier
+;;        * as a return or result parameter, makes non-immediates immutable
+;;
+;; free:  it's Scheme's responsibility to "free" this resource
+;;        * as a return or result parameter, registers the freep flag
+;;          this causes the type finalizer to be run when GCed
+;;
+;; maybe-null: this pointer type may be NULL
+;;        * as a result parameter, NULL is translated to #f
+;;          normally this would just return a wrapped NULL pointer
+;;        * as an input parameter, #f is translated to NULL
+;;          normally this would be a type error
+;;
+;; pointer: create a pointer to this type
+;;        * as a return parameter, wraps the result in a vanilla cpointer
+;;        * as a result parameter, boxes then unboxes the value
+;;
+;; struct: treat this struct type as a struct, not a pointer
+;;        * as an input parameter, dereferences the pointer
+;;        * as a type field, indicates a nested struct
+;;
+;; link:  add a gc link
+;;        * as a field getter, link to the parent object, so the
+;;          parent won't be GCed so long as we have a reference
+;;          to the child.  this behavior is automatic for nested
+;;          structs.
+;;
+;; result: return a result in this parameter
+;;        * if there are multiple results (including the return type),
+;;          they are all returned in a list
+;;        * if there are any result parameters, a return type
+;;          of errno returns #f on failure, and as eliminated
+;;          from the list of results otherwise
+;;
+;; (value <expr>): specify a fixed value
+;;        * as an input parameter, this parameter is not provided
+;;          in the Scheme API but always passed as <expr>
+;;
+;; (default <expr>): specify a default value
+;;        * as the final input parameter, makes the Scheme parameter
+;;          optional, defaulting to <expr>
+;;
+;; (array <type> [<length>])  an array type
+;;        * length must be specified for return and result parameters
+;;        * if specified, length can be any of
+;;        ** an integer, for a fixed size
+;;        ** the symbol null, indicating a NULL-terminated array
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (define types '())
 (define funcs '())
 
+(define (make-type type free? const? null? ptr? struct? link? result? array value default? i)
+  (vector type free? const? null? ptr? struct? link? result? array value default? i))
+
+(define (with-parsed-type type proc . o)
+  (cond
+   ((vector? type)
+    (apply proc (vector->list type)))
+   (else
+    (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f)
+             (ptr? #f) (struct? #f) (link? #f) (result? #f) (array #f)
+             (value #f) (default? #f))
+      (define (next) (if (null? (cddr type)) (cadr type) (cdr type)))
+      (case (and (pair? type) (car type))
+        ((free) (lp (next) #t const? null-ptr? ptr? struct? link? result? array value default?))
+        ((const) (lp (next) free? #t null-ptr? ptr? struct? link? result? array value default?))
+        ((maybe-null) (lp (next) free? const? #t ptr? struct? link? result? array value default?))
+        ((pointer) (lp (next) free? const? null-ptr? #t struct? link? result? array value default?))
+        ((struct) (lp (next) free? const? null-ptr? ptr? #t link? result? array value default?))
+        ((link) (lp (next) free? const? null-ptr? ptr? struct? #t result? array value default?))
+        ((result) (lp (next) free? const? null-ptr? ptr? struct? link? #t array value default?))
+        ((array) (lp (cadr type) free? const? null-ptr? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default?))
+        ((value) (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) default?))
+        ((default) (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) #t))
+        (else (proc type free? const? null-ptr? ptr? struct? link? result? array value default? (and (pair? o) (car o)))))))))
+
+(define (parse-type type . o)
+  (with-parsed-type type make-type (and (pair? o) (car o))))
+(define (maybe-parse-type type)
+  (if (vector? type) type (parse-type type)))
+
+(define (type-base type) (vector-ref (maybe-parse-type type) 0))
+(define (type-free type) (vector-ref (maybe-parse-type type) 1))
+(define (type-const type) (vector-ref (maybe-parse-type type) 2))
+(define (type-null? type) (vector-ref (maybe-parse-type type) 3))
+(define (type-pointer? type) (vector-ref (maybe-parse-type type) 4))
+(define (type-struct? type) (vector-ref (maybe-parse-type type) 5))
+(define (type-link? type) (vector-ref (maybe-parse-type type) 6))
+(define (type-result? type) (vector-ref (maybe-parse-type type) 7))
+(define (type-array type) (vector-ref (maybe-parse-type type) 8))
+(define (type-value type) (vector-ref (maybe-parse-type type) 9))
+(define (type-default? type) (vector-ref (maybe-parse-type type) 10))
+(define (type-index type) (vector-ref (maybe-parse-type type) 11))
+
 (define (cat . args)
   (for-each (lambda (x) (if (procedure? x) (x) (display x))) args))
 
@@ -125,27 +298,10 @@
                        funcs))
      #f)))
 
-(define (with-parsed-type type proc)
-  (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f)
-           (pointer? #f) (struct? #f) (link? #f) (result? #f))
-    (define (next) (if (null? (cddr type)) (cadr type) (cdr type)))
-    (case (and (pair? type) (car type))
-      ((free) (lp (next) #t const? null-ptr? pointer? struct? link? result?))
-      ((const) (lp (next) free? #t null-ptr? pointer? struct? link? result?))
-      ((maybe-null) (lp (next) free? const? #t pointer? struct? link? result?))
-      ((pointer) (lp (next) free? const? null-ptr? #t struct? link? result?))
-      ((struct) (lp (next) free? const? null-ptr? pointer? #t link? result?))
-      ((link) (lp (next) free? const? null-ptr? pointer? struct? #t result?))
-      ((result) (lp (next) free? const? null-ptr? pointer? struct? link? #t))
-      (else (proc type free? const? null-ptr? pointer? struct? link? result?)))))
-
-(define (get-base-type type)
-  (with-parsed-type type (lambda (x . args) x)))
-
 (define (c->scheme-converter type val . o)
   (with-parsed-type
    type
-   (lambda (type free? const? null-ptr? pointer? struct? link? result?)
+   (lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i)
      (cond
       ((eq? type 'void)
        (cat "((" val "), SEXP_VOID)"))
@@ -174,9 +330,9 @@
 (define (scheme->c-converter type val)
   (with-parsed-type
    type
-   (lambda (type free? const? null-ptr? pointer? struct? link? result?)
+   (lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i)
      (cond
-      ((eq? 'sexp type)
+      ((eq? type 'sexp)
        (cat val))
       ((eq? type 'time_t)
        (cat "sexp_uint_value(sexp_unshift_epoch(" val "))"))
@@ -200,7 +356,7 @@
 (define (type-predicate type)
   (with-parsed-type
    type
-   (lambda (type free? const? null-ptr? pointer? struct? link? result?)
+   (lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i)
      (cond
       ((int-type? type) "sexp_exact_integerp")
       ((float-type? type) "sexp_flonump")
@@ -210,7 +366,7 @@
 (define (type-name type)
   (with-parsed-type
    type
-   (lambda (type free? const? null-ptr? pointer? struct? link? result?)
+   (lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i)
      (cond
        ((int-type? type) "integer")
        ((float-type? type) "flonum")
@@ -219,19 +375,19 @@
 (define (type-c-name type)
   (with-parsed-type
    type
-   (lambda (base-type free? const? null-ptr? pointer? struct? link? result?)
+   (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i)
      (let ((struct? (assq base-type types)))
        (string-append
         (if const? "const " "")
         (if struct? "struct " "")
         (string-replace (symbol->string base-type) #\- #\space)
         (if struct? "*" "")
-        (if pointer? "*" ""))))))
+        (if ptr? "*" ""))))))
 
 (define (check-type arg type)
   (with-parsed-type
    type
-   (lambda (base-type free? const? null-ptr? pointer? struct? link? result?)
+   (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i)
      (cond
       ((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type))
        (cat (type-predicate type) "(" arg ")"))
@@ -252,7 +408,7 @@
 (define (validate-type arg type)
   (with-parsed-type
    type
-   (lambda (base-type free? const? null-ptr? pointer? struct? link? result?)
+   (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i)
      (cond
       ((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type))
        (cat
@@ -289,6 +445,109 @@
             (lp (cdr ls) (cons (car ls) res)))
         (reverse res))))
 
+(define (with-parsed-func func proc)
+  (let* ((ret-type (parse-type (cadr func)))
+         (scheme-name (if (pair? (caddr func)) (caaddr func) (caddr func)))
+         (c-name (if (pair? (caddr func))
+                     (cadr (caddr func))
+                     (mangle scheme-name))))
+    (let lp ((ls (cadddr func))
+             (i 0)
+             (results '())
+             (c-args '())
+             (s-args '()))
+      (cond
+       ((null? ls)
+        (proc scheme-name c-name ret-type
+              (reverse results) (reverse c-args) (reverse s-args)))
+       (else
+        (let ((type (parse-type (car ls) i)))
+          (cond
+           ((type-result? type)
+            (lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args))
+           ((type-value type)
+            (lp (cdr ls) (+ i 1) results (cons type c-args) s-args))
+           (else
+            (lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args)))
+           )))))))
+
+(define (write-parameters args)
+  (lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args)))
+
+(define (write-locals func)
+  (with-parsed-func func
+    (lambda (scheme-name c-name ret-type results c-args scheme-args)
+      (cat "  sexp res;\n"))))
+
+(define (write-validators args)
+  (for-each
+   (lambda (a)
+     (validate-type (string-append "arg" (number->string (type-index arg))) a))
+   args))
+
+(define (write-temporaries func)
+  #f)
+
+(define (write-call ret-type c-name c-args)
+  (cat (if (eq? 'errno (type-base ret-type)) "  err = " "  res = "))
+  (c->scheme-converter
+   ret-type
+   (lambda ()
+     (cat c-name "(")
+     (for-each
+      (lambda (arg)
+        (if (> (type-index arg) 0) (cat ", "))
+        (cond
+         ((type-result? arg)
+          (cat (if (or (type-pointer? result) (type-array result)) "" "&")
+               "tmp"))
+         ((type-value arg)
+          => (lambda (x) (write x)))
+         (else
+          (scheme->c-converter arg (string-append "arg" (type-index arg))))))
+      c-args)
+     (cat ");\n"))))
+
+(define (write-result result)
+  (if (type-array (car result))
+      (cat "    sexp_gc_preserve1(ctx, res);\n"
+           "    res = SEXP_NULL;\n"
+           "    for (i=" (type-array (car result)) "-1; i>=0; i--) {\n"
+           "      sexp_push(ctx, res, SEXP_VOID);\n"
+           "      sexp_car(res) = "
+           (lambda () (c->scheme-converter (car result) "tmp[i]")) ";\n"
+           "    }\n"
+           "    sexp_gc_release1(ctx);\n")
+      (c->scheme-converter (car result) "tmp")))
+
+(define (write-results ret-type results)
+  (if (eq? 'errno (type-base ret-type))
+      (cat "  if (err) {\n"
+           "    res = SEXP_FALSE;\n"
+           "  } else {\n"))
+  (if (null? results)
+      (cat "    res = SEXP_TRUE;\n")
+      (for-each write-result results))
+  (if (eq? 'errno (type-base ret-type))
+      (cat "  }\n")))
+
+(define (write-cleanup func)
+  #f)
+
+(define (write-func func)
+  (with-parsed-func func
+    (lambda (scheme-name c-name ret-type results c-args scheme-args)
+      (cat "static sexp " scheme-name
+           "(sexp ctx" (write-parameters scheme-args) ") {\n"
+           (write-locals func)
+           (write-validators scheme-args)
+           (write-temporaries func)
+           (write-call ret-type c-name c-args)
+           (write-result ret-type results)
+           (write-cleanup func)
+           "  return res;\n"
+           "}\n\n"))))
+
 (define (write-func func)
   (let ((ret-type (cadr func))
         (result (get-func-result func))
@@ -298,9 +557,19 @@
       (cond ((pair? ls)
              (cat ", sexp arg" i)
              (lp (cdr ls) (+ i 1)))))
-    (cat ") {\n  sexp res;\n")
+    (cat ") {\n  "
+         (if (and result (type-array result)) "sexp_gc_var1(res)" "sexp res")
+         ";\n")
     (if (eq? 'errno ret-type) (cat "  int err;\n"))
-    (if result (cat "  " (type-c-name result) " tmp;\n"))
+    (if (type-array result) (cat "  int i;\n"))
+    (if result
+        (cat "  " (type-c-name result) (if (type-pointer? result) "*" "")
+             " tmp"
+             (if (type-array result)
+                 (with-output-to-string
+                   (lambda () (cat "[" (type-array result) "]")))
+                 "")
+             ";\n"))
     (let lp ((ls args) (i 0))
       (cond ((pair? ls)
              (validate-type (string-append "arg" (number->string i)) (car ls))
@@ -314,7 +583,11 @@
          (cond ((pair? ls)
                 (cat (cond
                       ((eq? (car ls) result)
-                       "&tmp")
+                       (lambda () (cat (if (or (type-pointer? result)
+                                           (type-array result))
+                                       ""
+                                       "&")
+                                   "tmp")))
                       ((and (pair? (car ls)) (memq 'value (car ls)))
                        => (lambda (x) (write (cadr x)) ""))
                       (else
@@ -328,9 +601,22 @@
     (cat ";\n")
     (if (eq? 'errno ret-type)
         (if result
-            (cat "  res = (err ? SEXP_FALSE : "
+            (if (type-array result)
-                 (lambda () (c->scheme-converter result "tmp"))
+                (cat "  if (err) {\n"
-                 ");\n")
+                     "    res = SEXP_FALSE;\n"
+                     "  } else {\n"
+                     "    sexp_gc_preserve1(ctx, res);\n"
+                     "    res = SEXP_NULL;\n"
+                     "    for (i=" (type-array result) "-1; i>=0; i--) {\n"
+                     "      sexp_push(ctx, res, SEXP_VOID);\n"
+                     "      sexp_car(res) = "
+                     (lambda () (c->scheme-converter result "tmp[i]")) ";\n"
+                     "    }\n"
+                     "    sexp_gc_release1(ctx);\n"
+                     "  }\n")
+                (cat "  res = (err ? SEXP_FALSE : "
+                     (lambda () (c->scheme-converter result "tmp"))
+                     ");\n"))
             (cat "  res = sexp_make_boolean(! err);\n")))
     (cat "  return res;\n"
          "}\n\n")))
@@ -345,7 +631,7 @@
         (type (cdr type)))
     (with-parsed-type
      type
-     (lambda (base-type free? const? null-ptr? pointer? struct? link? result?)
+     (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i)
        (cat "  name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n"
             "  " (type-id-name name)
             " = sexp_unbox_fixnum(sexp_register_c_type(ctx, name, "
@@ -364,12 +650,12 @@
 
 (define (type-getter-name type name field)
   (string-append "sexp_" (x->string (type-name name))
-                 "_get_" (x->string (get-base-type (cadr field)))))
+                 "_get_" (x->string (type-base (cadr field)))))
 
 (define (write-type-getter type name field)
   (with-parsed-type
    (car field)
-   (lambda (field-type free? const? null-ptr? pointer? struct? link? result?)
+   (lambda (field-type free? const? null-ptr? ptr? struct? link? result? array value default? i)
      (cat "static sexp " (type-getter-name type name field)
           " (sexp ctx, sexp x) {\n"
           (lambda () (validate-type "x" name))
@@ -387,12 +673,12 @@
 
 (define (type-setter-name type name field)
   (string-append "sexp_" (x->string (type-name name))
-                 "_set_" (x->string (get-base-type (car field)))))
+                 "_set_" (x->string (type-base (car field)))))
 
 (define (write-type-setter type name field)
   (with-parsed-type
    (car field)
-   (lambda (field-type free? const? null-ptr? pointer? struct? link? result?)
+   (lambda (field-type free? const? null-ptr? ptr? struct? link? result? array value default? i)
      (cat "static sexp " (type-setter-name type name field)
          " (sexp ctx, sexp x, sexp v) {\n"
          (lambda () (validate-type "x" name))
@@ -413,7 +699,7 @@
         (type (cdr type)))
     (with-parsed-type
      type
-     (lambda (base-type free? const? null-ptr? pointer? struct? link? result?)
+     (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i)
        (cond
         ((memq 'finalizer: base-type)
          => (lambda (x)