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

r6rs tests and repairs

Browse Source 
svn: r8913
This commit is contained in:
Matthew Flatt 2008-03-07 03:18:06 +00:00
parent b866eeb557
commit 20055ac00e
10 changed files with 397 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

92
collects/r6rs/main.ss
View File

@ -8,7 +8,7 @@ FIXME:
(require (for-syntax scheme/base (require (for-syntax scheme/base
syntax/kerncase syntax/kerncase
(prefix-in parse: "private/parse-ref.ss") "private/parse-ref.ss"
scheme/provide-transform)) scheme/provide-transform))
(provide (rename-out [module-begin #%module-begin])) (provide (rename-out [module-begin #%module-begin]))
@ -169,59 +169,6 @@ FIXME:
;; ---------------------------------------- ;; ----------------------------------------
;; Imports and exports ;; Imports and exports
(define-for-syntax (parse-library-reference orig stx)
(datum->syntax
orig
`(,#'lib
,(parse:parse-library-reference stx
(lambda (msg)
(raise-syntax-error
#f
msg
orig
stx))))
orig))
(define-for-syntax (parse-import-set orig stx)
(define (bad)
(raise-syntax-error #f
(format "bad `~a' form"
(syntax-e (car (syntax-e stx))))
orig
stx))
(define (check-id id)
(unless (identifier? id)
(raise-syntax-error #f
(format "not an identifier in `~a' form"
(syntax-e (car (syntax-e stx))))
orig
id)))
(syntax-case* stx (library only except prefix rename) symbolic-identifier=?
[(library lib)
(parse-library-reference orig #'lib)]
[(library . _) (bad)]
[(only im id ...)
(for-each check-id (syntax->list #'(id ...)))
#`(only-in #,(parse-import-set orig #'im) id ...)]
[(only . _) (bad)]
[(except im id ...)
(for-each check-id (syntax->list #'(id ...)))
#`(except-in #,(parse-import-set orig #'im) id ...)]
[(except . _) (bad)]
[(prefix im id)
(check-id #'id)
#`(prefix-in id #,(parse-import-set orig #'im))]
[(prefix . _) (bad)]
[(rename im (id id2) ...)
(for-each check-id
(apply
append
(map syntax->list
(syntax->list #'((id id2) ...)))))
#`(rename-in #,(parse-import-set orig #'im) [id id2] ...)]
[(rename . _) (bad)]
[_ (parse-library-reference orig stx)]))
(define-syntax (r6rs-import stx) (define-syntax (r6rs-import stx)
(let ([orig (syntax-case stx () (let ([orig (syntax-case stx ()
[(_ orig) #'orig])]) [(_ orig) #'orig])])
@ -229,37 +176,14 @@ FIXME:
[(_ (import im ...)) [(_ (import im ...))
(with-syntax ([((im ...) ...) (with-syntax ([((im ...) ...)
(map (lambda (im) (map (lambda (im)
(syntax-case* im (for) symbolic-identifier=? (parse-import
[(for base-im level ...) orig
(let* ([levels im
(cons (lambda (msg orig stx)
#f (raise-syntax-error #f
(map (lambda (level) msg
(syntax-case* level (run expand meta) symbolic-identifier=?
[run #'0]
[expand #'1]
[(meta 0) #'0]
[(meta n) #'n]
[_
(raise-syntax-error
#f
"bad `for' level"
orig orig
level)])) stx))))
(syntax->list #'(level ...))))])
(with-syntax ([is (parse-import-set orig #'base-im)])
(with-syntax ([(level ...) levels]
[prelims (datum->syntax orig
'r6rs/private/prelims)])
#`((for-meta level is prelims) ...))))]
[(for . _)
(raise-syntax-error
#f
"bad `for' import form"
orig
im)]
[_ (let ([m (parse-import-set orig im)])
(list m `(for-label ,m)))]))
(syntax->list #'(im ...)))] (syntax->list #'(im ...)))]
[prelims (datum->syntax orig [prelims (datum->syntax orig
'r6rs/private/prelims)]) 'r6rs/private/prelims)])

83
collects/r6rs/private/parse-ref.ss
View File

@ -1,8 +1,9 @@
#lang scheme/base #lang scheme/base
(require "find-version.ss") (require "find-version.ss"
(for-template scheme/base))
(provide parse-library-reference) (provide parse-import)
(define (symbolic-identifier=? a b) (define (symbolic-identifier=? a b)
(eq? (syntax-e a) (syntax-e b))) (eq? (syntax-e a) (syntax-e b)))
@ -72,3 +73,81 @@
(parse-library-reference #'(id1 id2 ... ()) err)] (parse-library-reference #'(id1 id2 ... ()) err)]
[_ [_
(err "ill-formed library reference")])) (err "ill-formed library reference")]))
(define (convert-library-reference orig stx stx-err)
(datum->syntax
orig
`(,#'lib
,(parse-library-reference stx
(lambda (msg)
(stx-err msg orig stx))))
orig))
(define (parse-import-set orig stx stx-err)
(define (bad)
(stx-err (format "bad `~a' form"
(syntax-e (car (syntax-e stx))))
orig
stx))
(define (check-id id)
(unless (identifier? id)
(stx-err (format "not an identifier in `~a' form"
(syntax-e (car (syntax-e stx))))
orig
id)))
(syntax-case* stx (library only except prefix rename) symbolic-identifier=?
[(library lib)
(convert-library-reference orig #'lib stx-err)]
[(library . _) (bad)]
[(only im id ...)
(for-each check-id (syntax->list #'(id ...)))
#`(only-in #,(parse-import-set orig #'im stx-err) id ...)]
[(only . _) (bad)]
[(except im id ...)
(for-each check-id (syntax->list #'(id ...)))
#`(except-in #,(parse-import-set orig #'im stx-err) id ...)]
[(except . _) (bad)]
[(prefix im id)
(check-id #'id)
#`(prefix-in id #,(parse-import-set orig #'im stx-err))]
[(prefix . _) (bad)]
[(rename im (id id2) ...)
(for-each check-id
(apply
append
(map syntax->list
(syntax->list #'((id id2) ...)))))
#`(rename-in #,(parse-import-set orig #'im stx-err) [id id2] ...)]
[(rename . _) (bad)]
[_ (convert-library-reference orig stx stx-err)]))
(define (parse-import orig im stx-err)
(syntax-case* im (for) symbolic-identifier=?
[(for base-im level ...)
(let* ([levels
(cons
#f
(map (lambda (level)
(syntax-case* level (run expand meta) symbolic-identifier=?
[run #'0]
[expand #'1]
[(meta 0) #'0]
[(meta n) #'n]
[_
(stx-err
"bad `for' level"
orig
level)]))
(syntax->list #'(level ...))))])
(with-syntax ([is (parse-import-set orig #'base-im stx-err)])
(with-syntax ([(level ...) levels]
[prelims (datum->syntax orig
'r6rs/private/prelims)])
#`((for-meta level is prelims) ...))))]
[(for . _)
(stx-err
"bad `for' import form"
orig
im)]
[_ (let ([m (parse-import-set orig im stx-err)])
(list m `(for-label ,m)))]))

2
collects/rnrs/arithmetic/fixnums-6.ss
View File

@ -47,7 +47,7 @@
(define-fx even? fxeven? (a) nocheck) (define-fx even? fxeven? (a) nocheck)
(define-fx max fxmax (a b ...) nocheck) (define-fx max fxmax (a b ...) nocheck)
(define-fx max fxmin (a b ...) nocheck) (define-fx min fxmin (a b ...) nocheck)
(define-fx + fx+ (a b) check) (define-fx + fx+ (a b) check)
(define-fx * fx* (a b) check) (define-fx * fx* (a b) check)

35
collects/rnrs/eval-6.ss
View File

@ -1,6 +1,8 @@
#lang scheme/base #lang scheme/base
(require (only-in r6rs) (require (only-in r6rs)
(only-in r6rs/private/prelims)
scheme/mpair
r6rs/private/parse-ref) r6rs/private/parse-ref)
(provide (rename-out [r6rs:eval eval]) (provide (rename-out [r6rs:eval eval])
@ -8,20 +10,39 @@
(define-namespace-anchor anchor) (define-namespace-anchor anchor)
(define (mpair->pair p)
(cond
[(mpair? p) (cons (mpair->pair (mcar p))
(mpair->pair (mcdr p)))]
[(vector? p) (list->vector
(map mpair->pair
(vector->list p)))]
[else p]))
(define (show v)
(printf "~s\n" v)
v)
(define (r6rs:eval expr env) (define (r6rs:eval expr env)
(eval #`(#%expression #,expr) env)) (eval #`(#%expression #,(datum->syntax #f (mpair->pair expr))) env))
(define (environment . specs) (define (environment . specs)
(let ([mod-paths (let ([reqs
(map (lambda (spec) (map (lambda (spec)
`(lib ,(parse-library-reference (syntax->datum
spec (datum->syntax
(lambda (msg) #f
(error 'environment "~a: ~e" msg spec))))) (parse-import
#'here
(mpair->pair spec)
(lambda (msg orig stx)
(error 'environment "~a: ~e" msg spec))))))
specs)]) specs)])
(let ([ns (namespace-anchor->empty-namespace anchor)]) (let ([ns (namespace-anchor->empty-namespace anchor)])
;; Make sure all modules are instantiated here: ;; Make sure all modules are instantiated here:
(parameterize ([current-namespace ns]) (parameterize ([current-namespace ns])
(for-each namespace-require mod-paths)) (namespace-require '(rename scheme/base #%base-require require))
(eval `(#%base-require r6rs/private/prelims
. ,(datum->syntax #'here (apply append reqs)))))
ns))) ns)))

129
collects/tests/r6rs/arithmetic/fixnums.ss
View File

@ -15,6 +15,135 @@
(test (fxreverse-bit-field #b1010010 1 4) 88) ; #b1011000 (test (fxreverse-bit-field #b1010010 1 4) 88) ; #b1011000
;; ----------------------------------------
(test (fixnum? 1.0) #f)
(test (fixnum? 1+1i) #f)
(test (fixnum? 0) #t)
(test (fixnum? 1) #t)
(test (fixnum? -1) #t)
(test (fixnum? (- (expt 2 23))) #t)
(test (fixnum? (- (expt 2 23) 1)) #t)
(test (fixnum? (least-fixnum)) #t)
(test (fixnum? (- (least-fixnum) 1)) #f)
(test (fixnum? (greatest-fixnum)) #t)
(test (fixnum? (+ 1 (greatest-fixnum))) #f)
(let ([test-ordered
(lambda (a b c)
(test (fx=? a a) #t)
(test (fx=? b b) #t)
(test (fx=? c c) #t)
(test (fx=? a b) #f)
(test (fx=? b a) #f)
(test (fx=? b c) #f)
(test (fx=? c b) #f)
(test (fx=? a c b) #f)
(test (fx=? a a b) #f)
(test (fx=? a b b) #f)
(let ([test-lt
(lambda (fx<? fx<=? a b c)
(test (fx<? a b) #t)
(test (fx<? b c) #t)
(test (fx<? a c) #t)
(test (fx<? a b c) #t)
(test (fx<? b a) #f)
(test (fx<? c b) #f)
(test (fx<? a c b) #f)
(test (fx<=? a a) #t)
(test (fx<=? a b) #t)
(test (fx<=? a c) #t)
(test (fx<=? b b) #t)
(test (fx<=? b c) #t)
(test (fx<=? c c) #t)
(test (fx<=? a c c) #t)
(test (fx<=? a b c) #t)
(test (fx<=? b b c) #t)
(test (fx<=? c a) #f)
(test (fx<=? b a) #f)
(test (fx<=? a c b) #f)
(test (fx<=? b c a) #f))])
(test-lt fx<? fx<=? a b c)
(test-lt fx>? fx>=? c b a))
;; Since b is between a and c, we can add or subtract 1:
(test (fx=? (+ b 1) (+ b 1)) #t)
(test (fx<? b (+ b 1)) #t)
(test (fx<=? b (+ b 1)) #t)
(test (fx>? b (+ b 1)) #f)
(test (fx>=? b (+ b 1)) #f)
(test (fx=? (- b 1) (- b 1)) #t)
(test (fx<? b (- b 1)) #f)
(test (fx<=? b (- b 1)) #f)
(test (fx>? b (- b 1)) #t)
(test (fx>=? b (- b 1)) #t)
;; Check min & max while we have ordered values:
(test (fxmin a b) a)
(test (fxmin b c) b)
(test (fxmin a c) a)
(test (fxmin b a c) a)
(test (fxmax a b) b)
(test (fxmax b c) c)
(test (fxmax a c) c)
(test (fxmax b c a) c))])
(test-ordered 1 2 3)
(test-ordered -1 0 1)
(test-ordered (least-fixnum) 1 (greatest-fixnum)))
(test (fxzero? 0) #t)
(test (fxzero? 1) #f)
(test (fxzero? (greatest-fixnum)) #f)
(test (fxzero? (least-fixnum)) #f)
(test (fxpositive? 0) #f)
(test (fxpositive? (least-fixnum)) #f)
(test (fxpositive? (greatest-fixnum)) #t)
(test (fxnegative? 0) #f)
(test (fxnegative? (least-fixnum)) #t)
(test (fxnegative? (greatest-fixnum)) #f)
(test (fxodd? 0) #f)
(test (fxodd? 2) #f)
(test (fxodd? 1) #t)
(test (fxodd? -1) #t)
(test (fxodd? (greatest-fixnum)) #t)
(test (fxodd? (least-fixnum)) #f)
(test (fxeven? 0) #t)
(test (fxeven? 2) #t)
(test (fxeven? 1) #f)
(test (fxeven? -1) #f)
(test (fxeven? (greatest-fixnum)) #f)
(test (fxeven? (least-fixnum)) #t)
(test (fx+ 3 17) 20)
(test (fx+ (greatest-fixnum) (least-fixnum)) -1)
(test (fx+ 0 (greatest-fixnum)) (greatest-fixnum))
(test (fx+ 0 (least-fixnum)) (least-fixnum))
(test (fx* 3 17) 51)
(test (fx* 1 (least-fixnum)) (least-fixnum))
(test (fx* 1 (greatest-fixnum)) (greatest-fixnum))
(test (fx* -1 (greatest-fixnum)) (+ (least-fixnum) 1))
(test (fx- 1) -1)
(test (fx- -1) 1)
(test (fx- 0) 0)
(test (fx- (greatest-fixnum)) (+ 1 (least-fixnum)))
(test (fx- (greatest-fixnum) 1) (- (greatest-fixnum) 1))
(test (fx- (greatest-fixnum) (greatest-fixnum)) 0)
(test (fx- (least-fixnum) (least-fixnum)) 0)
;; ;;
)) ))

24
collects/tests/r6rs/eval.ss Normal file
View File

@ -0,0 +1,24 @@
#!r6rs
(library (tests r6rs eval)
(export run-eval-tests)
(import (rnrs)
(rnrs eval)
(tests r6rs test))
(define (run-eval-tests)
(test (eval '(let ((x 3)) x)
(environment '(rnrs)))
3)
(test (eval
'(eval:car (eval:cons 2 4))
(environment
'(prefix (only (rnrs) car cdr cons null?)
eval:)))
2)
;;
))

30
collects/tests/r6rs/mutable-pairs.ss Normal file
View File

@ -0,0 +1,30 @@
#!r6rs
(library (tests r6rs mutable-pairs)
(export run-mutable-pairs-tests)
(import (rnrs)
(rnrs mutable-pairs)
(tests r6rs test))
(define (f) (list 'not-a-constant-list))
(define (g) '(constant-list))
(define (run-mutable-pairs-tests)
(test/unspec (set-car! (f) 3))
(test/unspec-or-exn (set-car! (g) 3)
&assertion)
(test (let ((x (list 'a 'b 'c 'a))
(y (list 'a 'b 'c 'a 'b 'c 'a)))
(set-cdr! (list-tail x 2) x)
(set-cdr! (list-tail y 5) y)
(list
(equal? x x)
(equal? x y)
(equal? (list x y 'a) (list y x 'b))))
'(#t #t #f))
;;
))

24
collects/tests/r6rs/mutable-strings.ss Normal file
View File

@ -0,0 +1,24 @@
#!r6rs
(library (tests r6rs mutable-strings)
(export run-mutable-strings-tests)
(import (rnrs)
(rnrs mutable-strings)
(tests r6rs test))
(define (f) (make-string 3 #\*))
(define (g) "***")
(define (run-mutable-strings-tests)
(test/unspec (string-set! (f) 0 #\?))
(test/unspec-or-exn (string-set! (g) 0 #\?)
&assertion)
(test/unspec-or-exn (string-set! (symbol->string 'immutable)
0
#\?)
&assertion)
;;
))

63
collects/tests/r6rs/r5rs.ss Normal file
View File

@ -0,0 +1,63 @@
#!r6rs
(library (tests r6rs r5rs)
(export run-r5rs-tests)
(import (rnrs)
(rnrs r5rs)
(tests r6rs test))
;; ----------------------------------------
(define a-stream
(letrec ((next
(lambda (n)
(cons n (delay (next (+ n 1)))))))
(next 0)))
(define head car)
(define tail
(lambda (stream) (force (cdr stream))))
(define count 0)
(define p
(delay (begin (set! count (+ count 1))
(if (> count x)
count
(force p)))))
(define x 5)
;; ----------------------------------------
(define (run-r5rs-tests)
(test (modulo 13 4) 1)
(test (remainder 13 4) 1)
(test (modulo -13 4) 3)
(test (remainder -13 4) -1)
(test (modulo 13 -4) -3)
(test (remainder 13 -4) 1)
(test (modulo -13 -4) -1)
(test (remainder -13 -4) -1)
(test (remainder -13 -4.0) -1.0)
(test (force (delay (+ 1 2))) 3)
(test (let ((p (delay (+ 1 2))))
(list (force p) (force p)))
'(3 3))
(test (head (tail (tail a-stream))) 2)
(test/unspec p)
(test (force p) 6)
(test/unspec p)
(test (begin (set! x 10)
(force p))
6)
;;
))

10
collects/tests/r6rs/run.ss
View File

@ -18,7 +18,11 @@
(tests r6rs arithmetic bitwise) (tests r6rs arithmetic bitwise)
(tests r6rs syntax-case) (tests r6rs syntax-case)
(tests r6rs hashtables) (tests r6rs hashtables)
(tests r6rs enums)) (tests r6rs enums)
(tests r6rs eval)
(tests r6rs mutable-pairs)
(tests r6rs mutable-strings)
(tests r6rs r5rs))
(run-base-tests) (run-base-tests)
@ -38,6 +42,10 @@
(run-syntax-case-tests) (run-syntax-case-tests)
(run-hashtables-tests) (run-hashtables-tests)
(run-enums-tests) (run-enums-tests)
(run-eval-tests)
(run-mutable-pairs-tests)
(run-mutable-strings-tests)
(run-r5rs-tests)
(report-test-results) (report-test-results)