From a9657c4642f8f6e91f5035dedb79e194c9cd4f30 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Sun, 13 Jul 2008 11:25:46 -0700
Subject: [PATCH] define-record-type now understands parent-rtd (used to ignore
 it).

---
 scheme/last-revision       |  2 +-
 scheme/psyntax.expander.ss | 34 +++++++++++++++++++---------------
 2 files changed, 20 insertions(+), 16 deletions(-)

diff --git a/scheme/last-revision b/scheme/last-revision
index fa94e88..07b0f42 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1536
+1537
diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss
index 495e466..ea7ca09 100644
--- a/scheme/psyntax.expander.ss
+++ b/scheme/psyntax.expander.ss
@@ -1851,7 +1851,7 @@
            (if (free-id=? (bless id) x)
                `(,x . ,rest)
                (get-clause id ls))]))
-      (define (foo-rtd-code name clause*) 
+      (define (foo-rtd-code name clause* parent-rtd-code) 
         (define (convert-field-spec* ls)
           (list->vector
             (map (lambda (x) 
@@ -1860,11 +1860,7 @@
                      [(immutable name . rest) `(immutable ,name)]
                      [name `(immutable ,name)]))
                ls)))
-        (let ([parent-rtd-code 
-               (syntax-match (get-clause 'parent clause*) ()
-                 [(_ name) `(record-type-descriptor ,name)]
-                 [_ '#f])]
-              [uid-code
+        (let ([uid-code
                (syntax-match (get-clause 'nongenerative clause*) ()
                  [(_)     `',(gensym)]
                  [(_ uid) `',uid]
@@ -1886,13 +1882,21 @@
             `(make-record-type-descriptor ',name
                ,parent-rtd-code 
                ,uid-code ,sealed? ,opaque? ,fields))))
-      (define (foo-rcd-code clause* foo-rtd protocol) 
-        (let ([parent-rcd-code 
-               (syntax-match (get-clause 'parent clause*) ()
-                 [(_ name) `(record-constructor-descriptor ,name)]
-                 [_ #f])])
-          `(make-record-constructor-descriptor ,foo-rtd
-               ,parent-rcd-code ,protocol)))
+      (define (parent-rtd-code clause*)
+        (syntax-match (get-clause 'parent clause*) ()
+          [(_ name) `(record-type-descriptor ,name)]
+          [#f (syntax-match (get-clause 'parent-rtd clause*) ()
+                [(_ rtd rcd) rtd]
+                [#f #f])]))
+      (define (parent-rcd-code clause*)
+        (syntax-match (get-clause 'parent clause*) ()
+          [(_ name) `(record-constructor-descriptor ,name)]
+          [#f (syntax-match (get-clause 'parent-rtd clause*) ()
+                [(_ rtd rcd) rcd]
+                [#f #f])]))
+      (define (foo-rcd-code clause* foo-rtd protocol parent-rcd-code)
+        `(make-record-constructor-descriptor ,foo-rtd
+           ,parent-rcd-code ,protocol))
       (define (get-protocol-code clause*)
         (syntax-match (get-clause 'protocol clause*) ()
           [(_ expr) expr]
@@ -1962,8 +1966,8 @@
                [set-foo-x!* (get-mutators foo fields)]
                [set-foo-idx* (get-mutator-indices fields)]
                [foo? (get-record-predicate-name namespec)]
-               [foo-rtd-code (foo-rtd-code foo clause*)]
-               [foo-rcd-code (foo-rcd-code clause* foo-rtd protocol)]
+               [foo-rtd-code (foo-rtd-code foo clause* (parent-rtd-code clause*))]
+               [foo-rcd-code (foo-rcd-code clause* foo-rtd protocol (parent-rcd-code clause*))]
                [protocol-code (get-protocol-code clause*)])
           (bless
             `(begin