From b0c50494b65c4dfe01c92360ff24e44497a3b88c Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 2 Aug 2006 00:45:45 +0000 Subject: [PATCH] (%record-type-check): New function. (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. --- ice-9/boot-9.scm | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 0f56f9855..139954797 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -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)))