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

Andreas Rottmann's patches to R6RS support (merge to 4.2.2)

Browse Source 
svn: r16169
This commit is contained in:
Matthew Flatt 2009-09-29 16:06:15 +00:00
parent 95524d71a1
commit 11882b0819
2 changed files with 19 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -109,6 +109,13 @@
(define-fx bitwise-length fxlength (a) nocheck)
(define-fx bitwise-first-bit-set fxfirst-bit-set (a) nocheck)
(define positive-fixnum-width-bounds
(string-append "exact integer in [0, " (number->string (- (fixnum-width) 1)) "]"))
(define fixnum-width-bounds
(string-append "exact integer in [ " (number->string (- 1 (fixnum-width)))
", " (number->string (- (fixnum-width) 1)) "]"))
(define (fxbit-set? n bit)
(unless (fixnum? n)
(raise-type-error 'fxbit-set? "fixnum" n))
@ -124,7 +131,7 @@
(raise-type-error 'fxcopy-bit "fixnum" n))
(unless (and (exact-nonnegative-integer? pos)
(< pos (fixnum-width)))
(raise-type-error 'fxcopy-bit "exact integer in [0, 30]" pos))
(raise-type-error 'fxcopy-bit positive-fixnum-width-bounds pos))
(bitwise-copy-bit n pos bit))
(define (fxcopy-bit-field n start end m)
@ -132,7 +139,7 @@
(raise-type-error 'fxcopy-bit-field "fixnum" n))
(unless (and (exact-nonnegative-integer? end)
(< end (fixnum-width)))
(raise-type-error 'fxcopy-bit-field "exact integer in [0, 30]" end))
(raise-type-error 'fxcopy-bit-field positive-fixnum-width-bounds end))
(unless (fixnum? m)
(raise-type-error 'fxcopy-bit-field "fixnum" m))
(bitwise-copy-bit-field n start end m))
@ -142,7 +149,7 @@
(raise-type-error 'fxbit-field "fixnum" n))
(unless (and (exact-nonnegative-integer? end)
(< end (fixnum-width)))
(raise-type-error 'fxbit-field "exact integer in [0, 30]" end))
(raise-type-error 'fxbit-field positive-fixnum-width-bounds end))
(bitwise-bit-field n start end))
(define-syntax-rule (define-shifter fxarithmetic-shift r6rs:fxarithmetic-shift
@ -156,7 +163,7 @@
(let ([t1 a]
[t2 b])
(if (and (fixnum? a)
(and (exact-integer? b) (<= lower-bound b 30)))
(and (exact-integer? b) (<= lower-bound b (- (fixnum-width) 1))))
(let ([v (arithmetic-shift a (adjust b))])
(if (fixnum? v)
v
@ -165,7 +172,7 @@
(define (r6rs:fxarithmetic-shift a b)
(unless (fixnum? a)
(raise-type-error 'fxarithmetic-shift "fixnum" a))
(unless (and (exact-integer? b) (<= lower-bound b 30))
(unless (and (exact-integer? b) (<= lower-bound b (- (fixnum-width) 1)))
(raise-type-error 'fxarithmetic-shift bounds b))
(let ([v (arithmetic-shift a (adjust b))])
(if (fixnum? v)
@ -173,11 +180,11 @@
(implementation-restriction 'fxarithmetic-shift v))))))
(define-shifter fxarithmetic-shift r6rs:fxarithmetic-shift
-30 "exact integer in [-30, 30]" values)
(- 1 (fixnum-width)) fixnum-width-bounds values)
(define-shifter fxarithmetic-shift-left r6rs:fxarithmetic-shift-left
0 "exact integer in [0, 30]" values)
0 positive-fixnum-width-bounds values)
(define-shifter fxarithmetic-shift-right r6rs:fxarithmetic-shift-right
0 "exact integer in [0, 30]" -)
0 positive-fixnum-width-bounds -)
(define (fxrotate-bit-field n start end count)
@ -185,10 +192,10 @@
(raise-type-error 'fxrotate-bit-field "fixnum" n))
(unless (and (exact-nonnegative-integer? end)
(< end (fixnum-width)))
(raise-type-error 'fxrotate-bit-field "exact integer in [0, 30]" end))
(raise-type-error 'fxrotate-bit-field positive-fixnum-width-bounds end))
(unless (and (exact-nonnegative-integer? count)
(< count (fixnum-width)))
(raise-type-error 'fxrotate-bit-field "exact integer in [0, 30]" count))
(raise-type-error 'fxrotate-bit-field positive-fixnum-width-bounds count))
(bitwise-rotate-bit-field n start end count))
(define (fxreverse-bit-field n start end)
@ -196,5 +203,5 @@
(raise-type-error 'fxrotate-bit-field "fixnum" n))
(unless (and (exact-nonnegative-integer? end)
(< end (fixnum-width)))
(raise-type-error 'fxrotate-bit-field "exact integer in [0, 30]" end))
(raise-type-error 'fxrotate-bit-field positive-fixnum-width-bounds end))
(bitwise-reverse-bit-field n start end))

2
collects/rnrs/io/ports-6.ss
View File

@ -210,7 +210,7 @@
[enable-breaks?
(parameterize-break #t (write-bytes (subbytes bytes start end) port))]
[can-buffer/block?
(write-bytes (subbytes start end) port)]
(write-bytes (subbytes bytes start end) port)]
[else
(write-bytes-avail* (subbytes bytes start end) port)])))
(lambda ()