srfi-99 fixes from rotty

lib/srfi/99/records/inspection.scm

@@ -5,7 +5,7 @@
 (define (record-rtd x)
   (type-of x))
 
-(define (rtd-name x) (type-name x))
+(define (rtd-name x) (string->symbol (type-name x)))
 
 (define (rtd-parent x) (type-parent x))
 

lib/srfi/99/records/procedural.scm

@@ -7,7 +7,7 @@
   (type? x))
 
 (define (rtd-constructor rtd . o)
-  (let ((fields (vector->list (if (pair? o) (car o) (rtd-all-field-names))))
+  (let ((fields (vector->list (if (pair? o) (car o) (rtd-all-field-names rtd))))
         (make (make-constructor (type-name rtd) rtd)))
     (lambda args
       (let ((res (make)))
@@ -16,7 +16,7 @@
            ((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))
+            (slot-set! rtd res (rtd-field-offset rtd (car p)) (car a))
             (lp (cdr a) (cdr p)))))))))
 
 (define (rtd-predicate rtd)
@@ -42,10 +42,10 @@
                    i))))))
 
 (define (rtd-accessor rtd field)
-  (make-getter rtd (type-name rtd) (rtd-field-offset rtd field)))
+  (make-getter (type-name rtd) 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))
+      (make-setter (type-name rtd) rtd (rtd-field-offset rtd field))
       (error "can't make mutator for immutable field" rtd field)))
 

tests/record-tests.scm

@@ -1,7 +1,7 @@
 
 (cond-expand
  (modules
-  (import (srfi 99 records syntactic)
+  (import (srfi 99)
           (only (chibi test) test-begin test-assert test test-end)))
  (else #f))
 
@@ -152,4 +152,24 @@
 ;;(test-assert (equal? (make-employee "Chuck" 'male 20 'janitorial 50000.0)
 ;;                     (make-employee "Chuck" 'male 20 'janitorial 50000.0)))
 
+(test-assert (record? alice))
+(test 'person (rtd-name person))
+(let* ((constructor (rtd-constructor person))
+       (trent (constructor "Trent" 'male 44)))
+  (test "Trent" (person-name trent))
+  (test 'male (person-sex trent))
+  (test 44 ((rtd-accessor person 'age) trent))
+  ((rtd-mutator person 'age) trent 45)
+  (test 45 (person-age trent)))
+
+(test-assert (rtd-field-mutable? employee 'department))
+
+;;; We do not retain mutability information ATM.
+;; (define-record-type foo
+;;   (make-foo x)
+;;   foo?
+;;   (x foo-x))
+
+;; (test-assert (not (rtd-field-mutable? foo 'x)))
+
 (test-end)

vm.c

@@ -578,9 +578,12 @@ static int sexp_check_type(sexp ctx, sexp a, sexp b) {
     return 1;
   t = sexp_object_type(ctx, a);
   v = sexp_type_cpl(t);
+  if (! sexp_vectorp(v))
+    return 0;
+  if (b == sexp_type_by_index(ctx, SEXP_OBJECT))
+    return 1;
   d = sexp_type_depth(b);
-  return sexp_vectorp(v)
-    && (d < sexp_vector_length(v))
+  return (d < sexp_vector_length(v))
     && sexp_vector_ref(v, sexp_make_fixnum(d)) == b;
 }