From 5503e793552341ab17ad50e6c553e07b7da70437 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Thu, 8 Feb 2007 00:20:48 +0000 Subject: [PATCH] Adding more testing support svn: r5571 --- collects/profj/ast.ss | 3 + collects/profj/check.ss | 100 ++++++++++++++++++++++++ collects/profj/libs/java/runtime.scm | 106 ++++++++++++++++++-------- collects/profj/parsers/full-parser.ss | 6 +- collects/profj/parsers/lexer.ss | 4 +- collects/profj/to-scheme.ss | 27 +++++++ 6 files changed, 212 insertions(+), 34 deletions(-) diff --git a/collects/profj/ast.ss b/collects/profj/ast.ss index b66c1f6a11..ac6c0b16fc 100644 --- a/collects/profj/ast.ss +++ b/collects/profj/ast.ss @@ -300,6 +300,9 @@ ;(make-check-catch (U #f type) src Expression type-spec) (p-define-struct (check-catch check) (test exn)) + ;(make-check-by (U #f type) src Expression Expression (U '== Name)) + (p-define-struct (check-by check) (test actual compare)) + ;(make-check-mutate (U #f type) src Expression Expression src) (p-define-struct (check-mutate check) (mutate check op-src)) diff --git a/collects/profj/check.ss b/collects/profj/check.ss index 27beacac15..25d9df8a91 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -2725,6 +2725,16 @@ env (expr-src exp) type-recs)) + ((check-by? exp) + (check-test-by exp + (check-by-test exp) + (check-by-actual exp) + (check-by-compare exp) + check-sub-expr + env + level + (expr-src exp) + type-recs)) ((check-mutate? exp) (check-test-mutate (check-mutate-mutate exp) (check-mutate-check exp) @@ -2796,6 +2806,61 @@ [test-type (check-e test new-env)]) (make-type/env 'boolean (restore-exn-env (type/env-e test-type) env))))) + ;check-test-by: expr expr (U symbol id) (expr env -> type-env) env symbol src type-records -> type/env + (define (check-test-by exp test actual by check-e env level src type-recs) + (let* ([test-et (check-e test env)] + [actual-et (check-e actual (type/env-e test-et))] + [test-type (type/env-t test-et)] + [actual-type (type/env-t actual-et)] + [new-env (type/env-e actual-et)]) + (cond + [(eq? '== by) + (unless + (or (and (prim-numeric-type? test-type) + (prim-numeric-type? actual-type)) + (and (boolean? test-type) + (boolean? actual-type)) + (and + (reference-type? test-type) + (reference-type? actual-type) + (castable? actual-type test-type type-recs)) + (and + (reference-type? test-type) + (reference-type? actual-type) + (castable? test-type actual-type type-recs))) + (check-by-==-error test-type actual-type src))] + [else + (unless (and (reference-type? test-type) + (reference-type? actual-type)) + (check-by-error 'not-obj test-type actual-type #f src)) + (unless (or (dynamic-val? test-type) + (eq? 'dynamic test-type)) + (let* ([class-rec (send type-recs get-class-record test-type)] + [methods (get-method-records by class-rec type-recs)]) + (cond + [(null? methods) + (check-by-error 'no-such-method test-type #f by src)] + [else + (let ([meth (resolve-overloading methods + (list actual-type) + (lambda () + (check-by-error 'no-arg-count + test-type #f by src)) + (lambda () + (check-by-error 'conflict + test-type actual-type + by src)) + (lambda () + (check-by-error 'no-match + test-type actual-type + by src)) + type-recs)]) + (when meth + (unless (eq? (method-record-rtype meth) 'boolean) + (check-by-error 'not-boolean test-type actual-type by src)) + (set-check-by-compare! exp meth)))]) + (make-type/env 'boolean new-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) (unless (or (call? mutatee) @@ -3553,6 +3618,41 @@ 'check ta-src )) + (define (check-by-==-error t-type a-type src) + (raise-error + 'check + (string-append "In a 'check' expression with '==', the type of the expected and actual expression must be castable to each other~n" + (format "Given ~a and ~a, which are not comparable." + (type->ext-name t-type) (type->ext-name a-type))) + 'by + src)) + + (define (check-by-error kind t-type a-type by src) + (let ([by (if (id? by) (id-string by) by)]) + (raise-error + 'check + (case kind + [(not-obj) + (string-append "In a 'check' expression with 'by', the type of the expected value must be an interface or class~n" + (format "Exepected value is of ~a type, which is not allowed." + (type->ext-name t-type)))] + [(no-such-method) + (format "Class or interface ~a does not have a method ~a to compare with in this 'check'." + (type->ext-name t-type) by)] + [(no-arg-count) + (format "Class or interface ~a does not have a method ~a accepting one argument for this 'check'" + (type->ext-name t-type) by)] + [(conflict) + (format "Multiple methods in ~a could accept the argument ~a for comparison in this 'check'." + (type->ext-name t-type) (type->ext-name a-type) by)] + [(no-match) + (format "No ~a method in ~a expects a ~a for comparison in this 'check'." + by (type->ext-name t-type) (type->ext-name a-type))] + [(not-bool) + (format "Method ~a accepting ~a in ~a does not return a boolean and cannot do the comparison in this 'check'." + by (type->ext-name a-type) (type->ext-name t-type))]) + 'by src))) + ;check-catch-error: type src -> void (define (check-catch-error name src) (raise-error diff --git a/collects/profj/libs/java/runtime.scm b/collects/profj/libs/java/runtime.scm index de5e85599f..8352f33721 100644 --- a/collects/profj/libs/java/runtime.scm +++ b/collects/profj/libs/java/runtime.scm @@ -18,7 +18,7 @@ (provide convert-to-string shift not-equal bitwise mod divide-dynamic divide-int divide-float and or cast-primitive cast-reference instanceof-array nullError - check-eq? dynamic-equal? compare compare-within check-catch check-mutate) + check-eq? dynamic-equal? compare compare-within check-catch check-mutate check-by) (define (check-eq? obj1 obj2) (or (eq? obj1 obj2) @@ -207,6 +207,8 @@ (compare-within test act 0.0 info src test-obj catch? #f)) (define exception (gensym 'exception)) + ;(make-exn-thrown exn boolean string) + (define-struct exn-thrown (exception expected? cause)) ;compare-within: (-> val) val val (list symbol string) (U #f object) boolean . boolean -> boolean (define (compare-within test act range info src test-obj catch? . within?) @@ -246,10 +248,10 @@ (else #f))))) (fail? #f)) (set! test - (with-handlers ((exn? + (with-handlers ([exn? (lambda (e) (set! fail? #t) - (list exception catch? e)))) + (list exception catch? e "eval"))]) (test))) (let ([res (if fail? #f (java-equal? test act null null))] [values-list (append (list act test) (if (null? within?) (list range) null))]) @@ -275,6 +277,26 @@ (stored-checks (cons (list return 'check-catch info values-list src) (stored-checks))) (report-check-result return 'check-catch info values-list src test-obj)) return)) + + ;check-by: (-> val) value (value value -> boolean) (list string) string src object -> boolean + (define (check-by test act comp info meth src test-obj) + (let* ([fail? #f] + [test (with-handlers ([exn? + (lambda (e) + (set! fail? #t) + (list exception e "eval"))]) + (test))] + [result (with-handlers ([exn? + (lambda (e) + (set! fail? #t) + (list exception e "comp"))]) + (and (not fail?) + (comp test act)))] + [values-list (list act test meth result)]) + (if (in-check-mutate?) + (stored-checks (cons (list (and (not fail?) result) 'check-by info values-list src) (stored-checks))) + (report-check-result (and (not fail?) result) 'check-by info values-list src test-obj)) + (and (not fail?) result))) ;check-mutate: (-> val) (-> boolean) (list string) src object -> boolean (define (check-mutate mutatee check info src test-obj) @@ -311,39 +333,61 @@ (define (compose-message test-obj check-kind info values mutate-message) (letrec ((test-format (construct-info-msg info)) - (exception-raised? #f) + (eval-exception-raised? #f) + (comp-exception-raised? #f) (exception-not-error? #f) (formatted-values (map (lambda (v) - (if (and (pair? v) (eq? (car v) exception)) - (begin (set! exception-raised? #t) - (set! exception-not-error? (cadr v)) - (send test-obj format-value (caddr v))) - (send test-obj format-value v))) values)) + (cond + [(and (pair? v) (eq? (car v) exception)) + (if (equal? (cadddr v) "eval") + (set! eval-exception-raised? #t) + (set! comp-exception-raised? #t)) + (set! exception-not-error? (cadr v)) + (send test-obj format-value (caddr v))] + [else (send test-obj format-value v)])) values)) (expected-format (case check-kind - ((check-expect) "to produce ") + ((check-expect check-by) "to produce ") ((check-catch) "to throw an instance of ")))) - (append (list (if mutate-message mutate-message "check expected ") - test-format - expected-format - (first formatted-values)) - (case check-kind - ((check-expect) - (append (if (= (length formatted-values) 3) - (list ", within " (third formatted-values)) - null) - (cond - [(and exception-raised? (not exception-not-error?)) - (list ", instead a " (second formatted-values) " exception occurred")] - [(and exception-raised? exception-not-error?) - (list", instead an error occured")] - [else - (list ", instead found " (second formatted-values))]))) - ((check-catch) - (if (= (length formatted-values) 1) - (list ", instead no exceptions occured") - (list ", instead an instance of " (second formatted-values) " was thrown")))) - (list ".")))) + (cond + [(not (eq? 'check-by check-kind)) + (append (list (if mutate-message mutate-message "check expected ") + test-format + expected-format + (first formatted-values)) + (case check-kind + ((check-expect) + (append (if (= (length formatted-values) 3) + (list ", within " (third formatted-values)) + null) + (cond + [(and eval-exception-raised? (not exception-not-error?)) + (list ", instead a " (second formatted-values) " exception occurred")] + [(and eval-exception-raised? exception-not-error?) + (list", instead an error occurred")] + [else + (list ", instead found " (second formatted-values))]))) + ((check-catch) + (if (= (length formatted-values) 1) + (list ", instead no exceptions occurred") + (list ", instead an instance of " (second formatted-values) " was thrown")))) + (list "."))] + [(and (eq? check-kind 'check-by) + comp-exception-raised?) + (list "check encountered a " (fourth formatted-values) + " exception when using " (third formatted-values) + " to compare the actual value " (second formatted-values) + " with the expected result " (first formatted-values) ".")] + [(and (eq? check-kind 'check-by) eval-exception-raised?) + (list "check expected a value to use in " (third formatted-values) + " with argument " (first formatted-values) + " instead, a " (second formatted-values) + " exception occurred.")] + [else + (list "check received the value " (second formatted-values) + " to compare to " (first formatted-values) + " using " (third formatted-values) + ". This value did not match the expectation.")]))) ;construct-info-msg (list symbol string ...) -> string (define (construct-info-msg info) diff --git a/collects/profj/parsers/full-parser.ss b/collects/profj/parsers/full-parser.ss index ebc453334d..69d8528a4b 100644 --- a/collects/profj/parsers/full-parser.ss +++ b/collects/profj/parsers/full-parser.ss @@ -1028,7 +1028,11 @@ [(check ConditionalExpression expect ConditionalExpression within ConditionalExpression) (make-check-expect #f (build-src 6) $2 $4 $6 (build-src 2 4))] [(check ConditionalExpression catch Type) - (make-check-catch #f (build-src 4) $2 $4)]) + (make-check-catch #f (build-src 4) $2 $4)] + [(check ConditionalExpression expect ConditionalExpression by ==) + (make-check-by #f (build-src 6) $2 $4 '==)] + [(check ConditionalExpression expect ConditionalExpression by IDENTIFIER) + (make-check-by #f (build-src 6) $2 $4 $6)]) (MutateExpression [(CheckExpression) $1] diff --git a/collects/profj/parsers/lexer.ss b/collects/profj/parsers/lexer.ss index b4f40bf2d8..62ee26eef6 100644 --- a/collects/profj/parsers/lexer.ss +++ b/collects/profj/parsers/lexer.ss @@ -44,7 +44,7 @@ const for new switch continue goto package synchronized)) - (define-empty-tokens ExtraKeywords (dynamic check expect within -> ->> ->>> test tests testcase)) + (define-empty-tokens ExtraKeywords (dynamic check expect within by -> ->> ->>> test tests testcase)) (define-tokens java-vals (STRING_LIT CHAR_LIT INTEGER_LIT LONG_LIT FLOAT_LIT DOUBLE_LIT @@ -317,7 +317,7 @@ ((test-ext?) (string->symbol lexeme)) (else (token-IDENTIFIER lexeme)))) - ((re:or "test" "tests" "testcase") + ((re:or "test" "tests" "testcase" "by") (cond ((testcase-ext?) (string->symbol lexeme)) (else (token-IDENTIFIER lexeme)))) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index 5aa53bc1f3..8e0f453850 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -2938,6 +2938,10 @@ ((check-catch? expr) (translate-check-catch (check-catch-test expr) (check-catch-exn expr) (expr-src expr))) + ((check-by? expr) (translate-check-by (check-by-test expr) + (check-by-actual expr) + (check-by-compare expr) + (expr-src expr))) ((check-mutate? expr) (translate-check-mutate (check-mutate-mutate expr) (check-mutate-check expr) (expr-src expr))))) @@ -2968,6 +2972,29 @@ (lambda () #f))) (build-src src)))) + ;translate-check-by: expression expression (U '== method-record) src -> syntax + (define (translate-check-by test actual comp src) + (let ([t (create-syntax #f `(lambda () ,(translate-expression test)) #f)] + [a (translate-expression actual)] + [info (checked-info test)]) + (make-syntax #f + `(javaRuntime:check-by ,t ,a + ,(if (method-record? comp) + (create-syntax #f `(lambda (test-v a) + (send test-v + ,(build-identifier + (mangle-method-name + (method-record-name comp) + (method-record-atypes comp))) + a)) + (build-src src)) + 'eq?) + ,info + ,(if (method-record? comp) (method-record-name comp) "==") + ,src + (namespace-variable-value 'current~test~object% #f (lambda () #f))) + (build-src src)))) + ;translate-check-mutate: expression expression src -> syntax (define (translate-check-mutate mutatee check src) (let ((t (create-syntax #f `(lambda () ,(translate-expression mutatee)) #f))