From 43e0c29305b0c60f866f0852643f0ad9385537ae Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Fri, 27 Feb 2009 10:44:47 +0100
Subject: [PATCH] define-type has #:common-slots

* module/system/base/syntax.scm (define-type): Accept a #:common-slots
  argument, defining slots that are in all instances of this type.
---
 module/system/base/syntax.scm | 22 ++++++++++++++++------
 1 file changed, 16 insertions(+), 6 deletions(-)

diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index bc8db0388..4382a8e66 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -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) '())))