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) ;(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))) ;(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))
;(make-test-id (U #f type) src string)
(p-define-struct (test-id expr) (id)) (p-define-struct (test-id expr) (id))
) )

76
collects/profj/check.ss
View File

@ -37,7 +37,7 @@
;;Environment variable properties ;;Environment variable properties
;;(make-properties bool bool bool bool bool bool) ;;(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 parm (make-properties #t #f #f #t #f #t #t))
(define final-parm (make-properties #t #f #f #f #t #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)) (define method-var (make-properties #f #f #f #t #f #t #f))
@ -1562,6 +1562,11 @@
(check-test-exprs exp (check-test-exprs exp
check-sub-expr check-sub-expr
env level type-recs))) 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 ;;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)))) (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) (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)]) (for-each (lambda (id)
(unless (null? unbound-vars) (with-handlers ((exn? (lambda (e) (effect-vars-error (local-access-name (access-name id))
(check-test-effect-error 'unbound-vars unbound-vars)) (expr-src id)))))
(let ([t-ts/e (check-e id env))) vars)
(foldr (lambda (e acc) (let* ([t-ts/e
(let* ([env (car acc)] (foldr (lambda (e acc)
[curr (check-e e env)]) (let* ([env (car acc)]
(cons (type/env-e curr) [curr (check-e e env)])
(cons (type/env-t curr) (cdr acc))))) (cons (type/env-e curr)
(list env) (cons (type/env-t curr) (cdr acc)))))
test)]) (list env)
(let ([c-ts/e test)]
(foldr (lambda (e acc) [conds-env
(let* ([env (car acc)] (let loop ([test-vars vars] [env (car t-ts/e)])
[curr (check-e e env)]) (cond
(cons (type/env-e curr) [(null? test-vars) env]
(cons (type/env-t curr) (cdr acc))))) [else
(list (car t-ts/e)) (loop
conds)]) (cdr test-vars)
(unless (andmap (lambda (te) (eq? 'boolean te)) (cdr c-ts/e)) (add-var-to-env (string-append (id-string (local-access-name (access-name (car vars)))) "@")
(check-test-effect-error 'bad-cond-type)) (expr-types (car test-vars))
(make-type/env 'boolean (car c-ts/e)))))) 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) (define check-test-effect-error error)

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

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

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

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