mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +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 #:export-syntax (define-type define-record define-record/keywords
record-case)) 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 ;;; Type
@ -32,28 +37,33 @@
(define-macro (define-type name . rest) (define-macro (define-type name . rest)
(let ((name (if (pair? name) (car name) name)) (let ((name (if (pair? name) (car name) name))
(opts (if (pair? name) (cdr 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) `(begin ,@(map (lambda (def)
`(define-record ,(if printer `(define-record ,(if printer
`(,(car def) ,printer) `(,(car def) ,printer)
(car def)) (car def))
,@common-slots
,@(cdr def))) ,@(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 ;;; Record
;;; ;;;
(define (symbol-trim-both sym pred)
(string->symbol (string-trim-both (symbol->string sym) pred)))
(define-macro (define-record name-form . slots) (define-macro (define-record name-form . slots)
(let* ((name (if (pair? name-form) (car name-form) name-form)) (let* ((name (if (pair? name-form) (car name-form) name-form))
(printer (and (pair? name-form) (cadr name-form))) (printer (and (pair? name-form) (cadr name-form)))
(slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot)) (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
slots)) slots))
(stem (symbol-trim-both name (list->char-set '(#\< #\>))))) (stem (trim-brackets name)))
`(begin `(begin
(define ,name (make-record-type ,(symbol->string name) ',slot-names (define ,name (make-record-type ,(symbol->string name) ',slot-names
,@(if printer (list printer) '()))) ,@(if printer (list printer) '())))