r6rs tests and repairs
svn: r8913
This commit is contained in:
Matthew Flatt
parent
b866eeb557
commit
20055ac00e
|
|
@ -8,7 +8,7 @@ FIXME:
|
|||
|
||||
(require (for-syntax scheme/base
|
||||
syntax/kerncase
|
||||
(prefix-in parse: "private/parse-ref.ss")
|
||||
"private/parse-ref.ss"
|
||||
scheme/provide-transform))
|
||||
|
||||
(provide (rename-out [module-begin #%module-begin]))
|
||||
|
|
@ -169,59 +169,6 @@ FIXME:
|
|||
;; ----------------------------------------
|
||||
;; 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)
|
||||
(let ([orig (syntax-case stx ()
|
||||
[(_ orig) #'orig])])
|
||||
|
|
@ -229,37 +176,14 @@ FIXME:
|
|||
[(_ (import im ...))
|
||||
(with-syntax ([((im ...) ...)
|
||||
(map (lambda (im)
|
||||
(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]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad `for' level"
|
||||
(parse-import
|
||||
orig
|
||||
level)]))
|
||||
(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"
|
||||
im
|
||||
(lambda (msg orig stx)
|
||||
(raise-syntax-error #f
|
||||
msg
|
||||
orig
|
||||
im)]
|
||||
[_ (let ([m (parse-import-set orig im)])
|
||||
(list m `(for-label ,m)))]))
|
||||
stx))))
|
||||
(syntax->list #'(im ...)))]
|
||||
[prelims (datum->syntax orig
|
||||
'r6rs/private/prelims)])
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
#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)
|
||||
(eq? (syntax-e a) (syntax-e b)))
|
||||
|
|
@ -72,3 +73,81 @@
|
|||
(parse-library-reference #'(id1 id2 ... ()) err)]
|
||||
[_
|
||||
(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)))]))
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@
|
|||
(define-fx even? fxeven? (a) 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)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (only-in r6rs)
|
||||
(only-in r6rs/private/prelims)
|
||||
scheme/mpair
|
||||
r6rs/private/parse-ref)
|
||||
|
||||
(provide (rename-out [r6rs:eval eval])
|
||||
|
|
@ -8,20 +10,39 @@
|
|||
|
||||
(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)
|
||||
(eval #`(#%expression #,expr) env))
|
||||
(eval #`(#%expression #,(datum->syntax #f (mpair->pair expr))) env))
|
||||
|
||||
(define (environment . specs)
|
||||
(let ([mod-paths
|
||||
(let ([reqs
|
||||
(map (lambda (spec)
|
||||
`(lib ,(parse-library-reference
|
||||
spec
|
||||
(lambda (msg)
|
||||
(error 'environment "~a: ~e" msg spec)))))
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#f
|
||||
(parse-import
|
||||
#'here
|
||||
(mpair->pair spec)
|
||||
(lambda (msg orig stx)
|
||||
(error 'environment "~a: ~e" msg spec))))))
|
||||
specs)])
|
||||
(let ([ns (namespace-anchor->empty-namespace anchor)])
|
||||
;; Make sure all modules are instantiated here:
|
||||
(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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -15,6 +15,135 @@
|
|||
|
||||
(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
24
collects/tests/r6rs/eval.ss
Normal 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
30
collects/tests/r6rs/mutable-pairs.ss
Normal 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
24
collects/tests/r6rs/mutable-strings.ss
Normal 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
63
collects/tests/r6rs/r5rs.ss
Normal 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)
|
||||
;;
|
||||
))
|
||||
|
||||
|
|
@ -18,7 +18,11 @@
|
|||
(tests r6rs arithmetic bitwise)
|
||||
(tests r6rs syntax-case)
|
||||
(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)
|
||||
|
||||
|
|
@ -38,6 +42,10 @@
|
|||
(run-syntax-case-tests)
|
||||
(run-hashtables-tests)
|
||||
(run-enums-tests)
|
||||
(run-eval-tests)
|
||||
(run-mutable-pairs-tests)
|
||||
(run-mutable-strings-tests)
|
||||
(run-r5rs-tests)
|
||||
|
||||
(report-test-results)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user