Corrected bugs regarding exceptions and check ... catch

svn: r4464

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))
+                                  (let ((n (make-ref-type 
-                                                          (map id-string (name-path t)))))
+                                            (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)))))

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)))
+           (throw-error 'not-declared exp-type src))))
-        (else
+      (send type-recs add-req (make-req "Throwable" (list "java" "lang")))
-         (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
+  ;check-test-catch: expr type-spec (expr env -> type-env) env src type-records -> type/env
-  (define (check-test-catch test-type type src type-recs)
+  (define (check-test-catch test type check-e env src type-recs)
-    (let ((catch-type (type-spec-to-type type #f 'full 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)

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))

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)))

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)))

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 { }"