diff --git a/collects/profj/build-info.ss b/collects/profj/build-info.ss index bcebc5cf02..e78feca4b2 100644 --- a/collects/profj/build-info.ss +++ b/collects/profj/build-info.ss @@ -555,7 +555,7 @@ iface-records (header-implements info) m type-recs level) (no-abstract-methods m members level type-recs))) - + (valid-inherited-methods? (cons super-record iface-records) (cons (if (null? super) (make-name (make-id "Object" #f) null #f) @@ -569,6 +569,15 @@ level type-recs) + (when (and (memq 'abstract test-mods) + (or (not (null? iface-records)) + (not (null? (header-implements info))))) + (let ((unimp-stubs (make-unimplmented-stubs iface-records (header-implements info) + m type-recs))) + (set-def-members! class + (append unimp-stubs (def-members class))) + (set! m (append m (map method-rec unimp-stubs))))) + (let ((record (make-class-record cname @@ -1035,7 +1044,7 @@ #f)))) (check-for-conflicts (cdr methods) record members level type-recs))) - ;class-fully-implemented? class-record id (list class-record) (list id) (list method) symbol -> bool + ;class-fully-implemented? class-record id (list class-record) (list id) (list method) type-records symbol -> bool (define (class-fully-implemented? super super-name ifaces ifaces-name methods type-recs level) (when (memq 'abstract (class-record-modifiers super)) (let ((unimplemented-iface-methods (get-unimplemented-methods (class-record-methods super) @@ -1052,6 +1061,59 @@ ifaces ifaces-name)) + ;make-unimplmented-stubs: (list class-record) (list name) (list method-record) type-records -> (list method) + (define (make-unimplmented-stubs ifaces ifaces-name methods type-recs) + (letrec ((type->type-spec + (lambda (t) + (cond + ((symbol? t) (make-type-spec t 0 #f)) + ((ref-type? t) (make-type-spec (make-name (make-id (ref-type-class/iface t) #f) + (map (lambda (t) (make-id t #f)) + (ref-type-path t)) #f) + 0 #f)) + ((array-type? t) (make-type-spec (type-spec-name (type->type-spec (array-type-type t))) + (array-type-dim t)))))) + (copy-method-record + (lambda (m) + (make-method-record (method-record-name m) + (cons 'abstract (method-record-modifiers m)) + (method-record-rtype m) + (method-record-atypes m) + (method-record-throws m) + #f + (method-record-class m)))) + (remove-dups + (lambda (l) + (cond + ((null? l) l) + ((member (car l) (cdr l)) (remove-dups (cdr l))) + (else (cons (car l) (remove-dups (cdr l))))))) + (unimplemented-iface-methods + (car (get-unimplemented-methods methods + (remove-dups (append (map (lambda (iface) + (cond + ((id? iface) (list (id-string iface))) + ((name? iface) (cons (id-string (name-id iface)) + (map id-string (name-path iface)))))) + ifaces-name) + (map class-record-name ifaces))) type-recs)))) + (apply append + (map (lambda (m-lists) + (map (lambda (m) + (make-method (cons (make-modifier 'abstract #f) + (map (lambda (a) (make-modifier a #f)) (method-record-modifiers m))) + (type->type-spec (method-record-rtype m)) + null + (make-id (method-record-name m) #f) + (map (lambda (a) + (make-var-decl (make-id (gensym) #f) null + (type->type-spec a) #f)) + (method-record-atypes m)) + null #f #f + (copy-method-record m) #f)) + m-lists)) + unimplemented-iface-methods)))) + ;get-unimplemented-methods: (list method-record) (list (list string)) type-recs -> (list (list (list method-record)) (list string( (define (get-unimplemented-methods methods ifaces type-recs) (letrec ((method-req-equal diff --git a/collects/profj/check.ss b/collects/profj/check.ss index 9cac1e1c1a..0b26e8a394 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -2152,6 +2152,11 @@ (when (and static? (not (memq 'static mods)) (not expr)) (non-static-called-error name c-class src level)) + (when (and (memq 'abstract mods) + (special-name? expr) + (equal? "super" (special-name-name expr))) + (call-abstract-error level name exp-type src)) + (when (and (memq 'protected mods) (reference-type? exp-type) (or (not (is-eq-subclass? this exp-type type-recs)) (not (package-members? c-class (cons (ref-type-class/iface exp-type) (ref-type-path exp-type)) @@ -3038,6 +3043,16 @@ types))))) (substring out 0 (- (string-length out) 5)))) + ;call-abstract-error: symbol id type src -> void + (define (call-abstract-error level name exp src) + (let ((n (id->ext-name name)) + (t (get-call-type exp))) + (raise-error n + (if (memq level '(beginner)) + (format "You maynot call method ~a from ~a" n t) + (format "super.~a(...) may not be called as ~a is abstract in ~a." n n t)) + n src))) + ;call-access-error: symbol symbol id type src -> void (define (call-access-error kind level name exp src) (let ((n (id->ext-name name)) diff --git a/collects/tests/profj/intermediate-tests.ss b/collects/tests/profj/intermediate-tests.ss index 7e56315287..b9f72b9d21 100644 --- a/collects/tests/profj/intermediate-tests.ss +++ b/collects/tests/profj/intermediate-tests.ss @@ -4,6 +4,22 @@ (prepare-for-tests "Intermediate") ;;Execute tests without errors + + (execute-test + "interface A { int a(); } + abstract class B implements A { } + " + 'intermediate + #f "abstract class not fully implementing an interface") + + (execute-test + "interface A { int a(); } + abstract class B implements A { } + class C extends B { + int a() { return 3; } + }" + 'intermediate + #f "class implementing abstract class's unimplmenented interface") (execute-test "abstract class Foo { @@ -301,7 +317,23 @@ }" 'intermediate #f "Casts of class to implementing iface, and reverse") ;;Execute tests with errors + + (execute-test + "interface A { int a(); } + abstract class B implements A { } + class C extends B { int a() { return super.a() + 3; } }" + 'intermediate + #t "Extending class calls super.a() of an abstract method") + + (execute-test + "interface A { int a(); } + abstract class B implements A { } + class C extends B { }" + 'intermediate + #t + "Extending class fails to implement abstract parent's unimplemented interfaces") + (execute-test "class Foo { Foo() {}