Correction to int/float-double conversions, and Image printing

svn: r1936

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))

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

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?))
+         (cond
-                 (dynamic-val? (field-type init?)))
+           ((or (eq? 'dynamic (field-type init?))
-             (make-syntax #f (guard-convert-value body-syntax actual-type) body-syntax)
+                (dynamic-val? (field-type init?)))
-             body-syntax)))
+            (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))
+    (let ((expr (cond
-                    (guard-convert-value expr expr-type)
+                  ((and expr-type (eq? 'dynamic exp-type))
-                    expr)))
+                   (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))
+                          (cond
-                              (guard-convert-value (make-syntax #f expanded-expr (build-src src)) (expr-types assign-to))
+                            ((or (eq? type 'dynamic) (dynamic-val? type))
-                              expanded-expr)))))
+                             (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))

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

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)

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))
    

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))