From a1cda35b2aae39eb27246eb7c66697d646e83f96 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Wed, 31 May 2006 04:14:39 +0000 Subject: [PATCH] svn: r3143 --- collects/profj/check.ss | 42 ++++++++++++++--------- collects/profj/parsers/general-parsing.ss | 2 +- collects/profj/parsers/parse-error.ss | 6 ++-- collects/profj/profj-testing.ss | 3 +- 4 files changed, 32 insertions(+), 21 deletions(-) diff --git a/collects/profj/check.ss b/collects/profj/check.ss index 4c6045169e..89c2a260d6 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -2681,9 +2681,9 @@ (range-t (when range (type/env-t range-te))) (res (make-type/env 'boolean (type/env-e range-te)))) (when (eq? test-t 'void) - (check-type-error 'void test-t actual-t (expr-src test))) + (check-type-error 'void level test-t actual-t (expr-src test))) (when (eq? actual-t 'void) - (check-type-error 'void test-t actual-t (expr-src actual))) + (check-type-error 'void level test-t actual-t (expr-src actual))) (when (and range (not (prim-numeric-type? range-t))) (check-range-error (expr-src range) range-t)) (cond @@ -2701,25 +2701,26 @@ (reference-type? test-t) (reference-type? actual-t)) (cond ((castable? actual-t test-t type-recs) res) - (else (check-type-error 'cast test-t actual-t ta-src)))) + (else (check-type-error 'cast level test-t actual-t ta-src)))) ((and (memq level '(advanced full)) (or (array-type? test-t) (array-type? actual-t))) (cond ((castable? actual-t test-t type-recs) res) (else - (check-type-error 'cast test-t actual-t ta-src)))) + (check-type-error 'cast level test-t actual-t ta-src)))) ((and (eq? level 'beginner) (reference-type? test-t) (reference-type? actual-t)) (if (or (is-eq-subclass? actual-t test-t type-recs) (implements? actual-t test-t type-recs)) res - (check-type-error 'iface test-t actual-t ta-src))) + (check-type-error 'iface level test-t actual-t ta-src))) ((and (reference-type? test-t) (reference-type? actual-t)) (if (or (is-eq-subclass? actual-t test-t type-recs) (implements? actual-t test-t type-recs)) res - (check-type-error 'subtype test-t actual-t ta-src))) + (check-type-error 'subtype level test-t actual-t ta-src))) (else (check-type-error (if (memq level '(advanced full)) 'cast 'subtype) + level test-t actual-t ta-src))))) @@ -3429,7 +3430,7 @@ 'check (if check-fault? test-src actual-src) ))) - (define (check-type-error kind test-type actual-type ta-src) + (define (check-type-error kind level test-type actual-type ta-src) (raise-error 'check (cond @@ -3438,16 +3439,23 @@ ((and (eq? kind 'void) (eq? actual-type 'void)) "The expected result of a 'check' expression must be a value. Current expression is not a value.") (else - (string-append - (format "In a 'check' expression, the type of the expected expression must be ~a the tested expression.~n" - (if (eq? kind 'cast) "castable to" "a subtype of")) - (format "Found ~a, which is not ~a ~a, the type of the tested expression." - (type->ext-name actual-type) - (case kind - ((cast) "castable to") - ((iface subtype) "a subtype of")) - (type->ext-name test-type) - )))) + (string-append (format "A 'check' expression compares the test and expected expressions.~n") + (format "Found ~a which is not comparable to ~a.~a" + (type->ext-name actual-type) + (type->ext-name test-type) + (if (not (eq? level 'full)) + "" + " The expected expression must be castable to the test type."))) + #;(string-append + (format "In a 'check' expression, the type of the expected expression must be ~a the tested expression.~n" + (if (eq? kind 'cast) "castable to" "a subtype of")) + (format "Found ~a, which is not ~a ~a, the type of the tested expression." + (type->ext-name actual-type) + (case kind + ((cast) "castable to") + ((iface subtype) "a subtype of")) + (type->ext-name test-type) + )))) 'check ta-src )) diff --git a/collects/profj/parsers/general-parsing.ss b/collects/profj/parsers/general-parsing.ss index ec8d2dc96f..0e02ea0557 100644 --- a/collects/profj/parsers/general-parsing.ss +++ b/collects/profj/parsers/general-parsing.ss @@ -250,7 +250,7 @@ class import package)) (assignment-operator? t) (prim-type? t) - (modifier? t))) + (modifier-token? t))) ;only looks for incorrect capitalization at this point, intend to add 1-off spelling errors for at least some keywords ;close-to-keyword? token (opt symbol )-> bool diff --git a/collects/profj/parsers/parse-error.ss b/collects/profj/parsers/parse-error.ss index e142a0023e..ca44e0b625 100644 --- a/collects/profj/parsers/parse-error.ss +++ b/collects/profj/parsers/parse-error.ss @@ -885,8 +885,10 @@ (else (parse-error (format "Expected a method name, found ~a" (format-out next-tok)) next-start next-end))))) ((java-keyword? tok) - (parse-error - (format "Expected return type of the method, reserved word ~a is not a type" kind) srt end)) + (if (and (advanced?) (modifier-token? tok)) + (parse-members cur (getter) 'method getter abstract-method? just-method?) + (parse-error + (format "Expected return type of the method, reserved word ~a is not a type" kind) srt end))) (else (parse-error (format "Expected return type of a method, found ~a" out) srt end)))) ((method-id) (case kind diff --git a/collects/profj/profj-testing.ss b/collects/profj/profj-testing.ss index a374e40545..07f08c9501 100644 --- a/collects/profj/profj-testing.ss +++ b/collects/profj/profj-testing.ss @@ -2,6 +2,7 @@ (require (lib "compile.ss" "profj") (lib "parameters.ss" "profj") + (lib "display-java.ss" "profj") (lib "tool.ss" "profj") (lib "class.ss")) @@ -178,7 +179,7 @@ (v-pe (lambda () (open-input-string val))) (given-val (get-val i-st i-pe)) (exp-val (get-val v-st v-pe))) - (list 'interact (java-equal? given-val exp-val null null) (format-java given-val #t 'field null #f 0))))))) + (list 'interact (java-equal? given-val exp-val null null) (format-java-value given-val #t 'field null #f 0))))))) (with-handlers ([exn? (lambda (exn)