diff --git a/collects/profj/ast.ss b/collects/profj/ast.ss index 3f6f7a7ba6..2eadabde68 100644 --- a/collects/profj/ast.ss +++ b/collects/profj/ast.ss @@ -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)) ) diff --git a/collects/profj/check.ss b/collects/profj/check.ss index 37961e86b8..baacb472f4 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -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,32 +2986,55 @@ (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) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/profj/parsers/full-parser.ss b/collects/profj/parsers/full-parser.ss index 55731caed9..3988dd10fa 100644 --- a/collects/profj/parsers/full-parser.ss +++ b/collects/profj/parsers/full-parser.ss @@ -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] diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index 3df8bf9cd6..c7bb53ddce 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -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))))