From c733d6c74848b48e774e6514e67a8f0fbca84976 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Mon, 30 Mar 2009 22:44:43 +0000 Subject: [PATCH] Turning check ... inspect ... on: step one. svn: r14369 --- collects/profj/ast.ss | 6 ++ collects/profj/check.ss | 82 ++++++++++++++++++++++----- collects/profj/libs/java/runtime.ss | 18 +++++- collects/profj/parsers/full-parser.ss | 11 +++- collects/profj/parsers/lexer.ss | 9 +-- collects/profj/to-scheme.ss | 60 ++++++++++++++++---- 6 files changed, 150 insertions(+), 36 deletions(-) diff --git a/collects/profj/ast.ss b/collects/profj/ast.ss index 2eadabde68..a47bee41fc 100644 --- a/collects/profj/ast.ss +++ b/collects/profj/ast.ss @@ -310,6 +310,12 @@ ;(make-check-mutate (U #f type) src Expression Expression src) (p-define-struct (check-mutate check) (mutate check op-src)) + ;(make-check-inspect (U #f type) src Expression Expression Expression (list snap)) + (p-define-struct (check-inspect check) (val post range snaps)) + + ;(make-snap string type src) + (p-define-struct snap (name type src)) + ;(make-check-effect (U #f type) src (listof access) (listof Expression) (U Expression (listof Expression))) (p-define-struct (check-effect check) (vars conds test)) diff --git a/collects/profj/check.ss b/collects/profj/check.ss index 5987075776..dbd004c330 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -2047,6 +2047,7 @@ (name-string (when (id? name) (id-string name))) (expr (call-expr call)) (exp-type #f) + (test-method? #f) (handle-call-error (lambda (exn) (when (not (access? expr)) (raise exn)) @@ -2168,7 +2169,13 @@ ((null? rec) null) (else (get-method-records name-string rec type-recs))))))))))) - (when (null? methods) + (when (and (inspect-test?) (null? methods) + (or (equal? name-string "old") + (equal? name-string "modifies") + (equal? name-string "modifiesOnly"))) + (set! test-method? #t)) + + (when (and (null? methods) (not test-method?)) (let* ((rec (if exp-type (send type-recs get-class-record exp-type) (if static? (send type-recs get-class-record c-class) this))) @@ -2193,16 +2200,17 @@ (interaction-call-error name src level))) (else (no-method-error 'this sub-kind exp-type name src))))))) - - (unless (method-contract? (car methods)) - (when (and (not ctor?) - (eq? (method-record-rtype (car methods)) 'ctor)) - (ctor-called-error exp-type name src))) + (unless test-method? + (unless (method-contract? (car methods)) + (when (and (not ctor?) + (eq? (method-record-rtype (car methods)) 'ctor)) + (ctor-called-error exp-type name src)))) (let* ((args/env (check-args arg-exps check-sub env)) (args (car args/env)) (method-record (cond + [test-method? #f] ((method-contract? (car methods)) (set-method-contract-args! (car methods) args) (set-method-contract-return! (car methods) (make-dynamic-val #f)) @@ -2233,6 +2241,21 @@ (mods (when (method-record? method-record) (method-record-modifiers method-record)))) (cond + [test-method? + (cond + [(equal? name-string "old") + ;SKIPPING CHECKS + (snaps (cons (make-snap (id-string (local-access-name (access-name (car arg-exps)))) + (car args) + (expr-src (car arg-exps))) (snaps))) + (set-call-method-record! call 'test-method-old) + (set-id-string! (local-access-name (access-name (car arg-exps))) + (string-append (id-string (local-access-name (access-name (car arg-exps)))) + "@old")) + (make-type/env (car args) (cadr args/env)) + ] + [(equal? name-string "modifies") '...] + [(equal? name-string "modifiesOnly") '...])] ((method-record? method-record) (when (and static? (not (memq 'static mods)) (not expr)) (non-static-called-error name c-class src level)) @@ -2800,14 +2823,15 @@ env (expr-src exp) type-recs)) - ((check-effect? exp) - (check-test-effect (check-effect-vars exp) - (check-effect-conds exp) - (check-effect-test exp) - check-sub-expr - env - (expr-src exp) - type-recs)) + ((check-inspect? exp) + (check-test-inspect (check-inspect-val exp) + (check-inspect-post exp) + (check-inspect-range exp) + exp + check-sub-expr + env + (expr-src exp) + type-recs)) (else (error 'internal-error (format "Unknown check expression ~a" exp))))) ;check-test-expr: exp exp (U #f exp) (exp env -> type/env) env symbol src src type-records-> type/env @@ -2985,6 +3009,27 @@ (check-mutate-check-error (type/env-t checker-type) (expr-src check))) (make-type/env 'boolean (type/env-e checker-type)))) + ;Parameters for conducting inspection tests + (define inspect-test? (make-parameter #f)) + (define snaps (make-parameter null)) + + ;check-test-inspect: exp exp (U exp #f) exp (exp env -> type/env) env src type-records -> type/env + (define (check-test-inspect val posts range exp check-e env src type-recs) + (let* ([command/te (check-e val env)] + [command-type (type/env-t command/te)] + [env-p (type/env-e command/te)] + ;NOT ACCOUNTING FOR VOID ON RESULT + [env-posts (add-set-to-env + "result" + (add-var-to-env "result" command-type final-method-var env-p))]) + (parameterize ([inspect-test? #t] [snaps null]) + (let ([posts/te (check-e posts env-posts)]) + (set-check-inspect-snaps! exp (snaps)) + (unless (eq? 'boolean (type/env-t posts/te)) + (check-inspect-post-error (type/env-t posts/te) (expr-src posts))) + ;SKIPS RANGE FOR NOW + (make-type/env 'boolean (remove-var-from-env "result" (type/env-e posts/te))))))) + ;check-test-effect: (list access) (list exp) (list exp) (exp env -> type/env) env src type-records -> type/env (define (check-test-effect vars conds test check-e env src type-recs) @@ -3865,6 +3910,15 @@ (format "The expression following -> in a mutation test must return a boolean; found expresstion returning ~a." (type->ext-name type)) '-> src)) + + ;check-inspect-post-error: type src -> void + (define (check-inspect-post-error type src) + (raise-error + 'inspect + (format "The post-conditions for an 'inspect' test must return a boolean; found expression returning ~a." + (type->ext-name type)) + 'check + src)) (define check-location (make-parameter #f)) diff --git a/collects/profj/libs/java/runtime.ss b/collects/profj/libs/java/runtime.ss index 8d97144baa..a57c401a03 100644 --- a/collects/profj/libs/java/runtime.ss +++ b/collects/profj/libs/java/runtime.ss @@ -14,7 +14,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-by - compare-rand check-effect) + compare-rand check-effect check-inspect) (define (check-eq? obj1 obj2) (or (eq? obj1 obj2) @@ -345,6 +345,21 @@ (report-results (cdr checks))))) result-value))) + ;check-inspect: (-> val) (-> bool) info src test-obj -> boolean + (define (check-inspect test check info src test-obj) + (let ((fail? #f)) + (set! test + (with-handlers ([exn? + (lambda (e) + (set! fail? #t) + (list exception #t e "eval"))]) + (test))) + (let ([res (if fail? #f (check test))]) + (if (in-check-mutate?) + (stored-checks (cons (list res 'check-inspect info null src) (stored-checks))) + (report-check-result res 'check-inspect info null src test-obj)) + res))) + ;check-effects: (-> (listof val)) (-> (listof val)) (list string) src object -> boolean (define (check-effect tests checks info src test-obj) (let ([app (lambda (thunk) (thunk))]) @@ -380,6 +395,7 @@ (case check-kind ((check-expect check-by) "to produce ") ((check-rand) "to produce one of ") + ((check-inspect) "to satisfy the post-conditions given ") ((check-catch) "to throw an instance of "))]) (cond [(not (eq? 'check-by check-kind)) diff --git a/collects/profj/parsers/full-parser.ss b/collects/profj/parsers/full-parser.ss index 03e187b8ef..5b14a54d67 100644 --- a/collects/profj/parsers/full-parser.ss +++ b/collects/profj/parsers/full-parser.ss @@ -1036,7 +1036,12 @@ (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)] - [(checkEffect O_PAREN EffectVars SEMI_COLON EffectConds C_PAREN O_BRACE EffectExpression C_BRACE) + [(check ConditionalExpression inspect ConditionalExpression) + (make-check-inspect #f (build-src 4) $2 $4 #f null)] + [(check ConditionalExpression inspect ConditionalExpression within ConditionalExpression) + (make-check-inspect #f (build-src 6) $2 $4 $6 null)] + + #;[(checkEffect O_PAREN EffectVars SEMI_COLON EffectConds C_PAREN O_BRACE EffectExpression C_BRACE) (make-check-effect #f (build-src 9) $3 $5 $8)] ) @@ -1068,13 +1073,13 @@ [(StatementExpression SEMI_COLON) (list $1)] [(StmtExpressionList StatementExpression SEMI_COLON) (cons $2 $1)]) - (MutateExpression + #;(MutateExpression [(CheckExpression) $1] [(CheckExpression -> CheckExpression) (make-check-mutate #f (build-src 3) $1 $3 (build-src 2 2))]) (AssignmentExpression - [#;(ConditionalExpression) #;(CheckExpression) (MutateExpression) $1] + [#;(ConditionalExpression) #;(CheckExpression) (CheckExpression) $1] [(Assignment) $1]) (Assignment diff --git a/collects/profj/parsers/lexer.ss b/collects/profj/parsers/lexer.ss index cf08dda9d6..16713f7a7c 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 checkEffect expect within except oneOf by errorMsg -> ->> ->>> test tests testcase)) + (define-empty-tokens ExtraKeywords (dynamic check inspect expect within except oneOf by errorMsg test tests testcase)) (define-tokens java-vals (STRING_LIT CHAR_LIT INTEGER_LIT LONG_LIT FLOAT_LIT DOUBLE_LIT @@ -252,9 +252,6 @@ ((string=? l "|=") (token-OREQUAL)) (else (string->symbol l))))) - ("->" (string->symbol lexeme)) - ("->>" (string->symbol lexeme)) - ("->>>" (string->symbol lexeme)) ;; 3.11 ("(" (token-O_PAREN)) @@ -318,12 +315,12 @@ ((test-ext?) (string->symbol lexeme)) (else (token-IDENTIFIER lexeme)))) - ((re:or "test" "tests" "testcase" "by" "checkEffect" "except") + ((re:or "test" "tests" "testcase" "by" "except" "inspect") (cond ((testcase-ext?) (string->symbol lexeme)) (else (token-IDENTIFIER lexeme)))) - ((re:: Identifier "@") + #;((re:: Identifier "@") (cond [(testcase-ext?) (token-TEST_IDENTIFIER lexeme)] [else (token-ID_ERROR lexeme)])) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index ec95eed124..a576ab0dd9 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -498,7 +498,7 @@ (append (accesses-public fields) (accesses-package fields) (accesses-protected fields))) (generate-contract-defs (class-name)))) - #;(stm-class (generate-stm-class (class-name) + (stm-class (generate-stm-class (class-name) (parent-name) (class-record-methods class-rec) (class-record-fields class-rec))) @@ -731,7 +731,7 @@ )) ,@wrapper-classes - #;,@(if (testcase-ext?) (list stm-class) null) + ,@(if (testcase-ext?) (list stm-class) null) #;,@(create-generic-methods (append (accesses-public methods) (accesses-package methods) @@ -2583,16 +2583,19 @@ (expression (if expr (translate-expression expr) #f)) (unique-name (gensym)) (translated-args - (if (method-contract? method-record) - (map (lambda (arg type) - (guard-convert-value arg type)) - args arg-types) - (map (lambda (arg type call-type) + (cond + [(method-contract? method-record) + (map (lambda (arg type) + (guard-convert-value arg type)) + args arg-types)] + [(symbol? method-record) null] + [else (map (lambda (arg type call-type) (if (eq? 'dynamic call-type) (guard-convert-value arg type) arg)) - args arg-types (method-record-atypes method-record))))) + args arg-types (method-record-atypes method-record))]))) (cond + [(eq? method-record 'test-method-old) (car args)] ;Constructor case ((special-name? method-name) (let* ((name (if (equal? (special-name-name method-name) "super") @@ -3057,10 +3060,12 @@ ((check-mutate? expr) (translate-check-mutate (check-mutate-mutate expr) (check-mutate-check expr) (expr-src expr))) - ((check-effect? expr) (translate-check-effect (check-effect-vars expr) - (check-effect-conds expr) - (check-effect-test expr) - (expr-src expr))))) + ((check-inspect? expr) (translate-check-inspect (check-inspect-val expr) + (check-inspect-post expr) + (check-inspect-range expr) + (check-inspect-snaps expr) + (expr-src expr))) + )) ;translate-check: expression expression (U expression #f) src -> syntax @@ -3134,6 +3139,37 @@ (lambda () #f))) (build-src src)))) + (define inspect-test? (make-parameter #f)) + + ;IGNORES RANGE + ;IGNORES COLLECTING PRINTING INFORMATION + ;translate-check-inspect: expr expr (U #f expr) (listof snap) src -> syntax + (define (translate-check-inspect val post range snaps src) + (let ([command (create-syntax #f `(lambda () ,(translate-expression val)) #f)] + [post (create-syntax #f `(lambda (result~f) ,(parameterize ([inspect-test? #t]) (translate-expression post))) #f)]) + (make-syntax #f + `(let (,@(apply + append + (map (lambda (snap) + (let* ([name (snap-name snap)] + [id (build-var-name name)] + [type (snap-type snap)]) + `((,(build-identifier (build-var-name (string-append name "@old"))) ,(build-identifier id)) + (,(build-identifier id) + ,(cond + [(or (prim-numeric-type? type) (eq? type 'boolean)) (build-identifier id)] + [else + `(let ([obj@ (make-object + ,(build-identifier + (string-append (ref-type-class/iface type) "-stm")))]) + (send obj@ log ,(build-identifier id)) + obj@)]))))) + snaps))) + (javaRuntime:check-inspect ,command ,post + 'test-info (quote ,(src->list src)) + (namespace-variable-value 'current~test~object% #f (lambda () #f)))) + (build-src src)))) + ;translate-check-effect: (listof access) (listof expression) (listof expression) src -> syntax (define (translate-check-effect ids conds test src) (let ([cs (map (lambda (c) (create-syntax #f `(lambda () ,(translate-expression c)) #f)) conds)]