scsh-0.6/scheme/rts/numio.scm

197 lines
5.1 KiB
Scheme
Raw Normal View History

1999-09-14 08:45:02 -04:00
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
;;;; number->string and string->number
; NUMBER->STRING
(define-generic real-number->string &number->string)
(define (number->string number . maybe-radix)
(let ((radix (if (null? maybe-radix)
10
(car maybe-radix))))
(if (and (number? number)
(or (null? maybe-radix)
(and (null? (cdr maybe-radix))
(integer? radix)
(exact? radix)
(< 0 radix))))
(real-number->string number radix)
(apply call-error
"invalid argument"
'number->string
number
maybe-radix))))
(define-method &number->string (n radix)
(call-error "invalid argument"
'number->string
n
radix))
(define-method &number->string ((n :exact-integer) radix)
(integer->string n radix))
(define integer->string ;Won't necessarily work if n is inexact
(let ()
(define (integer->string n radix)
(let ((magnitude
(if (= n 0)
(list #\0)
(let recur ((n n) (l '()))
(if (= n 0)
l
(recur (quotient n radix)
(cons (integer->digit (abs (remainder n radix)))
l)))))))
(list->string (if (>= n 0)
magnitude
(cons #\- magnitude)))))
(define (integer->digit n)
(ascii->char (+ n (if (< n 10)
zero
a-minus-10))))
(define zero (char->ascii #\0))
(define a-minus-10 (- (char->ascii #\a) 10))
integer->string))
; STRING->NUMBER
; This just strips off any # prefixes and hands the rest off to
; really-string->number, which is generic.
(define (string->number string . options)
(if (not (string? string))
(apply call-error "invalid argument"
'string->number
string options))
(let* ((radix (cond ((null? options) 10)
((null? (cdr options)) (car options))
;; Revised^3 Scheme compatibility
(else (cadr options))))
(radix (case radix
((2 8 10 16) radix)
((b) 2) ((o) 8) ((d) 10) ((x) 16) ;R3RS only?
(else (call-error "invalid radix"
'string->number
string radix))))
(len (string-length string)))
(let loop ((pos 0) (exactness? #f) (exact? #t) (radix? #f) (radix radix))
(cond ((>= pos len)
#f)
((char=? (string-ref string pos) #\#)
(let ((pos (+ pos 1)))
(if (>= pos len)
#f
(let ((radix-is
(lambda (radix)
(if radix?
#f
(loop (+ pos 1) exactness? exact? #t radix))))
(exactness-is
(lambda (exact?)
(if exactness?
#f
(loop (+ pos 1) #t exact? radix? radix)))))
(case (char-downcase (string-ref string pos))
((#\b) (radix-is 2))
((#\o) (radix-is 8))
((#\d) (radix-is 10))
((#\x) (radix-is 16))
((#\e) (exactness-is #t))
((#\i) (exactness-is #f))
(else #f))))))
(else
(really-string->number
(substring string pos len)
radix
(if exactness?
exact?
(let loop ((pos pos))
(cond ((>= pos len) #t) ;exact
((char=? (string-ref string pos) #\.)
(if (not (= radix 10))
(warn "non-base-10 number has decimal point"
string))
#f) ;inexact
((char=? (string-ref string pos) #\#)
#f)
(else (loop (+ pos 1))))))))))))
(define-generic really-string->number &really-string->number)
(define-method &really-string->number (string radix xact?) #f)
; Read exact integers
(define-simple-type :integer-string (:string)
(lambda (s)
(and (string? s)
(let loop ((i (- (string-length s) 1)))
(if (< i 0)
#t
(let ((c (string-ref s i)))
(and (or (char-numeric? c)
(and (char>=? c #\a)
(char<=? c #\f))
(and (char>=? c #\A)
(char<=? c #\F))
(and (= i 0)
(or (char=? c #\+) (or (char=? c #\-)))))
(loop (- i 1)))))))))
(define-method &really-string->number ((string :integer-string) radix xact?)
(let ((n (string->integer string radix)))
(if n (set-exactness n xact?) #f)))
(define (set-exactness n xact?)
(if (exact? n)
(if xact? n (exact->inexact n))
(if xact? (inexact->exact n) n)))
(define string->integer
(let ()
(define (string->integer string radix)
(cond ((= (string-length string) 0) #f)
((char=? (string-ref string 0) #\+)
(do-it string 1 1 radix))
((char=? (string-ref string 0) #\-)
(do-it string 1 -1 radix))
(else
(do-it string 0 1 radix))))
(define (do-it string pos sign radix)
(let* ((len (string-length string)))
(if (>= pos len)
#f
(let loop ((n 0) (pos pos))
(if (>= pos len)
n
(let ((d (digit->integer (string-ref string pos)
radix)))
(if d
(loop (+ (* n radix) (* sign d))
(+ pos 1))
#f)))))))
(define (digit->integer c radix)
(cond ((char-numeric? c)
(let ((n (- (char->ascii c) zero)))
(if (< n radix) n #f)))
((<= radix 10) #f)
(else
(let ((n (- (char->ascii (char-downcase c)) a-minus-ten)))
(if (and (>= n 10) (< n radix)) n #f)))))
(define zero (char->ascii #\0))
(define a-minus-ten (- (char->ascii #\a) 10))
string->integer))