suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Corrected bug in statements after loop, running same language in two

Browse Source 
windows/tabs, substring off by one error, spelling error in error message

svn: r2591
This commit is contained in:
Kathy Gray 2006-04-04 17:42:06 +00:00
parent 740a1bd826
commit 524dbb1cbe
4 changed files with 78 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/profj/check.ss
View File

@ -1108,7 +1108,7 @@
(define (check-while cond/env src check-s loop-body) (define (check-while cond/env src check-s loop-body)
((check-cond 'while) (type/env-t cond/env) src) ((check-cond 'while) (type/env-t cond/env) src)
(check-s loop-body (type/env-e cond/env) #t #f) (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 ;check-do: (exp env -> type/env) exp src type/env -> type/env
(define (check-do check-e exp src loop/env) (define (check-do check-e exp src loop/env)
@ -2746,7 +2746,7 @@
((method-name) ((method-name)
(let ((line1 (let ((line1
(format "Method ~a is being erroneously accessed as a field for class ~a." field t)) (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))) (format "~a~n~a" line1 line2)))
((array) ((array)
(format "~a only has a length field, attempted to access ~a" t field)) (format "~a only has a length field, attempted to access ~a" t field))

2
collects/profj/libs/java/lang/Object-composite.ss
View File

@ -733,7 +733,7 @@
(when (>= begin (string-length text)) (when (>= begin (string-length text))
(raise (make-runtime-error (raise (make-runtime-error
(format "First argument to substring must be smaller than the string's length ~a, given ~a." (string-length text) begin)))) (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 (raise (make-runtime-error
(format "Second argument to substring must be smaller than the string's length ~a, given ~a." (string-length text) end)))) (format "Second argument to substring must be smaller than the string's length ~a, given ~a." (string-length text) end))))
(when (< end 0) (when (< end 0)

102
collects/profj/tool.ss
View File

@ -465,56 +465,58 @@
[class-path ((current-module-name-resolver) '(lib "class.ss") #f #f)] [class-path ((current-module-name-resolver) '(lib "class.ss") #f #f)]
[mred-path ((current-module-name-resolver) '(lib "mred.ss" "mred") #f #f)] [mred-path ((current-module-name-resolver) '(lib "mred.ss" "mred") #f #f)]
[n (current-namespace)]) [n (current-namespace)])
(read-case-sensitive #t) (let ((execute-types (create-type-record)))
(run-in-user-thread (read-case-sensitive #t)
(lambda () (run-in-user-thread
(error-display-handler (lambda ()
(drscheme:debug:make-debug-error-display-handler (error-display-handler))) (error-display-handler
(let ((old-current-eval (drscheme:debug:make-debug-eval-handler (current-eval)))) (drscheme:debug:make-debug-error-display-handler (error-display-handler)))
(current-eval (let ((old-current-eval (drscheme:debug:make-debug-eval-handler (current-eval))))
(lambda (exp) (current-eval
(syntax-case exp (parse-java-full-program parse-java-interactions) (lambda (exp)
((parse-java-full-program ex) (syntax-case exp (parse-java-full-program parse-java-interactions)
(let ((exp (old-current-eval (syntax ex)))) ((parse-java-full-program ex)
(execution? #t) (let ((exp (old-current-eval (syntax ex))))
(let ((name-to-require #f)) (execution? #t)
(let loop ((mods (order (compile-ast exp level execute-types))) (set! execute-types (create-type-record))
(extras (process-extras (let ((name-to-require #f))
(send execute-types get-interactions-boxes) execute-types)) (let loop ((mods (order (compile-ast exp level execute-types)))
(require? #f)) (extras (process-extras
(cond (send execute-types get-interactions-boxes) execute-types))
((and (not require?) (null? mods) (null? extras)) (void)) (require? #f))
((and (not require?) (null? mods)) (cond
(old-current-eval (syntax-as-top (car extras))) ((and (not require?) (null? mods) (null? extras)) (void))
(loop mods (cdr extras) require?)) ((and (not require?) (null? mods))
(require? (old-current-eval (syntax-as-top (car extras)))
(old-current-eval (loop mods (cdr extras) require?))
(syntax-as-top (with-syntax ([name name-to-require]) (require?
(syntax (require name))))) (old-current-eval
(loop mods extras #f)) (syntax-as-top (with-syntax ([name name-to-require])
(else (syntax (require name)))))
(let-values (((name syn) (get-module-name (expand (car mods))))) (loop mods extras #f))
(set! name-to-require name) (else
(syntax-as-top (old-current-eval syn)) (let-values (((name syn) (get-module-name (expand (car mods)))))
(loop (cdr mods) extras #t)))))))) (set! name-to-require name)
((parse-java-interactions ex loc) (syntax-as-top (old-current-eval syn))
(let ((exp (syntax-object->datum (syntax ex)))) (loop (cdr mods) extras #t))))))))
(old-current-eval ((parse-java-interactions ex loc)
(syntax-as-top (compile-interactions-ast exp (syntax loc) level execute-types #t))))) (let ((exp (syntax-object->datum (syntax ex))))
(_ (old-current-eval exp)))))) (old-current-eval
(with-handlers ([void (lambda (x) (printf "~a~n" (exn-message x)))]) (syntax-as-top (compile-interactions-ast exp (syntax loc) level execute-types #t)))))
(namespace-require 'mzscheme) (_ (old-current-eval exp))))))
(namespace-attach-module n obj-path) (with-handlers ([void (lambda (x) (printf "~a~n" (exn-message x)))])
(namespace-attach-module n string-path) (namespace-require 'mzscheme)
(namespace-attach-module n class-path) (namespace-attach-module n obj-path)
(namespace-attach-module n mred-path) (namespace-attach-module n string-path)
(namespace-require obj-path) (namespace-attach-module n class-path)
(namespace-require string-path) (namespace-attach-module n mred-path)
(namespace-require class-path) (namespace-require obj-path)
(namespace-require mred-path) (namespace-require string-path)
(namespace-require '(prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java"))) (namespace-require class-path)
(namespace-require '(prefix c: (lib "contract.ss"))) (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) #;(define/public (render-value value settings port); port-write)
(let ((print-full? (profj-settings-print-full? settings)) (let ((print-full? (profj-settings-print-full? settings))

23
collects/tests/profj/advanced-tests.ss
View File

@ -1,10 +1,26 @@
(module advanced-tests mzscheme (module advanced-tests mzscheme
(require (lib "profj-testing.ss" "profj")) (require (lib "profj-testing.ss" "profj"))
(require (lib "String.ss" "profj" "libs" "java" "lang"))
(prepare-for-tests "Advanced") (prepare-for-tests "Advanced")
;;Execution tests without errors ;;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 (execute-test
"interface A { int a( int x); } "interface A { int a( int x); }
abstract class B implements A { } abstract class B implements A { }
@ -325,6 +341,13 @@ class WeeklyPlanner{
(list '(void) 'o~f) (list '(void) 'o~f)
"Casting to a String") "Casting to a String")
(interact-test
'advanced
(list "\"hello\".substring(2,5)")
(list (make-java-string "llo"))
"Test of substring")
(report-test-results) (report-test-results)
) )