From 6b184c70de1acd973f4ef3349068e086accc1774 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sat, 24 Sep 2005 07:50:32 +0000 Subject: [PATCH] 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 | 19 +++++++ collects/honu/tenv.ss | 6 +- collects/honu/test.ss | 34 +++++++++++ collects/honu/top.ss | 51 ++++------------- collects/honu/utils.ss | 84 +++++++++++++++++++++++++--- 5 files changed, 145 insertions(+), 49 deletions(-) create mode 100644 collects/honu/examples/point-test.ss create mode 100644 collects/honu/test.ss diff --git a/collects/honu/examples/point-test.ss b/collects/honu/examples/point-test.ss new file mode 100644 index 0000000000..24cbf1b388 --- /dev/null +++ b/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))) diff --git a/collects/honu/tenv.ss b/collects/honu/tenv.ss index b26341d9f9..f01760e9aa 100644 --- a/collects/honu/tenv.ss +++ b/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?) diff --git a/collects/honu/test.ss b/collects/honu/test.ss new file mode 100644 index 0000000000..6870f64a4f --- /dev/null +++ b/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)) + + ) diff --git a/collects/honu/top.ss b/collects/honu/top.ss index 232accaab6..4f04c13f1a 100644 --- a/collects/honu/top.ss +++ b/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) - (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?) + (define/c (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) - #;(path-string? . -> . (values (listof (list/c symbol? any/c)) (listof (list/c symbol? any/c)))) + (define/c (top:run-program file) (path-string? . -> . (values (listof symbol?) (listof symbol?))) (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) - (top:reset-env) - (eval-syntax (top:translate-defns (top:check-defns (top:parse-file file)))) - (for-each run-test-class-from-name (tenv-names))) - + (define/c (top:run-programs files) + ((listof path-string?) . -> . (values (listof (listof symbol?)) (listof (listof symbol?)))) + (map-values top:run-program files)) + ) diff --git a/collects/honu/utils.ss b/collects/honu/utils.ss index c96945de2e..f66951b8f1 100644 --- a/collects/honu/utils.ss +++ b/collects/honu/utils.ss @@ -1,7 +1,73 @@ (module utils mzscheme - (require "ast.ss") - (require (lib "list.ss" "srfi" "1")) - (require (only (lib "list.ss") quicksort)) + + (require (lib "contract.ss") + (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 (identifierstring (syntax-e a)) @@ -32,10 +98,10 @@ #t cs)) (define (get-names ds p f) - (filter-map (lambda (defn) - (and (p defn) - (f defn))) - ds)) + (srfi1:filter-map (lambda (defn) + (and (p defn) + (f defn))) + 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))]))) - ) + )