mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-23 21:10:29 +02:00
Code Activity

inline record predicates into record-case

Browse source 
* module/system/base/syntax.scm (record-case): Inline record predicates
  into the record-case. Shaves off a few more milliseconds from a GOOPS
  load.
This commit is contained in:
Andy Wingo 2009-02-13 00:16:44 +01:00
parent d9d671f76e
commit 34898db352
1 changed files with 5 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

8
module/system/base/syntax.scm
View file

@ -165,7 +165,8 @@
(define-macro (record-case record . clauses) (define-macro (record-case record . clauses)
(let ((r (gensym))) (let ((r (gensym))
(rtd (gensym)))
(define (process-clause clause) (define (process-clause clause)
(if (eq? (car clause) 'else) (if (eq? (car clause) 'else)
clause clause
@ -173,14 +174,15 @@
(slots (cdar clause)) (slots (cdar clause))
(body (cdr clause))) (body (cdr clause)))
(let ((stem (symbol-trim-both record-type (list->char-set '(#\< #\>))))) (let ((stem (symbol-trim-both record-type (list->char-set '(#\< #\>)))))
`((,(symbol-append stem '?) ,r) `((eq? ,rtd ,record-type)
(let ,(map (lambda (slot) (let ,(map (lambda (slot)
(if (pair? slot) (if (pair? slot)
`(,(car slot) (,(symbol-append stem '- (cadr slot)) ,r)) `(,(car slot) (,(symbol-append stem '- (cadr slot)) ,r))
`(,slot (,(symbol-append stem '- slot) ,r)))) `(,slot (,(symbol-append stem '- slot) ,r))))
slots) slots)
,@body)))))) ,@body))))))
`(let ((,r ,record)) `(let* ((,r ,record)
(,rtd (struct-vtable ,r)))
(cond ,@(let ((clauses (map process-clause clauses))) (cond ,@(let ((clauses (map process-clause clauses)))
(if (assq 'else clauses) (if (assq 'else clauses)
clauses clauses