summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/system/base/syntax.scm8
1 files changed, 5 insertions, 3 deletions
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index 67bcdb61b..0fe8a4ddf 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -165,7 +165,8 @@
(define-macro (record-case record . clauses)
- (let ((r (gensym)))
+ (let ((r (gensym))
+ (rtd (gensym)))
(define (process-clause clause)
(if (eq? (car clause) 'else)
clause
@@ -173,14 +174,15 @@
(slots (cdar clause))
(body (cdr clause)))
(let ((stem (symbol-trim-both record-type (list->char-set '(#\< #\>)))))
- `((,(symbol-append stem '?) ,r)
+ `((eq? ,rtd ,record-type)
(let ,(map (lambda (slot)
(if (pair? slot)
`(,(car slot) (,(symbol-append stem '- (cadr slot)) ,r))
`(,slot (,(symbol-append stem '- slot) ,r))))
slots)
,@body))))))
- `(let ((,r ,record))
+ `(let* ((,r ,record)
+ (,rtd (struct-vtable ,r)))
(cond ,@(let ((clauses (map process-clause clauses)))
(if (assq 'else clauses)
clauses