suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add inherit/super and inherit/inner (to eventually replace rename-inner and rename-super)

Browse Source 
svn: r4087
This commit is contained in:
Matthew Flatt 2006-08-18 00:47:32 +00:00
parent b26c6fb351
commit 35d14b301f
2 changed files with 35 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/class.ss
View File

@ -36,7 +36,7 @@
pubment overment augride pubment overment augride
public-final override-final augment-final public-final override-final augment-final
field init init-field field init init-field
rename-super rename-inner inherit inherit-field rename-super rename-inner inherit inherit/super inherit/inner inherit-field
this super inner this super inner
super-make-object super-instantiate super-new super-make-object super-instantiate super-new
inspect)) inspect))

45
collects/mzlib/private/class-internal.ss
View File

@ -40,6 +40,7 @@
pubment overment augment pubment overment augment
public-final override-final augment-final public-final override-final augment-final
rename-super rename-inner inherit inherit-field rename-super rename-inner inherit inherit-field
inherit/super inherit/inner
inspect) inspect)
(define-syntax provide-class-define-like-keyword (define-syntax provide-class-define-like-keyword
@ -142,6 +143,8 @@
(quote-syntax augment) (quote-syntax augment)
(quote-syntax rename-super) (quote-syntax rename-super)
(quote-syntax inherit) (quote-syntax inherit)
(quote-syntax inherit/super)
(quote-syntax inherit/inner)
(quote-syntax rename-inner) (quote-syntax rename-inner)
(quote-syntax super) (quote-syntax super)
(quote-syntax inner) (quote-syntax inner)
@ -436,7 +439,7 @@
private public override augride private public override augride
public-final override-final augment-final public-final override-final augment-final
pubment overment augment pubment overment augment
rename-super inherit rename-inner rename-super inherit inherit/super inherit/inner rename-inner
inspect) inspect)
[(form orig idp ...) [(form orig idp ...)
(and (identifier? (syntax form)) (and (identifier? (syntax form))
@ -510,6 +513,8 @@
overment overment
augment augment
inherit inherit
inherit/super
inherit/inner
inherit-field))))) inherit-field)))))
(let ([form (syntax-e (syntax form))]) (let ([form (syntax-e (syntax form))])
(for-each (for-each
@ -544,6 +549,10 @@
(bad "ill-formed augment clause" stx)] (bad "ill-formed augment clause" stx)]
[(inherit . rest) [(inherit . rest)
(bad "ill-formed inherit clause" stx)] (bad "ill-formed inherit clause" stx)]
[(inherit/super . rest)
(bad "ill-formed inherit/super clause" stx)]
[(inherit/inner . rest)
(bad "ill-formed inherit/inner clause" stx)]
[(inherit-field . rest) [(inherit-field . rest)
(bad "ill-formed inherit-field clause" stx)] (bad "ill-formed inherit-field clause" stx)]
[(kw idp ...) [(kw idp ...)
@ -581,6 +590,8 @@
augment augment
rename-super rename-super
inherit inherit
inherit/super
inherit/inner
rename-inner))) rename-inner)))
defn-and-exprs defn-and-exprs
cons)] cons)]
@ -638,6 +649,10 @@
(flatten pair (extract* (list (quote-syntax rename-super)) decls))] (flatten pair (extract* (list (quote-syntax rename-super)) decls))]
[(inherits) [(inherits)
(flatten pair (extract* (list (quote-syntax inherit)) decls))] (flatten pair (extract* (list (quote-syntax inherit)) decls))]
[(inherit/supers)
(flatten pair (extract* (list (quote-syntax inherit/super)) decls))]
[(inherit/inners)
(flatten pair (extract* (list (quote-syntax inherit/inner)) decls))]
[(rename-inners) [(rename-inners)
(flatten pair (extract* (list (quote-syntax rename-inner)) decls))]) (flatten pair (extract* (list (quote-syntax rename-inner)) decls))])
@ -689,6 +704,8 @@
[inherit-field-names (map car inherit-fields)] [inherit-field-names (map car inherit-fields)]
[plain-init-names (map norm-init/field-iid normal-plain-inits)] [plain-init-names (map norm-init/field-iid normal-plain-inits)]
[inherit-names (map car inherits)] [inherit-names (map car inherits)]
[inherit/super-names (map car inherit/supers)]
[inherit/inner-names (map car inherit/inners)]
[rename-super-names (map car rename-supers)] [rename-super-names (map car rename-supers)]
[rename-inner-names (map car rename-inners)] [rename-inner-names (map car rename-inners)]
[local-public-dynamic-names (map car (append publics overrides augrides [local-public-dynamic-names (map car (append publics overrides augrides
@ -703,6 +720,8 @@
inherit-field-names inherit-field-names
plain-init-names plain-init-names
inherit-names inherit-names
inherit/super-names
inherit/inner-names
rename-super-names rename-super-names
rename-inner-names rename-inner-names
(kernel-form-identifier-list (kernel-form-identifier-list
@ -790,6 +809,8 @@
inherit-field-names inherit-field-names
plain-init-names plain-init-names
inherit-names inherit-names
inherit/super-names
inherit/inner-names
rename-super-names rename-super-names
rename-inner-names))]) rename-inner-names))])
(when dup (when dup
@ -914,12 +935,14 @@
(lambda (id-stx) (lambda (id-stx)
(datum->syntax-object (quote-syntax here) (datum->syntax-object (quote-syntax here)
(gensym (syntax-e id-stx))))] (gensym (syntax-e id-stx))))]
[rename-super-extras (append overments overrides override-finals)] [rename-super-extras (append overments overrides override-finals inherit/supers)]
[rename-inner-extras (append pubments overments augments)] [rename-inner-extras (append pubments overments augments inherit/inners)]
[all-rename-inners (append (map car rename-inners) [all-rename-inners (append (map car rename-inners)
(generate-temporaries (map car pubments)) (generate-temporaries (map car pubments))
(generate-temporaries (map car overments)) (generate-temporaries (map car overments))
(generate-temporaries (map car augments)))] (generate-temporaries (map car augments))
(generate-temporaries (map car inherit/inners)))]
[all-inherits (append inherits inherit/supers inherit/inners)]
[definify (lambda (l) [definify (lambda (l)
(map bind-local-id l) (map bind-local-id l)
l)]) l)])
@ -948,16 +971,16 @@
mk-method-temp mk-method-temp
(map car public-finals))] (map car public-finals))]
[(method-name ...) (append local-public-dynamic-names [(method-name ...) (append local-public-dynamic-names
(map car inherits))] (map car all-inherits))]
[(method-name-localized ...) (map lookup-localize [(method-name-localized ...) (map lookup-localize
(append local-public-dynamic-names (append local-public-dynamic-names
(map car inherits)))] (map car all-inherits)))]
[(method-accessor ...) (generate-temporaries [(method-accessor ...) (generate-temporaries
(map car (map car
(append publics overrides augrides (append publics overrides augrides
overments augments overments augments
override-finals augment-finals override-finals augment-finals
inherits)))] all-inherits)))]
[(inherit-field-accessor ...) (generate-temporaries [(inherit-field-accessor ...) (generate-temporaries
(map (lambda (id) (map (lambda (id)
(format "get-~a" (format "get-~a"
@ -968,7 +991,7 @@
(format "set-~a!" (format "set-~a!"
(syntax-e id))) (syntax-e id)))
inherit-field-names))] inherit-field-names))]
[(inherit-name ...) (definify (map car inherits))] [(inherit-name ...) (definify (map car all-inherits))]
[(inherit-field-name ...) (definify inherit-field-names)] [(inherit-field-name ...) (definify inherit-field-names)]
[(inherit-field-name-localized ...) (map lookup-localize inherit-field-names)] [(inherit-field-name-localized ...) (map lookup-localize inherit-field-names)]
[(local-field ...) (definify [(local-field ...) (definify
@ -1093,7 +1116,7 @@
[(rename-super-extra-name ...) (map lookup-localize-cdr rename-super-extras)] [(rename-super-extra-name ...) (map lookup-localize-cdr rename-super-extras)]
[(rename-inner-name ...) (map lookup-localize-cdr rename-inners)] [(rename-inner-name ...) (map lookup-localize-cdr rename-inners)]
[(rename-inner-extra-name ...) (map lookup-localize-cdr rename-inner-extras)] [(rename-inner-extra-name ...) (map lookup-localize-cdr rename-inner-extras)]
[inherit-names (map lookup-localize-cdr inherits)] [inherit-names (map lookup-localize-cdr all-inherits)]
[num-fields (datum->syntax-object [num-fields (datum->syntax-object
(quote-syntax here) (quote-syntax here)
(+ (length private-field-names) (+ (length private-field-names)
@ -1194,7 +1217,7 @@
#f #f
(string-append (string-append
"identifier for super call does not have an override, " "identifier for super call does not have an override, "
"override-final, or overment declaration") "override-final, overment, or inherit/super declaration")
stx stx
#'id)] #'id)]
[_else [_else
@ -1220,7 +1243,7 @@
#f #f
(string-append (string-append
"identifier for inner call does not have a pubment, augment, " "identifier for inner call does not have a pubment, augment, "
"or overment declaration") "overment, or inherit/inner declaration")
stx stx
#'id)] #'id)]
[(_) [(_)