diff --git a/collects/profj/check.ss b/collects/profj/check.ss index 33e52dd808..0100636b25 100644 --- a/collects/profj/check.ss +++ b/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) - (if (type/env? obj-type/env) (type/env-e obj-type/env) env)))) + (make-type/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) - (format "Only ~a methods or methods on objects may be called here" + (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." (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))) diff --git a/collects/profj/error-messaging.ss b/collects/profj/error-messaging.ss index 0eca85ffc3..d85d68bbc6 100644 --- a/collects/profj/error-messaging.ss +++ b/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) diff --git a/collects/profj/libs/java/runtime.scm b/collects/profj/libs/java/runtime.scm index 8d4fce3fd2..e839006fa9 100644 --- a/collects/profj/libs/java/runtime.scm +++ b/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) diff --git a/collects/profj/parsers/beginner-parser.ss b/collects/profj/parsers/beginner-parser.ss index c02b405edc..436befacf9 100644 --- a/collects/profj/parsers/beginner-parser.ss +++ b/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))] - [(BlockStatements Statement) (if (list? $2) (append (reverse $2) $1) (cons $2 $1))]) + [(Assignment SEMI_COLON) (if (list? $1) $1 (list $1))] + [(BlockStatements Assignment SEMI_COLON) (if (list? $2) (append (reverse $2) $1) (cons $2 $1))]) (BeginnerInteractions [(Statement) $1] diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index 5d41da1a43..d2895c5df8 100644 --- a/collects/profj/to-scheme.ss +++ b/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 - #f - (cond - ((or (is-int? type) (and (dynamic-val? type) (is-int? (dynamic-val-type type)))) - `(,(create-syntax #f 'javaRuntime:divide-int key-src) ,left ,right)) - (else - `(,(create-syntax #f 'javaRuntime:divide-float key-src) ,left ,right))) source)) + (let ((div-op + (cond + ((or (is-double? left-type) (is-double? right-type)) + 'javaRuntime:divide-float) + ((or (dynamic-val? left-type) (dynamic-val? right-type)) + 'javaRuntime:divide-dynamic) + (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) diff --git a/collects/profj/types.ss b/collects/profj/types.ss index 5c26f6067d..75621cf562 100644 --- a/collects/profj/types.ss +++ b/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)))