Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 22:59:16 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Patches from Ben Mather.

Browse source 
Allow #f to leave (srfi 99) record constructors and predicates undefined.
Distinguish default immutable fields (raw identifier), from default
mutable fields (list of one identifier) in the syntactic layer by not
creating setters for the immutable fields.  The record introspection
can still mutate such fields.
Fixes issue #190.
This commit is contained in:
Alex Shinn 2013-07-30 21:15:24 +09:00
parent 19e5398b92
commit 92ccc0144a
2 changed files with 98 additions and 56 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

106
lib/srfi/99/records/syntactic.scm
View file

@ -37,14 +37,15 @@
(,(rename 'make-type-predicate) (,(rename 'make-type-predicate)
,(id->string pred-name) ,(id->string pred-name)
,name))) ,name)))
#f) '())
;; accessors ;; accessors
,@(map (lambda (f) ,@(map (lambda (f)
(let ((g (if (and (pair? f) (pair? (cdr f))) (let ((g (if (and (pair? f) (pair? (cdr f)))
(cadr f) (cadr f)
(and (identifier? f) (string->symbol
(string->symbol (string-append name-str
(string-append name-str "-" (id->string f))))))) "-"
(id->string (if (pair? f) (car f) f)))))))
(and g (and g
`(,_define ,g `(,_define ,g
(,(rename 'make-getter) (,(rename 'make-getter)
@ -53,11 +54,14 @@
(,_type_slot_offset ,name ',(if (pair? f) (car f) f))))))) (,_type_slot_offset ,name ',(if (pair? f) (car f) f)))))))
fields) fields)
,@(map (lambda (f) ,@(map (lambda (f)
(let ((s (if (and (pair? f) (pair? (cdr f)) (pair? (cddr f))) (let ((s (and (pair? f)
(car (cddr f)) (if (and (pair? (cdr f)) (pair? (cddr f)))
(and (identifier? f) (car (cddr f))
(string->symbol (string->symbol
(string-append name-str "-" (id->string f) "-set!")))))) (string-append name-str
"-"
(id->string (car f))
"-set!"))))))
(and s (and s
`(,_define ,s `(,_define ,s
(,(rename 'make-setter) (,(rename 'make-setter)
@ -66,45 +70,47 @@
(,_type_slot_offset ,name ',(if (pair? f) (car f) f))))))) (,_type_slot_offset ,name ',(if (pair? f) (car f) f)))))))
fields) fields)
;; constructor ;; constructor
,(if make-fields ,@(if make-name
(let ((fields (map (lambda (f) (cons (rename f) f)) make-fields))) (if make-fields
`(,_define ,make-name (let ((fields (map (lambda (f) (cons (rename f) f)) make-fields)))
,(let lp ((ls fields) (sets '())) `((,_define ,make-name
(cond ,(let lp ((ls fields) (sets '()))
((null? ls) (cond
`(,_let ((,_make (,(rename 'make-constructor) ((null? ls)
,(id->string make-name) `(,_let ((,_make (,(rename 'make-constructor)
,name))) ,(id->string make-name)
(,_lambda ,(map car fields) ,name)))
(,_let ((res (,_make))) (,_lambda ,(map car fields)
,@sets (,_let ((res (,_make)))
res)))) ,@sets
(else res))))
(let ((field (assq (cdar ls) fields))) (else
(cond (let ((field (assq (cdar ls) fields)))
((and (pair? field) (pair? (cdr field)) (pair? (cddr field))) (cond
(lp (cdr ls) ((and (pair? field) (pair? (cdr field)) (pair? (cddr field)))
(cons (list (car (cddr field)) 'res (cdar ls)) sets))) (lp (cdr ls)
(else (cons (list (car (cddr field)) 'res (cdar ls)) sets)))
(lp (cdr ls) (else
(cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(cdar ls)) ,(caar ls)) sets)))))))))) (lp (cdr ls)
`(,_define ,make-name (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(cdar ls)) ,(caar ls)) sets)))))))))))
(,_let ((,_make (,(rename 'make-constructor) `((,_define ,make-name
,(id->string make-name) (,_let ((,_make (,(rename 'make-constructor)
,name))) ,(id->string make-name)
(,_lambda args ,name)))
(,_let ((res (,_make))) (,_lambda args
(let lp ((a args) (,_let ((res (,_make)))
(p (,_vector->list (,_rtd-all-field-names ,name)))) (let lp ((a args)
(cond (p (,_vector->list (,_rtd-all-field-names ,name))))
((null? a) (cond
(if (null? p) ((null? a)
res (if (null? p)
(error ,(string-append "not enough arguments to " (id->string make-name) ": missing") res
p))) (error ,(string-append "not enough arguments to " (id->string make-name) ": missing")
((null? p) p)))
(error ,(string-append "too many arguments to " (id->string make-name)) ((null? p)
a)) (error ,(string-append "too many arguments to " (id->string make-name))
(else a))
(,_slot-set! ,name res (,_type_slot_offset ,name (car p)) (car a)) (else
(lp (cdr a) (cdr p))))))))))))))) (,_slot-set! ,name res (,_type_slot_offset ,name (car p)) (car a))
(lp (cdr a) (cdr p)))))))))))
'()))))))

48
tests/record-tests.scm
View file

@ -2,6 +2,7 @@
(cond-expand (cond-expand
(modules (modules
(import (srfi 99) (import (srfi 99)
(only (chibi) env-exports)
(only (chibi test) test-begin test-assert test test-end))) (only (chibi test) test-begin test-assert test test-end)))
(else #f)) (else #f))
@ -112,8 +113,8 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-record-type person #t #t name sex age) (define-record-type person #t #t (name) (sex) (age))
(define-record-type (employee person) #t #t department salary) (define-record-type (employee person) #t #t (department) (salary))
(define bob (make-employee "Bob" 'male 28 'hr 50000.0)) (define bob (make-employee "Bob" 'male 28 'hr 50000.0))
(define alice (make-employee "Alice" 'female 32 'research 100000.0)) (define alice (make-employee "Alice" 'female 32 'research 100000.0))
@ -148,9 +149,9 @@
(test #f (employee-department bob)) (test #f (employee-department bob))
(test 0.0 (employee-salary bob)) (test 0.0 (employee-salary bob))
;;;; SRFI-99 forbids this, but we currently do it anyway. ;; SRFI-99 forbids this, but we currently do it anyway.
;;(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-assert (record? alice))
(test 'person (rtd-name person)) (test 'person (rtd-name person))
@ -169,7 +170,7 @@
;; (make-foo x) ;; (make-foo x)
;; foo? ;; foo?
;; (x foo-x)) ;; (x foo-x))
;;
;; (test-assert (not (rtd-field-mutable? foo 'x))) ;; (test-assert (not (rtd-field-mutable? foo 'x)))
(define point (make-rtd "point" #(x y))) (define point (make-rtd "point" #(x y)))
@ -183,4 +184,39 @@
(test-assert (example? (make-example 3))) (test-assert (example? (make-example 3)))
(test 3 (example-example (make-example 3))) (test 3 (example-example (make-example 3)))
;; record types definitions with #f passed as either the constructor or
;; predicate argument should not create the corresponding function
(define-record-type abstract
#f #t)
(test #f (memq 'make-abstract (env-exports (current-environment))))
(define-record-type (derived abstract)
#t #f)
(define instance (make-derived))
(test-assert (abstract? instance))
(test #f (memq 'derived? (env-exports (current-environment))))
(define-record-type container
#t #t
default-immutable
(default-mutable)
(named-immutable get-container-immutable)
(named-mutable get-container-mutable set-container-mutable!))
(define container-instance (make-container 1 2 3 4))
(test 1 (container-default-immutable container-instance))
(test 2 (container-default-mutable container-instance))
(test 3 (get-container-immutable container-instance))
(test 4 (get-container-mutable container-instance))
(container-default-mutable-set! container-instance #t)
(test #t (container-default-mutable container-instance))
(set-container-mutable! container-instance #t)
(test #t (get-container-mutable container-instance))
(test-end) (test-end)