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

checkEffect support

Browse Source 
svn: r10560
This commit is contained in:
Kathy Gray 2008-07-02 16:57:57 +00:00
parent 17cd54a1ad
commit af6f4f561b
4 changed files with 61 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/profj/ast.ss
View File

@ -310,9 +310,10 @@
;(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)))
;(make-check-effect (U #f type) src (listof access) (listof Expression) (U Expression (listof Expression)))
(p-define-struct (check-effect check) (vars conds test))
;(make-test-id (U #f type) src string)
(p-define-struct (test-id expr) (id))
)

76
collects/profj/check.ss
View File

@ -37,7 +37,7 @@
;;Environment variable properties
;;(make-properties bool bool bool bool bool bool)
(define-struct properties (parm? field? static? settable? final? usable? set?) #:transparent #:mutable)
(define-struct properties (parm? field? static? settable? final? usable? (set? #:mutable)) #:transparent)
(define parm (make-properties #t #f #f #t #f #t #t))
(define final-parm (make-properties #t #f #f #f #t #t #t))
(define method-var (make-properties #f #f #f #t #f #t #f))
@ -1562,6 +1562,11 @@
(check-test-exprs exp
check-sub-expr
env level type-recs)))
((test-id? exp)
(set-expr-type exp
(check-test-var (test-id-id exp)
(expr-src exp)
env)))
)))
;;check-bin-op: symbol exp exp (exp env -> type/env) env src-loc symbol type-records -> type/env
@ -2981,31 +2986,54 @@
(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
;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)
(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))))))
(for-each (lambda (id)
(with-handlers ((exn? (lambda (e) (effect-vars-error (local-access-name (access-name id))
(expr-src id)))))
(check-e id env))) 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)]
[conds-env
(let loop ([test-vars vars] [env (car t-ts/e)])
(cond
[(null? test-vars) env]
[else
(loop
(cdr test-vars)
(add-var-to-env (string-append (id-string (local-access-name (access-name (car vars)))) "@")
(expr-types (car test-vars))
final-parm
env))]))]
[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 conds-env)
conds)])
(unless (andmap (lambda (te) (eq? 'boolean te)) (cdr c-ts/e))
(check-test-effect-error 'bad-cond-type))
(make-type/env 'boolean (unnest-var env (car c-ts/e)))))
(define (check-test-var id src env)
(let ([t (lookup-var-in-env id env)])
(unless t (check-test-effect-error 'test-var))
(make-type/env (var-type-type t) env)))
(define (effect-vars-error id src)
(let ([var (id->ext-name id)])
(raise-error
var
(format "Effect variables in 'checkEffect' must be previously defined. ~a is undefined." var)
'checkEffect src)))
(define check-test-effect-error error)

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

@ -1046,8 +1046,9 @@
(EffectVars
[() null]
[(IDENTIFIER) (list (make-id $1 (build-src 1)))]
[(EffectVars COMMA IDENTIFIER) (cons (make-id $3 (build-src 3 3)) $1)])
[(IDENTIFIER) (list (make-access #f (build-src 1) (make-local-access (make-id $1 (build-src 1)))))]
[(EffectVars COMMA IDENTIFIER)
(cons (make-access #f (build-src 3 3) (make-local-access (make-id $3 (build-src 3 3)))) $1)])
(EffectConds
[() null]

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

@ -2310,6 +2310,7 @@
(assignment-key-src expr)
(expr-src expr)))
((check? expr) (translate-check expr))
((test-id? expr) (translate-id (test-id-id expr) (expr-src expr)))
(else
(error 'translate-expression (format "Translate Expression given unrecognized expression ~s" expr)))))
@ -3113,8 +3114,9 @@
[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)))
`(,(string->symbol (format "~a@" id)) ,(build-identifier (build-var-name id))))
(map (apply compose (list id-string local-access-name access-name))
ids)))
,@(map (lambda (t) `(,t)) ts)
,@(map (lambda (c) `(,c)) cs))
(build-src src))))