diff --git a/collects/profj/check.ss b/collects/profj/check.ss index 80fdfb375f..8785bb6e2a 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -1108,7 +1108,7 @@ (define (check-while cond/env src check-s loop-body) ((check-cond 'while) (type/env-t cond/env) src) (check-s loop-body (type/env-e cond/env) #t #f) - (make-type/env 'void (type/env-t cond/env))) + (make-type/env 'void (type/env-e cond/env))) ;check-do: (exp env -> type/env) exp src type/env -> type/env (define (check-do check-e exp src loop/env) @@ -2746,7 +2746,7 @@ ((method-name) (let ((line1 (format "Method ~a is being erroneously accessed as a field for class ~a." field t)) - (line2 "A call to a method chould be followed by () and any arguments to the method")) + (line2 "A call to a method should be followed by () and any arguments to the method")) (format "~a~n~a" line1 line2))) ((array) (format "~a only has a length field, attempted to access ~a" t field)) diff --git a/collects/profj/libs/java/lang/Object-composite.ss b/collects/profj/libs/java/lang/Object-composite.ss index f9227b9cb3..9088913040 100644 --- a/collects/profj/libs/java/lang/Object-composite.ss +++ b/collects/profj/libs/java/lang/Object-composite.ss @@ -733,7 +733,7 @@ (when (>= begin (string-length text)) (raise (make-runtime-error (format "First argument to substring must be smaller than the string's length ~a, given ~a." (string-length text) begin)))) - (when (>= end (string-length text)) + (when (> end (string-length text)) (raise (make-runtime-error (format "Second argument to substring must be smaller than the string's length ~a, given ~a." (string-length text) end)))) (when (< end 0) diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index 27d24dd493..370ae9ea65 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -465,56 +465,58 @@ [class-path ((current-module-name-resolver) '(lib "class.ss") #f #f)] [mred-path ((current-module-name-resolver) '(lib "mred.ss" "mred") #f #f)] [n (current-namespace)]) - (read-case-sensitive #t) - (run-in-user-thread - (lambda () - (error-display-handler - (drscheme:debug:make-debug-error-display-handler (error-display-handler))) - (let ((old-current-eval (drscheme:debug:make-debug-eval-handler (current-eval)))) - (current-eval - (lambda (exp) - (syntax-case exp (parse-java-full-program parse-java-interactions) - ((parse-java-full-program ex) - (let ((exp (old-current-eval (syntax ex)))) - (execution? #t) - (let ((name-to-require #f)) - (let loop ((mods (order (compile-ast exp level execute-types))) - (extras (process-extras - (send execute-types get-interactions-boxes) execute-types)) - (require? #f)) - (cond - ((and (not require?) (null? mods) (null? extras)) (void)) - ((and (not require?) (null? mods)) - (old-current-eval (syntax-as-top (car extras))) - (loop mods (cdr extras) require?)) - (require? - (old-current-eval - (syntax-as-top (with-syntax ([name name-to-require]) - (syntax (require name))))) - (loop mods extras #f)) - (else - (let-values (((name syn) (get-module-name (expand (car mods))))) - (set! name-to-require name) - (syntax-as-top (old-current-eval syn)) - (loop (cdr mods) extras #t)))))))) - ((parse-java-interactions ex loc) - (let ((exp (syntax-object->datum (syntax ex)))) - (old-current-eval - (syntax-as-top (compile-interactions-ast exp (syntax loc) level execute-types #t))))) - (_ (old-current-eval exp)))))) - (with-handlers ([void (lambda (x) (printf "~a~n" (exn-message x)))]) - (namespace-require 'mzscheme) - (namespace-attach-module n obj-path) - (namespace-attach-module n string-path) - (namespace-attach-module n class-path) - (namespace-attach-module n mred-path) - (namespace-require obj-path) - (namespace-require string-path) - (namespace-require class-path) - (namespace-require mred-path) - (namespace-require '(prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java"))) - (namespace-require '(prefix c: (lib "contract.ss"))) - ))))) + (let ((execute-types (create-type-record))) + (read-case-sensitive #t) + (run-in-user-thread + (lambda () + (error-display-handler + (drscheme:debug:make-debug-error-display-handler (error-display-handler))) + (let ((old-current-eval (drscheme:debug:make-debug-eval-handler (current-eval)))) + (current-eval + (lambda (exp) + (syntax-case exp (parse-java-full-program parse-java-interactions) + ((parse-java-full-program ex) + (let ((exp (old-current-eval (syntax ex)))) + (execution? #t) + (set! execute-types (create-type-record)) + (let ((name-to-require #f)) + (let loop ((mods (order (compile-ast exp level execute-types))) + (extras (process-extras + (send execute-types get-interactions-boxes) execute-types)) + (require? #f)) + (cond + ((and (not require?) (null? mods) (null? extras)) (void)) + ((and (not require?) (null? mods)) + (old-current-eval (syntax-as-top (car extras))) + (loop mods (cdr extras) require?)) + (require? + (old-current-eval + (syntax-as-top (with-syntax ([name name-to-require]) + (syntax (require name))))) + (loop mods extras #f)) + (else + (let-values (((name syn) (get-module-name (expand (car mods))))) + (set! name-to-require name) + (syntax-as-top (old-current-eval syn)) + (loop (cdr mods) extras #t)))))))) + ((parse-java-interactions ex loc) + (let ((exp (syntax-object->datum (syntax ex)))) + (old-current-eval + (syntax-as-top (compile-interactions-ast exp (syntax loc) level execute-types #t))))) + (_ (old-current-eval exp)))))) + (with-handlers ([void (lambda (x) (printf "~a~n" (exn-message x)))]) + (namespace-require 'mzscheme) + (namespace-attach-module n obj-path) + (namespace-attach-module n string-path) + (namespace-attach-module n class-path) + (namespace-attach-module n mred-path) + (namespace-require obj-path) + (namespace-require string-path) + (namespace-require class-path) + (namespace-require mred-path) + (namespace-require '(prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java"))) + (namespace-require '(prefix c: (lib "contract.ss"))) + )))))) #;(define/public (render-value value settings port); port-write) (let ((print-full? (profj-settings-print-full? settings)) diff --git a/collects/tests/profj/advanced-tests.ss b/collects/tests/profj/advanced-tests.ss index 6601a0d9b6..171ad59a23 100644 --- a/collects/tests/profj/advanced-tests.ss +++ b/collects/tests/profj/advanced-tests.ss @@ -1,10 +1,26 @@ (module advanced-tests mzscheme (require (lib "profj-testing.ss" "profj")) + (require (lib "String.ss" "profj" "libs" "java" "lang")) (prepare-for-tests "Advanced") ;;Execution tests without errors + (execute-test + "class Blah { + Blah () {} + int addUp (int top) { + int answer = 0; + int counter = 1; + while (counter <= top) { + answer += counter; + ++counter; + } + return answer; + } + }" + 'advanced #f "while loop with statements after") + (execute-test "interface A { int a( int x); } abstract class B implements A { } @@ -325,6 +341,13 @@ class WeeklyPlanner{ (list '(void) 'o~f) "Casting to a String") + (interact-test + 'advanced + (list "\"hello\".substring(2,5)") + (list (make-java-string "llo")) + "Test of substring") + + (report-test-results) ) \ No newline at end of file