From dfafe3c2c125fe8351c69268fe2eea4e4472508c Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Thu, 9 Nov 2006 10:19:02 +0000 Subject: [PATCH] svn: r4812 --- collects/tests/profj/profj-testing.ss | 258 -------------------------- 1 file changed, 258 deletions(-) delete mode 100644 collects/tests/profj/profj-testing.ss diff --git a/collects/tests/profj/profj-testing.ss b/collects/tests/profj/profj-testing.ss deleted file mode 100644 index c32a7439af..0000000000 --- a/collects/tests/profj/profj-testing.ss +++ /dev/null @@ -1,258 +0,0 @@ -(module profj-testing mzscheme - - (require (lib "compile.ss" "profj") - (lib "parameters.ss" "profj") - (lib "display-java.ss" "profj") - (lib "class.ss")) - - (define report-expected-error-messages (make-parameter #t)) - - (define interaction-errors (make-parameter 0)) - (define execution-errors (make-parameter 0)) - (define file-errors (make-parameter 0)) - (define interaction-msgs (make-parameter null)) - (define execution-msgs (make-parameter null)) - (define file-msgs (make-parameter null)) - (define missed-expected-errors (make-parameter 0)) - (define expected-failed-tests (make-parameter null)) - (define expected-error-messages (make-parameter null)) - - (provide java-values-equal?) - (define (java-values-equal? v1 v2) - (java-equal? v1 v2 null null)) - - ;java-equal?: 'a 'a (list 'a) (list 'a)-> bool - (define (java-equal? v1 v2 visited-v1 visited-v2) - (or (eq? v1 v2) - (already-seen? v1 v2 visited-v1 visited-v2) - (and (number? v1) (number? v2) (= v1 v2)) - (cond - ((and (object? v1) (object? v2)) - (cond - ((equal? "String" (send v1 my-name)) - (and (equal? "String" (send v2 my-name)) - (equal? (send v1 get-mzscheme-string) (send v2 get-mzscheme-string)))) - ((equal? "array" (send v1 my-name)) - (and (equal? "array" (send v2 my-name)) - (= (send v1 length) (send v2 length)) - (let ((v1-vals (array->list v1)) - (v2-vals (array->list v2))) - (andmap (lambda (x) x) - (map java-equal? v1-vals v2-vals - (map (lambda (v) (cons v1 visited-v1)) v1-vals) - (map (lambda (v) (cons v2 visited-v2)) v2-vals)))))) - (else - (and (equal? (send v1 my-name) (send v2 my-name)) - (let ((v1-fields (send v1 field-values)) - (v2-fields (send v2 field-values))) - (and (= (length v1-fields) (length v2-fields)) - (andmap (lambda (x) x) - (map java-equal? v1-fields v2-fields - (map (lambda (v) (cons v1 visited-v1)) v1-fields) - (map (lambda (v) (cons v2 visited-v2)) v2-fields))))))))) - ((and (not (object? v1)) (not (object? v2))) (equal? v1 v2)) - (else #f)))) - - ;array->list: java-array -> (list 'a) - (define (array->list v) - (letrec ((len (send v length)) - (build-up - (lambda (c) - (if (= c len) - null - (cons (send v access c) - (build-up (add1 c))))))) - (build-up 0))) - - ;already-seen?: 'a 'a (list 'a) (list 'a)-> bool - (define (already-seen? v1 v2 visited-v1 visited-v2) - (cond - ((and (null? visited-v1) (null? visited-v2)) #f) - ((memq v1 visited-v1) - (let ((position-v1 (get-position v1 visited-v1 0))) - (eq? v2 (list-ref visited-v2 position-v1)))) - (else #f))) - - ;get-position: 'a (list 'a) int -> int - (define (get-position v1 visited pos) - (if (eq? v1 (car visited)) - pos - (get-position v1 (cdr visited) (add1 pos)))) - - ;interact-internal: symbol (list string) (list evalable-value) string type-record -> void - (define (interact-internal level interacts vals msg type-recs) - (for-each (lambda (ent val) - (let ((st (open-input-string ent))) - (with-handlers - ([exn? - (lambda (exn) - (cond - ((and (eq? val 'error) (report-expected-error-messages)) - (expected-error-messages (cons (cons msg (exn-message exn)) (expected-error-messages)))) - ((not (eq? val 'error)) - (interaction-errors (add1 (interaction-errors))) - (interaction-msgs (cons - (format "Test ~a: Exception raised for ~a : ~a" - msg ent (exn-message exn)) (interaction-msgs))))))]) - (let ((new-val (eval `(begin - (require (lib "class.ss") - (prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java")) - (prefix c: (lib "contract.ss"))) - ,(compile-interactions st st type-recs level))))) - (when (eq? val 'error) - (missed-expected-errors (add1 (missed-expected-errors))) - (expected-failed-tests (cons msg (expected-failed-tests)))) - (unless (and (not (eq? val 'error)) (java-equal? (eval val) new-val null null)) - (interaction-errors (add1 (interaction-errors))) - (interaction-msgs (cons (format "Test ~a: ~a evaluated to ~a instead of ~a" - msg ent new-val val) (interaction-msgs)))))))) - interacts vals)) - - ;interact-test: symbol (list string) (list evalable-value) string | - ; : string stymbol (list string) (list evalable-value) string -> void - (define interact-test - (case-lambda - [(level in val msg) - (interact-internal level in val msg (create-type-record))] - ((defn level in val msg) - (let* ((type-recs (create-type-record)) - (def-st (open-input-string defn))) - (with-handlers - ([exn? - (lambda (exn) - (interaction-errors (add1 (interaction-errors))) - (interaction-msgs (cons (format "Test ~a: Exception raised in definition : ~a" - msg (exn-message exn)) - (interaction-msgs))))]) - (execution? #t) - (eval-modules (compile-java 'port 'port level #f def-st def-st type-recs)) - (interact-internal level in val msg type-recs)))))) - - ;interact-test-java-expected: string symbol (list string) (list string) string -> void - (define (interact-test-java-expected defn level in val msg) - (let* ((type-recs (create-type-record)) - (def-st (open-input-string defn))) - (with-handlers - ([exn? - (lambda (exn) - (interaction-errors (add1 (interaction-errors))) - (interaction-msgs (cons (format "Test ~a: Exception raised in definition : ~a" - msg (exn-message exn)) - (interaction-msgs))))]) - (execution? #t) - (eval-modules (compile-java 'port 'port level #f def-st def-st type-recs)) - (let ((vals (map (lambda (ex-val) - (let ((st (open-input-string ex-val))) - (eval `(begin (require (lib "class.ss") - (prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java"))) - ,(compile-interactions st st type-recs level))))) - val))) - (interact-internal level in vals msg type-recs))))) - - (define (execute-test defn level error? msg) - (let ((st (open-input-string defn))) - (with-handlers - ([exn? - (lambda (exn) - (cond - ((and error? (report-expected-error-messages)) - (expected-error-messages (cons (cons msg (exn-message exn)) (expected-error-messages)))) - ((not error?) - (execution-errors (add1 (execution-errors))) - (execution-msgs (cons - (format "Test ~a : Exception-raised: ~a" msg (exn-message exn)) (execution-msgs))))))]) - (eval-modules (compile-java 'port 'port level #f st st)) - (when error? - (missed-expected-errors (add1 (missed-expected-errors))) - (expected-failed-tests (cons msg (expected-failed-tests)))) - ))) - - ;run-test: symbol string (U string (list string)) (U string (list string)) -> (U (list (list symbol bool string)) (list ...)) - (define (run-test level defn interact val) - (let* ((type-recs (create-type-record)) - (def-st (open-input-string defn)) - (check-vals - (lambda (interact val) - (with-handlers - ([exn? - (lambda (exn) - (list 'interact #f (exn-message exn)))]) - (let* ((get-val (lambda (v-st v-pe) - (eval `(begin (require (lib "class.ss")) - (require (prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java"))) - ,(compile-interactions v-st v-st type-recs level))))) - (i-st (open-input-string interact)) - (v-st (open-input-string val)) - (i-pe (lambda () (open-input-string interact))) - (v-pe (lambda () (open-input-string val))) - (given-val (get-val i-st i-pe)) - (exp-val (get-val v-st v-pe))) - (list 'interact (java-equal? given-val exp-val null null) (format-java-value given-val #t 'field null #f 0))))))) - (with-handlers - ([exn? - (lambda (exn) - (list 'defn #f (exn-message exn)))]) - (execution? #t) - (eval-modules (compile-java 'port 'port level #f def-st def-st type-recs)) - (cond - ((and (pair? interact) (pair? val)) - (map check-vals interact val)) - ((and (string? interact) (string? val)) - (check-vals interact val)))))) - - (define (file-test file level error? msg) - (with-handlers - ([exn? - (lambda (exn) - (unless error? - (file-errors (add1 (file-errors))) - (file-msgs (cons - (format "Test ~a :Exception-raised: ~a" msg (exn-message exn)) (file-msgs)))))]) - (eval-modules (compile-java 'file 'port level file #f #f)))) - - (define (eval-modules modules) - (for-each eval - (apply append - (map compilation-unit-code modules)))) - - ;prepare-for-tests: String -> void - (define (prepare-for-tests lang-level) - (printf "Running tests for ~a~n" lang-level) - (interaction-errors 0) - (interaction-msgs null) - (execution-errors 0) - (execution-msgs null) - (file-errors 0) - (file-msgs null) - (missed-expected-errors 0) - (expected-failed-tests null) - (expected-error-messages null)) - - - ;report-test-results: -> void - (define (report-test-results) - (when (> (interaction-errors) 0) - (printf "~a Interaction errors occurred~n" (interaction-errors)) - (for-each (lambda (m) (printf "~a~n" m)) (interaction-msgs)) - (newline)) - (when (> (execution-errors) 0) - (printf "~a Execution errors occurred~n" (execution-errors)) - (for-each (lambda (m) (printf "~a~n" m)) (execution-msgs)) - (newline)) - (when (> (file-errors) 0) - (printf "~a file errors occurred~n" (file-errors)) - (for-each (lambda (m) (printf "~a~n" m)) (file-msgs)) - (newline)) - (when (> (missed-expected-errors) 0) - (printf "Failed to receive errors for these ~a tests:~n" (missed-expected-errors)) - (for-each (lambda (m) (printf "~a~n" m)) (expected-failed-tests)) - (newline)) - (when (report-expected-error-messages) - (printf "Received these expected error messages:~n") - (for-each (lambda (m) (printf "Error for test ~a : ~a~n" (car m) (cdr m))) (expected-error-messages))) - (printf "Tests completed~n")) - - (provide interact-test execute-test interact-test-java-expected file-test run-test - report-test-results prepare-for-tests report-expected-error-messages) - ) - \ No newline at end of file