From 50ca4e1cbf5ba484813cf5072d645ae0be0458a5 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Mon, 2 Oct 2006 20:17:36 +0000 Subject: [PATCH] Corrected bugs regarding exceptions and check ... catch svn: r4464 --- collects/profj/build-info.ss | 8 ++++-- collects/profj/check.ss | 27 +++++++++++++------ collects/profj/display-java.ss | 3 +++ collects/profj/parsers/parse-error.ss | 38 +++++++++++++-------------- collects/profj/profj-testing.ss | 23 +++++++++++++--- collects/tests/profj/full-tests.ss | 24 +++++++++++++++++ 6 files changed, 90 insertions(+), 33 deletions(-) diff --git a/collects/profj/build-info.ss b/collects/profj/build-info.ss index 0897a321ff..9fca544734 100644 --- a/collects/profj/build-info.ss +++ b/collects/profj/build-info.ss @@ -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))))) diff --git a/collects/profj/check.ss b/collects/profj/check.ss index def1b27eae..27beacac15 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -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) diff --git a/collects/profj/display-java.ss b/collects/profj/display-java.ss index f66728e50e..0d5ac86141 100644 --- a/collects/profj/display-java.ss +++ b/collects/profj/display-java.ss @@ -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)) diff --git a/collects/profj/parsers/parse-error.ss b/collects/profj/parsers/parse-error.ss index ca44e0b625..c7085b1604 100644 --- a/collects/profj/parsers/parse-error.ss +++ b/collects/profj/parsers/parse-error.ss @@ -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))) diff --git a/collects/profj/profj-testing.ss b/collects/profj/profj-testing.ss index 07f08c9501..c32a7439af 100644 --- a/collects/profj/profj-testing.ss +++ b/collects/profj/profj-testing.ss @@ -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))) diff --git a/collects/tests/profj/full-tests.ss b/collects/tests/profj/full-tests.ss index b74a21da06..32b80f9289 100644 --- a/collects/tests/profj/full-tests.ss +++ b/collects/tests/profj/full-tests.ss @@ -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 { }"