Honu:

- test.ss
  - added list of examples files to test
  - added test-file function to run file and related test cases
  - added run-tests to run automated honu tests
- examples/
  - added test case file for point.honu
- top.ss
  - imported util.ss
  - added run-programs
  - moved test-program to test.ss
- util.ss
  - removed unnecessary "ast.ss" import
  - added "contract.ss" import
  - changed names to prevent import name-clash
  - added definitions of define/p (provide) and define/c (provide/contract),
    plus define-struct versions
  - added map-values for mapping functions which return arbitrary numbers of values
- tenv.ss
  - added sqrt() function to Honu environment

svn: r909

collects/honu/examples/point-test.ss

@@ -0,0 +1,19 @@
+(require (lib "class.ss"))
+
+(define (mixin? obj) (null? obj))
+
+(append (map interface? (list MovingPoint<%>
+                              Point3D<%>
+                              Point<%>
+                              ColorPoint<%>
+                              Color<%>))
+        (map class? (list ColorC%
+                          Point3DC%
+                          ColorPointC%
+                          ColorMovingPointC%
+                          MovingColorPointC%
+                          PointC%
+                          MovingPointC%))
+        (map mixin? (list makeMobile-mixin
+                          addColor-mixin
+                          $Point3DC-mixin)))

collects/honu/tenv.ss

@@ -74,7 +74,11 @@
                                   (make-honu:type-tuple #f
                                     (list (make-honu:type-prim #f 'string)
                                           (make-honu:type-prim #f 'int)))
-                                  (make-honu:type-prim #f 'char)))))
+                                  (make-honu:type-prim #f 'char)))
+          (cons #'sqrt          (make-honu:type-func #f
+                                  (make-honu:type-prim #f 'float)
+                                  (make-honu:type-prim #f 'float)))
+          ))
  
   (provide tenv?)
   (define tenv? bound-identifier-mapping?)

collects/honu/test.ss

@@ -0,0 +1,34 @@
+(module test mzscheme
+
+  (require (lib "contract.ss")
+           "top.ss"
+           "utils.ss")
+
+  (define/p examples
+    (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/c (test-file file) (path-string? . -> . any)
+    (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")])
+        (top:run-program honu-path)
+        (load test-path))))
+
+  (define/c (run-tests) (-> (listof any/c))
+    (map test-file examples))
+  
+  )

collects/honu/top.ss

@@ -15,38 +15,13 @@
            "honu-context.ss"
            "ast.ss"
            "tenv.ss"
+           "utils.ss"
            )
 
-  (require-for-template (lib "contract.ss"))
+  (define/c top:current-tenv parameter? (make-parameter (empty-tenv)))
+  (define/c top:current-lenv parameter? (make-parameter (get-builtin-lenv)))
 
-  (define-syntax (define/provide stx)
+  (define/c (top:reset-env) (-> void?)
-    (syntax-case stx ()
-        [(_ (NAME ARG ...) BODY ...)
-         #`(begin
-             (define (NAME ARG ...) BODY ...)
-             (provide NAME))]
-        [(_ NAME BODY ...)
-         #`(begin
-             (define NAME BODY ...)
-             (provide NAME))]
-        ))
-
-  (define-syntax (def/pro/con stx)
-    (syntax-case stx ()
-        [(_ (NAME ARG ...) CONTRACT BODY ...)
-         #`(begin
-             (define (NAME ARG ...) BODY ...)
-             (provide/contract [NAME CONTRACT]))]
-        [(_ NAME CONTRACT BODY ...)
-         #`(begin
-             (define NAME BODY ...)
-             (provide/contract [NAME CONTRACT]))]
-        ))
-
-  (def/pro/con top:current-tenv parameter? (make-parameter (empty-tenv)))
-  (def/pro/con top:current-lenv parameter? (make-parameter (get-builtin-lenv)))
-
-  (def/pro/con (top:reset-env) (-> void?)
     (top:current-tenv (empty-tenv))
     (top:current-lenv (get-builtin-lenv)))
 
@@ -63,16 +38,16 @@
        #`(parameterize ([current-compile-context honu-compile-context])
            BODY ...)]))
 
-  (def/pro/con (top:parse-file file) (path-string? . -> . (listof honu:defn?))
+  (define/c (top:parse-file file) (path-string? . -> . (listof honu:defn?))
     (with-env
      (post-parse-program
       (add-defns-to-tenv
        (parse-port (open-input-file file) file)))))
 
-  (def/pro/con (top:check-defns defns) ((listof honu:defn?) . -> . (listof honu:defn?))
+  (define/c (top:check-defns defns) ((listof honu:defn?) . -> . (listof honu:defn?))
     (with-env (typecheck defns)))
 
-  (def/pro/con (top:translate-defns defns) ((listof honu:defn?) . -> . (syntax/c any/c))
+  (define/c (top:translate-defns defns) ((listof honu:defn?) . -> . (syntax/c any/c))
     (with-env
      (with-context
        (let-values
@@ -108,15 +83,13 @@
           (printf "WILL test ~s [~s]~n" def name)
           (printf "WONT test ~s [~s]~n" def name))))
   
-  (define/provide (top:run-program file)
+  (define/c (top:run-program file) (path-string? . -> . (values (listof symbol?) (listof symbol?)))
-    #;(path-string? . -> . (values (listof (list/c symbol? any/c)) (listof (list/c symbol? any/c))))
     (top:reset-env)
     (eval-syntax (top:translate-defns (top:check-defns (top:parse-file file))))
     (values (tenv-names) (lenv-names)))
 
-  (define/provide (top:test-program file)
+  (define/c (top:run-programs files)
-    (top:reset-env)
+    ((listof path-string?) . -> . (values (listof (listof symbol?)) (listof (listof symbol?))))
-    (eval-syntax (top:translate-defns (top:check-defns (top:parse-file file))))
+    (map-values top:run-program files))
-    (for-each run-test-class-from-name (tenv-names)))
+  
-
   )

collects/honu/utils.ss

@@ -1,7 +1,73 @@
 (module utils mzscheme
-  (require "ast.ss")
+
-  (require (lib "list.ss" "srfi" "1"))
+  (require (lib "contract.ss")
-  (require (only (lib "list.ss") quicksort))
+           (prefix srfi1: (lib "list.ss" "srfi" "1"))
+           (lib "list.ss"))
+
+  (require-for-template (lib "contract.ss"))
+
+  (provide define/p)
+  (define-syntax (define/p stx)
+    (syntax-case stx ()
+      [(_ (NAME . ARGS) BODY ...)
+       #`(begin
+           (define (NAME . ARGS) BODY ...)
+           (provide NAME))]
+      [(_ NAME BODY ...)
+       #`(begin
+           (define NAME BODY ...)
+           (provide NAME))]
+      ))
+
+  (provide define/c)
+  (define-syntax (define/c stx)
+    (syntax-case stx ()
+      [(_ (NAME . ARGS) CONTRACT BODY ...)
+       #`(begin
+           (define (NAME . ARGS) BODY ...)
+           (provide/contract [NAME CONTRACT]))]
+      [(_ NAME CONTRACT BODY ...)
+       #`(begin
+           (define NAME BODY ...)
+           (provide/contract [NAME CONTRACT]))]
+      ))
+
+  (provide define-struct/p)
+  (define-syntax (define-struct/p stx)
+    (syntax-case stx ()
+      [(_ (NAME SUPER) (FIELD ...) REST ...)
+       #`(begin
+           (define-struct (NAME SUPER) (FIELD ...) REST ...)
+           (provide (struct NAME (FIELD ...))))]
+      [(_ NAME (FIELD ...) REST ...)
+       #`(begin
+           (define-struct NAME (FIELD ...) REST ...)
+           (provide (struct NAME (FIELD ...))))]))
+
+  (provide define-struct/c)
+  (define-syntax (define-struct/c stx)
+    (syntax-case stx ()
+      [(_ (NAME SUPER) ([FIELD CONTRACT] ...) REST ...)
+       #`(begin
+           (define-struct (NAME SUPER) (FIELD ...) REST ...)
+           (provide/contract (struct NAME ([FIELD CONTRACT] ...))))]
+      [(_ NAME ([FIELD CONTRACT] ...) REST ...)
+       #`(begin
+           (define-struct NAME (FIELD ...) REST ...)
+           (provide/contract (struct NAME ([FIELD CONTRACT] ...))))]))
+
+  (define (map-values-rev-accs f lists accs)
+    (cond [(andmap empty? lists) (apply values (map reverse accs))]
+          [(ormap empty? lists) (error 'map-values "expects lists of equal length")]
+          [else (call-with-values (lambda () (apply f (map first lists)))
+                  (lambda vs (map-values-rev-accs f (map rest lists) (map cons vs accs))))]))
+  
+  (define/p (map-values f . lists)
+    (cond [(empty? lists) (error 'map-values "expects 1 or more input lists")]
+          [(ormap empty? lists) (error 'map-values "expects non-empty lists")]
+          [else
+           (call-with-values (lambda () (apply f (map first lists)))
+             (lambda vs (map-values-rev-accs f (map rest lists) (map list vs))))]))
 
   (define (identifier<? a b)
     (string<? (symbol->string (syntax-e a))
@@ -32,10 +98,10 @@
                     #t cs))
   
   (define (get-names ds p f)
-    (filter-map (lambda (defn)
+    (srfi1:filter-map (lambda (defn)
-                  (and (p defn)
+                        (and (p defn)
-                       (f defn)))
+                             (f defn)))
-                ds))    
+                      ds))
   
   (provide map-and-fold)
   (define (map-and-fold f i l)
@@ -54,7 +120,7 @@
     (let loop ((lists lists)
                (map1  '())
                (map2  '()))
-      (if (any null? lists)
+      (if (ormap empty? lists)
           (values (reverse map1) (reverse map2))
           (let-values ([(m1 m2) (apply f (map car lists))])
             (loop (map cdr lists)
@@ -72,4 +138,4 @@
          (values (car lis) (append (reverse passed) (cdr lis)))]
         [else
          (loop (cdr lis) (cons (car lis) passed))])))
-    )
+  )