Assorted bug fixes, mostly with dynamic

svn: r1421

collects/profj/check.ss

@@ -1692,8 +1692,9 @@
                 (unless (eq? level 'full)
                   (when (is-field-restricted? fname field-class)
                     (restricted-field-access-err (field-access-field acc) field-class src)))
-                (make-type/env (field-record-type record) 
+                (make-type/env 
-                               (if (type/env? obj-type/env) (type/env-e obj-type/env) env))))
+                 (if (eq? 'dynamic (field-record-type record)) (make-dynamic-val #f) (field-record-type record))
+                 (if (type/env? obj-type/env) (type/env-e obj-type/env) env))))
              ((and (dynamic-val? record) (dynamic-val-type record))
               (set-field-access-access! acc (make-var-access #f #t #t 'public 'unknown))
               (make-type/env (field-contract-type (unknown-ref-access (dynamic-val-type record)))
@@ -2026,11 +2027,11 @@
                                             type-recs)))
                       (else (prim-call-error call-exp name src level)))))
                  (else 
-                  (if (eq? level 'beginner)
+                  (if (and (eq? level 'beginner) (not interact?))
                       (beginner-method-access-error name (id-src name))
                       (let ((rec (if static? (send type-recs get-class-record c-class) this)))
                         (cond 
-                          ((and (null? rec) (dynamic?) (lookup-var-in-env name-string env)) =>
+                          ((and (dynamic?) (lookup-var-in-env name-string env)) =>
                            (lambda (var-type)
                              (if (eq? 'dynamic (var-type-type var-type))
                                  (list (make-method-contract (string-append name-string "~f") #f #f #f))
@@ -2057,7 +2058,10 @@
            (cond
              ((close-to-keyword? name-string)
               (close-to-keyword-error 'method name src))
-             (interact? (interaction-call-error name src level))
+             (interact? 
+              (if (or class? field?)
+                  (no-method-error 'interact sub-kind exp-type name src)
+                  (interaction-call-error name src level)))
              (else
               (no-method-error 'this sub-kind exp-type name src)))))))
       
@@ -2789,11 +2793,11 @@
           (let ((line1 
                  (format "Class ~a is inappropriately being used as a method." n))
                 (line2
-                 "Parenthesis typically follow the class name when creating an instance, perhaps 'new' was forgotten"))
+                 "Parenthesis typically follow the class name when creating an instance, perhaps 'new' was forgotten."))
           (format "~a~n~a" line1 line2)))
          ((field-name)
           (format 
-           "Field ~a is being inappropriately used as a method, parentheses are not used in interacting with a field"
+           "Field ~a is being inappropriately used as a method, parentheses are not used in interacting with a field."
            n)))                     
        n src)))
   
@@ -2804,12 +2808,12 @@
                    (case kind
                      ((method) 
                       (string-append
-                       (format "this method call uses an unfound method ~a, which is similar to a reserved word~n"
+                       (format "This method call uses an unfound method ~a, which is similar to a reserved word~n"
                                n)
                        "Perhaps it is miscapitalized or misspelled"))
                      ((field)
                        (string-append
-                        (format "this unknown variable, ~a, is similar to a reserved word.~n" n)
+                        (format "This unknown variable, ~a, is similar to a reserved word.~n" n)
                         "Perhaps it is miscaptialzed or misspelled")))
                    n src)))
 
@@ -2827,7 +2831,7 @@
   (define (beginner-method-access-error name src)
     (let ((n (id->ext-name name)))
       (raise-error n
-                   (format "method ~a from the current class must be called on 'this'" n)
+                   (format "Method ~a from the current class must be called on 'this'" n)
                    n src)))
 
   
@@ -2835,7 +2839,7 @@
   (define (restricted-method-call name class src)
     (let ((n (id->ext-name name)))
       (raise-error n
-                   (format "method ~a from ~a may not be called" n (car class))
+                   (format "Method ~a from ~a may not be called." n (car class))
                    n src)))
   
   ;ctor-called-error: type id src -> void
@@ -2843,7 +2847,7 @@
     (let ((t (if exp (type->ext-name exp) "the current class"))
           (n (id->ext-name name)))
       (raise-error n
-                   (format "Constructor ~a from ~a cannot be used as a method" n t)
+                   (format "Constructor ~a from ~a cannot be used as a method." n t)
                    n src)))
   
   ;non-static-called-error: id (list string) src bool -> void
@@ -2851,24 +2855,24 @@
     (let ((n (id->ext-name name)))
       (raise-error n
                    (if (memq level '(advanced full))
-                       (format "Non-static method ~a from ~a cannot be called directly from a static context"
+                       (format "Non-static method ~a from ~a cannot be called directly from a static context."
                                n (car class))
-                       (format "Method ~a from ~a cannot be called here" n (car class)))
+                       (format "Method ~a from ~a cannot be called here." n (car class)))
                    n src)))
   
   ;interaction-call-error
   (define (interaction-call-error name src level)
     (let ((n (id->ext-name name)))
       (raise-error n
-                   (string-append (format "method ~a cannot be called in the interactions window.~n" n)
+                   (string-append (format "Method ~a cannot be called in the interactions window.~n" n)
-                                  (format "Only ~a methods or methods on objects may be called here" 
+                                  (format "Only ~a methods or methods on objects may be called here." 
                                           (if (memq level '(beginner intermediate)) "certain library" "static")))
                    n src)))
 
   
   (define (illegal-ctor-call name src level)
     (let ((n (string->symbol name)))
-      (raise-error n (format "calls to ~a may only occur in ~a"
+      (raise-error n (format "Calls to ~a may only occur in ~a"
                              n
                              (if (memq level `(full advanced)) "other constructors" "the super constructor"))
                    n src)))

collects/profj/error-messaging.ss

@@ -1,4 +1,3 @@
-#cs
 (module error-messaging mzscheme
   
   (require "ast.ss")
@@ -11,7 +10,7 @@
   ;make-error: 'a string 'a src -> void
   (define (make-error-pass parm)
     (lambda (kind message so src)
-      (raise-syntax-error kind message (make-so so src parm))))
+      (raise-syntax-error 'Error #;kind message (make-so so src parm))))
   
   ;make-so: symbol src (-> location) -> syntax-object
   (define (make-so id src parm)

collects/profj/libs/java/runtime.scm

@@ -4,7 +4,6 @@
 
 ;This module provides functions needed at runtime for compiled Java code
 
-#cs
 (module runtime mzscheme
   
   (require (lib "class.ss")
@@ -15,7 +14,7 @@
            (lib "ClassCastException.ss" "profj" "libs" "java" "lang")
            (lib "NullPointerException.ss" "profj" "libs" "java" "lang"))
   
-  (provide convert-to-string shift not-equal bitwise mod divide-int 
+  (provide convert-to-string shift not-equal bitwise mod divide-dynamic divide-int 
            divide-float and or cast-primitive cast-reference instanceof-array nullError)
   
   ;convert-to-string: (U string int real bool char Object) -> string
@@ -58,6 +57,12 @@
                     (or left right)))
           ((or) (or left right)))))
 
+  ;divide-dynamic: number number -> number
+  (define (divide-dynamic left right)
+    (if (or (inexact? left) (inexact? right))
+        (divide-float left right)
+        (divide-int left right)))
+  
   ;divide-int: int int -> int
   (define (divide-int left right)
     (when (zero? right)

collects/profj/parsers/beginner-parser.ss

@@ -287,8 +287,8 @@
        [(O_BRACE Statement C_BRACE) (make-block (list $2) (build-src 3))])
       
       (BlockStatements
-       [(Statement) (if (list? $1) $1 (list $1))]
+       [(Assignment SEMI_COLON) (if (list? $1) $1 (list $1))]
-       [(BlockStatements Statement) (if (list? $2) (append (reverse $2) $1) (cons $2 $1))])
+       [(BlockStatements Assignment SEMI_COLON) (if (list? $2) (append (reverse $2) $1) (cons $2 $1))])
       
       (BeginnerInteractions
        [(Statement) $1]

collects/profj/to-scheme.ss

@@ -1826,7 +1826,7 @@
       ((symbol? type)
        (case type
          ((int short long byte) 'integer?)
-         ((double float) '(c:and/c number? inexact?))
+         ((double float) '(c:and/c number? (c:union inexact? integer?)))
          ((boolean) 'boolean?)
          ((char) 'char?)
          ((string String) 
@@ -2037,6 +2037,10 @@
   (define is-int? (make-is-test 'int))
   ;;is-char? type -> bool
   (define is-char? (make-is-test 'char))
+  ;;is-double?
+  (define (is-double? type)
+    (or ((make-is-test 'float) type)
+        ((make-is-test 'double) type)))  
   
   ;translate-bin-op: symbol syntax type syntax type src src type-> syntax
   (define (translate-bin-op op left left-type right right-type key src type)
@@ -2074,13 +2078,15 @@
               ((- *)
                (create-syntax #f `(,op-syntax ,left ,right) source))
               ((/) 
-               (make-syntax 
+               (let ((div-op                 
-                #f
+                      (cond
-                (cond
+                        ((or (is-double? left-type) (is-double? right-type))
-                  ((or (is-int? type) (and (dynamic-val? type) (is-int? (dynamic-val-type type))))
+                         'javaRuntime:divide-float)
-                   `(,(create-syntax #f 'javaRuntime:divide-int key-src) ,left ,right))
+                        ((or (dynamic-val? left-type) (dynamic-val? right-type))
-                  (else
+                         'javaRuntime:divide-dynamic)
-                   `(,(create-syntax #f 'javaRuntime:divide-float key-src) ,left ,right))) source))
+                        (else
+                         'javaRuntime:divide-int))))
+                 (make-syntax #f `(,(create-syntax #f div-op key-src) ,left ,right) source)))
               ((%) (make-syntax #f `(,(create-syntax #f 'javaRuntime:mod key-src) ,left ,right) source))
               ;Shift operations
               ((<< >> >>>) 
@@ -2111,7 +2117,7 @@
       (if (dynamic-val? type)
           (make-syntax #f
                        (convert-assert-value 
-                        (make-syntax #f `(c:contract ,(type->contract (dynamic-val-type type)) ,result 
+                        (make-syntax #f `(c:contract ,(type->contract (dynamic-val-type type) #t) ,result 
                                                      (quote ,(string->symbol (class-name))) '||) source)
                         type)
                        source)

collects/profj/types.ss

@@ -147,7 +147,7 @@
   ;; assignment-conversion: type type type-records -> boolean
   (define (assignment-conversion to from type-recs)
     (cond
-      ((dynamic-val? to) 
+      ((dynamic-val? to)
        (cond
          ((dynamic-val-type to) => (lambda (t) (assignment-conversion t from type-recs)))
          (else (set-dynamic-val-type! to from) #t)))