From e9ab189fcb0f1d999d4787a03b51b96309ea67de Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Tue, 24 Jan 2006 06:46:47 +0000 Subject: [PATCH] Correction to int/float-double conversions, and Image printing svn: r1936 --- collects/profj/check.ss | 2 +- collects/profj/libs/java/runtime.scm | 2 ++ collects/profj/to-scheme.ss | 41 +++++++++++++++------- collects/profj/tool.ss | 4 ++- collects/profj/types.ss | 1 + collects/tests/profj/beginner-tests.ss | 7 ++++ collects/tests/profj/intermediate-tests.ss | 6 +++- 7 files changed, 48 insertions(+), 15 deletions(-) diff --git a/collects/profj/check.ss b/collects/profj/check.ss index 4671687984..28f6c555ed 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -2508,7 +2508,7 @@ (unless (or (and (prim-numeric-type? exp-type) (prim-numeric-type? type) (or (widening-prim-conversion exp-type type) - (widening-prim-conversion type exp-type))) + (widening-prim-conversion type exp-type))) (and (eq? 'boolean type) (eq? 'boolean exp-type))) (cast-error 'incompatible-prim exp-type type src)) diff --git a/collects/profj/libs/java/runtime.scm b/collects/profj/libs/java/runtime.scm index 545098288a..ff4fea2232 100644 --- a/collects/profj/libs/java/runtime.scm +++ b/collects/profj/libs/java/runtime.scm @@ -151,6 +151,8 @@ (send (convert-to-string val) get-mzscheme-string)))))) ((float double) (cond + ((and (number? val) (inexact? val)) val) + ((and (number? val) (exact? val)) (exact->inexact val)) ((number? val) val) ((char? val) (char->integer val)) (else (raise-class-cast (format "Cast to ~a failed for ~a" type diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index 860e73940c..0db5a2d20f 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -84,6 +84,7 @@ (if (> (type-spec-dim type) 0) (make-syntax #f 'null #f) (cond + ((memq name '(float double)) (make-syntax #f 0.0 #f)) ((prim-numeric-type? name) (make-syntax #f 0 #f)) ((eq? 'char name) (make-syntax #f '#\space #f)) ((eq? 'boolean name) (make-syntax #f '#f #f)) @@ -1502,10 +1503,14 @@ (initialize-array (array-init-vals (var-init-init init?)) type) (translate-expression (var-init-init init?))))) - (if (or (eq? 'dynamic (field-type init?)) - (dynamic-val? (field-type init?))) - (make-syntax #f (guard-convert-value body-syntax actual-type) body-syntax) - body-syntax))) + (cond + ((or (eq? 'dynamic (field-type init?)) + (dynamic-val? (field-type init?))) + (make-syntax #f (guard-convert-value body-syntax actual-type) body-syntax)) + ((and (memq (field-type init?) '(float double)) + (memq actual-type '(long int byte short))) + (make-syntax #f `(exact->inexact ,body-syntax) body-syntax)) + (else body-syntax)))) (else (get-default-value type)))) ;translate-initialize: bool block src string type-records -> syntax @@ -1615,9 +1620,14 @@ ;Presently a no-op in the interactions window, although this is incorrect for advanced and full ;translate-return: syntax type type bool src -> syntax (define (translate-return expr expr-type exp-type in-tail? src) - (let ((expr (if (and expr-type (eq? 'dynamic exp-type)) - (guard-convert-value expr expr-type) - expr))) + (let ((expr (cond + ((and expr-type (eq? 'dynamic exp-type)) + (guard-convert-value expr expr-type)) + ((and expr-type + (memq exp-type '(float double)) + (memq expr-type '(long int short byte))) + (make-syntax #f `(exact->inexact ,expr) expr)) + (else expr)))) (if (or (interactions?) in-tail?) (make-syntax #f expr #f) (make-syntax #f `(return-k ,expr) (build-src src))))) @@ -2049,7 +2059,10 @@ temp-obj)))) (create-syntax #f (case type - ((char int long float double boolean) value) + ((float double) (if (inexact? value) + value + (exact->inexact value))) + ((char int long boolean) value) ((String string) make-string) ((image) (make-image)) ((null) 'null) @@ -2618,11 +2631,15 @@ ((>>=) `(javaRuntime:shift '>> ,name ,expr)) ((<<=) `(javaRuntime:shift '<< ,name ,expr)) ((>>>=) `(javaRuntime:shift '>>> ,name ,expr)) - ((%= &= ^= or=) + ((%= &= ^= or=) (error 'translate-assignment "Only supports =, +=, -=, *=, & /= >>= <<= >>>= at this time"))))) - (if (or (eq? type 'dynamic) (dynamic-val? type)) - (guard-convert-value (make-syntax #f expanded-expr (build-src src)) (expr-types assign-to)) - expanded-expr))))) + (cond + ((or (eq? type 'dynamic) (dynamic-val? type)) + (guard-convert-value (make-syntax #f expanded-expr (build-src src)) (expr-types assign-to))) + ((and (memq type '(float double)) + (memq (expr-types assign-to) '(long int short byte))) + `(exact->inexact ,expanded-expr)) + (else expanded-expr)))))) (cond ((array-access? name) (translate-array-mutation name expression assign-to src)) diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index e7ce4e8046..4211809c6a 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -885,7 +885,9 @@ ((string? value) (list (format "~v" value))) ((or (is-a? value ObjectI) (supports-printable-interface? value)) (cond - ((equal? "Image" (send value my-name)) + ((and (equal? "Image" (send value my-name)) + (object-method-arity-includes? value 'Image-constructor-dynamic 1) + (object-method-arity-includes? value 'movePinhole-draw2.Posn 1)) ;(printf "~a~n" ((send value fields-for-display))) (list (cadr ((send value fields-for-display))))) (else diff --git a/collects/profj/types.ss b/collects/profj/types.ss index 1b0ff28446..491a235c2d 100644 --- a/collects/profj/types.ss +++ b/collects/profj/types.ss @@ -115,6 +115,7 @@ ;; widening-prim-conversion: symbol-type symbol-type -> boolean (define (widening-prim-conversion to from) (cond + ((symbol=? to from) #t) ((symbol=? 'short to) (symbol=? 'byte from)) ((symbol=? 'int to) diff --git a/collects/tests/profj/beginner-tests.ss b/collects/tests/profj/beginner-tests.ss index 71660357e9..ef761cf24b 100644 --- a/collects/tests/profj/beginner-tests.ss +++ b/collects/tests/profj/beginner-tests.ss @@ -451,5 +451,12 @@ (list 'error) "Trying to create an instance of an interface") + (interact-test + "class X { X() { } double f() { return 2; } }" + language + (list "double x = 1;" "x" "new X().f()") + (list '(void) 1.0 2.0) + "Converting ints into doubles appropriately") + (report-test-results)) \ No newline at end of file diff --git a/collects/tests/profj/intermediate-tests.ss b/collects/tests/profj/intermediate-tests.ss index aa779212d2..7e04feb38b 100644 --- a/collects/tests/profj/intermediate-tests.ss +++ b/collects/tests/profj/intermediate-tests.ss @@ -440,6 +440,10 @@ (list 5) "Calling a super method") - + (interact-test + 'intermediate + '("(double) 1" "(double) 1.0" "double x;" "x" "x = 1;" "(int) x") + '(1.0 1.0 (void) 0.0 1.0 1) + "Double-int conversions") (report-test-results)) \ No newline at end of file