533 lines
21 KiB
Scheme
533 lines
21 KiB
Scheme
;;; strnum.ss
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
|
|
#|
|
|
R6RS Section 4.2.8 (Numbers) says:
|
|
|
|
A representation of a number object may be specified to be either
|
|
exact or inexact by a prefix. The prefixes are #e for exact, and #i
|
|
for inexact. An exactness prefix may appear before or after any radix
|
|
prefix that is used. If the representation of a number object has
|
|
no exactness prefix, the constant is inexact if it contains a decimal
|
|
point, an exponent, or a nonempty mantissa width; otherwise it is exact.
|
|
|
|
This specifies the exactness of the result. It doesn't specify precisely
|
|
the number produced when there is a mix of exact and inexact subparts
|
|
and what happens if an apparently exact subpart of an inexact number
|
|
cannot be represented.
|
|
|
|
Possible options include:
|
|
|
|
(A) Treat each subpart as inexact if the #i prefix is specified or the
|
|
#e prefix is not specified and any subpart is inexact, i.e.,
|
|
contains a decimal point, exponent, or mantissa width. Treat each
|
|
subpart as exact if the #e prefix is specified or if the #i prefix
|
|
is not specified and each subpart is exact.
|
|
|
|
(B) Treat each subpart as exact or inexact in isolation and use the
|
|
usual rules for preserving inexactness when combining the subparts.
|
|
Apply inexact to the result if #i is present and exact to the
|
|
result if #e is present.
|
|
|
|
(C) If #e and #i are not present, treat each subpart as exact or inexact
|
|
in isolation and use the usual rules for preserving inexactness when
|
|
combining the subparts. If #e is present, treat each subpart
|
|
as exact. If #i is present, treat each subpart as inexact.
|
|
|
|
Also, the R6RS description of string->number says:
|
|
|
|
If string is not a syntactically valid notation for a number object
|
|
or a notation for a rational number object with a zero denominator,
|
|
then string->number returns #f.
|
|
|
|
We take "zero denomintor" here to mean "exact zero denominator", and
|
|
treat, e.g., #i1/0, as +inf.0.
|
|
|
|
A B C
|
|
0/0 #f #f #f
|
|
1/0 #f #f #f
|
|
#e1/0 #f #f #f
|
|
#i1/0 +inf.0 #f +inf.0
|
|
1/0+1.0i +nan.0+1.0i #f #f
|
|
1.0+1/0i 1.0+nan.0i #f #f
|
|
#e1e1000 (expt 10 1000) #f (expt 10 1000)
|
|
0@1.0 0.0+0.0i 0 0
|
|
1.0+0i 1.0+0.0i 1.0 1.0
|
|
|
|
This code implements Option C. It computes inexact components with
|
|
exact arithmetic where possible, however, before converting them into
|
|
inexact numbers, to insure the greatest possible accuracy.
|
|
|
|
Rationale for Option C: B and C adhere most closely to the semantics of
|
|
the individual / and make-rectangular operators, sometimes produce exact
|
|
results when A would produce inexact results, and do not require a scan
|
|
of the entire number first (as with A) to determine the (in)exactness of
|
|
the result. C takes into account the known (in)exactness of the result
|
|
to represent some useful values that B cannot, such as #i1/0 and #e1e1000.
|
|
|
|
R6RS doesn't say is what string->number should return for syntactically
|
|
valid numbers (other than exact numbers with a zero denominator) for
|
|
which the implementation has no representation, such as exact 1@1 in an
|
|
implementation such as Chez Scheme that represents all complex numbers in
|
|
rectangular form. Options include returning an approximation represented
|
|
as an inexact number (so that the result, which should be exact, isn't
|
|
exact), returning an approximation represented as an exact number (so
|
|
that the approximation misleadingly represents itself as exact), or to
|
|
admit an implementation restriction. We choose the to return an inexact
|
|
result for 1@1 (extending the set of situations where numeric constants
|
|
are implicitly inexact) and treat #e1@1 as violating an implementation
|
|
restriction, with string->number returning #f and the reader raising
|
|
an exception.
|
|
|#
|
|
|
|
(begin
|
|
(let ()
|
|
;; (mknum-state <state name>
|
|
;; <expression if end of string found>
|
|
;; [<transition key> <state transition>]
|
|
;; ...)
|
|
(define-syntax mknum-state
|
|
(lambda (e)
|
|
(syntax-case e ()
|
|
[(_key name (id ...) efinal clause ...)
|
|
(with-implicit (_key str k i r6rs? !r6rs x1 c d)
|
|
(let ()
|
|
(define mknum-state-test
|
|
(lambda (key)
|
|
(syntax-case key (-)
|
|
[char
|
|
(char? (datum char))
|
|
#'(char=? c char)]
|
|
[(char1 - char2)
|
|
#'(char<=? char1 c char2)]
|
|
[(key ...)
|
|
`(,#'or ,@(map mknum-state-test #'(key ...)))])))
|
|
(define mknum-call
|
|
(lambda (incr? call)
|
|
(syntax-case call (let)
|
|
[(let ([x e] ...) call)
|
|
(with-syntax ([call (mknum-call incr? #'call)])
|
|
#'(let ([x e] ...) call))]
|
|
[(e1 e2 ...)
|
|
(if incr?
|
|
#'(e1 str k (fx+ i 1) r6rs? !r6rs x1 e2 ...)
|
|
#'(e1 str k i r6rs? !r6rs x1 e2 ...))])))
|
|
(define mknum-state-help
|
|
(lambda (ls)
|
|
(syntax-case ls (else)
|
|
[() #''bogus]
|
|
[((else call)) (mknum-call #f #'call)]
|
|
[_ (with-syntax ((rest (mknum-state-help (cdr ls))))
|
|
(syntax-case (car ls) (digit)
|
|
[((digit r) call)
|
|
(with-syntax ([call (mknum-call #t #'call)])
|
|
#'(let ((d (ascii-digit-value c r)))
|
|
(if d call rest)))]
|
|
[((digit r) fender call)
|
|
(with-syntax ([call (mknum-call #t #'call)])
|
|
#'(let ((d (ascii-digit-value c r)))
|
|
(if (and d fender) call rest)))]
|
|
[(key call)
|
|
(with-syntax ([test (mknum-state-test #'key)]
|
|
[call (mknum-call #t #'call)])
|
|
#'(if test call rest))]
|
|
[(key fender call)
|
|
(with-syntax ([test (mknum-state-test #'key)]
|
|
[call (mknum-call #t #'call)])
|
|
#'(if (and test fender) call rest))]))])))
|
|
(with-syntax ([rest (mknum-state-help #'(clause ...))]
|
|
[efinal (syntax-case #'efinal ()
|
|
[#f #'efinal]
|
|
[_ #'(if (and r6rs? !r6rs) '!r6rs efinal)])])
|
|
#'(define name
|
|
(lambda (str k i r6rs? !r6rs x1 id ...)
|
|
(if (= i k)
|
|
efinal
|
|
(let ([c (char-downcase (string-ref str i))])
|
|
rest)))))))])))
|
|
|
|
(define ascii-digit-value
|
|
(lambda (c r)
|
|
(let ([v (cond
|
|
[(char<=? #\0 c #\9) (char- c #\0)]
|
|
[(char<=? #\a c #\z) (char- c #\W)]
|
|
[else 36])])
|
|
(and (fx< v r) v))))
|
|
|
|
; variables automatically maintained and passed by the mknum macro:
|
|
; str: string
|
|
; k: string length
|
|
; i: index into string, 0 <= i < k
|
|
; r6rs?: if #t, return !r6rs for well-formed non-r6rs features
|
|
; !r6rs: if #t, seen non-r6rs feature
|
|
; x1: first part of complex number when ms = imag or angle: number, thunk, or norep
|
|
; variables automatically created by the mknum macro:
|
|
; c: holds current character
|
|
; d: holds digit value of c in a digit clause
|
|
; other "interesting" variables:
|
|
; r: radix, 2 <= r <= 36 (can be outside this range while constructing #<r>r prefix)
|
|
; ex: exactness: 'i, 'e, or #f
|
|
; s: function to add sign to number
|
|
; ms: meta-state: real, imag, angle
|
|
; n: exact integer
|
|
; m: exact or inexact integer
|
|
; w: exact or inexact integer or norep
|
|
; x: number, thunk, or norep
|
|
; e: exact integer exponent
|
|
; i?: #t if number should be made inexact
|
|
; invariant: (thunk) != exact 0.
|
|
|
|
; The sign of the mantissa cannot be put on until a number has
|
|
; been made inexact (if necessary) to make sure zero gets the right sign.
|
|
|
|
(let ()
|
|
|
|
(define plus (lambda (x) x))
|
|
(define minus -)
|
|
|
|
(define make-part
|
|
(lambda (i? s n)
|
|
(s (if i? (inexact n) n))))
|
|
|
|
(define make-part/exponent
|
|
(lambda (i? s w r e)
|
|
; get out quick for really large/small exponents, like 1e1000000000
|
|
; no need for great precision here; using 2x the min/max base two
|
|
; exponent, which should be conservative for all bases. 1x should
|
|
; actually work for positive n, but for negative e we need something
|
|
; smaller than 1x to allow denormalized numbers.
|
|
; s must be the actual sign of the result, with w >= 0
|
|
(define max-float-exponent
|
|
(float-type-case
|
|
[(ieee) 1023]))
|
|
(define min-float-exponent
|
|
(float-type-case
|
|
[(ieee) -1023]))
|
|
(cond
|
|
[(eq? w 'norep) 'norep]
|
|
[i? (s (if (eqv? w 0)
|
|
0.0
|
|
(if (<= (* min-float-exponent 2) e (* max-float-exponent 2))
|
|
(inexact (* w (expt r e)))
|
|
(if (< e 0) 0.0 +inf.0))))]
|
|
[(eqv? w 0) 0]
|
|
[else (lambda () (s (* w (expt r e))))])))
|
|
|
|
(define (thaw x) (if (procedure? x) (x) x))
|
|
|
|
(define finish-number
|
|
(lambda (ms ex x1 x)
|
|
(case ms
|
|
[(real ureal) (if (procedure? x) (x) x)]
|
|
[(angle)
|
|
(cond
|
|
[(or (eq? x1 'norep) (eq? x 'norep)) 'norep]
|
|
[(eqv? x1 0) 0]
|
|
[(eqv? x 0) (thaw x1)]
|
|
[(eq? ex 'e) 'norep]
|
|
[else (make-polar (thaw x1) (thaw x))])]
|
|
[else #f])))
|
|
|
|
(define finish-rectangular-number
|
|
(lambda (ms x1 x)
|
|
(case ms
|
|
[(real ureal)
|
|
(if (eq? x 'norep)
|
|
'norep
|
|
(make-rectangular 0 (thaw x)))]
|
|
[(imag)
|
|
(if (or (eq? x1 'norep) (eq? x 'norep))
|
|
'norep
|
|
(make-rectangular (thaw x1) (thaw x)))]
|
|
[else #f])))
|
|
|
|
(mknum-state prefix0 (r ex) ; start state
|
|
#f
|
|
[#\# (prefix1 r ex)]
|
|
[else (num0 r ex)])
|
|
|
|
(mknum-state prefix1 (r ex) ; saw leading #
|
|
#f
|
|
[(digit 10) (let ([!r6rs #t]) (prefix2 d ex))]
|
|
[#\e (prefix3 r 'e)]
|
|
[#\i (prefix3 r 'i)]
|
|
[#\b (prefix6 2 ex)]
|
|
[#\o (prefix6 8 ex)]
|
|
[#\d (prefix6 10 ex)]
|
|
[#\x (prefix6 16 ex)])
|
|
|
|
(mknum-state prefix2 (r ex) ; saw digit after #
|
|
#f
|
|
[(digit 10) (fx< r 37) (prefix2 (+ (* r 10) d) ex)]
|
|
[#\r (fx< 1 r 37) (prefix6 r ex)])
|
|
|
|
(mknum-state prefix3 (r ex) ; saw exactness prefix
|
|
#f
|
|
[#\# (prefix4 ex)]
|
|
[else (num0 r ex)])
|
|
|
|
(mknum-state prefix4 (ex) ; saw # after exactness
|
|
#f
|
|
[(digit 10) (let ([!r6rs #t]) (prefix5 d ex))]
|
|
[#\b (num0 2 ex)]
|
|
[#\o (num0 8 ex)]
|
|
[#\d (num0 10 ex)]
|
|
[#\x (num0 16 ex)])
|
|
|
|
(mknum-state prefix5 (r ex) ; saw # digit after exactness
|
|
#f
|
|
[(digit 10) (fx< r 37) (prefix5 (+ (* r 10) d) ex)]
|
|
[#\r (fx< 1 r 37) (num0 r ex)])
|
|
|
|
(mknum-state prefix6 (r ex) ; saw radix prefix
|
|
#f
|
|
[#\# (prefix7 r)]
|
|
[else (num0 r ex)])
|
|
|
|
(mknum-state prefix7 (r) ; saw # after radix
|
|
#f
|
|
[#\e (num0 r 'e)]
|
|
[#\i (num0 r 'i)])
|
|
|
|
(mknum-state num0 (r ex) ; saw prefix, if any
|
|
#f
|
|
[(digit r) (num2 r ex 'ureal plus d)]
|
|
[#\. (let ([!r6rs (or !r6rs (not (fx= r 10)))]) (float0 r ex 'ureal plus))]
|
|
[#\+ (num1 r ex 'real plus)]
|
|
[#\- (num1 r ex 'real minus)])
|
|
|
|
(mknum-state num1 (r ex ms s) ; saw sign
|
|
#f
|
|
[(digit r) (num2 r ex ms s d)]
|
|
[#\. (let ([!r6rs (or !r6rs (not (fx= r 10)))]) (float0 r ex ms s))]
|
|
[#\i (num3 r ex ms s)]
|
|
[#\n (nan0 r ex ms s)])
|
|
|
|
(mknum-state num2 (r ex ms s n) ; saw digit
|
|
(finish-number ms ex x1 (make-part (eq? ex 'i) s n))
|
|
[(digit r) (num2 r ex ms s (+ (* n r) d))]
|
|
[#\/ (rat0 r ex ms s (make-part (eq? ex 'i) plus n))]
|
|
[#\| (mwidth0 r ex ms (make-part (not (eq? ex 'e)) s n))]
|
|
[#\. (let ([!r6rs (or !r6rs (not (fx= r 10)))]) (float1 r ex ms s n (fx+ i 1) 0))]
|
|
[#\# (let ([!r6rs #t]) (numhash r ex ms s (* n r)))]
|
|
[(#\e #\s #\f #\d #\l) (let ([!r6rs (or !r6rs (not (fx= r 10)))]) (exp0 r ex ms s n))]
|
|
[else (complex0 r ex ms (make-part (eq? ex 'i) s n))])
|
|
|
|
(mknum-state num3 (r ex ms s) ; saw "i" after sign
|
|
(finish-rectangular-number ms x1 (make-part (eq? ex 'i) s 1))
|
|
[#\n (inf0 r ex ms s)])
|
|
|
|
(mknum-state inf0 (r ex ms s) ; saw "in" after sign
|
|
#f
|
|
[#\f (inf1 r ex ms s)])
|
|
|
|
(mknum-state inf1 (r ex ms s) ; saw "inf" after sign
|
|
#f
|
|
[#\. (inf2 r ex ms s)])
|
|
|
|
(mknum-state inf2 (r ex ms s) ; saw "inf." after sign
|
|
#f
|
|
[#\0 (inf3 r ex ms s)])
|
|
|
|
(mknum-state inf3 (r ex ms s) ; saw "inf.0" after sign
|
|
(finish-number ms ex x1 (if (eq? ex 'e) 'norep (s +inf.0)))
|
|
[else (complex0 r ex ms (if (eq? ex 'e) 'norep (s +inf.0)))])
|
|
|
|
(mknum-state nan0 (r ex ms s) ; saw "n" after sign
|
|
#f
|
|
[#\a (nan1 r ex ms s)])
|
|
|
|
(mknum-state nan1 (r ex ms s) ; saw "na" after sign
|
|
#f
|
|
[#\n (nan2 r ex ms s)])
|
|
|
|
(mknum-state nan2 (r ex ms s) ; saw "nan" after sign
|
|
#f
|
|
[#\. (nan3 r ex ms s)])
|
|
|
|
(mknum-state nan3 (r ex ms s) ; saw "nan." after sign
|
|
#f
|
|
[#\0 (nan4 r ex ms s)])
|
|
|
|
(mknum-state nan4 (r ex ms s) ; saw "nan.0" after sign
|
|
(finish-number ms ex x1 (if (eq? ex 'e) 'norep +nan.0))
|
|
[else (complex0 r ex ms +nan.0)])
|
|
|
|
(mknum-state numhash (r ex ms s n) ; saw # after integer
|
|
(finish-number ms ex x1 (make-part (not (eq? ex 'e)) s n))
|
|
[#\/ (rat0 r ex ms s (make-part (not (eq? ex 'e)) plus n))]
|
|
[#\. (floathash r ex ms s n (fx+ i 1) 0)]
|
|
[#\# (numhash r ex ms s (* n r))]
|
|
[(#\e #\s #\f #\d #\l) (exp0 r ex ms s n)]
|
|
[else (complex0 r ex ms (make-part (not (eq? ex 'e)) s n))])
|
|
|
|
; can't embed sign in m since we might end up in exp0 and then on
|
|
; to make-part, which counts on sign being separate
|
|
(mknum-state rat0 (r ex ms s m) ; saw slash
|
|
#f
|
|
[(digit r) (rat1 r ex ms s m d)])
|
|
|
|
(define (mkrat p q) (if (eqv? q 0) 'norep (/ p q)))
|
|
|
|
(mknum-state rat1 (r ex ms s m n) ; saw denominator digit
|
|
(finish-number ms ex x1 (mkrat m (make-part (eq? ex 'i) s n)))
|
|
[(digit r) (rat1 r ex ms s m (+ (* n r) d))]
|
|
[#\# (let ([!r6rs #t]) (rathash r ex ms s m (* n r)))]
|
|
[(#\e #\s #\f #\d #\l) (let ([!r6rs #t]) (exp0 r ex ms s (mkrat m (make-part (not (eq? ex 'e)) plus n))))]
|
|
[else (complex0 r ex ms (mkrat m (make-part (eq? ex 'i) s n)))])
|
|
|
|
(mknum-state rathash (r ex ms s m n) ; saw # after denominator
|
|
(finish-number ms ex x1 (mkrat m (make-part (not (eq? ex 'e)) s n)))
|
|
[#\# (rathash r ex ms s m (* n r))]
|
|
[(#\e #\s #\f #\d #\l) (exp0 r ex ms s (mkrat m (make-part (not (eq? ex 'e)) plus n)))]
|
|
[else (complex0 r ex ms (mkrat m (make-part (not (eq? ex 'e)) s n)))])
|
|
|
|
(mknum-state float0 (r ex ms s) ; saw leading decimal point
|
|
#f
|
|
[(digit r) (float1 r ex ms s 0 i d)])
|
|
|
|
(mknum-state float1 (r ex ms s m j n) ; saw fraction digit at j
|
|
(finish-number ms ex x1 (make-part (not (eq? ex 'e)) s (+ m (* n (expt r (- j i))))))
|
|
[(digit r) (float1 r ex ms s m j (+ (* n r) d))]
|
|
[#\| (mwidth0 r ex ms (make-part (not (eq? ex 'e)) s (+ m (* n (expt r (- j i))))))]
|
|
[#\# (let ([!r6rs #t]) (floathash r ex ms s m j (* n r)))]
|
|
[(#\e #\s #\f #\d #\l) (exp0 r ex ms s (+ m (* n (expt r (- j i)))))]
|
|
[else (complex0 r ex ms (make-part (not (eq? ex 'e)) s (+ m (* n (expt r (- j i))))))])
|
|
|
|
(mknum-state floathash (r ex ms s m j n) ; seen hash(es), now in fraction
|
|
(finish-number ms ex x1 (make-part (not (eq? ex 'e)) s (+ m (* n (expt r (- j i))))))
|
|
[#\# (floathash r ex ms s m j (* n r))]
|
|
[(#\e #\s #\f #\d #\l) (exp0 r ex ms s (+ m (* n (expt r (- j i)))))]
|
|
[else (complex0 r ex ms (make-part (not (eq? ex 'e)) s (+ m (* n (expt r (- j i))))))])
|
|
|
|
(mknum-state exp0 (r ex ms s w) ; saw exponent flag
|
|
#f
|
|
[(digit r) (exp2 r ex ms s w plus d)]
|
|
[#\+ (exp1 r ex ms s w plus)]
|
|
[#\- (exp1 r ex ms s w minus)])
|
|
|
|
(mknum-state exp1 (r ex ms sm w s) ; saw exponent sign
|
|
#f
|
|
[(digit r) (exp2 r ex ms sm w s d)])
|
|
|
|
(mknum-state exp2 (r ex ms sm w s e) ; saw exponent digit(s)
|
|
(finish-number ms ex x1 (make-part/exponent (not (eq? ex 'e)) sm w r (s e)))
|
|
[(digit r) (exp2 r ex ms sm w s (+ (* e r) d))]
|
|
[#\| (mwidth0 r ex ms (make-part/exponent (not (eq? ex 'e)) sm w r (s e)))]
|
|
[else (complex0 r ex ms (make-part/exponent (not (eq? ex 'e)) sm w r (s e)))])
|
|
|
|
(mknum-state mwidth0 (r ex ms x) ; saw vertical bar
|
|
#f
|
|
[(digit 10) (mwidth1 r ex ms x)])
|
|
|
|
(mknum-state mwidth1 (r ex ms x) ; saw digit after vertical bar
|
|
(finish-number ms ex x1 x)
|
|
[(digit 10) (mwidth1 r ex ms x)]
|
|
[else (complex0 r ex ms x)])
|
|
|
|
(mknum-state complex0 (r ex ms x) ; saw end of real part before end of string
|
|
(assert #f) ; should arrive here only from else clauses, thus not at the end of the string
|
|
[#\@ (memq ms '(real ureal)) (let ([x1 x]) (complex1 r ex 'angle))]
|
|
[#\+ (memq ms '(real ureal)) (let ([x1 x]) (num1 r ex 'imag plus))]
|
|
[#\- (memq ms '(real ureal)) (let ([x1 x]) (num1 r ex 'imag minus))]
|
|
[#\i (memq ms '(real imag)) (complex2 ms x)])
|
|
|
|
(mknum-state complex1 (r ex ms) ; seen @. like num0 but knows ms already
|
|
#f
|
|
[(digit r) (num2 r ex ms plus d)]
|
|
[#\. (let ([!r6rs (or !r6rs (not (fx= r 10)))]) (float0 r ex ms plus))]
|
|
[#\+ (num1 r ex ms plus)]
|
|
[#\- (num1 r ex ms minus)])
|
|
|
|
(mknum-state complex2 (ms x) ; saw i after real or imag
|
|
(finish-rectangular-number ms x1 x))
|
|
|
|
; str->num returns
|
|
; <number> syntactically valid, representable number
|
|
; !r6rs syntactically valid non-r6rs syntax in #!r6rs mode
|
|
; norep syntactically valid but cannot represent
|
|
; #f syntactically valid prefix (eof/end-of-string)
|
|
; bogus syntactically invalid prefix
|
|
(set! $str->num
|
|
(lambda (str k r ex r6rs?)
|
|
(prefix0 str k 0 r6rs? #f #f r ex)))
|
|
)) ; let
|
|
|
|
(define string->number
|
|
(case-lambda
|
|
[(x) (string->number x 10)]
|
|
[(x r)
|
|
(unless (string? x)
|
|
($oops 'string->number "~s is not a string" x))
|
|
(unless (and (fixnum? r) (fx< 1 r 37))
|
|
($oops 'string->number "~s is not a valid radix" r))
|
|
(let ([z ($str->num x (string-length x) r #f #f)])
|
|
(and (number? z) z))]))
|
|
|
|
(define-who #(r6rs: string->number)
|
|
(case-lambda
|
|
[(x) (string->number x 10)]
|
|
[(x r)
|
|
(unless (string? x) ($oops who "~s is not a string" x))
|
|
(unless (memq r '(2 8 10 16)) ($oops who "~s is not a valid radix" r))
|
|
(let ([z ($str->num x (string-length x) r #f #t)])
|
|
(and (number? z) z))]))
|
|
|
|
(define-who number->string
|
|
(case-lambda
|
|
[(x)
|
|
(unless (number? x) ($oops who "~s is not a number" x))
|
|
(format "~d" x)]
|
|
[(x r)
|
|
(unless (number? x) ($oops who "~s is not a number" x))
|
|
(unless (and (fixnum? r) (fx< 1 r 37))
|
|
($oops who "~s is not a valid radix" r))
|
|
(parameterize ([print-radix r]) (format "~a" x))]
|
|
[(x r m)
|
|
(unless (number? x) ($oops who "~s is not a number" x))
|
|
(unless (and (fixnum? r) (fx< 1 r 37))
|
|
($oops who "~s is not a valid radix" r))
|
|
(unless (or (and (fixnum? m) (fx> m 0))
|
|
(and (bignum? m) (> m 0)))
|
|
($oops who "~s is not a valid precision" m))
|
|
(unless (inexact? x)
|
|
($oops who "a precision is specified and ~s is not inexact" x))
|
|
(parameterize ([print-radix r] [print-precision m]) (format "~a" x))]))
|
|
|
|
(define-who #(r6rs: number->string)
|
|
(case-lambda
|
|
[(x)
|
|
(unless (number? x) ($oops who "~s is not a number" x))
|
|
(format "~d" x)]
|
|
[(x r)
|
|
(unless (number? x) ($oops who "~s is not a number" x))
|
|
(unless (memq r '(2 8 10 16))
|
|
($oops who "~s is not a valid radix" r))
|
|
(parameterize ([print-radix r]) (format "~a" x))]
|
|
[(x r m)
|
|
(unless (number? x) ($oops who "~s is not a number" x))
|
|
(unless (eqv? r 10)
|
|
(if (memq r '(2 8 16))
|
|
($oops who "a precision is specified and radix ~s is not 10" r)
|
|
($oops who "~s is not a valid radix" r)))
|
|
(unless (or (and (fixnum? m) (fx> m 0))
|
|
(and (bignum? m) ($bigpositive? m)))
|
|
($oops who "~s is not a valid precision" m))
|
|
(unless (inexact? x)
|
|
($oops who "a precision is specified and ~s is not inexact" x))
|
|
(parameterize ([print-radix r] [print-precision m]) (format "~a" x))]))
|
|
)
|