diff --git a/collects/honu/environment.ss b/collects/honu/environment.ss new file mode 100644 index 0000000000..f95a377ddb --- /dev/null +++ b/collects/honu/environment.ss @@ -0,0 +1,46 @@ +(module environment mzscheme + + (require (lib "contract.ss") + (prefix env: (planet "environment.ss" ("cobbe" "environment.plt" 2 1))) + ) + + (provide/contract + [mapping? (any/c . -> . boolean?)] + [empty (-> mapping?)] + [extend (mapping? identifier? any/c . -> . mapping?)] + [contains? (mapping? identifier? . -> . boolean?)] + [lookup (([mapping + (lambda (mapping) + (and (mapping? mapping) + (contains? mapping id)))] + [id identifier?]) + . ->r . any)] + ) + + ;; mapping? : Any -> Boolean + ;; Reports whether a value is a mapping. + (define (mapping? value) + (env:env? value)) + + ;; empty : -> [Mapping X] + ;; Contructs an empty mapping. + (define (empty) + (env:make-empty-env bound-identifier=?)) + + ;; extend : [Mapping X] Identifier X -> [Mapping X] + ;; Adds or shadows an environment binding. + (define (extend mapping id entry) + (env:extend-env (list id) (list entry) mapping)) + + ;; contains? : [Mapping X] Identifier -> Boolean + ;; Reports whether the given key has an entry. + (define (contains? mapping id) + (env:bound? mapping id)) + + ;; lookup : [Mapping X] Identifier -> X + ;; Returns the entry for the given key. + ;; Raises exn:fail:contract if no entry exists. + (define (lookup mapping id) + (env:lookup mapping id)) + + ) diff --git a/collects/honu/honu-tests.ss b/collects/honu/honu-tests.ss new file mode 100644 index 0000000000..95008cbe4d --- /dev/null +++ b/collects/honu/honu-tests.ss @@ -0,0 +1,20 @@ +(module honu-tests mzscheme + + (require (lib "contract.ss") + (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) + "private/tests/typechecker-tests.ss" + "private/tests/program-tests.ss" + ) + + (provide/contract [honu-tests test-suite?]) + + ;; honu-tests : TestSuite + ;; Honu Test Suite + (define honu-tests + (make-test-suite + "Honu" + program-tests + typechecker-tests + )) + + ) diff --git a/collects/honu/private/tests/program-tests.ss b/collects/honu/private/tests/program-tests.ss new file mode 100644 index 0000000000..bac52098f5 --- /dev/null +++ b/collects/honu/private/tests/program-tests.ss @@ -0,0 +1,48 @@ +(module program-tests mzscheme + + (require (lib "contract.ss") + (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) + (prefix srfi1: (lib "1.ss" "srfi")) + "../../top.ss" + ) + + (provide/contract [program-tests test-suite?]) + + (define program-files + (list "examples/BoundedStack.honu" + "examples/EvenOddClass.honu" + "examples/List.honu" + "examples/Y.honu" + "examples/bind-tup-top.honu" + "examples/cond-test.honu" + "examples/even-odd.honu" + "examples/exprs.honu" + "examples/point.honu" + "examples/struct.honu" + "examples/tup-bind.honu" +; "examples/types-error.honu" + "examples/types.honu" +; "examples/nonexistent.honu" + )) + + (define-assertion (assert-test-file program-file) + (let* ([results (test-file program-file)] + [indices (srfi1:iota (length results))] + [errors + (srfi1:filter-map (lambda (result index) (if result #f index)) + results indices)]) + (if (null? errors) + #t + (with-assertion-info + (['error-indices errors]) + (fail-assertion))))) + + (define (make-program-test program-file) + (make-test-case program-file (assert-test-file program-file))) + + (define program-tests + (apply make-test-suite + "Honu" + (map make-program-test program-files))) + + ) diff --git a/collects/honu/private/tests/typechecker-tests.ss b/collects/honu/private/tests/typechecker-tests.ss new file mode 100644 index 0000000000..8852009546 --- /dev/null +++ b/collects/honu/private/tests/typechecker-tests.ss @@ -0,0 +1,38 @@ +(module typechecker-tests mzscheme + + (require (lib "contract.ss") + (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) + (prefix srfi13: (lib "13.ss" "srfi")) + "../typechecker/typecheck-expression.ss" + "../../tenv.ss" + "../../ast.ss" + ) + + (provide/contract [typechecker-tests test-suite?]) + + (define non-void-in-sequence-test + (make-test-case "Non-void expression in a sequence" + (assert-exn + (lambda (exn) + (srfi13:string-contains (exn-message exn) "void")) + (lambda () + (typecheck-expression + (wrap-lenv) #f + (make-ast:expr:sequence + #'() + (list (make-ast:expr:literal #'() (make-ast:type:primitive #'() 'int) #'5)) + (make-ast:expr:literal #'() (make-ast:type:primitive #'() 'int) #'4))))))) + + (define error-message-tests + (make-test-suite + "Error messages" + non-void-in-sequence-test + )) + + (define typechecker-tests + (make-test-suite + "Typechecker" + error-message-tests + )) + + ) \ No newline at end of file diff --git a/collects/honu/run-tests.ss b/collects/honu/run-tests.ss new file mode 100644 index 0000000000..29c20830fe --- /dev/null +++ b/collects/honu/run-tests.ss @@ -0,0 +1,21 @@ +(module run-tests mzscheme + + (require "honu-tests.ss" + ) + + (provide test/text test/graphical) + + (define (test/text) + ((dynamic-require '(planet "text-ui.ss" ("schematics" "schemeunit.plt" 1 1)) 'test/text-ui) + honu-tests)) + + (define (test/graphical) + ((dynamic-require '(planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 1 1)) 'test/graphical-ui) + honu-tests)) + + ) + + + + + \ No newline at end of file diff --git a/collects/honu/top.ss b/collects/honu/top.ss index 39d4985803..aa95b72e8d 100644 --- a/collects/honu/top.ss +++ b/collects/honu/top.ss @@ -128,19 +128,17 @@ ) (define (test-file file) - (with-handlers - ([exn:fail? (lambda (exn) `(error ,(exn-message exn)))]) - (let* ([honu-path (if (path? file) file (string->path file))] - [test-path (path-replace-suffix honu-path "-test.ss")]) - (unless (file-exists? honu-path) - (error 'test-file "~s not found" (path->string honu-path))) - (unless (file-exists? test-path) - (error 'test-file "~s not found" (path->string test-path))) - (let* ([stx (program-syntax test-path)]) - (eval-after-program - honu-path - #`(begin - (require (lib "test-tools.ss" "honu")) - #,stx)))))) + (let* ([honu-path (if (path? file) file (string->path file))] + [test-path (path-replace-suffix honu-path "-test.ss")]) + (unless (file-exists? honu-path) + (error 'test-file "~s not found" (path->string honu-path))) + (unless (file-exists? test-path) + (error 'test-file "~s not found" (path->string test-path))) + (let* ([stx (program-syntax test-path)]) + (eval-after-program + honu-path + #`(begin + (require (lib "test-tools.ss" "honu")) + #,stx))))) )