diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 340fd6fe3d..7c48ed9aeb 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -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)