297 lines
8.4 KiB
Scheme
297 lines
8.4 KiB
Scheme
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
||
; Inexact rational arithmetic using hacked-in floating point numbers.
|
||
|
||
(define-extended-number-type :floatnum (:rational)
|
||
(make-floatnum datum)
|
||
floatnum?
|
||
(datum floatnum-datum))
|
||
|
||
(define (make-float-datum) (make-code-vector 8 0))
|
||
|
||
(define-enumeration flop
|
||
(+ - * / = <
|
||
fixnum->float
|
||
string->float
|
||
float->string
|
||
exp log sin cos tan asin acos atan sqrt
|
||
floor
|
||
integer?
|
||
float->fixnum
|
||
quotient
|
||
remainder))
|
||
|
||
; Floating point at interrupt level? Naw!
|
||
; Actually, if floatnum-datum is open-coded, there won't be any
|
||
; opportunity to get an interrupt in any of the situations where
|
||
; floperate is used.
|
||
|
||
(define float-vec (make-vector 3 #f))
|
||
|
||
(define-syntax floperate
|
||
(syntax-rules ()
|
||
((floperate ?which ?x)
|
||
(vm-extension (+ ?which 100) ?x))
|
||
((floperate ?which ?x ?y)
|
||
(vm-extension (+ ?which 100) (cons ?x ?y)))
|
||
((floperate ?which ?x ?y ?z)
|
||
(begin (vector-set! float-vec 0 ?x)
|
||
(vector-set! float-vec 1 ?y)
|
||
(vector-set! float-vec 2 ?z)
|
||
(vm-extension (+ ?which 100) float-vec)))))
|
||
|
||
(define (float&float->float op)
|
||
(lambda (a b)
|
||
(let ((float1 (x->float a))
|
||
(float2 (x->float b))
|
||
(res (make-float-datum)))
|
||
(floperate op
|
||
(floatnum-datum float1)
|
||
(floatnum-datum float2)
|
||
res)
|
||
(make-floatnum res))))
|
||
|
||
(define (float&float->boolean op)
|
||
(lambda (a b)
|
||
(let ((float1 (x->float a))
|
||
(float2 (x->float b)))
|
||
(floperate op
|
||
(floatnum-datum float1)
|
||
(floatnum-datum float2)))))
|
||
|
||
(define (float1 op)
|
||
(lambda (float)
|
||
(floperate op (floatnum-datum float))))
|
||
|
||
(define (float->float op)
|
||
(lambda (a)
|
||
(let ((float (x->float a))
|
||
(res (make-float-datum)))
|
||
(floperate op (floatnum-datum float) res)
|
||
(make-floatnum res))))
|
||
|
||
(define (string->float string)
|
||
(let ((res (make-float-datum)))
|
||
(floperate (enum flop string->float) string res)
|
||
(make-floatnum res)))
|
||
|
||
(define (float->string float)
|
||
(let* ((res (make-string 40 #\space))
|
||
(len (floperate (enum flop float->string)
|
||
(floatnum-datum float)
|
||
res))
|
||
(str (substring res 0 len)))
|
||
(let loop ((i 0))
|
||
(cond ((>= i (string-length str))
|
||
(string-append str "."))
|
||
((or (char=? (string-ref str i) #\e)
|
||
(char=? (string-ref str i) #\.))
|
||
str)
|
||
(else
|
||
(loop (+ i 1)))))))
|
||
|
||
(define (x->float x)
|
||
(cond ((floatnum? x) x)
|
||
((integer? x)
|
||
(exact-integer->float (if (exact? x)
|
||
x
|
||
(inexact->exact x))))
|
||
((rational? x)
|
||
;; This loses when num or den overflows flonum range
|
||
;; but x doesn't.
|
||
(float/ (numerator x) (denominator x)))
|
||
(else
|
||
(error "cannot coerce to a float" x))))
|
||
|
||
; Conversion to/from exact integer
|
||
|
||
(define (exact-integer->float k)
|
||
(or (fixnum->float k)
|
||
(float+ (float* (fixnum->float definitely-a-fixnum)
|
||
(quotient k definitely-a-fixnum))
|
||
(fixnum->float (remainder k definitely-a-fixnum)))))
|
||
|
||
(define (fixnum->float k) ;Returns #f is k is a bignum
|
||
(let ((res (make-float-datum)))
|
||
(if (floperate (enum flop fixnum->float) k res)
|
||
(make-floatnum res)
|
||
#f)))
|
||
|
||
(define (float->exact-integer x)
|
||
(or (float->fixnum x)
|
||
(let ((d (fixnum->float definitely-a-fixnum)))
|
||
(+ (* definitely-a-fixnum
|
||
(float->exact-integer (float-quotient x d)))
|
||
(float->fixnum (float-remainder x d))))))
|
||
|
||
(define definitely-a-fixnum (expt 2 23)) ;Be conservative
|
||
|
||
(define integral-floatnum? (float1 (enum flop integer?)))
|
||
(define float->fixnum (float1 (enum flop float->fixnum)))
|
||
|
||
(define float+ (float&float->float (enum flop +)))
|
||
(define float- (float&float->float (enum flop -)))
|
||
(define float* (float&float->float (enum flop *)))
|
||
(define float/ (float&float->float (enum flop /)))
|
||
(define float-quotient (float&float->float (enum flop quotient)))
|
||
(define float-remainder (float&float->float (enum flop remainder)))
|
||
(define float-atan (float&float->float (enum flop atan)))
|
||
|
||
(define float= (float&float->boolean (enum flop =)))
|
||
(define float< (float&float->boolean (enum flop <)))
|
||
|
||
(define float-exp (float->float (enum flop exp)))
|
||
(define float-log (float->float (enum flop log)))
|
||
(define float-sin (float->float (enum flop sin)))
|
||
(define float-cos (float->float (enum flop cos)))
|
||
(define float-tan (float->float (enum flop tan)))
|
||
(define float-asin (float->float (enum flop asin)))
|
||
(define float-acos (float->float (enum flop acos)))
|
||
(define float-sqrt (float->float (enum flop sqrt)))
|
||
(define float-floor (float->float (enum flop floor)))
|
||
|
||
; This lets you do ,open floatnum to get faster invocation
|
||
(begin
|
||
(define exp float-exp)
|
||
(define log float-log)
|
||
(define sin float-sin)
|
||
(define cos float-cos)
|
||
(define tan float-tan)
|
||
(define asin float-asin)
|
||
(define acos float-acos)
|
||
(define atan float-atan)
|
||
(define sqrt float-sqrt))
|
||
|
||
(define (float-fraction-length x)
|
||
(let ((two (exact-integer->float 2)))
|
||
(do ((x x (float* x two))
|
||
(i 0 (+ i 1)))
|
||
((integral-floatnum? x) i)
|
||
(if (> i 1000) (error "I'm bored." x)))))
|
||
|
||
(define (float-denominator x)
|
||
(expt (exact-integer->float 2) (float-fraction-length x)))
|
||
|
||
(define (float-numerator x)
|
||
(float* x (float-denominator x)))
|
||
|
||
(define (float->exact x)
|
||
(if (integral-floatnum? x)
|
||
(float->exact-integer x) ;+++
|
||
(let ((lose (lambda ()
|
||
(call-error "no exact representation"
|
||
inexact->exact x)))
|
||
(q (expt 2 (float-fraction-length x))))
|
||
(if (exact? q)
|
||
(let ((e (/ (float->exact-integer
|
||
(float* x (exact-integer->float q)))
|
||
q)))
|
||
(if (exact? e)
|
||
e
|
||
(lose)))
|
||
(lose)))))
|
||
|
||
|
||
; Methods on floatnums
|
||
|
||
(define-method &integer? ((x :floatnum))
|
||
(integral-floatnum? x))
|
||
|
||
(define-method &rational? ((n :floatnum)) #t)
|
||
|
||
(define-method &exact? ((x :floatnum)) #f)
|
||
|
||
(define-method &inexact->exact ((x :floatnum))
|
||
(float->exact x))
|
||
|
||
(define-method &exact->inexact ((x :rational))
|
||
(x->float x)) ;Should do this only if the number is within range.
|
||
|
||
(define-method &floor ((x :floatnum)) (float-floor x))
|
||
|
||
; beware infinite regress
|
||
(define-method &numerator ((x :floatnum)) (float-numerator x))
|
||
(define-method &denominator ((x :floatnum)) (float-denominator x))
|
||
|
||
(define (define-floatnum-method mtable proc)
|
||
(define-method mtable ((m :rational) (n :rational)) (proc m n)))
|
||
|
||
(define-floatnum-method &+ float+)
|
||
(define-floatnum-method &- float-)
|
||
(define-floatnum-method &* float*)
|
||
(define-floatnum-method &/ float/)
|
||
(define-floatnum-method "ient float-quotient)
|
||
(define-floatnum-method &remainder float-remainder)
|
||
(define-floatnum-method &= float=)
|
||
(define-floatnum-method &< float<)
|
||
|
||
(define-method &numerator ((x :rational)) (float-numerator x))
|
||
(define-method &denominator ((x :rational)) (float-denominator x))
|
||
|
||
(define-method &exp ((x :rational)) (float-exp x))
|
||
(define-method &log ((x :rational)) (float-log x))
|
||
(define-method &sqrt ((x :rational)) (float-sqrt x))
|
||
(define-method &sin ((x :rational)) (float-sin x))
|
||
(define-method &cos ((x :rational)) (float-cos x))
|
||
(define-method &tan ((x :rational)) (float-tan x))
|
||
(define-method &acos ((x :rational)) (float-acos x))
|
||
|
||
(define-floatnum-method &atan float-atan)
|
||
|
||
(define-method &number->string ((n :floatnum) radix)
|
||
(if (= radix 10)
|
||
(float->string n)
|
||
(next-method)))
|
||
|
||
; Oog.
|
||
|
||
(define (float-string? s)
|
||
(let ((len (string-length s)))
|
||
(define (start)
|
||
(cond ((< len 2)
|
||
#f)
|
||
((char-numeric? (string-ref s 0))
|
||
(digits 1 #f #f))
|
||
((and (or (char=? (string-ref s 0) #\+)
|
||
(char=? (string-ref s 0) #\-))
|
||
(char-numeric? (string-ref s 1)))
|
||
(digits 2 #f #f))
|
||
((and (char=? (string-ref s 0) #\.)
|
||
(char-numeric? (string-ref s 1)))
|
||
(digits 2 #t #f))
|
||
(else #f)))
|
||
(define (digits i dot? e?)
|
||
(cond ((>= i len) dot?)
|
||
((char-numeric? (string-ref s i))
|
||
(digits (+ i 1) dot? e?))
|
||
((and (char=? (string-ref s i) #\e)
|
||
(not e?))
|
||
(exponent (+ i 1)))
|
||
((and (char=? (string-ref s i) #\.)
|
||
(not dot?))
|
||
(digits (+ i 1) #t #f))
|
||
(else #f)))
|
||
(define (exponent i)
|
||
(cond ((>= i len) #f)
|
||
((char-numeric? (string-ref s i))
|
||
(digits (+ i 1) #t #t))
|
||
((or (char=? (string-ref s i) #\+)
|
||
(char=? (string-ref s i) #\-))
|
||
(exponent2 (+ i 1)))
|
||
(else #f)))
|
||
(define (exponent2 i)
|
||
(cond ((>= i len) #f)
|
||
((char-numeric? (string-ref s i))
|
||
(digits (+ i 1) #t #t))
|
||
(else #f)))
|
||
|
||
(start)))
|
||
|
||
(define-simple-type :float-string (:string) float-string?)
|
||
|
||
(define-method &really-string->number ((s :float-string) radix exact?)
|
||
(if (and (= radix 10)
|
||
(not exact?))
|
||
(string->float s)
|
||
(next-method)))
|