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

define* in record-constructor

Browse source 
* module/ice-9/boot-9.scm (record-constructor): Use define*.
This commit is contained in:
Andy Wingo 2010-05-21 23:35:24 +02:00
parent b2669c41a7
commit d44a0d12b4
1 changed files with 9 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

7
module/ice-9/boot-9.scm
View file

@ -717,17 +717,16 @@ If there is no handler at all, Guile prints an error and then exits."
(struct-ref obj (+ 1 vtable-offset-user)) (struct-ref obj (+ 1 vtable-offset-user))
(error 'not-a-record-type obj))) (error 'not-a-record-type obj)))
(define (record-constructor rtd . opt) (define* (record-constructor rtd #:optional field-names)
(if (null? opt) (if (not field-names)
(struct-ref rtd (+ 2 vtable-offset-user)) (struct-ref rtd (+ 2 vtable-offset-user))
(let ((field-names (car opt)))
(primitive-eval (primitive-eval
`(lambda ,field-names `(lambda ,field-names
(make-struct ',rtd 0 ,@(map (lambda (f) (make-struct ',rtd 0 ,@(map (lambda (f)
(if (memq f field-names) (if (memq f field-names)
f f
#f)) #f))
(record-type-fields rtd)))))))) (record-type-fields rtd)))))))
(define (record-predicate rtd) (define (record-predicate rtd)
(lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj))))) (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))