adding hash-tables and a more friendly FFI

Makefile

@@ -1,6 +1,6 @@
 # -*- makefile-gmake -*-
 
-.PHONY: all doc dist clean cleaner test install uninstall
+.PHONY: all libs doc dist clean cleaner test install uninstall
 
 CC       ?= cc
 PREFIX   ?= /usr/local
@@ -48,7 +48,9 @@ STATICFLAGS = -static
 endif
 endif
 
-all: chibi-scheme$(EXE)
+all: chibi-scheme$(EXE) libs
+
+libs: lib/srfi/69/hash$(SO)
 
 ifeq ($(USE_BOEHM),1)
 GCLDFLAGS := -lgc
@@ -90,6 +92,9 @@ chibi-scheme$(EXE): main.o libchibi-scheme$(SO)
 chibi-scheme-static$(EXE): main.o eval.o sexp.o
 	$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS)
 
+lib/srfi/69/hash$(SO): lib/srfi/69/hash.c
+	$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme
+
 clean:
 	rm -f *.o *.i *.s *.8
 

README

@@ -41,6 +41,8 @@ directly from make with:
 See the file main.c for an example of using chibi-scheme as a library.
 The essential functions to remember are:
 
+  #include <chibi/eval.h>
+
   sexp_make_context(NULL, NULL, NULL)
     returns a new context
 
@@ -50,3 +52,49 @@ The essential functions to remember are:
   sexp_eval_string(context, str)
     reads an s-expression from str and evaluates it
 
+  sexp_env_define(context, env, symbol, value)
+
+A minimal module system is provided by default.  Currently you can
+load the following SRFIs with (import (srfi N)):
+
+  1, 2, 6, 8, 9, 11, 16, 26, 69
+
+LOAD is extended to accept an optional environment argument, like
+EVAL.  You can also LOAD shared libraries in addition to Scheme source
+files - in this case the function sexp_init_library is automatically
+called with the following signature:
+
+  sexp_init_library(sexp context, sexp environment)
+
+To define new primitive functions from C, use sexp_define_foreign,
+which takes a Scheme environment, a name, a number of arguments the C
+function takes (not counting the context argument), and a C function.
+
+  /* sexp_define_foreign(context, env, name, num_args, f) */
+
+  sexp add1 (sexp context, sexp x) {
+    return sexp_fx_add(x, sexp_make_fixnum(1));
+  }
+
+  sexp_define_foreign(context, env, "add1", 1, add1)
+
+See the SRFI-69 implementation for more detailed examples of this.
+
+You can define new data types with SRFI-9.  This is just syntactic
+sugar for the following more primitive type constructors:
+
+(register-simple-type <name-string> <num-fields>)
+ => <type-id> ; a fixnum
+
+(make-type-predicate <opcode-name-string> <type-id>)
+ => <opcode>  ; takes 1 arg, returns #t iff that arg is of the type
+
+(make-constructor <constructor-name-string> <type-id>)
+ => <opcode>  ; takes 0 args, returns a newly allocated instance of type
+
+(make-getter <getter-name-string> <type-id> <field-index>)
+ => <opcode>  ; takes 1 args, retrieves the field located at the index
+
+(make-setter <setter-name-string> <type-id> <field-index>)
+ => <opcode>  ; takes 2 args, sets the field located at the index
+

TODO

@@ -46,4 +46,7 @@
 *- type inference with warnings
 *- SRFI-0 cond-expand
 *+ SRFI-9 define-record-type
+*+ SRFI-69 hash-tables
+*- tcp interface
+*- posix interface
 *- code repository with install tools

eval.c

@@ -2035,7 +2035,7 @@ sexp sexp_load_dl (sexp ctx, sexp file, sexp env) {
 #endif
 
 sexp sexp_load (sexp ctx, sexp source, sexp env) {
-  sexp tmp, out;
+  sexp tmp, out=SEXP_FALSE;
   sexp_gc_var4(ctx2, x, in, res);
 #if USE_DL
   char *suffix = sexp_string_data(source)
@@ -2053,9 +2053,10 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) {
   tmp = sexp_env_bindings(env);
   sexp_context_tailp(ctx2) = 0;
   if (sexp_exceptionp(in)) {
-    if (! sexp_oportp(out))
+    if (sexp_not(out))
       out = sexp_env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE);
-    sexp_print_exception(ctx, in, out);
+    if (sexp_oportp(out))
+      sexp_print_exception(ctx, in, out);
     res = in;
   } else {
     sexp_port_sourcep(in) = 1;
@@ -2219,7 +2220,7 @@ static sexp sexp_copy_opcode (sexp ctx, sexp op) {
 
 sexp sexp_make_opcode (sexp ctx, sexp name, sexp op_class, sexp code,
                        sexp num_args, sexp flags, sexp arg1t, sexp arg2t,
-                       sexp invp, sexp data, sexp data2, sexp_proc0 func) {
+                       sexp invp, sexp data, sexp data2, sexp_proc1 func) {
   sexp res;
   if (! sexp_stringp(name))
     res = sexp_type_exception(ctx, "make-opcode: not a string", name);
@@ -2250,6 +2251,36 @@ sexp sexp_make_opcode (sexp ctx, sexp name, sexp op_class, sexp code,
   return res;
 }
 
+sexp sexp_make_foreign (sexp ctx, char *name, int num_args, sexp_proc1 f) {
+  sexp res;
+  if (num_args > 6) {
+    res = sexp_type_exception(ctx, "make-foreign: exceeded foreign arg limit",
+                              sexp_make_fixnum(num_args));
+  } else {
+    res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
+    sexp_opcode_class(res) = OPC_FOREIGN;
+    sexp_opcode_code(res) = OP_FCALL1+num_args-1;
+    sexp_opcode_num_args(res) = num_args;
+    sexp_opcode_name(res) = name;
+    sexp_opcode_func(res) = f;
+  }
+  return res;
+}
+
+sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name,
+                              int num_args, sexp_proc1 f) {
+  sexp_gc_var1(op);
+  sexp_gc_preserve1(ctx, op);
+  sexp res = SEXP_VOID;
+  op = sexp_make_foreign(ctx, name, num_args, (sexp_proc1)f);
+  if (sexp_exceptionp(op))
+    res = op;
+  else
+    sexp_env_define(ctx, env, sexp_intern(ctx, name), op);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
 #if USE_TYPE_DEFS
 
 sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) {
@@ -2389,16 +2420,23 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
   sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx));
   sexp_sint_t top = sexp_context_top(ctx), len, offset;
   len = sexp_unbox_fixnum(sexp_length(ctx, args));
-  offset = top + len;
+  if (sexp_opcodep(proc))
-  for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++)
+    proc = make_opcode_procedure(ctx, proc, len);
-    stack[--offset] = sexp_car(ls);
+  if (! sexp_procedurep(proc)) {
-  stack[top] = sexp_make_fixnum(len);
+    res = sexp_exceptionp(proc) ? proc :
-  top++;
+      sexp_type_exception(ctx, "apply: not a procedure", proc);
-  stack[top++] = sexp_make_fixnum(0);
+  } else {
-  stack[top++] = final_resumer;
+    offset = top + len;
-  stack[top++] = sexp_make_fixnum(0);
+    for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++)
-  sexp_context_top(ctx) = top;
+      stack[--offset] = sexp_car(ls);
-  res = sexp_vm(ctx, proc);
+    stack[top] = sexp_make_fixnum(len);
+    top++;
+    stack[top++] = sexp_make_fixnum(0);
+    stack[top++] = final_resumer;
+    stack[top++] = sexp_make_fixnum(0);
+    sexp_context_top(ctx) = top;
+    res = sexp_vm(ctx, proc);
+  }
   return res;
 }
 

include/chibi/eval.h

@@ -124,17 +124,20 @@ enum opcode_names {
 
 /**************************** prototypes ******************************/
 
-SEXP_API void sexp_scheme_init(void);
+SEXP_API void sexp_scheme_init (void);
-SEXP_API sexp sexp_apply(sexp context, sexp proc, sexp args);
+SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args);
-SEXP_API sexp sexp_eval(sexp context, sexp obj, sexp env);
+SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env);
-SEXP_API sexp sexp_eval_string(sexp context, char *str, sexp env);
+SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env);
-SEXP_API sexp sexp_load(sexp context, sexp expr, sexp env);
+SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env);
-SEXP_API sexp sexp_make_env(sexp context);
+SEXP_API sexp sexp_make_env (sexp context);
-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_API void sexp_env_define(sexp context, sexp env, sexp sym, sexp val);
+SEXP_API void sexp_env_define (sexp context, sexp env, sexp sym, sexp val);
-SEXP_API sexp sexp_make_context(sexp context, sexp stack, sexp env);
+SEXP_API sexp sexp_make_context (sexp context, sexp stack, sexp env);
-SEXP_API void sexp_warn_undefs(sexp ctx, sexp from, sexp to, sexp out);
+SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out);
-SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc0);
+SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
+SEXP_API sexp sexp_make_foreign (sexp ctx, char *name, int num_args, sexp_proc1 f);
+SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, sexp_proc1 f);
+#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,(sexp_proc1)f)
 
 #if USE_TYPE_DEFS
 SEXP_API sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type);

include/chibi/sexp.h

@@ -208,7 +208,7 @@ struct sexp_struct {
         arg1_type, arg2_type, inverse;
       char *name;
       sexp data, data2, proc;
-      sexp_proc0 func;
+      sexp_proc1 func;
     } opcode;
     struct {
       char code;

lib/srfi/69.module

@@ -0,0 +1,18 @@
+
+(define-module (srfi 69)
+  (export
+   make-hash-table hash-table? alist->hash-table
+   hash-table-equivalence-function hash-table-hash-function
+   hash-table-ref hash-table-ref/default hash-table-set!
+   hash-table-delete! hash-table-exists?
+   hash-table-update! hash-table-update!/default
+   hash-table-size hash-table-keys hash-table-values
+   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 (srfi 9))
+  (include "srfi/69/type.scm"
+           "srfi/69/hash.so"
+           "srfi/69/interface.scm"))
+

lib/srfi/69/hash.c

@@ -0,0 +1,196 @@
+
+#include <chibi/eval.h>
+
+#define HASH_DEPTH 5
+
+#define FNV_PRIME 16777619
+#define FNV_OFFSET_BASIS 2166136261uL
+
+#define sexp_hash_table_buckets(x)  sexp_slot_ref(x, 0)
+#define sexp_hash_table_size(x)     sexp_slot_ref(x, 1)
+#define sexp_hash_table_hash_fn(x)  sexp_slot_ref(x, 2)
+#define sexp_hash_table_eq_fn(x)    sexp_slot_ref(x, 3)
+
+static sexp_uint_t string_hash (char *str, sexp_uint_t bound) {
+  sexp_uint_t acc = FNV_OFFSET_BASIS;
+  while (*str) {acc *= FNV_PRIME; acc ^= *str++;}
+  return acc % bound;
+}
+
+static sexp sexp_string_hash (sexp ctx, sexp str, sexp bound) {
+  return sexp_make_fixnum(string_hash(sexp_string_data(str),
+                                      sexp_unbox_fixnum(bound)));
+}
+
+static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) {
+  sexp_uint_t acc = FNV_OFFSET_BASIS;
+  while (*str) {acc *= FNV_PRIME; acc ^= tolower(*str++);}
+  return acc % bound;
+}
+
+static sexp sexp_string_ci_hash (sexp ctx, sexp str, sexp bound) {
+  return sexp_make_fixnum(string_ci_hash(sexp_string_data(str),
+                                         sexp_unbox_fixnum(bound)));
+}
+
+static sexp_uint_t hash_one (sexp obj, sexp_uint_t bound, sexp_sint_t depth) {
+  sexp_uint_t acc = FNV_OFFSET_BASIS, size;
+  sexp_sint_t i, len;
+  sexp t, *p;
+  char *p0;
+ loop:
+#if USE_FLONUMS
+  if (sexp_flonump(obj))
+    acc ^= (sexp_sint_t) sexp_flonum_value(obj);
+  else
+#endif
+  if (sexp_pointerp(obj)) {
+    if (depth) {
+      t = &(sexp_type_specs[sexp_pointer_tag(obj)]);
+      p = (sexp*) (((char*)obj) + sexp_type_field_base(t));
+      p0 = ((char*)obj) + offsetof(struct sexp_struct, value);
+      if ((sexp)p == obj) p=(sexp*)p0;
+      /* hash trailing non-object data */
+      size = sexp_type_size_of_object(t, obj)-offsetof(struct sexp_struct, value);
+      p0 = ((char*)p + sexp_type_num_slots_of_object(t,obj)*sizeof(sexp));
+      if (((char*)obj + size) > p0)
+        for (i=0; i<size; i++) {acc *= FNV_PRIME; acc ^= p0[i];}
+      /* hash eq-object slots */
+      len = sexp_type_num_eq_slots_of_object(t, obj);
+      if (len > 0) {
+        depth--;
+        for (i=0; i<len-1; i++) {
+          acc *= FNV_PRIME;
+          acc ^= hash_one(p[i], 0, depth);
+        }
+        /* tail-recurse on the last value */
+        obj = p[len-1]; goto loop;
+      }
+    } else {
+      acc ^= sexp_pointer_tag(obj);
+    }
+  } else {
+    acc ^= (sexp_uint_t)obj;
+  }
+  return (bound ? acc % bound : acc);
+}
+
+static sexp_uint_t hash (sexp obj, sexp_uint_t bound) {
+  return hash_one(obj, bound, HASH_DEPTH);
+}
+
+static sexp sexp_hash (sexp ctx, sexp obj, sexp bound) {
+  return sexp_make_fixnum(hash(obj, sexp_unbox_fixnum(bound)));
+}
+
+static sexp sexp_hash_by_identity (sexp ctx, sexp obj, sexp bound) {
+  return sexp_make_fixnum((sexp_uint_t)obj % sexp_unbox_fixnum(bound));
+}
+
+static sexp sexp_get_bucket (sexp ctx, sexp ht, sexp obj) {
+  sexp_gc_var1(args);
+  sexp buckets = sexp_hash_table_buckets(ht), hash_fn, res;
+  sexp_uint_t len = sexp_vector_length(buckets);
+  hash_fn = sexp_hash_table_hash_fn(ht);
+  if (hash_fn == sexp_make_fixnum(1))
+    res = sexp_hash_by_identity(ctx, obj, sexp_make_fixnum(len));
+  else if (hash_fn == sexp_make_fixnum(2))
+    res = sexp_hash(ctx, obj, sexp_make_fixnum(len));
+  else {
+    sexp_gc_preserve1(ctx, args);
+    args = sexp_list2(ctx, obj, sexp_make_fixnum(len));
+    res = sexp_apply(ctx, hash_fn, args);
+    if (sexp_exceptionp(res)) {
+      args = sexp_eval_string(ctx, "(current-error-port)", sexp_context_env(ctx));
+      sexp_print_exception(ctx, res, args);
+      res = sexp_make_fixnum(0);
+    }
+    sexp_gc_release1(ctx);
+  }
+  return res;
+}
+
+static sexp sexp_scan_bucket (sexp ctx, sexp ls, sexp obj, sexp eq_fn) {
+  sexp_gc_var1(res);
+  sexp p;
+  res = SEXP_FALSE;
+  if ((eq_fn == sexp_make_fixnum(1))
+      || ((eq_fn == sexp_make_fixnum(2))
+          && (sexp_pointerp(obj) ?
+              (sexp_pointer_tag(obj) == SEXP_SYMBOL) : ! sexp_fixnump(obj)))) {
+    for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) {
+      if (sexp_caar(p) == obj) {
+        res = p;
+        break;
+      }
+    }
+  } else if (eq_fn == sexp_make_fixnum(2)) {
+    for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) {
+      if (sexp_truep(sexp_equalp(ctx, sexp_caar(p), obj))) {
+        res = p;
+        break;
+      }
+    }
+  } else {
+    sexp_gc_preserve1(ctx, res);
+    for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) {
+      res = sexp_list2(ctx, sexp_caar(p), obj);
+      if (sexp_truep(sexp_apply(ctx, eq_fn, res))) {
+        res = p;
+        break;
+      } else {
+        res = SEXP_FALSE;
+      }
+    }
+    sexp_gc_release1(ctx);
+  }
+  return res;
+}
+
+static sexp sexp_hash_table_cell (sexp ctx, sexp ht, sexp obj, sexp createp) {
+  sexp_gc_var1(res);
+  sexp_uint_t size;
+  sexp buckets=sexp_hash_table_buckets(ht), eq_fn=sexp_hash_table_eq_fn(ht),
+    i=sexp_get_bucket(ctx, ht, obj);
+  res = sexp_scan_bucket(ctx, sexp_vector_ref(buckets, i), obj, eq_fn);
+  if (sexp_truep(res)) {
+    res = sexp_car(res);
+  } else if (sexp_truep(createp)) {
+    sexp_gc_preserve1(ctx, res);
+    size = sexp_unbox_fixnum(sexp_hash_table_size(ht));
+    res = sexp_cons(ctx, obj, createp);
+    sexp_vector_set(buckets, i, sexp_cons(ctx, res, sexp_vector_ref(buckets, i)));
+    sexp_hash_table_size(ht) = sexp_make_fixnum(size+1);
+    sexp_gc_release1(ctx);
+  }
+  return res;
+}
+
+static sexp sexp_hash_table_delete (sexp ctx, sexp ht, sexp obj) {
+  sexp buckets=sexp_hash_table_buckets(ht), eq_fn=sexp_hash_table_eq_fn(ht),
+    i=sexp_get_bucket(ctx, ht, obj), p, res;
+  res = sexp_scan_bucket(ctx, sexp_vector_ref(buckets, i), obj, eq_fn);
+  if (sexp_pairp(res)) {
+    if (res == sexp_vector_ref(buckets, i)) {
+      sexp_vector_set(buckets, i, sexp_cdr(res));
+    } else {
+      for (p=sexp_vector_ref(buckets, i); sexp_cdr(p)!=res; p=sexp_cdr(p))
+        ;
+      sexp_cdr(p) = sexp_cdr(res);
+    }
+  }
+  return SEXP_VOID;
+}
+
+sexp sexp_init_library (sexp ctx, sexp env) {
+
+  sexp_define_foreign(ctx, env, "string-hash", 2, sexp_string_hash);
+  sexp_define_foreign(ctx, env, "string-ci-hash", 2, sexp_string_ci_hash);
+  sexp_define_foreign(ctx, env, "hash", 2, sexp_hash);
+  sexp_define_foreign(ctx, env, "hash-by-identity", 2, sexp_hash_by_identity);
+  sexp_define_foreign(ctx, env, "hash-table-cell", 3, sexp_hash_table_cell);
+  sexp_define_foreign(ctx, env, "hash-table-delete!", 2, sexp_hash_table_delete);
+
+  return SEXP_VOID;
+}
+

lib/srfi/69/interface.scm

@@ -0,0 +1,110 @@
+
+(define (make-hash-table . o)
+  (let ((eq-fn (if (pair? o) (car o) equal?))
+        (hash-fn (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) hash)))
+    (cond
+     ((not (procedure? eq-fn))
+      (error "make-hash-table: bad equivalence function" eq-fn))
+     ((not (procedure? hash-fn))
+      (error "make-hash-table: bad hash function" hash-fn))
+     (else
+      (%make-hash-table
+       (make-vector 23 '())
+       0
+       (if (eq? hash-fn hash-by-identity) 1 (if (eq? hash-fn hash) 2 hash-fn))
+       (if (eq? eq-fn eq?) 1 (if (eq? eq-fn equal?) 2 eq-fn)))))))
+
+(define (hash-table-hash-function table)
+  (let ((f (%hash-table-hash-function table)))
+    (case f ((1) hash-by-identity) ((2) hash) (else f))))
+
+(define (hash-table-equivalence-function table)
+  (let ((f (%hash-table-equivalence-function table)))
+    (case f ((1) eq?) ((2) equal?) (else f))))
+
+(define-syntax assert-hash-table
+  (syntax-rules ()
+    ((assert-hash-table from obj)
+     (if (not (hash-table? obj))
+         (error (string-append from ": not a hash-table") obj)))))
+
+(define (hash-table-ref table key . o)
+  (assert-hash-table "hash-table-ref" table)
+  (let ((cell (hash-table-cell table key #f)))
+    (cond (cell (cdr cell))
+          ((pair? o) ((car o)))
+          (else (error "hash-table-ref: key not found" key)))))
+
+(define (hash-table-ref/default table key default)
+  (assert-hash-table "hash-table-ref/default" table)
+  (let ((cell (hash-table-cell table key #f)))
+    (if cell (cdr cell) default)))
+
+(define (hash-table-set! table key value)
+  (assert-hash-table "hash-table-set!" table)
+  (let ((cell (hash-table-cell table key #t)))
+    (set-cdr! cell value)))
+
+(define (hash-table-exists? table key)
+  (assert-hash-table "hash-table-exists?" table)
+  (and (hash-table-cell table key #f) #t))
+
+(define hash-table-update!
+  (let ((not-found (cons 'not-found '())))
+    (lambda (table key func . o)
+      (assert-hash-table "hash-table-update!" table)
+      (let ((cell (hash-table-cell table key not-found)))
+        (set-cdr! cell (if (eq? not-found (cdr cell))
+                           (if (pair? o)
+                               (func ((car o)))
+                               (error "hash-table-update!: key not found" key))
+                           (func (cdr cell))))))))
+
+(define hash-table-update!/default
+  (let ((not-found (cons 'not-found '())))
+    (lambda (table key func default)
+      (assert-hash-table "hash-table-update!/default" table)
+      (let ((cell (hash-table-cell table key not-found)))
+        (set-cdr! cell (func (if (eq? not-found (cdr cell)) default (cdr cell))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (hash-table-fold table kons knil)
+  (assert-hash-table "hash-table-fold" table)
+  (let ((vec (hash-table-buckets table)))
+    (let lp1 ((i (- (vector-length vec) 1)) (acc knil))
+      (if (< i 0)
+          acc
+          (let lp2 ((ls (vector-ref vec i)) (acc acc))
+            (if (null? ls)
+                (lp1 (- i 1) acc)
+                (lp2 (cdr ls) (kons (car (car ls)) (cdr (car ls)) acc))))))))
+
+(define (hash-table-walk table proc)
+  (hash-table-fold table (lambda (k v a) (proc k v)) #f)
+  (if #f #f))
+
+(define (hash-table->alist table)
+  (hash-table-fold table (lambda (k v a) (cons (cons k v) a)) '()))
+
+(define (hash-table-keys table)
+  (hash-table-fold table (lambda (k v a) (cons k a)) '()))
+
+(define (hash-table-values table)
+  (hash-table-fold table (lambda (k v a) (cons v a)) '()))
+
+(define (alist->hash-table ls . o)
+  (let ((res (apply make-hash-table o)))
+    (for-each (lambda (x) (hash-table-set! res (car x) (cdr x))) ls)
+    res))
+
+(define (hash-table-merge! a b)
+  (hash-table-walk b (lambda (k v) (hash-table-set! a k v)))
+  a)
+
+(define (hash-table-copy table)
+  (assert-hash-table "hash-table-copy" table)
+  (let ((res (make-hash-table (hash-table-equivalence-function table))))
+    (hash-table-merge! res table)
+    res))
+

lib/srfi/69/type.scm

@@ -0,0 +1,9 @@
+
+(define-record-type hash-table
+  (%make-hash-table buckets size hash-fn eq-fn)
+  hash-table?
+  (buckets hash-table-buckets hash-table-buckets-set!)
+  (size hash-table-size hash-table-size-set!)
+  (hash-fn %hash-table-hash-function)
+  (eq-fn %hash-table-equivalence-function))
+

lib/srfi/9.module

@@ -20,6 +20,30 @@
             (let lp ((ls ls) (i 0))
               (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1)))))
           `(,(rename 'begin)
+            (,_define ,pred (,(rename 'make-type-predicate)
+                             ,(symbol->string pred)
+                             ,index))
+            ,@(let lp ((ls fields) (i 0) (res '()))
+                (if (null? ls)
+                    res
+                    (let ((res
+                           (cons `(,_define ,(cadar ls)
+                                    (,(rename 'make-getter)
+                                     ,(symbol->string (cadar ls))
+                                     ,index
+                                     ,i))
+                                 res)))
+                      (lp (cdr ls)
+                          (+ i 1)
+                          (if (pair? (cddar ls))
+                              (cons
+                               `(,_define ,(caddar ls)
+                                  (,(rename 'make-setter)
+                                   ,(symbol->string (caddar ls))
+                                   ,index
+                                   ,i))
+                               res)
+                              res)))))
             (,_define ,make
               ,(let lp ((ls make-fields) (sets '()) (set-defs '()))
                  (cond
@@ -54,29 +78,5 @@
                                                setter-name
                                                index
                                                (index-of (car ls) fields)))
-                                   set-defs))))))))))
+                                   set-defs)))))))))))))))))
-            (,_define ,pred (,(rename 'make-type-predicate)
-                             ,(symbol->string pred)
-                             ,index))
-            ,@(let lp ((ls fields) (i 0) (res '()))
-                (if (null? ls)
-                    res
-                    (let ((res
-                           (cons `(,_define ,(cadar ls)
-                                    (,(rename 'make-getter)
-                                     ,(symbol->string (cadar ls))
-                                     ,index
-                                     ,i))
-                                 res)))
-                      (lp (cdr ls)
-                          (+ i 1)
-                          (if (pair? (cddar ls))
-                              (cons
-                               `(,_define ,(caddar ls)
-                                  (,(rename 'make-setter)
-                                   ,(symbol->string (caddar ls))
-                                   ,index
-                                   ,i))
-                               res)
-                              res))))))))))))
 

opcodes.c

@@ -2,7 +2,7 @@
 #define _OP(c,o,n,m,t,u,i,s,d,f)                                \
   {.tag=SEXP_OPCODE,                                            \
       .value={.opcode={c, o, n, m, t, u, i, s, d, NULL, NULL, f}}}
-#define _FN(o,n,m,t,u,s,f,p) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, f, (sexp_proc0)p)
+#define _FN(o,n,m,t,u,s,f,p) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, f, (sexp_proc1)p)
 #define _FN0(s, f, d) _FN(OP_FCALL0, 0, 0, 0, 0, s, f, d)
 #define _FN1(t, s, f, d) _FN(OP_FCALL1, 1, 0, t, 0, s, f, d)
 #define _FN2(t, u, s, f, d) _FN(OP_FCALL2, 2, 0, t, u, s, f, d)

sexp.c

@@ -446,7 +446,7 @@ sexp sexp_equalp (sexp ctx, sexp a, sexp b) {
     q0 = ((char*)q + sexp_type_num_slots_of_object(t,b)*sizeof(sexp));
     if (size != sexp_type_size_of_object(t,b)-offsetof(struct sexp_struct,value))
       return SEXP_FALSE;
-    if (memcmp(p0, q0, size-((char*)p0-(char*)p)))
+    if (memcmp(p0, q0, size))
       return SEXP_FALSE;
   }
   /* check eq-object slots */