From 581ee0783c820101da828ed18402ce9216612578 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Fri, 20 Jan 2006 04:12:33 +0000 Subject: [PATCH] Correction to bugs with accessing fields of wrapped java objects, and using == in the presence of dynamic. svn: r1880 --- .../profj/libs/java/io/Serializable.jinfo | 2 +- .../profj/libs/java/lang/Comparable.jinfo | 2 +- .../profj/libs/java/lang/Object-composite.ss | 56 ++++++++++++++-- collects/profj/libs/java/lang/Object.jinfo | 2 +- collects/profj/libs/java/lang/Object.ss | 2 +- collects/profj/libs/java/lang/String.jinfo | 2 +- collects/profj/libs/java/lang/Throwable.jinfo | 2 +- collects/profj/libs/java/runtime.scm | 21 +++++- collects/profj/to-scheme.ss | 67 +++++++++++++------ collects/profj/types.ss | 2 +- collects/tests/profj/full-tests.ss | 14 ++++ 11 files changed, 139 insertions(+), 33 deletions(-) diff --git a/collects/profj/libs/java/io/Serializable.jinfo b/collects/profj/libs/java/io/Serializable.jinfo index 1759d99e04..297de97a2e 100644 --- a/collects/profj/libs/java/io/Serializable.jinfo +++ b/collects/profj/libs/java/io/Serializable.jinfo @@ -7,4 +7,4 @@ () () () - "version3") + "version4") diff --git a/collects/profj/libs/java/lang/Comparable.jinfo b/collects/profj/libs/java/lang/Comparable.jinfo index 67ba69f7cd..4825db6e06 100644 --- a/collects/profj/libs/java/lang/Comparable.jinfo +++ b/collects/profj/libs/java/lang/Comparable.jinfo @@ -7,4 +7,4 @@ () () () - "version3") + "version4") diff --git a/collects/profj/libs/java/lang/Object-composite.ss b/collects/profj/libs/java/lang/Object-composite.ss index 950ad2c114..f9227b9cb3 100644 --- a/collects/profj/libs/java/lang/Object-composite.ss +++ b/collects/profj/libs/java/lang/Object-composite.ss @@ -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) diff --git a/collects/profj/libs/java/lang/Object.jinfo b/collects/profj/libs/java/lang/Object.jinfo index e26bb10a07..94db6f99f7 100644 --- a/collects/profj/libs/java/lang/Object.jinfo +++ b/collects/profj/libs/java/lang/Object.jinfo @@ -17,5 +17,5 @@ () (("Object" "java" "lang")) () - "version3") + "version4") diff --git a/collects/profj/libs/java/lang/Object.ss b/collects/profj/libs/java/lang/Object.ss index 41486fdb6e..392889d422 100644 --- a/collects/profj/libs/java/lang/Object.ss +++ b/collects/profj/libs/java/lang/Object.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/String.jinfo b/collects/profj/libs/java/lang/String.jinfo index cc4b969d56..f4f6ea597c 100644 --- a/collects/profj/libs/java/lang/String.jinfo +++ b/collects/profj/libs/java/lang/String.jinfo @@ -85,4 +85,4 @@ () (("Object" "java" "lang")) (("Serializable" "java" "io") ("Comparable" "java" "lang") ("CharSequence" "java" "lang")) - "version3") + "version4") diff --git a/collects/profj/libs/java/lang/Throwable.jinfo b/collects/profj/libs/java/lang/Throwable.jinfo index ea7c457da5..51c5e7f966 100644 --- a/collects/profj/libs/java/lang/Throwable.jinfo +++ b/collects/profj/libs/java/lang/Throwable.jinfo @@ -35,4 +35,4 @@ () (("Object" "java" "lang")) (("Serializable" "java" "io")) - "version3") + "version4") diff --git a/collects/profj/libs/java/runtime.scm b/collects/profj/libs/java/runtime.scm index baf45585dd..545098288a 100644 --- a/collects/profj/libs/java/runtime.scm +++ b/collects/profj/libs/java/runtime.scm @@ -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))))))) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index eb6ef913da..c5ae70348c 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -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 diff --git a/collects/profj/types.ss b/collects/profj/types.ss index c350c72e82..1b0ff28446 100644 --- a/collects/profj/types.ss +++ b/collects/profj/types.ss @@ -720,7 +720,7 @@ ; - (define type-version "version3") + (define type-version "version4") (define type-length 10) ;; read-record: path -> (U class-record #f) diff --git a/collects/tests/profj/full-tests.ss b/collects/tests/profj/full-tests.ss index 736735d6db..8cf4e57f00 100644 --- a/collects/tests/profj/full-tests.ss +++ b/collects/tests/profj/full-tests.ss @@ -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(); }}"