Corrected bugs regarding exceptions and check ... catch
svn: r4464
This commit is contained in:
Kathy Gray
parent
459b86900b
commit
50ca4e1cbf
|
|
@ -1414,8 +1414,12 @@
|
|||
(not (or (is-eq-subclass? n runtime-exn-type type-recs))))
|
||||
;(is-eq-subclass? n error-type type-recs))))
|
||||
(map (lambda (t)
|
||||
(let ((n (make-ref-type (id-string (name-id t))
|
||||
(map id-string (name-path t)))))
|
||||
(let ((n (make-ref-type
|
||||
(id-string (name-id t))
|
||||
(if (null? (name-path t))
|
||||
(send type-recs lookup-path (id-string (name-id t))
|
||||
(lambda () null))
|
||||
(map id-string (name-path t))))))
|
||||
(if (is-eq-subclass? n throw-type type-recs)
|
||||
n
|
||||
(throws-error (name-id t) (name-src t)))))
|
||||
|
|
|
|||
|
|
@ -192,6 +192,14 @@
|
|||
(add-exns-to-env (cdr exns)
|
||||
(add-exn-to-env (car exns) env))))
|
||||
|
||||
;restore-exn-env: env env -> env
|
||||
(define (restore-exn-env old-env new-env)
|
||||
(make-environment (environment-types new-env)
|
||||
(environment-set-vars new-env)
|
||||
(environment-exns old-env)
|
||||
(environment-labels new-env)
|
||||
(environment-local-inners new-env)))
|
||||
|
||||
;;lookup-exn: type env type-records symbol-> bool
|
||||
(define (lookup-exn type env type-recs level)
|
||||
(ormap (lambda (lookup)
|
||||
|
|
@ -1108,9 +1116,8 @@
|
|||
(throw-error 'not-throwable exp-type src))
|
||||
((not (is-eq-subclass? exp-type runtime-exn-type type-recs))
|
||||
(unless (or interact? (lookup-exn exp-type env type-recs 'full))
|
||||
(throw-error 'not-declared exp-type src)))
|
||||
(else
|
||||
(send type-recs add-req (make-req "Throwable" (list "java" "lang")))))
|
||||
(throw-error 'not-declared exp-type src))))
|
||||
(send type-recs add-req (make-req "Throwable" (list "java" "lang")))
|
||||
exp/env))
|
||||
|
||||
;check-return: statement expression type env (expression -> type/env) src bool symbol type-records -> type/env
|
||||
|
|
@ -2712,8 +2719,10 @@
|
|||
(expr-src exp)
|
||||
type-recs))
|
||||
((check-catch? exp)
|
||||
(check-test-catch (check-sub-expr (check-catch-test exp) env)
|
||||
(check-test-catch (check-catch-test exp)
|
||||
(check-catch-exn exp)
|
||||
check-sub-expr
|
||||
env
|
||||
(expr-src exp)
|
||||
type-recs))
|
||||
((check-mutate? exp)
|
||||
|
|
@ -2776,14 +2785,16 @@
|
|||
level
|
||||
test-t actual-t ta-src)))))
|
||||
|
||||
;check-test-catch: type/env type-spec src type-records -> type/env
|
||||
(define (check-test-catch test-type type src type-recs)
|
||||
(let ((catch-type (type-spec-to-type type #f 'full type-recs)))
|
||||
;check-test-catch: expr type-spec (expr env -> type-env) env src type-records -> type/env
|
||||
(define (check-test-catch test type check-e env src type-recs)
|
||||
(let ([catch-type (type-spec-to-type type #f 'full type-recs)])
|
||||
(unless (is-eq-subclass? catch-type throw-type type-recs)
|
||||
(check-catch-error catch-type (type-spec-src type)))
|
||||
(when (reference-type? catch-type)
|
||||
(send type-recs add-req (make-req (ref-type-class/iface catch-type) (ref-type-path catch-type))))
|
||||
(make-type/env 'boolean (type/env-e test-type))))
|
||||
(let* ([new-env (add-exn-to-env catch-type env)]
|
||||
[test-type (check-e test new-env)])
|
||||
(make-type/env 'boolean (restore-exn-env (type/env-e test-type) env)))))
|
||||
|
||||
;check-test-mutate: exp exp (exp env -> type/env) env src type-records -> type/env
|
||||
(define (check-test-mutate mutatee check check-sub-expr env src type-recs)
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@
|
|||
(lib "framework.ss" "framework")
|
||||
(lib "Object.ss" "profj" "libs" "java" "lang")
|
||||
(lib "String.ss" "profj" "libs" "java" "lang")
|
||||
(lib "Throwable.ss" "profj" "libs" "java" "lang")
|
||||
(lib "array.ss" "profj" "libs" "java" "lang"))
|
||||
|
||||
(provide format-java-value make-format-style make-java-snip)
|
||||
|
|
@ -49,6 +50,8 @@
|
|||
(format-array->list value 3 (- (send value length) 3) #f style already-printed newline? num-tabs)))
|
||||
((is-a? value String) (list (format "~v" (send value get-mzscheme-string))))
|
||||
((string? value) (list (format "~v" value)))
|
||||
((java:exception? value) (internal-format (java:exception-object value) full-print?
|
||||
style already-printed newline? num-tabs))
|
||||
((or (is-a? value ObjectI) (supports-printable-interface? value))
|
||||
(cond
|
||||
((and (equal? "Image" (send value my-name))
|
||||
|
|
|
|||
|
|
@ -341,14 +341,14 @@
|
|||
(next-tok (get-tok next)))
|
||||
(cond
|
||||
((class? next-tok) (parse-definition cur-tok next state getter))
|
||||
((eof? next-tok) (parse-error "abstract should be followed by class definition" srt end))
|
||||
((eof? next-tok) (parse-error "'abstract' should be followed by a class definition." srt end))
|
||||
(else
|
||||
(if (close-to-keyword? next-tok 'class)
|
||||
(parse-error (format "expected 'class' after 'abstract', found ~a which is incorrectly spelled or capitalized"
|
||||
(parse-error (format "Expected 'class' after 'abstract', found ~a which is incorrectly spelled or capitalized."
|
||||
(token-value next-tok))
|
||||
srt
|
||||
(get-end next))
|
||||
(parse-error (format "abstract must be immediately followed by 'class' not ~a" (format-out next-tok))
|
||||
(parse-error (format "'abstract' must be immediately followed by 'class' not ~a." (format-out next-tok))
|
||||
srt
|
||||
(get-end next))))))))
|
||||
((interface)
|
||||
|
|
@ -409,27 +409,27 @@
|
|||
(let* ((next (getter))
|
||||
(next-tok (get-tok next)))
|
||||
(cond
|
||||
((eof? next-tok) (parse-error (format "expected class body after ~a" (token-value tok)) srt end))
|
||||
((eof? next-tok) (parse-error (format "Expected class body after ~a" (token-value tok)) srt end))
|
||||
((and (extends? next-tok) (or (intermediate?) (advanced?)))
|
||||
(parse-definition next (getter) 'extends getter))
|
||||
((implements? next-tok)
|
||||
(parse-definition next (getter) 'implements getter))
|
||||
((o-brace? next-tok) (parse-definition cur-tok next 'class-body getter))
|
||||
((and (or (intermediate?) (advanced?)) (close-to-keyword? next-tok 'extends) )
|
||||
(parse-error (format "found ~a, which is similar to 'extends'" (token-value next-tok))
|
||||
(parse-error (format "Found ~a, which is similar to 'extends'" (token-value next-tok))
|
||||
(get-start next) (get-end next)))
|
||||
((close-to-keyword? next-tok 'implements)
|
||||
(parse-error (format "found ~a, which is similar to 'implements'" (token-value next-tok))
|
||||
(parse-error (format "Found ~a, which is similar to 'implements'" (token-value next-tok))
|
||||
(get-start next) (get-end next)))
|
||||
((open-separator? next-tok)
|
||||
(parse-error (format "expected { to begin class body, but found ~a" (format-out next-tok))
|
||||
(parse-error (format "Expected { to begin class body, but found ~a" (format-out next-tok))
|
||||
(get-start next) (get-end next)))
|
||||
((c-brace? tok)
|
||||
(parse-error (format "Class body must be opened with { before being closed, found ~a" out)
|
||||
(get-start next) (get-end next)))
|
||||
(else
|
||||
(parse-error
|
||||
(format "class name must be followed by ~a 'implements' or a { to start class body, found ~a"
|
||||
(format "Class name must be followed by ~a 'implements' or a { to start class body, found ~a"
|
||||
(if (not (beginner?)) "'extends' clause or " "")
|
||||
(format-out next-tok)) srt (get-end next))))))
|
||||
(else
|
||||
|
|
@ -446,15 +446,15 @@
|
|||
((eof? next-tok) (parse-error (format "Expected interface body after ~a" (token-value tok)) srt end))
|
||||
((extends? next-tok)
|
||||
(if (beginner?)
|
||||
(parse-error "Expected '{' to begin interface body, found 'extends' which is not allowed here"
|
||||
(parse-error "Expected a '{' to begin interface body, found 'extends' which is not allowed here."
|
||||
(get-start next) (get-end next))
|
||||
(parse-definition next (getter) 'iface-extends getter)))
|
||||
((o-brace? next-tok) (parse-definition cur-tok next 'iface-body getter))
|
||||
((close-to-keyword? next-tok 'extends)
|
||||
(if (beginner?)
|
||||
(parse-error (format "Expected '{' to begin interface body, ~a cannot appear here" (token-value next-tok))
|
||||
(parse-error (format "Expected a '{' to begin interface body, ~a cannot appear here" (token-value next-tok))
|
||||
(get-start next) (get-end next))
|
||||
(parse-error (format "found ~a, which is similar to 'extends'" (token-value next-tok))
|
||||
(parse-error (format "Found ~a, which is similar to 'extends'." (token-value next-tok))
|
||||
(get-start next) (get-end next))))
|
||||
((open-separator? next-tok)
|
||||
(parse-error (format "Expected { to begin interface body, but found ~a" (format-out next-tok))
|
||||
|
|
@ -469,11 +469,11 @@
|
|||
(format-out next-tok)) srt (get-end next))))))
|
||||
(else
|
||||
(if (java-keyword? tok)
|
||||
(parse-error (format "interface may not be called ~a, as this is a reserved term" tokN) srt end)
|
||||
(parse-error (format "An interface may not be called ~a, as this is a reserved term." tokN) srt end)
|
||||
(parse-error (format "Expected a name for this interface, given ~a" out) srt end)))))
|
||||
((extends)
|
||||
(cond
|
||||
((eof? tok) (parse-error "Expected parent class after extends" ps pe))
|
||||
((eof? tok) (parse-error "Expected parent class after extends." ps pe))
|
||||
((id-token? tok)
|
||||
;(if (beginner?)
|
||||
; (parse-definition cur-tok (getter) 'class-body getter)
|
||||
|
|
@ -812,7 +812,7 @@
|
|||
(n-out (format-out n-tok))
|
||||
(ne (get-end next)))
|
||||
(cond
|
||||
((eof? n-tok) (parse-error "Field has not completed, class body still requires a }" srt end))
|
||||
((eof? n-tok) (parse-error "Field declaration has not completed, and class body still requires a }" srt end))
|
||||
((semi-colon? n-tok) (parse-members next (getter) 'start getter #f just-method?))
|
||||
((comma? n-tok) (parse-members next (getter) 'field-list getter #f just-method?))
|
||||
((teaching-assignment-operator? n-tok)
|
||||
|
|
@ -966,10 +966,10 @@
|
|||
((eof? afterC-tok) (parse-error "Expected rest of parameter list, and class body requires a }"
|
||||
(get-start afterID) (get-end afterID)))
|
||||
((c-paren? afterC-tok)
|
||||
(parse-error "Comma is unneeded before ) unless another variable is desired"
|
||||
(parse-error "Comma is unneeded before ) unless another variable is declared."
|
||||
(get-start afterID) (get-end afterC)))
|
||||
((comma? afterC-tok)
|
||||
(parse-error "Parameter list should not have ,, Only one is needed"
|
||||
(parse-error "Parameter list should not have ,, Only one ',' is needed."
|
||||
(get-start afterID) (get-end afterC)))
|
||||
(else (parse-members afterID afterC 'ctor-parms getter #f just-method?)))))
|
||||
((or (prim-type? afterID-tok) (id-token? afterID-tok))
|
||||
|
|
@ -996,13 +996,13 @@
|
|||
(let* ((next (getter))
|
||||
(next-tok (get-tok next)))
|
||||
(cond
|
||||
((eof? next-tok) (parse-error "Expected remainder of array type" srt end))
|
||||
((eof? next-tok) (parse-error "Expected remainder of array type declaration." srt end))
|
||||
((c-bracket? next-tok) (parse-members next (getter) 'array-type getter #f just-method?))
|
||||
(else
|
||||
(parse-error (format "Expected ']' to close array type, found ~a which is not allowed"
|
||||
(parse-error (format "Expected ']' to close array type, found ~a which is not allowed."
|
||||
(format-out next-tok))
|
||||
srt (get-end next))))))
|
||||
((COMMA) (parse-error "Expected new paramter name after type, found ','" srt end))
|
||||
((COMMA) (parse-error "Expected new paramter name after type, found ','." srt end))
|
||||
((IDENTIFIER)
|
||||
(let* ((next (getter))
|
||||
(next-tok (get-tok next)))
|
||||
|
|
|
|||
|
|
@ -3,7 +3,6 @@
|
|||
(require (lib "compile.ss" "profj")
|
||||
(lib "parameters.ss" "profj")
|
||||
(lib "display-java.ss" "profj")
|
||||
(lib "tool.ss" "profj")
|
||||
(lib "class.ss"))
|
||||
|
||||
(define report-expected-error-messages (make-parameter #t))
|
||||
|
|
@ -14,6 +13,8 @@
|
|||
(define interaction-msgs (make-parameter null))
|
||||
(define execution-msgs (make-parameter null))
|
||||
(define file-msgs (make-parameter null))
|
||||
(define missed-expected-errors (make-parameter 0))
|
||||
(define expected-failed-tests (make-parameter null))
|
||||
(define expected-error-messages (make-parameter null))
|
||||
|
||||
(provide java-values-equal?)
|
||||
|
|
@ -98,7 +99,10 @@
|
|||
(prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java"))
|
||||
(prefix c: (lib "contract.ss")))
|
||||
,(compile-interactions st st type-recs level)))))
|
||||
(unless (java-equal? (eval val) new-val null null)
|
||||
(when (eq? val 'error)
|
||||
(missed-expected-errors (add1 (missed-expected-errors)))
|
||||
(expected-failed-tests (cons msg (expected-failed-tests))))
|
||||
(unless (and (not (eq? val 'error)) (java-equal? (eval val) new-val null null))
|
||||
(interaction-errors (add1 (interaction-errors)))
|
||||
(interaction-msgs (cons (format "Test ~a: ~a evaluated to ~a instead of ~a"
|
||||
msg ent new-val val) (interaction-msgs))))))))
|
||||
|
|
@ -157,7 +161,11 @@
|
|||
(execution-errors (add1 (execution-errors)))
|
||||
(execution-msgs (cons
|
||||
(format "Test ~a : Exception-raised: ~a" msg (exn-message exn)) (execution-msgs))))))])
|
||||
(eval-modules (compile-java 'port 'port level #f st st)))))
|
||||
(eval-modules (compile-java 'port 'port level #f st st))
|
||||
(when error?
|
||||
(missed-expected-errors (add1 (missed-expected-errors)))
|
||||
(expected-failed-tests (cons msg (expected-failed-tests))))
|
||||
)))
|
||||
|
||||
;run-test: symbol string (U string (list string)) (U string (list string)) -> (U (list (list symbol bool string)) (list ...))
|
||||
(define (run-test level defn interact val)
|
||||
|
|
@ -215,7 +223,10 @@
|
|||
(execution-errors 0)
|
||||
(execution-msgs null)
|
||||
(file-errors 0)
|
||||
(file-msgs null))
|
||||
(file-msgs null)
|
||||
(missed-expected-errors 0)
|
||||
(expected-failed-tests null)
|
||||
(expected-error-messages null))
|
||||
|
||||
|
||||
;report-test-results: -> void
|
||||
|
|
@ -232,6 +243,10 @@
|
|||
(printf "~a file errors occurred~n" (file-errors))
|
||||
(for-each (lambda (m) (printf "~a~n" m)) (file-msgs))
|
||||
(newline))
|
||||
(when (> (missed-expected-errors) 0)
|
||||
(printf "Failed to receive errors for these ~a tests:~n" (missed-expected-errors))
|
||||
(for-each (lambda (m) (printf "~a~n" m)) (expected-failed-tests))
|
||||
(newline))
|
||||
(when (report-expected-error-messages)
|
||||
(printf "Received these expected error messages:~n")
|
||||
(for-each (lambda (m) (printf "Error for test ~a : ~a~n" (car m) (cdr m))) (expected-error-messages)))
|
||||
|
|
|
|||
|
|
@ -4,6 +4,30 @@
|
|||
|
||||
(prepare-for-tests "Full")
|
||||
|
||||
(execute-test
|
||||
"class AnExceptionThrower {
|
||||
int m() throws Throwable {
|
||||
if (true)
|
||||
throw new Throwable();
|
||||
throw new Exception();
|
||||
}
|
||||
}" 'full #f "Throwable is a subclass of Throwable for purpose of throws clause")
|
||||
|
||||
(execute-test
|
||||
"class AnotherExceptionThrower {
|
||||
int m() throws Exception {
|
||||
throw new Exception();
|
||||
}}" 'full #f "Throwable is imported when using throw")
|
||||
|
||||
(interact-test
|
||||
"class YAET {
|
||||
int m() throws Exception {
|
||||
throw new Exception();
|
||||
}
|
||||
}"
|
||||
'full '("check new YAET().m() catch Exception" "check new YAET().m() catch Throwable")
|
||||
'(#t #t) "Check properly catching exceptions")
|
||||
|
||||
(execute-test
|
||||
"import java.util.*;
|
||||
class Random { }"
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user