- 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
parent
9085b79b64
commit
7db56cf76e
Binary file not shown.
Binary file not shown.
|
|
@ -876,66 +876,177 @@
|
|||
(die 'bytevector-ieee-single-native-set! "invalid index" i))
|
||||
(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 who 'bytevector-ieee-double-ref)
|
||||
(if (bytevector? bv)
|
||||
(if (and (fixnum? i)
|
||||
($fx>= i 0)
|
||||
($fxzero? ($fxlogand i 7))
|
||||
($fx< i ($bytevector-length bv)))
|
||||
(case endianness
|
||||
[(little) ($bytevector-ieee-double-native-ref bv i)]
|
||||
[(big) ($bytevector-ieee-double-nonnative-ref bv i)]
|
||||
[else (die 'bytevector-ieee-double-ref
|
||||
"invalid endianness" endianness)])
|
||||
(die 'bytevector-ieee-double-ref "invalid index" i))
|
||||
(die 'bytevector-ieee-double-ref "not a bytevector" bv)))
|
||||
(if (and (fixnum? i) ($fx>= i 0))
|
||||
(let ([len ($bytevector-length bv)])
|
||||
(if (and ($fxzero? ($fxlogand i 7)) ($fx< i len))
|
||||
(case endianness
|
||||
[(little) ($bytevector-ieee-double-native-ref bv i)]
|
||||
[(big) ($bytevector-ieee-double-nonnative-ref bv i)]
|
||||
[else (die who "invalid endianness" endianness)])
|
||||
(if ($fx<= i ($fx- len 8))
|
||||
(case endianness
|
||||
[(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 who 'bytevector-ieee-single-ref)
|
||||
(if (bytevector? bv)
|
||||
(if (and (fixnum? i)
|
||||
($fx>= i 0)
|
||||
($fxzero? ($fxlogand i 3))
|
||||
($fx< i ($bytevector-length bv)))
|
||||
(case endianness
|
||||
[(little) ($bytevector-ieee-single-native-ref bv i)]
|
||||
[(big) ($bytevector-ieee-single-nonnative-ref bv i)]
|
||||
[else (die 'bytevector-ieee-single-ref
|
||||
"invalid endianness" endianness)])
|
||||
(die 'bytevector-ieee-single-ref "invalid index" i))
|
||||
(die 'bytevector-ieee-single-ref "not a bytevector" bv)))
|
||||
(if (and (fixnum? i) ($fx>= i 0))
|
||||
(let ([len ($bytevector-length bv)])
|
||||
(if (and ($fxzero? ($fxlogand i 3)) ($fx< i len))
|
||||
(case endianness
|
||||
[(little) ($bytevector-ieee-single-native-ref bv i)]
|
||||
[(big) ($bytevector-ieee-single-nonnative-ref bv i)]
|
||||
[else (die who "invalid endianness" endianness)])
|
||||
(if ($fx<= i ($fx- len 4))
|
||||
(case endianness
|
||||
[(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 who 'bytevector-ieee-double-set!)
|
||||
(if (bytevector? bv)
|
||||
(if (and (fixnum? i)
|
||||
($fx>= i 0)
|
||||
($fxzero? ($fxlogand i 7))
|
||||
($fx< i ($bytevector-length bv)))
|
||||
(if (flonum? x)
|
||||
(case endianness
|
||||
[(little) ($bytevector-ieee-double-native-set! bv i x)]
|
||||
[(big) ($bytevector-ieee-double-nonnative-set! bv i x)]
|
||||
[else (die 'bytevector-ieee-double-set!
|
||||
"invalid endianness" endianness)])
|
||||
(die 'bytevector-ieee-double-set! "not a flonum" x))
|
||||
(die 'bytevector-ieee-double-set! "invalid index" i))
|
||||
(die 'bytevector-ieee-double-set! "not a bytevector" bv)))
|
||||
(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
|
||||
[(little) ($bytevector-ieee-double-native-set! bv i x)]
|
||||
[(big) ($bytevector-ieee-double-nonnative-set! bv i x)]
|
||||
[else
|
||||
(die who "invalid endianness" endianness)])
|
||||
(if ($fx<= i ($fx- len 8))
|
||||
(case endianness
|
||||
[(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 who 'bytevector-ieee-single-set!)
|
||||
(if (bytevector? bv)
|
||||
(if (and (fixnum? i)
|
||||
($fx>= i 0)
|
||||
($fxzero? ($fxlogand i 3))
|
||||
($fx< i ($bytevector-length bv)))
|
||||
(if (flonum? x)
|
||||
(case endianness
|
||||
[(little) ($bytevector-ieee-single-native-set! bv i x)]
|
||||
[(big) ($bytevector-ieee-single-nonnative-set! bv i x)]
|
||||
[else (die 'bytevector-ieee-single-set!
|
||||
"invalid endianness" endianness)])
|
||||
(die 'bytevector-ieee-single-set! "not a flonum" x))
|
||||
(die 'bytevector-ieee-single-set! "invalid index" i))
|
||||
(die 'bytevector-ieee-single-set! "not a bytevector" bv)))
|
||||
|
||||
(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
|
||||
[(little) ($bytevector-ieee-single-native-set! bv i x)]
|
||||
[(big) ($bytevector-ieee-single-nonnative-set! bv i x)]
|
||||
[else
|
||||
(die who "invalid endianness" endianness)])
|
||||
(if ($fx<= i ($fx- len 4))
|
||||
(case endianness
|
||||
[(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)
|
||||
(if (bytevector? bv)
|
||||
|
|
|
|||
|
|
@ -17,12 +17,12 @@
|
|||
(library (ikarus codecs)
|
||||
(export latin-1-codec utf-8-codec utf-16-codec native-eol-style
|
||||
make-transcoder native-transcoder buffer-mode?
|
||||
file-options-spec transcoder-codec transcoder-eol-style
|
||||
transcoder-codec transcoder-eol-style
|
||||
transcoder-error-handling-mode)
|
||||
(import
|
||||
(except (ikarus) latin-1-codec utf-8-codec utf-16-codec
|
||||
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)
|
||||
(ikarus system $transcoders))
|
||||
(define (latin-1-codec) 'latin-1-codec)
|
||||
|
|
@ -116,32 +116,5 @@
|
|||
(define (buffer-mode? x)
|
||||
(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])))
|
||||
|
||||
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -17,14 +17,16 @@
|
|||
(export make-enumeration enum-set-universe enum-set-indexer
|
||||
enum-set-constructor enum-set->list enum-set-member?
|
||||
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
|
||||
(except (ikarus)
|
||||
make-enumeration enum-set-universe enum-set-indexer
|
||||
enum-set-constructor enum-set->list enum-set-member?
|
||||
enum-set-subset? enum-set=? enum-set-union enum-set-difference
|
||||
enum-set-intersection enum-set-complement
|
||||
enum-set-projection))
|
||||
enum-set-projection
|
||||
make-file-options))
|
||||
|
||||
(define-record-type enum
|
||||
(fields g univ values)
|
||||
|
|
@ -217,6 +219,12 @@
|
|||
(make-enum g u (combine u s))))))
|
||||
(die 'enum-set-projection "not an enumeration" x2))
|
||||
(die 'enum-set-projection "not an enumeration" x1)))
|
||||
|
||||
(define make-file-options
|
||||
(enum-set-constructor
|
||||
(make-enumeration
|
||||
'(no-create no-fail no-truncate))))
|
||||
|
||||
)
|
||||
|
||||
#!eof
|
||||
|
|
|
|||
|
|
@ -1376,16 +1376,12 @@
|
|||
[else fh])))
|
||||
|
||||
(define (open-output-file-handle filename file-options who)
|
||||
(let ([opt (case file-options
|
||||
[(fo:default) 0]
|
||||
[(fo:no-create) 1]
|
||||
[(fo:no-fail) 2]
|
||||
[(fo:no-fail/no-create) 3]
|
||||
[(fo:no-truncate) 4]
|
||||
[(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)])])
|
||||
(define (opt->num x)
|
||||
(bitwise-ior
|
||||
(if (enum-set-member? 'no-create x) 1 0)
|
||||
(if (enum-set-member? 'no-fail x) 2 0)
|
||||
(if (enum-set-member? 'no-truncate x) 4 0)))
|
||||
(let ([opt (opt->num file-options)])
|
||||
(let ([fh (foreign-call "ikrt_open_output_fd"
|
||||
(string->utf8 filename)
|
||||
opt)])
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(library (ikarus flonums)
|
||||
(export $flonum->exact $flonum->integer flonum-parts
|
||||
(export $flonum->exact flonum-parts
|
||||
inexact->exact exact $flonum-rational? $flonum-integer? $flzero?
|
||||
$flnegative? flpositive? flabs fixnum->flonum
|
||||
flsin flcos fltan flasin flacos flatan fleven? flodd?
|
||||
|
|
@ -103,7 +103,7 @@
|
|||
($flround x)
|
||||
(die 'flround "not a flonum" x)))
|
||||
|
||||
(module ($flonum->integer $flonum->exact)
|
||||
(module ($flonum->exact)
|
||||
(define ($flonum-signed-mantissa x)
|
||||
(let ([b0 ($flonum-u8-ref x 0)])
|
||||
(let ([m0 ($fx+ ($flonum-u8-ref x 7)
|
||||
|
|
@ -122,33 +122,6 @@
|
|||
(+ (bitwise-arithmetic-shift-left
|
||||
($fx- 0 ($fxlogor m1 ($fxsll m2 24))) 24)
|
||||
($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)
|
||||
(import (ikarus))
|
||||
(let ([sbe ($flonum-sbe x)])
|
||||
|
|
@ -167,9 +140,9 @@
|
|||
(if (= m 0)
|
||||
0
|
||||
(* (if pos? 1 -1)
|
||||
(/ m (ctexpt 2 1074))))]
|
||||
(/ m (expt 2 1074))))]
|
||||
[else ; normalized flonum
|
||||
(/ (+ m (ctexpt 2 52))
|
||||
(/ (+ m (expt 2 52))
|
||||
(bitwise-arithmetic-shift-left
|
||||
(if pos? 1 -1)
|
||||
(- 1075 be)))]))])))))
|
||||
|
|
@ -413,7 +386,7 @@
|
|||
(ikarus system $chars)
|
||||
(ikarus system $strings)
|
||||
(only (ikarus flonums) $flonum->exact $flzero? $flnegative?
|
||||
$flonum->integer $flround)
|
||||
$flround)
|
||||
(except (ikarus) + - * / zero? = < <= > >= add1 sub1 quotient
|
||||
remainder modulo even? odd? quotient+remainder number->string
|
||||
bitwise-arithmetic-shift-right bitwise-arithmetic-shift-left
|
||||
|
|
@ -1101,23 +1074,35 @@
|
|||
[y (if (< y 0) (- y) y)])
|
||||
(let ([g (binary-gcd x y)])
|
||||
(binary* y (quotient x g))))]
|
||||
[(number? y)
|
||||
(die 'lcm "not an exact integer" y)]
|
||||
[(flonum? y)
|
||||
(let ([v ($flonum->exact y)])
|
||||
(cond
|
||||
[(or (fixnum? v) (bignum? v))
|
||||
(inexact (lcm x v))]
|
||||
[else (die 'lcm "not an integer" y)]))]
|
||||
[else
|
||||
(die 'lcm "not a number" y)])]
|
||||
[(number? x)
|
||||
(die 'lcm "not an exact integer" x)]
|
||||
(die 'lcm "not an integer" y)])]
|
||||
[(flonum? x)
|
||||
(let ([v ($flonum->exact x)])
|
||||
(cond
|
||||
[(or (fixnum? v) (bignum? v))
|
||||
(inexact (lcm v y))]
|
||||
[else (die 'lcm "not an integer" x)]))]
|
||||
[else
|
||||
(die 'lcm "not a number" x)])]
|
||||
(die 'lcm "not an integer" x)])]
|
||||
[(x)
|
||||
(cond
|
||||
[(or (fixnum? x) (bignum? x)) x]
|
||||
[(number? x)
|
||||
(die 'lcm "not an exact integer" x)]
|
||||
[(flonum? x)
|
||||
(let ([v ($flonum->exact x)])
|
||||
(cond
|
||||
[(or (fixnum? v) (bignum? v)) x]
|
||||
[else (die 'lcm "not an integer" x)]))]
|
||||
[else
|
||||
(die 'lcm "not a number" x)])]
|
||||
(die 'lcm "not an integer" x)])]
|
||||
[() 1]
|
||||
[(x y z . ls)
|
||||
;;; FIXME: incorrect for multiple roundings
|
||||
(let f ([g (lcm (lcm x y) z)] [ls ls])
|
||||
(cond
|
||||
[(null? ls) g]
|
||||
|
|
@ -1529,16 +1514,25 @@
|
|||
(cond
|
||||
[(fixnum? x) ($fxeven? 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)]))
|
||||
|
||||
(define (odd? x)
|
||||
(not
|
||||
(cond
|
||||
[(fixnum? x) ($fxeven? x)]
|
||||
[(bignum? x) (even-bignum? x)]
|
||||
[(flonum? x) (die 'odd? "BUG" x)]
|
||||
[else (die 'odd? "not an integer" x)])))
|
||||
(cond
|
||||
[(fixnum? x) (not ($fxeven? x))]
|
||||
[(bignum? x) (not (even-bignum? x))]
|
||||
[(flonum? 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 (bignum->string)
|
||||
|
|
@ -1660,9 +1654,10 @@
|
|||
n
|
||||
(foreign-call "ikrt_fxbnplus" n m)))]
|
||||
[(flonum? m)
|
||||
(let ([v ($flonum->integer m)])
|
||||
(let ([v ($flonum->exact m)])
|
||||
(cond
|
||||
[v (inexact (modulo n v))]
|
||||
[(or (fixnum? v) (bignum? v))
|
||||
(inexact (modulo n v))]
|
||||
[else
|
||||
(die 'modulo "not an integer" m)]))]
|
||||
[(ratnum? m) (die 'modulo "not an integer" m)]
|
||||
|
|
@ -1680,17 +1675,19 @@
|
|||
(+ m (remainder n m))
|
||||
(remainder n m)))]
|
||||
[(flonum? m)
|
||||
(let ([v ($flonum->integer m)])
|
||||
(let ([v ($flonum->exact m)])
|
||||
(cond
|
||||
[v (inexact (modulo n v))]
|
||||
[(or (fixnum? v) (bignum? v))
|
||||
(inexact (modulo n v))]
|
||||
[else
|
||||
(die 'modulo "not an integer" m)]))]
|
||||
[(ratnum? m) (die 'modulo "not an integer" m)]
|
||||
[else (die 'modulo "not a number" m)])]
|
||||
[(flonum? n)
|
||||
(let ([v ($flonum->integer n)])
|
||||
(let ([v ($flonum->exact n)])
|
||||
(cond
|
||||
[v (inexact (modulo v m))]
|
||||
[(or (fixnum? v) (bignum? v))
|
||||
(inexact (modulo v m))]
|
||||
[else
|
||||
(die 'modulo "not an integer" n)]))]
|
||||
[(ratnum? n) (die 'modulo "not an integer" n)]
|
||||
|
|
@ -2385,9 +2382,11 @@
|
|||
[(flonum? m) (flexpt (inexact n) m)]
|
||||
[(ratnum? m) (flexpt (inexact n) (inexact m))]
|
||||
[(or (compnum? m) (cflonum? m))
|
||||
(let ([e 2.718281828459045])
|
||||
(define (ln x) (/ (log x) (log e)))
|
||||
(exp (* m (ln n))))]
|
||||
(if (eq? n 0)
|
||||
0
|
||||
(let ([e 2.718281828459045])
|
||||
(define (ln x) (/ (log x) (log e)))
|
||||
(exp (* m (ln n)))))]
|
||||
[else (die 'expt "not a number" m)])))
|
||||
|
||||
(define quotient
|
||||
|
|
@ -2413,9 +2412,9 @@
|
|||
(fxremainder x y))]
|
||||
[(bignum? y) (values 0 x)]
|
||||
[(flonum? y)
|
||||
(let ([v ($flonum->integer y)])
|
||||
(let ([v ($flonum->exact y)])
|
||||
(cond
|
||||
[v
|
||||
[(or (fixnum? v) (bignum? v))
|
||||
(let-values ([(q r) (quotient+remainder x v)])
|
||||
(values (inexact q) (inexact r)))]
|
||||
[else
|
||||
|
|
@ -2430,18 +2429,18 @@
|
|||
(let ([p (foreign-call "ikrt_bnbndivrem" x y)])
|
||||
(values (car p) (cdr p)))]
|
||||
[(flonum? y)
|
||||
(let ([v ($flonum->integer y)])
|
||||
(let ([v ($flonum->exact y)])
|
||||
(cond
|
||||
[v
|
||||
[(or (fixnum? v) (bignum? v))
|
||||
(let-values ([(q r) (quotient+remainder x v)])
|
||||
(values (inexact q) (inexact r)))]
|
||||
[else
|
||||
(die 'quotient+remainder "not an integer" y)]))]
|
||||
[else (die 'quotient+remainder "not a number" y)])]
|
||||
[(flonum? x)
|
||||
(let ([v ($flonum->integer x)])
|
||||
(let ([v ($flonum->exact x)])
|
||||
(cond
|
||||
[v
|
||||
[(or (fixnum? v) (bignum? v))
|
||||
(let-values ([(q r) (quotient+remainder v y)])
|
||||
(values (inexact q) (inexact r)))]
|
||||
[else (die 'quotient+remainder "not an integer" x)]))]
|
||||
|
|
@ -2695,8 +2694,7 @@
|
|||
;;;
|
||||
(cond
|
||||
[(flonum? x)
|
||||
(let ([e (or ($flonum->exact x)
|
||||
(die 'truncate "number has no real value" x))])
|
||||
(let ([e ($flonum->exact x)])
|
||||
(cond
|
||||
[(ratnum? e) (exact->inexact ($ratnum-truncate e))]
|
||||
[else x]))]
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1550
|
||||
1551
|
||||
|
|
|
|||
|
|
@ -1333,7 +1333,7 @@
|
|||
[syntax-error i]
|
||||
[$transcoder->data $transc]
|
||||
[$data->transcoder $transc]
|
||||
[file-options-spec i]
|
||||
[make-file-options i]
|
||||
;;;
|
||||
[port-id i]
|
||||
[read-annotated i]
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@
|
|||
(library (psyntax compat)
|
||||
(export define-record make-parameter parameterize format gensym
|
||||
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-stripped
|
||||
read-library-source-file)
|
||||
|
|
|
|||
|
|
@ -2599,10 +2599,12 @@
|
|||
|
||||
(define file-options-macro
|
||||
(lambda (x)
|
||||
(define (valid-option? x)
|
||||
(and (id? x) (memq (id->sym x) '(no-fail no-create no-truncate))))
|
||||
(syntax-match x ()
|
||||
((_ opt* ...)
|
||||
(and (for-all id? opt*) (file-options-spec (map id->sym opt*)))
|
||||
(bless `(quote ,(file-options-spec (map id->sym opt*))))))))
|
||||
(for-all valid-option? opt*)
|
||||
(bless `(make-file-options ',opt*))))))
|
||||
|
||||
(define symbol-macro
|
||||
(lambda (x set)
|
||||
|
|
|
|||
Loading…
Reference in New Issue