Correction to bugs with accessing fields of wrapped java objects, and using == in the presence of dynamic.
svn: r1880
This commit is contained in:
Kathy Gray
parent
19435656d0
commit
581ee0783c
|
|
@ -7,4 +7,4 @@
|
|||
()
|
||||
()
|
||||
()
|
||||
"version3")
|
||||
"version4")
|
||||
|
|
|
|||
|
|
@ -7,4 +7,4 @@
|
|||
()
|
||||
()
|
||||
()
|
||||
"version3")
|
||||
"version4")
|
||||
|
|
|
|||
|
|
@ -54,7 +54,10 @@
|
|||
;Needs to do something
|
||||
(define/public clone (lambda () void))
|
||||
|
||||
(define/public (equals-java.lang.Object obj) (eq? this obj))
|
||||
(define/public (equals-java.lang.Object obj)
|
||||
(or (eq? this obj)
|
||||
(and (is-a? obj wrapper)
|
||||
(send obj compare this obj))))
|
||||
(define/public (equals obj) (send this equals-java.lang.Object obj))
|
||||
|
||||
;Needs to do something
|
||||
|
|
@ -119,9 +122,13 @@
|
|||
(wait-long (c:-> c:any/c c:any/c))
|
||||
(wait-long-int (c:-> c:any/c c:any/c c:any/c))) obj p n s)
|
||||
(make-object convert-assert-Object obj p n s c))))
|
||||
|
||||
(define-local-member-name get-wrapped)
|
||||
(define wrapper (interface () get-wrapped))
|
||||
(provide wrapper)
|
||||
|
||||
(define convert-assert-Object
|
||||
(class object%
|
||||
(class* object% (wrapper)
|
||||
|
||||
(init w p n s c)
|
||||
(define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null))
|
||||
|
|
@ -130,6 +137,26 @@
|
|||
(set! neg-blame n)
|
||||
(set! src s)
|
||||
(set! cc-marks c)
|
||||
|
||||
(define/public (get-wrapped) wrapped)
|
||||
(define/public (compare obj1 obj2)
|
||||
(cond
|
||||
((and (is-a? obj1 wrapper) (is-a? obj2 wrapper))
|
||||
(compare (send obj1 get-wrapped) (send obj2 get-wrapped)))
|
||||
((is-a? obj1 wrapper)
|
||||
(compare (send obj1 get-wrapped) obj2))
|
||||
((is-a? obj2 wrapper)
|
||||
(compare obj1 (send obj2 get-wrapped)))
|
||||
(else (eq? obj1 obj2))))
|
||||
|
||||
(define/public (down-cast class wrapped-class)
|
||||
(and (check-instance class)
|
||||
(make-object wrapped-class wrapped pos-blame neg-blame src cc-marks)))
|
||||
|
||||
(define/public (check-instance class)
|
||||
(if (is-a? wrapped wrapper)
|
||||
(send wrapped check-instance class)
|
||||
(is-a? wrapped class)))
|
||||
|
||||
(define/public (clone) (send wrapped clone))
|
||||
(define/public (equals-java.lang.Object obj)
|
||||
|
|
@ -172,9 +199,9 @@
|
|||
|
||||
(define dynamic-Object/c
|
||||
(c:flat-named-contract "Object" (lambda (v) (is-a? v convert-assert-Object))))
|
||||
|
||||
|
||||
(define guard-convert-Object
|
||||
(class object%
|
||||
(class* object% (wrapper)
|
||||
|
||||
(init w p n s c)
|
||||
(define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null))
|
||||
|
|
@ -184,6 +211,27 @@
|
|||
(set! src s)
|
||||
(set! cc-marks s)
|
||||
|
||||
(define/public (get-wrapped) wrapped)
|
||||
|
||||
(define/public (compare obj1 obj2)
|
||||
(cond
|
||||
((and (is-a? obj1 wrapper) (is-a? obj2 wrapper))
|
||||
(compare (send obj1 get-wrapped) (send obj2 get-wrapped)))
|
||||
((is-a? obj1 wrapper)
|
||||
(compare (send obj1 get-wrapped) obj2))
|
||||
((is-a? obj2 wrapper)
|
||||
(compare obj1 (send obj2 get-wrapped)))
|
||||
(else (eq? obj1 obj2))))
|
||||
|
||||
(define/public (down-cast class wrapped-class)
|
||||
(and (check-instance class)
|
||||
(make-object wrapped-class wrapped pos-blame neg-blame src cc-marks)))
|
||||
|
||||
(define/public (check-instance class)
|
||||
(if (is-a? wrapped wrapper)
|
||||
(send wrapped check-instance class)
|
||||
(is-a? wrapped class)))
|
||||
|
||||
(define/public (clone) (send wrapped clone))
|
||||
(define/public (equals-java.lang.Object . obj)
|
||||
(unless (= (length obj) 1)
|
||||
|
|
|
|||
|
|
@ -17,5 +17,5 @@
|
|||
()
|
||||
(("Object" "java" "lang"))
|
||||
()
|
||||
"version3")
|
||||
"version4")
|
||||
|
||||
|
|
|
|||
|
|
@ -3,4 +3,4 @@
|
|||
(require "Object-composite.ss")
|
||||
(provide ObjectI Object-Mix Object)
|
||||
(provide guard-convert-Object convert-assert-Object wrap-convert-assert-Object
|
||||
dynamic-Object/c static-Object/c))
|
||||
dynamic-Object/c static-Object/c wrapper))
|
||||
|
|
|
|||
|
|
@ -85,4 +85,4 @@
|
|||
()
|
||||
(("Object" "java" "lang"))
|
||||
(("Serializable" "java" "io") ("Comparable" "java" "lang") ("CharSequence" "java" "lang"))
|
||||
"version3")
|
||||
"version4")
|
||||
|
|
|
|||
|
|
@ -35,4 +35,4 @@
|
|||
()
|
||||
(("Object" "java" "lang"))
|
||||
(("Serializable" "java" "io"))
|
||||
"version3")
|
||||
"version4")
|
||||
|
|
|
|||
|
|
@ -15,7 +15,20 @@
|
|||
(lib "NullPointerException.ss" "profj" "libs" "java" "lang"))
|
||||
|
||||
(provide convert-to-string shift not-equal bitwise mod divide-dynamic divide-int
|
||||
divide-float and or cast-primitive cast-reference instanceof-array nullError)
|
||||
divide-float and or cast-primitive cast-reference instanceof-array nullError
|
||||
check-eq? dynamic-equal?)
|
||||
|
||||
(define (check-eq? obj1 obj2)
|
||||
(or (eq? obj1 obj2)
|
||||
(cond
|
||||
((is-a? obj1 wrapper) (send obj1 compare obj1 obj2))
|
||||
((is-a? obj2 wrapper) (send obj2 compare obj1 obj2))
|
||||
(else #f))))
|
||||
|
||||
(define (dynamic-equal? val1 val2)
|
||||
(cond
|
||||
((number? val1) (= val1 val2))
|
||||
(else (check-eq? val1 val2))))
|
||||
|
||||
;convert-to-string: (U string int real bool char Object) -> string
|
||||
(define (convert-to-string data)
|
||||
|
|
@ -153,7 +166,13 @@
|
|||
(cond
|
||||
((and (eq? Object type) (is-a? val ObjectI)) val)
|
||||
((and (is-a? val convert-assert-Object) (is-a? val ca-type)) val)
|
||||
((is-a? val convert-assert-Object)
|
||||
(or (send val down-cast type ca-type)
|
||||
(raise-class-cast (format "Cast to ~a failed for ~a" name (send val my-name)))))
|
||||
((and (is-a? val guard-convert-Object) (is-a? val gc-type)) val)
|
||||
((is-a? val guard-convert-Object)
|
||||
(or (send val down-cast type gc-type)
|
||||
(raise-class-cast (format "Cast to ~a failed for ~a" name (send val my-name)))))
|
||||
((is-a? val type) val)
|
||||
(else (raise-class-cast (format "Cast to ~a failed for ~a" name (send val my-name)))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -757,7 +757,7 @@
|
|||
(set! cc-marks c*)
|
||||
(super-instantiate (w* p* n* s* c*))
|
||||
|
||||
,(generate-wrapper-fields fields from-dynamic?)
|
||||
,@(generate-wrapper-fields fields from-dynamic?)
|
||||
|
||||
,@(generate-wrapper-methods
|
||||
(filter (lambda (m) (not (eq? (method-record-rtype m) 'ctor)))
|
||||
|
|
@ -784,16 +784,41 @@
|
|||
|
||||
;generate-wrapper-fields: (list field) boolean -> sexp
|
||||
(define (generate-wrapper-fields fields from-dynamic?)
|
||||
`(field ,@(map (lambda (field)
|
||||
(let* ((field-name (id-string (field-name field)))
|
||||
(value `(,(create-get-name field-name) wrapped-obj)))
|
||||
`(,(build-identifier (build-var-name field-name))
|
||||
,(convert-value
|
||||
(if from-dynamic? (assert-value value (field-type field) #t 'field field-name) value)
|
||||
(field-type field)
|
||||
from-dynamic?))))
|
||||
fields)))
|
||||
|
||||
(apply append
|
||||
(map (lambda (field)
|
||||
(let* ((name (id-string (field-name field)))
|
||||
(dynamic-access-body
|
||||
(lambda (guard-body scheme-body)
|
||||
`(if (is-a? wrapped-obj guard-convert-Object)
|
||||
,guard-body
|
||||
,scheme-body)))
|
||||
(get-name (create-get-name name))
|
||||
(set-name (create-set-name name))
|
||||
(get-call `(,get-name wrapped-obj))
|
||||
(set-call `(lambda (new-val) (,set-name wrapped-obj new-val))))
|
||||
|
||||
(list
|
||||
`(define/public (,(build-identifier (format "~a-wrapped" get-name)))
|
||||
,(convert-value
|
||||
(if from-dynamic?
|
||||
(assert-value
|
||||
(dynamic-access-body get-call `(get-field wrapped-obj (quote ,(build-identifier name))))
|
||||
(field-type field) #t 'field name)
|
||||
get-call) (field-type field) from-dynamic?))
|
||||
(if (memq 'final (field-modifiers field))
|
||||
null
|
||||
`(define/public (,(build-identifier (format "~a-wrapped" set-name)) new-val)
|
||||
(,(if from-dynamic?
|
||||
(dynamic-access-body set-call
|
||||
`(lambda (new-val)
|
||||
(define set-field null)
|
||||
(set-field wrapped-obj (quote ,(build-identifier name)) new-val)))
|
||||
set-call)
|
||||
,(convert-value (if (not from-dynamic?)
|
||||
(assert-value 'new-val (field-type field) #t 'field name)
|
||||
'new-val) (field-type field) from-dynamic?)))))))
|
||||
fields)))
|
||||
|
||||
;generate-wrapper-methods: (list method-record) boolean boolean -> (list sexp)
|
||||
;When is dynamic-callable?, will define methods callable from a dynamic context
|
||||
(define (generate-wrapper-methods methods dynamic-callable? from-dynamic?)
|
||||
|
|
@ -1384,30 +1409,30 @@
|
|||
null
|
||||
(let* ((field (car fields))
|
||||
(class (build-identifier (class-name)))
|
||||
(ca-class (build-identifier (string-append "convert-assert-" (class-name))))
|
||||
(quote-name (build-identifier (build-var-name (id-string (field-name field)))))
|
||||
(field-name (id-string (field-name field)))
|
||||
(quote-name (build-identifier (build-var-name field-name)))
|
||||
(getter (car names))
|
||||
(setter (cadr names))
|
||||
(final (final? (map modifier-kind (field-modifiers field)))))
|
||||
(append (cons (make-syntax #f
|
||||
`(define ,getter
|
||||
(let ((normal-get (class-field-accessor ,class ,quote-name))
|
||||
(dyn-get (class-field-accessor ,ca-class ,quote-name)))
|
||||
(let ((normal-get (class-field-accessor ,class ,quote-name)))
|
||||
(lambda (obj)
|
||||
(cond
|
||||
((is-a? obj ,class) (normal-get obj))
|
||||
((is-a? obj ,ca-class) (dyn-get obj))))))
|
||||
(else
|
||||
(send obj
|
||||
,(build-identifier (format "~a-wrapped" getter))))))))
|
||||
#f)
|
||||
(if (not final)
|
||||
(list
|
||||
(make-syntax #f
|
||||
`(define ,setter
|
||||
(let ((normal-set (class-field-mutator ,class ,quote-name))
|
||||
(dyn-set (class-field-mutator ,ca-class ,quote-name)))
|
||||
(let ((normal-set (class-field-mutator ,class ,quote-name)))
|
||||
(lambda (obj val)
|
||||
(if (is-a? obj ,class)
|
||||
(normal-set obj val)
|
||||
(dyn-set obj val)))))
|
||||
(send obj ,(build-identifier (format "~a-wrapped" setter)) val)))))
|
||||
#f))
|
||||
null))
|
||||
(create-field-accessors (if final (cdr names) (cddr names)) (cdr fields))))))
|
||||
|
|
@ -2112,11 +2137,11 @@
|
|||
(make-syntax #f
|
||||
(cond
|
||||
((or (dynamic-val? left-type) (dynamic-val? right-type))
|
||||
`(,(create-syntax #f 'eq? key-src) ,left ,right))
|
||||
`(,(create-syntax #f 'javaRuntime:dynamic-equal key-src) ,left ,right))
|
||||
((and (prim-numeric-type? left-type) (prim-numeric-type? right-type))
|
||||
`(,(create-syntax #f '= key-src) ,left ,right))
|
||||
(else
|
||||
`(,(create-syntax #f 'eq? key-src) ,left ,right))) source))
|
||||
`(,(create-syntax #f 'javaRuntime:check-eq? key-src) ,left ,right))) source))
|
||||
((!=)
|
||||
(make-syntax #f `(,(create-syntax #f 'javaRuntime:not-equal key-src) ,left ,right) source))
|
||||
;logicals
|
||||
|
|
|
|||
|
|
@ -720,7 +720,7 @@
|
|||
;
|
||||
|
||||
|
||||
(define type-version "version3")
|
||||
(define type-version "version4")
|
||||
(define type-length 10)
|
||||
|
||||
;; read-record: path -> (U class-record #f)
|
||||
|
|
|
|||
|
|
@ -4,6 +4,20 @@
|
|||
|
||||
(prepare-for-tests "Full")
|
||||
|
||||
(parameterize ((dynamic? #t))
|
||||
"class X { }"
|
||||
'full
|
||||
'("X x = new X();" "X y = (dynamic) x;" "x.equals(y)" "y.equals(x)" "y==x" "x==y")
|
||||
'((void) (void) #t #t #t #t)
|
||||
"Equality test of a wrapped and unwrapped object")
|
||||
|
||||
(parameterize ((dynamic? #t))
|
||||
"class X { int y; X(int y) { this.y = y; } }"
|
||||
'full
|
||||
'("X x = new X(3);" "X y = (dynamic) x;" "x.y = 4" "y.y" "y.y=5" "x.y")
|
||||
'((void) (void) 4 4 5 5)
|
||||
"Accessing fields of a dynamic value")
|
||||
|
||||
(execute-test
|
||||
"package a; class a { int x;
|
||||
Object get() { class b { int y() { return a.this.x; } } return new b(); }}"
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user