records are now generative, match can destructure records with $ patterns

eval.c

@@ -397,7 +397,7 @@ static sexp sexp_syntactic_closure_expr_op (sexp ctx sexp_api_params(self, n), s
   return (sexp_synclop(x) ? sexp_synclo_expr(x) : x);
 }
 
-static sexp sexp_strip_synclos (sexp ctx, sexp x) {
+static sexp sexp_strip_synclos (sexp ctx sexp_api_params(self, n), sexp x) {
   sexp res;
   sexp_gc_var2(kar, kdr);
   sexp_gc_preserve2(ctx, kar, kdr);
@@ -406,8 +406,8 @@ static sexp sexp_strip_synclos (sexp ctx, sexp x) {
     x = sexp_synclo_expr(x);
     goto loop;
   } else if (sexp_pairp(x)) {
-    kar = sexp_strip_synclos(ctx, sexp_car(x));
+    kar = sexp_strip_synclos(ctx sexp_api_pass(self, n), sexp_car(x));
-    kdr = sexp_strip_synclos(ctx, sexp_cdr(x));
+    kdr = sexp_strip_synclos(ctx sexp_api_pass(self, n), sexp_cdr(x));
     res = sexp_cons(ctx, kar, kdr);
     sexp_immutablep(res) = 1;
   } else {
@@ -641,8 +641,8 @@ static sexp analyze_define (sexp ctx, sexp x) {
 
 static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
   sexp res = SEXP_VOID, name;
-  sexp_gc_var3(proc, mac, tmp);
+  sexp_gc_var2(proc, mac);
-  sexp_gc_preserve3(eval_ctx, proc, mac, tmp);
+  sexp_gc_preserve2(eval_ctx, proc, mac);
   for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
     if (! (sexp_pairp(sexp_car(ls)) && sexp_pairp(sexp_cdar(ls))
            && sexp_nullp(sexp_cddar(ls)))) {
@@ -662,7 +662,7 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
       }
     }
   }
-  sexp_gc_release3(eval_ctx);
+  sexp_gc_release2(eval_ctx);
   return res;
 }
 
@@ -741,7 +741,7 @@ static sexp analyze (sexp ctx, sexp object) {
             else
               res = sexp_make_lit(ctx,
                                   (sexp_core_code(op) == SEXP_CORE_QUOTE) ?
-                                  sexp_strip_synclos(ctx, sexp_cadr(x)) :
+                                  sexp_strip_synclos(ctx  sexp_api_pass(NULL, 1), sexp_cadr(x)) :
                                   sexp_cadr(x));
             break;
           case SEXP_CORE_DEFINE_SYNTAX:
@@ -1361,6 +1361,7 @@ sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_ar
 #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,
@@ -1369,6 +1370,7 @@ sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name,
 
 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),
@@ -1378,6 +1380,7 @@ sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sex
 }
 
 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))
@@ -1389,6 +1392,7 @@ sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp typ
 }
 
 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))

include/chibi/eval.h

@@ -93,6 +93,9 @@ enum sexp_opcode_names {
   SEXP_OP_MAKE,
   SEXP_OP_SLOT_REF,
   SEXP_OP_SLOT_SET,
+  SEXP_OP_ISA,
+  SEXP_OP_SLOTN_REF,
+  SEXP_OP_SLOTN_SET,
   SEXP_OP_CAR,
   SEXP_OP_CDR,
   SEXP_OP_SET_CAR,

include/chibi/sexp.h

@@ -472,6 +472,8 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
 #define sexp_slot_ref(x,i)   (((sexp*)&((x)->value))[i])
 #define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v))
 
+#define sexp_isa(a, b) (sexp_pointerp(a) && sexp_typep(b) && (sexp_pointer_tag(a) == sexp_type_tag(b)))
+
 #if SEXP_USE_IMMEDIATE_FLONUMS
 union sexp_flonum_conv {
   float flonum;

lib/chibi/match/match.scm

@@ -161,6 +161,10 @@
      (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
     ((match-two v (p *** . q) g+s sk fk i)
      (match-syntax-error "invalid use of ***" (p *** . q)))
+    ((match-two v ($ rec p ...) g+s sk fk i)
+     (if (is-a? v rec)
+         (match-record-refs v rec 0 (p ...) g+s sk fk i)
+         fk))
     ((match-two v (p . q) g+s sk fk i)
      (if (pair? v)
          (let ((w (car v)) (x (cdr v)))
@@ -471,6 +475,15 @@
                       (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
                       fk i)))))))
 
+(define-syntax match-record-refs
+  (syntax-rules ()
+    ((_ v rec n (p . q) g+s sk fk i)
+     (let ((w (slot-ref rec v n)))
+       (match-one w p ((slot-ref rec v n) (slot-set! rec v n))
+                  (match-record-refs v rec (+ n 1) q g+s sk fk) fk i)))
+    ((_ v rec n () g+s (sk ...) fk i)
+     (sk ... i))))
+
 ;; Extract all identifiers in a pattern.  A little more complicated
 ;; than just looking for symbols, we need to ignore special keywords
 ;; and non-pattern forms (such as the predicate expression in ?

lib/srfi/9.module

@@ -13,17 +13,21 @@
                (pred (cadddr expr))
                (fields (cddddr expr))
                (num-fields (length fields))
-               (index (register-simple-type name-str num-fields))
                (_define (rename 'define))
                (_lambda (rename 'lambda))
-               (_let (rename 'let)))
+               (_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)))))
           `(,(rename 'begin)
+            ;; type
+            (,_define ,name (,_register ,name-str ,num-fields))
+            ;; predicate
             (,_define ,pred (,(rename 'make-type-predicate)
                              ,(symbol->string (identifier->symbol pred))
-                             ,index))
+                             ,name))
+            ;; fields
             ,@(let lp ((ls fields) (i 0) (res '()))
                 (if (null? ls)
                     res
@@ -32,7 +36,7 @@
                                     (,(rename 'make-getter)
                                      ,(symbol->string
                                        (identifier->symbol (cadar ls)))
-                                     ,index
+                                     ,name
                                      ,i))
                                  res)))
                       (lp (cdr ls)
@@ -43,17 +47,18 @@
                                   (,(rename 'make-setter)
                                    ,(symbol->string
                                      (identifier->symbol (caddar ls)))
-                                   ,index
+                                   ,name
                                    ,i))
                                res)
                               res)))))
+            ;; constructor
             (,_define ,make
               ,(let lp ((ls make-fields) (sets '()) (set-defs '()))
                  (cond
                   ((null? ls)
                    `(,_let ((%make (,(rename 'make-constructor)
                                     ,(symbol->string (identifier->symbol make))
-                                    ,index))
+                                    ,name))
                             ,@set-defs)
                       (,_lambda ,make-fields
                         (,_let ((res (%make)))
@@ -79,7 +84,7 @@
                              (cons (list setter
                                          (list (rename 'make-setter)
                                                setter-name
-                                               index
+                                               name
                                                (index-of (car ls) fields)))
                                    set-defs)))))))))))))))))
 

opcodes.c

@@ -36,6 +36,8 @@ _OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string
 #endif
 #endif
 _OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL),
+_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF,3,0, 0, SEXP_FIXNUM, 0,"slot-ref", 0, NULL),
+_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET,4,0, 0, SEXP_FIXNUM, 0,"slot-set!", 0, NULL),
 _OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL),
 _OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL),
 _OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL),
@@ -58,6 +60,7 @@ _OP(SEXP_OPC_CONSTRUCTOR,    SEXP_OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL),
 _OP(SEXP_OPC_CONSTRUCTOR,    SEXP_OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL),
 _OP(SEXP_OPC_CONSTRUCTOR,    SEXP_OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL),
 _OP(SEXP_OPC_CONSTRUCTOR,    SEXP_OP_MAKE_EXCEPTION, 5, 0, 0, 0, 0, "make-exception", 0, NULL),
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_ISA,  2, 0, 0, 0, 0, "is-a?", NULL, 0),
 _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP,  1, 0, 0, 0, 0, "null?", NULL, 0),
 _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP,  1, 0, 0, 0, 0, "eof-object?", NULL, 0),
 _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP,  1, 0, 0, 0, 0, "symbol?", NULL, 0),

opt/opcode_names.h

@@ -10,9 +10,10 @@ static const char* reverse_opcode_names[] =
    "STRING-REF", "STRING-SET", "STRING-LENGTH",
    "MAKE-PROCEDURE", "MAKE-VECTOR",
    "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?",
-   "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR",
+   "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET",
-   "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB",
+   "ISA?", "SLOTN-REF", "SLOTN-SET",
-   "MUL", "DIV", "QUOTIENT", "REMAINDER",
+   "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS",
+   "ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER",
    "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT",
    "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE",
    "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR",

sexp.c

@@ -183,7 +183,7 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name,
     sexp_type_size_scale(type) = sexp_unbox_fixnum(sc);
     sexp_type_name(type) = strdup(sexp_string_data(name));
     sexp_type_finalize(type) = f;
-    res = sexp_make_fixnum(num_types);
+    res = type;
 #if SEXP_USE_GLOBAL_TYPES
     sexp_num_types = num_types + 1;
 #else
@@ -1200,6 +1200,11 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
       sexp_write_one(ctx, sexp_synclop(x) ? sexp_synclo_expr(x): x, out);
       sexp_write_string(ctx, ">", out);
       break;
+    case SEXP_SYNCLO:
+      sexp_write_string(ctx, "#<sc: ", out);
+      sexp_write(ctx, sexp_synclo_expr(obj), out);
+      sexp_write_string(ctx, ">", out);
+      break;
     case SEXP_STRING:
       sexp_write_char(ctx, '"', out);
       i = sexp_string_length(obj);

vm.c

@@ -931,6 +931,33 @@ sexp sexp_vm (sexp ctx, sexp proc) {
     ip += sizeof(sexp)*2;
     top--;
     break;
+  case SEXP_OP_ISA:
+    _ARG2 = sexp_make_boolean(sexp_isa(_ARG1, _ARG2));
+    top--;
+    break;
+  case SEXP_OP_SLOTN_REF:
+    if (! sexp_typep(_ARG1))
+      sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1));
+    else if (! sexp_isa(_ARG2, _ARG1))
+      sexp_raise("slot-ref: bad type", sexp_list1(ctx, _ARG2));
+    else if (! sexp_fixnump(_ARG3))
+      sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3));
+    _ARG3 = sexp_slot_ref(_ARG2, sexp_unbox_fixnum(_ARG3));
+    top-=2;
+    break;
+  case SEXP_OP_SLOTN_SET:
+    if (! sexp_typep(_ARG1))
+      sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1));
+    else if (! sexp_isa(_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_slot_set(_ARG2, sexp_unbox_fixnum(_ARG3), _ARG4);
+    _ARG4 = SEXP_VOID;
+    top-=3;
+    break;
   case SEXP_OP_CAR:
     if (! sexp_pairp(_ARG1))
       sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1));