r6rs tests and repairs
svn: r8905
This commit is contained in:
Matthew Flatt
parent
9fb1397da6
commit
53bc658226
|
|
@ -10,8 +10,16 @@
|
|||
(provide fixnum?
|
||||
fixnum-width
|
||||
least-fixnum
|
||||
greatest-fixnum)
|
||||
;; Many other provides from macros below
|
||||
greatest-fixnum
|
||||
fxbit-set?
|
||||
fxcopy-bit
|
||||
fxcopy-bit-field
|
||||
fxarithmetic-shift
|
||||
fxarithmetic-shift-left
|
||||
fxarithmetic-shift-right
|
||||
fxrotate-bit-field
|
||||
fxreverse-bit-field)
|
||||
;; Many other provides from macros below
|
||||
|
||||
(define 64-bit? (fixnum? (expt 2 33)))
|
||||
|
||||
|
|
|
|||
|
|
@ -13,6 +13,9 @@
|
|||
|
||||
(provide (rename-out [inexact-real? flonum?])
|
||||
real->flonum
|
||||
flnumerator
|
||||
fldenominator
|
||||
fllog flsqrt flexpt
|
||||
&no-infinities make-no-infinities-violation no-infinities-violation?
|
||||
&no-nans make-no-nans-violation no-nans-violation?
|
||||
fixnum->flonum)
|
||||
|
|
@ -53,15 +56,40 @@
|
|||
(define-fl div0 fldiv0 (a b) nocheck)
|
||||
(define-fl mod0 flmod0 (a b) nocheck)
|
||||
|
||||
(define-fl numerator flnumerator (a) nocheck)
|
||||
(define-fl denominator fldenominator (a) nocheck)
|
||||
(define (flnumerator c)
|
||||
(if (inexact-real? c)
|
||||
(if (and (rational? c)
|
||||
(not (equal? c -0.0)))
|
||||
(numerator c)
|
||||
c)
|
||||
(raise-type-error 'flnumerator "flonum" c)))
|
||||
|
||||
(define (fldenominator c)
|
||||
(if (inexact-real? c)
|
||||
(if (rational? c)
|
||||
(denominator c)
|
||||
1.0)
|
||||
(raise-type-error 'fldenominator "flonum" c)))
|
||||
|
||||
(define-fl floor flfloor (a) nocheck)
|
||||
(define-fl ceiling flceiling (a) nocheck)
|
||||
(define-fl truncate fltruncate (a) nocheck)
|
||||
(define-fl round flround (a) nocheck)
|
||||
|
||||
(define-fl exp flexp (a) nocheck)
|
||||
(define-fl log fllog [(a) (a b)] nocheck)
|
||||
|
||||
(define fllog
|
||||
(case-lambda
|
||||
[(v)
|
||||
(unless (inexact-real? v)
|
||||
(raise-type-error 'fllog "flonum" v))
|
||||
(let ([v (log v)])
|
||||
(if (inexact-real? v)
|
||||
v
|
||||
+nan.0))]
|
||||
[(v1 v2)
|
||||
(/ (fllog v1) (fllog v2))]))
|
||||
|
||||
(define-fl sin flsin (a) nocheck)
|
||||
(define-fl cos flcos (a) nocheck)
|
||||
(define-fl tan fltan (a) nocheck)
|
||||
|
|
@ -69,9 +97,23 @@
|
|||
(define-fl acos flacos (a) nocheck)
|
||||
(define-fl atan flatan [(a) (a b)] nocheck)
|
||||
|
||||
(define-fl sqrt flsqrt (a) nocheck)
|
||||
(define (flsqrt v)
|
||||
(unless (inexact-real? v)
|
||||
(raise-type-error 'flsqrt "flonum" v))
|
||||
(let ([v (sqrt v)])
|
||||
(if (inexact-real? v)
|
||||
v
|
||||
+nan.0)))
|
||||
|
||||
(define-fl expt flexpt (a b) nocheck)
|
||||
(define (flexpt a b)
|
||||
(unless (inexact-real? a)
|
||||
(raise-type-error 'flexpt "flonum" a))
|
||||
(unless (inexact-real? b)
|
||||
(raise-type-error 'flexpt "flonum" b))
|
||||
(let ([v (expt a b)])
|
||||
(if (inexact-real? v)
|
||||
v
|
||||
+nan.0)))
|
||||
|
||||
(define-condition-type &no-infinities
|
||||
&implementation-restriction
|
||||
|
|
|
|||
|
|
@ -455,17 +455,20 @@
|
|||
[else (datum->syntax stx r stx)]))
|
||||
|
||||
(define-for-syntax (wrap-as-needed v)
|
||||
(if (and (procedure? v)
|
||||
(procedure-arity-includes? v 1))
|
||||
(procedure-reduce-arity
|
||||
(case-lambda
|
||||
[(stx) (if (syntax? stx)
|
||||
(let ([r (v stx)])
|
||||
(wrap r stx))
|
||||
(v stx))]
|
||||
[args (apply v args)])
|
||||
(procedure-arity v))
|
||||
v))
|
||||
(cond
|
||||
[(and (procedure? v)
|
||||
(procedure-arity-includes? v 1))
|
||||
(procedure-reduce-arity
|
||||
(case-lambda
|
||||
[(stx) (if (syntax? stx)
|
||||
(let ([r (v stx)])
|
||||
(wrap r stx))
|
||||
(v stx))]
|
||||
[args (apply v args)])
|
||||
(procedure-arity v))]
|
||||
[(set!-transformer? v)
|
||||
(make-set!-transformer (wrap-as-needed (set!-transformer-procedure v)))]
|
||||
[else v]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -8,17 +8,17 @@
|
|||
(rename-out [bytes? bytevector?]
|
||||
[bytes-length bytevector-length]
|
||||
[bytes=? bytevector=?]
|
||||
[bytes-copy! bytevector-copy!]
|
||||
[bytes-copy bytevector-copy]
|
||||
[bytes-ref bytevector-u8-ref]
|
||||
[bytes-set! bytevector-u8-set!])
|
||||
bytevector-copy!
|
||||
bytevector->u8-list
|
||||
u8-list->bytevector
|
||||
make-bytevector
|
||||
bytevector-fill!
|
||||
bytevector-s8-ref
|
||||
bytevector-s8-set!
|
||||
|
||||
|
||||
bytevector-u16-ref
|
||||
bytevector-s16-ref
|
||||
bytevector-u16-native-ref
|
||||
|
|
@ -51,6 +51,11 @@
|
|||
bytevector-uint-set!
|
||||
bytevector-sint-set!
|
||||
|
||||
bytevector->uint-list
|
||||
bytevector->sint-list
|
||||
uint-list->bytevector
|
||||
sint-list->bytevector
|
||||
|
||||
string->utf8
|
||||
string->utf16
|
||||
string->utf32
|
||||
|
|
@ -65,6 +70,9 @@
|
|||
(endianness big)
|
||||
(endianness little)))
|
||||
|
||||
(define (bytevector-copy! src src-start target target-start k)
|
||||
(bytes-copy! target target-start src src-start (+ src-start k)))
|
||||
|
||||
(define (bytevector->u8-list bv)
|
||||
(list->mlist (bytes->list bv)))
|
||||
|
||||
|
|
@ -96,8 +104,8 @@
|
|||
(- v 256)
|
||||
v)))
|
||||
|
||||
(define (bytevector-s8-set! bytes k)
|
||||
(bytes-set! bytes (convert-fill 'bytevector-s8-set! k)))
|
||||
(define (bytevector-s8-set! bytes k v)
|
||||
(bytes-set! bytes k (convert-fill 'bytevector-s8-set! v)))
|
||||
|
||||
(define (check-endian endianness)
|
||||
(unless (or (eq? endianness 'little)
|
||||
|
|
@ -236,6 +244,43 @@
|
|||
n)])
|
||||
(bytevector-int-set! 'bytevector-uint-set! bstr k pos-n n endianness size (* size (sub1 8)))))
|
||||
|
||||
(define (bytevector->int-list who ref bv endianness size)
|
||||
(unless (bytes? bv)
|
||||
(raise-type-error who "bytevector" bv))
|
||||
(check-endian endianness)
|
||||
(unless (exact-positive-integer? size)
|
||||
(raise-type-error who "exact positive integer" size))
|
||||
(unless (zero? (modulo (bytes-length bv) size))
|
||||
(raise-mismatch-error who "bytevector length is not a mulitple of given size: " size))
|
||||
(list->mlist
|
||||
(for/list ([k (in-range 0 (bytes-length bv) size)])
|
||||
(ref bv k endianness size))))
|
||||
|
||||
(define (bytevector->uint-list bv endianness size)
|
||||
(bytevector->int-list 'bytevector->uint-list bytevector-uint-ref bv endianness size))
|
||||
|
||||
(define (bytevector->sint-list bv endianness size)
|
||||
(bytevector->int-list 'bytevector->sint-list bytevector-sint-ref bv endianness size))
|
||||
|
||||
(define (int-list->bytevector who signed? set l endianness size)
|
||||
(unless (list? l)
|
||||
(raise-type-error who "list" l))
|
||||
(check-endian endianness)
|
||||
(unless (exact-positive-integer? size)
|
||||
(raise-type-error who "exact positive integer" size))
|
||||
(let* ([len (length l)]
|
||||
[bv (make-bytes (* size len))])
|
||||
(for ([v (in-list l)]
|
||||
[k (in-naturals)])
|
||||
(set l k v endianness size))
|
||||
bv))
|
||||
|
||||
(define (uint-list->bytevector l endianness size)
|
||||
(int-list->bytevector 'uint-list->bytevector #f bytevector-uint-set! l endianness size))
|
||||
|
||||
(define (sint-list->bytevector l endianness size)
|
||||
(int-list->bytevector 'sint-list->bytevector #f bytevector-sint-set! l endianness size))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (string->utf8 str)
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
(require rnrs/records/syntactic-6
|
||||
rnrs/records/procedural-6
|
||||
r6rs/private/conds
|
||||
scheme/mpair
|
||||
(for-syntax scheme/base))
|
||||
|
||||
(provide &condition
|
||||
|
|
@ -45,7 +46,7 @@
|
|||
conds)
|
||||
(let ([conditions
|
||||
(apply append
|
||||
(map simple-conditions conds))])
|
||||
(map simple-conditions/list conds))])
|
||||
((if (ormap serious-condition? conditions)
|
||||
make-compound-condition:fail
|
||||
make-compound-condition)
|
||||
|
|
@ -65,7 +66,7 @@
|
|||
(let ([pred (record-predicate rtd)])
|
||||
(lambda (v)
|
||||
(and (condition? v)
|
||||
(ormap pred (simple-conditions v))))))
|
||||
(ormap pred (simple-conditions/list v))))))
|
||||
|
||||
(define (condition-accessor rtd proc)
|
||||
(let ([pred (record-predicate rtd)])
|
||||
|
|
@ -75,12 +76,12 @@
|
|||
(lambda (v)
|
||||
(let ([v (ormap (lambda (x)
|
||||
(and (pred x) x))
|
||||
(simple-conditions v))])
|
||||
(simple-conditions/list v))])
|
||||
(if v
|
||||
(proc v)
|
||||
(raise-type-error 'a-condition-accessor "specific kind of condition" v))))))
|
||||
|
||||
(define (simple-conditions c)
|
||||
(define (simple-conditions/list c)
|
||||
(cond
|
||||
[(&condition? c) (list c)]
|
||||
[(compound-condition? c)
|
||||
|
|
@ -138,6 +139,8 @@
|
|||
"condition"
|
||||
c)]))
|
||||
|
||||
(define (simple-conditions c)
|
||||
(list->mlist (simple-conditions/list c)))
|
||||
|
||||
(define-syntax (define-condition-type stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
enum-set-universe
|
||||
enum-set-indexer
|
||||
enum-set-constructor
|
||||
enum-set->list
|
||||
enum-set-member?
|
||||
enum-set-subset?
|
||||
enum-set=?
|
||||
|
|
@ -18,7 +19,8 @@
|
|||
enum-set-projection
|
||||
define-enumeration)
|
||||
|
||||
(define-struct enum-set (val ht))
|
||||
(define-struct universe (ht syms))
|
||||
(define-struct enum-set (val uni))
|
||||
|
||||
(define (make-enumeration-universe enum)
|
||||
(let ([bad (lambda ()
|
||||
|
|
@ -30,50 +32,55 @@
|
|||
(let ([enum (mlist->list enum)])
|
||||
(unless (andmap symbol? enum) (bad))
|
||||
(let ([ht (make-hash-table)])
|
||||
(for ([s (in-list enum)])
|
||||
(unless (hash-table-get ht s #f)
|
||||
(hash-table-put! ht s (arithmetic-shift 1 (hash-table-count ht)))))
|
||||
ht))))
|
||||
(make-universe
|
||||
ht
|
||||
(for/list ([s (in-list enum)]
|
||||
#:when (not (hash-table-get ht s #f)))
|
||||
(hash-table-put! ht s (arithmetic-shift 1 (hash-table-count ht)))
|
||||
s))))))
|
||||
|
||||
(define (make-enumeration enum)
|
||||
(let ([ht (make-enumeration-universe enum)])
|
||||
(make-enum-set (sub1 (arithmetic-shift 1 (hash-table-count ht)))
|
||||
ht)))
|
||||
(let ([uni (make-enumeration-universe enum)])
|
||||
(make-enum-set (sub1 (arithmetic-shift 1 (hash-table-count (universe-ht uni))))
|
||||
uni)))
|
||||
|
||||
(define (enum-set-universe enum)
|
||||
(unless (enum-set? enum)
|
||||
(raise-type-error 'enum-set-universe
|
||||
"enumeration set"
|
||||
enum))
|
||||
(let ([ht (enum-set-ht enum)])
|
||||
(make-enum-set (sub1 (arithmetic-shift 1 (hash-table-count ht))) ht)))
|
||||
(let ([uni (enum-set-uni enum)])
|
||||
(make-enum-set (sub1 (arithmetic-shift 1 (hash-table-count
|
||||
(universe-ht uni))))
|
||||
uni)))
|
||||
|
||||
(define (enum-set-indexer enum)
|
||||
(unless (enum-set? enum)
|
||||
(raise-type-error 'enum-set-indexer
|
||||
"enumeration set"
|
||||
enum))
|
||||
(let ([ht (enum-set-ht enum)])
|
||||
(let ([ht (universe-ht (enum-set-uni enum))])
|
||||
(lambda (sym)
|
||||
(let ([v (hash-table-get ht sym #f)])
|
||||
(if v
|
||||
(bitwise-first-bit-set v)
|
||||
(error 'generated-enum-set-indexer
|
||||
(if (symbol? sym)
|
||||
"symbol not in universe: ~e"
|
||||
"not a symbol: ~e")
|
||||
sym))))))
|
||||
(if (symbol? sym)
|
||||
#f
|
||||
(error 'generated-enum-set-indexer
|
||||
"not a symbol: ~e"
|
||||
sym)))))))
|
||||
|
||||
(define (enum-set-constructor enum)
|
||||
(unless (enum-set? enum)
|
||||
(raise-type-error 'enum-set-constructor
|
||||
"enumeration set"
|
||||
enum))
|
||||
(let ([ht (enum-set-ht enum)])
|
||||
(let* ([uni (enum-set-uni enum)]
|
||||
[ht (universe-ht uni)])
|
||||
(lambda (orig-syms)
|
||||
(let loop ([syms orig-syms][val 0])
|
||||
(cond
|
||||
[(null? syms) (make-enum-set val ht)]
|
||||
[(null? syms) (make-enum-set val uni)]
|
||||
[(not (mpair? syms))
|
||||
(raise-type-error 'make-enum-set
|
||||
"list of symbols"
|
||||
|
|
@ -88,6 +95,18 @@
|
|||
"not a symbol: ~e")
|
||||
(mcar syms))])))))
|
||||
|
||||
(define (enum-set->list enum)
|
||||
(unless (enum-set? enum)
|
||||
(raise-type-error 'enum-set->list
|
||||
"enumeration set"
|
||||
enum))
|
||||
(let ([v (enum-set-val enum)])
|
||||
(list->mlist
|
||||
(for/list ([sym (in-list (universe-syms (enum-set-uni enum)))]
|
||||
[i (in-naturals)]
|
||||
#:when (not (zero? (bitwise-and (arithmetic-shift 1 i) v))))
|
||||
sym))))
|
||||
|
||||
(define (enum-set-member? sym enum)
|
||||
(unless (symbol? sym)
|
||||
(raise-type-error 'enum-set-member?
|
||||
|
|
@ -97,7 +116,7 @@
|
|||
(raise-type-error 'enum-set-member?
|
||||
"enumeration set"
|
||||
enum))
|
||||
(let ([v (hash-table-get (enum-set-ht enum) sym #f)])
|
||||
(let ([v (hash-table-get (universe-ht (enum-set-uni enum)) sym #f)])
|
||||
(and v
|
||||
(not (zero? (bitwise-and v (enum-set-val enum)))))))
|
||||
|
||||
|
|
@ -112,15 +131,15 @@
|
|||
|
||||
(define (enum-set-subset? enum1 enum2)
|
||||
(check-2-enums 'enum-set-subset? enum1 enum2)
|
||||
(if (eq? (enum-set-ht enum1) (enum-set-ht enum2))
|
||||
(if (eq? (enum-set-uni enum1) (enum-set-uni enum2))
|
||||
(= (enum-set-val enum1)
|
||||
(bitwise-and (enum-set-val enum1) (enum-set-val enum2)))
|
||||
(let ([ht2 (enum-set-ht enum2)]
|
||||
(let ([ht2 (universe-ht (enum-set-uni enum2))]
|
||||
[v1 (enum-set-val enum1)]
|
||||
[v2 (enum-set-val enum2)])
|
||||
(for/fold ([sub? #t])
|
||||
(#:when sub?
|
||||
[(key1 val1) (in-hash-table (enum-set-ht enum1))])
|
||||
[(key1 val1) (in-hash-table (universe-ht (enum-set-uni enum1)))])
|
||||
(or (zero? (bitwise-and v1 val1))
|
||||
(let ([val2 (hash-table-get ht2 key1 #f)])
|
||||
(and val2
|
||||
|
|
@ -128,15 +147,15 @@
|
|||
|
||||
(define (enum-set=? enum1 enum2)
|
||||
(check-2-enums 'enum-set=? enum1 enum2)
|
||||
(if (eq? (enum-set-ht enum1) (enum-set-ht enum2))
|
||||
(if (eq? (enum-set-uni enum1) (enum-set-uni enum2))
|
||||
(= (enum-set-val enum1) (enum-set-val enum2))
|
||||
(and (enum-set-subset? enum1 enum2)
|
||||
(enum-set-subset? enum2 enum1))))
|
||||
|
||||
(define (check-2-enums/same who enum1 enum2)
|
||||
(check-2-enums who enum1 enum2)
|
||||
(unless (eq? (enum-set-ht enum1)
|
||||
(enum-set-ht enum2))
|
||||
(unless (eq? (enum-set-uni enum1)
|
||||
(enum-set-uni enum2))
|
||||
(error who
|
||||
"enumeration sets are not the same enumeration type: ~e ~e"
|
||||
enum1 enum2)))
|
||||
|
|
@ -145,20 +164,20 @@
|
|||
(check-2-enums/same 'enum-set-union enum1 enum2)
|
||||
(make-enum-set (bitwise-ior (enum-set-val enum1)
|
||||
(enum-set-val enum2))
|
||||
(enum-set-ht enum1)))
|
||||
(enum-set-uni enum1)))
|
||||
|
||||
(define (enum-set-intersection enum1 enum2)
|
||||
(check-2-enums/same 'enum-set-intersection enum1 enum2)
|
||||
(make-enum-set (bitwise-and (enum-set-val enum1)
|
||||
(enum-set-val enum2))
|
||||
(enum-set-ht enum1)))
|
||||
(enum-set-uni enum1)))
|
||||
|
||||
(define (enum-set-difference enum1 enum2)
|
||||
(check-2-enums/same 'enum-set-intersection enum1 enum2)
|
||||
(make-enum-set (- (enum-set-val enum1)
|
||||
(bitwise-and (enum-set-val enum1)
|
||||
(enum-set-val enum2)))
|
||||
(enum-set-ht enum1)))
|
||||
(enum-set-uni enum1)))
|
||||
|
||||
(define (enum-set-complement enum1)
|
||||
(unless (enum-set? enum1)
|
||||
|
|
@ -167,25 +186,27 @@
|
|||
enum1))
|
||||
(make-enum-set (bitwise-xor (sub1 (arithmetic-shift
|
||||
1
|
||||
(hash-table-count (enum-set-ht enum1))))
|
||||
(hash-table-count
|
||||
(universe-ht (enum-set-uni enum1)))))
|
||||
(enum-set-val enum1))
|
||||
(enum-set-ht enum1)))
|
||||
(enum-set-uni enum1)))
|
||||
|
||||
(define (enum-set-projection enum1 enum2)
|
||||
(check-2-enums 'enum-set-projection enum1 enum2)
|
||||
(let ([ht2 (enum-set-ht enum2)]
|
||||
[v1 (enum-set-val enum1)]
|
||||
[v2 (enum-set-val enum2)])
|
||||
(let* ([uni2 (enum-set-uni enum2)]
|
||||
[ht2 (universe-ht uni2)]
|
||||
[v1 (enum-set-val enum1)]
|
||||
[v2 (enum-set-val enum2)])
|
||||
(make-enum-set
|
||||
(for/fold ([val 0])
|
||||
([(key1 val1) (in-hash-table (enum-set-ht enum1))])
|
||||
([(key1 val1) (in-hash-table (universe-ht (enum-set-uni enum1)))])
|
||||
(if (zero? (bitwise-and v1 val1))
|
||||
val
|
||||
(let ([val2 (hash-table-get ht2 key1 #f)])
|
||||
(if val2
|
||||
(bitwise-ior val val2)
|
||||
val))))
|
||||
ht2)))
|
||||
uni2)))
|
||||
|
||||
(define-syntax (define-enumeration stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@
|
|||
native-transcoder
|
||||
;bytevector->string
|
||||
;string->bytevector
|
||||
(rename-out [eof eof-object])
|
||||
eof-object
|
||||
eof-object?
|
||||
port?
|
||||
port-transcoder
|
||||
|
|
@ -139,6 +139,8 @@
|
|||
(define (native-transcoder)
|
||||
utf8-transcoder)
|
||||
|
||||
(define (eof-object) eof)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (make-disconnectable-input-port port)
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
(require (prefix-in r6rs: rnrs/io/ports-6))
|
||||
|
||||
(provide (rename-out [eof eof-object])
|
||||
(provide (rename-out [r6rs:eof-object eof-object])
|
||||
eof-object?
|
||||
(rename-out [r6rs:call-with-input-file call-with-input-file]
|
||||
[r6rs:call-with-output-file call-with-output-file])
|
||||
|
|
|
|||
|
|
@ -331,25 +331,20 @@ otherwise.}
|
|||
@examples[(truncate 17/4) (truncate -17/4) (truncate 2.5) (truncate -2.5)]}
|
||||
|
||||
|
||||
@defproc[(numerator [x real?]) (or/c integer? (one-of/c +nan.0))]{
|
||||
Coreces @scheme[x] to an exact number, finds the numerator of the number
|
||||
@defproc[(numerator [q rational?]) integer?]{
|
||||
Coreces @scheme[q] to an exact number, finds the numerator of the number
|
||||
expressed in its simplest fractional form, and returns this number
|
||||
coerced to the exactness of @scheme[x]. An exception is when @scheme[x] is
|
||||
@scheme[+inf.0], @scheme[-inf.0], and @scheme[+nan.0], in which case
|
||||
@scheme[x] is returned.
|
||||
coerced to the exactness of @scheme[q].
|
||||
|
||||
@examples[(numerator 5) (numerator 34/8) (numerator 2.3) (numerator +inf.0)]}
|
||||
@examples[(numerator 5) (numerator 34/8) (numerator 2.3)]}
|
||||
|
||||
|
||||
@defproc[(denominator [x real?]) (or/c integer? (one-of/c +nan.0))]{
|
||||
Coreces @scheme[x] to an exact number, finds the numerator of the number
|
||||
@defproc[(denominator [q rational?]) integer?]{
|
||||
Coreces @scheme[q] to an exact number, finds the numerator of the number
|
||||
expressed in its simplest fractional form, and returns this number
|
||||
coerced to the exactness of @scheme[x]. Exceptions are when @scheme[x] is
|
||||
@scheme[+inf.0] or @scheme[-inf.0], in which case @scheme[1.0] is
|
||||
returned, or when @scheme[x] is @scheme[+nan.0], in which case
|
||||
@scheme[+nan.0] is returned.
|
||||
coerced to the exactness of @scheme[q].
|
||||
|
||||
@examples[(denominator 5) (denominator 34/8) (denominator 2.3) (denominator +inf.0)]}
|
||||
@examples[(denominator 5) (denominator 34/8) (denominator 2.3)]}
|
||||
|
||||
|
||||
@defproc[(rationalize [x real?][tolerance real?]) real?]{
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@
|
|||
"plai"
|
||||
"plot"
|
||||
"profj"
|
||||
"r6rs"
|
||||
"srfi"
|
||||
"srpersist"
|
||||
"stepper"
|
||||
|
|
|
|||
25
collects/tests/r6rs/arithmetic/bitwise.ss
Normal file
25
collects/tests/r6rs/arithmetic/bitwise.ss
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
#!r6rs
|
||||
|
||||
(library (tests r6rs arithmetic bitwise)
|
||||
(export run-arithmetic-bitwise-tests)
|
||||
(import (rnrs)
|
||||
(tests r6rs test))
|
||||
|
||||
(define (run-arithmetic-bitwise-tests)
|
||||
|
||||
(test (bitwise-first-bit-set 0) -1)
|
||||
(test (bitwise-first-bit-set 1) 0)
|
||||
(test (bitwise-first-bit-set -4) 2)
|
||||
|
||||
(test (bitwise-arithmetic-shift -6 -1) -3)
|
||||
(test (bitwise-arithmetic-shift -5 -1) -3)
|
||||
(test (bitwise-arithmetic-shift -4 -1) -2)
|
||||
(test (bitwise-arithmetic-shift -3 -1) -2)
|
||||
(test (bitwise-arithmetic-shift -2 -1) -1)
|
||||
(test (bitwise-arithmetic-shift -1 -1) -1)
|
||||
|
||||
(test (bitwise-reverse-bit-field #b1010010 1 4) 88) ; #b1011000
|
||||
|
||||
;;
|
||||
))
|
||||
|
||||
20
collects/tests/r6rs/arithmetic/fixnums.ss
Normal file
20
collects/tests/r6rs/arithmetic/fixnums.ss
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
#!r6rs
|
||||
|
||||
(library (tests r6rs arithmetic fixnums)
|
||||
(export run-arithmetic-fixnums-tests)
|
||||
(import (rnrs)
|
||||
(tests r6rs test))
|
||||
|
||||
(define (run-arithmetic-fixnums-tests)
|
||||
|
||||
(test/exn (fx- (least-fixnum)) &implementation-restriction)
|
||||
|
||||
(test (fxfirst-bit-set 0) -1)
|
||||
(test (fxfirst-bit-set 1) 0)
|
||||
(test (fxfirst-bit-set -4) 2)
|
||||
|
||||
(test (fxreverse-bit-field #b1010010 1 4) 88) ; #b1011000
|
||||
|
||||
;;
|
||||
))
|
||||
|
||||
74
collects/tests/r6rs/arithmetic/flonums.ss
Normal file
74
collects/tests/r6rs/arithmetic/flonums.ss
Normal file
|
|
@ -0,0 +1,74 @@
|
|||
#!r6rs
|
||||
|
||||
(library (tests r6rs arithmetic flonums)
|
||||
(export run-arithmetic-flonums-tests)
|
||||
(import (rnrs)
|
||||
(tests r6rs test))
|
||||
|
||||
(define (try-flonums proc)
|
||||
(proc 0.0)
|
||||
(proc 1.0)
|
||||
(proc -1.0)
|
||||
(proc +inf.0)
|
||||
(proc -inf.0)
|
||||
(proc +nan.0))
|
||||
|
||||
(define (run-arithmetic-flonums-tests)
|
||||
|
||||
(test (fl=? +inf.0 +inf.0) #t)
|
||||
(test (fl=? -inf.0 +inf.0) #f)
|
||||
(test (fl=? -inf.0 -inf.0) #t)
|
||||
(test (fl=? 0.0 -0.0) #t)
|
||||
(test (fl<? 0.0 -0.0) #f)
|
||||
(try-flonums
|
||||
(lambda (fl)
|
||||
(test (fl=? +nan.0 fl) #f)
|
||||
(test (fl<? +nan.0 fl) #f)))
|
||||
|
||||
(test (flnegative? -0.0) #f)
|
||||
(test (flfinite? +inf.0) #f)
|
||||
(test (flfinite? 5.0) #t)
|
||||
(test (flinfinite? 5.0) #f)
|
||||
(test (flinfinite? +inf.0) #t)
|
||||
|
||||
(test (fl+ +inf.0 -inf.0) +nan.0)
|
||||
(try-flonums
|
||||
(lambda (fl)
|
||||
(test (fl+ +nan.0 fl) +nan.0)
|
||||
(test (fl* +nan.0 fl) +nan.0)))
|
||||
|
||||
(test (fl- +inf.0 +inf.0) +nan.0)
|
||||
|
||||
(test (fl/ 1.0 0.0) +inf.0)
|
||||
(test (fl/ -1.0 0.0) -inf.0)
|
||||
(test (fl/ 0.0 0.0) +nan.0)
|
||||
|
||||
(test (flnumerator +inf.0) +inf.0)
|
||||
(test (flnumerator -inf.0) -inf.0)
|
||||
(test (fldenominator +inf.0) 1.0)
|
||||
(test (fldenominator -inf.0) 1.0)
|
||||
|
||||
; (test (flnumerator 0.75) 3.0) ; probably
|
||||
; (test (fldenominator 0.75) 4.0) ; probably
|
||||
|
||||
(test (flnumerator -0.0) -0.0)
|
||||
|
||||
(test (flfloor +inf.0) +inf.0)
|
||||
(test (flceiling -inf.0) -inf.0)
|
||||
(test (fltruncate +nan.0) +nan.0)
|
||||
|
||||
(test (flexp +inf.0) +inf.0)
|
||||
(test (flexp -inf.0) 0.0)
|
||||
(test (fllog +inf.0) +inf.0)
|
||||
(test (fllog 0.0) -inf.0)
|
||||
(test/unspec (fllog -0.0)) ; if -0.0 is distinguished
|
||||
(test (fllog -inf.0) +nan.0)
|
||||
(test/approx (flatan -inf.0) -1.5707963267948965)
|
||||
(test/approx (flatan +inf.0) 1.5707963267948965)
|
||||
|
||||
(test (flsqrt +inf.0) +inf.0)
|
||||
(test (flsqrt -0.0) -0.0)
|
||||
|
||||
;;
|
||||
))
|
||||
|
||||
109
collects/tests/r6rs/bytevectors.ss
Normal file
109
collects/tests/r6rs/bytevectors.ss
Normal file
|
|
@ -0,0 +1,109 @@
|
|||
#!r6rs
|
||||
|
||||
(library (tests r6rs bytevectors)
|
||||
(export run-bytevectors-tests)
|
||||
(import (rnrs)
|
||||
(tests r6rs test))
|
||||
|
||||
(define (run-bytevectors-tests)
|
||||
|
||||
(test (let ((b (u8-list->bytevector '(1 2 3 4 5 6 7 8))))
|
||||
(bytevector-copy! b 0 b 3 4)
|
||||
(bytevector->u8-list b))
|
||||
'(1 2 3 1 2 3 4 8))
|
||||
|
||||
(test (let ((b1 (make-bytevector 16 -127))
|
||||
(b2 (make-bytevector 16 255)))
|
||||
(list
|
||||
(bytevector-s8-ref b1 0)
|
||||
(bytevector-u8-ref b1 0)
|
||||
(bytevector-s8-ref b2 0)
|
||||
(bytevector-u8-ref b2 0)))
|
||||
'(-127 129 -1 255))
|
||||
|
||||
(test (let ((b (make-bytevector 16 -127)))
|
||||
|
||||
(bytevector-s8-set! b 0 -126)
|
||||
(bytevector-u8-set! b 1 246)
|
||||
|
||||
(list
|
||||
(bytevector-s8-ref b 0)
|
||||
(bytevector-u8-ref b 0)
|
||||
(bytevector-s8-ref b 1)
|
||||
(bytevector-u8-ref b 1)))
|
||||
'(-126 130 -10 246))
|
||||
|
||||
(let ([b (make-bytevector 16 -127)])
|
||||
(test/unspec
|
||||
(bytevector-uint-set! b 0 (- (expt 2 128) 3)
|
||||
(endianness little) 16))
|
||||
|
||||
(test (bytevector-uint-ref b 0 (endianness little) 16)
|
||||
#xfffffffffffffffffffffffffffffffd)
|
||||
|
||||
(test (bytevector-sint-ref b 0 (endianness little) 16)
|
||||
-3)
|
||||
|
||||
(test (bytevector->u8-list b)
|
||||
'(253 255 255 255 255 255 255 255
|
||||
255 255 255 255 255 255 255 255))
|
||||
|
||||
(test/unspec (bytevector-uint-set! b 0 (- (expt 2 128) 3)
|
||||
(endianness big) 16))
|
||||
(test (bytevector-uint-ref b 0 (endianness big) 16)
|
||||
#xfffffffffffffffffffffffffffffffd)
|
||||
|
||||
(test (bytevector-sint-ref b 0 (endianness big) 16) -3)
|
||||
|
||||
(test (bytevector->u8-list b)
|
||||
'(255 255 255 255 255 255 255 255
|
||||
255 255 255 255 255 255 255 253))
|
||||
|
||||
(test
|
||||
(let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
|
||||
(bytevector->sint-list b (endianness little) 2))
|
||||
'(513 -253 513 513))
|
||||
|
||||
(test (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
|
||||
(bytevector->uint-list b (endianness little) 2))
|
||||
'(513 65283 513 513)))
|
||||
|
||||
(let ([b (u8-list->bytevector
|
||||
'(255 255 255 255 255 255 255 255
|
||||
255 255 255 255 255 255 255 253))])
|
||||
|
||||
(test (bytevector-u16-ref b 14 (endianness little)) 65023)
|
||||
(test (bytevector-s16-ref b 14 (endianness little)) -513)
|
||||
(test (bytevector-u16-ref b 14 (endianness big)) 65533)
|
||||
(test (bytevector-s16-ref b 14 (endianness big)) -3)
|
||||
|
||||
(test/unspec (bytevector-u16-set! b 0 12345 (endianness little)))
|
||||
(test (bytevector-u16-ref b 0 (endianness little)) 12345)
|
||||
|
||||
(test/unspec (bytevector-u16-native-set! b 0 12345))
|
||||
(test (bytevector-u16-native-ref b 0) 12345)
|
||||
|
||||
(test/unspec (bytevector-u16-ref b 0 (endianness little))))
|
||||
|
||||
(let ([b (u8-list->bytevector
|
||||
'(255 255 255 255 255 255 255 255
|
||||
255 255 255 255 255 255 255 253))])
|
||||
|
||||
(test (bytevector-u32-ref b 12 (endianness little)) 4261412863)
|
||||
(test (bytevector-s32-ref b 12 (endianness little)) -33554433)
|
||||
(test (bytevector-u32-ref b 12 (endianness big)) 4294967293)
|
||||
(test (bytevector-s32-ref b 12 (endianness big)) -3))
|
||||
|
||||
(let ([b (u8-list->bytevector
|
||||
'(255 255 255 255 255 255 255 255
|
||||
255 255 255 255 255 255 255 253))])
|
||||
(test (bytevector-u64-ref b 8 (endianness little)) 18302628885633695743)
|
||||
(test (bytevector-s64-ref b 8 (endianness little)) -144115188075855873)
|
||||
(test (bytevector-u64-ref b 8 (endianness big)) 18446744073709551613)
|
||||
(test (bytevector-s64-ref b 8 (endianness big)) -3))
|
||||
|
||||
;;
|
||||
))
|
||||
|
||||
|
||||
|
||||
124
collects/tests/r6rs/conditions.ss
Normal file
124
collects/tests/r6rs/conditions.ss
Normal file
|
|
@ -0,0 +1,124 @@
|
|||
#!r6rs
|
||||
|
||||
(library (tests r6rs conditions)
|
||||
(export run-conditions-tests)
|
||||
(import (rnrs)
|
||||
(tests r6rs test))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-record-type (&cond1 make-cond1 real-cond1?)
|
||||
(parent &condition)
|
||||
(fields
|
||||
(immutable x real-cond1-x)))
|
||||
|
||||
(define cond1?
|
||||
(condition-predicate
|
||||
(record-type-descriptor &cond1)))
|
||||
(define cond1-x
|
||||
(condition-accessor
|
||||
(record-type-descriptor &cond1)
|
||||
real-cond1-x))
|
||||
|
||||
(define foo (make-cond1 'foo))
|
||||
|
||||
(define-record-type (&cond2 make-cond2 real-cond2?)
|
||||
(parent &condition)
|
||||
(fields
|
||||
(immutable y real-cond2-y)))
|
||||
|
||||
(define cond2?
|
||||
(condition-predicate
|
||||
(record-type-descriptor &cond2)))
|
||||
(define cond2-y
|
||||
(condition-accessor
|
||||
(record-type-descriptor &cond2)
|
||||
real-cond2-y))
|
||||
|
||||
(define bar (make-cond2 'bar))
|
||||
|
||||
(define-condition-type &c &condition
|
||||
make-c c?
|
||||
(x c-x))
|
||||
|
||||
(define-condition-type &c1 &c
|
||||
make-c1 c1?
|
||||
(a c1-a))
|
||||
|
||||
(define-condition-type &c2 &c
|
||||
make-c2 c2?
|
||||
(b c2-b))
|
||||
|
||||
(define v1 (make-c1 "V1" "a1"))
|
||||
|
||||
(define v2 (make-c2 "V2" "b2"))
|
||||
|
||||
(define v3 (condition
|
||||
(make-c1 "V3/1" "a3")
|
||||
(make-c2 "V3/2" "b3")))
|
||||
|
||||
(define v4 (condition v1 v2))
|
||||
|
||||
(define v5 (condition v2 v3))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (run-conditions-tests)
|
||||
|
||||
(test (condition? foo) #t)
|
||||
(test (cond1? foo) #t)
|
||||
(test (cond1-x foo) 'foo)
|
||||
|
||||
(test (condition? (condition foo bar)) #t)
|
||||
(test (cond1? (condition foo bar)) #t)
|
||||
(test (cond2? (condition foo bar)) #t)
|
||||
(test (cond1? (condition foo)) #t)
|
||||
(test/unspec (real-cond1? (condition foo)))
|
||||
(test (real-cond1? (condition foo bar)) #f)
|
||||
(test (cond1-x (condition foo bar)) 'foo)
|
||||
(test (cond2-y (condition foo bar)) 'bar)
|
||||
|
||||
(test (simple-conditions (condition foo bar))
|
||||
(list foo bar))
|
||||
|
||||
(test (simple-conditions
|
||||
(condition foo (condition bar)))
|
||||
(list foo bar))
|
||||
|
||||
(test (c? v1) #t)
|
||||
(test (c1? v1) #t)
|
||||
(test (c2? v1) #f)
|
||||
(test (c-x v1) "V1")
|
||||
(test (c1-a v1) "a1")
|
||||
|
||||
(test (c? v2) #t)
|
||||
(test (c1? v2) #f)
|
||||
(test (c2? v2) #t)
|
||||
(test (c-x v2) "V2")
|
||||
(test (c2-b v2) "b2")
|
||||
|
||||
(test (c? v3) #t)
|
||||
(test (c1? v3) #t)
|
||||
(test (c2? v3) #t)
|
||||
(test (c-x v3) "V3/1")
|
||||
(test (c1-a v3) "a3")
|
||||
(test (c2-b v3) "b3")
|
||||
|
||||
(test (c? v4) #t)
|
||||
(test (c1? v4) #t)
|
||||
(test (c2? v4) #t)
|
||||
(test (c-x v4) "V1")
|
||||
(test (c1-a v4) "a1")
|
||||
(test (c2-b v4) "b2")
|
||||
|
||||
(test (c? v5) #t)
|
||||
(test (c1? v5) #t)
|
||||
(test (c2? v5) #t)
|
||||
(test (c-x v5) "V2")
|
||||
(test (c1-a v5) "a3")
|
||||
(test (c2-b v5) "b2")
|
||||
|
||||
|
||||
;;
|
||||
))
|
||||
|
||||
43
collects/tests/r6rs/control.ss
Normal file
43
collects/tests/r6rs/control.ss
Normal file
|
|
@ -0,0 +1,43 @@
|
|||
#!r6rs
|
||||
|
||||
(library (tests r6rs control)
|
||||
(export run-control-tests)
|
||||
(import (rnrs)
|
||||
(tests r6rs test))
|
||||
|
||||
(define (run-control-tests)
|
||||
|
||||
(test (when (> 3 2) 'greater) 'greater)
|
||||
(test/unspec (when (< 3 2) 'greater))
|
||||
(test/unspec (unless (> 3 2) 'less))
|
||||
(test (unless (< 3 2) 'less) 'less)
|
||||
|
||||
(test (do ((vec (make-vector 5))
|
||||
(i 0 (+ i 1)))
|
||||
((= i 5) vec)
|
||||
(vector-set! vec i i))
|
||||
'#(0 1 2 3 4))
|
||||
|
||||
(test (let ((x '(1 3 5 7 9)))
|
||||
(do ((x x (cdr x))
|
||||
(sum 0 (+ sum (car x))))
|
||||
((null? x) sum)))
|
||||
25)
|
||||
|
||||
(let ([foo
|
||||
(case-lambda
|
||||
(() 'zero)
|
||||
((x) (list 'one x))
|
||||
((x y) (list 'two x y))
|
||||
((a b c d . e) (list 'four a b c d e))
|
||||
(rest (list 'rest rest)))])
|
||||
|
||||
(test (foo) 'zero)
|
||||
(test (foo 1) '(one 1))
|
||||
(test (foo 1 2) '(two 1 2))
|
||||
(test (foo 1 2 3) '(rest (1 2 3)))
|
||||
(test (foo 1 2 3 4) '(four 1 2 3 4 ())))
|
||||
|
||||
;;
|
||||
))
|
||||
|
||||
63
collects/tests/r6rs/enums.ss
Normal file
63
collects/tests/r6rs/enums.ss
Normal file
|
|
@ -0,0 +1,63 @@
|
|||
#!r6rs
|
||||
|
||||
(library (tests r6rs enums)
|
||||
(export run-enums-tests)
|
||||
(import (rnrs)
|
||||
(tests r6rs test))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-enumeration color
|
||||
(black white purple maroon)
|
||||
color-set)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (run-enums-tests)
|
||||
|
||||
(test (let* ((e (make-enumeration '(red green blue)))
|
||||
(i (enum-set-indexer e)))
|
||||
(list (i 'red) (i 'green) (i 'blue) (i 'yellow)))
|
||||
'(0 1 2 #f))
|
||||
|
||||
(test (let* ((e (make-enumeration '(red green blue)))
|
||||
(c (enum-set-constructor e)))
|
||||
(enum-set->list (c '(blue red))))
|
||||
'(red blue))
|
||||
|
||||
(test (let* ((e (make-enumeration '(red green blue)))
|
||||
(c (enum-set-constructor e)))
|
||||
(list (enum-set->list
|
||||
(enum-set-union (c '(blue)) (c '(red))))
|
||||
(enum-set->list
|
||||
(enum-set-intersection (c '(red green))
|
||||
(c '(red blue))))
|
||||
(enum-set->list
|
||||
(enum-set-difference (c '(red green))
|
||||
(c '(red blue))))))
|
||||
'((red blue) (red) (green)))
|
||||
|
||||
(test (let* ((e (make-enumeration '(red green blue)))
|
||||
(c (enum-set-constructor e)))
|
||||
(enum-set->list
|
||||
(enum-set-complement (c '(red)))))
|
||||
'(green blue))
|
||||
|
||||
(test (let ((e1 (make-enumeration
|
||||
'(red green blue black)))
|
||||
(e2 (make-enumeration
|
||||
'(red black white))))
|
||||
(enum-set->list
|
||||
(enum-set-projection e1 e2)))
|
||||
'(red black))
|
||||
|
||||
(test (color black) 'black)
|
||||
; (test/exn (color purpel) &syntax) ; not a runtime exception
|
||||
(test (enum-set->list (color-set)) '())
|
||||
(test (enum-set->list
|
||||
(color-set maroon white))
|
||||
'(white maroon))
|
||||
|
||||
;;
|
||||
))
|
||||
|
||||
74
collects/tests/r6rs/exceptions.ss
Normal file
74
collects/tests/r6rs/exceptions.ss
Normal file
|
|
@ -0,0 +1,74 @@
|
|||
#!r6rs
|
||||
|
||||
(library (tests r6rs exceptions)
|
||||
(export run-exceptions-tests)
|
||||
(import (rnrs)
|
||||
(tests r6rs test))
|
||||
|
||||
(define (run-exceptions-tests)
|
||||
|
||||
(test/output
|
||||
(guard (con
|
||||
((error? con)
|
||||
(if (message-condition? con)
|
||||
(display (condition-message con))
|
||||
(display "an error has occurred"))
|
||||
'error)
|
||||
((violation? con)
|
||||
(if (message-condition? con)
|
||||
(display (condition-message con))
|
||||
(display "the program has a bug"))
|
||||
'violation))
|
||||
(raise
|
||||
(condition
|
||||
(make-error)
|
||||
(make-message-condition "I am an error"))))
|
||||
'error
|
||||
"I am an error")
|
||||
|
||||
(test/exn
|
||||
(guard (con
|
||||
((error? con)
|
||||
(if (message-condition? con)
|
||||
(display (condition-message con))
|
||||
(display "an error has occurred"))
|
||||
'error))
|
||||
(raise
|
||||
(condition
|
||||
(make-violation)
|
||||
(make-message-condition "I am an error"))))
|
||||
&violation)
|
||||
|
||||
(test/output
|
||||
(guard (con
|
||||
((error? con)
|
||||
(display "error opening file")
|
||||
#f))
|
||||
(call-with-input-file "foo-must-not-exist.scm" read))
|
||||
#f
|
||||
"error opening file")
|
||||
|
||||
(test/output
|
||||
(with-exception-handler
|
||||
(lambda (con)
|
||||
(cond
|
||||
((not (warning? con))
|
||||
(raise con))
|
||||
((message-condition? con)
|
||||
(display (condition-message con)))
|
||||
(else
|
||||
(display "a warning has been issued")))
|
||||
42)
|
||||
(lambda ()
|
||||
(+ (raise-continuable
|
||||
(condition
|
||||
(make-warning)
|
||||
(make-message-condition
|
||||
"should be a number")))
|
||||
23)))
|
||||
65
|
||||
"should be a number")
|
||||
|
||||
;;
|
||||
))
|
||||
|
||||
31
collects/tests/r6rs/hashtables.ss
Normal file
31
collects/tests/r6rs/hashtables.ss
Normal file
|
|
@ -0,0 +1,31 @@
|
|||
#!r6rs
|
||||
|
||||
(library (tests r6rs hashtables)
|
||||
(export run-hashtables-tests)
|
||||
(import (rnrs)
|
||||
(tests r6rs test))
|
||||
|
||||
(define (run-hashtables-tests)
|
||||
|
||||
(let-values ([(kv vv)
|
||||
(let ((h (make-eqv-hashtable)))
|
||||
(hashtable-set! h 1 'one)
|
||||
(hashtable-set! h 2 'two)
|
||||
(hashtable-set! h 3 'three)
|
||||
(hashtable-entries h))])
|
||||
(test (or (equal? (cons kv vv)
|
||||
'(#(1 2 3) . #(one two three)))
|
||||
(equal? (cons kv vv)
|
||||
'(#(1 3 2) . #(one three two)))
|
||||
(equal? (cons kv vv)
|
||||
'(#(2 1 3) . #(two one three)))
|
||||
(equal? (cons kv vv)
|
||||
'(#(2 3 1) . #(two three one)))
|
||||
(equal? (cons kv vv)
|
||||
'(#(3 1 2) . #(three one two)))
|
||||
(equal? (cons kv vv)
|
||||
'(#(3 2 1) . #(three two one))))
|
||||
#t))
|
||||
;;
|
||||
))
|
||||
|
||||
15
collects/tests/r6rs/io/ports.ss
Normal file
15
collects/tests/r6rs/io/ports.ss
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
#!r6rs
|
||||
|
||||
(library (tests r6rs io ports)
|
||||
(export run-io-ports-tests)
|
||||
(import (rnrs)
|
||||
(tests r6rs test))
|
||||
|
||||
(define (run-io-ports-tests)
|
||||
|
||||
(test (eqv? (eof-object) (eof-object)) #t)
|
||||
(test (eq? (eof-object) (eof-object)) #t)
|
||||
|
||||
;;
|
||||
))
|
||||
|
||||
109
collects/tests/r6rs/lists.ss
Normal file
109
collects/tests/r6rs/lists.ss
Normal file
|
|
@ -0,0 +1,109 @@
|
|||
#!r6rs
|
||||
|
||||
(library (tests r6rs lists)
|
||||
(export run-lists-tests)
|
||||
(import (rnrs)
|
||||
(tests r6rs test))
|
||||
|
||||
(define (run-lists-tests)
|
||||
|
||||
(test (find even? '(3 1 4 1 5 9)) 4)
|
||||
(test (find even? '(3 1 5 1 5 9)) #f)
|
||||
|
||||
(test (for-all even? '(3 1 4 1 5 9)) #f)
|
||||
(test (for-all even? '(3 1 4 1 5 9 . 2)) #f)
|
||||
(test (for-all even? '(2 4 14)) #t)
|
||||
(test/exn (for-all even? '(2 4 14 . 9)) &assertion)
|
||||
(test (for-all (lambda (n) (and (even? n) n))
|
||||
'(2 4 14))
|
||||
14)
|
||||
(test (for-all < '(1 2 3) '(2 3 4)) #t)
|
||||
(test (for-all < '(1 2 4) '(2 3 4)) #f)
|
||||
|
||||
(test (exists even? '(3 1 4 1 5 9)) #t)
|
||||
(test (exists even? '(3 1 1 5 9)) #f)
|
||||
(test/exn (exists even? '(3 1 1 5 9 . 2)) &assertion)
|
||||
(test (exists (lambda (n) (and (even? n) n)) '(2 1 4 14)) 2)
|
||||
(test (exists < '(1 2 4) '(2 3 4)) #t)
|
||||
(test (exists > '(1 2 3) '(2 3 4)) #f)
|
||||
|
||||
(test (filter even? '(3 1 4 1 5 9 2 6)) '(4 2 6))
|
||||
|
||||
(test/values (partition even? '(3 1 4 1 5 9 2 6)) '(4 2 6) '(3 1 1 5 9))
|
||||
|
||||
(test (fold-left + 0 '(1 2 3 4 5)) 15)
|
||||
|
||||
(test (fold-left (lambda (a e) (cons e a)) '()
|
||||
'(1 2 3 4 5))
|
||||
'(5 4 3 2 1))
|
||||
|
||||
(test (fold-left (lambda (count x)
|
||||
(if (odd? x) (+ count 1) count))
|
||||
0
|
||||
'(3 1 4 1 5 9 2 6 5 3))
|
||||
7)
|
||||
(test (fold-left (lambda (max-len s)
|
||||
(max max-len (string-length s)))
|
||||
0
|
||||
'("longest" "long" "longer"))
|
||||
7)
|
||||
|
||||
(test (fold-left cons '(q) '(a b c)) '((((q) . a) . b) . c))
|
||||
|
||||
(test (fold-left + 0 '(1 2 3) '(4 5 6)) 21)
|
||||
|
||||
(test (fold-right + 0 '(1 2 3 4 5)) 15)
|
||||
|
||||
(test (fold-right cons '() '(1 2 3 4 5)) '(1 2 3 4 5))
|
||||
|
||||
(test (fold-right (lambda (x l)
|
||||
(if (odd? x) (cons x l) l))
|
||||
'()
|
||||
'(3 1 4 1 5 9 2 6 5))
|
||||
'(3 1 1 5 9 5))
|
||||
|
||||
(test (fold-right cons '(q) '(a b c)) '(a b c q))
|
||||
|
||||
(test (fold-right + 0 '(1 2 3) '(4 5 6)) 21)
|
||||
|
||||
(test (remp even? '(3 1 4 1 5 9 2 6 5)) '(3 1 1 5 9 5))
|
||||
|
||||
(test (remove 1 '(3 1 4 1 5 9 2 6 5)) '(3 4 5 9 2 6 5))
|
||||
|
||||
(test (remv 1 '(3 1 4 1 5 9 2 6 5)) '(3 4 5 9 2 6 5))
|
||||
|
||||
(test (remq 'foo '(bar foo baz)) '(bar baz))
|
||||
|
||||
(test (memp even? '(3 1 4 1 5 9 2 6 5)) '(4 1 5 9 2 6 5))
|
||||
|
||||
(test (memq 'a '(a b c)) '(a b c))
|
||||
(test (memq 'b '(a b c)) '(b c))
|
||||
(test (memq 'a '(b c d)) #f)
|
||||
(test (memq (list 'a) '(b (a) c)) #f)
|
||||
(test (member (list 'a) '(b (a) c)) '((a) c))
|
||||
(test/unspec (memq 101 '(100 101 102)))
|
||||
(test (memv 101 '(100 101 102)) '(101 102))
|
||||
|
||||
(let ([d '((3 a) (1 b) (4 c))])
|
||||
(test (assp even? d) '(4 c))
|
||||
(test (assp odd? d) '(3 a)))
|
||||
|
||||
(let ([e '((a 1) (b 2) (c 3))])
|
||||
(test (assq 'a e) '(a 1))
|
||||
(test (assq 'b e) '(b 2))
|
||||
(test (assq 'd e) #f))
|
||||
|
||||
|
||||
(test (assq (list 'a) '(((a)) ((b)) ((c))))
|
||||
#f)
|
||||
(test (assoc (list 'a) '(((a)) ((b)) ((c))))
|
||||
'((a)))
|
||||
(test/unspec (assq 5 '((2 3) (5 7) (11 13))))
|
||||
(test (assv 5 '((2 3) (5 7) (11 13))) '(5 7))
|
||||
|
||||
(test (cons* 1 2 '(3 4 5)) '(1 2 3 4 5))
|
||||
(test (cons* 1 2 3) '(1 2 . 3))
|
||||
(test (cons* 1) 1)
|
||||
|
||||
;;
|
||||
))
|
||||
166
collects/tests/r6rs/records/procedural.ss
Normal file
166
collects/tests/r6rs/records/procedural.ss
Normal file
|
|
@ -0,0 +1,166 @@
|
|||
#!r6rs
|
||||
|
||||
(library (tests r6rs records procedural)
|
||||
(export run-records-procedural-tests)
|
||||
(import (rnrs)
|
||||
(tests r6rs test))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define rtd1
|
||||
(make-record-type-descriptor
|
||||
'rtd1 #f #f #f #f
|
||||
'#((immutable x1) (immutable x2))))
|
||||
|
||||
(define rtd2
|
||||
(make-record-type-descriptor
|
||||
'rtd2 rtd1 #f #f #f
|
||||
'#((immutable x3) (immutable x4))))
|
||||
|
||||
(define rtd3
|
||||
(make-record-type-descriptor
|
||||
'rtd3 rtd2 #f #f #f
|
||||
'#((immutable x5) (immutable x6))))
|
||||
|
||||
(define protocol1
|
||||
(lambda (p)
|
||||
(lambda (a b c)
|
||||
(p (+ a b) (+ b c)))))
|
||||
|
||||
(define protocol2
|
||||
(lambda (n)
|
||||
(lambda (a b c d e f)
|
||||
(let ((p (n a b c)))
|
||||
(p (+ d e) (+ e f))))))
|
||||
|
||||
(define protocol3
|
||||
(lambda (n)
|
||||
(lambda (a b c d e f g h i)
|
||||
(let ((p (n a b c d e f)))
|
||||
(p (+ g h) (+ h i))))))
|
||||
|
||||
(define cd1
|
||||
(make-record-constructor-descriptor
|
||||
rtd1 #f protocol1))
|
||||
|
||||
(define cd2
|
||||
(make-record-constructor-descriptor
|
||||
rtd2 cd1 protocol2))
|
||||
|
||||
(define cd3
|
||||
(make-record-constructor-descriptor
|
||||
rtd3 cd2 protocol3))
|
||||
|
||||
(define make-rtd1 (record-constructor cd1))
|
||||
|
||||
(define make-rtd2 (record-constructor cd2))
|
||||
|
||||
(define make-rtd3 (record-constructor cd3))
|
||||
|
||||
|
||||
(define :point
|
||||
(make-record-type-descriptor
|
||||
'point #f
|
||||
#f #f #f
|
||||
'#((mutable x) (mutable y))))
|
||||
|
||||
(define :point-cd
|
||||
(make-record-constructor-descriptor :point #f #f))
|
||||
|
||||
(define make-point (record-constructor :point-cd))
|
||||
|
||||
(define point? (record-predicate :point))
|
||||
(define point-x (record-accessor :point 0))
|
||||
(define point-y (record-accessor :point 1))
|
||||
(define point-x-set! (record-mutator :point 0))
|
||||
(define point-y-set! (record-mutator :point 1))
|
||||
|
||||
(define p1 (make-point 1 2))
|
||||
|
||||
(define :point2
|
||||
(make-record-type-descriptor
|
||||
'point2 :point
|
||||
#f #f #f '#((mutable x) (mutable y))))
|
||||
|
||||
(define make-point2
|
||||
(record-constructor
|
||||
(make-record-constructor-descriptor :point2
|
||||
#f #f)))
|
||||
(define point2? (record-predicate :point2))
|
||||
(define point2-xx (record-accessor :point2 0))
|
||||
(define point2-yy (record-accessor :point2 1))
|
||||
|
||||
(define p2 (make-point2 1 2 3 4))
|
||||
|
||||
(define :point-cd/abs
|
||||
(make-record-constructor-descriptor
|
||||
:point #f
|
||||
(lambda (new)
|
||||
(lambda (x y)
|
||||
(new (abs x) (abs y))))))
|
||||
|
||||
(define make-point/abs
|
||||
(record-constructor :point-cd/abs))
|
||||
|
||||
(define :cpoint
|
||||
(make-record-type-descriptor
|
||||
'cpoint :point
|
||||
#f #f #f
|
||||
'#((mutable rgb))))
|
||||
|
||||
(define make-cpoint
|
||||
(record-constructor
|
||||
(make-record-constructor-descriptor
|
||||
:cpoint :point-cd
|
||||
(lambda (p)
|
||||
(lambda (x y c)
|
||||
((p x y) (color->rgb c)))))))
|
||||
|
||||
(define make-cpoint/abs
|
||||
(record-constructor
|
||||
(make-record-constructor-descriptor
|
||||
:cpoint :point-cd/abs
|
||||
(lambda (p)
|
||||
(lambda (x y c)
|
||||
((p x y) (color->rgb c)))))))
|
||||
|
||||
(define cpoint-rgb
|
||||
(record-accessor :cpoint 0))
|
||||
|
||||
(define (color->rgb c)
|
||||
(cons 'rgb c))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (run-records-procedural-tests)
|
||||
|
||||
(let ([r (make-rtd3 1 2 3 4 5 6 7 8 9)])
|
||||
(test ((record-accessor rtd1 0) r) 3)
|
||||
(test ((record-accessor rtd1 1) r) 5)
|
||||
(test ((record-accessor rtd2 0) r) 9)
|
||||
(test ((record-accessor rtd2 1) r) 11)
|
||||
(test ((record-accessor rtd3 0) r) 15)
|
||||
(test ((record-accessor rtd3 1) r) 17))
|
||||
|
||||
(test (point? p1) #t)
|
||||
(test (point-x p1) 1)
|
||||
(test (point-y p1) 2)
|
||||
(test/unspec (point-x-set! p1 5))
|
||||
(test (point-x p1) 5)
|
||||
|
||||
(test (point? p2) #t)
|
||||
(test (point-x p2) 1)
|
||||
(test (point-y p2) 2)
|
||||
(test (point2-xx p2) 3)
|
||||
(test (point2-yy p2) 4)
|
||||
|
||||
(test (point-x (make-point/abs -1 -2)) 1)
|
||||
(test (point-y (make-point/abs -1 -2)) 2)
|
||||
|
||||
(test (cpoint-rgb (make-cpoint -1 -3 'red)) '(rgb . red))
|
||||
(test (point-x (make-cpoint -1 -3 'red)) -1)
|
||||
(test (point-x (make-cpoint/abs -1 -3 'red)) 1)
|
||||
|
||||
;;
|
||||
))
|
||||
|
||||
114
collects/tests/r6rs/records/syntactic.ss
Normal file
114
collects/tests/r6rs/records/syntactic.ss
Normal file
|
|
@ -0,0 +1,114 @@
|
|||
#!r6rs
|
||||
|
||||
(library (tests r6rs records syntactic)
|
||||
(export run-records-syntactic-tests)
|
||||
(import (rnrs)
|
||||
(tests r6rs test))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-record-type (point make-point point?)
|
||||
(fields (immutable x point-x)
|
||||
(mutable y point-y set-point-y!))
|
||||
(nongenerative
|
||||
point-4893d957-e00b-11d9-817f-00111175eb9e))
|
||||
|
||||
(define-record-type (cpoint make-cpoint cpoint?)
|
||||
(parent point)
|
||||
(protocol
|
||||
(lambda (n)
|
||||
(lambda (x y c)
|
||||
((n x y) (color->rgb c)))))
|
||||
(fields
|
||||
(mutable rgb cpoint-rgb cpoint-rgb-set!)))
|
||||
|
||||
(define (color->rgb c)
|
||||
(cons 'rgb c))
|
||||
|
||||
(define p1 (make-point 1 2))
|
||||
(define p2 (make-cpoint 3 4 'red))
|
||||
|
||||
(define-record-type (ex1 make-ex1 ex1?)
|
||||
(protocol (lambda (p) (lambda a (p a))))
|
||||
(fields (immutable f ex1-f)))
|
||||
|
||||
(define ex1-i1 (make-ex1 1 2 3))
|
||||
|
||||
(define-record-type (ex2 make-ex2 ex2?)
|
||||
(protocol
|
||||
(lambda (p) (lambda (a . b) (p a b))))
|
||||
(fields (immutable a ex2-a)
|
||||
(immutable b ex2-b)))
|
||||
|
||||
(define ex2-i1 (make-ex2 1 2 3))
|
||||
|
||||
(define-record-type (unit-vector
|
||||
make-unit-vector
|
||||
unit-vector?)
|
||||
(protocol
|
||||
(lambda (p)
|
||||
(lambda (x y z)
|
||||
(let ((length
|
||||
(sqrt (+ (* x x)
|
||||
(* y y)
|
||||
(* z z)))))
|
||||
(p (/ x length)
|
||||
(/ y length)
|
||||
(/ z length))))))
|
||||
(fields (immutable x unit-vector-x)
|
||||
(immutable y unit-vector-y)
|
||||
(immutable z unit-vector-z)))
|
||||
|
||||
(define *ex3-instance* #f)
|
||||
|
||||
(define-record-type ex3
|
||||
(parent cpoint)
|
||||
(protocol
|
||||
(lambda (n)
|
||||
(lambda (x y t)
|
||||
(let ((r ((n x y 'red) t)))
|
||||
(set! *ex3-instance* r)
|
||||
r))))
|
||||
(fields
|
||||
(mutable thickness))
|
||||
(sealed #t) (opaque #t))
|
||||
|
||||
(define ex3-i1 (make-ex3 1 2 17))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (run-records-syntactic-tests)
|
||||
(test (point? p1) #t)
|
||||
(test (point? p2) #t)
|
||||
(test (point? (vector)) #f)
|
||||
(test (point? (cons 'a 'b)) #f)
|
||||
(test (cpoint? p1) #f)
|
||||
(test (cpoint? p2) #t)
|
||||
(test (point-x p1) 1)
|
||||
(test (point-y p1) 2)
|
||||
(test (point-x p2) 3)
|
||||
(test (point-y p2) 4)
|
||||
(test (cpoint-rgb p2) '(rgb . red))
|
||||
|
||||
(test/unspec (set-point-y! p1 17))
|
||||
(test (point-y p1) 17)
|
||||
|
||||
(test (record-rtd p1) (record-type-descriptor point))
|
||||
|
||||
(test (ex1-f ex1-i1) '(1 2 3))
|
||||
|
||||
(test (ex2-a ex2-i1) 1)
|
||||
(test (ex2-b ex2-i1) '(2 3))
|
||||
|
||||
(test (ex3? ex3-i1) #t)
|
||||
(test (cpoint-rgb ex3-i1) '(rgb . red))
|
||||
(test (ex3-thickness ex3-i1) 17)
|
||||
(test/unspec (ex3-thickness-set! ex3-i1 18))
|
||||
(test (ex3-thickness ex3-i1) 18)
|
||||
(test *ex3-instance* ex3-i1)
|
||||
|
||||
(test (record? ex3-i1) #f)
|
||||
|
||||
;;
|
||||
))
|
||||
|
||||
|
|
@ -2,8 +2,42 @@
|
|||
|
||||
(import (rnrs)
|
||||
(tests r6rs test)
|
||||
(tests r6rs base))
|
||||
(tests r6rs base)
|
||||
(tests r6rs unicode)
|
||||
(tests r6rs bytevectors)
|
||||
(tests r6rs lists)
|
||||
(tests r6rs sorting)
|
||||
(tests r6rs control)
|
||||
(tests r6rs records syntactic)
|
||||
(tests r6rs records procedural)
|
||||
(tests r6rs exceptions)
|
||||
(tests r6rs conditions)
|
||||
(tests r6rs io ports)
|
||||
(tests r6rs arithmetic fixnums)
|
||||
(tests r6rs arithmetic flonums)
|
||||
(tests r6rs arithmetic bitwise)
|
||||
(tests r6rs syntax-case)
|
||||
(tests r6rs hashtables)
|
||||
(tests r6rs enums))
|
||||
|
||||
(run-base-tests)
|
||||
|
||||
(run-unicode-tests)
|
||||
(run-bytevectors-tests)
|
||||
(run-lists-tests)
|
||||
(run-sorting-tests)
|
||||
(run-control-tests)
|
||||
(run-records-syntactic-tests)
|
||||
(run-records-procedural-tests)
|
||||
(run-exceptions-tests)
|
||||
(run-conditions-tests)
|
||||
(run-io-ports-tests)
|
||||
(run-arithmetic-fixnums-tests)
|
||||
(run-arithmetic-flonums-tests)
|
||||
(run-arithmetic-bitwise-tests)
|
||||
(run-syntax-case-tests)
|
||||
(run-hashtables-tests)
|
||||
(run-enums-tests)
|
||||
|
||||
(report-test-results)
|
||||
|
||||
|
|
|
|||
19
collects/tests/r6rs/sorting.ss
Normal file
19
collects/tests/r6rs/sorting.ss
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
#!r6rs
|
||||
|
||||
(library (tests r6rs sorting)
|
||||
(export run-sorting-tests)
|
||||
(import (rnrs)
|
||||
(tests r6rs test))
|
||||
|
||||
(define (run-sorting-tests)
|
||||
|
||||
(test (list-sort < '(3 5 2 1)) '(1 2 3 5))
|
||||
(test (vector-sort < '#(3 5 2 1)) '#(1 2 3 5))
|
||||
|
||||
(let ([v (vector 3 5 2 1)])
|
||||
(test/unspec (vector-sort! < v))
|
||||
(test v '#(1 2 3 5)))
|
||||
|
||||
;;
|
||||
))
|
||||
|
||||
105
collects/tests/r6rs/syntax-case.ss
Normal file
105
collects/tests/r6rs/syntax-case.ss
Normal file
|
|
@ -0,0 +1,105 @@
|
|||
#!r6rs
|
||||
|
||||
(library (tests r6rs syntax-case)
|
||||
(export run-syntax-case-tests)
|
||||
(import (for (rnrs) run expand)
|
||||
(tests r6rs test))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define p (cons 4 5))
|
||||
(define-syntax p.car
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ . rest) #'((car p) . rest)]
|
||||
[_ #'(car p)])))
|
||||
|
||||
;; Different frmo the report to avoid set-car!
|
||||
(define p2 (cons 4 5))
|
||||
(define-syntax p2.car
|
||||
(make-variable-transformer
|
||||
(lambda (x)
|
||||
(syntax-case x (set!)
|
||||
[(set! _ e) #'(set! p2 (cons e (cdr p2)))]
|
||||
[(_ . rest) #'((car p2) . rest)]
|
||||
[_ #'(car p2)]))))
|
||||
|
||||
(define-syntax rec
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ x e)
|
||||
(identifier? #'x)
|
||||
#'(letrec ([x e]) x)])))
|
||||
|
||||
(define-syntax loop
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(k e ...)
|
||||
(with-syntax
|
||||
([break (datum->syntax #'k 'break)])
|
||||
#'(call-with-current-continuation
|
||||
(lambda (break)
|
||||
(let f () e ... (f)))))])))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (run-syntax-case-tests)
|
||||
|
||||
(test p.car 4)
|
||||
;; (test/exn (set! p.car 15) &syntax) ; not a runtime exception
|
||||
|
||||
(set! p2.car 15)
|
||||
(test p2.car 15)
|
||||
(test p2 '(15 . 5))
|
||||
|
||||
(test (map (rec fact
|
||||
(lambda (n)
|
||||
(if (= n 0)
|
||||
1
|
||||
(* n (fact (- n 1))))))
|
||||
'(1 2 3 4 5))
|
||||
'(1 2 6 24 120))
|
||||
|
||||
; (test/exn (rec 5 (lambda (x) x)) &syntax) ; not a runtime exception
|
||||
|
||||
(test
|
||||
(let ([fred 17])
|
||||
(define-syntax a
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ id) #'(b id fred)])))
|
||||
(define-syntax b
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ id1 id2)
|
||||
#`(list
|
||||
#,(free-identifier=? #'id1 #'id2)
|
||||
#,(bound-identifier=? #'id1 #'id2))])))
|
||||
(a fred))
|
||||
'(#t #f))
|
||||
|
||||
; (test/exn (let ([a 3] [a 4]) (+ a a)) &syntax)
|
||||
|
||||
(test (let-syntax
|
||||
([dolet (lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ b)
|
||||
#'(let ([a 3] [b 4]) (+ a b))]))])
|
||||
(dolet a))
|
||||
7)
|
||||
|
||||
#;
|
||||
(test/exn (let ([else #f])
|
||||
(case 0 [else (write "oops")]))
|
||||
&syntax)
|
||||
|
||||
(test (let ((n 3) (ls '()))
|
||||
(loop
|
||||
(if (= n 0) (break ls))
|
||||
(set! ls (cons 'a ls))
|
||||
(set! n (- n 1))))
|
||||
'(a a a))
|
||||
|
||||
;;
|
||||
))
|
||||
|
||||
85
collects/tests/r6rs/unicode.ss
Normal file
85
collects/tests/r6rs/unicode.ss
Normal file
|
|
@ -0,0 +1,85 @@
|
|||
#!r6rs
|
||||
|
||||
(library (tests r6rs unicode)
|
||||
(export run-unicode-tests)
|
||||
(import (rnrs)
|
||||
(tests r6rs test))
|
||||
|
||||
(define (run-unicode-tests)
|
||||
|
||||
(test (char-upcase #\i) #\I)
|
||||
(test (char-downcase #\i) #\i)
|
||||
(test (char-titlecase #\i) #\I)
|
||||
(test (char-foldcase #\i) #\i)
|
||||
|
||||
(test (char-upcase #\xDF) #\xDF)
|
||||
(test (char-downcase #\xDF) #\xDF)
|
||||
(test (char-titlecase #\xDF) #\xDF)
|
||||
(test (char-foldcase #\xDF) #\xDF)
|
||||
|
||||
(test (char-upcase #\x3A3) #\x3A3)
|
||||
(test (char-downcase #\x3A3) #\x3C3)
|
||||
(test (char-titlecase #\x3A3) #\x3A3)
|
||||
(test (char-foldcase #\x3A3) #\x3C3)
|
||||
|
||||
(test (char-upcase #\x3C2) #\x3A3)
|
||||
(test (char-downcase #\x3C2) #\x3C2)
|
||||
(test (char-titlecase #\x3C2) #\x3A3)
|
||||
(test (char-foldcase #\x3C2) #\x3C3)
|
||||
|
||||
(test (char-ci<? #\z #\Z) #f)
|
||||
(test (char-ci=? #\z #\Z) #t)
|
||||
(test (char-ci=? #\x3C2 #\x3C3) #t)
|
||||
|
||||
(test (char-alphabetic? #\a) #t)
|
||||
(test (char-numeric? #\1) #t)
|
||||
(test (char-whitespace? #\space) #t)
|
||||
(test (char-whitespace? #\x00A0) #t)
|
||||
(test (char-upper-case? #\x3A3) #t)
|
||||
(test (char-lower-case? #\x3C3) #t)
|
||||
(test (char-lower-case? #\x00AA) #t)
|
||||
(test (char-title-case? #\I) #f)
|
||||
(test (char-title-case? #\x01C5) #t)
|
||||
|
||||
(test (char-general-category #\a) 'Ll)
|
||||
(test (char-general-category #\space) 'Zs)
|
||||
(test (char-general-category #\x10FFFF) 'Cn)
|
||||
|
||||
(test (string-upcase "Hi") "HI")
|
||||
(test (string-downcase "Hi") "hi")
|
||||
(test (string-foldcase "Hi") "hi")
|
||||
|
||||
(test (string-upcase "Stra\xDF;e") "STRASSE")
|
||||
(test (string-downcase "Stra\xDF;e") "stra\xDF;e")
|
||||
(test (string-foldcase "Stra\xDF;e") "strasse")
|
||||
(test (string-downcase "STRASSE") "strasse")
|
||||
|
||||
(test (string-downcase "\x3A3;") "\x3C3;")
|
||||
|
||||
(test (string-upcase "\x39E;\x391;\x39F;\x3A3;") "\x39E;\x391;\x39F;\x3A3;")
|
||||
(test (string-downcase "\x39E;\x391;\x39F;\x3A3;") "\x3BE;\x3B1;\x3BF;\x3C2;")
|
||||
(test (string-downcase "\x39E;\x391;\x39F;\x3A3;\x3A3;") "\x3BE;\x3B1;\x3BF;\x3C3;\x3C2;")
|
||||
(test (string-downcase "\x39E;\x391;\x39F;\x3A3; \x3A3;") "\x3BE;\x3B1;\x3BF;\x3C2; \x3C3;")
|
||||
(test (string-foldcase "\x39E;\x391;\x39F;\x3A3;") "\x3BE;\x3B1;\x3BF;\x3C3;")
|
||||
(test (string-upcase "\x3BE;\x3B1;\x3BF;\x3C3;") "\x39E;\x391;\x39F;\x3A3;")
|
||||
(test (string-upcase "\x3BE;\x3B1;\x3BF;\x3C2;") "\x39E;\x391;\x39F;\x3A3;")
|
||||
|
||||
(test (string-titlecase "kNock KNoCK") "Knock Knock")
|
||||
(test (string-titlecase "who's there?") "Who's There?")
|
||||
(test (string-titlecase "r6rs") "R6Rs")
|
||||
(test (string-titlecase "R6RS") "R6Rs")
|
||||
|
||||
(test (string-ci<? "z" "Z") #f)
|
||||
(test (string-ci=? "z" "Z") #t)
|
||||
(test (string-ci=? "Stra\xDF;e" "Strasse") #t)
|
||||
(test (string-ci=? "Stra\xDF;e" "STRASSE") #t)
|
||||
(test (string-ci=? "\x39E;\x391;\x39F;\x3A3;" "\x3BE;\x3B1;\x3BF;\x3C2;") #t)
|
||||
(test (string-ci=? "\x39E;\x391;\x39F;\x3A3;" "\x3BE;\x3B1;\x3BF;\x3C3;") #t)
|
||||
|
||||
(test (string-normalize-nfd "\xE9;") "\x65;\x301;")
|
||||
(test (string-normalize-nfc "\xE9;") "\xE9;")
|
||||
(test (string-normalize-nfd "\x65;\x301;") "\x65;\x301;")
|
||||
(test (string-normalize-nfc "\x65;\x301;") "\xE9;")
|
||||
|
||||
;;
|
||||
))
|
||||
|
|
@ -1348,7 +1348,7 @@ static Scheme_Object *get_frac(char *name, int low_p,
|
|||
if (MZ_IS_NAN(d)
|
||||
|| MZ_IS_POS_INFINITY(d)
|
||||
|| MZ_IS_NEG_INFINITY(d)) {
|
||||
scheme_wrong_type(name, REAL_NUMBER_STR, 0, argc, argv);
|
||||
scheme_wrong_type(name, "rational number", 0, argc, argv);
|
||||
ESCAPED_BEFORE_HERE;
|
||||
}
|
||||
|
||||
|
|
@ -1368,7 +1368,7 @@ static Scheme_Object *get_frac(char *name, int low_p,
|
|||
else
|
||||
n = scheme_rational_numerator(n);
|
||||
} else {
|
||||
scheme_wrong_type(name, REAL_NUMBER_STR, 0, argc, argv);
|
||||
scheme_wrong_type(name, "rational number", 0, argc, argv);
|
||||
ESCAPED_BEFORE_HERE;
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user