~ chicken-core (chicken-5) 0378abc4f4ec7a302fd8ba60175558f806530eea
commit 0378abc4f4ec7a302fd8ba60175558f806530eea
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Sat Jan 24 21:56:42 2015 +0100
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun May 31 14:12:40 2015 +0200
Add basic support for reading and writing of extended numbers.
This adds the following new procedures:
- integer-length to get the length in bits for an integer (from SRFI 33)
- fxlen to get the integer length of a fixnum
It doesn't work 100%: ratnums can't be read yet because there's no
division support yet (they need to be simplified after reading),
and exact numbers can't be read in scientific notation yet due to
missing integer-power and aforementioned division procedures.
Reading complex numbers works, except for exact compnums due to the
above caveats), and bignums work when written as a sequence of digits
in any radix.
diff --git a/c-platform.scm b/c-platform.scm
index 501a2a47..4659f486 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -142,11 +142,11 @@
(set! default-extended-bindings
'(bignum? cplxnum? ratnum? bitwise-and bitwise-ior bitwise-xor bitwise-not
add1 sub1 fx+ fx- fx* fx/ fx+? fx-? fx*? fx/? fxmod o fp/?
- fx= fx> fx< fx>= fx<= fixnum? fxneg fxmax fxmin identity fp+ fp- fp* fp/ fpmin fpmax fpneg
+ fx= fx> fx< fx>= fx<= fixnum? fxneg fxmax fxmin fxlen identity fp+ fp- fp* fp/ fpmin fpmax fpneg
fp> fp< fp= fp>= fp<= fxand fxnot fxior fxxor fxshr fxshl bit-set? fxodd? fxeven?
fpfloor fpceiling fptruncate fpround fpsin fpcos fptan fpasin fpacos fpatan
fpatan2 fpexp fpexpt fplog fpsqrt fpabs fpinteger? exact-integer?
- arithmetic-shift void flush-output
+ integer-length arithmetic-shift void flush-output
atom? print print* error call/cc
blob-size u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared
s16vector->blob/shared u32vector->blob/shared s32vector->blob/shared
@@ -629,6 +629,7 @@
(rewrite 'fxmin 2 2 "C_i_fixnum_min" #t)
(rewrite 'fpmax 2 2 "C_i_flonum_max" #f)
(rewrite 'fpmin 2 2 "C_i_flonum_min" #f)
+(rewrite 'fxlen 2 1 "C_i_fixnum_length" #t)
(rewrite 'char-numeric? 2 1 "C_u_i_char_numericp" #t)
(rewrite 'char-alphabetic? 2 1 "C_u_i_char_alphabeticp" #t)
(rewrite 'char-whitespace? 2 1 "C_u_i_char_whitespacep" #t)
@@ -821,24 +822,6 @@
(rewrite 'fpceiling 16 1 "C_a_i_flonum_ceiling" #f words-per-flonum)
(rewrite 'fpround 16 1 "C_a_i_flonum_floor" #f words-per-flonum)
-(rewrite
- 'string->number 8
- (lambda (db classargs cont callargs)
- ;; (string->number X) -> (##core#inline_allocate ("C_a_i_string_to_number" 4) X 10)
- ;; (string->number X Y) -> (##core#inline_allocate ("C_a_i_string_to_number" 4) X Y)
- (define (build x y)
- (make-node
- '##core#call (list #t)
- (list cont
- (make-node
- '##core#inline_allocate
- '("C_a_i_string_to_number" 4) ; words-per-flonum
- (list x y)))))
- (case (length callargs)
- ((1) (build (first callargs) (qnode 10)))
- ((2) (build (first callargs) (second callargs)))
- (else #f))))
-
(rewrite 'cons 16 2 "C_a_i_cons" #t 3)
(rewrite '##sys#cons 16 2 "C_a_i_cons" #t 3)
(rewrite 'list 16 #f "C_a_i_list" #t '(1 3) #t)
@@ -1124,6 +1107,18 @@
(list (if (eq? number-type 'fixnum) "C_u_i_bit_setp" "C_i_bit_setp"))
callargs) ) ) ) ) )
+(rewrite
+ 'integer-length 8
+ (lambda (db classargs cont callargs)
+ (and (= 1 (length callargs))
+ (make-node
+ '##core#call (list #t)
+ (list cont
+ (make-node
+ '##core#inline
+ (list (if (eq? number-type 'fixnum) "C_i_fixnum_length" "C_i_integer_length"))
+ callargs) ) ) ) ) )
+
(rewrite 'read-char 23 0 '##sys#read-char/port '##sys#standard-input)
(rewrite 'write-char 23 1 '##sys#write-char/port '##sys#standard-output)
(rewrite 'read-string 23 1 '##sys#read-string/port '##sys#standard-input)
diff --git a/chicken.h b/chicken.h
index ca25047c..569dc1a9 100644
--- a/chicken.h
+++ b/chicken.h
@@ -419,6 +419,7 @@ static inline int isinf_ld (long double x)
#endif
/* These might fit better in runtime.c? */
+#define C_fitsinbignumhalfdigitp(n) (C_BIGNUM_DIGIT_HI_HALF(n) == 0)
#define C_BIGNUM_DIGIT_LENGTH C_WORD_SIZE
#define C_BIGNUM_HALF_DIGIT_LENGTH C_HALF_WORD_SIZE
#define C_BIGNUM_BITS_TO_DIGITS(n) \
@@ -1265,6 +1266,7 @@ extern double trunc(double);
#define C_u_fixnum_decrease(n) ((n) - (1 << C_FIXNUM_SHIFT))
#define C_fixnum_decrease(n) (C_u_fixnum_decrease(n) | C_FIXNUM_BIT)
#define C_fixnum_abs(n) C_fix(abs(C_unfix(n)))
+#define C_i_fixnum_length(x) C_fix(C_ilen(((x) & C_INT_SIGN_BIT) ? ~C_unfix(x) : C_unfix(x)))
#define C_flonum_equalp(n1, n2) C_mk_bool(C_flonum_magnitude(n1) == C_flonum_magnitude(n2))
#define C_flonum_greaterp(n1, n2) C_mk_bool(C_flonum_magnitude(n1) > C_flonum_magnitude(n2))
@@ -1882,8 +1884,11 @@ C_fctexport void C_ccall C_allocate_bignum(C_word c, C_word self, C_word k, C_wo
C_fctexport void C_ccall C_string_to_symbol(C_word c, C_word closure, C_word k, C_word string) C_noret;
C_fctexport void C_ccall C_build_symbol(C_word c, C_word closure, C_word k, C_word string) C_noret;
C_fctexport void C_ccall C_quotient(C_word c, C_word closure, C_word k, C_word n1, C_word n2) C_noret;
+C_fctexport void C_ccall C_digits_to_integer(C_word c, C_word self, C_word k, C_word n, C_word start, C_word end, C_word radix, C_word negp) C_noret;
C_fctexport void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num, ...) C_noret;
-C_fctexport void C_ccall C_fixnum_to_string(C_word c, C_word closure, C_word k, C_word num) C_noret;
+C_fctexport void C_ccall C_fixnum_to_string(C_word c, C_word closure, C_word k, C_word num, C_word radix) C_noret;
+C_fctexport void C_ccall C_flonum_to_string(C_word c, C_word closure, C_word k, C_word num, C_word radix) C_noret;
+C_fctexport void C_ccall C_integer_to_string(C_word c, C_word closure, C_word k, C_word num, C_word radix) C_noret;
C_fctexport void C_ccall C_make_structure(C_word c, C_word closure, C_word k, C_word type, ...) C_noret;
C_fctexport void C_ccall C_make_symbol(C_word c, C_word closure, C_word k, C_word name) C_noret;
C_fctexport void C_ccall C_make_pointer(C_word c, C_word closure, C_word k) C_noret;
@@ -2010,6 +2015,7 @@ C_fctexport C_word C_fcall C_a_i_bitwise_and(C_word **a, int c, C_word n1, C_wor
C_fctexport C_word C_fcall C_a_i_bitwise_ior(C_word **a, int c, C_word n1, C_word n2) C_regparm;
C_fctexport C_word C_fcall C_a_i_bitwise_not(C_word **a, int c, C_word n1) C_regparm;
C_fctexport C_word C_fcall C_i_bit_setp(C_word n, C_word i) C_regparm;
+C_fctexport C_word C_fcall C_i_integer_length(C_word x) C_regparm;
C_fctexport C_word C_fcall C_a_i_bitwise_xor(C_word **a, int c, C_word n1, C_word n2) C_regparm;
C_fctexport C_word C_fcall C_a_i_arithmetic_shift(C_word **a, int c, C_word n1, C_word n2) C_regparm;
C_fctexport C_word C_fcall C_a_i_exp(C_word **a, int c, C_word n) C_regparm;
@@ -2036,6 +2042,7 @@ C_fctexport C_word C_fcall C_i_get_keyword(C_word key, C_word args, C_word def)
C_fctexport double C_fcall C_milliseconds(void) C_regparm;
C_fctexport double C_fcall C_cpu_milliseconds(void) C_regparm;
C_fctexport C_word C_fcall C_a_i_cpu_time(C_word **a, int c, C_word buf) C_regparm;
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport C_word C_fcall C_a_i_string_to_number(C_word **a, int c, C_word str, C_word radix) C_regparm;
C_fctexport C_word C_fcall C_a_i_exact_to_inexact(C_word **a, int c, C_word n) C_regparm;
C_fctexport C_word C_fcall C_i_file_exists_p(C_word name, C_word file, C_word dir) C_regparm;
@@ -3062,6 +3069,26 @@ C_inline C_word C_a_u_i_fix_to_big(C_word **ptr, C_word x)
return C_bignum1(ptr, 0, x);
}
+/*
+ * From Hacker's Delight by Henry S. Warren
+ * based on a modified nlz() from section 5-3 (fig. 5-7)
+ */
+C_inline int C_ilen(C_uword x)
+{
+ C_uword y;
+ C_word n = 0;
+
+#ifdef C_SIXTY_FOUR
+ y = x >> 32; if (y != 0) { n += 32; x = y; }
+#endif
+ y = x >> 16; if (y != 0) { n += 16; x = y; }
+ y = x >> 8; if (y != 0) { n += 8; x = y; }
+ y = x >> 4; if (y != 0) { n += 4; x = y; }
+ y = x >> 2; if (y != 0) { n += 2; x = y; }
+ y = x >> 1; if (y != 0) return n + 2;
+ return n + x;
+}
+
/* These strl* functions are based on public domain code by C.B. Falconer */
#ifdef HAVE_STRLCPY
# define C_strlcpy strlcpy
diff --git a/chicken.import.scm b/chicken.import.scm
index 6cceb89c..a325410b 100644
--- a/chicken.import.scm
+++ b/chicken.import.scm
@@ -140,6 +140,7 @@
fxand
fxeven?
fxior
+ fxlen
fxmax
fxmin
fxmod
@@ -161,6 +162,7 @@
getter-with-setter
implicit-exit-handler
infinite?
+ integer-length
ir-macro-transformer
keyword->string
keyword-style
diff --git a/library.scm b/library.scm
index 5cda691c..75b8b7b9 100644
--- a/library.scm
+++ b/library.scm
@@ -35,7 +35,11 @@
##sys#print-exit
##sys#format-here-doc-warning
exit-in-progress
- maximal-string-length)
+ maximal-string-length
+ ##sys#integer-power ##sys#integer-quotient
+ make-complex
+ +maximum-allowed-exponent+ mantexp->dbl ldexp round-quotient
+ ##sys#string->compnum)
(not inline ##sys#user-read-hook ##sys#error-hook ##sys#signal-hook ##sys#schedule
##sys#default-read-info-hook ##sys#infix-list-hook ##sys#sharp-number-hook
##sys#user-print-hook ##sys#user-interrupt-hook ##sys#step-hook)
@@ -443,6 +447,10 @@ EOF
(##sys#error-hook
(foreign-value "C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR" int) loc arg))
+(define (##sys#error-bad-base arg #!optional loc)
+ (##sys#error-hook
+ (foreign-value "C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR" int) loc arg))
+
(define (append . lsts)
(if (eq? lsts '())
lsts
@@ -735,6 +743,7 @@ EOF
(define (fxshr x y) (##core#inline "C_fixnum_shift_right" x y))
(define (fxodd? x) (##core#inline "C_i_fixnumoddp" x))
(define (fxeven? x) (##core#inline "C_i_fixnumevenp" x))
+(define (fxlen x) (##core#inline "C_i_fixnum_length" x))
(define (fx/ x y) (##core#inline "C_fixnum_divide" x y) )
(define (fxmod x y) (##core#inline "C_fixnum_modulo" x y) )
@@ -896,6 +905,13 @@ EOF
(fp-check-flonum x 'fpinteger?)
(##core#inline "C_u_i_fpintegerp" x))
+;; Placeholders for later
+(define (##sys#+-2 a b) (+ a b))
+(define (##sys#*-2 a b) (* a b))
+(define (##sys#/-2 a b) (/ a b))
+(define (##sys#integer-power a b) (expt a b))
+(define (##sys#integer-quotient a b) (quotient a b))
+
(define * (##core#primitive "C_times"))
(define - (##core#primitive "C_minus"))
(define + (##core#primitive "C_plus"))
@@ -955,8 +971,9 @@ EOF
(##sys#check-real r 'make-polar)
(##sys#check-real phi 'make-polar)
(let ((fphi (exact->inexact phi)))
- (make-complex (* r (##core#inline_allocate ("C_a_i_cos" 4) fphi))
- (* r (##core#inline_allocate ("C_a_i_sin" 4) fphi)))))
+ (make-complex
+ (##sys#*-2 r (##core#inline_allocate ("C_a_i_cos" 4) fphi))
+ (##sys#*-2 r (##core#inline_allocate ("C_a_i_sin" 4) fphi)))))
(define (real-part x)
(cond ((cplxnum? x) (%cplxnum-real x))
@@ -1148,19 +1165,289 @@ EOF
(##sys#lcm head n2)
(##sys#slot next 1)) #f) ) ) ) ) ) )
-(define (string->number str #!optional (radix 10) exactness)
- (let ((num (##core#inline_allocate ("C_a_i_string_to_number" 4) str radix)))
- (case exactness
- ((i) (##core#inline_allocate ("C_a_i_exact_to_inexact" 4) num))
- ;; If inf/nan, don't error but just return #f
- ((e) (and num
- (##core#inline "C_i_finitep" num)
- (##core#inline "C_i_inexact_to_exact" num)))
- (else num))))
-
-(define ##sys#string->number string->number)
+(define ##sys#extended-number->string
+ (let ((string-append string-append))
+ (lambda (n base)
+ (cond
+ ((ratnum? n)
+ (string-append (number->string (%ratnum-numerator n) base)
+ "/"
+ (number->string (%ratnum-denominator n) base)))
+ ;; What about bases that include an "i"? That could lead to
+ ;; ambiguous results.
+ ((cplxnum? n) (let ((r (%cplxnum-real n))
+ (i (%cplxnum-imag n)) )
+ (string-append
+ (number->string r base)
+ ;; The infinities and NaN always print their sign
+ (if (and (finite? i) (positive? i)) "+" "")
+ (number->string i base) "i") ))
+ (else (##sys#error-bad-number 'number->string n))) ) ) )
+
+(define number->string (##core#primitive "C_number_to_string"))
+(define ##sys#number->string number->string) ; for printer
+
+;; We try to prevent memory exhaustion attacks by limiting the
+;; maximum exponent value. Perhaps this should be a parameter?
+(define-constant +maximum-allowed-exponent+ 10000)
+
+;; From "Easy Accurate Reading and Writing of Floating-Point Numbers"
+;; by Aubrey Jaffer.
+(define (mantexp->dbl mant point)
+ (if (not (negative? point))
+ (exact->inexact (##sys#*-2 mant (##sys#integer-power 10 point)))
+ (let* ((scl (##sys#integer-power 10 (abs point)))
+ (bex (fx- (fx- (integer-length mant) (integer-length scl))
+ flonum-precision)))
+ (if (fx< bex 0)
+ (let* ((num (arithmetic-shift mant (fxneg bex)))
+ (quo (round-quotient num scl)))
+ (cond ((> (integer-length quo) flonum-precision)
+ ;; Too many bits of quotient; readjust
+ (set! bex (fx+ 1 bex))
+ (set! quo (round-quotient num (##sys#*-2 scl 2)))))
+ (ldexp (exact->inexact quo) bex))
+ ;; Fall back to exact calculation in extreme cases
+ (##sys#*-2 mant (##sys#integer-power 10 point))))))
+
+(define ldexp (foreign-lambda double "ldexp" double int))
+
+;; Should we export this?
+(define (round-quotient n d)
+ (let ((q (##sys#integer-quotient n d)))
+ (if ((if (even? q) > >=) (##sys#*-2 (abs (remainder n d)) 2) (abs d))
+ (##sys#+-2 q (if (eqv? (negative? n) (negative? d)) 1 -1))
+ q)))
+
+;; Shorthand for readability. TODO: Replace other C_subchar calls with this
+(define-inline (%subchar s i) (##core#inline "C_subchar" s i))
+(define (##sys#string->compnum radix str offset exactness)
+ (define (go-inexact!)
+ ;; Go inexact unless exact was requested (with #e prefix)
+ (unless (eq? exactness 'e) (set! exactness 'i)))
+ (define (safe-exponent value e)
+ (and e (cond
+ ((not value) 0)
+ ((> e +maximum-allowed-exponent+)
+ (and (eq? exactness 'i)
+ (cond ((zero? value) 0.0)
+ ((> value 0.0) +inf.0)
+ (else -inf.0))))
+ ((< e (fxneg +maximum-allowed-exponent+))
+ (and (eq? exactness 'i) +0.0))
+ ((eq? exactness 'i) (mantexp->dbl value e))
+ (else (##sys#*-2 value (##sys#integer-power 10 e))))))
+ (define (make-nan)
+ ;; Return fresh NaNs, so eqv? returns #f on two read NaNs. This
+ ;; is not mandated by the standard, but compatible with earlier
+ ;; CHICKENs and it just makes more sense.
+ (##core#inline_allocate ("C_a_i_flonum_quotient" 4) 0.0 0.0))
+ (let* ((len (##sys#size str))
+ (0..r (integer->char (fx+ (char->integer #\0) (fx- radix 1))))
+ (a..r (integer->char (fx+ (char->integer #\a) (fx- radix 11))))
+ (A..r (integer->char (fx+ (char->integer #\A) (fx- radix 11))))
+ ;; Ugly flag which we need (note that "exactness" is mutated too!)
+ ;; Since there is (almost) no backtracking we can do this.
+ (seen-hashes? #f)
+ ;; All these procedures return #f or an object consed onto an end
+ ;; position. If the cdr is false, that's the end of the string.
+ ;; If just #f is returned, the string contains invalid number syntax.
+ (scan-digits
+ (lambda (start)
+ (let lp ((i start))
+ (if (fx= i len)
+ (and (fx> i start) (cons i #f))
+ (let ((c (%subchar str i)))
+ (if (fx<= radix 10)
+ (if (and (char>=? c #\0) (char<=? c 0..r))
+ (lp (fx+ i 1))
+ (and (fx> i start) (cons i i)))
+ (if (or (and (char>=? c #\0) (char<=? c #\9))
+ (and (char>=? c #\a) (char<=? c a..r))
+ (and (char>=? c #\A) (char<=? c A..r)))
+ (lp (fx+ i 1))
+ (and (fx> i start) (cons i i)))))))))
+ (scan-hashes
+ (lambda (start)
+ (let lp ((i start))
+ (if (fx= i len)
+ (and (fx> i start) (cons i #f))
+ (let ((c (%subchar str i)))
+ (if (eq? c #\#)
+ (lp (fx+ i 1))
+ (and (fx> i start) (cons i i))))))))
+ (scan-digits+hashes
+ (lambda (start neg? all-hashes-ok?)
+ (let* ((digits (and (not seen-hashes?) (scan-digits start)))
+ (hashes (if digits
+ (and (cdr digits) (scan-hashes (cdr digits)))
+ (and all-hashes-ok? (scan-hashes start))))
+ (end (or hashes digits)))
+ (and-let* ((end)
+ (num ((##core#primitive "C_digits_to_integer")
+ str start (car end) radix neg?)))
+ (when hashes ; Eeewww. Feeling dirty yet?
+ (set! seen-hashes? #t)
+ (go-inexact!))
+ (cons num (cdr end))))))
+ (scan-exponent
+ (lambda (start)
+ (and (fx< start len)
+ (let ((sign (case (%subchar str start)
+ ((#\+) 'pos) ((#\-) 'neg) (else #f))))
+ (and-let* ((start (if sign (fx+ start 1) start))
+ (end (scan-digits start)))
+ (go-inexact!)
+ (cons ((##core#primitive "C_digits_to_integer")
+ str start (car end) radix (eq? sign 'neg))
+ (cdr end)))))))
+ (scan-decimal-tail ; The part after the decimal dot
+ (lambda (start neg? decimal-head)
+ (and (fx< start len)
+ (let* ((tail (scan-digits+hashes start neg? decimal-head))
+ (next (if tail (cdr tail) start)))
+ (and (or decimal-head (not next)
+ (fx> next start)) ; Don't allow empty "."
+ (case (and next (%subchar str next))
+ ((#\e #\s #\f #\d #\l
+ #\E #\S #\F #\D #\L)
+ (and-let* (((fx> len next))
+ (ee (scan-exponent (fx+ next 1)))
+ (e (car ee))
+ (h (safe-exponent decimal-head e)))
+ (let* ((te (and tail (fx- e (fx- (cdr tail) start))))
+ (num (and tail (car tail)))
+ (t (safe-exponent num te)))
+ (cons (if t (##sys#+-2 h t) h) (cdr ee)))))
+ (else (let* ((last (or next len))
+ (te (and tail (fx- start last)))
+ (num (and tail (car tail)))
+ (t (safe-exponent num te))
+ (h (or decimal-head 0)))
+ (cons (if t (##sys#+-2 h t) h) next)))))))))
+ (scan-ureal
+ (lambda (start neg?)
+ (if (and (fx> len (fx+ start 1)) (eq? radix 10)
+ (eq? (%subchar str start) #\.))
+ (begin
+ (go-inexact!)
+ (scan-decimal-tail (fx+ start 1) neg? #f))
+ (and-let* ((end (scan-digits+hashes start neg? #f)))
+ (case (and (cdr end) (%subchar str (cdr end)))
+ ((#\.)
+ (go-inexact!)
+ (and (eq? radix 10)
+ (if (fx> len (fx+ (cdr end) 1))
+ (scan-decimal-tail (fx+ (cdr end) 1) neg? (car end))
+ (cons (car end) #f))))
+ ((#\e #\s #\f #\d #\l
+ #\E #\S #\F #\D #\L)
+ (and-let* (((eq? radix 10))
+ ((fx> len (cdr end)))
+ (ee (scan-exponent (fx+ (cdr end) 1)))
+ (num (car end))
+ (val (safe-exponent num (car ee))))
+ (cons val (cdr ee))))
+ ((#\/)
+ (set! seen-hashes? #f) ; Reset flag for denominator
+ (and-let* (((fx> len (cdr end)))
+ (d (scan-digits+hashes (fx+ (cdr end) 1) #f #f))
+ (num (car end))
+ (denom (car d)))
+ (if (not (eq? denom 0))
+ (cons (##sys#/-2 num denom) (cdr d))
+ ;; Hacky: keep around an inexact until we decide we
+ ;; *really* need exact values, then fail at the end.
+ (and (not (eq? exactness 'e))
+ (case (signum num)
+ ((-1) (cons -inf.0 (cdr d)))
+ ((0) (cons (make-nan) (cdr d)))
+ ((+1) (cons +inf.0 (cdr d))))))))
+ (else end))))))
+ (scan-real
+ (lambda (start)
+ (and (fx< start len)
+ (let* ((sign (case (%subchar str start)
+ ((#\+) 'pos) ((#\-) 'neg) (else #f)))
+ (next (if sign (fx+ start 1) start)))
+ (and (fx< next len)
+ (case (%subchar str next)
+ ((#\i #\I)
+ (or (and sign
+ (cond
+ ((fx= (fx+ next 1) len) ; [+-]i
+ (cons (if (eq? sign 'neg) -1 1) next))
+ ((and (fx<= (fx+ next 5) len)
+ (string-ci=? (substring str next (fx+ next 5)) "inf.0"))
+ (go-inexact!)
+ (cons (if (eq? sign 'neg) -inf.0 +inf.0)
+ (and (fx< (fx+ next 5) len)
+ (fx+ next 5))))
+ (else #f)))
+ (scan-ureal next (eq? sign 'neg))))
+ ((#\n #\N)
+ (or (and sign
+ (fx<= (fx+ next 5) len)
+ (string-ci=? (substring str next (fx+ next 5)) "nan.0")
+ (begin (go-inexact!)
+ (cons (make-nan)
+ (and (fx< (fx+ next 5) len)
+ (fx+ next 5)))))
+ (scan-ureal next (eq? sign 'neg))))
+ (else (scan-ureal next (eq? sign 'neg)))))))))
+ (number (and-let* ((r1 (scan-real offset)))
+ (case (and (cdr r1) (%subchar str (cdr r1)))
+ ((#f) (car r1))
+ ((#\i #\I) (and (fx= len (fx+ (cdr r1) 1))
+ (or (eq? (%subchar str offset) #\+) ; ugh
+ (eq? (%subchar str offset) #\-))
+ (make-rectangular 0 (car r1))))
+ ((#\+ #\-)
+ (set! seen-hashes? #f) ; Reset flag for imaginary part
+ (and-let* ((r2 (scan-real (cdr r1)))
+ ((cdr r2))
+ ((fx= len (fx+ (cdr r2) 1)))
+ ((or (eq? (%subchar str (cdr r2)) #\i)
+ (eq? (%subchar str (cdr r2)) #\I))))
+ (make-rectangular (car r1) (car r2))))
+ ((#\@)
+ (set! seen-hashes? #f) ; Reset flag for angle
+ (and-let* ((r2 (scan-real (fx+ (cdr r1) 1)))
+ ((not (cdr r2))))
+ (make-polar (car r1) (car r2))))
+ (else #f)))))
+ (and number (if (eq? exactness 'i)
+ (exact->inexact number)
+ ;; Ensure we didn't encounter +inf.0 or +nan.0 with #e
+ (and (finite? number) number)))))
+
+(define (string->number str #!optional (base 10))
+ (##sys#check-string str 'string->number)
+ (unless (and (##core#inline "C_fixnump" base)
+ (fx< 1 base) (fx< base 37)) ; We only have 0-9 and the alphabet!
+ (##sys#error-bad-base base 'string->number))
+ (let scan-prefix ((i 0)
+ (exness #f)
+ (radix #f)
+ (len (##sys#size str)))
+ (if (and (fx< (fx+ i 2) len) (eq? (%subchar str i) #\#))
+ (case (%subchar str (fx+ i 1))
+ ((#\i #\I) (and (not exness) (scan-prefix (fx+ i 2) 'i radix len)))
+ ((#\e #\E) (and (not exness) (scan-prefix (fx+ i 2) 'e radix len)))
+ ((#\b #\B) (and (not radix) (scan-prefix (fx+ i 2) exness 2 len)))
+ ((#\o #\O) (and (not radix) (scan-prefix (fx+ i 2) exness 8 len)))
+ ((#\d #\D) (and (not radix) (scan-prefix (fx+ i 2) exness 10 len)))
+ ((#\x #\X) (and (not radix) (scan-prefix (fx+ i 2) exness 16 len)))
+ (else #f))
+ (##sys#string->compnum (or radix base) str i exness))))
+
+(define (##sys#string->number str #!optional (radix 10) exactness)
+ (##sys#string->compnum radix str 0 exactness))
+
(define number->string (##core#primitive "C_number_to_string"))
(define ##sys#fixnum->string (##core#primitive "C_fixnum_to_string"))
+(define ##sys#flonum->string (##core#primitive "C_flonum_to_string"))
+(define ##sys#integer->string (##core#primitive "C_integer_to_string"))
(define ##sys#number->string number->string)
(define (flonum-print-precision #!optional prec)
@@ -2431,15 +2718,14 @@ EOF
(current-read-table current-read-table)
(kwprefix (string (integer->char 0))))
(lambda (port infohandler)
- (let ([csp (case-sensitive)]
- [ksp (keyword-style)]
- [psp (parentheses-synonyms)]
- [sep (symbol-escape)]
- [crt (current-read-table)]
- [rat-flag #f]
+ (let ((csp (case-sensitive))
+ (ksp (keyword-style))
+ (psp (parentheses-synonyms))
+ (sep (symbol-escape))
+ (crt (current-read-table))
; set below - needs more state to make a decision
(terminating-characters '(#\, #\; #\( #\) #\' #\" #\[ #\] #\{ #\}))
- [reserved-characters #f] )
+ (reserved-characters #f) )
(define (container c)
(##sys#read-error port "unexpected list terminator" c) )
@@ -2661,7 +2947,6 @@ EOF
(##sys#read-error port "invalid vector syntax" lst) ) ) )
(define (r-number radix exactness)
- (set! rat-flag #f)
(r-xtoken
(lambda (tok kw)
(cond (kw
@@ -2671,16 +2956,9 @@ EOF
(##sys#read-error port "invalid use of `.'"))
((and (fx> (##sys#size tok) 0) (char=? (string-ref tok 0) #\#))
(##sys#read-error port "unexpected prefix in number syntax" tok))
- (else
- (let ((val (##sys#string->number tok (or radix 10) exactness)) )
- (cond (val
- (when (and (##sys#inexact? val) (not (eq? exactness 'i)) rat-flag)
- (##sys#read-warning
- port
- "cannot represent exact fraction - coerced to flonum" tok) )
- val)
- (radix (##sys#read-error port "illegal number syntax" tok))
- (else (build-symbol tok)) ) ) ) ) ) ))
+ ((##sys#string->number tok (or radix 10) exactness))
+ (radix (##sys#read-error port "illegal number syntax" tok))
+ (else (build-symbol tok)) ) ) ))
(define (r-number-with-exactness radix)
(cond [(eq? #\# (##sys#peek-char-0 port))
@@ -2717,7 +2995,6 @@ EOF
((char=? c #\x00)
(##sys#read-error port "attempt to read expression from something that looks like binary data"))
(else
- (when (char=? c #\/) (set! rat-flag #t))
(read-unreserved-char-0 port)
(loop (##sys#peek-char-0 port)
(cons (if csp c (char-downcase c)) lst) ) ) ) ) )
@@ -3485,8 +3762,11 @@ EOF
(thunk)))))))
-;;; Bitwise fixnum operations:
+;;; Bitwise operations:
+;; From SRFI-33
+(define (integer-length x) (##core#inline "C_i_integer_length" x))
+
(define (bitwise-and . xs)
(let loop ([x -1] [xs xs])
(if (null? xs)
diff --git a/manual/C interface b/manual/C interface
index 81caf6f5..a24f0578 100644
--- a/manual/C interface
+++ b/manual/C interface
@@ -1023,6 +1023,12 @@ Returns the smallest of the two fixnums {{n1}} and {{n2}}.
Returns the largest of the two fixnums {{n1}} and {{n2}}.
+===== C_i_fixnum_length
+
+ [C function] C_word C_i_fixnum_length(C_word x)
+
+Returns the integer length in bits of the fixnum {{x}} (as a fixnum).
+
==== Flonums
diff --git a/manual/Unit library b/manual/Unit library
index c1beed5e..c0ab0042 100644
--- a/manual/Unit library
+++ b/manual/Unit library
@@ -38,6 +38,13 @@ platforms).
Returns {{#t}} if the bit at the position {{INDEX}} in the integer {{N}} is
set, or {{#f}} otherwise. The rightmost/least-significant bit is bit 0.
+==== integer-length
+
+<procedure>(integer-length N)</procedure>
+
+Returns the number of bits needed to represent the exact integer N in
+2's complement notation.
+
==== bignum?
<procedure>(bignum? X)</procedure>
diff --git a/runtime.c b/runtime.c
index 627e6639..e0ef4e7d 100644
--- a/runtime.c
+++ b/runtime.c
@@ -489,6 +489,7 @@ static void initialize_symbol_table(void);
static void global_signal_handler(int signum);
static C_word arg_val(C_char *arg);
static void barf(int code, char *loc, ...) C_noret;
+static void try_extended_number(char *ext_proc_name, C_word c, C_word k, ...) C_noret;
static void panic(C_char *msg) C_noret;
static void usual_panic(C_char *msg) C_noret;
static void horror(C_char *msg) C_noret;
@@ -504,6 +505,9 @@ static C_word C_fcall hash_string(int len, C_char *str, C_word m, C_word r, int
static C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
static double compute_symbol_table_load(double *avg_bucket_len, int *total);
static C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word *fix, double *flo) C_regparm;
+static void digits_to_integer_2(C_word c, C_word self, C_word result) C_noret;
+static C_regparm C_word str_to_bignum(C_word bignum, char *str, char *str_end, int radix);
+static void bignum_to_str_2(C_word c, C_word self, C_word string) C_noret;
static C_word C_fcall maybe_inexact_to_exact(C_word n) C_regparm;
static void C_fcall remark_system_globals(void) C_regparm;
static void C_fcall really_remark(C_word *x) C_regparm;
@@ -517,6 +521,8 @@ static void gc_2(void *dummy) C_noret;
static void allocate_vector_2(void *dummy) C_noret;
static void allocate_bignum_2(void *dummy) C_noret;
static C_word allocate_tmp_bignum(C_word size, C_word negp, C_word initp);
+static C_uword bignum_digits_destructive_scale_up_with_carry(C_uword *start, C_uword *end, C_uword factor, C_uword carry);
+static C_uword bignum_digits_destructive_scale_down(C_uword *start, C_uword *end, C_uword denominator);
static void make_structure_2(void *dummy) C_noret;
static void generic_trampoline(void *dummy) C_noret;
static void handle_interrupt(void *trampoline, void *proc) C_noret;
@@ -789,7 +795,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
{
/* IMPORTANT: hardcoded table size -
this must match the number of C_pte calls + 1 (NULL terminator)! */
- C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 54);
+ C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 58);
int i = 0;
if(pt == NULL)
@@ -849,6 +855,10 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(C_copy_closure);
C_pte(C_dump_heap_state);
C_pte(C_filter_heap_objects);
+ C_pte(C_digits_to_integer);
+ C_pte(C_fixnum_to_string);
+ C_pte(C_integer_to_string);
+ C_pte(C_flonum_to_string);
/* IMPORTANT: did you remember the hardcoded pte table size? */
pt[ i ].id = NULL;
@@ -1800,6 +1810,38 @@ void barf(int code, char *loc, ...)
}
+/* Never use extended number hook procedure names longer than this! */
+/* Current longest name: numbers#@bignum-2-divrem-burnikel-ziegler */
+#define MAX_EXTNUM_HOOK_NAME 64
+
+/* This exists so that we don't have to create any extra closures */
+static void try_extended_number(char *ext_proc_name, C_word c, C_word k, ...)
+{
+ static C_word ab[C_SIZEOF_STRING(MAX_EXTNUM_HOOK_NAME)];
+ int i;
+ va_list v;
+ C_word ext_proc_sym, ext_proc = C_SCHEME_FALSE, *a = ab;
+
+ ext_proc_sym = C_lookup_symbol(C_intern2(&a, ext_proc_name));
+
+ if(!C_immediatep(ext_proc_sym))
+ ext_proc = C_block_item(ext_proc_sym, 0);
+
+ if (!C_immediatep(ext_proc) && C_closurep(ext_proc)) {
+ va_start(v, k);
+ i = c - 1;
+
+ while(i--)
+ C_save(va_arg(v, C_word));
+
+ va_end(v);
+ C_do_apply(c - 1, ext_proc, k);
+ } else {
+ barf(C_UNBOUND_VARIABLE_ERROR, NULL, ext_proc_sym);
+ }
+}
+
+
/* Hook for setting breakpoints */
C_word C_dbg_hook(C_word dummy)
@@ -5391,6 +5433,27 @@ C_regparm C_word C_fcall C_a_i_bitwise_xor(C_word **a, int c, C_word n1, C_word
else return C_flonum(a, nn1);
}
+C_regparm C_word C_fcall C_i_integer_length(C_word x)
+{
+ if (x & C_FIXNUM_BIT) {
+ return C_i_fixnum_length(x);
+ } else if (C_truep(C_i_bignump(x))) {
+ C_uword result = (C_bignum_size(x) - 1) * C_BIGNUM_DIGIT_LENGTH,
+ *last_digit = C_bignum_digits(x) + C_bignum_size(x) - 1,
+ last_digit_length = C_ilen(*last_digit);
+
+ /* If *only* the highest bit is set, negating will give one less bit */
+ if (C_bignum_negativep(x) &&
+ *last_digit == ((C_uword)1 << (last_digit_length-1))) {
+ C_uword *startx = C_bignum_digits(x);
+ while (startx < last_digit && *startx == 0) ++startx;
+ if (startx == last_digit) result--;
+ }
+ return C_fix(result + last_digit_length);
+ } else {
+ barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_ERROR, "integer-length", x);
+ }
+}
C_regparm C_word C_fcall C_i_bit_setp(C_word n, C_word i)
{
@@ -7534,6 +7597,64 @@ C_regparm C_word C_fcall C_bignum_simplify(C_word big)
}
}
+/* Copy all the digits from source to target, obliterating what was
+ * there. If target is larger than source, the most significant
+ * digits will remain untouched.
+ */
+C_inline void bignum_digits_destructive_copy(C_word target, C_word source)
+{
+ C_memcpy(C_bignum_digits(target), C_bignum_digits(source),
+ C_wordstobytes(C_bignum_size(source)));
+}
+
+static C_uword
+bignum_digits_destructive_scale_up_with_carry(C_uword *start, C_uword *end, C_uword factor, C_uword carry)
+{
+ C_uword digit, p;
+
+ assert(C_fitsinbignumhalfdigitp(carry));
+ assert(C_fitsinbignumhalfdigitp(factor));
+
+ /* See fixnum_times. Substitute xlo = factor, xhi = 0, y = digit
+ * and simplify the result to reduce variable usage.
+ */
+ while (start < end) {
+ digit = (*start);
+
+ p = factor * C_BIGNUM_DIGIT_LO_HALF(digit) + carry;
+ carry = C_BIGNUM_DIGIT_LO_HALF(p);
+
+ p = factor * C_BIGNUM_DIGIT_HI_HALF(digit) + C_BIGNUM_DIGIT_HI_HALF(p);
+ (*start++) = C_BIGNUM_DIGIT_COMBINE(C_BIGNUM_DIGIT_LO_HALF(p), carry);
+ carry = C_BIGNUM_DIGIT_HI_HALF(p);
+ }
+ return carry;
+}
+
+static C_uword
+bignum_digits_destructive_scale_down(C_uword *start, C_uword *end, C_uword denominator)
+{
+ C_uword digit, k = 0;
+ C_uhword q_j_hi, q_j_lo;
+
+ /* Single digit divisor case from Hacker's Delight, Figure 9-1,
+ * adapted to modify u[] in-place instead of writing to q[].
+ */
+ while (start < end) {
+ digit = (*--end);
+
+ k = C_BIGNUM_DIGIT_COMBINE(k, C_BIGNUM_DIGIT_HI_HALF(digit)); /* j */
+ q_j_hi = k / denominator;
+ k -= q_j_hi * denominator;
+
+ k = C_BIGNUM_DIGIT_COMBINE(k, C_BIGNUM_DIGIT_LO_HALF(digit)); /* j-1 */
+ q_j_lo = k / denominator;
+ k -= q_j_lo * denominator;
+
+ *end = C_BIGNUM_DIGIT_COMBINE(q_j_hi, q_j_lo);
+ }
+ return k;
+}
void C_ccall C_string_to_symbol(C_word c, C_word closure, C_word k, C_word string)
{
@@ -7644,6 +7765,7 @@ void C_ccall C_quotient(C_word c, C_word closure, C_word k, C_word n1, C_word n2
}
+/* TODO OBSOLETE XXX: This needs to go, but still translated by c-platform */
C_regparm C_word C_fcall
C_a_i_string_to_number(C_word **a, int c, C_word str, C_word radix0)
{
@@ -7783,6 +7905,110 @@ C_a_i_string_to_number(C_word **a, int c, C_word str, C_word radix0)
return n;
}
+void C_ccall
+C_digits_to_integer(C_word c, C_word self, C_word k, C_word str,
+ C_word start, C_word end, C_word radix, C_word negp)
+{
+ assert((C_unfix(radix) > 1) && C_fitsinbignumhalfdigitp(C_unfix(radix)));
+
+ if (start == end) {
+ C_kontinue(k, C_SCHEME_FALSE);
+ } else {
+ C_word kab[C_SIZEOF_CLOSURE(6)], *ka = kab, k2, size;
+ size_t nbits;
+ k2 = C_closure(&ka, 6, (C_word)digits_to_integer_2, k, str, start, end, radix);
+
+ nbits = (C_unfix(end) - C_unfix(start)) * C_ilen(C_unfix(radix)-1);
+ size = C_fix(C_BIGNUM_BITS_TO_DIGITS(nbits));
+ C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
+ }
+}
+
+C_inline int hex_char_to_digit(int ch)
+{
+ if (ch == (int)'#') return 0; /* Hash characters in numbers are mapped to 0 */
+ else if (ch >= (int)'a') return ch - (int)'a' + 10; /* lower hex */
+ else if (ch >= (int)'A') return ch - (int)'A' + 10; /* upper hex */
+ else return ch - (int)'0'; /* decimal (OR INVALID; handled elsewhere) */
+}
+
+static void
+digits_to_integer_2(C_word c, C_word self, C_word result)
+{
+ C_word k = C_block_item(self, 1),
+ str = C_block_item(self, 2),
+ start = C_unfix(C_block_item(self, 3)),
+ end = C_unfix(C_block_item(self, 4)),
+ radix = C_unfix(C_block_item(self, 5));
+ char *s = C_c_string(str);
+
+ C_kontinue(k, str_to_bignum(result, s + start, s + end, radix));
+}
+
+/* Write from digit character stream to bignum. Bignum does not need
+ * to be initialised. Returns the bignum, or a fixnum. Assumes the
+ * string contains only digits that fit within radix (checked by
+ * string->number).
+ */
+static C_regparm C_word
+str_to_bignum(C_word bignum, char *str, char *str_end, int radix)
+{
+ int radix_shift, str_digit;
+ C_uword *digits = C_bignum_digits(bignum),
+ *end_digits = digits + C_bignum_size(bignum), big_digit = 0;
+
+ /* Below, we try to save up as much as possible in big_digit, and
+ * only when it exceeds what we would be able to multiply easily, we
+ * scale up the bignum and add what we saved up.
+ */
+ radix_shift = C_ilen(radix) - 1;
+ if (((C_uword)1 << radix_shift) == radix) { /* Power of two? */
+ int n = 0; /* Number of bits read so far into current big digit */
+
+ /* Read from least to most significant digit to avoid shifting or scaling */
+ while (str_end > str) {
+ str_digit = hex_char_to_digit((int)*--str_end);
+
+ big_digit |= (C_uword)str_digit << n;
+ n += radix_shift;
+
+ if (n >= C_BIGNUM_DIGIT_LENGTH) {
+ n -= C_BIGNUM_DIGIT_LENGTH;
+ *digits++ = big_digit;
+ big_digit = str_digit >> (radix_shift - n);
+ }
+ }
+ assert(n < C_BIGNUM_DIGIT_LENGTH);
+ /* If radix isn't an exact divisor of digit length, write final digit */
+ if (n > 0) *digits++ = big_digit;
+ assert(digits == end_digits);
+ } else { /* Not a power of two */
+ C_uword *last_digit = digits, factor; /* bignum starts as zero */
+
+ do {
+ factor = radix;
+ while (str < str_end && C_fitsinbignumhalfdigitp(factor)) {
+ str_digit = hex_char_to_digit((int)*str++);
+ factor *= radix;
+ big_digit = radix * big_digit + str_digit;
+ }
+
+ big_digit = bignum_digits_destructive_scale_up_with_carry(
+ digits, last_digit, factor / radix, big_digit);
+
+ if (big_digit) {
+ (*last_digit++) = big_digit; /* Move end */
+ big_digit = 0;
+ }
+ } while (str < str_end);
+
+ /* Set remaining digits to zero so bignum_simplify can do its work */
+ assert(last_digit <= end_digits);
+ while (last_digit < end_digits) *last_digit++ = 0;
+ }
+
+ return C_bignum_simplify(bignum);
+}
static int from_n_nary(C_char *str, int base, double *r)
{
@@ -7807,6 +8033,7 @@ static int from_n_nary(C_char *str, int base, double *r)
}
+/* TODO OBSOLETE XXX: This needs to go, but still used in decode_literal */
C_regparm C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word *fix, double *flo)
{
C_ulong ln;
@@ -7873,129 +8100,135 @@ C_regparm C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word
}
-static char *to_n_nary(C_uword num, C_uword base)
+static char *to_n_nary(C_uword num, C_uword base, int negp, int as_flonum)
{
+ static char *digits = "0123456789abcdef";
char *p;
- static char digits[] ={ '0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F' };
- buffer [ 66 ] = '\0';
+ C_uword shift = C_ilen(base) - 1;
+ int mask = (1 << shift) - 1;
+ if (as_flonum) {
+ buffer[68] = '\0';
+ buffer[67] = '0';
+ buffer[66] = '.';
+ } else {
+ buffer[66] = '\0';
+ }
p = buffer + 66;
-
- do {
- *(--p) = digits [ num % base ];
- num /= base;
- } while (num);
-
+ if (mask == base - 1) {
+ do {
+ *(--p) = digits [ num & mask ];
+ num >>= shift;
+ } while (num);
+ } else {
+ do {
+ *(--p) = digits [ num % base ];
+ num /= base;
+ } while (num);
+ }
+ if (negp) *(--p) = '-';
return p;
}
void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num, ...)
{
- C_word radix, *a;
- C_char *p;
- double f;
- va_list v;
- int neg = 0;
+ C_word radix;
+
+ if(c == 3) {
+ radix = C_fix(10);
+ } else if(c == 4) {
+ va_list v;
- if(c == 3) radix = 10;
- else if(c == 4) {
va_start(v, num);
radix = va_arg(v, C_word);
va_end(v);
- if(radix & C_FIXNUM_BIT) radix = C_unfix(radix);
- else barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", radix);
+ if(!(radix & C_FIXNUM_BIT))
+ barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", radix);
+ } else {
+ C_bad_argc(c, 3);
}
- else C_bad_argc(c, 3);
if(num & C_FIXNUM_BIT) {
- num = C_unfix(num);
-
- if(num < 0) {
- neg = 1;
- num = -num;
- }
-
- if((radix < 2) || (radix > 16)){
- barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));
- }
-
- switch(radix) {
-#ifdef C_SIXTY_FOUR
- case 8: C_snprintf(p = buffer + 1, sizeof(buffer) -1 , C_text("%llo"), (long long)num); break;
- case 10: C_snprintf(p = buffer + 1, sizeof(buffer) - 1, C_text("%lld"), (long long)num); break;
- case 16: C_snprintf(p = buffer + 1, sizeof(buffer) - 1, C_text("%llx"), (long long)num); break;
-#else
- case 8: C_snprintf(p = buffer + 1, sizeof(buffer) - 1, C_text("%o"), num); break;
- case 10: C_snprintf(p = buffer + 1, sizeof(buffer) - 1, C_text("%d"), num); break;
- case 16: C_snprintf(p = buffer + 1, sizeof(buffer) - 1, C_text("%x"), num); break;
-#endif
- default:
- p = to_n_nary(num, radix);
- }
+ C_fixnum_to_string(4, (C_word)NULL, k, num, radix);
+ } else if (C_immediatep(num)) {
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "number->string", num);
+ } else if(C_block_header(num) == C_FLONUM_TAG) {
+ C_flonum_to_string(4, (C_word)NULL, k, num, radix);
+ } else if (C_header_bits(num) == C_BIGNUM_TYPE) {
+ C_integer_to_string(4, (C_word)NULL, k, num, radix);
+ } else {
+ try_extended_number("\003sysextended-number->string", 3, k, num, radix);
}
- else if(!C_immediatep(num) && C_block_header(num) == C_FLONUM_TAG) {
- f = C_flonum_magnitude(num);
+}
- if(C_fits_in_unsigned_int_p(num) == C_SCHEME_TRUE) {
- if(f < 0) {
- neg = 1;
- f = -f;
- }
+void C_ccall
+C_fixnum_to_string(C_word c, C_word self, C_word k, C_word num, C_word radix)
+{
+ C_char *p;
+ C_word *a, neg = num & C_INT_SIGN_BIT ? 1 : 0;
- if((radix < 2) || (radix > 16)){
- barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));
- }
+ radix = C_unfix(radix);
+ if (radix < 2 || radix > 16) {
+ barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));
+ }
- switch(radix) {
- case 8:
- C_snprintf(p = buffer, sizeof(buffer), "%o", (unsigned int)f);
- goto fini;
+ num = neg ? -C_unfix(num) : C_unfix(num);
+ p = to_n_nary(num, radix, neg, 0);
- case 16:
- C_snprintf(p = buffer, sizeof(buffer), "%x", (unsigned int)f);
- goto fini;
+ num = C_strlen(p);
+ a = C_alloc((C_bytestowords(num) + 1));
+ C_kontinue(k, C_string(&a, num, p));
+}
- case 10: break; /* force output of decimal point to retain
- read/write invariance (the little we support) */
+void C_ccall
+C_flonum_to_string(C_word c, C_word self, C_word k, C_word num, C_word radix)
+{
+ C_word *a;
+ C_char *p;
+ double f;
- default:
- p = to_n_nary((unsigned int)f, radix);
- goto fini;
+ radix = C_unfix(radix);
+ f = C_flonum_magnitude(num);
- }
- }
+ /* XXX TODO: Should inexacts be printable in other bases than 10?
+ * Perhaps output a string starting with #i?
+ * Right now something like (number->string 1e40 16) results in
+ * a string that can't be read back using string->number.
+ */
+ if((radix < 2) || (radix > 16)){
+ barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));
+ }
- if(C_isnan(f)) {
- C_strlcpy(buffer, C_text("+nan.0"), sizeof(buffer));
- p = buffer;
- goto fini;
- }
- else if(C_isinf(f)) {
- C_snprintf(buffer, sizeof(buffer), "%cinf.0", f > 0 ? '+' : '-');
- p = buffer;
- goto fini;
+ if(C_fits_in_unsigned_int_p(num) == C_SCHEME_TRUE) { /* Use fast int code */
+ if(f < 0) {
+ p = to_n_nary((C_uword)-f, radix, 1, 1);
+ } else {
+ p = to_n_nary((C_uword)f, radix, 0, 1);
}
-
+ } else if(C_isnan(f)) {
+ p = "+nan.0";
+ } else if(C_isinf(f)) {
+ p = f > 0 ? "+inf.0" : "-inf.0";
+ } else { /* Doesn't fit an unsigned int and not "special"; use system libc */
C_snprintf(buffer, STRING_BUFFER_SIZE, C_text("%.*g"),
- flonum_print_precision, f);
+ /* XXX: flonum_print_precision */
+ (int)C_unfix(C_get_print_precision()), f);
buffer[STRING_BUFFER_SIZE-1] = '\0';
if((p = C_strpbrk(buffer, C_text(".eE"))) == NULL) {
- if(*buffer == 'i' || *buffer == 'n') { /* inf or nan */
- C_memmove(buffer + 1, buffer, C_strlen(buffer) + 1);
- *buffer = '+';
- }
- else if(buffer[ 1 ] != 'i') C_strlcat(buffer, C_text(".0"), sizeof(buffer)); /* negative infinity? */
+ /* Already checked for these, so shouldn't happen */
+ assert(*buffer != 'i'); /* "inf" */
+ assert(*buffer != 'n'); /* "nan" */
+ /* Ensure integral flonums w/o expt are always terminated by .0 */
+#if defined(HAVE_STRLCAT) || !defined(C_strcat)
+ C_strlcat(buffer, C_text(".0"), sizeof(buffer));
+#else
+ C_strcat(buffer, C_text(".0"));
+#endif
}
-
p = buffer;
}
- else
- barf(C_BAD_ARGUMENT_TYPE_ERROR, "number->string", num);
-
- fini:
- if(neg) *(--p) = '-';
radix = C_strlen(p);
a = C_alloc((C_bytestowords(radix) + 1));
@@ -8003,26 +8236,155 @@ void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num,
C_kontinue(k, radix);
}
-
-/* special case for fixnum arg and decimal radix */
-void C_ccall
-C_fixnum_to_string(C_word c, C_word self, C_word k, C_word num)
+void C_ccall
+C_integer_to_string(C_word c, C_word self, C_word k, C_word num, C_word radix)
{
- C_word *a, s;
- int n;
+ if (num & C_FIXNUM_BIT) {
+ C_fixnum_to_string(4, (C_word)NULL, k, num, radix);
+ } else {
+ int len, radix_shift;
+ size_t nbits;
- /*XXX is this necessary? */
-#ifdef C_SIXTY_FOUR
- C_snprintf(buffer, sizeof(buffer), C_text(LONG_FORMAT_STRING), C_unfix(num));
-#else
- C_snprintf(buffer, sizeof(buffer), C_text("%d"), C_unfix(num));
-#endif
- n = C_strlen(buffer);
- a = C_alloc(C_bytestowords(n) + 1);
- s = C_string2(&a, buffer);
- C_kontinue(k, s);
+ if ((C_unfix(radix) < 2) || (C_unfix(radix) > 16)) {
+ barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", radix);
+ }
+
+ /* Approximation of the number of radix digits we'll need. We try
+ * to be as precise as possible to avoid memmove overhead at the end
+ * of the non-powers of two part of the conversion procedure, which
+ * we may need to do because we write strings back-to-front, and
+ * pointers must be aligned (even for byte blocks).
+ */
+ len = C_bignum_size(num)-1;
+
+ nbits = (size_t)len * C_BIGNUM_DIGIT_LENGTH;
+ nbits += C_ilen(C_bignum_digits(num)[len]);
+
+ len = C_ilen(C_unfix(radix))-1;
+ len = (nbits + len - 1) / len;
+ len += C_bignum_negativep(num) ? 1 : 0; /* Add space for negative sign */
+
+ radix_shift = C_ilen(C_unfix(radix)) - 1;
+ /* TODO: Activate later */
+ /* if (len > C_RECURSIVE_TO_STRING_THRESHOLD && */
+ /* /\* The power of two fast path is much faster than recursion *\/ */
+ /* ((C_uword)1 << radix_shift) != C_unfix(radix)) { */
+ /* try_extended_number("numbers#@integer->string/recursive", */
+ /* 4, k, num, radix, C_fix(len)); */
+ /* } else { */
+ C_word k2, negp = C_mk_bool(C_bignum_negativep(num)), *ka;
+ ka = C_alloc(C_SIZEOF_CLOSURE(4));
+ k2 = C_closure(&ka, 4, (C_word)bignum_to_str_2, k, num, radix);
+ C_allocate_vector(6, (C_word)NULL, k2, C_fix(len),
+ /* Byte vec, no initialization, align at 8 bytes */
+ C_SCHEME_TRUE, C_SCHEME_FALSE, C_SCHEME_FALSE);
+ /* } */
+ }
}
+static void
+bignum_to_str_2(C_word c, C_word self, C_word string)
+{
+ static char *characters = "0123456789abcdef";
+ C_word k = C_block_item(self, 1),
+ bignum = C_block_item(self, 2),
+ radix = C_unfix(C_block_item(self, 3));
+ char *buf = C_c_string(string), *index = buf + C_header_size(string) - 1;
+ int radix_shift, negp = (C_bignum_negativep(bignum) ? 1 : 0);
+
+ radix_shift = C_ilen(radix) - 1;
+ if (((C_uword)1 << radix_shift) == radix) { /* Power of two? */
+ int radix_mask = radix - 1, big_digit_len = 0, radix_digit;
+ C_uword *scan, *end, big_digit = 0;
+
+ scan = C_bignum_digits(bignum);
+ end = scan + C_bignum_size(bignum);
+
+ while (scan < end) {
+ /* If radix isn't an exact divisor of digit length, handle overlap */
+ if (big_digit_len == 0) {
+ big_digit = *scan++;
+ big_digit_len = C_BIGNUM_DIGIT_LENGTH;
+ } else {
+ assert(index >= buf);
+ radix_digit = big_digit;
+ big_digit = *scan++;
+ radix_digit |= (big_digit << big_digit_len) & radix_mask;
+ big_digit >>= (radix_shift - big_digit_len);
+ big_digit_len = C_BIGNUM_DIGIT_LENGTH - big_digit_len;
+ }
+
+ while(big_digit_len >= radix_shift && index >= buf) {
+ radix_digit = big_digit & radix_mask;
+ *index-- = characters[radix_digit];
+ big_digit >>= radix_shift;
+ big_digit_len -= radix_shift;
+ }
+ }
+
+ assert(big_digit < radix);
+
+ /* Final digit (like overlap at start of while loop) */
+ if (big_digit) *index-- = characters[big_digit];
+
+ if (negp) {
+ /* Loop above might've overwritten sign position with a zero */
+ if (*(index+1) == '0') *(index+1) = '-';
+ else *index-- = '-';
+ }
+
+ /* Length calculation is always precise for radix powers of two. */
+ assert(index == buf-1);
+ } else {
+ C_uword base, *start, *scan, big_digit;
+ C_word working_copy;
+ int steps, i;
+
+ working_copy = allocate_tmp_bignum(C_fix(C_bignum_size(bignum)),
+ C_mk_bool(negp), C_SCHEME_FALSE);
+ bignum_digits_destructive_copy(working_copy, bignum);
+
+ start = C_bignum_digits(working_copy);
+
+ scan = start + C_bignum_size(bignum);
+ /* Calculate the largest power of radix that fits a halfdigit:
+ * steps = log10(2^halfdigit_bits), base = 10^steps
+ */
+ for(steps = 0, base = radix; C_fitsinbignumhalfdigitp(base); base *= radix)
+ steps++;
+
+ base /= radix; /* Back down: we overshot in the loop */
+
+ while (scan > start) {
+ big_digit = bignum_digits_destructive_scale_down(start, scan, base);
+
+ if (*(scan-1) == 0) scan--; /* Adjust if we exhausted the highest digit */
+
+ for(i = 0; i < steps && index >= buf; ++i) {
+ C_word tmp = big_digit / radix;
+ *index-- = characters[big_digit - (tmp*radix)]; /* big_digit % radix */
+ big_digit = tmp;
+ }
+ }
+ assert(index >= buf-1);
+ free_tmp_bignum(working_copy);
+
+ /* Move index onto first nonzero digit. We're writing a bignum
+ here: it can't consist of only zeroes. */
+ while(*++index == '0');
+
+ if (negp) *--index = '-';
+
+ /* Shorten with distance between start and index. */
+ if (buf != index) {
+ i = C_header_size(string) - (index - buf);
+ C_memmove(buf, index, i); /* Move start of number to beginning. */
+ C_block_header(string) = C_STRING_TYPE | i; /* Mutate strlength. */
+ }
+ }
+
+ C_kontinue(k, string);
+}
void C_ccall C_make_structure(C_word c, C_word closure, C_word k, C_word type, ...)
{
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index bdf74fbf..496a6972 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -239,7 +239,7 @@
(assert
(equal?
(map (lambda (n) (number->string 32 n)) (list-tabulate 15 (cut + 2 <>)))
- '("100000" "1012" "200" "112" "52" "44" "40" "35" "32" "2A" "28" "26" "24" "22" "20")))
+ '("100000" "1012" "200" "112" "52" "44" "40" "35" "32" "2a" "28" "26" "24" "22" "20")))
;; string->number conversion
diff --git a/types.db b/types.db
index 8a1d30ce..c819e995 100644
--- a/types.db
+++ b/types.db
@@ -534,9 +534,18 @@
((float float) (##core#inline_allocate ("C_a_i_flonum_atan2" 4) #(1) #(2))))
(number->string (#(procedure #:clean #:enforce) number->string (number #!optional fixnum) string)
- ((fixnum) (##sys#fixnum->string #(1))))
-
-(##sys#fixnum->string (#(procedure #:clean #:enforce) ##sys#fixnum->string (fixnum) string))
+ ((fixnum fixnum) (##sys#fixnum->string #(1) #(2)))
+ ((fixnum) (##sys#fixnum->string #(1) '10))
+ ((integer fixnum) (##sys#integer->string #(1) #(2)))
+ ((integer) (##sys#integer->string #(1) '10))
+ ((float fixnum) (##sys#flonum->string #(1) #(2)))
+ ((float) (##sys#flonum->string #(1) '10))
+ ((* *) (##sys#number->string #(1) #(2)))
+ ((*) (##sys#number->string #(1) '10)))
+
+(##sys#fixnum->string (#(procedure #:clean #:enforce) ##sys#fixnum->string (fixnum fixnum) string))
+(##sys#integer->string (#(procedure #:clean #:enforce) ##sys#integer->string (integer fixnum) string))
+(##sys#flonum->string (#(procedure #:clean #:enforce) ##sys#flonum->string (float fixnum) string))
(string->number (#(procedure #:clean #:enforce #:foldable) string->number (string #!optional fixnum)
(or number false)))
@@ -774,6 +783,9 @@
(argc+argv (#(procedure #:clean) argc+argv () fixnum (list-of string) fixnum))
(argv (#(procedure #:clean) argv () (list-of string)))
(arithmetic-shift (#(procedure #:clean #:enforce #:foldable) arithmetic-shift (number number) number))
+(integer-length (#(procedure #:clean #:enforce #:foldable) integer-length (integer) fixnum)
+ ((fixnum) (##core#inline "C_i_fixnum_length" #(1)))
+ ((*) (##core#inline "C_i_integer_length" #(1))))
(bignum? (#(procedure #:pure #:predicate bignum) bignum? (*) boolean))
@@ -1026,6 +1038,7 @@
(fxshl (#(procedure #:clean #:foldable) fxshl (fixnum fixnum) fixnum))
(fxshr (#(procedure #:clean #:foldable) fxshr (fixnum fixnum) fixnum))
(fxxor (#(procedure #:clean #:foldable) fxxor (fixnum fixnum) fixnum))
+(fxlen (#(procedure #:clean #:foldable) fxlen (fixnum) fixnum))
(gc (#(procedure #:clean) gc (#!optional *) fixnum))
(gensym (#(procedure #:clean) gensym (#!optional (or string symbol)) symbol))
Trap