Turning check ... inspect ... on: step one.

svn: r14369

collects/profj/ast.ss

@@ -310,6 +310,12 @@
   ;(make-check-mutate (U #f type) src Expression Expression src)
   (p-define-struct (check-mutate check) (mutate check op-src))
   
+  ;(make-check-inspect (U #f type) src Expression Expression Expression (list snap))
+  (p-define-struct (check-inspect check) (val post range snaps))
+  
+  ;(make-snap string type src)
+  (p-define-struct snap (name type src))
+  
   ;(make-check-effect (U #f type) src (listof access) (listof Expression) (U Expression (listof Expression)))
   (p-define-struct (check-effect check) (vars conds test))
   

collects/profj/check.ss

@@ -2047,6 +2047,7 @@
            (name-string (when (id? name) (id-string name)))
            (expr (call-expr call))
            (exp-type #f)
+           (test-method? #f)
            (handle-call-error 
             (lambda (exn)
               (when (not (access? expr)) (raise exn))
@@ -2168,7 +2169,13 @@
                           ((null? rec) null)
                           (else (get-method-records name-string rec type-recs)))))))))))
       
-      (when (null? methods)
+      (when (and (inspect-test?) (null? methods)
+                 (or (equal? name-string "old")
+                     (equal? name-string "modifies")
+                     (equal? name-string "modifiesOnly")))
+        (set! test-method? #t))
+      
+      (when (and (null? methods) (not test-method?))
         (let* ((rec (if exp-type 
                         (send type-recs get-class-record exp-type)
                         (if static? (send type-recs get-class-record c-class) this)))
@@ -2193,16 +2200,17 @@
                   (interaction-call-error name src level)))
              (else
               (no-method-error 'this sub-kind exp-type name src)))))))
-      
+      (unless test-method?
-      (unless (method-contract? (car methods))
+        (unless (method-contract? (car methods))
-        (when (and (not ctor?)
+          (when (and (not ctor?)
-                   (eq? (method-record-rtype (car methods)) 'ctor))
+                     (eq? (method-record-rtype (car methods)) 'ctor))
-          (ctor-called-error exp-type name src)))
+            (ctor-called-error exp-type name src))))
       
       (let* ((args/env (check-args arg-exps check-sub env))
              (args (car args/env))
              (method-record
               (cond
+                [test-method? #f]
                 ((method-contract? (car methods))
                  (set-method-contract-args! (car methods) args)
                  (set-method-contract-return! (car methods) (make-dynamic-val #f))
@@ -2233,6 +2241,21 @@
              (mods (when (method-record? method-record) (method-record-modifiers method-record))))
         
         (cond 
+          [test-method?
+           (cond
+             [(equal? name-string "old") 
+              ;SKIPPING CHECKS
+              (snaps (cons (make-snap (id-string (local-access-name (access-name (car arg-exps))))
+                                      (car args)
+                                      (expr-src (car arg-exps))) (snaps)))
+              (set-call-method-record! call 'test-method-old)
+              (set-id-string! (local-access-name (access-name (car arg-exps)))
+                              (string-append (id-string (local-access-name (access-name (car arg-exps))))
+                                             "@old"))
+              (make-type/env (car args) (cadr args/env))
+              ]
+             [(equal? name-string "modifies") '...]
+             [(equal? name-string "modifiesOnly") '...])]
           ((method-record? method-record)        
            (when (and static? (not (memq 'static mods)) (not expr))
              (non-static-called-error name c-class src level))
@@ -2800,14 +2823,15 @@
                           env
                           (expr-src exp)
                           type-recs))
-      ((check-effect? exp)
+      ((check-inspect? exp)
-       (check-test-effect (check-effect-vars exp)
+       (check-test-inspect (check-inspect-val exp)
-                          (check-effect-conds exp)
+                           (check-inspect-post exp)
-                          (check-effect-test exp)
+                           (check-inspect-range exp)
-                          check-sub-expr
+                           exp
-                          env
+                           check-sub-expr
-                          (expr-src exp)
+                           env
-                          type-recs))
+                           (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
@@ -2985,6 +3009,27 @@
         (check-mutate-check-error (type/env-t checker-type) (expr-src check)))
       (make-type/env 'boolean (type/env-e checker-type))))
   
+  ;Parameters for conducting inspection tests
+  (define inspect-test? (make-parameter #f))
+  (define snaps (make-parameter null))
+  
+  ;check-test-inspect: exp exp (U exp #f) exp (exp env -> type/env) env src type-records -> type/env
+  (define (check-test-inspect val posts range exp check-e env src type-recs)
+    (let* ([command/te (check-e val env)]
+           [command-type (type/env-t command/te)]
+           [env-p (type/env-e command/te)]
+           ;NOT ACCOUNTING FOR VOID ON RESULT
+           [env-posts (add-set-to-env 
+                       "result"
+                       (add-var-to-env "result" command-type final-method-var env-p))])
+      (parameterize ([inspect-test? #t] [snaps null])
+        (let ([posts/te (check-e posts env-posts)])
+          (set-check-inspect-snaps! exp (snaps))
+          (unless (eq? 'boolean (type/env-t posts/te))
+            (check-inspect-post-error (type/env-t posts/te) (expr-src posts)))
+          ;SKIPS RANGE FOR NOW
+          (make-type/env 'boolean (remove-var-from-env "result" (type/env-e posts/te)))))))
+      
     
   ;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)
@@ -3866,6 +3911,15 @@
              (type->ext-name type))
      '-> src))
   
+  ;check-inspect-post-error: type src -> void
+  (define (check-inspect-post-error type src)
+    (raise-error
+     'inspect
+     (format "The post-conditions for an 'inspect' test must return a boolean; found expression returning ~a."
+             (type->ext-name type))
+     'check
+     src))
+
   
   (define check-location (make-parameter #f))
   

collects/profj/libs/java/runtime.ss

@@ -14,7 +14,7 @@
   (provide convert-to-string shift not-equal bitwise mod divide-dynamic divide-int 
            divide-float and or cast-primitive cast-reference instanceof-array nullError
            check-eq? dynamic-equal? compare compare-within check-catch check-mutate check-by
-           compare-rand check-effect)
+           compare-rand check-effect check-inspect)
 
   (define (check-eq? obj1 obj2)
     (or (eq? obj1 obj2)
@@ -345,6 +345,21 @@
               (report-results (cdr checks)))))
         result-value)))
   
+  ;check-inspect: (-> val) (-> bool) info src test-obj -> boolean
+  (define (check-inspect test check info src test-obj)
+    (let ((fail? #f))
+      (set! test 
+            (with-handlers ([exn? 
+                             (lambda (e) 
+                               (set! fail? #t)
+                               (list exception #t e "eval"))])
+              (test)))
+      (let ([res (if fail? #f (check test))])
+        (if (in-check-mutate?)
+            (stored-checks (cons (list res 'check-inspect info null src) (stored-checks)))
+            (report-check-result res 'check-inspect info null src test-obj))
+        res)))
+  
   ;check-effects: (-> (listof val)) (-> (listof val)) (list string) src object -> boolean
   (define (check-effect tests checks info src test-obj)
     (let ([app (lambda (thunk) (thunk))])
@@ -380,6 +395,7 @@
               (case check-kind
                 ((check-expect check-by) "to produce ")
                 ((check-rand) "to produce one of ")
+                ((check-inspect) "to satisfy the post-conditions given ")
                 ((check-catch) "to throw an instance of "))])
       (cond 
         [(not (eq? 'check-by check-kind))

collects/profj/parsers/full-parser.ss

@@ -1036,7 +1036,12 @@
         (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)]
-       [(checkEffect O_PAREN EffectVars SEMI_COLON EffectConds C_PAREN O_BRACE EffectExpression C_BRACE)
+       [(check ConditionalExpression inspect ConditionalExpression)
+        (make-check-inspect #f (build-src 4) $2 $4 #f null)]
+       [(check ConditionalExpression inspect ConditionalExpression within ConditionalExpression)
+        (make-check-inspect #f (build-src 6) $2 $4 $6 null)]
+       
+       #;[(checkEffect O_PAREN EffectVars SEMI_COLON EffectConds C_PAREN O_BRACE EffectExpression C_BRACE)
         (make-check-effect #f (build-src 9) $3 $5 $8)]
        )
       
@@ -1068,13 +1073,13 @@
        [(StatementExpression SEMI_COLON) (list $1)]
        [(StmtExpressionList StatementExpression SEMI_COLON) (cons $2 $1)])       
        
-      (MutateExpression
+      #;(MutateExpression
        [(CheckExpression) $1]
        [(CheckExpression -> CheckExpression) 
         (make-check-mutate #f (build-src 3) $1 $3 (build-src 2 2))])
       
       (AssignmentExpression
-       [#;(ConditionalExpression) #;(CheckExpression) (MutateExpression) $1]
+       [#;(ConditionalExpression) #;(CheckExpression) (CheckExpression) $1]
        [(Assignment) $1])
       
       (Assignment

collects/profj/parsers/lexer.ss

@@ -44,7 +44,7 @@
                                     const       for        new           switch
                                     continue    goto       package       synchronized))
   
-  (define-empty-tokens ExtraKeywords (dynamic check checkEffect expect within except oneOf by errorMsg -> ->> ->>> test tests testcase))
+  (define-empty-tokens ExtraKeywords (dynamic check inspect 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 
@@ -252,9 +252,6 @@
                    ((string=? l "|=") (token-OREQUAL))
                    (else (string->symbol l)))))
 
-     ("->" (string->symbol lexeme))
-     ("->>" (string->symbol lexeme))
-     ("->>>" (string->symbol lexeme))
      
      ;; 3.11
      ("(" (token-O_PAREN))
@@ -318,12 +315,12 @@
         ((test-ext?) (string->symbol lexeme))
         (else (token-IDENTIFIER lexeme))))
      
-     ((re:or "test" "tests" "testcase" "by" "checkEffect" "except")
+     ((re:or "test" "tests" "testcase" "by" "except" "inspect")
       (cond
         ((testcase-ext?) (string->symbol lexeme))
         (else (token-IDENTIFIER lexeme))))
      
-     ((re:: Identifier "@")
+     #;((re:: Identifier "@")
       (cond
         [(testcase-ext?) (token-TEST_IDENTIFIER lexeme)]
         [else (token-ID_ERROR lexeme)]))

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
-                          #;,@(if (testcase-ext?) (list stm-class) null)
+                          ,@(if (testcase-ext?) (list stm-class) null)
                           
                           #;,@(create-generic-methods (append (accesses-public methods)
                                                             (accesses-package methods)
@@ -2583,16 +2583,19 @@
           (expression (if expr (translate-expression expr) #f))
           (unique-name (gensym))
           (translated-args 
-           (if (method-contract? method-record)
+           (cond 
-               (map (lambda (arg type)
+             [(method-contract? method-record)
-                      (guard-convert-value arg type))
+              (map (lambda (arg type)
-                    args arg-types)
+                     (guard-convert-value arg type))
-               (map (lambda (arg type call-type)
+                   args arg-types)]
+             [(symbol? method-record) null]
+             [else (map (lambda (arg type call-type)
                       (if (eq? 'dynamic call-type)
                           (guard-convert-value arg type)
                           arg))
-                    args arg-types (method-record-atypes method-record)))))
+                    args arg-types (method-record-atypes method-record))])))
       (cond
+        [(eq? method-record 'test-method-old) (car args)]
         ;Constructor case
         ((special-name? method-name)
          (let* ((name (if (equal? (special-name-name method-name) "super")
@@ -3057,10 +3060,12 @@
       ((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-inspect? expr) (translate-check-inspect (check-inspect-val expr)
-                                                    (check-effect-conds expr)
+                                                      (check-inspect-post expr)
-                                                    (check-effect-test expr)
+                                                      (check-inspect-range expr)
-                                                    (expr-src expr)))))
+                                                      (check-inspect-snaps expr)
+                                                      (expr-src expr)))
+      ))
 
   
   ;translate-check: expression expression (U expression #f) src -> syntax
@@ -3134,6 +3139,37 @@
                                                                         (lambda () #f)))
                    (build-src src))))
   
+  (define inspect-test? (make-parameter #f))
+  
+  ;IGNORES RANGE
+  ;IGNORES COLLECTING PRINTING INFORMATION
+  ;translate-check-inspect: expr expr (U #f expr) (listof snap) src -> syntax
+  (define (translate-check-inspect val post range snaps src)
+    (let ([command (create-syntax #f `(lambda () ,(translate-expression val)) #f)]
+          [post (create-syntax #f `(lambda (result~f) ,(parameterize ([inspect-test? #t]) (translate-expression post))) #f)])
+      (make-syntax #f
+                   `(let (,@(apply
+                             append
+                             (map (lambda (snap)
+                                    (let* ([name (snap-name snap)]
+                                           [id (build-var-name name)]
+                                           [type (snap-type snap)])
+                                      `((,(build-identifier (build-var-name (string-append name "@old"))) ,(build-identifier id))
+                                        (,(build-identifier id)
+                                         ,(cond
+                                            [(or (prim-numeric-type? type) (eq? type 'boolean)) (build-identifier id)]
+                                            [else 
+                                             `(let ([obj@ (make-object 
+                                                              ,(build-identifier 
+                                                                (string-append (ref-type-class/iface type) "-stm")))])
+                                                (send obj@ log ,(build-identifier id))
+                                                obj@)])))))
+                                  snaps)))
+                      (javaRuntime:check-inspect ,command ,post 
+                                                 'test-info (quote ,(src->list src))
+                                                 (namespace-variable-value 'current~test~object% #f (lambda () #f))))
+                   (build-src src))))
+  
   ;translate-check-effect: (listof access) (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)]