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

Correction to bug causing methods with the same name and different access to interfere with each other.

Browse Source 
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 2006-08-02 03:53:43 +00:00
parent 894fbdc63e
commit 325c304560
7 changed files with 198 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -557,9 +557,9 @@
(let*-values (((old-methods) (class-record-methods super-record)) (let*-values (((old-methods) (class-record-methods super-record))
((f m i) ((f m i)
(if (memq 'strictfp test-mods) (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)) (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))) ((ctor?) (has-ctor? m)))
(unless ctor? (unless ctor?
@ -766,7 +766,7 @@
(let-values (((f m i) (process-members members (apply append (let-values (((f m i) (process-members members (apply append
(map class-record-methods super-records)) (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-field-names? f members m level type-recs)
(valid-method-sigs? m members level type-recs) (valid-method-sigs? m members level type-recs)
@ -839,7 +839,7 @@
(let*-values (((old-methods) (class-record-methods super-record)) (let*-values (((old-methods) (class-record-methods super-record))
((f m i) ((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))) ((ctor?) (has-ctor? m)))
(if ctor? (if ctor?
@ -1108,6 +1108,7 @@
(method-record-atypes (car methods)))))) (method-record-atypes (car methods))))))
(method-member? method (cdr methods) level)))) (method-member? method (cdr methods) level))))
;identical-method-member? method-record (listof method-record) -> method-record
(define (identical-method-member? method methods) (define (identical-method-member? method methods)
(and (not (null? methods)) (and (not (null? methods))
(or (and (equal? (method-record-name method) (or (and (equal? (method-record-name method)
@ -1116,7 +1117,8 @@
(= (length (method-record-atypes method)) (= (length (method-record-atypes method))
(length (method-record-atypes (car methods)))) (length (method-record-atypes (car methods))))
(andmap type=? (method-record-atypes method) (andmap type=? (method-record-atypes method)
(method-record-atypes (car methods)))) (method-record-atypes (car methods)))
(car methods))
(identical-method-member? method (cdr methods))))) (identical-method-member? method (cdr methods)))))
;valid-inherited-methods?: (list class-record) (list name) symbol type-records -> bool ;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 ;implements-all? (list method-record) (list method) name symbol -> bool
(define (implements-all? inherit-methods methods name level) (define (implements-all? inherit-methods methods name level)
(or (null? inherit-methods) (or (null? inherit-methods)
(and (not (identical-method-member? (car inherit-methods) methods)) (let* ([current-method (car inherit-methods)]
(method-error 'not-implement [id-name (make-id (method-record-name current-method) #f)]
(make-id (method-record-name (car inherit-methods)) #f) [implementing-method (identical-method-member? current-method methods)])
(method-record-atypes (car inherit-methods)) (or (and (not implementing-method)
(method-record-rtype (car inherit-methods)) (method-error 'not-implement
(id-string (name-id name)) id-name
(id-src (name-id name)) (method-record-atypes current-method)
#f)) (method-record-rtype current-method)
(implements-all? (cdr inherit-methods) methods name level))) (id-string (name-id name))
(id-src (name-id name))
#f))
(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) (define (no-abstract-methods methods members level type-recs)
(or (null? methods) (or (null? methods)
@ -1319,9 +1333,9 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Methods to process fields and methods ;;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)) ;; (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) (let loop ((members members)
(fields null) (fields null)
(methods null) (methods null)
@ -1337,8 +1351,8 @@
(loop (cdr members) (loop (cdr members)
fields fields
(cons (if (null? args) (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 iface? 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? (car args)))
methods) methods)
inners)) inners))
((def? (car members)) ((def? (car members))
@ -1361,14 +1375,19 @@
(if (class-name) (cons (class-name) (cdr cname)) cname) (if (class-name) (cons (class-name) (cdr cname)) cname)
(field-type field))) (field-type field)))
;; process-method: method (list method-record) (list string) type-records symbol boolean -> method-record ;; 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 test? . args) (define (process-method method inherited-methods cname type-recs level iface? test? . args)
(let* ((name (id-string (method-name method))) (let* ((name (id-string (method-name method)))
(parms (map (lambda (p) (parms (map (lambda (p)
(set-field-type! p (type-spec-to-type (field-type-spec p) cname level type-recs)) (set-field-type! p (type-spec-to-type (field-type-spec p) cname level type-recs))
(field-type p)) (field-type p))
(method-parms method))) (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)) (ret (type-spec-to-type (method-type method) cname level type-recs))
(throws (filter (lambda (n) (throws (filter (lambda (n)
(not (or (is-eq-subclass? n runtime-exn-type type-recs)))) (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-full-name class r-name (type->ext-name ctor?))))
m-name src)))) 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 ;testcase-not-in-test: string string src -> void
(define (testcase-not-in-test name class src) (define (testcase-not-in-test name class src)
(raise-error (raise-error
@ -1892,10 +1923,10 @@
m-name (car class) (if (list? parent) (car parent) parent)) m-name (car class) (if (list? parent) (car parent) parent))
(format "Method ~a from ~a cannot be overridden in ~a" name parent (car class)))) (format "Method ~a from ~a cannot be overridden in ~a" name parent (car class))))
((static) ((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)) m-name (car class) parent))
((public) ((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)) m-name (car class) parent name))
((protected) ((protected)
(format (format

5
collects/profj/check.ss
View File

@ -1734,7 +1734,10 @@
(illegal-field-access 'private (string->symbol fname) level (car field-class) src))) (illegal-field-access 'private (string->symbol fname) level (car field-class) src)))
(when (and protected? (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) (is-subclass? c-class (make-ref-type (car field-class) (cdr field-class)) type-recs)
(package-members? c-class field-class type-recs)))) (package-members? c-class field-class type-recs))))
(illegal-field-access 'protected (string->symbol fname) level (car field-class) src)) (illegal-field-access 'protected (string->symbol fname) level (car field-class) src))

15
collects/profj/compile.ss
View File

@ -8,7 +8,7 @@
compilation-unit-code compilation-unit-contains set-compilation-unit-code! compilation-unit-code compilation-unit-contains set-compilation-unit-code!
read-record write-record read-record write-record
set-syntax-location create-type-record set-syntax-location create-type-record
) compile-to-ast)
(define (set-syntax-location so) (syntax-location so)) (define (set-syntax-location so) (syntax-location so))
@ -156,6 +156,19 @@
(order-cus (translate-program ast type-recs) (order-cus (translate-program ast type-recs)
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) ;compile-java-internal: port location type-records bool level-> (list compilation-unit)
(define (compile-java-internal port location type-recs file? level) (define (compile-java-internal port location type-recs file? level)
(packages null) (packages null)

35
collects/profj/to-scheme.ss
View File

@ -153,6 +153,10 @@
(else (error 'mangle-method-name (format "Internal Error: given unexptected type ~a" t)))))))) (else (error 'mangle-method-name (format "Internal Error: given unexptected type ~a" t))))))))
(format "~a~a" id (apply string-append (map parm-name types))))) (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 ;constructor? string -> bool
(define (constructor? name) (define (constructor? name)
(equal? name (class-name))) (equal? name (class-name)))
@ -1460,17 +1464,22 @@
(cons (cons
(build-identifier ((if (constructor? (id-string (method-name (car methods)))) (build-identifier ((if (constructor? (id-string (method-name (car methods))))
build-constructor-name build-constructor-name
mangle-method-name) mangle-private-method)
(id-string (method-name (car methods))) (id-string (method-name (car methods)))
(method-record-atypes (method-rec (car methods))))) (method-record-atypes (method-rec (car methods)))))
(make-method-names (cdr methods) minus-methods))))) (make-method-names (cdr methods) minus-methods)))))
;translate-method: type-spec (list symbol) id (list parm) statement bool ;translate-method: type-spec (list symbol) id (list parm) statement bool
; src bool int method-record type-records -> syntax ; src bool int method-record type-records -> syntax
(define (translate-method type modifiers id parms block all-tail? src inner? depth rec type-recs) (define (translate-method type modifiers id parms block all-tail? src inner? depth rec type-recs)
(let* ((final (final? modifiers)) (let* ((final (final? modifiers))
(ctor? (eq? 'ctor (method-record-rtype rec)));(constructor? (id-string id))) (ctor? (eq? 'ctor (method-record-rtype rec)))
(method-string ((if ctor? build-constructor-name mangle-method-name) (priv? (private? modifiers))
(method-string ((cond
[ctor? build-constructor-name]
[priv? mangle-private-method]
[else mangle-method-name])
(id-string id) (id-string id)
(method-record-atypes rec))) (method-record-atypes rec)))
(method-name (translate-id method-string (id-src id))) (method-name (translate-id method-string (id-src id)))
@ -1491,8 +1500,11 @@
;make-static-method-names: (list method) type-recs -> (list string) ;make-static-method-names: (list method) type-recs -> (list string)
(define (make-static-method-names methods type-recs) (define (make-static-method-names methods type-recs)
(map (lambda (m) (map (lambda (m)
(build-static-name (mangle-method-name (id-string (method-name m)) (build-static-name
(method-record-atypes (method-rec m))))) ((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)) methods))
;create-static-methods: (list string) (list method) type-records -> (list syntax) ;create-static-methods: (list string) (list method) type-records -> (list syntax)
@ -1525,9 +1537,9 @@
(void? (eq? (type-spec-name rtype) 'void)) (void? (eq? (type-spec-name rtype) 'void))
(native? (memq 'native modifiers)) (native? (memq 'native modifiers))
(static? (memq 'static modifiers)) (static? (memq 'static modifiers))
(native-method-name (build-identifier (native-method-name
(string-append method-name #;(substring method-name 0 (- (string-length method-name) 2)) (build-identifier
"-native")))) (string-append (regexp-replace "private-" method-name "") "-native"))))
(static-method static?) (static-method static?)
(make-syntax #f (make-syntax #f
@ -2548,8 +2560,11 @@
(let* ((static? (and (not (method-contract? method-record)) (let* ((static? (and (not (method-contract? method-record))
(memq 'static (method-record-modifiers method-record)))) (memq 'static (method-record-modifiers method-record))))
(temp (unless (method-contract? method-record) (temp (unless (method-contract? method-record)
(mangle-method-name (method-record-name method-record) (if (memq 'private (method-record-modifiers method-record))
(method-record-atypes 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)))))
(m-name (cond (m-name (cond
((method-contract? method-record) ((method-contract? method-record)
(if (method-contract-prefix method-record) (if (method-contract-prefix method-record)

18
collects/profj/types.ss
View File

@ -231,6 +231,24 @@
(and (signature-equals? m1 m2) (and (signature-equals? m1 m2)
(type=? (method-record-rtype m1) (method-record-rtype 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 ;; 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) (define (type-spec-to-type ts container-class level type-recs)
(let* ((ts-name (type-spec-name ts)) (let* ((ts-name (type-spec-name ts))

57
collects/tests/profj/advanced-tests.ss
View File

@ -6,6 +6,17 @@
;;Execution tests without errors ;;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 (execute-test
"class OneC { } "class OneC { }
class TwoC extends OneC { } class TwoC extends OneC { }
@ -125,6 +136,12 @@
;;Execution tests with errors ;;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 (execute-test
"class X { "class X {
final int x = 4; final int x = 4;
@ -305,6 +322,40 @@ class WeeklyPlanner{
;;Interaction tests, mix of right and error ;;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 (interact-test
'advanced 'advanced
'("int a = 'a';" "a" "int b;" "b = 'a';") '("int a = 'a';" "a" "int b;" "b = 'a';")
@ -444,6 +495,12 @@ class WeeklyPlanner{
(list '(void)) (list '(void))
"Test of array init") "Test of array init")
(interact-test
'advanced
(list "null instanceof Object")
(list #f)
"Test of instanceof and null")
(report-test-results) (report-test-results)
) )

27
collects/tests/profj/full-tests.ss
View File

@ -4,6 +4,31 @@
(prepare-for-tests "Full") (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 (execute-test
"class hasCharArray { "class hasCharArray {
char[] b = new char[]{'a'}; char[] b = new char[]{'a'};
@ -247,7 +272,7 @@
class Aia implements Gaa { class Aia implements Gaa {
Aia() { } Aia() { }
int foo(int x) { return 3; } public int foo(int x) { return 3; }
}" 'full #f "Extending an interface while overriding a method") }" 'full #f "Extending an interface while overriding a method")
(execute-test (execute-test