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

Turning on stm; supporting checkEffect form.

Browse Source 
svn: r10449
This commit is contained in:
Kathy Gray 2008-06-25 12:47:45 +00:00
parent 15eb016e25
commit 00615e98aa
5 changed files with 148 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/profj/ast.ss
View File

@ -298,7 +298,7 @@
;(make-check-expect (U #f type) src Expression Expression (U #f Expression) src) ;(make-check-expect (U #f type) src Expression Expression (U #f Expression) src)
(p-define-struct (check-expect check) (test actual range ta-src)) (p-define-struct (check-expect check) (test actual range ta-src))
;(make-check-rand (U #f type) src Expression Expression src) ;(make-check-rand (U #f type) src Expression (listof Expression) src)
(p-define-struct (check-rand check) (test range ta-src)) (p-define-struct (check-rand check) (test range ta-src))
;(make-check-catch (U #f type) src Expression type-spec) ;(make-check-catch (U #f type) src Expression type-spec)
@ -310,4 +310,9 @@
;(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-effect (U #f type) src (listof id) (listof Expression) (U Expression (listof Expression)))
(p-define-struct (check-effect check) (vars conds test))
(p-define-struct (test-id expr) (id))
) )

114
collects/profj/check.ss
View File

@ -2794,7 +2794,16 @@
check-sub-expr check-sub-expr
env env
(expr-src exp) (expr-src exp)
type-recs)))) 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))
(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 ;check-test-expr: exp exp (U #f exp) (exp env -> type/env) env symbol src src type-records-> type/env
(define (check-test-expect test actual range check-e env level ta-src src type-recs) (define (check-test-expect test actual range check-e env level ta-src src type-recs)
@ -2914,44 +2923,47 @@
(set-check-by-compare! exp meth)))]) (set-check-by-compare! exp meth)))])
(make-type/env 'boolean new-env)))]))) (make-type/env 'boolean new-env)))])))
;check-test-rand: exp exp (exp env -> type/env) env symbol src type-records -> type/env ;check-test-rand: exp [listof exp] (exp env -> type/env) env symbol src type-records -> type/env
(define (check-test-rand actual expt-range check-e env level src type-recs) (define (check-test-rand actual expt-range check-e env level src type-recs)
(let* ([actual-te (check-e actual env)] (let* ([actual-te (check-e actual env)]
[actual-t (type/env-t actual-te)] [actual-t (type/env-t actual-te)]
[expt-range-te (check-e expt-range (type/env-e actual-te))] [expt-range-te
[er-t (type/env-t expt-range-te)] (foldr (lambda (e acc)
[res (make-type/env 'boolean (type/env-e expt-range-te))]) (let* ([env (car acc)]
[curr (check-e e env)])
(cons (type/env-e curr)
(cons (type/env-t curr) (cdr acc)))))
(list (type/env-e actual-t))
expt-range)
#;(check-e expt-range (type/env-e actual-te))]
[er-ts (cdr expt-range-te)]
[res (make-type/env 'boolean (car expt-range-te))])
(when (eq? actual-t 'void) (when (eq? actual-t 'void)
(check-rand-type-error 'void level actual-t er-t (expr-src actual))) (check-rand-type-error 'void level actual-t er-ts (expr-src actual)))
(when (eq? er-t 'void) (when (null? er-ts)
(check-rand-type-error 'void level actual-t er-t (expr-src expt-range))) (check-rand-type-error 'empty level actual-t src))
(when (not (array-type? er-t))
(check-rand-type-error 'not-array level actual-t er-t (expr-src expt-range))) (and
(let ([er-a-t (andmap
(lambda (er-t er)
(cond (cond
[(eq? (array-type-dim er-t) 1) (array-type-type er-t)] [(eq? er-t 'void)
[else (make-array-type (array-type-type er-t) (sub1 (array-type-dim er-t)))])]) (check-rand-type-error 'void level actual-t er-t (expr-src er))]
(cond [(and (eq? 'boolean actual-t) (eq? 'boolean er-t)) #t]
((and (eq? 'boolean actual-t) [(and (prim-numeric-type? actual-t) (prim-numeric-type? er-t)) #t]
(eq? 'boolean er-a-t)) res) [(and (memq level '(advanced full))
((and (prim-numeric-type? actual-t) (reference-type? actual-t) (reference-type? er-t))
(prim-numeric-type? er-a-t)) (or (castable? er-t actual-t type-recs)
res) (check-rand-type-error 'cast level actual-t er-t (expr-src er)))]
((and (memq level '(advanced full)) [(and (memq level '(advanced full))
(reference-type? actual-t) (reference-type? er-a-t)) (or (array-type? actual-t) (array-type? er-t)))
(cond (or (castable? er-t actual-t type-recs)
((castable? er-a-t actual-t type-recs) res) (check-rand-type-error 'cast level actual-t er-t (expr-src er)))]
(else (check-rand-type-error 'cast level actual-t er-a-t src))))
((and (memq level '(advanced full))
(or (array-type? actual-t) (array-type? er-a-t)))
(cond
((castable? er-a-t actual-t type-recs) res)
(else
(check-rand-type-error 'cast level actual-t er-a-t src))))
(else (else
(check-rand-type-error (if (memq level '(advanced full)) 'cast 'subtype) (check-rand-type-error (if (memq level '(advanced full)) 'cast 'subtype)
level level
actual-t er-a-t src)))))) actual-t er-t (expr-src er))))) er-ts expt-range)
res)))
;check-test-mutate: exp exp (exp env -> type/env) env src type-records -> type/env ;check-test-mutate: exp exp (exp env -> type/env) env src type-records -> type/env
@ -2969,6 +2981,34 @@
(make-type/env 'boolean (type/env-e checker-type)))) (make-type/env 'boolean (type/env-e checker-type))))
;check-test-effect: (list id) (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)
(let ([unbound-vars (filter (lambda (v) (not (lookup-var-in-env (id-string v) env))) vars)])
(unless (null? unbound-vars)
(check-test-effect-error 'unbound-vars unbound-vars))
(let ([t-ts/e
(foldr (lambda (e acc)
(let* ([env (car acc)]
[curr (check-e e env)])
(cons (type/env-e curr)
(cons (type/env-t curr) (cdr acc)))))
(list env)
test)])
(let ([c-ts/e
(foldr (lambda (e acc)
(let* ([env (car acc)]
[curr (check-e e env)])
(cons (type/env-e curr)
(cons (type/env-t curr) (cdr acc)))))
(list (car t-ts/e))
conds)])
(unless (andmap (lambda (te) (eq? 'boolean te)) (cdr c-ts/e))
(check-test-effect-error 'bad-cond-type))
(make-type/env 'boolean (car c-ts/e))))))
(define check-test-effect-error error)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Expression Errors ;;Expression Errors
@ -3729,16 +3769,16 @@
[(and (eq? kind 'void) (eq? actual-type 'void)) [(and (eq? kind 'void) (eq? actual-type 'void))
"The test of a 'check' expression must produce a value. Current expression does not."] "The test of a 'check' expression must produce a value. Current expression does not."]
[(and (eq? kind 'void) (eq? expt-type 'void)) [(and (eq? kind 'void) (eq? expt-type 'void))
"The expected result of a 'check' 'within' expression must be an array of values. Current expression is not a value."] "Each possible result of a 'check' 'oneOf' expression must be a value. Current expression is not a value."]
[(eq? kind 'not-array) [(eq? kind 'empty)
(string-append "The expected result of a 'check' 'within' expression must be an array of possible values.\n" (string-append "The expected result of a 'check' 'oneOf' expression must be a list of possible values.\n"
(format "Found ~a, which is not appropriate in this expression." (type->ext-name expt-type)))] (format "Found ~a, which is not appropriate in this expression." (type->ext-name expt-type)))]
[else [else
(string-append "A 'check' 'within' expession compares the test expression with an array of possible answers.\n" (string-append "Each possible result of a 'check' 'oneOf' expession must be comparable with the test expression.\n"
(format "Found an array of ~a which is not comparable to ~a." (format "Found a ~a which is not comparable to ~a."
(type->ext-name expt-type) (type->ext-name expt-type)
(type->ext-name actual-type)))]) (type->ext-name actual-type)))])
'within src)) 'oneOf src))
(define (check-by-==-error t-type a-type src) (define (check-by-==-error t-type a-type src)
(raise-error (raise-error

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

@ -19,7 +19,7 @@
(define parsers (define parsers
(parser (parser
(start CompilationUnit Interactions VariableInitializer Type) (start CompilationUnit Interactions VariableInitializer Type)
;;(debug "parser.output") #;(debug "parser.output")
(tokens java-vals special-toks Keywords ExtraKeywords Separators EmptyLiterals Operators) (tokens java-vals special-toks Keywords ExtraKeywords Separators EmptyLiterals Operators)
(error (lambda (tok-ok name val start-pos end-pos) (error (lambda (tok-ok name val start-pos end-pos)
(raise-read-error (format "Parse error near <~a:~a>" name val) (raise-read-error (format "Parse error near <~a:~a>" name val)
@ -886,6 +886,7 @@
(PostfixExpression (PostfixExpression
[(Primary) $1] [(Primary) $1]
[(Name) (name->access $1)] [(Name) (name->access $1)]
[(TEST_IDENTIFIER) (make-test-id #f (build-src 1) $1)]
[(PostIncrementExpression) $1] [(PostIncrementExpression) $1]
[(PostDecrementExpression) $1]) [(PostDecrementExpression) $1])
@ -1027,14 +1028,44 @@
(make-check-expect #f (build-src 4) $2 $4 #f (build-src 2 4))] (make-check-expect #f (build-src 4) $2 $4 #f (build-src 2 4))]
[(check ConditionalExpression expect ConditionalExpression within ConditionalExpression) [(check ConditionalExpression expect ConditionalExpression within ConditionalExpression)
(make-check-expect #f (build-src 6) $2 $4 $6 (build-src 2 4))] (make-check-expect #f (build-src 6) $2 $4 $6 (build-src 2 4))]
[(check ConditionalExpression within ConditionalExpression) [(check ConditionalExpression oneOf O_PAREN ConditionalExpressionList C_PAREN)
(make-check-rand #f (build-src 4) $2 $4 (build-src 2 4))] (make-check-rand #f (build-src 6) $2 (reverse $5) (build-src 2 6))]
[(check ConditionalExpression catch Type) [(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 ==) [(check ConditionalExpression expect ConditionalExpression by ==)
(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)
(make-check-effect #f (build-src 9) $3 $5 $8)]
)
(ConditionalExpressionList
((ConditionalExpression) (list $1))
((ConditionalExpressionList COMMA ConditionalExpression) (cons $3 $1)))
(EffectVars
[() null]
[(IDENTIFIER) (list (make-id $1 (build-src 1)))]
[(EffectVars COMMA IDENTIFIER) (cons (make-id $3 (build-src 3 3)) $1)])
(EffectConds
[() null]
[(EffectCond) (list $1)]
[(EffectConds COMMA EffectCond) (cons $3 $1)])
(EffectCond
[(ConditionalExpression except ConditionalExpression)
'condition-expression]
[(ConditionalExpression) $1])
(EffectExpression
[(Expression) $1]
[(StmtExpressionList) $1])
(StmtExpressionList
[(StatementExpression SEMI_COLON) (list $1)]
[(StmtExpressionList StatementExpression SEMI_COLON) (cons $2 $1)])
(MutateExpression (MutateExpression
[(CheckExpression) $1] [(CheckExpression) $1]

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

@ -44,11 +44,12 @@
const for new switch const for new switch
continue goto package synchronized)) continue goto package synchronized))
(define-empty-tokens ExtraKeywords (dynamic check expect within by -> ->> ->>> test tests testcase)) (define-empty-tokens ExtraKeywords (dynamic check checkEffect 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
IDENTIFIER STRING_ERROR NUMBER_ERROR HEX_LIT OCT_LIT HEXL_LIT OCTL_LIT)) IDENTIFIER STRING_ERROR NUMBER_ERROR HEX_LIT OCT_LIT HEXL_LIT OCTL_LIT
TEST_IDENTIFIER ID_ERROR))
(define-tokens special-toks (EXAMPLE TEST_SUITE IMAGE_SPECIAL OTHER_SPECIAL)) (define-tokens special-toks (EXAMPLE TEST_SUITE IMAGE_SPECIAL OTHER_SPECIAL))
@ -312,16 +313,21 @@
((dynamic?) (string->symbol lexeme)) ((dynamic?) (string->symbol lexeme))
(else (token-IDENTIFIER lexeme)))) (else (token-IDENTIFIER lexeme))))
((re:or "check" "expect" "within") ((re:or "check" "expect" "within" "oneOf" "errorMsg")
(cond (cond
((test-ext?) (string->symbol lexeme)) ((test-ext?) (string->symbol lexeme))
(else (token-IDENTIFIER lexeme)))) (else (token-IDENTIFIER lexeme))))
((re:or "test" "tests" "testcase" "by") ((re:or "test" "tests" "testcase" "by" "checkEffect" "except")
(cond (cond
((testcase-ext?) (string->symbol lexeme)) ((testcase-ext?) (string->symbol lexeme))
(else (token-IDENTIFIER lexeme)))) (else (token-IDENTIFIER lexeme))))
((re:: Identifier "@")
(cond
[(testcase-ext?) (token-TEST_IDENTIFIER lexeme)]
[else (token-ID_ERROR lexeme)]))
;; 3.9 ;; 3.9
(Keyword (string->symbol lexeme)) (Keyword (string->symbol lexeme))

20
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
#;,stm-class ,@(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)
@ -3029,6 +3029,10 @@
(expr-src expr))) (expr-src expr)))
((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)))
((check-effect? expr) (translate-check-effect (check-effect-vars expr)
(check-effect-conds expr)
(check-effect-test expr)
(expr-src expr))))) (expr-src expr)))))
@ -3103,6 +3107,18 @@
(lambda () #f))) (lambda () #f)))
(build-src src)))) (build-src src))))
;translate-check-effect: (listof id) (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)]
[ts (map (lambda (t) (create-syntax #f `(lambda () ,(translate-expression t)) #f)) test)])
(make-syntax #f
`(let (,@(map (lambda (id)
`(,(string->symbol (format "~a@" id)) ,id))
(map id-string ids)))
,@(map (lambda (t) `(,t)) ts)
,@(map (lambda (c) `(,c)) cs))
(build-src src))))
(require "error-messaging.ss") (require "error-messaging.ss")
;checked-info: expression -> (list sym string...) ;checked-info: expression -> (list sym string...)