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)
(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))
;(make-check-catch (U #f type) src Expression type-spec)
@ -310,4 +310,9 @@
;(make-check-mutate (U #f type) src Expression Expression 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))
)

118
collects/profj/check.ss
View File

@ -2794,7 +2794,16 @@
check-sub-expr
env
(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
(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)))])
(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)
(let* ([actual-te (check-e actual env)]
[actual-t (type/env-t actual-te)]
[expt-range-te (check-e expt-range (type/env-e actual-te))]
[er-t (type/env-t expt-range-te)]
[res (make-type/env 'boolean (type/env-e expt-range-te))])
[expt-range-te
(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 (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)
(check-rand-type-error 'void level actual-t er-t (expr-src actual)))
(when (eq? er-t 'void)
(check-rand-type-error 'void level actual-t er-t (expr-src expt-range)))
(when (not (array-type? er-t))
(check-rand-type-error 'not-array level actual-t er-t (expr-src expt-range)))
(let ([er-a-t
(cond
[(eq? (array-type-dim er-t) 1) (array-type-type er-t)]
[else (make-array-type (array-type-type er-t) (sub1 (array-type-dim er-t)))])])
(cond
((and (eq? 'boolean actual-t)
(eq? 'boolean er-a-t)) res)
((and (prim-numeric-type? actual-t)
(prim-numeric-type? er-a-t))
res)
((and (memq level '(advanced full))
(reference-type? actual-t) (reference-type? er-a-t))
(check-rand-type-error 'void level actual-t er-ts (expr-src actual)))
(when (null? er-ts)
(check-rand-type-error 'empty level actual-t src))
(and
(andmap
(lambda (er-t er)
(cond
((castable? er-a-t actual-t type-recs) res)
(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)
[(eq? er-t 'void)
(check-rand-type-error 'void level actual-t er-t (expr-src er))]
[(and (eq? 'boolean actual-t) (eq? 'boolean er-t)) #t]
[(and (prim-numeric-type? actual-t) (prim-numeric-type? er-t)) #t]
[(and (memq level '(advanced full))
(reference-type? actual-t) (reference-type? er-t))
(or (castable? er-t actual-t type-recs)
(check-rand-type-error 'cast level actual-t er-t (expr-src er)))]
[(and (memq level '(advanced full))
(or (array-type? actual-t) (array-type? er-t)))
(or (castable? er-t actual-t type-recs)
(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))))
(else
(check-rand-type-error (if (memq level '(advanced full)) 'cast 'subtype)
level
actual-t er-a-t src))))))
(check-rand-type-error (if (memq level '(advanced full)) 'cast 'subtype)
level
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
@ -2969,6 +2981,34 @@
(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
@ -3729,16 +3769,16 @@
[(and (eq? kind 'void) (eq? actual-type 'void))
"The test of a 'check' expression must produce a value. Current expression does not."]
[(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."]
[(eq? kind 'not-array)
(string-append "The expected result of a 'check' 'within' expression must be an array of possible values.\n"
"Each possible result of a 'check' 'oneOf' expression must be a value. Current expression is not a value."]
[(eq? kind 'empty)
(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)))]
[else
(string-append "A 'check' 'within' expession compares the test expression with an array of possible answers.\n"
(format "Found an array of ~a which is not comparable to ~a."
(string-append "Each possible result of a 'check' 'oneOf' expession must be comparable with the test expression.\n"
(format "Found a ~a which is not comparable to ~a."
(type->ext-name expt-type)
(type->ext-name actual-type)))])
'within src))
'oneOf src))
(define (check-by-==-error t-type a-type src)
(raise-error

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

@ -19,7 +19,7 @@
(define parsers
(parser
(start CompilationUnit Interactions VariableInitializer Type)
;;(debug "parser.output")
#;(debug "parser.output")
(tokens java-vals special-toks Keywords ExtraKeywords Separators EmptyLiterals Operators)
(error (lambda (tok-ok name val start-pos end-pos)
(raise-read-error (format "Parse error near <~a:~a>" name val)
@ -886,6 +886,7 @@
(PostfixExpression
[(Primary) $1]
[(Name) (name->access $1)]
[(TEST_IDENTIFIER) (make-test-id #f (build-src 1) $1)]
[(PostIncrementExpression) $1]
[(PostDecrementExpression) $1])
@ -1027,14 +1028,44 @@
(make-check-expect #f (build-src 4) $2 $4 #f (build-src 2 4))]
[(check ConditionalExpression expect ConditionalExpression within ConditionalExpression)
(make-check-expect #f (build-src 6) $2 $4 $6 (build-src 2 4))]
[(check ConditionalExpression within ConditionalExpression)
(make-check-rand #f (build-src 4) $2 $4 (build-src 2 4))]
[(check ConditionalExpression oneOf O_PAREN ConditionalExpressionList C_PAREN)
(make-check-rand #f (build-src 6) $2 (reverse $5) (build-src 2 6))]
[(check ConditionalExpression catch Type)
(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)])
(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
[(CheckExpression) $1]

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

@ -44,11 +44,12 @@
const for new switch
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
(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))
@ -312,16 +313,21 @@
((dynamic?) (string->symbol lexeme))
(else (token-IDENTIFIER lexeme))))
((re:or "check" "expect" "within")
((re:or "check" "expect" "within" "oneOf" "errorMsg")
(cond
((test-ext?) (string->symbol lexeme))
(else (token-IDENTIFIER lexeme))))
((re:or "test" "tests" "testcase" "by")
((re:or "test" "tests" "testcase" "by" "checkEffect" "except")
(cond
((testcase-ext?) (string->symbol lexeme))
(else (token-IDENTIFIER lexeme))))
((re:: Identifier "@")
(cond
[(testcase-ext?) (token-TEST_IDENTIFIER lexeme)]
[else (token-ID_ERROR lexeme)]))
;; 3.9
(Keyword (string->symbol lexeme))

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

@ -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
#;,stm-class
,@(if (testcase-ext?) (list stm-class) null)
#;,@(create-generic-methods (append (accesses-public methods)
(accesses-package methods)
@ -3029,6 +3029,10 @@
(expr-src expr)))
((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)))))
@ -3103,6 +3107,18 @@
(lambda () #f)))
(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")
;checked-info: expression -> (list sym string...)