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

Corrected bugs:

Browse Source 
abstract class implementing interface does not have to fully implement it
  super.METHOD(...) now fails when super method is abstract

svn: r2291
This commit is contained in:
Kathy Gray 2006-02-20 23:10:04 +00:00
parent 4190ed9af2
commit ce5eca215c
3 changed files with 111 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
collects/profj/build-info.ss
View File

@ -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

15
collects/profj/check.ss
View File

@ -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))

32
collects/tests/profj/intermediate-tests.ss
View File

@ -5,6 +5,22 @@
;;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 {
abstract int f();
@ -302,6 +318,22 @@
;;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() {}