adding srfi-99

Makefile

@@ -200,6 +200,9 @@ test-loop: chibi-scheme$(EXE)
 test-sort: chibi-scheme$(EXE)
 	LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/sort-tests.scm
 
+test-records: chibi-scheme$(EXE)
+	LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/record-tests.scm
+
 test-libs: chibi-scheme$(EXE)
 	LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/lib-tests.scm
 

eval.c

@@ -1288,6 +1288,73 @@ sexp sexp_string_utf8_index_set (sexp ctx sexp_api_params(self, n), sexp str, se
 
 /***************************** opcodes ********************************/
 
+#if SEXP_USE_TYPE_DEFS
+
+sexp sexp_type_slot_offset_op (sexp ctx  sexp_api_params(self, n), sexp type, sexp slot) {
+  sexp cpl, slots, *v;
+  int i, offset=0, len;
+  sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, type);
+  cpl = sexp_type_cpl(type);
+  if (sexp_vectorp(cpl)) {
+    v = sexp_vector_data(cpl);
+    len = sexp_vector_length(cpl);
+  } else {
+    v = &sexp_type_slots(type);
+    len = 1;
+  }
+  len = sexp_vectorp(cpl) ? sexp_vector_length(cpl) : 1;
+  for (i=0; i<len; i++)
+    for (slots=sexp_type_slots(v[i]); sexp_pairp(slots); slots=sexp_cdr(slots), offset++)
+      if (sexp_car(slots) == slot)
+        return sexp_make_fixnum(offset);
+  return SEXP_FALSE;
+}
+
+sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) {
+  if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type);
+  return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE),
+                          sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO,
+                          SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL);
+}
+
+sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) {
+  sexp_uint_t type_size;
+  if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
+  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type);
+  type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type)));
+  return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR),
+                          sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO,
+                          SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type,
+                          sexp_make_fixnum(type_size), NULL);
+}
+
+sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) {
+  if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
+  if ((! sexp_fixnump(type))  || (sexp_unbox_fixnum(type) < 0))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, type);
+  if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, index);
+  return
+    sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_GETTER),
+                     sexp_make_fixnum(SEXP_OP_SLOT_REF), SEXP_ONE, SEXP_ZERO,
+                     type, SEXP_ZERO, SEXP_ZERO, type, index, NULL);
+}
+
+sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) {
+  if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
+  if ((! sexp_fixnump(type))  || (sexp_unbox_fixnum(type) < 0))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, type);
+  if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0))
+    return sexp_type_exception(ctx, self, SEXP_FIXNUM, index);
+  return
+    sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_SETTER),
+                     sexp_make_fixnum(SEXP_OP_SLOT_SET), SEXP_TWO, SEXP_ZERO,
+                     type, SEXP_ZERO, SEXP_ZERO, type, index, NULL);
+}
+
+#endif
+
 #include "opcodes.c"
 
 static sexp sexp_copy_core (sexp ctx, struct sexp_core_form_struct *core) {
@@ -1383,53 +1450,6 @@ sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_ar
   return res;
 }
 
-#if SEXP_USE_TYPE_DEFS
-
-sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) {
-  if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
-  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type);
-  return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE),
-                          sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO,
-                          SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type, NULL, NULL);
-}
-
-sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) {
-  sexp_uint_t type_size;
-  if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
-  sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type);
-  type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type)));
-  return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR),
-                          sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO,
-                          SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type,
-                          sexp_make_fixnum(type_size), NULL);
-}
-
-sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) {
-  if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
-  if ((! sexp_fixnump(type))  || (sexp_unbox_fixnum(type) < 0))
-    return sexp_type_exception(ctx, self, SEXP_FIXNUM, type);
-  if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0))
-    return sexp_type_exception(ctx, self, SEXP_FIXNUM, index);
-  return
-    sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_GETTER),
-                     sexp_make_fixnum(SEXP_OP_SLOT_REF), SEXP_ONE, SEXP_ZERO,
-                     type, SEXP_ZERO, SEXP_ZERO, type, index, NULL);
-}
-
-sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) {
-  if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
-  if ((! sexp_fixnump(type))  || (sexp_unbox_fixnum(type) < 0))
-    return sexp_type_exception(ctx, self, SEXP_FIXNUM, type);
-  if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0))
-    return sexp_type_exception(ctx, self, SEXP_FIXNUM, index);
-  return
-    sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_SETTER),
-                     sexp_make_fixnum(SEXP_OP_SLOT_SET), SEXP_TWO, SEXP_ZERO,
-                     type, SEXP_ZERO, SEXP_ZERO, type, index, NULL);
-}
-
-#endif
-
 #if SEXP_USE_STATIC_LIBS
 #include "clibs.c"
 #endif

lib/chibi/ast.c

@@ -137,6 +137,29 @@ static sexp sexp_type_of (sexp ctx sexp_api_params(self, n), sexp x) {
     return sexp_type_by_index(ctx, SEXP_OBJECT);
 }
 
+static sexp sexp_type_name_op (sexp ctx sexp_api_params(self, n), sexp t) {
+  sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
+  return sexp_c_string(ctx, sexp_type_name(t), -1);
+}
+
+static sexp sexp_type_cpl_op (sexp ctx sexp_api_params(self, n), sexp t) {
+  sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
+  return sexp_type_cpl(t);
+}
+
+static sexp sexp_type_slots_op (sexp ctx sexp_api_params(self, n), sexp t) {
+  sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
+  return sexp_type_slots(t);
+}
+
+static sexp sexp_object_size (sexp ctx sexp_api_params(self, n), sexp x) {
+  sexp t;
+  if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
+    return SEXP_ZERO;
+  t = sexp_object_type(ctx, x);
+  return sexp_make_fixnum(sexp_type_size_of_object(t, x));
+}
+
 static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) {
   sexp ctx2 = ctx;
   if (sexp_envp(e)) {
@@ -243,6 +266,10 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
   sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type);
   sexp_define_foreign(ctx, env, "optimize", 1, sexp_optimize);
   sexp_define_foreign(ctx, env, "type-of", 1, sexp_type_of);
+  sexp_define_foreign(ctx, env, "type-name", 1, sexp_type_name_op);
+  sexp_define_foreign(ctx, env, "type-cpl", 1, sexp_type_cpl_op);
+  sexp_define_foreign(ctx, env, "type-slots", 1, sexp_type_slots_op);
+  sexp_define_foreign(ctx, env, "object-size", 1, sexp_object_size);
   return SEXP_VOID;
 }
 

lib/chibi/ast.module

@@ -26,7 +26,9 @@
    exception-irritants exception-irritants-set!
    opcode-name opcode-num-params opcode-return-type opcode-param-type
    opcode-variadic?
-   procedure-code procedure-vars procedure-name bytecode-name)
+   procedure-code procedure-vars procedure-name bytecode-name
+   type? type-name type-cpl type-parent type-slots
+   object-size)
   (import-immutable (scheme))
   (include-shared "ast")
   (include "ast.scm"))

lib/chibi/ast.scm

@@ -89,3 +89,8 @@
        ((opcode? x) (or (opcode-name x) x))
        (else x)))))
 
+(define (type-parent x)
+  (let ((v (type-cpl x)))
+    (and (vector? v)
+         (> (vector-length v) 1)
+         (vector-ref v (- (vector-length v) 2)))))

lib/srfi/9.scm

@@ -12,11 +12,9 @@
             (_define (rename 'define))
             (_lambda (rename 'lambda))
             (_let (rename 'let))
-            (_register (rename 'register-simple-type)))
-       (define (index-of field ls)
-         (let lp ((ls ls) (i 0))
-           (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1)))))
-       (write `(name: ,name parent: ,parent)) (newline)
+            (_register (rename 'register-simple-type))
+            (_slot-set! (rename 'slot-set!))
+            (_type_slot_offset (rename 'type-slot-offset)))
        `(,(rename 'begin)
          ;; type
          (,_define ,name (,_register ,name-str ,parent ',fields))
@@ -25,63 +23,44 @@
                           ,(symbol->string (identifier->symbol pred))
                           ,name))
          ;; fields
-         ,@(let lp ((ls fields) (i 0) (res '()))
-             (if (null? ls)
-                 res
-                 (let ((res
-                        (cons `(,_define ,(cadar ls)
-                                 (,(rename 'make-getter)
-                                  ,(symbol->string
-                                    (identifier->symbol (cadar ls)))
-                                  ,name
-                                  ,i))
-                              res)))
-                   (lp (cdr ls)
-                       (+ i 1)
-                       (if (pair? (cddar ls))
-                           (cons
-                            `(,_define ,(caddar ls)
-                               (,(rename 'make-setter)
-                                ,(symbol->string
-                                  (identifier->symbol (caddar ls)))
-                                ,name
-                                ,i))
-                            res)
-                           res)))))
+         ,@(map (lambda (f)
+                  (and (pair? f) (pair? (cdr f))
+                       `(,_define ,(cadar ls)
+                                  (,(rename 'make-getter)
+                                   ,(symbol->string
+                                     (identifier->symbol (cadr f)))
+                                   ,name
+                                   (,_type_slot_offset ,name ,(car f))))))
+                fields)
+         ,@(map (lambda (f)
+                  (and (pair? f) (pair? (cdr f)) (pair? (cddr f))
+                       `(,_define ,(caddar ls)
+                                  (,(rename 'make-setter)
+                                   ,(symbol->string
+                                     (identifier->symbol (caddr f)))
+                                   ,name
+                                   (,_type_slot_offset ,name ,(car f))))))
+                fields)
          ;; constructor
          (,_define ,make
-           ,(let lp ((ls make-fields) (sets '()) (set-defs '()))
-              (cond
-               ((null? ls)
-                `(,_let ((%make (,(rename 'make-constructor)
-                                 ,(symbol->string (identifier->symbol make))
-                                 ,name))
-                         ,@set-defs)
-                   (,_lambda ,make-fields
-                     (,_let ((res (%make)))
-                       ,@sets
-                       res))))
-               (else
-                (let ((field (assq (car ls) fields)))
-                  (cond
-                   ((not field)
-                    (error "unknown record field in constructor" (car ls)))
-                   ((pair? (cddr field))
-                    (lp (cdr ls)
-                        (cons (list (caddr field) 'res (car ls)) sets)
-                        set-defs))
-                   (else
-                    (let* ((setter-name
-                            (string-append "%" name-str "-"
-                                           (symbol->string (car ls)) "-set!"))
-                           (setter (rename (string->symbol setter-name)))
-                           (i (index-of (car ls) fields)))
-                      (lp (cdr ls)
-                          (cons (list setter 'res (car ls)) sets)
-                          (cons (list setter
-                                      (list (rename 'make-setter)
-                                            setter-name
-                                            name
-                                            (index-of (car ls) fields)))
-                                set-defs))))))))))
-         (display "done\n"))))))
+                   ,(let lp ((ls make-fields) (sets '()))
+                      (cond
+                       ((null? ls)
+                        `(,_let ((%make (,(rename 'make-constructor)
+                                         ,(symbol->string (identifier->symbol make))
+                                         ,name)))
+                                (,_lambda ,make-fields
+                                          (,_let ((res (%make)))
+                                                 ,@sets
+                                                 res))))
+                       (else
+                        (let ((field (assq (car ls) fields)))
+                          (cond
+                           ((not field)
+                            (error "unknown record field in constructor" (car ls)))
+                           ((pair? (cddr field))
+                            (lp (cdr ls)
+                                (cons (list (caddr field) 'res (car ls)) sets)))
+                           (else
+                            (lp (cdr ls)
+                                (cons (list _slot-set! 'res (list 'quote (car ls)) (car ls)) sets))))))))))))))

lib/srfi/99.module

@@ -0,0 +1,7 @@
+
+(define-module (srfi 99)
+  (import (srfi 99 records))
+  (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator
+          record? record-rtd rtd-name rtd-parent
+          rtd-field-names rtd-all-field-names rtd-field-mutable?
+          define-record-type))

lib/srfi/99/records.module

@@ -0,0 +1,9 @@
+
+(define-module (srfi 99 records)
+  (import (srfi 99 records procedural)
+          (srfi 99 records inspection)
+          (srfi 99 records syntactic))
+  (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator
+          record? record-rtd rtd-name rtd-parent
+          rtd-field-names rtd-all-field-names rtd-field-mutable?
+          define-record-type))

lib/srfi/99/records/inspection.module

@@ -0,0 +1,7 @@
+
+(define-module (srfi 99 records inspection)
+  (export record? record-rtd rtd-name rtd-parent
+          rtd-field-names rtd-all-field-names rtd-field-mutable?)
+  (import-immutable (scheme))
+  (import (chibi ast))
+  (include "inspection.scm"))

lib/srfi/99/records/inspection.scm

@@ -0,0 +1,34 @@
+
+(define (record? x)
+  (is-a? x <object>))
+
+(define (record-rtd x)
+  (type-of x))
+
+(define (rtd-name x) (type-name x))
+
+(define (rtd-parent x) (type-parent x))
+
+(define (rtd-field-names x)
+  (list->vector
+   (map (lambda (x) (if (pair? x) (cadr x) x)) (type-slots x))))
+
+(define (rtd-all-field-names x)
+  (let lp ((x x) (res '()))
+    (let ((res (append (vector->list (rtd-field-names x)) res)))
+      (let ((p (type-parent x)))
+        (if (type? p)
+            (lp p res)
+            (list->vector res))))))
+
+(define (rtd-field-mutable? rtd x)
+  (let lp ((ls (type-slots rtd)))
+    (cond ((null? ls)
+           (let ((p (type-parent rtd)))
+             (if (type? p)
+                 (rtd-field-mutable? p x)
+                 (error "unknown field" rtd x))))
+          ((eq? x (car ls)))
+          ((and (pair? (car ls)) (eq? x (cadar ls)))
+           (not (eq? 'immutable (caar ls))))
+          (else (lp (cdr ls))))))

lib/srfi/99/records/procedural.module

@@ -0,0 +1,6 @@
+
+(define-module (srfi 99 records procedural)
+  (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator)
+  (import-immutable (scheme))
+  (import (chibi ast) (srfi 99 records inspection))
+  (include "procedural.scm"))

lib/srfi/99/records/procedural.scm

@@ -0,0 +1,51 @@
+
+(define (make-rtd name fields . o)
+  (let ((parent (and (pair? o) (car o))))
+    (register-simple-type name (vector->list fields) parent)))
+
+(define (rtd? x)
+  (type? x))
+
+(define (rtd-constructor rtd . o)
+  (let ((fields (vector->list (if (pair? o) (car o) (rtd-all-field-names))))
+        (make (make-constructor (type-name rtd) rtd)))
+    (lambda args
+      (let ((res (make)))
+        (let lp ((a args) (p fields))
+          (cond
+           ((null? a) (if (null? p) res (error "not enough args" p)))
+           ((null? p) (error "too many args" a))
+           (else
+            (slot-set! res rtd (car p) (car a))
+            (lp (cdr a) (cdr p)))))))))
+
+(define (rtd-predicate rtd)
+  (make-type-predicate (type-name rtd) rtd))
+
+(define (field-index-of ls field)
+  (let lp ((i 0) (ls ls))
+    (cond ((null? ls ) #f)
+          ((if (pair? (car ls))
+               (eq? field (cadar ls))
+               (eq? field (car ls)))
+           i)
+          (else (lp (+ i 1) (cdr ls))))))
+
+(define (rtd-field-offset rtd field)
+  (let ((p (type-parent rtd)))
+    (or (and (type? p)
+             (rtd-field-offset p field))
+        (let ((i (field-index-of (type-slots rtd) field)))
+          (and i
+               (if (type? p)
+                   (+ i (vector-length (rtd-all-field-names p)))
+                   i))))))
+
+(define (rtd-accessor rtd field)
+  (make-getter rtd (type-name rtd) (rtd-field-offset rtd field)))
+
+(define (rtd-mutator rtd field)
+  (if (rtd-field-mutable? rtd field)
+      (make-setter rtd (type-name rtd) (rtd-field-offset rtd field))
+      (error "can't make mutator for immutable field" rtd field)))
+

lib/srfi/99/records/syntactic.module

@@ -0,0 +1,6 @@
+
+(define-module (srfi 99 records syntactic)
+  (export define-record-type)
+  (import-immutable (scheme))
+  (import (srfi 99 records inspection))
+  (include "syntactic.scm"))

lib/srfi/99/records/syntactic.scm

@@ -0,0 +1,109 @@
+
+(define-syntax define-record-type
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let* ((id->string (lambda (x) (symbol->string (identifier->symbol x))))
+            (name (if (pair? (cadr expr)) (caadr expr) (cadr expr)))
+            (parent (and (pair? (cadr expr)) (cadadr expr)))
+            (name-str (id->string name))
+            (make (caddr expr))
+            (make-name (if (eq? make #t)
+                           (string->symbol (string-append "make-" name-str))
+                           (if (pair? make) (car make) make)))
+            (pred (cadddr expr))
+            (pred-name (if (eq? pred #t)
+                           (string->symbol (string-append name-str "?"))
+                           pred))
+            (fields (cddddr expr))
+            (field-names (map (lambda (x) (if (pair? x) (car x) x)) fields))
+            (make-fields (if (pair? make) (cdr make) (and (not parent) field-names)))
+            (_define (rename 'define))
+            (_lambda (rename 'lambda))
+            (_let (rename 'let))
+            (_register (rename 'register-simple-type))
+            (_slot-set! (rename 'slot-set!))
+            (_vector->list (rename 'vector->list))
+            (_type_slot_offset (rename 'type-slot-offset))
+            (_rtd-all-field-names (rename 'rtd-all-field-names)))
+       `(,(rename 'begin)
+         ;; type
+         (,_define ,name (,_register ,name-str ,parent ',field-names))
+         ;; predicate
+         ,@(if pred-name
+               `((,_define ,pred-name
+                           (,(rename 'make-type-predicate)
+                            ,(id->string pred-name)
+                            ,name)))
+               #f)
+         ;; accessors
+         ,@(map (lambda (f)
+                  (let ((g (if (and (pair? f) (pair? (cdr f)))
+                               (cadr f)
+                               (and (identifier? f)
+                                    (string->symbol
+                                     (string-append name-str "-" (id->string f)))))))
+                    (and g
+                         `(,_define ,g
+                                    (,(rename 'make-getter)
+                                     ,(id->string g)
+                                     ,name
+                                     (,_type_slot_offset ,name ',(if (pair? f) (car f) f)))))))
+                fields)
+         ,@(map (lambda (f)
+                  (let ((s (if (and (pair? f) (pair? (cdr f)) (pair? (cddr f)))
+                               (caddr f)
+                               (and (identifier? f)
+                                    (string->symbol
+                                     (string-append name-str "-" (id->string f) "-set!"))))))
+                    (and s
+                         `(,_define ,s
+                                    (,(rename 'make-setter)
+                                     ,(id->string s)
+                                     ,name
+                                     (,_type_slot_offset ,name ',(if (pair? f) (car f) f)))))))
+                fields)
+         ;; constructor
+         ,(if make-fields
+             `(,_define ,make-name
+                       ,(let lp ((ls make-fields) (sets '()))
+                          (cond
+                           ((null? ls)
+                            `(,_let ((%make (,(rename 'make-constructor)
+                                             ,(id->string make-name)
+                                             ,name)))
+                                    (,_lambda ,make-fields
+                                              (,_let ((res (%make)))
+                                                     ,@sets
+                                                     res))))
+                           (else
+                            (let ((field (assq (car ls) fields)))
+                              (cond
+                               ;;((not field)
+                               ;; (error "unknown record field in constructor" (car ls)))
+                               ((and (pair? field) (pair? (cdr field)) (pair? (cddr field)))
+                                (lp (cdr ls)
+                                    (cons (list (caddr field) 'res (car ls)) sets)))
+                               (else
+                                (lp (cdr ls)
+                                    (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) sets)))))))))
+             `(,_define ,make-name
+                        (,_let ((%make (,(rename 'make-constructor)
+                                        ,(id->string make-name)
+                                        ,name)))
+                               (,_lambda args
+                                         (,_let ((res (%make)))
+                                                (let lp ((a args)
+                                                         (p (,_vector->list (,_rtd-all-field-names ,name))))
+                                                  (cond
+                                                   ((null? a)
+                                                    (if (null? p)
+                                                        res
+                                                        (error ,(string-append "not enough arguments to " (id->string make-name) ": missing")
+                                                               p)))
+                                                   ((null? p)
+                                                    (error ,(string-append "too many arguments to " (id->string make-name))
+                                                           a))
+                                                   (else
+                                                    (,_slot-set! ,name res (,_type_slot_offset ,name (car p)) (car a))
+                                                    (lp (cdr a) (cdr p)))))))))
+             ))))))

opcodes.c

@@ -37,8 +37,6 @@ _OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, SEXP_VOID, _I(SEXP_STRING), _I(SE
 #endif
 #endif
 _OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_STRING), SEXP_FALSE, SEXP_FALSE, 0,"string-length", 0, NULL),
-_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF, 3, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0, "slot-ref", 0, NULL),
-_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET, 4, 0, SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0,"slot-set!", 0, NULL),
 _OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, _I(SEXP_FLONUM), _I(SEXP_NUMBER), SEXP_FALSE, SEXP_FALSE, 0, "exact->inexact", 0, NULL),
 _OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_NUMBER), SEXP_FALSE, SEXP_FALSE, 0, "inexact->exact", 0, NULL),
 _OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char->integer", 0, NULL),
@@ -159,6 +157,9 @@ _FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-type-predicate", 0
 _FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-constructor", 0, sexp_make_constructor_op),
 _FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-getter", 0, sexp_make_getter_op),
 _FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-setter", 0, sexp_make_setter_op),
+_FN2(_I(SEXP_OPCODE), _I(SEXP_TYPE), _I(SEXP_SYMBOL), "type-slot-offset", 0, sexp_type_slot_offset_op),
+_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF, 3, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0, "slot-ref", 0, NULL),
+_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET, 4, 0, SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0,"slot-set!", 0, NULL),
 #endif
 #if PLAN9
 #include "opt/plan9-opcodes.c"

sexp.c

@@ -173,6 +173,7 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name,
     type = sexp_type_by_index(ctx, num_types);
     sexp_pointer_tag(type) = SEXP_TYPE;
     sexp_type_tag(type) = num_types;
+    sexp_type_slots(type) = slots;
     sexp_type_field_base(type) = sexp_unbox_fixnum(fb);
     sexp_type_field_eq_len_base(type) = sexp_unbox_fixnum(felb);
     sexp_type_field_len_base(type) = sexp_unbox_fixnum(flb);

tests/match-tests.scm

@@ -132,4 +132,103 @@
      (list tag attrs text))
     (else #f)))
 
+(test "joined tail" '(1 2)
+      (match '(1 2 3) ((and (a ... b) x) a)))
+    (((x . y) ... u v w) (list x y u v w))))
+
+(test "Riastradh quasiquote" '(2 3)
+  (match '(1 2 3) (`(1 ,b ,c) (list b c))))
+
+(test "trivial tree search" '(1 2 3)
+  (match '(1 2 3) ((_ *** (a b c)) (list a b c))))
+
+(test "simple tree search" '(1 2 3)
+  (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))))
+
+(test "deep tree search" '(1 2 3)
+  (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))))
+
+(test "non-tail tree search" '(1 2 3)
+  (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))))
+
+(test "restricted tree search" '(1 2 3)
+  (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))))
+
+(test "fail restricted tree search" #f
+  (match '(x (y (x a b c (1 2 3) d e f)))
+    (('x *** (a b c)) (list a b c))
+    (else #f)))
+
+(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode"))
+  (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
+    (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...))
+     (list attrs text))
+    (else #f)))
+
+(test "failed sxml tree search" #f
+  (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
+    (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...))
+     (list attrs text))
+    (else #f)))
+
+(test "collect tree search"
+    '((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))
+  (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
+    (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...))
+     (list tag attrs text))
+    (else #f)))
+
+(test "joined tail" '(1 2)
+      (match '(1 2 3) ((and (a ... b) x) a)))
+
+    (((x . y) ... u v w) (list x y u v w))))
+
+(test "Riastradh quasiquote" '(2 3)
+  (match '(1 2 3) (`(1 ,b ,c) (list b c))))
+
+(test "trivial tree search" '(1 2 3)
+  (match '(1 2 3) ((_ *** (a b c)) (list a b c))))
+
+(test "simple tree search" '(1 2 3)
+  (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))))
+
+(test "deep tree search" '(1 2 3)
+  (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))))
+
+(test "non-tail tree search" '(1 2 3)
+  (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))))
+
+(test "restricted tree search" '(1 2 3)
+  (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))))
+
+(test "fail restricted tree search" #f
+  (match '(x (y (x a b c (1 2 3) d e f)))
+    (('x *** (a b c)) (list a b c))
+    (else #f)))
+
+(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode"))
+  (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
+    (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...))
+     (list attrs text))
+    (else #f)))
+
+(test "failed sxml tree search" #f
+  (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
+    (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...))
+     (list attrs text))
+    (else #f)))
+
+(test "collect tree search"
+    '((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))
+  (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
+    (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...))
+     (list tag attrs text))
+    (else #f)))
+
+(test "anded tail pattern" '(1 2)
+      (match '(1 2 3) ((and (a ... b) x) a)))
+
+(test "anded search pattern" '(a b c)
+      (match '(a (b (c d))) ((and (p *** 'd) x) p)))
+
 (test-end)

tests/record-tests.scm

@@ -0,0 +1,151 @@
+
+(import (srfi 99 records syntactic) (chibi test))
+
+(test-begin "records")
+
+(define-record-type organism
+  (make-organism name)
+  organism?
+  (name name-of set-name-of!))
+
+;; kingdom
+(define-record-type (animal organism)
+  (make-animal name food)
+  animal?
+  ;; all animals eat
+  (food food-of set-food-of!))
+
+;; phylum
+(define-record-type (chordate animal)
+  (make-chordate name food)
+  chordate?)
+
+;; class
+(define-record-type (mammal chordate)
+  (make-mammal name food num-nipples)
+  mammal?
+  ;; all mammals have nipples
+  (num-nipples num-nipples-of set-num-nipples-of!))
+
+;; order
+(define-record-type (carnivore mammal)
+  (make-carnivore name food num-nipples)
+  carnivore?)
+
+(define-record-type (rodent mammal)
+  (make-rodent name food num-nipples)
+  rodent?)
+
+;; family
+(define-record-type (felidae carnivore)
+  (make-felidae name food num-nipples)
+  felidae?)
+
+(define-record-type (muridae rodent)
+  (make-muridae name food num-nipples)
+  muridae?)
+
+;; genus
+(define-record-type (felis felidae)
+  (make-felis name food num-nipples)
+  felis?)
+
+(define-record-type (mus muridae)
+  (make-mus name food num-nipples)
+  mus?)
+
+;; species
+(define-record-type (cat felis)
+  (make-cat name food num-nipples breed color)
+  cat?
+  (breed breed-of set-breed-of!)
+  (color color-of set-color-of!))
+
+(define-record-type (mouse mus)
+  (make-mouse name food num-nipples)
+  mouse?)
+
+(define mickey (make-mouse "Mickey" "cheese" 10))
+(define felix (make-cat "Felix" mickey 8 'mixed '(and black white)))
+
+(test-assert (organism? mickey))
+(test-assert (animal? mickey))
+(test-assert (chordate? mickey))
+(test-assert (mammal? mickey))
+(test-assert (rodent? mickey))
+(test-assert (muridae? mickey))
+(test-assert (mus? mickey))
+(test-assert (mouse? mickey))
+
+(test-assert (not (carnivore? mickey)))
+(test-assert (not (felidae? mickey)))
+(test-assert (not (felis? mickey)))
+(test-assert (not (cat? mickey)))
+
+(test-assert (organism? felix))
+(test-assert (animal? felix))
+(test-assert (chordate? felix))
+(test-assert (mammal? felix))
+(test-assert (carnivore? felix))
+(test-assert (felidae? felix))
+(test-assert (felis? felix))
+(test-assert (cat? felix))
+
+(test-assert (not (rodent? felix)))
+(test-assert (not (muridae? felix)))
+(test-assert (not (mus? felix)))
+(test-assert (not (mouse? felix)))
+
+(test "Mickey" (name-of mickey))
+(test "cheese" (food-of mickey))
+(test 10 (num-nipples-of mickey))
+
+(test "Felix" (name-of felix))
+(test mickey (food-of felix))
+(test 8 (num-nipples-of felix))
+(test 'mixed (breed-of felix))
+(test '(and black white) (color-of felix))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-record-type person #t #t name sex age)
+(define-record-type (employee person) #t #t department salary)
+
+(define bob (make-employee "Bob" 'male 28 'hr 50000.0))
+(define alice (make-employee "Alice" 'female 32 'research 100000.0))
+
+(test-assert (person? bob))
+(test-assert (employee? bob))
+(test "Bob" (person-name bob))
+(test 'male (person-sex bob))
+(test 28 (person-age bob))
+(test 'hr (employee-department bob))
+(test 50000.0 (employee-salary bob))
+
+(test-assert (person? alice))
+(test-assert (employee? alice))
+(test "Alice" (person-name alice))
+(test 'female (person-sex alice))
+(test 32 (person-age alice))
+(test 'research (employee-department alice))
+(test 100000.0 (employee-salary alice))
+
+;; After a trip to Thailand...
+(person-sex-set! bob 'female)
+(person-name-set! bob "Roberta")
+
+;; Then Roberta quits!
+(employee-department-set! bob #f)
+(employee-salary-set! bob 0.0)
+
+(test "Roberta" (person-name bob))
+(test 'female (person-sex bob))
+(test 28 (person-age bob))
+(test #f (employee-department bob))
+(test 0.0 (employee-salary bob))
+
+;;;; SRFI-99 forbids this, but we currently do it anyway.
+;;(test-assert (equal? (make-employee "Chuck" 'male 20 'janitorial 50000.0)
+;;                     (make-employee "Chuck" 'male 20 'janitorial 50000.0)))
+
+(test-end)

vm.c

@@ -969,13 +969,13 @@ sexp sexp_vm (sexp ctx, sexp proc) {
     break;
   case SEXP_OP_SLOTN_SET:
     if (! sexp_typep(_ARG1))
-      sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1));
+      sexp_raise("slot-set!: not a record type", sexp_list1(ctx, _ARG1));
     else if (! sexp_check_type(ctx, _ARG2, _ARG1))
       sexp_raise("slot-set!: bad type", sexp_list1(ctx, _ARG2));
     else if (sexp_immutablep(_ARG2))
       sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG2));
     else if (! sexp_fixnump(_ARG3))
-      sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3));
+      sexp_raise("slot-set!: not an integer", sexp_list1(ctx, _ARG3));
     sexp_slot_set(_ARG2, sexp_unbox_fixnum(_ARG3), _ARG4);
     _ARG4 = SEXP_VOID;
     top-=3;