mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-04 05:50:26 +02:00
Code Activity

(%record-type-check): New function.

Browse source 
(record-accessor, record-modifier): Use it for a strict type check of
the given record.  Previously an accessor returned #f on a wrong
record type, and modifier silently did nothing.
This commit is contained in:
Kevin Ryde 2006-08-02 00:45:45 +00:00
parent 729ab63afa
commit b0c50494b6
1 changed files with 11 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

15
ice-9/boot-9.scm
View file

@ -429,13 +429,20 @@
(define (record-predicate rtd)
(lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
(define (%record-type-check rtd obj) ;; private helper
(or (eq? rtd (record-type-descriptor obj))
(scm-error 'wrong-type-arg "%record-type-check"
"Wrong type record (want `~S'): ~S"
(list (record-type-name rtd) obj)
#f)))
(define (record-accessor 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)
(and (eq? ',rtd (record-type-descriptor obj))
(struct-ref obj ,pos)))
(%record-type-check ',rtd obj)
(struct-ref obj ,pos))
the-root-environment)))
(define (record-modifier rtd field-name)
@ -443,8 +450,8 @@
(if (not pos)
(error 'no-such-field field-name))
(local-eval `(lambda (obj val)
(and (eq? ',rtd (record-type-descriptor obj))
(struct-set! obj ,pos val)))
(%record-type-check ',rtd obj)
(struct-set! obj ,pos val))
the-root-environment)))