mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-08 18:40:23 +02:00
Code Activity

(define-record-type): In accessor and modifier procedures

Browse source 
generated, check that the record is the right type and throw an error
if not, as per srfi-9 spec.  Previously a different record type
resulted in #f from an accessor and silently doing nothing in
modifier.
This commit is contained in:
Kevin Ryde 2006-06-13 01:07:43 +00:00
parent 99f4af3672
commit 043571b258
1 changed files with 28 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

31
srfi/srfi-9.scm
View file

@ -88,6 +88,31 @@
(cond-expand-provide (current-module) '(srfi-9))
(define (check-record-type rtd obj)
(or (eq? rtd (record-type-descriptor obj))
(error 'wrong-record-type obj)))
;; same as boot-9.scm, but with check-record-type
(define (record-accessor-strict rtd field-name)
(let* ((pos (list-index (record-type-fields rtd) field-name)))
(if (not pos)
(error 'no-such-field field-name))
(local-eval `(lambda (obj)
(,check-record-type ,rtd obj)
(struct-ref obj ,pos))
the-root-environment)))
;; same as boot-9.scm, but with check-record-type
(define (record-modifier-strict rtd field-name)
(let* ((pos (list-index (record-type-fields rtd) field-name)))
(if (not pos)
(error 'no-such-field field-name))
(local-eval `(lambda (obj val)
(,check-record-type ,rtd obj)
(struct-set! obj ,pos val))
the-root-environment)))
(define-macro (define-record-type type-name constructor/field-tag
predicate-name . field-specs)
`(begin
@ -102,13 +127,13 @@
(cond
((= (length spec) 2)
`(define ,(cadr spec)
(record-accessor ,type-name ',(car spec))))
(,record-accessor-strict ,type-name ',(car spec))))
((= (length spec) 3)
`(begin
(define ,(cadr spec)
(record-accessor ,type-name ',(car spec)))
(,record-accessor-strict ,type-name ',(car spec)))
(define ,(caddr spec)
(record-modifier ,type-name ',(car spec)))))
(,record-modifier-strict ,type-name ',(car spec)))))
(else
(error "invalid field spec " spec))))
field-specs)))