Correction to bug causing methods with the same name and different access to interfere with each other.
Correction to bug allowing package access methods to implement interface methods. Correction to bug preventing interactions window from accessing protected fields. svn: r3922
This commit is contained in:
Kathy Gray
parent
894fbdc63e
commit
325c304560
|
|
@ -557,9 +557,9 @@
|
|||
(let*-values (((old-methods) (class-record-methods super-record))
|
||||
((f m i)
|
||||
(if (memq 'strictfp test-mods)
|
||||
(process-members members old-methods cname type-recs level #f
|
||||
(process-members members old-methods cname type-recs level #f #f
|
||||
(find-strictfp modifiers))
|
||||
(process-members members old-methods cname type-recs level #f)))
|
||||
(process-members members old-methods cname type-recs level #f #f)))
|
||||
((ctor?) (has-ctor? m)))
|
||||
|
||||
(unless ctor?
|
||||
|
|
@ -766,7 +766,7 @@
|
|||
|
||||
(let-values (((f m i) (process-members members (apply append
|
||||
(map class-record-methods super-records))
|
||||
iname type-recs level #f)))
|
||||
iname type-recs level #t #f)))
|
||||
|
||||
(valid-field-names? f members m level type-recs)
|
||||
(valid-method-sigs? m members level type-recs)
|
||||
|
|
@ -839,7 +839,7 @@
|
|||
|
||||
(let*-values (((old-methods) (class-record-methods super-record))
|
||||
((f m i)
|
||||
(process-members members old-methods tname type-recs level #t))
|
||||
(process-members members old-methods tname type-recs level #f #t))
|
||||
((ctor?) (has-ctor? m)))
|
||||
|
||||
(if ctor?
|
||||
|
|
@ -1108,6 +1108,7 @@
|
|||
(method-record-atypes (car methods))))))
|
||||
(method-member? method (cdr methods) level))))
|
||||
|
||||
;identical-method-member? method-record (listof method-record) -> method-record
|
||||
(define (identical-method-member? method methods)
|
||||
(and (not (null? methods))
|
||||
(or (and (equal? (method-record-name method)
|
||||
|
|
@ -1116,7 +1117,8 @@
|
|||
(= (length (method-record-atypes method))
|
||||
(length (method-record-atypes (car methods))))
|
||||
(andmap type=? (method-record-atypes method)
|
||||
(method-record-atypes (car methods))))
|
||||
(method-record-atypes (car methods)))
|
||||
(car methods))
|
||||
(identical-method-member? method (cdr methods)))))
|
||||
|
||||
;valid-inherited-methods?: (list class-record) (list name) symbol type-records -> bool
|
||||
|
|
@ -1292,15 +1294,27 @@
|
|||
;implements-all? (list method-record) (list method) name symbol -> bool
|
||||
(define (implements-all? inherit-methods methods name level)
|
||||
(or (null? inherit-methods)
|
||||
(and (not (identical-method-member? (car inherit-methods) methods))
|
||||
(let* ([current-method (car inherit-methods)]
|
||||
[id-name (make-id (method-record-name current-method) #f)]
|
||||
[implementing-method (identical-method-member? current-method methods)])
|
||||
(or (and (not implementing-method)
|
||||
(method-error 'not-implement
|
||||
(make-id (method-record-name (car inherit-methods)) #f)
|
||||
(method-record-atypes (car inherit-methods))
|
||||
(method-record-rtype (car inherit-methods))
|
||||
id-name
|
||||
(method-record-atypes current-method)
|
||||
(method-record-rtype current-method)
|
||||
(id-string (name-id name))
|
||||
(id-src (name-id name))
|
||||
#f))
|
||||
(implements-all? (cdr inherit-methods) methods name level)))
|
||||
(and (memq level '(advanced full))
|
||||
(not (equal-greater-access? (method-record-modifiers implementing-method)
|
||||
(method-record-modifiers current-method)))
|
||||
(implements-error id-name
|
||||
(method-record-atypes current-method)
|
||||
(method-record-modifiers implementing-method)
|
||||
(method-record-modifiers current-method)
|
||||
(id-string (name-id name))
|
||||
(id-src (name-id name))))
|
||||
(implements-all? (cdr inherit-methods) methods name level)))))
|
||||
|
||||
(define (no-abstract-methods methods members level type-recs)
|
||||
(or (null? methods)
|
||||
|
|
@ -1319,9 +1333,9 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;Methods to process fields and methods
|
||||
|
||||
;; process-members: (list members) (list method-record) (list string) type-records symbol boolean->
|
||||
;; process-members: (list members) (list method-record) (list string) type-records symbol boolean boolean->
|
||||
;; (values (list field-record) (list method-record) (list inner-record))
|
||||
(define (process-members members inherited-methods cname type-recs level test? . args)
|
||||
(define (process-members members inherited-methods cname type-recs level iface? test? . args)
|
||||
(let loop ((members members)
|
||||
(fields null)
|
||||
(methods null)
|
||||
|
|
@ -1337,8 +1351,8 @@
|
|||
(loop (cdr members)
|
||||
fields
|
||||
(cons (if (null? args)
|
||||
(process-method (car members) inherited-methods cname type-recs level test?)
|
||||
(process-method (car members) inherited-methods cname type-recs level test? (car args)))
|
||||
(process-method (car members) inherited-methods cname type-recs level iface? test?)
|
||||
(process-method (car members) inherited-methods cname type-recs level iface? test? (car args)))
|
||||
methods)
|
||||
inners))
|
||||
((def? (car members))
|
||||
|
|
@ -1361,14 +1375,19 @@
|
|||
(if (class-name) (cons (class-name) (cdr cname)) cname)
|
||||
(field-type field)))
|
||||
|
||||
;; process-method: method (list method-record) (list string) type-records symbol boolean -> method-record
|
||||
(define (process-method method inherited-methods cname type-recs level test? . args)
|
||||
;; process-method: method (list method-record) (list string) type-records symbol boolean boolean -> method-record
|
||||
(define (process-method method inherited-methods cname type-recs level iface? test? . args)
|
||||
(let* ((name (id-string (method-name method)))
|
||||
(parms (map (lambda (p)
|
||||
(set-field-type! p (type-spec-to-type (field-type-spec p) cname level type-recs))
|
||||
(field-type p))
|
||||
(method-parms method)))
|
||||
(mods (if (null? args) (method-modifiers method) (cons (car args) (method-modifiers method))))
|
||||
(mods
|
||||
(cond
|
||||
[(not (null? args)) (cons (car args) (method-modifiers method))]
|
||||
[(and iface? (not (memq 'public (map modifier-kind (method-modifiers method)))))
|
||||
(cons (make-modifier 'public #f) (method-modifiers method))]
|
||||
[else (method-modifiers method)]))
|
||||
(ret (type-spec-to-type (method-type method) cname level type-recs))
|
||||
(throws (filter (lambda (n)
|
||||
(not (or (is-eq-subclass? n runtime-exn-type type-recs))))
|
||||
|
|
@ -1768,6 +1787,18 @@
|
|||
m-full-name class r-name (type->ext-name ctor?))))
|
||||
m-name src))))
|
||||
|
||||
;implements-error: id (list type) (list symbol) (list symbol) string src -> void
|
||||
(define (implements-error name parms current-mods parent-mods class src)
|
||||
(let ([m-name (method-name->ext-name (id-string name) parms)]
|
||||
[current-access (extract-access current-mods)]
|
||||
[parent-access (extract-access parent-mods)])
|
||||
(raise-error
|
||||
'implements
|
||||
(format "Method ~a must be at least ~a to implement the ~a method from ~a; ~a access is not sufficient."
|
||||
m-name (if (eq? parent-access 'package) 'default parent-access) m-name
|
||||
class (if (eq? current-access 'package) 'default current-access))
|
||||
m-name src)))
|
||||
|
||||
;testcase-not-in-test: string string src -> void
|
||||
(define (testcase-not-in-test name class src)
|
||||
(raise-error
|
||||
|
|
@ -1892,10 +1923,10 @@
|
|||
m-name (car class) (if (list? parent) (car parent) parent))
|
||||
(format "Method ~a from ~a cannot be overridden in ~a" name parent (car class))))
|
||||
((static)
|
||||
(format "Method ~a in ~a attempts to override static method from ~a, which is not allowed"
|
||||
(format "Method ~a in ~a attempts to override static method from ~a, which is not allowed."
|
||||
m-name (car class) parent))
|
||||
((public)
|
||||
(format "Method ~a in ~a must be public to override public method from ~a, ~a is not public"
|
||||
(format "Method ~a in ~a must be public to override public method from ~a, ~a is not public."
|
||||
m-name (car class) parent name))
|
||||
((protected)
|
||||
(format
|
||||
|
|
|
|||
|
|
@ -1734,7 +1734,10 @@
|
|||
(illegal-field-access 'private (string->symbol fname) level (car field-class) src)))
|
||||
|
||||
(when (and protected?
|
||||
(not (or (equal? c-class field-class)
|
||||
(not (or (and (equal? c-class '("scheme-interactions"))
|
||||
(equal? (send type-recs get-interactions-package)
|
||||
(cdr field-class)))
|
||||
(equal? c-class field-class)
|
||||
(is-subclass? c-class (make-ref-type (car field-class) (cdr field-class)) type-recs)
|
||||
(package-members? c-class field-class type-recs))))
|
||||
(illegal-field-access 'protected (string->symbol fname) level (car field-class) src))
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@
|
|||
compilation-unit-code compilation-unit-contains set-compilation-unit-code!
|
||||
read-record write-record
|
||||
set-syntax-location create-type-record
|
||||
)
|
||||
compile-to-ast)
|
||||
|
||||
(define (set-syntax-location so) (syntax-location so))
|
||||
|
||||
|
|
@ -156,6 +156,19 @@
|
|||
(order-cus (translate-program ast type-recs)
|
||||
type-recs))
|
||||
|
||||
(define (compile-to-ast port location type-recs file? level)
|
||||
(packages null)
|
||||
(check-list null)
|
||||
(to-file file?)
|
||||
(let ((ast (parse port location level)))
|
||||
(remember-main ast)
|
||||
(load-lang type-recs)
|
||||
(set-importer! type-recs find-implicit-import)
|
||||
(build-info ast level type-recs #f)
|
||||
(unless (null? (check-list))
|
||||
(check-defs (car (check-list)) level type-recs))
|
||||
(remove-from-packages ast type-recs)))
|
||||
|
||||
;compile-java-internal: port location type-records bool level-> (list compilation-unit)
|
||||
(define (compile-java-internal port location type-recs file? level)
|
||||
(packages null)
|
||||
|
|
|
|||
|
|
@ -153,6 +153,10 @@
|
|||
(else (error 'mangle-method-name (format "Internal Error: given unexptected type ~a" t))))))))
|
||||
(format "~a~a" id (apply string-append (map parm-name types)))))
|
||||
|
||||
;mangle-private-method: string (list type) -> string
|
||||
(define (mangle-private-method name args)
|
||||
(string-append "private-" (mangle-method-name name args)))
|
||||
|
||||
;constructor? string -> bool
|
||||
(define (constructor? name)
|
||||
(equal? name (class-name)))
|
||||
|
|
@ -1460,17 +1464,22 @@
|
|||
(cons
|
||||
(build-identifier ((if (constructor? (id-string (method-name (car methods))))
|
||||
build-constructor-name
|
||||
mangle-method-name)
|
||||
mangle-private-method)
|
||||
(id-string (method-name (car methods)))
|
||||
(method-record-atypes (method-rec (car methods)))))
|
||||
(make-method-names (cdr methods) minus-methods)))))
|
||||
|
||||
|
||||
;translate-method: type-spec (list symbol) id (list parm) statement bool
|
||||
; src bool int method-record type-records -> syntax
|
||||
(define (translate-method type modifiers id parms block all-tail? src inner? depth rec type-recs)
|
||||
(let* ((final (final? modifiers))
|
||||
(ctor? (eq? 'ctor (method-record-rtype rec)));(constructor? (id-string id)))
|
||||
(method-string ((if ctor? build-constructor-name mangle-method-name)
|
||||
(ctor? (eq? 'ctor (method-record-rtype rec)))
|
||||
(priv? (private? modifiers))
|
||||
(method-string ((cond
|
||||
[ctor? build-constructor-name]
|
||||
[priv? mangle-private-method]
|
||||
[else mangle-method-name])
|
||||
(id-string id)
|
||||
(method-record-atypes rec)))
|
||||
(method-name (translate-id method-string (id-src id)))
|
||||
|
|
@ -1491,7 +1500,10 @@
|
|||
;make-static-method-names: (list method) type-recs -> (list string)
|
||||
(define (make-static-method-names methods type-recs)
|
||||
(map (lambda (m)
|
||||
(build-static-name (mangle-method-name (id-string (method-name m))
|
||||
(build-static-name
|
||||
((if (memq 'private (method-record-modifiers (method-rec m)))
|
||||
mangle-private-method mangle-method-name)
|
||||
(id-string (method-name m))
|
||||
(method-record-atypes (method-rec m)))))
|
||||
methods))
|
||||
|
||||
|
|
@ -1525,9 +1537,9 @@
|
|||
(void? (eq? (type-spec-name rtype) 'void))
|
||||
(native? (memq 'native modifiers))
|
||||
(static? (memq 'static modifiers))
|
||||
(native-method-name (build-identifier
|
||||
(string-append method-name #;(substring method-name 0 (- (string-length method-name) 2))
|
||||
"-native"))))
|
||||
(native-method-name
|
||||
(build-identifier
|
||||
(string-append (regexp-replace "private-" method-name "") "-native"))))
|
||||
|
||||
(static-method static?)
|
||||
(make-syntax #f
|
||||
|
|
@ -2548,8 +2560,11 @@
|
|||
(let* ((static? (and (not (method-contract? method-record))
|
||||
(memq 'static (method-record-modifiers method-record))))
|
||||
(temp (unless (method-contract? method-record)
|
||||
(if (memq 'private (method-record-modifiers method-record))
|
||||
(mangle-private-method (method-record-name method-record)
|
||||
(method-record-atypes method-record))
|
||||
(mangle-method-name (method-record-name method-record)
|
||||
(method-record-atypes method-record))))
|
||||
(method-record-atypes method-record)))))
|
||||
(m-name (cond
|
||||
((method-contract? method-record)
|
||||
(if (method-contract-prefix method-record)
|
||||
|
|
|
|||
|
|
@ -231,6 +231,24 @@
|
|||
(and (signature-equals? m1 m2)
|
||||
(type=? (method-record-rtype m1) (method-record-rtype m2))))
|
||||
|
||||
;;equal-greater-access? (list symbol) (list symbol) -> boolean
|
||||
(define (equal-greater-access? mods-l mods-r)
|
||||
(let ([eq-gt?
|
||||
(lambda (acc-l acc-r)
|
||||
(case acc-l
|
||||
[(public) (memq acc-r '(package protected public))]
|
||||
[(protected) (memq acc-r '(package protected))]
|
||||
[(package) (memq acc-r '(package))]
|
||||
[else #f]))])
|
||||
(eq-gt? (extract-access mods-l) (extract-access mods-r))))
|
||||
|
||||
(define (extract-access mods)
|
||||
(cond
|
||||
[(memq 'public mods) 'public]
|
||||
[(memq 'protected mods) 'protected]
|
||||
[(memq 'private mods) 'private]
|
||||
[else 'package]))
|
||||
|
||||
;; type-spec-to-type: type-spec (U #f (list string) symbol type-records -> type
|
||||
(define (type-spec-to-type ts container-class level type-recs)
|
||||
(let* ((ts-name (type-spec-name ts))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,17 @@
|
|||
|
||||
;;Execution tests without errors
|
||||
|
||||
(execute-test
|
||||
"interface mustbepublic {
|
||||
int a();
|
||||
int b();
|
||||
}
|
||||
class musthavepublic implements mustbepublic {
|
||||
public int a() { return 3; }
|
||||
public int b() { return 5; }
|
||||
}" 'advanced #f "public implementation of an interface"
|
||||
)
|
||||
|
||||
(execute-test
|
||||
"class OneC { }
|
||||
class TwoC extends OneC { }
|
||||
|
|
@ -125,6 +136,12 @@
|
|||
|
||||
;;Execution tests with errors
|
||||
|
||||
(execute-test
|
||||
"interface a { int a(); }
|
||||
class b implements a{ int a() { return 3; } }"
|
||||
'advanced #t "Interface implement without public"
|
||||
)
|
||||
|
||||
(execute-test
|
||||
"class X {
|
||||
final int x = 4;
|
||||
|
|
@ -305,6 +322,40 @@ class WeeklyPlanner{
|
|||
|
||||
;;Interaction tests, mix of right and error
|
||||
|
||||
(interact-test
|
||||
"interface topping { }
|
||||
interface cheese extends topping { }
|
||||
interface sausage extends topping { }
|
||||
interface parm extends cheese { }
|
||||
interface base { }
|
||||
interface red extends base { }
|
||||
interface bbq extends red { }
|
||||
interface marinara extends red { }
|
||||
|
||||
class Traditional implements parm, marinara { }
|
||||
class Traditional2 extends Traditional { }
|
||||
class Odd implements bbq, cheese, sausage { }
|
||||
|
||||
class OverloadTest {
|
||||
int meth( topping t, base b ) { return 1; }
|
||||
int meth( cheese t, base b) { return 2; }
|
||||
int meth( cheese t, marinara b) { return 3; }
|
||||
int meth( topping t, red b) { return 4; }
|
||||
int meth( Traditional2 t, red b) { return 5; }
|
||||
}" 'advanced
|
||||
'("OverloadTest t = new OverloadTest();"
|
||||
"t.meth(new Traditional(), new Odd()) //ambiguous"
|
||||
"t.meth(new Traditional(), new Traditional()) // 3"
|
||||
"t.meth(new Traditional2(), new Traditional()) //ambiguous"
|
||||
"t.meth(new Odd(), new Odd()) //ambiguous"
|
||||
"t.meth(new Odd(), (red) new Odd()) //ambiguous"
|
||||
"t.meth(new Odd(), (base) new Odd()) // 2"
|
||||
"t.meth((topping) new Odd(), (base) new Odd()) // 1"
|
||||
"t.meth(new Traditional2(), new Odd()) // 5"
|
||||
"t.meth((topping) new Odd(), new Traditional()) // 4")
|
||||
'((void) error 3 error error error 2 1 5 4)
|
||||
"Overloading resolution with interfaces and interface inheritance")
|
||||
|
||||
(interact-test
|
||||
'advanced
|
||||
'("int a = 'a';" "a" "int b;" "b = 'a';")
|
||||
|
|
@ -444,6 +495,12 @@ class WeeklyPlanner{
|
|||
(list '(void))
|
||||
"Test of array init")
|
||||
|
||||
(interact-test
|
||||
'advanced
|
||||
(list "null instanceof Object")
|
||||
(list #f)
|
||||
"Test of instanceof and null")
|
||||
|
||||
(report-test-results)
|
||||
|
||||
)
|
||||
|
|
@ -4,6 +4,31 @@
|
|||
|
||||
(prepare-for-tests "Full")
|
||||
|
||||
(interact-test
|
||||
"class allPublic {
|
||||
public int x() { return 3; }
|
||||
}
|
||||
class onePrivate {
|
||||
private int x() { return new allPublic().x(); }
|
||||
public int y() { return x(); }
|
||||
}
|
||||
"
|
||||
'full
|
||||
'("new onePrivate().y()") '(3) "Private method calling public method of same name")
|
||||
|
||||
(execute-test
|
||||
"class withPrivate {
|
||||
withPublic f;
|
||||
|
||||
private int with() { return this.f.with(); }
|
||||
}
|
||||
|
||||
class withPublic {
|
||||
withPrivate r = new withPrivate();
|
||||
|
||||
public int with() { return 3; }
|
||||
}" 'full #f "Potential conflict of names for private method")
|
||||
|
||||
(execute-test
|
||||
"class hasCharArray {
|
||||
char[] b = new char[]{'a'};
|
||||
|
|
@ -247,7 +272,7 @@
|
|||
|
||||
class Aia implements Gaa {
|
||||
Aia() { }
|
||||
int foo(int x) { return 3; }
|
||||
public int foo(int x) { return 3; }
|
||||
}" 'full #f "Extending an interface while overriding a method")
|
||||
|
||||
(execute-test
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user