diff --git a/lib/srfi/99/records/inspection.scm b/lib/srfi/99/records/inspection.scm index bc66a3d2..4626050d 100644 --- a/lib/srfi/99/records/inspection.scm +++ b/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)) diff --git a/lib/srfi/99/records/procedural.scm b/lib/srfi/99/records/procedural.scm index 5994f934..f8477da8 100644 --- a/lib/srfi/99/records/procedural.scm +++ b/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))) diff --git a/tests/record-tests.scm b/tests/record-tests.scm index 3f842a59..91671e82 100644 --- a/tests/record-tests.scm +++ b/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) diff --git a/vm.c b/vm.c index 4a1ac499..aad431ef 100644 --- a/vm.c +++ b/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; }