From a9657c4642f8f6e91f5035dedb79e194c9cd4f30 Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum 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