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

Add abstract methods to the class system.

Browse Source
This commit is contained in:
Asumu Takikawa 2012-02-01 17:40:17 -05:00
parent be9faeac65
commit 06091079b1
1 changed files with 95 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

132
collects/racket/private/class-internal.rkt
View File

@ -68,7 +68,7 @@
rename-super rename-inner inherit inherit/super inherit/inner inherit-field rename-super rename-inner inherit inherit/super inherit/inner inherit-field
this this% super inner this this% super inner
super-make-object super-instantiate super-new super-make-object super-instantiate super-new
inspect absent)) inspect absent abstract))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
@ -125,7 +125,8 @@
[inherit -inherit] [inherit -inherit]
[inherit-field -inherit-field] [inherit-field -inherit-field]
[inherit/super -inherit/super] [inherit/super -inherit/super]
[inherit/inner -inherit/inner]) [inherit/inner -inherit/inner]
[abstract -abstract])
(define-for-syntax (rewrite-naming-class-keyword stx internal-id) (define-for-syntax (rewrite-naming-class-keyword stx internal-id)
(syntax-case stx () (syntax-case stx ()
@ -339,6 +340,7 @@
(quote-syntax -inherit/super) (quote-syntax -inherit/super)
(quote-syntax -inherit/inner) (quote-syntax -inherit/inner)
(quote-syntax -rename-inner) (quote-syntax -rename-inner)
(quote-syntax -abstract)
(quote-syntax super) (quote-syntax super)
(quote-syntax inner) (quote-syntax inner)
(quote-syntax this) (quote-syntax this)
@ -690,6 +692,7 @@
-public-final -override-final -augment-final -public-final -override-final -augment-final
-pubment -overment -augment -pubment -overment -augment
-rename-super -inherit -inherit/super -inherit/inner -rename-inner -rename-super -inherit -inherit/super -inherit/inner -rename-inner
-abstract
-inspect) -inspect)
[(form orig idp ...) [(form orig idp ...)
(and (identifier? (syntax form)) (and (identifier? (syntax form))
@ -765,7 +768,8 @@
-inherit -inherit
-inherit/super -inherit/super
-inherit/inner -inherit/inner
-inherit-field))))) -inherit-field
-abstract)))))
(let ([form (syntax-e (syntax form))]) (let ([form (syntax-e (syntax form))])
(for-each (for-each
(lambda (idp) (lambda (idp)
@ -805,6 +809,8 @@
(bad "ill-formed inherit/inner clause" stx)] (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)]
[(-abstract . rest)
(bad "ill-formed abstract clause" stx)]
[(kw idp ...) [(kw idp ...)
(and (identifier? #'kw) (and (identifier? #'kw)
(or (free-identifier=? #'-rename-super #'kw) (or (free-identifier=? #'-rename-super #'kw)
@ -842,6 +848,7 @@
-inherit -inherit
-inherit/super -inherit/super
-inherit/inner -inherit/inner
-abstract
-rename-inner))) -rename-inner)))
defn-and-exprs defn-and-exprs
cons)] cons)]
@ -903,6 +910,8 @@
(flatten pair (extract* (list (quote-syntax -inherit/super)) decls))] (flatten pair (extract* (list (quote-syntax -inherit/super)) decls))]
[(inherit/inners) [(inherit/inners)
(flatten pair (extract* (list (quote-syntax -inherit/inner)) decls))] (flatten pair (extract* (list (quote-syntax -inherit/inner)) decls))]
[(abstracts)
(flatten pair (extract* (list (quote-syntax -abstract)) decls))]
[(rename-inners) [(rename-inners)
(flatten pair (extract* (list (quote-syntax -rename-inner)) decls))]) (flatten pair (extract* (list (quote-syntax -rename-inner)) decls))])
@ -956,11 +965,13 @@
[inherit-names (map car inherits)] [inherit-names (map car inherits)]
[inherit/super-names (map car inherit/supers)] [inherit/super-names (map car inherit/supers)]
[inherit/inner-names (map car inherit/inners)] [inherit/inner-names (map car inherit/inners)]
[abstract-names (map car abstracts)]
[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
overments augments overments augments
override-finals augment-finals))] override-finals augment-finals
abstracts))]
[local-public-names (append (map car (append pubments public-finals)) [local-public-names (append (map car (append pubments public-finals))
local-public-dynamic-names)] local-public-dynamic-names)]
[local-method-names (append (map car privates) local-public-names)] [local-method-names (append (map car privates) local-public-names)]
@ -1089,6 +1100,7 @@
(check-dup "field" (map norm-init/field-eid (append normal-plain-fields normal-plain-init-fields)))) (check-dup "field" (map norm-init/field-eid (append normal-plain-fields normal-plain-init-fields))))
;; -- Check that private/public/override/augride are defined -- ;; -- Check that private/public/override/augride are defined --
;; -- and that abstracts are *not* defined --
(let ([ht (make-hasheq)] (let ([ht (make-hasheq)]
[stx-ht (make-hasheq)]) [stx-ht (make-hasheq)])
(for-each (for-each
@ -1103,17 +1115,23 @@
defined-syntax-names) defined-syntax-names)
(for-each (for-each
(lambda (pubovr-name) (lambda (pubovr-name)
(let ([l (hash-ref ht (syntax-e pubovr-name) null)]) (let ([l (hash-ref ht (syntax-e pubovr-name) null)]
(unless (ormap (lambda (i) (bound-identifier=? i pubovr-name)) l) [stx-l (hash-ref stx-ht (syntax-e pubovr-name) null)])
;; Either undefined or defined as syntax: (cond ;; defined as value
(let ([stx-l (hash-ref stx-ht (syntax-e pubovr-name) null)]) [(ormap (lambda (i) (bound-identifier=? i pubovr-name)) l)
(if (ormap (lambda (i) (bound-identifier=? i pubovr-name)) stx-l) ;; check if abstract and fail if so
(bad (when (memq pubovr-name abstract-names)
"method declared but defined as syntax" (bad "method declared as abstract but was defined"
pubovr-name) pubovr-name))]
(bad ;; defined as syntax
"method declared but not defined" [(ormap (lambda (i) (bound-identifier=? i pubovr-name)) stx-l)
pubovr-name)))))) (bad "method declared but defined as syntax"
pubovr-name)]
;; undefined
[else
(unless (memq pubovr-name abstract-names)
(bad "method declared as concrete but not defined"
pubovr-name))])))
local-method-names)) local-method-names))
;; ---- Check that rename-inner doesn't have a non-final decl --- ;; ---- Check that rename-inner doesn't have a non-final decl ---
@ -1230,7 +1248,7 @@
(append publics overrides augrides (append publics overrides augrides
overments augments overments augments
override-finals augment-finals override-finals augment-finals
all-inherits)))] all-inherits abstracts)))]
[(inherit-field-accessor ...) (generate-temporaries [(inherit-field-accessor ...) (generate-temporaries
(map (lambda (id) (map (lambda (id)
(format "get-~a" (format "get-~a"
@ -1369,6 +1387,7 @@
[(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 all-inherits)] [inherit-names (map lookup-localize-cdr all-inherits)]
[abstract-names (map lookup-localize-cdr abstracts)]
[num-fields (datum->syntax [num-fields (datum->syntax
(quote-syntax here) (quote-syntax here)
(+ (length private-field-names) (+ (length private-field-names)
@ -1395,6 +1414,7 @@
augrides)))] augrides)))]
[(pubment-method ...) (map (find-method methods) (map car pubments))] [(pubment-method ...) (map (find-method methods) (map car pubments))]
[(public-final-method ...) (map (find-method methods) (map car public-finals))] [(public-final-method ...) (map (find-method methods) (map car public-finals))]
[(abstract-method ...) (map (find-method methods) (map car abstracts))]
[mappings mappings] [mappings mappings]
[exprs exprs] [exprs exprs]
@ -1432,6 +1452,7 @@
`augment-final-names `augment-final-names
`augride-names `augride-names
`inherit-names `inherit-names
`abstract-names
;; Init arg names (in order) ;; Init arg names (in order)
`init-names `init-names
(quote init-mode) (quote init-mode)
@ -1525,7 +1546,8 @@
[public-final-temp public-final-method] [public-final-temp public-final-method]
...) ...)
(values (values
(list pubment-temp ... public-final-temp ... . public-methods) (list pubment-temp ... public-final-temp ...
abstract-method ... . public-methods)
(list . override-methods) (list . override-methods)
(list . augride-methods) (list . augride-methods)
;; Initialization ;; Initialization
@ -1861,10 +1883,11 @@
method-width ; total number of methods method-width ; total number of methods
method-ht ; maps public names to vector positions method-ht ; maps public names to vector positions
method-ids ; reverse-ordered list of public method names method-ids ; reverse-ordered list of public method names
abstract-ids ; list of abstract method names
method-ictcs ; list of indices of methods to fix for interface ctcs method-ictcs ; list of indices of methods to fix for interface ctcs
ictc-classes ; concretized versions of this class keyed by blame ictc-classes ; concretized versions of this class keyed by blame
methods ; vector of methods (for external dynamic dispatch) methods ; vector of methods (for external dynamic dispatch)
super-methods ; vector of methods (for subclass super calls) super-methods ; vector of methods (for subclass super calls)
int-methods ; vector of vector of methods (for internal dynamic dispatch) int-methods ; vector of vector of methods (for internal dynamic dispatch)
@ -1941,6 +1964,7 @@
augment-final-names augment-final-names
augride-normal-names augride-normal-names
inherit-names inherit-names
abstract-names
init-args ; list of symbols in order, or #f init-args ; list of symbols in order, or #f
init-mode ; 'normal, 'stop, or 'list init-mode ; 'normal, 'stop, or 'list
@ -1975,7 +1999,8 @@
(check-still-unique name (check-still-unique name
(append pubment-names public-final-names public-normal-names (append pubment-names public-final-names public-normal-names
overment-names override-final-names override-normal-names overment-names override-final-names override-normal-names
augment-names augment-final-names augride-normal-names) augment-names augment-final-names augride-normal-names
abstract-names)
"method names")) "method names"))
;; -- Create new class's name -- ;; -- Create new class's name --
@ -1987,12 +2012,12 @@
(format "derived-from-~a" s) (format "derived-from-~a" s)
s))))] s))))]
;; Combine method lists ;; Combine method lists
[public-names (append pubment-names public-final-names public-normal-names)] [public-names (append pubment-names public-final-names public-normal-names abstract-names)]
[override-names (append overment-names override-final-names override-normal-names)] [override-names (append overment-names override-final-names override-normal-names)]
[augride-names (append augment-names augment-final-names augride-normal-names)] [augride-names (append augment-names augment-final-names augride-normal-names)]
[final-names (append public-final-names override-final-names augment-final-names)] [final-names (append public-final-names override-final-names augment-final-names)]
[augonly-names (append pubment-names overment-names augment-names)] [augonly-names (append pubment-names overment-names augment-names)]
;; Mis utilities ;; Misc utilities
[no-new-methods? (null? public-names)] [no-new-methods? (null? public-names)]
[no-method-changes? (and (null? public-names) [no-method-changes? (and (null? public-names)
(null? override-names) (null? override-names)
@ -2027,7 +2052,8 @@
[super-method-ht (class-method-ht super)] [super-method-ht (class-method-ht super)]
[super-method-ids (class-method-ids super)] [super-method-ids (class-method-ids super)]
[super-field-ids (class-field-ids super)] [super-field-ids (class-field-ids super)]
[super-field-ht (class-field-ht super)]) [super-field-ht (class-field-ht super)]
[super-abstract-ids (class-abstract-ids super)])
;; Put new ids in table, with pos (replace field pos with accessor info later) ;; Put new ids in table, with pos (replace field pos with accessor info later)
(unless no-new-methods? (unless no-new-methods?
@ -2039,6 +2065,19 @@
id id
(for-class name))) (for-class name)))
(hash-set! method-ht id p))) (hash-set! method-ht id p)))
;; Make sure new abstracts do not conflict with super methods
;; TODO: this check may be redundant
#;
(unless no-new-methods?
(for ([id abstract-names])
(when (memq id super-method-ids)
(obj-error 'class* "superclass ~e already contains method: ~a~a"
super
id
(for-class name)))
(hash-set! method-ht id #t)))
;; Keep check here for early failure, will add to hashtable later in this function. ;; Keep check here for early failure, will add to hashtable later in this function.
(unless no-new-fields? (unless no-new-fields?
(for ([id (in-list public-field-names)]) (for ([id (in-list public-field-names)])
@ -2086,7 +2125,8 @@
[rename-inner-indices (get-indices method-ht "rename-inner" rename-inner-names)] [rename-inner-indices (get-indices method-ht "rename-inner" rename-inner-names)]
[new-augonly-indices (get-indices method-ht "pubment" pubment-names)] [new-augonly-indices (get-indices method-ht "pubment" pubment-names)]
[new-final-indices (get-indices method-ht "public-final" public-final-names)] [new-final-indices (get-indices method-ht "public-final" public-final-names)]
[new-normal-indices (get-indices method-ht "public" public-normal-names)]) [new-normal-indices (get-indices method-ht "public" public-normal-names)]
[new-abstract-indices (get-indices method-ht "abstract" abstract-names)])
;; -- Check that all interfaces are satisfied -- ;; -- Check that all interfaces are satisfied --
(for-each (for-each
@ -2132,6 +2172,10 @@
make-interface)] make-interface)]
[method-names (append (reverse public-names) super-method-ids)] [method-names (append (reverse public-names) super-method-ids)]
[field-names (append public-field-names super-field-ids)] [field-names (append public-field-names super-field-ids)]
;; Superclass abstracts that have not been concretized
[remaining-abstract-names
(append abstract-names
(remq* override-names super-abstract-ids))]
[super-interfaces (cons (class-self-interface super) interfaces)] [super-interfaces (cons (class-self-interface super) interfaces)]
[i (interface-make name super-interfaces #f method-names (make-immutable-hash) #f null)] [i (interface-make name super-interfaces #f method-names (make-immutable-hash) #f null)]
[methods (if no-method-changes? [methods (if no-method-changes?
@ -2164,7 +2208,8 @@
i i
(let-values ([(struct: make- ? -ref -set) (make-struct-type 'insp #f 0 0 #f null inspector)]) (let-values ([(struct: make- ? -ref -set) (make-struct-type 'insp #f 0 0 #f null inspector)])
make-) make-)
method-width method-ht method-names (interfaces->contracted-methods (list i)) method-width method-ht method-names remaining-abstract-names
(interfaces->contracted-methods (list i))
(make-weak-hasheq) (make-weak-hasheq)
methods super-methods int-methods beta-methods meth-flags methods super-methods int-methods beta-methods meth-flags
inner-projs dynamic-idxs dynamic-projs inner-projs dynamic-idxs dynamic-projs
@ -2323,19 +2368,26 @@
(vector-copy! dynamic-idxs 0 (class-dynamic-idxs super)) (vector-copy! dynamic-idxs 0 (class-dynamic-idxs super))
(for-each (lambda (index) (for-each (lambda (index)
(vector-set! dynamic-idxs index 0)) (vector-set! dynamic-idxs index 0))
(append new-augonly-indices new-final-indices new-normal-indices))) (append new-augonly-indices new-final-indices
new-normal-indices new-abstract-indices)))
;; -- Create method accessors -- ;; -- Create method accessors --
(let ([method-accessors (map (lambda (index) (let* ([method-accessors/no-abstracts
(let ([dyn-idx (vector-ref dynamic-idxs index)]) (map (lambda (index)
(lambda (obj) (let ([dyn-idx (vector-ref dynamic-idxs index)])
(vector-ref (vector-ref (class-int-methods (object-ref obj)) (lambda (obj)
index) (vector-ref (vector-ref (class-int-methods (object-ref obj))
dyn-idx)))) index)
(append new-normal-indices replace-normal-indices refine-normal-indices dyn-idx))))
replace-augonly-indices refine-augonly-indices (append new-normal-indices replace-normal-indices refine-normal-indices
replace-final-indices refine-final-indices replace-augonly-indices refine-augonly-indices
inherit-indices))]) replace-final-indices refine-final-indices
inherit-indices))]
[method-accessors (append method-accessors/no-abstracts
(map (lambda (name)
(lambda (obj)
(error "Cannot call accessor on abstract method")))
abstract-names))])
;; -- Get new methods and initializers -- ;; -- Get new methods and initializers --
(let-values ([(new-methods override-methods augride-methods init) (let-values ([(new-methods override-methods augride-methods init)
@ -2364,7 +2416,8 @@
(vector-set! inner-projs index identity) (vector-set! inner-projs index identity)
(vector-set! dynamic-idxs index 0) (vector-set! dynamic-idxs index 0)
(vector-set! dynamic-projs index (vector identity))) (vector-set! dynamic-projs index (vector identity)))
(append new-augonly-indices new-final-indices new-normal-indices) (append new-augonly-indices new-final-indices
new-abstract-indices new-normal-indices)
new-methods) new-methods)
;; Override old methods: ;; Override old methods:
(for-each (lambda (index method id) (for-each (lambda (index method id)
@ -2812,6 +2865,7 @@ An example
method-width method-width
method-ht method-ht
(class-method-ids cls) (class-method-ids cls)
(class-abstract-ids cls)
(remq* ctc-methods method-ictcs) (remq* ctc-methods method-ictcs)
(make-weak-hasheq) (make-weak-hasheq)
@ -3658,7 +3712,7 @@ An example
object<%> object<%>
void ; never inspectable void ; never inspectable
0 (make-hasheq) null null 0 (make-hasheq) null null null
(make-weak-hasheq) (make-weak-hasheq)
(vector) (vector) (vector) (vector) (vector) (vector) (vector) (vector) (vector) (vector)
@ -3888,6 +3942,9 @@ An example
(define (do-make-object blame class by-pos-args named-args) (define (do-make-object blame class by-pos-args named-args)
(unless (class? class) (unless (class? class)
(raise-type-error 'instantiate "class" class)) (raise-type-error 'instantiate "class" class))
;; TODO: make sure this error is the right one to raise
(unless (null? (class-abstract-ids class))
(obj-error 'instantiate "cannot instantiate abstract class ~a" class))
;; Generate correct class by concretizing methods w/interface ctcs ;; Generate correct class by concretizing methods w/interface ctcs
(let* ([class (fetch-concrete-class class blame)] (let* ([class (fetch-concrete-class class blame)]
[o ((class-make-object class))]) [o ((class-make-object class))])
@ -4714,6 +4771,7 @@ An example
method-width method-width
method-ht method-ht
(class-method-ids cls) (class-method-ids cls)
(class-abstract-ids cls)
(class-method-ictcs cls) (class-method-ictcs cls)
(class-ictc-classes cls) (class-ictc-classes cls)