Honu: (merging from branch)

- Updated testing framework to use SchemeUnit
- Added generalized environment implementation

svn: r1986

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))
+
+  )

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
+     ))
+  
+  )

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)))
+
+  )

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
+     ))
+
+  )

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))
+
+  )
+
+
+  
+
+  

collects/honu/top.ss

@@ -128,19 +128,17 @@
    )
   
   (define (test-file file)
-    (with-handlers
+    (let* ([honu-path (if (path? file) file (string->path file))]
-        ([exn:fail? (lambda (exn) `(error ,(exn-message exn)))])
+           [test-path (path-replace-suffix honu-path "-test.ss")])
-      (let* ([honu-path (if (path? file) file (string->path file))]
+      (unless (file-exists? honu-path)
-             [test-path (path-replace-suffix honu-path "-test.ss")])
+        (error 'test-file "~s not found" (path->string honu-path)))
-        (unless (file-exists? honu-path)
+      (unless (file-exists? test-path)
-          (error 'test-file "~s not found" (path->string honu-path)))
+        (error 'test-file "~s not found" (path->string test-path)))
-        (unless (file-exists? test-path)
+      (let* ([stx (program-syntax test-path)])
-          (error 'test-file "~s not found" (path->string test-path)))
+        (eval-after-program
-        (let* ([stx (program-syntax test-path)])
+         honu-path
-          (eval-after-program
+         #`(begin
-           honu-path
+             (require (lib "test-tools.ss" "honu"))
-           #`(begin
+             #,stx)))))
-               (require (lib "test-tools.ss" "honu"))
-               #,stx))))))
   
   )