conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

define-record-type now understands parent-rtd (used to ignore it).

This commit is contained in:
Abdulaziz Ghuloum 2008-07-13 11:25:46 -07:00
parent c3b12a22e8
commit a9657c4642
2 changed files with 20 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/last-revision
View File

@ -1 +1 @@
1536 1537

34
scheme/psyntax.expander.ss
View File

@ -1851,7 +1851,7 @@
(if (free-id=? (bless id) x) (if (free-id=? (bless id) x)
`(,x . ,rest) `(,x . ,rest)
(get-clause id ls))])) (get-clause id ls))]))
(define (foo-rtd-code name clause*) (define (foo-rtd-code name clause* parent-rtd-code)
(define (convert-field-spec* ls) (define (convert-field-spec* ls)
(list->vector (list->vector
(map (lambda (x) (map (lambda (x)
@ -1860,11 +1860,7 @@
[(immutable name . rest) `(immutable ,name)] [(immutable name . rest) `(immutable ,name)]
[name `(immutable ,name)])) [name `(immutable ,name)]))
ls))) ls)))
(let ([parent-rtd-code (let ([uid-code
(syntax-match (get-clause 'parent clause*) ()
[(_ name) `(record-type-descriptor ,name)]
[_ '#f])]
[uid-code
(syntax-match (get-clause 'nongenerative clause*) () (syntax-match (get-clause 'nongenerative clause*) ()
[(_) `',(gensym)] [(_) `',(gensym)]
[(_ uid) `',uid] [(_ uid) `',uid]
@ -1886,13 +1882,21 @@
`(make-record-type-descriptor ',name `(make-record-type-descriptor ',name
,parent-rtd-code ,parent-rtd-code
,uid-code ,sealed? ,opaque? ,fields)))) ,uid-code ,sealed? ,opaque? ,fields))))
(define (foo-rcd-code clause* foo-rtd protocol) (define (parent-rtd-code clause*)
(let ([parent-rcd-code (syntax-match (get-clause 'parent clause*) ()
(syntax-match (get-clause 'parent clause*) () [(_ name) `(record-type-descriptor ,name)]
[(_ name) `(record-constructor-descriptor ,name)] [#f (syntax-match (get-clause 'parent-rtd clause*) ()
[_ #f])]) [(_ rtd rcd) rtd]
`(make-record-constructor-descriptor ,foo-rtd [#f #f])]))
,parent-rcd-code ,protocol))) (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*) (define (get-protocol-code clause*)
(syntax-match (get-clause 'protocol clause*) () (syntax-match (get-clause 'protocol clause*) ()
[(_ expr) expr] [(_ expr) expr]
@ -1962,8 +1966,8 @@
[set-foo-x!* (get-mutators foo fields)] [set-foo-x!* (get-mutators foo fields)]
[set-foo-idx* (get-mutator-indices fields)] [set-foo-idx* (get-mutator-indices fields)]
[foo? (get-record-predicate-name namespec)] [foo? (get-record-predicate-name namespec)]
[foo-rtd-code (foo-rtd-code foo clause*)] [foo-rtd-code (foo-rtd-code foo clause* (parent-rtd-code clause*))]
[foo-rcd-code (foo-rcd-code clause* foo-rtd protocol)] [foo-rcd-code (foo-rcd-code clause* foo-rtd protocol (parent-rcd-code clause*))]
[protocol-code (get-protocol-code clause*)]) [protocol-code (get-protocol-code clause*)])
(bless (bless
`(begin `(begin