suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Turning check ... inspect ... on: step one.

Browse Source 
svn: r14369
This commit is contained in:
Kathy Gray 2009-03-30 22:44:43 +00:00
parent 72e2049f96
commit c733d6c748
6 changed files with 150 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/profj/ast.ss
View File

@ -310,6 +310,12 @@
;(make-check-mutate (U #f type) src Expression Expression src) ;(make-check-mutate (U #f type) src Expression Expression src)
(p-define-struct (check-mutate check) (mutate check op-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))) ;(make-check-effect (U #f type) src (listof access) (listof Expression) (U Expression (listof Expression)))
(p-define-struct (check-effect check) (vars conds test)) (p-define-struct (check-effect check) (vars conds test))

68
collects/profj/check.ss
View File

@ -2047,6 +2047,7 @@
(name-string (when (id? name) (id-string name))) (name-string (when (id? name) (id-string name)))
(expr (call-expr call)) (expr (call-expr call))
(exp-type #f) (exp-type #f)
(test-method? #f)
(handle-call-error (handle-call-error
(lambda (exn) (lambda (exn)
(when (not (access? expr)) (raise exn)) (when (not (access? expr)) (raise exn))
@ -2168,7 +2169,13 @@
((null? rec) null) ((null? rec) null)
(else (get-method-records name-string rec type-recs))))))))))) (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 (let* ((rec (if exp-type
(send type-recs get-class-record exp-type) (send type-recs get-class-record exp-type)
(if static? (send type-recs get-class-record c-class) this))) (if static? (send type-recs get-class-record c-class) this)))
@ -2193,16 +2200,17 @@
(interaction-call-error name src level))) (interaction-call-error name src level)))
(else (else
(no-method-error 'this sub-kind exp-type name src))))))) (no-method-error 'this sub-kind exp-type name src)))))))
(unless test-method?
(unless (method-contract? (car methods)) (unless (method-contract? (car methods))
(when (and (not ctor?) (when (and (not ctor?)
(eq? (method-record-rtype (car methods)) 'ctor)) (eq? (method-record-rtype (car methods)) 'ctor))
(ctor-called-error exp-type name src))) (ctor-called-error exp-type name src))))
(let* ((args/env (check-args arg-exps check-sub env)) (let* ((args/env (check-args arg-exps check-sub env))
(args (car args/env)) (args (car args/env))
(method-record (method-record
(cond (cond
[test-method? #f]
((method-contract? (car methods)) ((method-contract? (car methods))
(set-method-contract-args! (car methods) args) (set-method-contract-args! (car methods) args)
(set-method-contract-return! (car methods) (make-dynamic-val #f)) (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)))) (mods (when (method-record? method-record) (method-record-modifiers method-record))))
(cond (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) ((method-record? method-record)
(when (and static? (not (memq 'static mods)) (not expr)) (when (and static? (not (memq 'static mods)) (not expr))
(non-static-called-error name c-class src level)) (non-static-called-error name c-class src level))
@ -2800,10 +2823,11 @@
env env
(expr-src exp) (expr-src exp)
type-recs)) type-recs))
((check-effect? exp) ((check-inspect? exp)
(check-test-effect (check-effect-vars exp) (check-test-inspect (check-inspect-val exp)
(check-effect-conds exp) (check-inspect-post exp)
(check-effect-test exp) (check-inspect-range exp)
exp
check-sub-expr check-sub-expr
env env
(expr-src exp) (expr-src exp)
@ -2985,6 +3009,27 @@
(check-mutate-check-error (type/env-t checker-type) (expr-src check))) (check-mutate-check-error (type/env-t checker-type) (expr-src check)))
(make-type/env 'boolean (type/env-e checker-type)))) (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 ;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) (define (check-test-effect vars conds test check-e env src type-recs)
@ -3866,6 +3911,15 @@
(type->ext-name type)) (type->ext-name type))
'-> src)) '-> 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)) (define check-location (make-parameter #f))

18
collects/profj/libs/java/runtime.ss
View File

@ -14,7 +14,7 @@
(provide convert-to-string shift not-equal bitwise mod divide-dynamic divide-int (provide convert-to-string shift not-equal bitwise mod divide-dynamic divide-int
divide-float and or cast-primitive cast-reference instanceof-array nullError divide-float and or cast-primitive cast-reference instanceof-array nullError
check-eq? dynamic-equal? compare compare-within check-catch check-mutate check-by 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) (define (check-eq? obj1 obj2)
(or (eq? obj1 obj2) (or (eq? obj1 obj2)
@ -345,6 +345,21 @@
(report-results (cdr checks))))) (report-results (cdr checks)))))
result-value))) 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 ;check-effects: (-> (listof val)) (-> (listof val)) (list string) src object -> boolean
(define (check-effect tests checks info src test-obj) (define (check-effect tests checks info src test-obj)
(let ([app (lambda (thunk) (thunk))]) (let ([app (lambda (thunk) (thunk))])
@ -380,6 +395,7 @@
(case check-kind (case check-kind
((check-expect check-by) "to produce ") ((check-expect check-by) "to produce ")
((check-rand) "to produce one of ") ((check-rand) "to produce one of ")
((check-inspect) "to satisfy the post-conditions given ")
((check-catch) "to throw an instance of "))]) ((check-catch) "to throw an instance of "))])
(cond (cond
[(not (eq? 'check-by check-kind)) [(not (eq? 'check-by check-kind))

11
collects/profj/parsers/full-parser.ss
View File

@ -1036,7 +1036,12 @@
(make-check-by #f (build-src 6) $2 $4 '==)] (make-check-by #f (build-src 6) $2 $4 '==)]
[(check ConditionalExpression expect ConditionalExpression by IDENTIFIER) [(check ConditionalExpression expect ConditionalExpression by IDENTIFIER)
(make-check-by #f (build-src 6) $2 $4 $6)] (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)] (make-check-effect #f (build-src 9) $3 $5 $8)]
) )
@ -1068,13 +1073,13 @@
[(StatementExpression SEMI_COLON) (list $1)] [(StatementExpression SEMI_COLON) (list $1)]
[(StmtExpressionList StatementExpression SEMI_COLON) (cons $2 $1)]) [(StmtExpressionList StatementExpression SEMI_COLON) (cons $2 $1)])
(MutateExpression #;(MutateExpression
[(CheckExpression) $1] [(CheckExpression) $1]
[(CheckExpression -> CheckExpression) [(CheckExpression -> CheckExpression)
(make-check-mutate #f (build-src 3) $1 $3 (build-src 2 2))]) (make-check-mutate #f (build-src 3) $1 $3 (build-src 2 2))])
(AssignmentExpression (AssignmentExpression
[#;(ConditionalExpression) #;(CheckExpression) (MutateExpression) $1] [#;(ConditionalExpression) #;(CheckExpression) (CheckExpression) $1]
[(Assignment) $1]) [(Assignment) $1])
(Assignment (Assignment

9
collects/profj/parsers/lexer.ss
View File

@ -44,7 +44,7 @@
const for new switch const for new switch
continue goto package synchronized)) 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 (define-tokens java-vals
(STRING_LIT CHAR_LIT INTEGER_LIT LONG_LIT FLOAT_LIT DOUBLE_LIT (STRING_LIT CHAR_LIT INTEGER_LIT LONG_LIT FLOAT_LIT DOUBLE_LIT
@ -252,9 +252,6 @@
((string=? l "|=") (token-OREQUAL)) ((string=? l "|=") (token-OREQUAL))
(else (string->symbol l))))) (else (string->symbol l)))))
("->" (string->symbol lexeme))
("->>" (string->symbol lexeme))
("->>>" (string->symbol lexeme))
;; 3.11 ;; 3.11
("(" (token-O_PAREN)) ("(" (token-O_PAREN))
@ -318,12 +315,12 @@
((test-ext?) (string->symbol lexeme)) ((test-ext?) (string->symbol lexeme))
(else (token-IDENTIFIER lexeme)))) (else (token-IDENTIFIER lexeme))))
((re:or "test" "tests" "testcase" "by" "checkEffect" "except") ((re:or "test" "tests" "testcase" "by" "except" "inspect")
(cond (cond
((testcase-ext?) (string->symbol lexeme)) ((testcase-ext?) (string->symbol lexeme))
(else (token-IDENTIFIER lexeme)))) (else (token-IDENTIFIER lexeme))))
((re:: Identifier "@") #;((re:: Identifier "@")
(cond (cond
[(testcase-ext?) (token-TEST_IDENTIFIER lexeme)] [(testcase-ext?) (token-TEST_IDENTIFIER lexeme)]
[else (token-ID_ERROR lexeme)])) [else (token-ID_ERROR lexeme)]))

56
collects/profj/to-scheme.ss
View File

@ -498,7 +498,7 @@
(append (accesses-public fields) (accesses-package fields) (append (accesses-public fields) (accesses-package fields)
(accesses-protected fields))) (accesses-protected fields)))
(generate-contract-defs (class-name)))) (generate-contract-defs (class-name))))
#;(stm-class (generate-stm-class (class-name) (stm-class (generate-stm-class (class-name)
(parent-name) (parent-name)
(class-record-methods class-rec) (class-record-methods class-rec)
(class-record-fields class-rec))) (class-record-fields class-rec)))
@ -731,7 +731,7 @@
)) ))
,@wrapper-classes ,@wrapper-classes
#;,@(if (testcase-ext?) (list stm-class) null) ,@(if (testcase-ext?) (list stm-class) null)
#;,@(create-generic-methods (append (accesses-public methods) #;,@(create-generic-methods (append (accesses-public methods)
(accesses-package methods) (accesses-package methods)
@ -2583,16 +2583,19 @@
(expression (if expr (translate-expression expr) #f)) (expression (if expr (translate-expression expr) #f))
(unique-name (gensym)) (unique-name (gensym))
(translated-args (translated-args
(if (method-contract? method-record) (cond
[(method-contract? method-record)
(map (lambda (arg type) (map (lambda (arg type)
(guard-convert-value arg type)) (guard-convert-value arg type))
args arg-types) args arg-types)]
(map (lambda (arg type call-type) [(symbol? method-record) null]
[else (map (lambda (arg type call-type)
(if (eq? 'dynamic call-type) (if (eq? 'dynamic call-type)
(guard-convert-value arg type) (guard-convert-value arg type)
arg)) arg))
args arg-types (method-record-atypes method-record))))) args arg-types (method-record-atypes method-record))])))
(cond (cond
[(eq? method-record 'test-method-old) (car args)]
;Constructor case ;Constructor case
((special-name? method-name) ((special-name? method-name)
(let* ((name (if (equal? (special-name-name method-name) "super") (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? expr) (translate-check-mutate (check-mutate-mutate expr)
(check-mutate-check expr) (check-mutate-check expr)
(expr-src expr))) (expr-src expr)))
((check-effect? expr) (translate-check-effect (check-effect-vars expr) ((check-inspect? expr) (translate-check-inspect (check-inspect-val expr)
(check-effect-conds expr) (check-inspect-post expr)
(check-effect-test expr) (check-inspect-range expr)
(expr-src expr))))) (check-inspect-snaps expr)
(expr-src expr)))
))
;translate-check: expression expression (U expression #f) src -> syntax ;translate-check: expression expression (U expression #f) src -> syntax
@ -3134,6 +3139,37 @@
(lambda () #f))) (lambda () #f)))
(build-src src)))) (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 ;translate-check-effect: (listof access) (listof expression) (listof expression) src -> syntax
(define (translate-check-effect ids conds test src) (define (translate-check-effect ids conds test src)
(let ([cs (map (lambda (c) (create-syntax #f `(lambda () ,(translate-expression c)) #f)) conds)] (let ([cs (map (lambda (c) (create-syntax #f `(lambda () ,(translate-expression c)) #f)) conds)]