Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 14:19:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

srfi-99 fixes from rotty

Browse source
This commit is contained in:
Alex Shinn 2011-05-21 23:02:44 -07:00
parent 265d3e5136
commit 1e02e95590
4 changed files with 31 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lib/srfi/99/records/inspection.scm
View file

@ -5,7 +5,7 @@
(define (record-rtd x) (define (record-rtd x)
(type-of 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)) (define (rtd-parent x) (type-parent x))

8
lib/srfi/99/records/procedural.scm
View file

@ -7,7 +7,7 @@
(type? x)) (type? x))
(define (rtd-constructor rtd . o) (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))) (make (make-constructor (type-name rtd) rtd)))
(lambda args (lambda args
(let ((res (make))) (let ((res (make)))
@ -16,7 +16,7 @@
((null? a) (if (null? p) res (error "not enough args" p))) ((null? a) (if (null? p) res (error "not enough args" p)))
((null? p) (error "too many args" a)) ((null? p) (error "too many args" a))
(else (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))))))))) (lp (cdr a) (cdr p)))))))))
(define (rtd-predicate rtd) (define (rtd-predicate rtd)
@ -42,10 +42,10 @@
i)))))) i))))))
(define (rtd-accessor rtd field) (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) (define (rtd-mutator rtd field)
(if (rtd-field-mutable? 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))) (error "can't make mutator for immutable field" rtd field)))

22
tests/record-tests.scm
View file

@ -1,7 +1,7 @@
(cond-expand (cond-expand
(modules (modules
(import (srfi 99 records syntactic) (import (srfi 99)
(only (chibi test) test-begin test-assert test test-end))) (only (chibi test) test-begin test-assert test test-end)))
(else #f)) (else #f))
@ -152,4 +152,24 @@
;;(test-assert (equal? (make-employee "Chuck" 'male 20 'janitorial 50000.0) ;;(test-assert (equal? (make-employee "Chuck" 'male 20 'janitorial 50000.0)
;; (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) (test-end)

7
vm.c
View file

@ -578,9 +578,12 @@ static int sexp_check_type(sexp ctx, sexp a, sexp b) {
return 1; return 1;
t = sexp_object_type(ctx, a); t = sexp_object_type(ctx, a);
v = sexp_type_cpl(t); 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); d = sexp_type_depth(b);
return sexp_vectorp(v) return (d < sexp_vector_length(v))
&& (d < sexp_vector_length(v))
&& sexp_vector_ref(v, sexp_make_fixnum(d)) == b; && sexp_vector_ref(v, sexp_make_fixnum(d)) == b;
} }