suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Honu:

Browse Source 
- 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
This commit is contained in:
Carl Eastlund 2005-09-24 07:50:32 +00:00
parent d96e47c4b7
commit 6b184c70de
5 changed files with 145 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/honu/examples/point-test.ss Normal file
View File

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

6
collects/honu/tenv.ss
View File

@ -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?)

34
collects/honu/test.ss Normal file
View File

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

49
collects/honu/top.ss
View File

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

84
collects/honu/utils.ss
View File

@ -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 (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)
(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))])))
)
)