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