From 00615e98aa0180ee64691696214bd84b0126d237 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Wed, 25 Jun 2008 12:47:45 +0000 Subject: [PATCH] Turning on stm; supporting checkEffect form. svn: r10449 --- collects/profj/ast.ss | 7 +- collects/profj/check.ss | 118 +++++++++++++++++--------- collects/profj/parsers/full-parser.ss | 39 ++++++++- collects/profj/parsers/lexer.ss | 14 ++- collects/profj/to-scheme.ss | 20 ++++- 5 files changed, 148 insertions(+), 50 deletions(-) diff --git a/collects/profj/ast.ss b/collects/profj/ast.ss index 6778a7c89a..3f6f7a7ba6 100644 --- a/collects/profj/ast.ss +++ b/collects/profj/ast.ss @@ -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)) + ) diff --git a/collects/profj/check.ss b/collects/profj/check.ss index f95e402343..37961e86b8 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -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 diff --git a/collects/profj/parsers/full-parser.ss b/collects/profj/parsers/full-parser.ss index 4b0fba2263..55731caed9 100644 --- a/collects/profj/parsers/full-parser.ss +++ b/collects/profj/parsers/full-parser.ss @@ -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] diff --git a/collects/profj/parsers/lexer.ss b/collects/profj/parsers/lexer.ss index 9e9f4108c1..cf08dda9d6 100644 --- a/collects/profj/parsers/lexer.ss +++ b/collects/profj/parsers/lexer.ss @@ -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)) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index 1e12dcd7c7..3df8bf9cd6 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -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...)