conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

- bytevector-ieee-[single|double]-[ref|set!] now accept unaligned 

indices (r6rs requirement).
- file-options are now represented as enum-sets (r6rs requirement)
- odd?, even?, lcm, remainder, etc., now accept inexact integers.
This commit is contained in:
Abdulaziz Ghuloum 2008-07-24 18:58:53 -07:00
parent 9085b79b64
commit 7db56cf76e
11 changed files with 248 additions and 160 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.4.prebuilt
View File

Binary file not shown.

BIN
scheme/ikarus.boot.8.prebuilt
View File

Binary file not shown.

181
scheme/ikarus.bytevectors.ss
View File

@ -876,66 +876,177 @@
(die 'bytevector-ieee-single-native-set! "invalid index" i)) (die 'bytevector-ieee-single-native-set! "invalid index" i))
(die 'bytevector-ieee-single-native-set! "not a bytevector" bv))) (die 'bytevector-ieee-single-native-set! "not a bytevector" bv)))
(define ($bytevector-ieee-double-ref/little x i)
(import (ikarus system $flonums))
(let ([y ($make-flonum)])
($flonum-set! y 0 ($bytevector-u8-ref x i))
($flonum-set! y 1 ($bytevector-u8-ref x ($fx+ i 1)))
($flonum-set! y 2 ($bytevector-u8-ref x ($fx+ i 2)))
($flonum-set! y 3 ($bytevector-u8-ref x ($fx+ i 3)))
($flonum-set! y 4 ($bytevector-u8-ref x ($fx+ i 4)))
($flonum-set! y 5 ($bytevector-u8-ref x ($fx+ i 5)))
($flonum-set! y 6 ($bytevector-u8-ref x ($fx+ i 6)))
($flonum-set! y 7 ($bytevector-u8-ref x ($fx+ i 7)))
y))
(define ($bytevector-ieee-double-set!/little x i y)
(import (ikarus system $flonums))
($bytevector-set! x i ($flonum-u8-ref y 0))
($bytevector-set! x ($fx+ i 1) ($flonum-u8-ref y 1))
($bytevector-set! x ($fx+ i 2) ($flonum-u8-ref y 2))
($bytevector-set! x ($fx+ i 3) ($flonum-u8-ref y 3))
($bytevector-set! x ($fx+ i 4) ($flonum-u8-ref y 4))
($bytevector-set! x ($fx+ i 5) ($flonum-u8-ref y 5))
($bytevector-set! x ($fx+ i 6) ($flonum-u8-ref y 6))
($bytevector-set! x ($fx+ i 7) ($flonum-u8-ref y 7)))
(define ($bytevector-ieee-double-ref/big x i)
(import (ikarus system $flonums))
(let ([y ($make-flonum)])
($flonum-set! y 7 ($bytevector-u8-ref x i))
($flonum-set! y 6 ($bytevector-u8-ref x ($fx+ i 1)))
($flonum-set! y 5 ($bytevector-u8-ref x ($fx+ i 2)))
($flonum-set! y 4 ($bytevector-u8-ref x ($fx+ i 3)))
($flonum-set! y 3 ($bytevector-u8-ref x ($fx+ i 4)))
($flonum-set! y 2 ($bytevector-u8-ref x ($fx+ i 5)))
($flonum-set! y 1 ($bytevector-u8-ref x ($fx+ i 6)))
($flonum-set! y 0 ($bytevector-u8-ref x ($fx+ i 7)))
y))
(define ($bytevector-ieee-double-set!/big x i y)
(import (ikarus system $flonums))
($bytevector-set! x i ($flonum-u8-ref y 7))
($bytevector-set! x ($fx+ i 1) ($flonum-u8-ref y 6))
($bytevector-set! x ($fx+ i 2) ($flonum-u8-ref y 5))
($bytevector-set! x ($fx+ i 3) ($flonum-u8-ref y 4))
($bytevector-set! x ($fx+ i 4) ($flonum-u8-ref y 3))
($bytevector-set! x ($fx+ i 5) ($flonum-u8-ref y 2))
($bytevector-set! x ($fx+ i 6) ($flonum-u8-ref y 1))
($bytevector-set! x ($fx+ i 7) ($flonum-u8-ref y 0)))
(define ($bytevector-ieee-single-ref/little x i)
(let ([bv (make-bytevector 4)])
($bytevector-set! bv 0 ($bytevector-u8-ref x i))
($bytevector-set! bv 1 ($bytevector-u8-ref x ($fx+ i 1)))
($bytevector-set! bv 2 ($bytevector-u8-ref x ($fx+ i 2)))
($bytevector-set! bv 3 ($bytevector-u8-ref x ($fx+ i 3)))
($bytevector-ieee-single-native-ref bv 0)))
(define ($bytevector-ieee-single-ref/big x i)
(let ([bv (make-bytevector 4)])
($bytevector-set! bv 3 ($bytevector-u8-ref x i))
($bytevector-set! bv 2 ($bytevector-u8-ref x ($fx+ i 1)))
($bytevector-set! bv 1 ($bytevector-u8-ref x ($fx+ i 2)))
($bytevector-set! bv 0 ($bytevector-u8-ref x ($fx+ i 3)))
($bytevector-ieee-single-native-ref bv 0)))
(define ($bytevector-ieee-single-set!/little x i v)
(let ([bv (make-bytevector 4)])
($bytevector-ieee-single-native-set! bv 0 v)
($bytevector-set! x i ($bytevector-u8-ref bv 0))
($bytevector-set! x ($fx+ i 1) ($bytevector-u8-ref bv 1))
($bytevector-set! x ($fx+ i 2) ($bytevector-u8-ref bv 2))
($bytevector-set! x ($fx+ i 3) ($bytevector-u8-ref bv 3))))
(define ($bytevector-ieee-single-set!/big x i v)
(let ([bv (make-bytevector 4)])
($bytevector-ieee-single-native-set! bv 0 v)
($bytevector-set! x i ($bytevector-u8-ref bv 3))
($bytevector-set! x ($fx+ i 1) ($bytevector-u8-ref bv 2))
($bytevector-set! x ($fx+ i 2) ($bytevector-u8-ref bv 1))
($bytevector-set! x ($fx+ i 3) ($bytevector-u8-ref bv 0))))
(define (bytevector-ieee-double-ref bv i endianness) (define (bytevector-ieee-double-ref bv i endianness)
(define who 'bytevector-ieee-double-ref)
(if (bytevector? bv) (if (bytevector? bv)
(if (and (fixnum? i) (if (and (fixnum? i) ($fx>= i 0))
($fx>= i 0) (let ([len ($bytevector-length bv)])
($fxzero? ($fxlogand i 7)) (if (and ($fxzero? ($fxlogand i 7)) ($fx< i len))
($fx< i ($bytevector-length bv)))
(case endianness (case endianness
[(little) ($bytevector-ieee-double-native-ref bv i)] [(little) ($bytevector-ieee-double-native-ref bv i)]
[(big) ($bytevector-ieee-double-nonnative-ref bv i)] [(big) ($bytevector-ieee-double-nonnative-ref bv i)]
[else (die 'bytevector-ieee-double-ref [else (die who "invalid endianness" endianness)])
"invalid endianness" endianness)]) (if ($fx<= i ($fx- len 8))
(die 'bytevector-ieee-double-ref "invalid index" i)) (case endianness
(die 'bytevector-ieee-double-ref "not a bytevector" bv))) [(little)
($bytevector-ieee-double-ref/little bv i)]
[(big)
($bytevector-ieee-double-ref/big bv i)]
[else (die who "invalid endianness" endianness)])
(die who "invalid index" i))))
(die who "invalid index" i))
(die who "not a bytevector" bv)))
(define (bytevector-ieee-single-ref bv i endianness) (define (bytevector-ieee-single-ref bv i endianness)
(define who 'bytevector-ieee-single-ref)
(if (bytevector? bv) (if (bytevector? bv)
(if (and (fixnum? i) (if (and (fixnum? i) ($fx>= i 0))
($fx>= i 0) (let ([len ($bytevector-length bv)])
($fxzero? ($fxlogand i 3)) (if (and ($fxzero? ($fxlogand i 3)) ($fx< i len))
($fx< i ($bytevector-length bv)))
(case endianness (case endianness
[(little) ($bytevector-ieee-single-native-ref bv i)] [(little) ($bytevector-ieee-single-native-ref bv i)]
[(big) ($bytevector-ieee-single-nonnative-ref bv i)] [(big) ($bytevector-ieee-single-nonnative-ref bv i)]
[else (die 'bytevector-ieee-single-ref [else (die who "invalid endianness" endianness)])
"invalid endianness" endianness)]) (if ($fx<= i ($fx- len 4))
(die 'bytevector-ieee-single-ref "invalid index" i)) (case endianness
(die 'bytevector-ieee-single-ref "not a bytevector" bv))) [(little)
($bytevector-ieee-single-ref/little bv i)]
[(big)
($bytevector-ieee-single-ref/big bv i)]
[else (die who "invalid endianness" endianness)])
(die who "invalid index" i))))
(die who "invalid index" i))
(die who "not a bytevector" bv)))
(define (bytevector-ieee-double-set! bv i x endianness) (define (bytevector-ieee-double-set! bv i x endianness)
(define who 'bytevector-ieee-double-set!)
(if (bytevector? bv) (if (bytevector? bv)
(if (and (fixnum? i)
($fx>= i 0)
($fxzero? ($fxlogand i 7))
($fx< i ($bytevector-length bv)))
(if (flonum? x) (if (flonum? x)
(if (and (fixnum? i) ($fx>= i 0))
(let ([len ($bytevector-length bv)])
(if (and ($fxzero? ($fxlogand i 7)) ($fx< i len))
(case endianness (case endianness
[(little) ($bytevector-ieee-double-native-set! bv i x)] [(little) ($bytevector-ieee-double-native-set! bv i x)]
[(big) ($bytevector-ieee-double-nonnative-set! bv i x)] [(big) ($bytevector-ieee-double-nonnative-set! bv i x)]
[else (die 'bytevector-ieee-double-set! [else
"invalid endianness" endianness)]) (die who "invalid endianness" endianness)])
(die 'bytevector-ieee-double-set! "not a flonum" x)) (if ($fx<= i ($fx- len 8))
(die 'bytevector-ieee-double-set! "invalid index" i)) (case endianness
(die 'bytevector-ieee-double-set! "not a bytevector" bv))) [(little)
($bytevector-ieee-double-set!/little bv i x)]
[(big)
($bytevector-ieee-double-set!/big bv i x)]
[else
(die who "invalid endianness" endianness)])
(die who "invalid index" i))))
(die who "invalid index" i))
(die who "not a flonum" x))
(die who "not a bytevector" bv)))
(define (bytevector-ieee-single-set! bv i x endianness) (define (bytevector-ieee-single-set! bv i x endianness)
(define who 'bytevector-ieee-single-set!)
(if (bytevector? bv) (if (bytevector? bv)
(if (and (fixnum? i)
($fx>= i 0)
($fxzero? ($fxlogand i 3))
($fx< i ($bytevector-length bv)))
(if (flonum? x) (if (flonum? x)
(if (and (fixnum? i) ($fx>= i 0))
(let ([len ($bytevector-length bv)])
(if (and ($fxzero? ($fxlogand i 3)) ($fx< i len))
(case endianness (case endianness
[(little) ($bytevector-ieee-single-native-set! bv i x)] [(little) ($bytevector-ieee-single-native-set! bv i x)]
[(big) ($bytevector-ieee-single-nonnative-set! bv i x)] [(big) ($bytevector-ieee-single-nonnative-set! bv i x)]
[else (die 'bytevector-ieee-single-set! [else
"invalid endianness" endianness)]) (die who "invalid endianness" endianness)])
(die 'bytevector-ieee-single-set! "not a flonum" x)) (if ($fx<= i ($fx- len 4))
(die 'bytevector-ieee-single-set! "invalid index" i)) (case endianness
(die 'bytevector-ieee-single-set! "not a bytevector" bv))) [(little)
($bytevector-ieee-single-set!/little bv i x)]
[(big)
($bytevector-ieee-single-set!/big bv i x)]
[else
(die who "invalid endianness" endianness)])
(die who "invalid index" i))))
(die who "invalid index" i))
(die who "not a flonum" x))
(die who "not a bytevector" bv)))
(define ($bytevector-ref/64 bv i who decoder endianness) (define ($bytevector-ref/64 bv i who decoder endianness)
(if (bytevector? bv) (if (bytevector? bv)

31
scheme/ikarus.codecs.ss
View File

@ -17,12 +17,12 @@
(library (ikarus codecs) (library (ikarus codecs)
(export latin-1-codec utf-8-codec utf-16-codec native-eol-style (export latin-1-codec utf-8-codec utf-16-codec native-eol-style
make-transcoder native-transcoder buffer-mode? make-transcoder native-transcoder buffer-mode?
file-options-spec transcoder-codec transcoder-eol-style transcoder-codec transcoder-eol-style
transcoder-error-handling-mode) transcoder-error-handling-mode)
(import (import
(except (ikarus) latin-1-codec utf-8-codec utf-16-codec (except (ikarus) latin-1-codec utf-8-codec utf-16-codec
native-eol-style make-transcoder native-transcoder native-eol-style make-transcoder native-transcoder
buffer-mode? file-options-spec transcoder-codec buffer-mode? transcoder-codec
transcoder-eol-style transcoder-error-handling-mode) transcoder-eol-style transcoder-error-handling-mode)
(ikarus system $transcoders)) (ikarus system $transcoders))
(define (latin-1-codec) 'latin-1-codec) (define (latin-1-codec) 'latin-1-codec)
@ -116,32 +116,5 @@
(define (buffer-mode? x) (define (buffer-mode? x)
(and (memq x '(none line block)) #t)) (and (memq x '(none line block)) #t))
(define file-options-vec
'#(fo:default
fo:no-create
fo:no-fail
fo:no-fail/no-create
fo:no-truncate
fo:no-truncate/no-create
fo:no-truncate/no-fail
fo:no-truncate/no-fail/no-create))
(define file-options-alist
'([no-create . #b001]
[no-fail . #b010]
[no-truncate . #b100]))
(define (file-options-spec ls)
(unless (list? ls)
(die 'file-options-spec "not a list" ls))
(let f ([ls ls] [n 0])
(cond
[(null? ls) (vector-ref file-options-vec n)]
[(assq (car ls) file-options-alist) =>
(lambda (a)
(f (cdr ls) (fxlogor (cdr a) n)))]
[else #f])))
) )

12
scheme/ikarus.enumerations.ss
View File

@ -17,14 +17,16 @@
(export make-enumeration enum-set-universe enum-set-indexer (export make-enumeration enum-set-universe enum-set-indexer
enum-set-constructor enum-set->list enum-set-member? enum-set-constructor enum-set->list enum-set-member?
enum-set-subset? enum-set=? enum-set-union enum-set-difference enum-set-subset? enum-set=? enum-set-union enum-set-difference
enum-set-intersection enum-set-complement enum-set-projection) enum-set-intersection enum-set-complement enum-set-projection
make-file-options)
(import (import
(except (ikarus) (except (ikarus)
make-enumeration enum-set-universe enum-set-indexer make-enumeration enum-set-universe enum-set-indexer
enum-set-constructor enum-set->list enum-set-member? enum-set-constructor enum-set->list enum-set-member?
enum-set-subset? enum-set=? enum-set-union enum-set-difference enum-set-subset? enum-set=? enum-set-union enum-set-difference
enum-set-intersection enum-set-complement enum-set-intersection enum-set-complement
enum-set-projection)) enum-set-projection
make-file-options))
(define-record-type enum (define-record-type enum
(fields g univ values) (fields g univ values)
@ -217,6 +219,12 @@
(make-enum g u (combine u s)))))) (make-enum g u (combine u s))))))
(die 'enum-set-projection "not an enumeration" x2)) (die 'enum-set-projection "not an enumeration" x2))
(die 'enum-set-projection "not an enumeration" x1))) (die 'enum-set-projection "not an enumeration" x1)))
(define make-file-options
(enum-set-constructor
(make-enumeration
'(no-create no-fail no-truncate))))
) )
#!eof #!eof

16
scheme/ikarus.io.ss
View File

@ -1376,16 +1376,12 @@
[else fh]))) [else fh])))
(define (open-output-file-handle filename file-options who) (define (open-output-file-handle filename file-options who)
(let ([opt (case file-options (define (opt->num x)
[(fo:default) 0] (bitwise-ior
[(fo:no-create) 1] (if (enum-set-member? 'no-create x) 1 0)
[(fo:no-fail) 2] (if (enum-set-member? 'no-fail x) 2 0)
[(fo:no-fail/no-create) 3] (if (enum-set-member? 'no-truncate x) 4 0)))
[(fo:no-truncate) 4] (let ([opt (opt->num file-options)])
[(fo:no-truncate/no-create) 5]
[(fo:no-truncate/no-fail) 6]
[(fo:no-truncate/no-fail/no-create) 7]
[else (die who "invalid file option" file-options)])])
(let ([fh (foreign-call "ikrt_open_output_fd" (let ([fh (foreign-call "ikrt_open_output_fd"
(string->utf8 filename) (string->utf8 filename)
opt)]) opt)])

122
scheme/ikarus.numerics.ss
View File

@ -14,7 +14,7 @@
;;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(library (ikarus flonums) (library (ikarus flonums)
(export $flonum->exact $flonum->integer flonum-parts (export $flonum->exact flonum-parts
inexact->exact exact $flonum-rational? $flonum-integer? $flzero? inexact->exact exact $flonum-rational? $flonum-integer? $flzero?
$flnegative? flpositive? flabs fixnum->flonum $flnegative? flpositive? flabs fixnum->flonum
flsin flcos fltan flasin flacos flatan fleven? flodd? flsin flcos fltan flasin flacos flatan fleven? flodd?
@ -103,7 +103,7 @@
($flround x) ($flround x)
(die 'flround "not a flonum" x))) (die 'flround "not a flonum" x)))
(module ($flonum->integer $flonum->exact) (module ($flonum->exact)
(define ($flonum-signed-mantissa x) (define ($flonum-signed-mantissa x)
(let ([b0 ($flonum-u8-ref x 0)]) (let ([b0 ($flonum-u8-ref x 0)])
(let ([m0 ($fx+ ($flonum-u8-ref x 7) (let ([m0 ($fx+ ($flonum-u8-ref x 7)
@ -122,33 +122,6 @@
(+ (bitwise-arithmetic-shift-left (+ (bitwise-arithmetic-shift-left
($fx- 0 ($fxlogor m1 ($fxsll m2 24))) 24) ($fx- 0 ($fxlogor m1 ($fxsll m2 24))) 24)
($fx- 0 m0)))))) ($fx- 0 m0))))))
(define ($flonum->integer x)
(let ([sbe ($flonum-sbe x)])
(let ([be ($fxlogand sbe #x7FF)])
(cond
[($fx= be 2047) #f] ;;; nans/infs
[($fx>= be 1075) ;;; magnitude large enough to be an integer
(bitwise-arithmetic-shift-left
($flonum-signed-mantissa x)
(- be 1075))]
[else
(let-values ([(pos? be m) (flonum-parts x)])
(cond
[(<= 1 be 2046) ; normalized flonum
(let ([n (+ m (expt 2 52))]
[d (expt 2 (- be 1075))])
(let-values ([(q r) (quotient+remainder n d)])
(if (= r 0)
(if pos? q (- q))
#f)))]
[(= be 0) (if (= m 0) 0 #f)]
[else #f]))]))))
(define-syntax ctexpt
(lambda (x)
(import (ikarus))
(syntax-case x ()
[(_ n m)
(expt (syntax->datum #'n) (syntax->datum #'m))])))
(define ($flonum->exact x) (define ($flonum->exact x)
(import (ikarus)) (import (ikarus))
(let ([sbe ($flonum-sbe x)]) (let ([sbe ($flonum-sbe x)])
@ -167,9 +140,9 @@
(if (= m 0) (if (= m 0)
0 0
(* (if pos? 1 -1) (* (if pos? 1 -1)
(/ m (ctexpt 2 1074))))] (/ m (expt 2 1074))))]
[else ; normalized flonum [else ; normalized flonum
(/ (+ m (ctexpt 2 52)) (/ (+ m (expt 2 52))
(bitwise-arithmetic-shift-left (bitwise-arithmetic-shift-left
(if pos? 1 -1) (if pos? 1 -1)
(- 1075 be)))]))]))))) (- 1075 be)))]))])))))
@ -413,7 +386,7 @@
(ikarus system $chars) (ikarus system $chars)
(ikarus system $strings) (ikarus system $strings)
(only (ikarus flonums) $flonum->exact $flzero? $flnegative? (only (ikarus flonums) $flonum->exact $flzero? $flnegative?
$flonum->integer $flround) $flround)
(except (ikarus) + - * / zero? = < <= > >= add1 sub1 quotient (except (ikarus) + - * / zero? = < <= > >= add1 sub1 quotient
remainder modulo even? odd? quotient+remainder number->string remainder modulo even? odd? quotient+remainder number->string
bitwise-arithmetic-shift-right bitwise-arithmetic-shift-left bitwise-arithmetic-shift-right bitwise-arithmetic-shift-left
@ -1101,23 +1074,35 @@
[y (if (< y 0) (- y) y)]) [y (if (< y 0) (- y) y)])
(let ([g (binary-gcd x y)]) (let ([g (binary-gcd x y)])
(binary* y (quotient x g))))] (binary* y (quotient x g))))]
[(number? y) [(flonum? y)
(die 'lcm "not an exact integer" y)] (let ([v ($flonum->exact y)])
(cond
[(or (fixnum? v) (bignum? v))
(inexact (lcm x v))]
[else (die 'lcm "not an integer" y)]))]
[else [else
(die 'lcm "not a number" y)])] (die 'lcm "not an integer" y)])]
[(number? x) [(flonum? x)
(die 'lcm "not an exact integer" x)] (let ([v ($flonum->exact x)])
(cond
[(or (fixnum? v) (bignum? v))
(inexact (lcm v y))]
[else (die 'lcm "not an integer" x)]))]
[else [else
(die 'lcm "not a number" x)])] (die 'lcm "not an integer" x)])]
[(x) [(x)
(cond (cond
[(or (fixnum? x) (bignum? x)) x] [(or (fixnum? x) (bignum? x)) x]
[(number? x) [(flonum? x)
(die 'lcm "not an exact integer" x)] (let ([v ($flonum->exact x)])
(cond
[(or (fixnum? v) (bignum? v)) x]
[else (die 'lcm "not an integer" x)]))]
[else [else
(die 'lcm "not a number" x)])] (die 'lcm "not an integer" x)])]
[() 1] [() 1]
[(x y z . ls) [(x y z . ls)
;;; FIXME: incorrect for multiple roundings
(let f ([g (lcm (lcm x y) z)] [ls ls]) (let f ([g (lcm (lcm x y) z)] [ls ls])
(cond (cond
[(null? ls) g] [(null? ls) g]
@ -1529,16 +1514,25 @@
(cond (cond
[(fixnum? x) ($fxeven? x)] [(fixnum? x) ($fxeven? x)]
[(bignum? x) (even-bignum? x)] [(bignum? x) (even-bignum? x)]
[(flonum? x) (die 'even? "BUG" x)] [(flonum? x)
(let ([v ($flonum->exact x)])
(cond
[(fixnum? v) ($fxeven? v)]
[(bignum? v) (even-bignum? v)]
[else (die 'even? "not an integer" x)]))]
[else (die 'even? "not an integer" x)])) [else (die 'even? "not an integer" x)]))
(define (odd? x) (define (odd? x)
(not
(cond (cond
[(fixnum? x) ($fxeven? x)] [(fixnum? x) (not ($fxeven? x))]
[(bignum? x) (even-bignum? x)] [(bignum? x) (not (even-bignum? x))]
[(flonum? x) (die 'odd? "BUG" x)] [(flonum? x)
[else (die 'odd? "not an integer" x)]))) (let ([v ($flonum->exact x)])
(cond
[(fixnum? v) (not ($fxeven? v))]
[(bignum? v) (not (even-bignum? v))]
[else (die 'odd? "not an integer" x)]))]
[else (die 'odd? "not an integer" x)]))
(module (number->string) (module (number->string)
(module (bignum->string) (module (bignum->string)
@ -1660,9 +1654,10 @@
n n
(foreign-call "ikrt_fxbnplus" n m)))] (foreign-call "ikrt_fxbnplus" n m)))]
[(flonum? m) [(flonum? m)
(let ([v ($flonum->integer m)]) (let ([v ($flonum->exact m)])
(cond (cond
[v (inexact (modulo n v))] [(or (fixnum? v) (bignum? v))
(inexact (modulo n v))]
[else [else
(die 'modulo "not an integer" m)]))] (die 'modulo "not an integer" m)]))]
[(ratnum? m) (die 'modulo "not an integer" m)] [(ratnum? m) (die 'modulo "not an integer" m)]
@ -1680,17 +1675,19 @@
(+ m (remainder n m)) (+ m (remainder n m))
(remainder n m)))] (remainder n m)))]
[(flonum? m) [(flonum? m)
(let ([v ($flonum->integer m)]) (let ([v ($flonum->exact m)])
(cond (cond
[v (inexact (modulo n v))] [(or (fixnum? v) (bignum? v))
(inexact (modulo n v))]
[else [else
(die 'modulo "not an integer" m)]))] (die 'modulo "not an integer" m)]))]
[(ratnum? m) (die 'modulo "not an integer" m)] [(ratnum? m) (die 'modulo "not an integer" m)]
[else (die 'modulo "not a number" m)])] [else (die 'modulo "not a number" m)])]
[(flonum? n) [(flonum? n)
(let ([v ($flonum->integer n)]) (let ([v ($flonum->exact n)])
(cond (cond
[v (inexact (modulo v m))] [(or (fixnum? v) (bignum? v))
(inexact (modulo v m))]
[else [else
(die 'modulo "not an integer" n)]))] (die 'modulo "not an integer" n)]))]
[(ratnum? n) (die 'modulo "not an integer" n)] [(ratnum? n) (die 'modulo "not an integer" n)]
@ -2385,9 +2382,11 @@
[(flonum? m) (flexpt (inexact n) m)] [(flonum? m) (flexpt (inexact n) m)]
[(ratnum? m) (flexpt (inexact n) (inexact m))] [(ratnum? m) (flexpt (inexact n) (inexact m))]
[(or (compnum? m) (cflonum? m)) [(or (compnum? m) (cflonum? m))
(if (eq? n 0)
0
(let ([e 2.718281828459045]) (let ([e 2.718281828459045])
(define (ln x) (/ (log x) (log e))) (define (ln x) (/ (log x) (log e)))
(exp (* m (ln n))))] (exp (* m (ln n)))))]
[else (die 'expt "not a number" m)]))) [else (die 'expt "not a number" m)])))
(define quotient (define quotient
@ -2413,9 +2412,9 @@
(fxremainder x y))] (fxremainder x y))]
[(bignum? y) (values 0 x)] [(bignum? y) (values 0 x)]
[(flonum? y) [(flonum? y)
(let ([v ($flonum->integer y)]) (let ([v ($flonum->exact y)])
(cond (cond
[v [(or (fixnum? v) (bignum? v))
(let-values ([(q r) (quotient+remainder x v)]) (let-values ([(q r) (quotient+remainder x v)])
(values (inexact q) (inexact r)))] (values (inexact q) (inexact r)))]
[else [else
@ -2430,18 +2429,18 @@
(let ([p (foreign-call "ikrt_bnbndivrem" x y)]) (let ([p (foreign-call "ikrt_bnbndivrem" x y)])
(values (car p) (cdr p)))] (values (car p) (cdr p)))]
[(flonum? y) [(flonum? y)
(let ([v ($flonum->integer y)]) (let ([v ($flonum->exact y)])
(cond (cond
[v [(or (fixnum? v) (bignum? v))
(let-values ([(q r) (quotient+remainder x v)]) (let-values ([(q r) (quotient+remainder x v)])
(values (inexact q) (inexact r)))] (values (inexact q) (inexact r)))]
[else [else
(die 'quotient+remainder "not an integer" y)]))] (die 'quotient+remainder "not an integer" y)]))]
[else (die 'quotient+remainder "not a number" y)])] [else (die 'quotient+remainder "not a number" y)])]
[(flonum? x) [(flonum? x)
(let ([v ($flonum->integer x)]) (let ([v ($flonum->exact x)])
(cond (cond
[v [(or (fixnum? v) (bignum? v))
(let-values ([(q r) (quotient+remainder v y)]) (let-values ([(q r) (quotient+remainder v y)])
(values (inexact q) (inexact r)))] (values (inexact q) (inexact r)))]
[else (die 'quotient+remainder "not an integer" x)]))] [else (die 'quotient+remainder "not an integer" x)]))]
@ -2695,8 +2694,7 @@
;;; ;;;
(cond (cond
[(flonum? x) [(flonum? x)
(let ([e (or ($flonum->exact x) (let ([e ($flonum->exact x)])
(die 'truncate "number has no real value" x))])
(cond (cond
[(ratnum? e) (exact->inexact ($ratnum-truncate e))] [(ratnum? e) (exact->inexact ($ratnum-truncate e))]
[else x]))] [else x]))]

2
scheme/last-revision
View File

@ -1 +1 @@
1550 1551

2
scheme/makefile.ss
View File

@ -1333,7 +1333,7 @@
[syntax-error i] [syntax-error i]
[$transcoder->data $transc] [$transcoder->data $transc]
[$data->transcoder $transc] [$data->transcoder $transc]
[file-options-spec i] [make-file-options i]
;;; ;;;
[port-id i] [port-id i]
[read-annotated i] [read-annotated i]

2
scheme/psyntax.compat.ss
View File

@ -17,7 +17,7 @@
(library (psyntax compat) (library (psyntax compat)
(export define-record make-parameter parameterize format gensym (export define-record make-parameter parameterize format gensym
eval-core symbol-value set-symbol-value! eval-core symbol-value set-symbol-value!
file-options-spec make-struct-type read-annotated make-struct-type read-annotated
annotation? annotation-expression annotation-source annotation? annotation-expression annotation-source
annotation-stripped annotation-stripped
read-library-source-file) read-library-source-file)

6
scheme/psyntax.expander.ss
View File

@ -2599,10 +2599,12 @@
(define file-options-macro (define file-options-macro
(lambda (x) (lambda (x)
(define (valid-option? x)
(and (id? x) (memq (id->sym x) '(no-fail no-create no-truncate))))
(syntax-match x () (syntax-match x ()
((_ opt* ...) ((_ opt* ...)
(and (for-all id? opt*) (file-options-spec (map id->sym opt*))) (for-all valid-option? opt*)
(bless `(quote ,(file-options-spec (map id->sym opt*)))))))) (bless `(make-file-options ',opt*))))))
(define symbol-macro (define symbol-macro
(lambda (x set) (lambda (x set)