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

define-type has #:common-slots

Browse source 
* module/system/base/syntax.scm (define-type): Accept a #:common-slots
  argument, defining slots that are in all instances of this type.
This commit is contained in:
Andy Wingo 2009-02-27 10:44:47 +01:00
parent 4054d93183
commit 43e0c29305
1 changed files with 16 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -24,6 +24,11 @@
#:export-syntax (define-type define-record define-record/keywords
record-case))
(define (symbol-trim-both sym pred)
(string->symbol (string-trim-both (symbol->string sym) pred)))
(define (trim-brackets sym)
(symbol-trim-both sym (list->char-set '(#\< #\>))))
;;;
;;; Type
@ -32,28 +37,33 @@
(define-macro (define-type name . rest)
(let ((name (if (pair? name) (car name) name))
(opts (if (pair? name) (cdr name) '())))
(let ((printer (kw-arg-ref opts #:printer)))
(let ((printer (kw-arg-ref opts #:printer))
(common-slots (or (kw-arg-ref opts #:common-slots) '())))
`(begin ,@(map (lambda (def)
`(define-record ,(if printer
`(,(car def) ,printer)
(car def))
,@common-slots
,@(cdr def)))
rest)))))
rest)
,@(map (lambda (common-slot i)
`(define (,(symbol-append (trim-brackets name)
'- common-slot)
x)
(struct-ref x i)))
common-slots (iota (length common-slots)))))))
;;;
;;; Record
;;;
(define (symbol-trim-both sym pred)
(string->symbol (string-trim-both (symbol->string sym) pred)))
(define-macro (define-record name-form . slots)
(let* ((name (if (pair? name-form) (car name-form) name-form))
(printer (and (pair? name-form) (cadr name-form)))
(slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
slots))
(stem (symbol-trim-both name (list->char-set '(#\< #\>)))))
(stem (trim-brackets name)))
`(begin
(define ,name (make-record-type ,(symbol->string name) ',slot-names
,@(if printer (list printer) '())))