Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

11297 lines (9962 sloc) 418.307 kb
;;;============================================================================
;;; File: "_num.scm", Time-stamp: <2009-11-26 16:15:21 feeley>
;;; Copyright (c) 1994-2009 by Marc Feeley, All Rights Reserved.
;;; Copyright (c) 2004-2009 by Brad Lucier, All Rights Reserved.
;;;============================================================================
(##include "header.scm")
(c-declare "#include \"mem.h\"")
(##define-macro (use-fast-bignum-algorithms) #t)
;;;============================================================================
;;; Implementation of exceptions.
(implement-library-type-range-exception)
(define-prim (##raise-range-exception arg-num proc . args)
(##extract-procedure-and-arguments
proc
args
arg-num
#f
#f
(lambda (procedure arguments arg-num dummy1 dummy2)
(macro-raise
(macro-make-range-exception procedure arguments arg-num)))))
(implement-library-type-divide-by-zero-exception)
(define-prim (##raise-divide-by-zero-exception proc . args)
(##extract-procedure-and-arguments
proc
args
#f
#f
#f
(lambda (procedure arguments dummy1 dummy2 dummy3)
(macro-raise
(macro-make-divide-by-zero-exception procedure arguments)))))
(implement-library-type-fixnum-overflow-exception)
(define-prim (##raise-fixnum-overflow-exception proc . args)
(##extract-procedure-and-arguments
proc
args
#f
#f
#f
(lambda (procedure arguments dummy1 dummy2 dummy3)
(macro-raise
(macro-make-fixnum-overflow-exception procedure arguments)))))
;;;----------------------------------------------------------------------------
;;; Define type checking procedures.
(define-fail-check-type exact-signed-int8 'exact-signed-int8)
(define-fail-check-type exact-signed-int8-list 'exact-signed-int8-list)
(define-fail-check-type exact-unsigned-int8 'exact-unsigned-int8)
(define-fail-check-type exact-unsigned-int8-list 'exact-unsigned-int8-list)
(define-fail-check-type exact-signed-int16 'exact-signed-int16)
(define-fail-check-type exact-signed-int16-list 'exact-signed-int16-list)
(define-fail-check-type exact-unsigned-int16 'exact-unsigned-int16)
(define-fail-check-type exact-unsigned-int16-list 'exact-unsigned-int16-list)
(define-fail-check-type exact-signed-int32 'exact-signed-int32)
(define-fail-check-type exact-signed-int32-list 'exact-signed-int32-list)
(define-fail-check-type exact-unsigned-int32 'exact-unsigned-int32)
(define-fail-check-type exact-unsigned-int32-list 'exact-unsigned-int32-list)
(define-fail-check-type exact-signed-int64 'exact-signed-int64)
(define-fail-check-type exact-signed-int64-list 'exact-signed-int64-list)
(define-fail-check-type exact-unsigned-int64 'exact-unsigned-int64)
(define-fail-check-type exact-unsigned-int64-list 'exact-unsigned-int64-list)
(define-fail-check-type inexact-real 'inexact-real)
(define-fail-check-type inexact-real-list 'inexact-real-list)
(define-fail-check-type number 'number)
(define-fail-check-type real 'real)
(define-fail-check-type finite-real 'finite-real)
(define-fail-check-type rational 'rational)
(define-fail-check-type integer 'integer)
(define-fail-check-type exact-integer 'exact-integer)
(define-fail-check-type fixnum 'fixnum)
(define-fail-check-type flonum 'flonum)
;;;----------------------------------------------------------------------------
;;; Numerical type predicates.
(define-prim (##number? x)
(##complex? x))
(define-prim (##complex? x)
(macro-number-dispatch x #f
#t ;; x = fixnum
#t ;; x = bignum
#t ;; x = ratnum
#t ;; x = flonum
#t)) ;; x = cpxnum
(define-prim (number? x)
(macro-force-vars (x)
(##number? x)))
(define-prim (complex? x)
(macro-force-vars (x)
(##complex? x)))
(define-prim (##real? x)
(macro-number-dispatch x #f
#t ;; x = fixnum
#t ;; x = bignum
#t ;; x = ratnum
#t ;; x = flonum
(macro-cpxnum-real? x))) ;; x = cpxnum
(define-prim (real? x)
(macro-force-vars (x)
(##real? x)))
(define-prim (##rational? x)
(macro-number-dispatch x #f
#t ;; x = fixnum
#t ;; x = bignum
#t ;; x = ratnum
(macro-flonum-rational? x) ;; x = flonum
(macro-cpxnum-rational? x))) ;; x = cpxnum
(define-prim (rational? x)
(macro-force-vars (x)
(##rational? x)))
(define-prim (##integer? x)
(macro-number-dispatch x #f
#t ;; x = fixnum
#t ;; x = bignum
#f ;; x = ratnum
(macro-flonum-int? x) ;; x = flonum
(macro-cpxnum-int? x))) ;; x = cpxnum
(define-prim (integer? x)
(macro-force-vars (x)
(##integer? x)))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;; Exactness predicates.
(define-prim (##exact? x)
(define (type-error) #f)
(macro-number-dispatch x (type-error)
#t ;; x = fixnum
#t ;; x = bignum
#t ;; x = ratnum
#f ;; x = flonum
(and (##not (##flonum? (macro-cpxnum-real x))) ;; x = cpxnum
(##not (##flonum? (macro-cpxnum-imag x))))))
(define-prim (exact? x)
(macro-force-vars (x)
(let ()
(define (type-error)
(##fail-check-number 1 exact? x))
(macro-number-dispatch x (type-error)
#t ;; x = fixnum
#t ;; x = bignum
#t ;; x = ratnum
#f ;; x = flonum
(and (##not (##flonum? (macro-cpxnum-real x))) ;; x = cpxnum
(##not (##flonum? (macro-cpxnum-imag x))))))))
(define-prim (##inexact? x)
(define (type-error) #f)
(macro-number-dispatch x (type-error)
#f ;; x = fixnum
#f ;; x = bignum
#f ;; x = ratnum
#t ;; x = flonum
(or (##flonum? (macro-cpxnum-real x)) ;; x = cpxnum
(##flonum? (macro-cpxnum-imag x)))))
(define-prim (inexact? x)
(macro-force-vars (x)
(let ()
(define (type-error)
(##fail-check-number 1 inexact? x))
(macro-number-dispatch x (type-error)
#f ;; x = fixnum
#f ;; x = bignum
#f ;; x = ratnum
#t ;; x = flonum
(or (##flonum? (macro-cpxnum-real x)) ;; x = cpxnum
(##flonum? (macro-cpxnum-imag x)))))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;; Comparison predicates.
(define-prim (##= x y)
(##define-macro (type-error-on-x) `'(1))
(##define-macro (type-error-on-y) `'(2))
(macro-number-dispatch x (type-error-on-x)
(macro-number-dispatch y (type-error-on-y) ;; x = fixnum
(##fixnum.= x y)
#f
#f
(if (##flonum.<-fixnum-exact? x)
(##flonum.= (##flonum.<-fixnum x) y)
(and (##flonum.finite? y)
(##ratnum.= (##ratnum.<-exact-int x) (##flonum.->ratnum y))))
(##cpxnum.= (##cpxnum.<-noncpxnum x) y))
(macro-number-dispatch y (type-error-on-y) ;; x = bignum
#f
(or (##eq? x y)
(##bignum.= x y))
#f
(and (##flonum.finite? y)
(##ratnum.= (##ratnum.<-exact-int x) (##flonum.->ratnum y)))
(##cpxnum.= (##cpxnum.<-noncpxnum x) y))
(macro-number-dispatch y (type-error-on-y) ;; x = ratnum
#f
#f
(or (##eq? x y)
(##ratnum.= x y))
(and (##flonum.finite? y)
(##ratnum.= x (##flonum.->ratnum y)))
(##cpxnum.= (##cpxnum.<-noncpxnum x) y))
(macro-number-dispatch y (type-error-on-y) ;; x = flonum
(if (##flonum.<-fixnum-exact? y)
(##flonum.= x (##flonum.<-fixnum y))
(and (##flonum.finite? x)
(##ratnum.= (##flonum.->ratnum x) (##ratnum.<-exact-int y))))
(and (##flonum.finite? x)
(##ratnum.= (##flonum.->ratnum x) (##ratnum.<-exact-int y)))
(and (##flonum.finite? x)
(##ratnum.= (##flonum.->ratnum x) y))
(##flonum.= x y)
(##cpxnum.= (##cpxnum.<-noncpxnum x) y))
(macro-number-dispatch y (type-error-on-y) ;; x = cpxnum
(##cpxnum.= x (##cpxnum.<-noncpxnum y))
(##cpxnum.= x (##cpxnum.<-noncpxnum y))
(##cpxnum.= x (##cpxnum.<-noncpxnum y))
(##cpxnum.= x (##cpxnum.<-noncpxnum y))
(##cpxnum.= x y))))
(define-prim-nary-bool (= x y)
#t
(if (##number? x) #t '(1))
(##= x y)
macro-force-vars
macro-no-check
(##pair? ##fail-check-number))
(define-prim (##< x y #!optional (nan-result #f))
(##define-macro (type-error-on-x) `'(1))
(##define-macro (type-error-on-y) `'(2))
(macro-number-dispatch x (type-error-on-x)
(macro-number-dispatch y (type-error-on-y) ;; x = fixnum
(##fixnum.< x y)
(##not (##bignum.negative? y))
(##ratnum.< (##ratnum.<-exact-int x) y)
(cond ((##flonum.finite? y)
(if (##flonum.<-fixnum-exact? x)
(##flonum.< (##flonum.<-fixnum x) y)
(##ratnum.< (##ratnum.<-exact-int x) (##flonum.->ratnum y))))
((##flonum.nan? y)
nan-result)
(else
(##flonum.positive? y)))
(if (macro-cpxnum-real? y)
(##< x (macro-cpxnum-real y) nan-result)
(type-error-on-y)))
(macro-number-dispatch y (type-error-on-y) ;; x = bignum
(##bignum.negative? x)
(##bignum.< x y)
(##ratnum.< (##ratnum.<-exact-int x) y)
(cond ((##flonum.finite? y)
(##ratnum.< (##ratnum.<-exact-int x) (##flonum.->ratnum y)))
((##flonum.nan? y)
nan-result)
(else
(##flonum.positive? y)))
(if (macro-cpxnum-real? y)
(##< x (macro-cpxnum-real y) nan-result)
(type-error-on-y)))
(macro-number-dispatch y (type-error-on-y) ;; x = ratnum
(##ratnum.< x (##ratnum.<-exact-int y))
(##ratnum.< x (##ratnum.<-exact-int y))
(##ratnum.< x y)
(cond ((##flonum.finite? y)
(##ratnum.< x (##flonum.->ratnum y)))
((##flonum.nan? y)
nan-result)
(else
(##flonum.positive? y)))
(if (macro-cpxnum-real? y)
(##< x (macro-cpxnum-real y) nan-result)
(type-error-on-y)))
(macro-number-dispatch y (type-error-on-y) ;; x = flonum
(cond ((##flonum.finite? x)
(if (##flonum.<-fixnum-exact? y)
(##flonum.< x (##flonum.<-fixnum y))
(##ratnum.< (##flonum.->ratnum x) (##ratnum.<-exact-int y))))
((##flonum.nan? x)
nan-result)
(else
(##flonum.negative? x)))
(cond ((##flonum.finite? x)
(##ratnum.< (##flonum.->ratnum x) (##ratnum.<-exact-int y)))
((##flonum.nan? x)
nan-result)
(else
(##flonum.negative? x)))
(cond ((##flonum.finite? x)
(##ratnum.< (##flonum.->ratnum x) y))
((##flonum.nan? x)
nan-result)
(else
(##flonum.negative? x)))
(if (or (##flonum.nan? x) (##flonum.nan? y))
nan-result
(##flonum.< x y))
(if (macro-cpxnum-real? y)
(##< x (macro-cpxnum-real y) nan-result)
(type-error-on-y)))
(if (macro-cpxnum-real? x) ;; x = cpxnum
(macro-number-dispatch y (type-error-on-y)
(##< (macro-cpxnum-real x) y nan-result)
(##< (macro-cpxnum-real x) y nan-result)
(##< (macro-cpxnum-real x) y nan-result)
(##< (macro-cpxnum-real x) y nan-result)
(if (macro-cpxnum-real? y)
(##< (macro-cpxnum-real x) (macro-cpxnum-real y) nan-result)
(type-error-on-y)))
(type-error-on-x))))
(define-prim-nary-bool (< x y)
#t
(if (##real? x) #t '(1))
(##< x y #f)
macro-force-vars
macro-no-check
(##pair? ##fail-check-real))
(define-prim-nary-bool (> x y)
#t
(if (##real? x) #t '(1))
(##< y x #f)
macro-force-vars
macro-no-check
(##pair? ##fail-check-real))
(define-prim-nary-bool (<= x y)
#t
(if (##real? x) #t '(1))
(##not (##< y x #t))
macro-force-vars
macro-no-check
(##pair? ##fail-check-real))
(define-prim-nary-bool (>= x y)
#t
(if (##real? x) #t '(1))
(##not (##< x y #t))
macro-force-vars
macro-no-check
(##pair? ##fail-check-real))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;; Numerical property predicates.
(define-prim (##zero? x)
(define (type-error)
(##fail-check-number 1 zero? x))
(macro-number-dispatch x (type-error)
(##fixnum.zero? x)
#f
#f
(##flonum.zero? x)
(and (let ((imag (macro-cpxnum-imag x)))
(and (##flonum? imag) (##flonum.zero? imag)))
(let ((real (macro-cpxnum-real x)))
(if (##fixnum? real)
(##fixnum.zero? real)
(and (##flonum? real) (##flonum.zero? real)))))))
(define-prim (zero? x)
(macro-force-vars (x)
(##zero? x)))
(define-prim (##positive? x)
(define (type-error)
(##fail-check-real 1 positive? x))
(macro-number-dispatch x (type-error)
(##fixnum.positive? x)
(##not (##bignum.negative? x))
(##positive? (macro-ratnum-numerator x))
(##flonum.positive? x)
(if (macro-cpxnum-real? x)
(##positive? (macro-cpxnum-real x))
(type-error))))
(define-prim (positive? x)
(macro-force-vars (x)
(##positive? x)))
(define-prim (##negative? x)
(define (type-error)
(##fail-check-real 1 negative? x))
(macro-number-dispatch x (type-error)
(##fixnum.negative? x)
(##bignum.negative? x)
(##negative? (macro-ratnum-numerator x))
(##flonum.negative? x)
(if (macro-cpxnum-real? x)
(##negative? (macro-cpxnum-real x))
(type-error))))
(define-prim (negative? x)
(macro-force-vars (x)
(##negative? x)))
(define-prim (##odd? x)
(define (type-error)
(##fail-check-integer 1 odd? x))
(macro-number-dispatch x (type-error)
(##fixnum.odd? x)
(macro-bignum-odd? x)
(type-error)
(if (macro-flonum-int? x)
(##odd? (##flonum.->exact-int x))
(type-error))
(if (macro-cpxnum-int? x)
(##odd? (##inexact->exact (macro-cpxnum-real x)))
(type-error))))
(define-prim (odd? x)
(macro-force-vars (x)
(##odd? x)))
(define-prim (##even? x)
(define (type-error)
(##fail-check-integer 1 even? x))
(macro-number-dispatch x (type-error)
(##not (##fixnum.odd? x))
(##not (macro-bignum-odd? x))
(type-error)
(if (macro-flonum-int? x)
(##even? (##flonum.->exact-int x))
(type-error))
(if (macro-cpxnum-int? x)
(##even? (##inexact->exact (macro-cpxnum-real x)))
(type-error))))
(define-prim (even? x)
(macro-force-vars (x)
(##even? x)))
(define-prim (##finite? x)
(define (type-error)
(##fail-check-real 1 finite? x))
(macro-number-dispatch x (type-error)
#t
#t
#t
(##flfinite? x)
(if (macro-cpxnum-real? x)
(let ((real (macro-cpxnum-real x)))
(or (##not (##flonum? real))
(##flfinite? real)))
(type-error))))
(define-prim (finite? x)
(macro-force-vars (x)
(##finite? x)))
(define-prim (##infinite? x)
(define (type-error)
(##fail-check-real 1 infinite? x))
(macro-number-dispatch x (type-error)
#f
#f
#f
(##flinfinite? x)
(if (macro-cpxnum-real? x)
(let ((real (macro-cpxnum-real x)))
(and (##flonum? real)
(##flinfinite? real)))
(type-error))))
(define-prim (infinite? x)
(macro-force-vars (x)
(##infinite? x)))
(define-prim (##nan? x)
(define (type-error)
(##fail-check-real 1 nan? x))
(macro-number-dispatch x (type-error)
#f
#f
#f
(##flnan? x)
(if (macro-cpxnum-real? x)
(let ((real (macro-cpxnum-real x)))
(and (##flonum? real)
(##flnan? real)))
(type-error))))
(define-prim (nan? x)
(macro-force-vars (x)
(##nan? x)))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;; Max and min.
(define-prim (##max x y)
(##define-macro (type-error-on-x) `'(1))
(##define-macro (type-error-on-y) `'(2))
(macro-number-dispatch x (type-error-on-x)
(macro-number-dispatch y (type-error-on-y) ;; x = fixnum
(##fixnum.max x y)
(if (##< x y) y x)
(if (##< x y) y x)
(##flonum.max (##flonum.<-fixnum x) y)
(if (macro-cpxnum-real? y)
(##max x (macro-cpxnum-real y))
(type-error-on-y)))
(macro-number-dispatch y (type-error-on-y) ;; x = bignum
(if (##< x y) y x)
(if (##< x y) y x)
(if (##< x y) y x)
(##flonum.max (##flonum.<-exact-int x) y)
(if (macro-cpxnum-real? y)
(##max x (macro-cpxnum-real y))
(type-error-on-y)))
(macro-number-dispatch y (type-error-on-y) ;; x = ratnum
(if (##< x y) y x)
(if (##< x y) y x)
(if (##< x y) y x)
(##flonum.max (##flonum.<-ratnum x) y)
(if (macro-cpxnum-real? y)
(##max x (macro-cpxnum-real y))
(type-error-on-y)))
(macro-number-dispatch y (type-error-on-y) ;; x = flonum
(##flonum.max x (##flonum.<-fixnum y))
(##flonum.max x (##flonum.<-exact-int y))
(##flonum.max x (##flonum.<-ratnum y))
(##flonum.max x y)
(if (macro-cpxnum-real? y)
(##max x (macro-cpxnum-real y))
(type-error-on-y)))
(if (macro-cpxnum-real? x) ;; x = cpxnum
(macro-number-dispatch y (type-error-on-y)
(##max (macro-cpxnum-real x) y)
(##max (macro-cpxnum-real x) y)
(##max (macro-cpxnum-real x) y)
(##max (macro-cpxnum-real x) y)
(if (macro-cpxnum-real? y)
(##max (macro-cpxnum-real x) (macro-cpxnum-real y))
(type-error-on-y)))
(type-error-on-x))))
(define-prim-nary (max x y)
()
(if (##real? x) x '(1))
(##max x y)
macro-force-vars
macro-no-check
(##pair? ##fail-check-real))
(define-prim (##min x y)
(##define-macro (type-error-on-x) `'(1))
(##define-macro (type-error-on-y) `'(2))
(macro-number-dispatch x (type-error-on-x)
(macro-number-dispatch y (type-error-on-y) ;; x = fixnum
(##fixnum.min x y)
(if (##< x y) x y)
(if (##< x y) x y)
(##flonum.min (##flonum.<-fixnum x) y)
(if (macro-cpxnum-real? y)
(##min x (macro-cpxnum-real y))
(type-error-on-y)))
(macro-number-dispatch y (type-error-on-y) ;; x = bignum
(if (##< x y) x y)
(if (##< x y) x y)
(if (##< x y) x y)
(##flonum.min (##flonum.<-exact-int x) y)
(if (macro-cpxnum-real? y)
(##min x (macro-cpxnum-real y))
(type-error-on-y)))
(macro-number-dispatch y (type-error-on-y) ;; x = ratnum
(if (##< x y) x y)
(if (##< x y) x y)
(if (##< x y) x y)
(##flonum.min (##flonum.<-ratnum x) y)
(if (macro-cpxnum-real? y)
(##min x (macro-cpxnum-real y))
(type-error-on-y)))
(macro-number-dispatch y (type-error-on-y) ;; x = flonum
(##flonum.min x (##flonum.<-fixnum y))
(##flonum.min x (##flonum.<-exact-int y))
(##flonum.min x (##flonum.<-ratnum y))
(##flonum.min x y)
(if (macro-cpxnum-real? y)
(##min x (macro-cpxnum-real y))
(type-error-on-y)))
(if (macro-cpxnum-real? x) ;; x = cpxnum
(macro-number-dispatch y (type-error-on-y)
(##min (macro-cpxnum-real x) y)
(##min (macro-cpxnum-real x) y)
(##min (macro-cpxnum-real x) y)
(##min (macro-cpxnum-real x) y)
(if (macro-cpxnum-real? y)
(##min (macro-cpxnum-real x) (macro-cpxnum-real y))
(type-error-on-y)))
(type-error-on-x))))
(define-prim-nary (min x y)
()
(if (##real? x) x '(1))
(##min x y)
macro-force-vars
macro-no-check
(##pair? ##fail-check-real))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;; +, *, -, /
(define-prim (##+ x y)
(##define-macro (type-error-on-x) `'(1))
(##define-macro (type-error-on-y) `'(2))
(macro-number-dispatch x (type-error-on-x)
(macro-number-dispatch y (type-error-on-y) ;; x = fixnum
(or (##fixnum.+? x y)
(##bignum.+ (##bignum.<-fixnum x) (##bignum.<-fixnum y)))
(if (##fixnum.zero? x)
y
(##bignum.+ (##bignum.<-fixnum x) y))
(if (##fixnum.zero? x)
y
(##ratnum.+ (##ratnum.<-exact-int x) y))
(if (and (macro-special-case-exact-zero?) (##fixnum.zero? x))
y
(##flonum.+ (##flonum.<-fixnum x) y))
(##cpxnum.+ (##cpxnum.<-noncpxnum x) y))
(macro-number-dispatch y (type-error-on-y) ;; x = bignum
(if (##fixnum.zero? y)
x
(##bignum.+ x (##bignum.<-fixnum y)))
(##bignum.+ x y)
(##ratnum.+ (##ratnum.<-exact-int x) y)
(##flonum.+ (##flonum.<-exact-int x) y)
(##cpxnum.+ (##cpxnum.<-noncpxnum x) y))
(macro-number-dispatch y (type-error-on-y) ;; x = ratnum
(if (##fixnum.zero? y)
x
(##ratnum.+ x (##ratnum.<-exact-int y)))
(##ratnum.+ x (##ratnum.<-exact-int y))
(##ratnum.+ x y)
(##flonum.+ (##flonum.<-ratnum x) y)
(##cpxnum.+ (##cpxnum.<-noncpxnum x) y))
(macro-number-dispatch y (type-error-on-y) ;; x = flonum
(if (and (macro-special-case-exact-zero?) (##fixnum.zero? y))
x
(##flonum.+ x (##flonum.<-fixnum y)))
(##flonum.+ x (##flonum.<-exact-int y))
(##flonum.+ x (##flonum.<-ratnum y))
(##flonum.+ x y)
(##cpxnum.+ (##cpxnum.<-noncpxnum x) y))
(macro-number-dispatch y (type-error-on-y) ;; x = cpxnum
(##cpxnum.+ x (##cpxnum.<-noncpxnum y))
(##cpxnum.+ x (##cpxnum.<-noncpxnum y))
(##cpxnum.+ x (##cpxnum.<-noncpxnum y))
(##cpxnum.+ x (##cpxnum.<-noncpxnum y))
(##cpxnum.+ x y))))
(define-prim-nary (+ x y)
0
(if (##number? x) x '(1))
(##+ x y)
macro-force-vars
macro-no-check
(##pair? ##fail-check-number))
(define-prim (##* x y)
(##define-macro (type-error-on-x) `'(1))
(##define-macro (type-error-on-y) `'(2))
(macro-number-dispatch x (type-error-on-x)
(macro-number-dispatch y (type-error-on-y) ;; x = fixnum
(cond ((##fixnum.= y 0)
0)
((if (##fixnum.= y -1)
(##fixnum.-? x)
(##fixnum.*? x y))
=> (lambda (result) result))
(else
(##bignum.* (##bignum.<-fixnum x) (##bignum.<-fixnum y))))
(cond ((##fixnum.zero? x)
0)
((##fixnum.= x 1)
y)
((##fixnum.= x -1)
(##negate y))
(else
(##bignum.* (##bignum.<-fixnum x) y)))
(cond ((##fixnum.zero? x)
0)
((##fixnum.= x 1)
y)
((##fixnum.= x -1)
(##negate y))
(else
(##ratnum.* (##ratnum.<-exact-int x) y)))
(cond ((and (macro-special-case-exact-zero?)
(##fixnum.zero? x))
0)
((##fixnum.= x 1)
y)
(else
(##flonum.* (##flonum.<-fixnum x) y)))
(cond ((and (macro-special-case-exact-zero?)
(##fixnum.zero? x))
0)
((##fixnum.= x 1)
y)
(else
(##cpxnum.* (##cpxnum.<-noncpxnum x) y))))
(macro-number-dispatch y (type-error-on-y) ;; x = bignum
(cond ((##eq? y 0)
0)
((##eq? y 1)
x)
((##eq? y -1)
(##negate x))
(else
(##bignum.* x (##bignum.<-fixnum y))))
(##bignum.* x y)
(##ratnum.* (##ratnum.<-exact-int x) y)
(##flonum.* (##flonum.<-exact-int x) y)
(##cpxnum.* (##cpxnum.<-noncpxnum x) y))
(macro-number-dispatch y (type-error-on-y) ;; x = ratnum
(cond ((##fixnum.zero? y)
0)
((##fixnum.= y 1)
x)
((##fixnum.= y -1)
(##negate x))
(else
(##ratnum.* x (##ratnum.<-exact-int y))))
(##ratnum.* x (##ratnum.<-exact-int y))
(##ratnum.* x y)
(##flonum.* (##flonum.<-ratnum x) y)
(##cpxnum.* (##cpxnum.<-noncpxnum x) y))
(macro-number-dispatch y (type-error-on-y) ;; x = flonum
(cond ((and (macro-special-case-exact-zero?) (##fixnum.zero? y))
0)
((##fixnum.= y 1)
x)
(else
(##flonum.* x (##flonum.<-fixnum y))))
(##flonum.* x (##flonum.<-exact-int y))
(##flonum.* x (##flonum.<-ratnum y))
(##flonum.* x y)
(##cpxnum.* (##cpxnum.<-noncpxnum x) y))
(macro-number-dispatch y (type-error-on-y) ;; x = cpxnum
(cond ((and (macro-special-case-exact-zero?) (##fixnum.zero? y))
0)
((##fixnum.= y 1)
x)
(else
(##cpxnum.* x (##cpxnum.<-noncpxnum y))))
(##cpxnum.* x (##cpxnum.<-noncpxnum y))
(##cpxnum.* x (##cpxnum.<-noncpxnum y))
(##cpxnum.* x (##cpxnum.<-noncpxnum y))
(##cpxnum.* x y))))
(define-prim-nary (* x y)
1
(if (##number? x) x '(1))
(##* x y)
macro-force-vars
macro-no-check
(##pair? ##fail-check-number))
(define-prim (##negate x)
(##define-macro (type-error) `'(1))
(macro-number-dispatch x (type-error)
(or (##fixnum.-? x)
(##bignum.- (##bignum.<-fixnum 0) (##bignum.<-fixnum ##min-fixnum)))
(##bignum.- (##bignum.<-fixnum 0) x)
(macro-ratnum-make (##negate (macro-ratnum-numerator x))
(macro-ratnum-denominator x))
(##flonum.- x)
(##make-rectangular (##negate (macro-cpxnum-real x))
(##negate (macro-cpxnum-imag x)))))
(define-prim (##- x y)
(##define-macro (type-error-on-x) `'(1))
(##define-macro (type-error-on-y) `'(2))
(macro-number-dispatch x (type-error-on-x)
(macro-number-dispatch y (type-error-on-y) ;; x = fixnum
(or (##fixnum.-? x y)
(##bignum.- (##bignum.<-fixnum x) (##bignum.<-fixnum y)))
(##bignum.- (##bignum.<-fixnum x) y)
(if (##fixnum.zero? x)
(##negate y)
(##ratnum.- (##ratnum.<-exact-int x) y))
(if (and (macro-special-case-exact-zero?) (##fixnum.zero? x))
(##flonum.- y)
(##flonum.- (##flonum.<-fixnum x) y))
(##cpxnum.- (##cpxnum.<-noncpxnum x) y))
(macro-number-dispatch y (type-error-on-y) ;; x = bignum
(if (##fixnum.zero? y)
x
(##bignum.- x (##bignum.<-fixnum y)))
(##bignum.- x y)
(##ratnum.- (##ratnum.<-exact-int x) y)
(##flonum.- (##flonum.<-exact-int x) y)
(##cpxnum.- (##cpxnum.<-noncpxnum x) y))
(macro-number-dispatch y (type-error-on-y) ;; x = ratnum
(if (##fixnum.zero? y)
x
(##ratnum.- x (##ratnum.<-exact-int y)))
(##ratnum.- x (##ratnum.<-exact-int y))
(##ratnum.- x y)
(##flonum.- (##flonum.<-ratnum x) y)
(##cpxnum.- (##cpxnum.<-noncpxnum x) y))
(macro-number-dispatch y (type-error-on-y) ;; x = flonum
(if (and (macro-special-case-exact-zero?) (##fixnum.zero? y))
x
(##flonum.- x (##flonum.<-fixnum y)))
(##flonum.- x (##flonum.<-exact-int y))
(##flonum.- x (##flonum.<-ratnum y))
(##flonum.- x y)
(##cpxnum.- (##cpxnum.<-noncpxnum x) y))
(macro-number-dispatch y (type-error-on-y) ;; x = cpxnum
(##cpxnum.- x (##cpxnum.<-noncpxnum y))
(##cpxnum.- x (##cpxnum.<-noncpxnum y))
(##cpxnum.- x (##cpxnum.<-noncpxnum y))
(##cpxnum.- x (##cpxnum.<-noncpxnum y))
(##cpxnum.- x y))))
(define-prim-nary (- x y)
()
(##negate x)
(##- x y)
macro-force-vars
macro-no-check
(##pair? ##fail-check-number))
(define-prim (##inverse x)
(##define-macro (type-error) `'(1))
(define (divide-by-zero-error) #f)
(macro-number-dispatch x (type-error)
(if (##fixnum.zero? x)
(divide-by-zero-error)
(if (##fixnum.negative? x)
(if (##fixnum.= x -1)
x
(macro-ratnum-make -1 (##negate x)))
(if (##fixnum.= x 1)
x
(macro-ratnum-make 1 x))))
(if (##bignum.negative? x)
(macro-ratnum-make -1 (##negate x))
(macro-ratnum-make 1 x))
(let ((num (macro-ratnum-numerator x))
(den (macro-ratnum-denominator x)))
(cond ((##eq? num 1)
den)
((##eq? num -1)
(##negate den))
(else
(if (##negative? num)
(macro-ratnum-make (##negate den) (##negate num))
(macro-ratnum-make den num)))))
(##flonum./ (macro-inexact-+1) x)
(##cpxnum./ (##cpxnum.<-noncpxnum 1) x)))
(define-prim (##/ x y)
(##define-macro (type-error-on-x) `'(1))
(##define-macro (type-error-on-y) `'(2))
(define (divide-by-zero-error) #f)
(macro-number-dispatch y (type-error-on-y)
(macro-number-dispatch x (type-error-on-x) ;; y = fixnum
(cond ((##fixnum.zero? y)
(divide-by-zero-error))
((##fixnum.= y 1)
x)
((##fixnum.= y -1)
(##negate x))
((##fixnum.zero? x)
0)
((##fixnum.= x 1)
(##inverse y))
(else
(##ratnum./ (##ratnum.<-exact-int x) (##ratnum.<-exact-int y))))
(cond ((##fixnum.zero? y)
(divide-by-zero-error))
((##fixnum.= y 1)
x)
((##fixnum.= y -1)
(##negate x))
(else
(##ratnum./ (##ratnum.<-exact-int x) (##ratnum.<-exact-int y))))
(cond ((##fixnum.zero? y)
(divide-by-zero-error))
((##fixnum.= y 1)
x)
((##fixnum.= y -1)
(##negate x))
(else
(##ratnum./ x (##ratnum.<-exact-int y))))
(if (##fixnum.zero? y)
(divide-by-zero-error)
(##flonum./ x (##flonum.<-fixnum y)))
(if (##fixnum.zero? y)
(divide-by-zero-error)
(##cpxnum./ x (##cpxnum.<-noncpxnum y))))
(macro-number-dispatch x (type-error-on-x) ;; y = bignum
(cond ((##fixnum.zero? x)
0)
((##fixnum.= x 1)
(##inverse y))
(else
(##ratnum./ (##ratnum.<-exact-int x) (##ratnum.<-exact-int y))))
(##ratnum./ (##ratnum.<-exact-int x) (##ratnum.<-exact-int y))
(##ratnum./ x (##ratnum.<-exact-int y))
(##flonum./ x (##flonum.<-exact-int y))
(##cpxnum./ x (##cpxnum.<-noncpxnum y)))
(macro-number-dispatch x (type-error-on-x) ;; y = ratnum
(cond ((##fixnum.zero? x)
0)
((##fixnum.= x 1)
(##inverse y))
(else
(##ratnum./ (##ratnum.<-exact-int x) y)))
(##ratnum./ (##ratnum.<-exact-int x) y)
(##ratnum./ x y)
(##flonum./ x (##flonum.<-ratnum y))
(##cpxnum./ x (##cpxnum.<-noncpxnum y)))
(macro-number-dispatch x (type-error-on-x) ;; y = flonum, no error possible
(if (and (macro-special-case-exact-zero?) (##fixnum.zero? x))
x
(##flonum./ (##flonum.<-fixnum x) y))
(##flonum./ (##flonum.<-exact-int x) y)
(##flonum./ (##flonum.<-ratnum x) y)
(##flonum./ x y)
(##cpxnum./ x (##cpxnum.<-noncpxnum y)))
(macro-number-dispatch x (type-error-on-x) ;; y = cpxnum
(##cpxnum./ (##cpxnum.<-noncpxnum x) y)
(##cpxnum./ (##cpxnum.<-noncpxnum x) y)
(##cpxnum./ (##cpxnum.<-noncpxnum x) y)
(##cpxnum./ (##cpxnum.<-noncpxnum x) y)
(##cpxnum./ x y))))
(define-prim-nary (/ x y)
()
(##inverse x)
(##/ x y)
macro-force-vars
macro-no-check
(##pair? ##fail-check-number)
(##not ##raise-divide-by-zero-exception))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;; abs
(define-prim (##abs x)
(define (type-error)
(##fail-check-real 1 abs x))
(macro-number-dispatch x (type-error)
(if (##fixnum.negative? x) (##negate x) x)
(if (##bignum.negative? x) (##negate x) x)
(macro-ratnum-make (##abs (macro-ratnum-numerator x))
(macro-ratnum-denominator x))
(##flonum.abs x)
(if (macro-cpxnum-real? x)
(##make-rectangular (##abs (macro-cpxnum-real x))
(##abs (macro-cpxnum-imag x)))
(type-error))))
(define-prim (abs x)
(macro-force-vars (x)
(##abs x)))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;; quotient, remainder, modulo
(define-prim (##quotient x y)
(define (type-error-on-x)
(##fail-check-integer 1 quotient x y))
(define (type-error-on-y)
(##fail-check-integer 2 quotient x y))
(define (divide-by-zero-error)
(##raise-divide-by-zero-exception quotient x y))
(define (exact-quotient x y)
(##car (##exact-int.div x y)))
(define (inexact-quotient x y)
(let ((exact-y (##inexact->exact y)))
(if (##eq? exact-y 0)
(divide-by-zero-error)
(##exact->inexact
(##quotient (##inexact->exact x) exact-y)))))
(macro-number-dispatch y (type-error-on-y)
(macro-number-dispatch x (type-error-on-x) ;; y = fixnum
(cond ((##fixnum.= y 0)
(divide-by-zero-error))
((##fixnum.= y -1) ;; (quotient ##min-fixnum -1) is a bignum
(##negate x))
(else
(##fixnum.quotient x y)))
(cond ((##fixnum.= y 0)
(divide-by-zero-error))
(else
(exact-quotient x y)))
(type-error-on-x)
(if (macro-flonum-int? x)
(inexact-quotient x y)
(type-error-on-x))
(if (macro-cpxnum-int? x)
(inexact-quotient x y)
(type-error-on-x)))
(macro-number-dispatch x (type-error-on-x) ;; y = bignum
(exact-quotient x y)
(exact-quotient x y)
(type-error-on-x)
(if (macro-flonum-int? x)
(inexact-quotient x y)
(type-error-on-x))
(if (macro-cpxnum-int? x)
(inexact-quotient x y)
(type-error-on-x)))
(type-error-on-y) ;; y = ratnum
(macro-number-dispatch x (type-error-on-x) ;; y = flonum
(if (macro-flonum-int? y)
(inexact-quotient x y)
(type-error-on-y))
(if (macro-flonum-int? y)
(inexact-quotient x y)
(type-error-on-y))
(type-error-on-x)
(if (macro-flonum-int? x)
(if (macro-flonum-int? y)
(inexact-quotient x y)
(type-error-on-y))
(type-error-on-x))
(if (macro-cpxnum-int? x)
(if (macro-flonum-int? y)
(inexact-quotient x y)
(type-error-on-y))
(type-error-on-x)))
(if (macro-cpxnum-int? y) ;; y = cpxnum
(macro-number-dispatch x (type-error-on-x)
(inexact-quotient x y)
(inexact-quotient x y)
(type-error-on-x)
(if (macro-flonum-int? x)
(inexact-quotient x y)
(type-error-on-x))
(if (macro-cpxnum-int? x)
(inexact-quotient x y)
(type-error-on-x)))
(type-error-on-y))))
(define-prim (quotient x y)
(macro-force-vars (x y)
(##quotient x y)))
(define-prim (##remainder x y)
(define (type-error-on-x)
(##fail-check-integer 1 remainder x y))
(define (type-error-on-y)
(##fail-check-integer 2 remainder x y))
(define (divide-by-zero-error)
(##raise-divide-by-zero-exception remainder x y))
(define (exact-remainder x y)
(##cdr (##exact-int.div x y)))
(define (inexact-remainder x y)
(let ((exact-y (##inexact->exact y)))
(if (##eq? exact-y 0)
(divide-by-zero-error)
(##exact->inexact
(##remainder (##inexact->exact x) exact-y)))))
(macro-number-dispatch y (type-error-on-y)
(macro-number-dispatch x (type-error-on-x) ;; y = fixnum
(cond ((##fixnum.= y 0)
(divide-by-zero-error))
(else
(##fixnum.remainder x y)))
(cond ((##fixnum.= y 0)
(divide-by-zero-error))
(else
(exact-remainder x y)))
(type-error-on-x)
(if (macro-flonum-int? x)
(inexact-remainder x y)
(type-error-on-x))
(if (macro-cpxnum-int? x)
(inexact-remainder x y)
(type-error-on-x)))
(macro-number-dispatch x (type-error-on-x) ;; y = bignum
(exact-remainder x y)
(exact-remainder x y)
(type-error-on-x)
(if (macro-flonum-int? x)
(inexact-remainder x y)
(type-error-on-x))
(if (macro-cpxnum-int? x)
(inexact-remainder x y)
(type-error-on-x)))
(type-error-on-y) ;; y = ratnum
(macro-number-dispatch x (type-error-on-x) ;; y = flonum
(if (macro-flonum-int? y)
(inexact-remainder x y)
(type-error-on-y))
(if (macro-flonum-int? y)
(inexact-remainder x y)
(type-error-on-y))
(type-error-on-x)
(if (macro-flonum-int? x)
(if (macro-flonum-int? y)
(inexact-remainder x y)
(type-error-on-y))
(type-error-on-x))
(if (macro-cpxnum-int? x)
(if (macro-flonum-int? y)
(inexact-remainder x y)
(type-error-on-y))
(type-error-on-x)))
(if (macro-cpxnum-int? y) ;; y = cpxnum
(macro-number-dispatch x (type-error-on-x)
(inexact-remainder x y)
(inexact-remainder x y)
(type-error-on-x)
(if (macro-flonum-int? x)
(inexact-remainder x y)
(type-error-on-x))
(if (macro-cpxnum-int? x)
(inexact-remainder x y)
(type-error-on-x)))
(type-error-on-y))))
(define-prim (remainder x y)
(macro-force-vars (x y)
(##remainder x y)))
(define-prim (##modulo x y)
(define (type-error-on-x)
(##fail-check-integer 1 modulo x y))
(define (type-error-on-y)
(##fail-check-integer 2 modulo x y))
(define (divide-by-zero-error)
(##raise-divide-by-zero-exception modulo x y))
(define (exact-modulo x y)
(let ((r (##cdr (##exact-int.div x y))))
(if (##eq? r 0)
0
(if (##eq? (##negative? x) (##negative? y))
r
(##+ r y)))))
(define (inexact-modulo x y)
(let ((exact-y (##inexact->exact y)))
(if (##eq? exact-y 0)
(divide-by-zero-error)
(##exact->inexact
(##modulo (##inexact->exact x) exact-y)))))
(macro-number-dispatch y (type-error-on-y)
(macro-number-dispatch x (type-error-on-x) ;; y = fixnum
(cond ((##fixnum.= y 0)
(divide-by-zero-error))
(else
(##fixnum.modulo x y)))
(cond ((##fixnum.= y 0)
(divide-by-zero-error))
(else
(exact-modulo x y)))
(type-error-on-x)
(if (macro-flonum-int? x)
(inexact-modulo x y)
(type-error-on-x))
(if (macro-cpxnum-int? x)
(inexact-modulo x y)
(type-error-on-x)))
(macro-number-dispatch x (type-error-on-x) ;; y = bignum
(exact-modulo x y)
(exact-modulo x y)
(type-error-on-x)
(if (macro-flonum-int? x)
(inexact-modulo x y)
(type-error-on-x))
(if (macro-cpxnum-int? x)
(inexact-modulo x y)
(type-error-on-x)))
(type-error-on-y) ;; y = ratnum
(macro-number-dispatch x (type-error-on-x) ;; y = flonum
(if (macro-flonum-int? y)
(inexact-modulo x y)
(type-error-on-y))
(if (macro-flonum-int? y)
(inexact-modulo x y)
(type-error-on-y))
(type-error-on-x)
(if (macro-flonum-int? x)
(if (macro-flonum-int? y)
(inexact-modulo x y)
(type-error-on-y))
(type-error-on-x))
(if (macro-cpxnum-int? x)
(if (macro-flonum-int? y)
(inexact-modulo x y)
(type-error-on-y))
(type-error-on-x)))
(if (macro-cpxnum-int? y) ;; y = cpxnum
(macro-number-dispatch x (type-error-on-x)
(inexact-modulo x y)
(inexact-modulo x y)
(type-error-on-x)
(if (macro-flonum-int? x)
(inexact-modulo x y)
(type-error-on-x))
(if (macro-cpxnum-int? x)
(inexact-modulo x y)
(type-error-on-x)))
(type-error-on-y))))
(define-prim (modulo x y)
(macro-force-vars (x y)
(##modulo x y)))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;; gcd, lcm
(define-prim (##gcd x y)
(##define-macro (type-error-on-x) `'(1))
(##define-macro (type-error-on-y) `'(2))
(define (##fast-gcd u v)
;; See the paper "Fast Reduction and Composition of Binary
;; Quadratic Forms" by Arnold Schoenhage. His algorithm and proof
;; are derived from, and basically the same for, his Controlled
;; Euclidean Descent algorithm for gcd, which he has never
;; published. This algorithm has complexity log N times a
;; constant times the complexity of a multiplication of the same
;; size. We don't use it until we get to about 6800 bits. Note
;; that this is the same place that we start using FFT
;; multiplication and fast division with Newton's method for
;; finding inverses.
;; Niels Mo"ller has written two papers about an improved version
;; of this algorithm.
;; assumes u and v are nonnegative exact ints
(define (make-gcd-matrix A_11 A_12
A_21 A_22)
(##vector A_11 A_12
A_21 A_22))
(define (gcd-matrix_11 A)
(##vector-ref A 0))
(define (gcd-matrix_12 A)
(##vector-ref A 1))
(define (gcd-matrix_21 A)
(##vector-ref A 2))
(define (gcd-matrix_22 A)
(##vector-ref A 3))
(define (make-gcd-vector v_1 v_2)
(##vector v_1 v_2))
(define (gcd-vector_1 v)
(##vector-ref v 0))
(define (gcd-vector_2 v)
(##vector-ref v 1))
(define gcd-matrix-identity '#(1 0
0 1))
(define (gcd-matrix-multiply A B)
(cond ((##eq? A gcd-matrix-identity)
B)
((##eq? B gcd-matrix-identity)
A)
(else
(let ((A_11 (gcd-matrix_11 A)) (A_12 (gcd-matrix_12 A))
(A_21 (gcd-matrix_21 A)) (A_22 (gcd-matrix_22 A))
(B_11 (gcd-matrix_11 B)) (B_12 (gcd-matrix_12 B))
(B_21 (gcd-matrix_21 B)) (B_22 (gcd-matrix_22 B)))
(make-gcd-matrix (##+ (##* A_11 B_11)
(##* A_12 B_21))
(##+ (##* A_11 B_12)
(##* A_12 B_22))
(##+ (##* A_21 B_11)
(##* A_22 B_21))
(##+ (##* A_21 B_12)
(##* A_22 B_22)))))))
(define (gcd-matrix-multiply-strassen A B)
;; from http://mathworld.wolfram.com/StrassenFormulas.html
(cond ((##eq? A gcd-matrix-identity)
B)
((##eq? B gcd-matrix-identity)
A)
(else
(let ((A_11 (gcd-matrix_11 A)) (A_12 (gcd-matrix_12 A))
(A_21 (gcd-matrix_21 A)) (A_22 (gcd-matrix_22 A))
(B_11 (gcd-matrix_11 B)) (B_12 (gcd-matrix_12 B))
(B_21 (gcd-matrix_21 B)) (B_22 (gcd-matrix_22 B)))
(let ((Q_1 (##* (##+ A_11 A_22) (##+ B_11 B_22)))
(Q_2 (##* (##+ A_21 A_22) B_11))
(Q_3 (##* A_11 (##- B_12 B_22)))
(Q_4 (##* A_22 (##- B_21 B_11)))
(Q_5 (##* (##+ A_11 A_12) B_22))
(Q_6 (##* (##- A_21 A_11) (##+ B_11 B_12)))
(Q_7 (##* (##- A_12 A_22) (##+ B_21 B_22))))
(make-gcd-matrix (##+ (##+ Q_1 Q_4) (##- Q_7 Q_5))
(##+ Q_3 Q_5)
(##+ Q_2 Q_4)
(##+ (##+ Q_1 Q_3) (##- Q_6 Q_2))))))))
(define (gcd-matrix-solve A y)
(let ((y_1 (gcd-vector_1 y))
(y_2 (gcd-vector_2 y)))
(make-gcd-vector (##- (##* y_1 (gcd-matrix_22 A))
(##* y_2 (gcd-matrix_12 A)))
(##- (##* y_2 (gcd-matrix_11 A))
(##* y_1 (gcd-matrix_21 A))))))
(define (x>=2^n x n)
(cond ((##eq? x 0)
#f)
((and (##fixnum? x)
(##fixnum.<= n ##bignum.mdigit-width))
(##fixnum.>= x (##fixnum.arithmetic-shift-left 1 n)))
(else
(let ((x (if (##fixnum? x) (##bignum.<-fixnum x) x)))
(let loop ((i (##fixnum.- (##bignum.mdigit-length x) 1)))
(let ((digit (##bignum.mdigit-ref x i)))
(if (##fixnum.zero? digit)
(loop (##fixnum.- i 1))
(let ((words (##fixnum.quotient n ##bignum.mdigit-width)))
(or (##fixnum.> i words)
(and (##fixnum.= i words)
(##fixnum.>= digit
(##fixnum.arithmetic-shift-left
1
(##fixnum.remainder n ##bignum.mdigit-width)))))))))))))
(define (determined-minimal? u v s)
;; assumes 2^s <= u , v; s>= 0 fixnum
;; returns #t if we can determine that |u-v|<2^s
;; at least one of u and v is a bignum
(let ((u (if (##fixnum? u) (##bignum.<-fixnum u) u))
(v (if (##fixnum? v) (##bignum.<-fixnum v) v)))
(let ((u-length (##bignum.mdigit-length u)))
(and (##fixnum.= u-length (##bignum.mdigit-length v))
(let loop ((i (##fixnum.- u-length 1)))
(let ((v-digit (##bignum.mdigit-ref v i))
(u-digit (##bignum.mdigit-ref u i)))
(if (and (##fixnum.zero? u-digit)
(##fixnum.zero? v-digit))
(loop (##fixnum.- i 1))
(and (##fixnum.= (##fixnum.quotient s ##bignum.mdigit-width)
i)
(##fixnum.< (##fixnum.max (##fixnum.- u-digit v-digit)
(##fixnum.- v-digit u-digit))
(##fixnum.arithmetic-shift-left
1
(##fixnum.remainder s ##bignum.mdigit-width)))))))))))
(define (gcd-small-step cont M u v s)
;; u, v >= 2^s
;; M is the matrix product of the partial sums of
;; the continued fraction representation of a/b so far
;; returns updated M, u, v, and a truth value
;; u, v >= 2^s and
;; if last return value is #t, we know that
;; (- (max u v) (min u v)) < 2^s, i.e, u, v are minimal above 2^s
(define (gcd-matrix-multiply-low M q)
(let ((M_11 (gcd-matrix_11 M))
(M_12 (gcd-matrix_12 M))
(M_21 (gcd-matrix_21 M))
(M_22 (gcd-matrix_22 M)))
(make-gcd-matrix (##+ M_11 (##* q M_12)) M_12
(##+ M_21 (##* q M_22)) M_22)))
(define (gcd-matrix-multiply-high M q)
(let ((M_11 (gcd-matrix_11 M))
(M_12 (gcd-matrix_12 M))
(M_21 (gcd-matrix_21 M))
(M_22 (gcd-matrix_22 M)))
(make-gcd-matrix M_11 (##+ (##* q M_11) M_12)
M_21 (##+ (##* q M_21) M_22))))
(if (or (##bignum? u)
(##bignum? v))
;; if u and v are nearly equal bignums, the two ##<
;; following this condition could take O(N) time to compute.
;; When this happens, however, it will be likely that
;; determined-minimal? will return true.
(cond ((determined-minimal? u v s)
(cont M
u
v
#t))
((##< u v)
(let* ((qr (##exact-int.div v u))
(q (##car qr))
(r (##cdr qr)))
(cond ((x>=2^n r s)
(cont (gcd-matrix-multiply-low M q)
u
r
#f))
((##eq? q 1)
(cont M
u
v
#t))
(else
(cont (gcd-matrix-multiply-low M (##- q 1))
u
(##+ r u)
#t)))))
((##< v u)
(let* ((qr (##exact-int.div u v))
(q (##car qr))
(r (##cdr qr)))
(cond ((x>=2^n r s)
(cont (gcd-matrix-multiply-high M q)
r
v
#f))
((##eq? q 1)
(cont M
u
v
#t))
(else
(cont (gcd-matrix-multiply-high M (##- q 1))
(##+ r v)
v
#t)))))
(else
(cont M
u
v
#t)))
;; here u and v are fixnums, so 2^s, which is <= u and v, is
;; also a fixnum
(let ((two^s (##fixnum.arithmetic-shift-left 1 s)))
(if (##fixnum.< u v)
(if (##fixnum.< (##fixnum.- v u) two^s)
(cont M
u
v
#t)
(let ((r (##fixnum.remainder v u))
(q (##fixnum.quotient v u)))
(if (##fixnum.>= r two^s)
(cont (gcd-matrix-multiply-low M q)
u
r
#f)
;; the case when q is one and the remainder is < two^s
;; is covered in the first test
(cont (gcd-matrix-multiply-low M (##fixnum.- q 1))
u
(##fixnum.+ r u)
#t))))
;; here u >= v, but the case u = v is covered by the first test
(if (##fixnum.< (##fixnum.- u v) two^s)
(cont M
u
v
#t)
(let ((r (##fixnum.remainder u v))
(q (##fixnum.quotient u v)))
(if (##fixnum.>= r two^s)
(cont (gcd-matrix-multiply-high M q)
r
v
#f)
;; the case when q is one and the remainder is < two^s
;; is covered in the first test
(cont (gcd-matrix-multiply-high M (##fixnum.- q 1))
(##fixnum.+ r v)
v
#t))))))))
(define (gcd-middle-step cont a b h m-prime cont-needs-M?)
((lambda (cont)
(if (and (x>=2^n a h)
(x>=2^n b h))
(MR cont a b h cont-needs-M?)
(cont gcd-matrix-identity a b)))
(lambda (M x y)
(let loop ((M M)
(x x)
(y y))
(if (or (x>=2^n x h)
(x>=2^n y h))
((lambda (cont) (gcd-small-step cont M x y m-prime))
(lambda (M x y minimal?)
(if minimal?
(cont M x y)
(loop M x y))))
((lambda (cont) (MR cont x y m-prime cont-needs-M?))
(lambda (M-prime alpha beta)
(cont (if cont-needs-M?
(if (##fixnum.> (##fixnum.- h m-prime) 1024)
;; here we trade off 1 multiplication
;; for 21 additions
(gcd-matrix-multiply-strassen M M-prime)
(gcd-matrix-multiply M M-prime))
gcd-matrix-identity)
alpha
beta))))))))
(define (MR cont a b m cont-needs-M?)
((lambda (cont)
(if (and (x>=2^n a (##fixnum.+ m 2))
(x>=2^n b (##fixnum.+ m 2)))
(let ((n (##fixnum.- (##fixnum.max (##integer-length a)
(##integer-length b))
m)))
((lambda (cont)
(if (##fixnum.<= m n)
(cont m 0)
(cont n (##fixnum.- (##fixnum.+ m 1) n))))
(lambda (m-prime p)
(let ((h (##fixnum.+ m-prime (##fixnum.quotient n 2))))
(if (##fixnum.< 0 p)
(let ((a (##arithmetic-shift a (##fixnum.- p)))
(b (##arithmetic-shift b (##fixnum.- p)))
(a_0 (##extract-bit-field p 0 a))
(b_0 (##extract-bit-field p 0 b)))
((lambda (cont)
(gcd-middle-step cont a b h m-prime #t))
(lambda (M alpha beta)
(let ((M-inverse-v_0 (gcd-matrix-solve M (make-gcd-vector a_0 b_0))))
(cont (if cont-needs-M? M gcd-matrix-identity)
(##+ (##arithmetic-shift alpha p)
(gcd-vector_1 M-inverse-v_0))
(##+ (##arithmetic-shift beta p)
(gcd-vector_2 M-inverse-v_0)))))))
(gcd-middle-step cont a b h m-prime cont-needs-M?))))))
(cont gcd-matrix-identity
a
b)))
(lambda (M alpha beta)
(let loop ((M M)
(alpha alpha)
(beta beta)
(minimal? #f))
(if minimal?
(cont M alpha beta)
(gcd-small-step loop M alpha beta m))))))
((lambda (cont)
(if (and (use-fast-bignum-algorithms)
(##bignum? u)
(##bignum? v)
(x>=2^n u ##bignum.fast-gcd-size)
(x>=2^n v ##bignum.fast-gcd-size))
(MR cont u v ##bignum.fast-gcd-size #f)
(cont 0 u v)))
(lambda (M a b)
(general-base a b))))
(define (general-base a b)
(##declare (not interrupts-enabled))
(if (##eq? b 0)
a
(if (##fixnum? b)
(fixnum-base b (##remainder a b))
(general-base b (##remainder a b)))))
(define (fixnum-base a b)
(##declare (not interrupts-enabled))
(if (##eq? b 0)
a
(let ((a b)
(b (##fixnum.remainder a b)))
(if (##eq? b 0)
a
(fixnum-base b (##fixnum.remainder a b))))))
(define (exact-gcd x y)
(let ((x (##abs x))
(y (##abs y)))
(cond ((##eq? x 0)
y)
((##eq? y 0)
x)
((and (##fixnum? x) (##fixnum? y))
(fixnum-base x y))
(else
(let ((x-first-bit (##first-bit-set x))
(y-first-bit (##first-bit-set y)))
(##arithmetic-shift
(##fast-gcd (##arithmetic-shift x (##fixnum.- x-first-bit))
(##arithmetic-shift y (##fixnum.- y-first-bit)))
(##fixnum.min x-first-bit y-first-bit)))))))
(define (inexact-gcd x y)
(##exact->inexact
(exact-gcd (##inexact->exact x)
(##inexact->exact y))))
(cond ((##not (##integer? x))
(type-error-on-x))
((##not (##integer? y))
(type-error-on-y))
((##eq? x y)
(##abs x))
(else
(if (and (##exact? x) (##exact? y))
(exact-gcd x y)
(inexact-gcd x y)))))
(define-prim-nary (gcd x y)
0
(if (##integer? x) (##abs x) '(1))
(##gcd x y)
macro-force-vars
macro-no-check
(##pair? ##fail-check-integer))
(define-prim (##lcm x y)
(##define-macro (type-error-on-x) `'(1))
(##define-macro (type-error-on-y) `'(2))
(define (exact-lcm x y)
(if (or (##eq? x 0) (##eq? y 0))
0
(##abs (##* (##quotient x (##gcd x y))
y))))
(define (inexact-lcm x y)
(##exact->inexact
(exact-lcm (##inexact->exact x)
(##inexact->exact y))))
(cond ((##not (##integer? x))
(type-error-on-x))
((##not (##integer? y))
(type-error-on-y))
(else
(if (and (##exact? x) (##exact? y))
(exact-lcm x y)
(inexact-lcm x y)))))
(define-prim-nary (lcm x y)
1
(if (##integer? x) (##abs x) '(1))
(##lcm x y)
macro-force-vars
macro-no-check
(##pair? ##fail-check-integer))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;; numerator, denominator
(define-prim (##numerator x)
(define (type-error)
(##fail-check-rational 1 numerator x))
(macro-number-dispatch x (type-error)
x
x
(macro-ratnum-numerator x)
(cond ((##flonum.zero? x)
x)
((macro-flonum-rational? x)
(##exact->inexact (##numerator (##flonum.inexact->exact x))))
(else
(type-error)))
(if (macro-cpxnum-rational? x)
(##numerator (macro-cpxnum-real x))
(type-error))))
(define-prim (numerator x)
(macro-force-vars (x)
(##numerator x)))
(define-prim (##denominator x)
(define (type-error)
(##fail-check-rational 1 denominator x))
(macro-number-dispatch x (type-error)
1
1
(macro-ratnum-denominator x)
(if (macro-flonum-rational? x)
(##exact->inexact (##denominator (##flonum.inexact->exact x)))
(type-error))
(if (macro-cpxnum-rational? x)
(##denominator (macro-cpxnum-real x))
(type-error))))
(define-prim (denominator x)
(macro-force-vars (x)
(##denominator x)))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;; floor, ceiling, truncate, round
(define-prim (##floor x)
(define (type-error)
(##fail-check-finite-real 1 floor x))
(macro-number-dispatch x (type-error)
x
x
(let ((num (macro-ratnum-numerator x))
(den (macro-ratnum-denominator x)))
(if (##negative? num)
(##quotient (##- num (##- den 1)) den)
(##quotient num den)))
(if (##flonum.finite? x)
(##flonum.floor x)
(type-error))
(if (macro-cpxnum-real? x)
(##floor (macro-cpxnum-real x))
(type-error))))
(define-prim (floor x)
(macro-force-vars (x)
(##floor x)))
(define-prim (##ceiling x)
(define (type-error)
(##fail-check-finite-real 1 ceiling x))
(macro-number-dispatch x (type-error)
x
x
(let ((num (macro-ratnum-numerator x))
(den (macro-ratnum-denominator x)))
(if (##negative? num)
(##quotient num den)
(##quotient (##+ num (##- den 1)) den)))
(if (##flonum.finite? x)
(##flonum.ceiling x)
(type-error))
(if (macro-cpxnum-real? x)
(##ceiling (macro-cpxnum-real x))
(type-error))))
(define-prim (ceiling x)
(macro-force-vars (x)
(##ceiling x)))
(define-prim (##truncate x)
(define (type-error)
(##fail-check-finite-real 1 truncate x))
(macro-number-dispatch x (type-error)
x
x
(##quotient (macro-ratnum-numerator x)
(macro-ratnum-denominator x))
(if (##flonum.finite? x)
(##flonum.truncate x)
(type-error))
(if (macro-cpxnum-real? x)
(##truncate (macro-cpxnum-real x))
(type-error))))
(define-prim (truncate x)
(macro-force-vars (x)
(##truncate x)))
(define-prim (##round x)
(define (type-error)
(##fail-check-finite-real 1 round x))
(macro-number-dispatch x (type-error)
x
x
(##ratnum.round x)
(if (##flonum.finite? x)
(##flonum.round x)
(type-error))
(if (macro-cpxnum-real? x)
(##round (macro-cpxnum-real x))
(type-error))))
(define-prim (round x)
(macro-force-vars (x)
(##round x)))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;; rationalize
(define-prim (##rationalize x y)
(define (simplest-rational1 x y)
(if (##< y x)
(simplest-rational2 y x)
(simplest-rational2 x y)))
(define (simplest-rational2 x y)
(cond ((##not (##< x y))
x)
((##positive? x)
(simplest-rational3 x y))
((##negative? y)
(##negate (simplest-rational3 (##negate y) (##negate x))))
(else
0)))
(define (simplest-rational3 x y)
(let ((fx (##floor x))
(fy (##floor y)))
(cond ((##not (##< fx x))
fx)
((##= fx fy)
(##+ fx
(##inverse
(simplest-rational3
(##inverse (##- y fy))
(##inverse (##- x fx))))))
(else
(##+ fx 1)))))
(cond ((##not (##rational? x))
(##fail-check-finite-real 1 rationalize x y))
((and (##flonum? y)
(##flonum.= y (macro-inexact-+inf)))
(macro-inexact-+0))
((##not (##rational? y))
(##fail-check-real 2 rationalize x y))
((##negative? y)
(##raise-range-exception 2 rationalize x y))
((and (##exact? x) (##exact? y))
(simplest-rational1 (##- x y) (##+ x y)))
(else
(let ((exact-x (##inexact->exact x))
(exact-y (##inexact->exact y)))
(##exact->inexact
(simplest-rational1 (##- exact-x exact-y)
(##+ exact-x exact-y)))))))
(define-prim (rationalize x y)
(macro-force-vars (x y)
(##rationalize x y)))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;; trigonometry and complex numbers
(define-prim (##exp x)
(define (type-error)
(##fail-check-number 1 exp x))
(macro-number-dispatch x (type-error)
(if (##fixnum.zero? x)
1
(##flonum.exp (##flonum.<-fixnum x)))
(##flonum.exp (##flonum.<-exact-int x))
(##flonum.exp (##flonum.<-ratnum x))
(##flonum.exp x)
(##make-polar (##exp (macro-cpxnum-real x))
(macro-cpxnum-imag x))))
(define-prim (exp x)
(macro-force-vars (x)
(##exp x)))
(define-prim (##flonum.full-precision? x)
(let ((y (##flonum.abs x)))
(and (##fl< y (macro-inexact-+inf))
(##fl<= (macro-flonum-min-normal) y))))
(define-prim (##log x)
(define (type-error)
(##fail-check-number 1 log x))
(define (range-error)
(##raise-range-exception 1 log x))
(define (negative-log x)
(##make-rectangular (##log (##negate x)) (macro-inexact-+pi)))
(define (exact-log x)
;; x is positive, x is not 1.
;; There are three places where just converting to a flonum and
;; taking the flonum logarithm doesn't work well.
;; 1. Overflow in the conversion
;; 2. Underflow in the conversion (or even loss of precision
;; because of a denormalized conversion result)
;; 3. When the number is close to 1.
(let ((float-x (##exact->inexact x)))
(cond ((##= x float-x)
(##fllog float-x)) ;; first, we trust the builtin flonum log
((##not (##flonum.full-precision? float-x))
;; direct conversion to flonum could incur massive relative
;; rounding errors, or would just lead to an infinite result
;; so we tolerate more than one rounding error in the calculation
(let* ((wn (##integer-length (##numerator x)))
(wd (##integer-length (##denominator x)))
(p (##fx- wn wd))
(float-p (##flonum.<-fixnum p))
(partial-result (##fllog
(##exact->inexact
(##* x (##expt 2 (##fx- p)))))))
(##fl+ (##fl* float-p
(macro-inexact-log-2))
partial-result)))
((or (##fl< (macro-inexact-exp-+1/2) float-x)
(##fl< float-x (macro-inexact-exp--1/2)))
;; here the absolute value of the logarithm is at least 0.5,
;; so there is less rounding error in the final result.
(##flonum.log float-x))
(else
;; for rational numbers near one, we use the taylor
;; series for (log (/ (- x 1) (+ x 1))) by hand.
;; we first approximate (/ (- x 1) (+ x 1)) by a dyadic
;; rational with (macro-flonum-m-bits-plus-1*2) bits accuracy
(let* ((y (##/ (##- x 1) (##+ x 1)))
(normalizer (##expt 2 (##fx+ (macro-flonum-m-bits-plus-1*2)
(##fx- (##integer-length (##denominator y))
(##integer-length (##numerator y))))))
(dyadic-y (##/ (##round (##* y normalizer))
normalizer))
(dyadic-y^2 (##* dyadic-y dyadic-y))
(bits-gained-per-loop (##fx- (##integer-length (##denominator dyadic-y^2))
(##integer-length (##numerator dyadic-y^2))
1)))
(let loop ((k 0)
(y^2k+1 dyadic-y)
(result dyadic-y)
(accuracy bits-gained-per-loop))
(if (##fx< (macro-flonum-m-bits-plus-1*2) accuracy)
(##flonum.<-ratnum (##* 2 result))
(let ((y^2k+1 (##* dyadic-y^2 y^2k+1))
(k (##fx+ k 1)))
(loop k
y^2k+1
(##+ result (##/ y^2k+1 (##fx+ (##fx* 2 k) 1)))
(##fx+ accuracy bits-gained-per-loop))))))))))
(define (complex-log-magnitude x)
(define (log-mag a b)
;; both are finite, 0 <= a <= b, b is nonzero
(let* ((c (##/ a b))
(approx-mag (##* b (##sqrt (##+ 1 (##* c c))))))
(if (or (##exact? approx-mag)
(and (##flonum.full-precision? approx-mag)
(or (##fl< (macro-inexact-exp-+1/2) approx-mag)
(##fl< approx-mag (macro-inexact-exp--1/2)))))
;; log composed with magnitude will compute a relatively accurate answer
(##log approx-mag)
(let ((a (##inexact->exact a))
(b (##inexact->exact b)))
(##* 1/2 (exact-log (##+ (##* a a) (##* b b))))))))
(let ((abs-r (##abs (##real-part x)))
(abs-i (##abs (##imag-part x))))
;; abs-i is not exact 0
(cond ((or (and (##flonum? abs-r)
(##flonum.= abs-r (macro-inexact-+inf)))
(and (##flonum? abs-i)
(##flonum.= abs-i (macro-inexact-+inf))))
(macro-inexact-+inf))
;; neither abs-r or abs-i is infinite
((and (##flonum? abs-r)
(##flonum.nan? abs-r))
abs-r)
;; abs-r is not a NaN
((and (##flonum? abs-i)
(##flonum.nan? abs-i))
abs-i)
;; abs-i is not a NaN
((##eq? abs-r 0)
(##log abs-i))
;; abs-r is not exact 0
((and (##zero? abs-r)
(##zero? abs-i))
(macro-inexact--inf))
;; abs-i and abs-r are not both zero
(else
(if (##< abs-r abs-i)
(log-mag abs-r abs-i)
(log-mag abs-i abs-r))))))
(macro-number-dispatch x (type-error)
(if (##fixnum.zero? x)
(range-error)
(if (##fixnum.negative? x)
(negative-log x)
(if (##eq? x 1)
0
(exact-log x))))
(if (##bignum.negative? x)
(negative-log x)
(exact-log x))
(if (##negative? (macro-ratnum-numerator x))
(negative-log x)
(exact-log x))
(if (or (##flonum.nan? x)
(##not (##flonum.negative?
(##flonum.copysign (macro-inexact-+1) x))))
(##flonum.log x)
(negative-log x))
(##make-rectangular (complex-log-magnitude x) (##angle x))))
(define-prim (log x)
(macro-force-vars (x)
(##log x)))
(define-prim (##sin x)
(define (type-error)
(##fail-check-number 1 sin x))
(macro-number-dispatch x (type-error)
(if (##fixnum.zero? x)
0
(##flonum.sin (##flonum.<-fixnum x)))
(##flonum.sin (##flonum.<-exact-int x))
(##flonum.sin (##flonum.<-ratnum x))
(##flonum.sin x)
(##/ (##- (##exp (##make-rectangular
(##negate (macro-cpxnum-imag x))
(macro-cpxnum-real x)))
(##exp (##make-rectangular
(macro-cpxnum-imag x)
(##negate (macro-cpxnum-real x)))))
(macro-cpxnum-+2i))))
(define-prim (sin x)
(macro-force-vars (x)
(##sin x)))
(define-prim (##cos x)
(define (type-error)
(##fail-check-number 1 cos x))
(macro-number-dispatch x (type-error)
(if (##fixnum.zero? x)
1
(##flonum.cos (##flonum.<-fixnum x)))
(##flonum.cos (##flonum.<-exact-int x))
(##flonum.cos (##flonum.<-ratnum x))
(##flonum.cos x)
(##/ (##+ (##exp (##make-rectangular
(##negate (macro-cpxnum-imag x))
(macro-cpxnum-real x)))
(##exp (##make-rectangular
(macro-cpxnum-imag x)
(##negate (macro-cpxnum-real x)))))
2)))
(define-prim (cos x)
(macro-force-vars (x)
(##cos x)))
(define-prim (##tan x)
(define (type-error)
(##fail-check-number 1 tan x))
(macro-number-dispatch x (type-error)
(if (##fixnum.zero? x)
0
(##flonum.tan (##flonum.<-fixnum x)))
(##flonum.tan (##flonum.<-exact-int x))
(##flonum.tan (##flonum.<-ratnum x))
(##flonum.tan x)
(let ((a (##exp (##make-rectangular
(##negate (macro-cpxnum-imag x))
(macro-cpxnum-real x))))
(b (##exp (##make-rectangular
(macro-cpxnum-imag x)
(##negate (macro-cpxnum-real x))))))
(let ((c (##/ (##- a b) (##+ a b))))
(##make-rectangular (##imag-part c) (##negate (##real-part c)))))))
(define-prim (tan x)
(macro-force-vars (x)
(##tan x)))
(define-prim (##asin x)
(define (type-error)
(##fail-check-number 1 asin x))
(define (safe-case x)
(##* (macro-cpxnum--i)
(##log (##+ (##* (macro-cpxnum-+i) x)
(##sqrt (##- 1 (##* x x)))))))
(define (unsafe-case x)
(##negate (safe-case (##negate x))))
(define (real-case x)
(cond ((##< x -1)
(unsafe-case x))
((##< 1 x)
(safe-case x))
(else
(##flonum.asin (##exact->inexact x)))))
(macro-number-dispatch x (type-error)
(if (##fixnum.zero? x)
0
(real-case x))
(real-case x)
(real-case x)
(real-case x)
(let ((imag (macro-cpxnum-imag x)))
(if (or (##positive? imag)
(and (##flonum? imag)
(##flonum.zero? imag)
(##negative? (macro-cpxnum-real x))))
(unsafe-case x)
(safe-case x)))))
(define-prim (asin x)
(macro-force-vars (x)
(##asin x)))
(define-prim (##acos x)
(define (type-error)
(##fail-check-number 1 acos x))
(define (complex-case x)
(##- (macro-inexact-+pi/2) (##asin x)))
(define (real-case x)
(if (or (##< x -1) (##< 1 x))
(complex-case x)
(##flonum.acos (##exact->inexact x))))
(macro-number-dispatch x (type-error)
(if (##fixnum.zero? x)
(macro-inexact-+pi/2)
(real-case x))
(real-case x)
(real-case x)
(real-case x)
(complex-case x)))
(define-prim (acos x)
(macro-force-vars (x)
(##acos x)))
(define-prim (##atan x)
(define (type-error)
(##fail-check-number 1 atan x))
(define (range-error)
(##raise-range-exception 1 atan x))
(macro-number-dispatch x (type-error)
(if (##fixnum.zero? x)
0
(##flonum.atan (##flonum.<-fixnum x)))
(##flonum.atan (##flonum.<-exact-int x))
(##flonum.atan (##flonum.<-ratnum x))
(##flonum.atan x)
(let ((real (macro-cpxnum-real x))
(imag (macro-cpxnum-imag x)))
(if (and (##eq? real 0) (##eq? imag 1))
(range-error)
(let ((a (##make-rectangular (##negate imag) real)))
(##/ (##- (##log (##+ a 1)) (##log (##- 1 a)))
(macro-cpxnum-+2i)))))))
(define-prim (##atan2 y x)
(define (flonum-substitute x)
(cond ((##flonum? x)
x)
((##eq? x 0)
0.)
((##positive? x)
1.)
(else
-1.)))
(define (irregular-flonum? x)
(and (##flonum? x)
(or (##flonum.zero? x)
(##not (##flfinite? x)))))
(cond ((##eq? 0 y)
(if (##exact? x)
(if (##negative? x)
(macro-inexact-+pi)
0)
(if (##negative? (##flonum.copysign (macro-inexact-+1) x))
(macro-inexact-+pi)
0.)))
((or (irregular-flonum? x)
(irregular-flonum? y))
(##flonum.atan (flonum-substitute y)
(flonum-substitute x)))
(else
(let ((inexact-x (##exact->inexact x))
(inexact-y (##exact->inexact y)))
(if (and (or (##flonum? x)
(##flonum.full-precision? inexact-x)
(##= x inexact-x))
(or (##flonum? y)
(##flonum.full-precision? inexact-y)
(##= y inexact-y)))
(##flonum.atan inexact-y inexact-x)
;; at least one of x or y is nonzero
;; and at least one of them is not a flonum
(let* ((exact-x (##inexact->exact x))
(exact-y (##inexact->exact y))
(max-arg (##max (##abs exact-x)
(##abs exact-y)))
(normalizer (##expt 2 (##- (##integer-length (##denominator max-arg))
(##integer-length (##numerator max-arg))))))
;; now the largest argument will be about 1.
(##flonum.atan (##exact->inexact (##* normalizer exact-y))
(##exact->inexact (##* normalizer exact-x)))))))))
(define-prim (atan x #!optional (y (macro-absent-obj)))
(macro-force-vars (x)
(if (##eq? y (macro-absent-obj))
(##atan x)
(macro-force-vars (y)
(cond ((##not (##real? x))
(##fail-check-real 1 atan x y))
((##not (##real? y))
(##fail-check-real 2 atan x y))
(else
(##atan2 x y)))))))
(define-prim (##sqrt x)
(define (type-error)
(##fail-check-number 1 sqrt x))
(define (exact-int-sqrt x)
(if (##negative? x)
(##make-rectangular 0 (exact-int-sqrt (##negate x)))
(let ((y (##exact-int.sqrt x)))
(cond ((##eq? (##cdr y) 0)
(##car y))
((if (##fixnum? x)
(or (##not (##fixnum? (macro-flonum-+m-max-plus-1)))
(##fixnum.<= x (macro-flonum-+m-max-plus-1)))
(and (##not (##fixnum? (macro-flonum-+m-max-plus-1)))
(##not (##bignum.< (macro-flonum-+m-max-plus-1) x))))
;; 0 <= x <= (macro-flonum-+m-max-plus-1), can be
;; converted to flonum exactly so avoids double
;; rounding in next expression this has a relatively
;; fast path for small integers.
(##flonum.sqrt
(if (##fixnum? x)
(##flonum.<-fixnum x)
(##flonum.<-exact-int x))))
((##not (##< (##car y) (macro-flonum-+m-max-plus-1)))
;; ##flonum.<-exact-int uses second argument correctly
(##flonum.<-exact-int (##car y) #t))
(else
;; The integer part of y does not have enough bits accuracy
;; to round it correctly to a flonum, so to
;; make sure (##car y) is big enough in the next call we
;; multiply by (expt 2 (macro-flonum-m-bits-plus-1*2)),
;; which is somewhat extravagant;
;; (expt 2 (+ 1 (macro-flonum-m-bits-plus-1))) should
;; work fine.
(##flonum.* (macro-flonum-inverse-+m-max-plus-1-inexact)
(exact-int-sqrt
(##arithmetic-shift
x
(macro-flonum-m-bits-plus-1*2)))))))))
(define (ratnum-sqrt x)
(if (##negative? x)
(##make-rectangular 0 (ratnum-sqrt (##negate x)))
(let ((p (macro-ratnum-numerator x))
(q (macro-ratnum-denominator x)))
(let ((sqrt-p (##exact-int.sqrt p))
(sqrt-q (##exact-int.sqrt q)))
(if (and (##zero? (##cdr sqrt-p))
(##zero? (##cdr sqrt-q)))
;; both (abs p) and q are perfect squares and
;; their square roots do not have any common factors
(macro-ratnum-make (##car sqrt-p)
(##car sqrt-q))
(let ((wp (##integer-length p))
(wq (##integer-length q)))
;; for IEEE 754 double precision, we need at least
;; 53 or 54 (I can't seem to work it out) of the
;; leading bits of (sqrt (/ p q)). Here we get
;; about 64 leading bits. We just shift p (either
;; right or left) until it is about 128 bits longer
;; than q (shift must be even), then take the
;; integer square root of the result.
(let* ((shift
(##fixnum.arithmetic-shift-left
(##fixnum.arithmetic-shift-right
(##fixnum.- 128 (##fixnum.- wp wq))
1)
1))
(leading-bits
(##car
(##exact-int.sqrt
(##quotient
(##arithmetic-shift p shift)
q))))
(pre-rounded-result
(if (##fixnum.negative? shift)
(##arithmetic-shift
leading-bits
(##fixnum.-
(##fixnum.arithmetic-shift-right
shift
1)))
(##ratnum.normalize
leading-bits
(##arithmetic-shift
1
(##fixnum.arithmetic-shift-right
shift
1))))))
(if (##ratnum? pre-rounded-result)
(##flonum.<-ratnum pre-rounded-result #t)
(##flonum.<-exact-int pre-rounded-result #t)))))))))
(define (complex-sqrt-magnitude x)
(define (sqrt-mag a b)
;; both are finite, 0 <= a <= b, b is nonzero
(let* ((c (##/ a b))
(d (##sqrt (##+ 1 (##* c c)))))
;; the following may return an inexact result when the true
;; result is exact, but we're just feeding it into make-polar
;; with a non-exact-zero angle, anyway.
(##* (##sqrt b) (##sqrt d))))
(let ((abs-r (##abs (##real-part x)))
(abs-i (##abs (##imag-part x))))
;; abs-i is not exact 0
(cond ((or (and (##flonum? abs-r)
(##flonum.= abs-r (macro-inexact-+inf)))
(and (##flonum? abs-i)
(##flonum.= abs-i (macro-inexact-+inf))))
(macro-inexact-+inf))
;; neither abs-r or abs-i is infinite
((and (##flonum? abs-r)
(##flonum.nan? abs-r))
abs-r)
;; abs-r is not a NaN
((and (##flonum? abs-i)
(##flonum.nan? abs-i))
abs-i)
;; abs-i is not a NaN
((##eq? abs-r 0)
(##sqrt abs-i))
;; abs-r is not exact 0
((and (##zero? abs-r)
(##zero? abs-i))
(macro-inexact-+0))
;; abs-i and abs-r are not both zero
(else
(if (##< abs-r abs-i)
(sqrt-mag abs-r abs-i)
(sqrt-mag abs-i abs-r))))))
(macro-number-dispatch x (type-error)
(exact-int-sqrt x)
(exact-int-sqrt x)
(ratnum-sqrt x)
(if (##flonum.negative? x)
(##make-rectangular 0 (##flonum.sqrt (##flonum.- x)))
(##flonum.sqrt x))
(let ((real (##real-part x))
(imag (##imag-part x)))
(cond ((and (##flonum? imag)
(##flonum.zero? imag))
(if (##flonum.positive? (##flonum.copysign (macro-inexact-+1) imag))
(cond ((##negative? real)
(##make-rectangular (macro-inexact-+0)
(##exact->inexact
(##sqrt (##negate real)))))
((and (##flonum? real)
(##flonum.nan? real))
(##make-rectangular real real))
(else
(##make-rectangular (##exact->inexact (##sqrt real))
(macro-inexact-+0))))
(cond ((##negative? real)
(##make-rectangular (macro-inexact-+0)
(##exact->inexact
(##negate (##sqrt (##negate real))))))
((and (##flonum? real)
(##flonum.nan? real))
(##make-rectangular real real))
(else
(##make-rectangular (##exact->inexact (##sqrt real))
(macro-inexact--0))))))
((and (##exact? real)
(##exact? imag)
(let ((discriminant (##sqrt (##+ (##* real real)
(##* imag imag)))))
(and (##exact? discriminant)
(let ((result-real (##sqrt (##/ (##+ real discriminant) 2))))
(and (##exact? result-real)
(##make-rectangular result-real (##/ imag (##* 2 result-real))))))))
=>
values)
(else
(##make-polar (complex-sqrt-magnitude x)
(##/ (##angle x) 2)))))))
(define-prim (sqrt x)
(macro-force-vars (x)
(##sqrt x)))
(define-prim (##expt x y)
(define (exact-int-expt x y)
(define (positive-int-expt x y)
;; x is an exact number and y is a positive exact integer
(define (square x)
(##* x x))
(define (expt-aux x y)
;; x is an exact integer (not 0 or 1) and y is a nonzero exact integer
(if (##eq? y 1)
x
(let ((temp (square (expt-aux x (##arithmetic-shift y -1)))))
(if (##even? y)
temp
(##* x temp)))))
(cond ((or (##eq? x 0)
(##eq? x 1))
x)
((##ratnum? x)
(macro-ratnum-make
(exact-int-expt (macro-ratnum-numerator x) y)
(exact-int-expt (macro-ratnum-denominator x) y)))
(else
(expt-aux x y))))
(define (invert z)
;; z is exact
(let ((result (##inverse z)))
(if (##not result)
(##raise-range-exception 1 expt x y)
result)))
(if (##negative? y)
(invert (positive-int-expt x (##negate y)))
(positive-int-expt x y)))
(define (complex-expt x y)
(##exp (##* (##log x) y)))
(define (ratnum-expt x y)
;; x is exact-int or ratnum
(cond ((##eq? x 0)
(if (##negative? y)
(##raise-range-exception 1 expt x y)
0))
((##eq? x 1)
1)
((##negative? x)
;; We'll do some nice multiples of angles of pi carefully
(case (macro-ratnum-denominator y)
((2)
(##* (##expt (##negate x) y)
(case (##modulo (macro-ratnum-numerator y) 4)
((1)
(macro-cpxnum-+i))
(else ;; (3)
(macro-cpxnum--i)))))
((3)
(##* (##expt (##negate x) y)
(case (##modulo (macro-ratnum-numerator y) 6)
((1)
(macro-cpxnum-+1/2+sqrt3/2i))
((2)
(macro-cpxnum--1/2+sqrt3/2i))
((4)
(macro-cpxnum--1/2-sqrt3/2i))
(else ;; (5)
(macro-cpxnum-+1/2-sqrt3/2i)))))
((6)
(##* (##expt (##negate x) y)
(case (##modulo (macro-ratnum-numerator y) 12)
((1)
(macro-cpxnum-+sqrt3/2+1/2i))
((5)
(macro-cpxnum--sqrt3/2+1/2i))
((7)
(macro-cpxnum--sqrt3/2-1/2i))
(else ;; (11)
(macro-cpxnum-+sqrt3/2-1/2i)))))
;; otherwise, we punt
(else
(complex-expt x y))))
((or (##fixnum? x)
(##bignum? x))
(let* ((y-den (macro-ratnum-denominator y))
(temp (##exact-int.nth-root x y-den)))
(if (##= x (exact-int-expt temp y-den))
(exact-int-expt temp (macro-ratnum-numerator y))
(##flonum.expt (##flonum.<-exact-int x)
(##flonum.<-ratnum y)))))
(else
;; x is a ratnum
(let ((x-num (macro-ratnum-numerator x))
(x-den (macro-ratnum-denominator x))
(y-num (macro-ratnum-numerator y))
(y-den (macro-ratnum-denominator y)))
(let ((temp-num (##exact-int.nth-root x-num y-den)))
(if (##= (exact-int-expt temp-num y-den) x-num)
(let ((temp-den (##exact-int.nth-root x-den y-den)))
(if (##= (exact-int-expt temp-den y-den) x-den)
(exact-int-expt (macro-ratnum-make temp-num temp-den)
y-num)
(##flonum.expt (##flonum.<-ratnum x)
(##flonum.<-ratnum y))))
(##flonum.expt (##flonum.<-ratnum x)
(##flonum.<-ratnum y))))))))
(macro-number-dispatch y (##fail-check-number 2 expt x y)
(macro-number-dispatch x (##fail-check-number 1 expt x y) ;; y a fixnum
(if (##eq? y 0)
1
(exact-int-expt x y))
(if (##eq? y 0)
1
(exact-int-expt x y))
(if (##eq? y 0)
1
(exact-int-expt x y))
(cond ((##eq? y 0)
1)
((##flonum.nan? x)
x)
((##flonum.negative? x)
;; we do this because (##flonum.<-fixnum y) is always
;; even for large enough y on 64-bit machines
(let ((abs-result
(##flonum.expt (##flonum.- x) (##flonum.<-fixnum y))))
(if (##fixnum.odd? y)
(##flonum.- abs-result)
abs-result)))
(else
(##flonum.expt x (##flonum.<-fixnum y))))
(cond ((##eq? y 0)
1)
((##eq? y 1)
x)
((##exact? x)
(exact-int-expt x y))
(else
(complex-expt x y))))
(macro-number-dispatch x (##fail-check-number 1 expt x y) ;; y a bignum
(exact-int-expt x y)
(exact-int-expt x y)
(exact-int-expt x y)
(cond ((##flonum.nan? x)
x)
((##flonum.negative? x)
;; we do this because (##flonum.<-exact-int y) is always
;; even for large enough y
(let ((abs-result
(##flonum.expt (##flonum.- x) (##flonum.<-exact-int y))))
(if (##odd? y)
(##flonum.- abs-result)
abs-result)))
(else
(##flonum.expt x (##flonum.<-exact-int y))))
(if (##exact? x)
(exact-int-expt x y)
(complex-expt x y)))
(macro-number-dispatch x (##fail-check-number 1 expt x y) ;; y a ratnum
(ratnum-expt x y)
(ratnum-expt x y)
(ratnum-expt x y)
(cond ((##flonum.nan? x)
x)
((##flonum.negative? x)
(if (##eq? 2 (macro-ratnum-denominator y))
(let ((magnitude (##flonum.expt (##flonum.- x) (##flonum.<-ratnum y))))
(if (##eq? 1 (##modulo (macro-ratnum-numerator y) 4))
;; multiple of i
(macro-cpxnum-make 0 magnitude)
;; multiple of -i
(macro-cpxnum-make 0 (##flonum.- magnitude))))
(complex-expt x y)))
(else
(##flonum.expt x (##flonum.<-ratnum y))))
(complex-expt x y))
(macro-number-dispatch x (##fail-check-number 1 expt x y) ;; y a flonum
(cond ((##flonum.nan? y)
y)
((##eq? x 0)
(if (##flonum.negative? y)
(##raise-range-exception 1 expt x y)
0))
((or (##fixnum.positive? x)
(macro-flonum-int? y))
(##flonum.expt (##flonum.<-fixnum x) y))
(else
(complex-expt x y)))
(cond ((##flonum.nan? y)
y)
((or (##positive? x)
(macro-flonum-int? y))
(##flonum.expt (##flonum.<-exact-int x) y))
(else
(complex-expt x y)))
(cond ((##flonum.nan? y)
y)
((or (##positive? x)
(macro-flonum-int? y))
(##flonum.expt (##flonum.<-ratnum x) y))
(else
(complex-expt x y)))
(cond ((##flonum.nan? x)
x)
((##flonum.nan? y)
y)
((or (##flonum.positive? x)
(macro-flonum-int? y))
(##flonum.expt x y))
(else
(complex-expt x y)))
(cond ((##flonum.nan? y)
y)
(else
(complex-expt x y))))
(macro-number-dispatch x (##fail-check-number 1 expt x y) ;; y a cpxnum
(if (##eq? x 0)
(let ((real (##real-part y)))
(if (##positive? real)
0
;; If we call (complex-expt 0 y),
;; we'll try to take (##log 0) in complex-expt,
;; so we raise the exception here.
(##raise-range-exception 1 expt x y)))
(complex-expt x y))
(complex-expt x y)
(complex-expt x y)
(complex-expt x y)
(complex-expt x y))))
(define-prim (expt x y)
(macro-force-vars (x y)
(##expt x y)))
(define-prim (##make-rectangular x y)
(cond ((##not (##real? x))
(##fail-check-real 1 make-rectangular x y))
((##not (##real? y))
(##fail-check-real 2 make-rectangular x y))
(else
(let ((real (##real-part x))
(imag (##real-part y)))
(if (##eq? imag 0)
real
(macro-cpxnum-make real imag))))))
(define-prim (make-rectangular x y)
(macro-force-vars (x y)
(##make-rectangular x y)))
(define-prim (##make-polar x y)
(cond ((##not (##real? x))
(##fail-check-real 1 make-polar x y))
((##not (##real? y))
(##fail-check-real 2 make-polar x y))
(else
(let ((real-x (##real-part x))
(real-y (##real-part y)))
(##make-rectangular (##* real-x (##cos real-y))
(##* real-x (##sin real-y)))))))
(define-prim (make-polar x y)
(macro-force-vars (x y)
(##make-polar x y)))
(define-prim (##real-part x)
(define (type-error)
(##fail-check-number 1 real-part x))
(macro-number-dispatch x (type-error)
x x x x (macro-cpxnum-real x)))
(define-prim (real-part x)
(macro-force-vars (x)
(##real-part x)))
(define-prim (##imag-part x)
(define (type-error)
(##fail-check-number 1 imag-part x))
(macro-number-dispatch x (type-error)
0 0 0 0 (macro-cpxnum-imag x)))
(define-prim (imag-part x)
(macro-force-vars (x)
(##imag-part x)))
(define-prim (##magnitude x)
(define (type-error)
(##fail-check-number 1 magnitude x))
(macro-number-dispatch x (type-error)
(if (##fixnum.negative? x) (##negate x) x)
(if (##bignum.negative? x) (##negate x) x)
(macro-ratnum-make (##abs (macro-ratnum-numerator x))
(macro-ratnum-denominator x))
(##flonum.abs x)
(let ((abs-r (##abs (##real-part x)))
(abs-i (##abs (##imag-part x))))
(define (complex-magn a b)
(cond ((##eq? a 0)
b)
((and (##flonum? a) (##flonum.zero? a))
(##exact->inexact b))
(else
(let ((c (##/ a b)))
(##* b (##sqrt (##+ (##* c c) 1)))))))
(cond ((or (and (##flonum? abs-r)
(##flonum.= abs-r (macro-inexact-+inf)))
(and (##flonum? abs-i)
(##flonum.= abs-i (macro-inexact-+inf))))
(macro-inexact-+inf))
((and (##flonum? abs-r) (##flonum.nan? abs-r))
abs-r)
((and (##flonum? abs-i) (##flonum.nan? abs-i))
abs-i)
(else
(if (##< abs-r abs-i)
(complex-magn abs-r abs-i)
(complex-magn abs-i abs-r)))))))
(define-prim (magnitude x)
(macro-force-vars (x)
(##magnitude x)))
(define-prim (##angle x)
(define (type-error)
(##fail-check-number 1 angle x))
(macro-number-dispatch x (type-error)
(if (##fixnum.negative? x)
(macro-inexact-+pi)
0)
(if (##bignum.negative? x)
(macro-inexact-+pi)
0)
(if (##negative? (macro-ratnum-numerator x))
(macro-inexact-+pi)
0)
(if (##flonum.negative? (##flonum.copysign (macro-inexact-+1) x))
(macro-inexact-+pi)
(macro-inexact-+0))
(##atan2 (macro-cpxnum-imag x) (macro-cpxnum-real x))))
(define-prim (angle x)
(macro-force-vars (x)
(##angle x)))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;; exact->inexact, inexact->exact
(define-prim (##exact->inexact x)
(define (type-error)
(##fail-check-number 1 exact->inexact x))
(macro-number-dispatch x (type-error)
(##flonum.<-fixnum x)
(##flonum.<-exact-int x)
(##flonum.<-ratnum x)
x
(##make-rectangular (##exact->inexact (macro-cpxnum-real x))
(##exact->inexact (macro-cpxnum-imag x)))))
(define-prim (exact->inexact x)
(macro-force-vars (x)
(##exact->inexact x)))
(define-prim (##inexact->exact x)
(define (type-error)
(##fail-check-number 1 inexact->exact x))
(define (range-error)
(##raise-range-exception 1 inexact->exact x))
(macro-number-dispatch x (type-error)
x
x
x
(if (macro-flonum-rational? x)
(##flonum.inexact->exact x)
(range-error))
(let ((real (macro-cpxnum-real x))
(imag (macro-cpxnum-imag x)))
(if (and (macro-noncpxnum-rational? real)
(macro-noncpxnum-rational? imag))
(##make-rectangular (##inexact->exact real)
(##inexact->exact imag))
(range-error)))))
(define-prim (inexact->exact x)
(macro-force-vars (x)
(##inexact->exact x)))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;; number->string, string->number
(define-prim (##exact-int.number->string x rad force-sign?)
(##define-macro (macro-make-block-size)
(let* ((max-rad 16)
(t (make-vector (+ max-rad 1) 0)))
(define max-fixnum 536870911) ;; OK to be conservative
(define (block-size-for rad)
(let loop ((i 0) (rad^i 1))
(let ((new-rad^i (* rad^i rad)))
(if (<= new-rad^i max-fixnum)
(loop (+ i 1) new-rad^i)
i))))
(let loop ((i max-rad))
(if (< 1 i)
(begin
(vector-set! t i (block-size-for i))
(loop (- i 1)))))
`',t))
(define block-size (macro-make-block-size))
(##define-macro (macro-make-rad^block-size)
(let* ((max-rad 16)
(t (make-vector (+ max-rad 1) 0)))
(define max-fixnum 536870911) ;; OK to be conservative
(define (rad^block-size-for rad)
(let loop ((i 0) (rad^i 1))
(let ((new-rad^i (* rad^i rad)))
(if (<= new-rad^i max-fixnum)
(loop (+ i 1) new-rad^i)
rad^i))))
(let loop ((i max-rad))
(if (< 1 i)
(begin
(vector-set! t i (rad^block-size-for i))
(loop (- i 1)))))
`',t))
(define rad^block-size (macro-make-rad^block-size))
(define (make-string-from-last-fixnum rad x len pos)
(let loop ((x x) (len len) (pos pos))
(if (##fixnum.= x 0)
(##make-string len)
(let* ((new-pos
(##fixnum.+ pos 1))
(s
(loop (##fixnum.quotient x rad)
(##fixnum.+ len 1)
new-pos)))
(##string-set!
s
(##fixnum.- (##string-length s) new-pos)
(##string-ref ##digit-to-char-table
(##fixnum.- (##fixnum.remainder x rad))))
s))))
(define (convert-non-last-fixnum s rad x pos)
(let loop ((x x)
(size (##vector-ref block-size rad))
(i (##fixnum.- (##string-length s) pos)))
(if (##fixnum.< 0 size)
(let ((new-i (##fixnum.- i 1)))
(##string-set!
s
new-i
(##string-ref ##digit-to-char-table
(##fixnum.remainder x rad)))
(loop (##fixnum.quotient x rad)
(##fixnum.- size 1)
new-i)))))
(define (make-string-from-fixnums rad lst len pos)
(let loop ((lst lst) (pos pos))
(let ((new-lst (##cdr lst)))
(if (##null? new-lst)
(make-string-from-last-fixnum
rad
(##fixnum.- (##car lst))
(##fixnum.+ len pos)
pos)
(let* ((size
(##vector-ref block-size rad))
(new-pos
(##fixnum.+ pos size))
(s
(loop new-lst new-pos)))
(convert-non-last-fixnum s rad (##car lst) pos)
s)))))
(define (uinteger->fixnums level sqs x lst)
(cond ((and (##null? lst) (##eq? x 0))
lst)
((##fixnum.= level 0)
(##cons x lst))
(else
(let* ((qr (##exact-int.div x (##car sqs)))
(new-level (##fixnum.- level 1))
(new-sqs (##cdr sqs))
(q (##car qr))
(r (##cdr qr)))
(uinteger->fixnums
new-level
new-sqs
r
(uinteger->fixnums new-level new-sqs q lst))))))
(define (uinteger->string x rad len)
(make-string-from-fixnums
rad
(let ((rad^size
(##vector-ref rad^block-size rad))
(x-length
(##integer-length x)))
(let loop ((level 0)
(sqs '())
(rad^size^2^level rad^size))
(let ((new-level
(##fixnum.+ level 1))
(new-sqs
(##cons rad^size^2^level sqs)))
(if (##fixnum.< x-length
(##fixnum.-
(##fixnum.* (##integer-length rad^size^2^level) 2)
1))
(uinteger->fixnums new-level new-sqs x '())
(let ((new-rad^size^2^level
(##exact-int.square rad^size^2^level)))
(if (##< x new-rad^size^2^level)
(uinteger->fixnums new-level new-sqs x '())
(loop new-level
new-sqs
new-rad^size^2^level)))))))
len
0))
(if (##fixnum? x)
(cond ((##fixnum.negative? x)
(let ((s (make-string-from-last-fixnum rad x 1 0)))
(##string-set! s 0 #\-)
s))
((##fixnum.zero? x)
(if force-sign?
(##string #\+ #\0)
(##string #\0)))
(else
(if force-sign?
(let ((s (make-string-from-last-fixnum rad (##fixnum.- x) 1 0)))
(##string-set! s 0 #\+)
s)
(make-string-from-last-fixnum rad (##fixnum.- x) 0 0))))
(cond ((##bignum.negative? x)
(let ((s (uinteger->string (##negate x) rad 1)))
(##string-set! s 0 #\-)
s))
(else
(if force-sign?
(let ((s (uinteger->string x rad 1)))
(##string-set! s 0 #\+)
s)
(uinteger->string x rad 0))))))
(define ##digit-to-char-table "0123456789abcdefghijklmnopqrstuvwxyz")
(define-prim (##ratnum.number->string x rad force-sign?)
(##string-append
(##exact-int.number->string (macro-ratnum-numerator x) rad force-sign?)
"/"
(##exact-int.number->string (macro-ratnum-denominator x) rad #f)))
(##define-macro (macro-r6rs-fp-syntax) #t)
(##define-macro (macro-chez-fp-syntax) #f)
(##define-macro (macro-make-10^constants)
(define n 326)
(let ((v (make-vector n)))
(let loop ((i 0) (x 1))
(if (< i n)
(begin
(vector-set! v i x)
(loop (+ i 1) (* x 10)))))
`',v))
(define ##10^-constants
(if (use-fast-bignum-algorithms)
(macro-make-10^constants)
#f))
(define-prim (##flonum.printout v sign-prefix)
;; This algorithm is derived from the paper "Printing Floating-Point
;; Numbers Quickly and Accurately" by Robert G. Burger and R. Kent Dybvig,
;; SIGPLAN'96 Conference on Programming Language Design an Implementation.
;; v is a flonum
;; f is an exact integer (fixnum or bignum)
;; e is an exact integer (fixnum only)
(define (10^ n) ;; 0 <= n < 326
(if (use-fast-bignum-algorithms)
(##vector-ref ##10^-constants n)
(##expt 10 n)))
(define (base-10-log x)
(##define-macro (1/log10) `',(/ (log 10)))
(##flonum.* (##flonum.log x) (1/log10)))
(##define-macro (epsilon)
1e-10)
(define (scale r s m+ m- round? v)
;; r is an exact integer (fixnum or bignum)
;; s is an exact integer (fixnum or bignum)
;; m+ is an exact integer (fixnum or bignum)
;; m- is an exact integer (fixnum or bignum)
;; round? is a boolean
;; v is a flonum
(let ((est
(##flonum->fixnum
(##flonum.ceiling (##flonum.- (base-10-log v) (epsilon))))))
(if (##fixnum.negative? est)
(let ((factor (10^ (##fixnum.- est))))
(fixup (##* r factor)
s
(##* m+ factor)
(##* m- factor)
est
round?))
(let ((factor (10^ est)))
(fixup r
(##* s factor)
m+
m-
est
round?)))))
(define (fixup r s m+ m- k round?)
(if (if round?
(##not (##< (##+ r m+) s))
(##< s (##+ r m+)))
(##cons (##fixnum.+ k 1)
(generate r
s
m+
m-
round?
0))
(##cons k
(generate (##* r 10)
s
(##* m+ 10)
(##* m- 10)
round?
0))))
(define (generate r s m+ m- round? n)
(let* ((dr (##exact-int.div r s))
(d (##car dr))
(r (##cdr dr))
(tc (if round?
(##not (##< (##+ r m+) s))
(##< s (##+ r m+)))))
(if (if round? (##not (##< m- r)) (##< r m-))
(let* ((last-digit
(if tc
(let ((r*2 (##arithmetic-shift r 1)))
(if (or (and (##fixnum.even? d)
(##= r*2 s)) ;; tie, round d to even
(##< r*2 s))
d
(##fixnum.+ d 1)))
d))
(str
(##make-string (##fixnum.+ n 1))))
(##string-set!
str
n
(##string-ref ##digit-to-char-table last-digit))
str)
(if tc
(let ((str
(##make-string (##fixnum.+ n 1))))
(##string-set!
str
n
(##string-ref ##digit-to-char-table (##fixnum.+ d 1)))
str)
(let ((str
(generate (##* r 10)
s
(##* m+ 10)
(##* m- 10)
round?
(##fixnum.+ n 1))))
(##string-set!
str
n
(##string-ref ##digit-to-char-table d))
str)))))
(define (flonum->exponent-and-digits v)
(let* ((x (##flonum.->exact-exponential-format v))
(f (##vector-ref x 0))
(e (##vector-ref x 1))
(round? (##not (##odd? f))))
(if (##fixnum.negative? e)
(if (and (##not (##fixnum.= e (macro-flonum-e-min)))
(##= f (macro-flonum-+m-min)))
(scale (##arithmetic-shift f 2)
(##arithmetic-shift 1 (##fixnum.- 2 e))
2
1
round?
v)
(scale (##arithmetic-shift f 1)
(##arithmetic-shift 1 (##fixnum.- 1 e))
1
1
round?
v))
(let ((2^e (##arithmetic-shift 1 e)))
(if (##= f (macro-flonum-+m-min))
(scale (##arithmetic-shift f (##fixnum.+ e 2))
4
(##arithmetic-shift 1 (##fixnum.+ e 1))
2^e
round?
v)
(scale (##arithmetic-shift f (##fixnum.+ e 1))
2
2^e
2^e
round?
v))))))
(let* ((x (flonum->exponent-and-digits v))
(e (##car x))
(d (##cdr x)) ;; d = digits
(n (##string-length d))) ;; n = number of digits
(cond ((and (##not (##fixnum.< e 0)) ;; 0<=e<=10
(##not (##fixnum.< 10 e)))
(cond ((##fixnum.= e 0) ;; e=0
;; Format 1: .DDD (0.DDD in chez-fp-syntax)
(##string-append sign-prefix
(if (macro-chez-fp-syntax) "0." ".")
d))
((##fixnum.< e n) ;; e<n
;; Format 2: D.DDD up to DDD.D
(##string-append sign-prefix
(##substring d 0 e)
"."
(##substring d e n)))
((##fixnum.= e n) ;; e=n
;; Format 3: DDD. (DDD.0 in chez-fp-syntax)
(##string-append sign-prefix
d
(if (macro-chez-fp-syntax) ".0" ".")))
(else ;; e>n
;; Format 4: DDD000000. (DDD000000.0 in chez-fp-syntax)
(##string-append sign-prefix
d
(##make-string (##fixnum.- e n) #\0)
(if (macro-chez-fp-syntax) ".0" ".")))))
((and (##not (##fixnum.< e -2)) ;; -2<=e<=-1
(##not (##fixnum.< -1 e)))
;; Format 5: .0DDD or .00DDD (0.0DDD or 0.00DDD in chez-fp-syntax)
(##string-append sign-prefix
(if (macro-chez-fp-syntax) "0." ".")
(##make-string (##fixnum.- e) #\0)
d))
(else
;; Format 6: D.DDDeEEE
;;
;; This is the most general format. We insert a period after
;; the first digit (unless there is only one digit) and add
;; an exponent.
(##string-append sign-prefix
(##substring d 0 1)
(if (##fixnum.= n 1) "" ".")
(##substring d 1 n)
"e"
(##number->string (##fixnum.- e 1) 10))))))
(define-prim (##flonum.number->string x rad force-sign?)
(define (non-neg-num->str x rad sign-prefix)
(if (##flonum.zero? x)
(##string-append sign-prefix (if (macro-chez-fp-syntax) "0.0" "0."))
(##flonum.printout x sign-prefix)))
(cond ((##flonum.nan? x)
(##string-copy (if (or (macro-r6rs-fp-syntax)
(macro-chez-fp-syntax))
"+nan.0"
"+nan.")))
((##flonum.negative? (##flonum.copysign (macro-inexact-+1) x))
(let ((abs-x (##flonum.copysign x (macro-inexact-+1))))
(cond ((##flonum.= abs-x (macro-inexact-+inf))
(##string-copy (if (or (macro-r6rs-fp-syntax)
(macro-chez-fp-syntax))
"-inf.0"
"-inf.")))
(else
(non-neg-num->str abs-x rad "-")))))
(else
(cond ((##flonum.= x (macro-inexact-+inf))
(##string-copy (if (or (macro-r6rs-fp-syntax)
(macro-chez-fp-syntax))
"+inf.0"
"+inf.")))
(force-sign?
(non-neg-num->str x rad "+"))
(else
(non-neg-num->str x rad ""))))))
(define-prim (##cpxnum.number->string x rad force-sign?)
(let* ((real
(macro-cpxnum-real x))
(real-str
(if (##eq? real 0) "" (##number->string real rad force-sign?))))
(let ((imag (macro-cpxnum-imag x)))
(cond ((##eq? imag 1)
(##string-append real-str "+i"))
((##eq? imag -1)
(##string-append real-str "-i"))
(else
(##string-append real-str
(##number->string imag rad #t)
"i"))))))
(define-prim (##number->string x #!optional (rad 10) (force-sign? #f))
(macro-number-dispatch x '()
(##exact-int.number->string x rad force-sign?)
(##exact-int.number->string x rad force-sign?)
(##ratnum.number->string x rad force-sign?)
(##flonum.number->string x rad force-sign?)
(##cpxnum.number->string x rad force-sign?)))
(define-prim (number->string n #!optional (r (macro-absent-obj)))
(macro-force-vars (n r)
(let ((rad (if (##eq? r (macro-absent-obj)) 10 r)))
(if (macro-exact-int? rad)
(if (or (##eq? rad 2)
(##eq? rad 8)
(##eq? rad 10)
(##eq? rad 16))
(let ((result (##number->string n rad #f)))
(if (##null? result)
(##fail-check-number 1 number->string n r)
result))
(##raise-range-exception 2 number->string n r))
(##fail-check-exact-integer 2 number->string n r)))))
(##define-macro (macro-make-char-to-digit-table)
(let ((t (make-vector 128 99)))
(vector-set! t (char->integer #\#) 0) ;; #\# counts as 0
(let loop1 ((i 9))
(if (not (< i 0))
(begin
(vector-set! t (+ (char->integer #\0) i) i)
(loop1 (- i 1)))))
(let loop2 ((i 25))
(if (not (< i 0))
(begin
(vector-set! t (+ (char->integer #\A) i) (+ i 10))
(vector-set! t (+ (char->integer #\a) i) (+ i 10))
(loop2 (- i 1)))))
`',(list->u8vector (vector->list t))))
(define ##char-to-digit-table (macro-make-char-to-digit-table))
(define-prim (##string->number str #!optional (rad 10) (check-only? #f))
;; The number grammar parsed by this procedure is:
;;
;; <num R E> : <prefix R E> <complex R E>
;;
;; <complex R E> : <real R E>
;; | <real R E> @ <real R E>
;; | <real R E> <sign> <ureal R> i
;; | <real R E> <sign-inf-nan R E> i
;; | <real R E> <sign> i
;; | <sign> <ureal R> i
;; | <sign-inf-nan R E> i
;; | <sign> i
;;
;; <real R E> : <ureal R>
;; | <sign> <ureal R>
;; | <sign-inf-nan R E>
;;
;; <sign-inf-nan R i> : +inf.0
;; | -inf.0
;; | +nan.0
;; <sign-inf-nan R empty> : <sign-inf-nan R i>
;;
;; <ureal R> : <uinteger R>
;; | <uinteger R> / <uinteger R>
;; | <decimal R>
;;
;; <decimal 10> : <uinteger 10> <suffix>
;; | . <digit 10>+ #* <suffix>
;; | <digit 10>+ . <digit 10>* #* <suffix>
;; | <digit 10>+ #+ . #* <suffix>
;;
;; <uinteger R> : <digit R>+ #*
;;
;; <prefix R E> : <radix R E> <exactness E>
;; | <exactness E> <radix R E>
;;
;; <suffix> : <empty>
;; | <exponent marker> <digit 10>+
;; | <exponent marker> <sign> <digit 10>+
;;
;; <exponent marker> : e | s | f | d | l
;; <sign> : + | -
;; <exactness empty> : <empty>
;; <exactness i> : #i
;; <exactness e> : #e
;; <radix 2> : #b
;; <radix 8> : #o
;; <radix 10> : <empty> | #d
;; <radix 16> : #x
;; <digit 2> : 0 | 1
;; <digit 8> : 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7
;; <digit 10> : 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
;; <digit 16> : <digit 10> | a | b | c | d | e | f
(##define-macro (macro-make-exact-10^n-table)
(define max-exact-power-of-10 22) ;; (floor (inexact->exact (/ (log (expt 2 (macro-flonum-m-bits-plus-1))) (log 5))))
(let ((t (make-vector (+ max-exact-power-of-10 1))))
(let loop ((i max-exact-power-of-10))
(if (not (< i 0))
(begin
(vector-set! t i (exact->inexact (expt 10 i)))
(loop (- i 1)))))
`',(list->f64vector (vector->list t))))
(define exact-10^n-table (macro-make-exact-10^n-table))
(##define-macro (macro-make-block-size)
(let* ((max-rad 16)
(t (make-vector (+ max-rad 1) 0)))
(define max-fixnum 536870911) ;; OK to be conservative
(define (block-size-for rad)
(let loop ((i 0) (rad^i 1))
(let ((new-rad^i (* rad^i rad)))
(if (<= new-rad^i max-fixnum)
(loop (+ i 1) new-rad^i)
i))))
(let loop ((i max-rad))
(if (< 1 i)
(begin
(vector-set! t i (block-size-for i))
(loop (- i 1)))))
`',t))
(define block-size (macro-make-block-size))
(##define-macro (macro-make-rad^block-size)
(let* ((max-rad 16)
(t (make-vector (+ max-rad 1) 0)))
(define max-fixnum 536870911) ;; OK to be conservative
(define (rad^block-size-for rad)
(let loop ((i 0) (rad^i 1))
(let ((new-rad^i (* rad^i rad)))
(if (<= new-rad^i max-fixnum)
(loop (+ i 1) new-rad^i)
rad^i))))
(let loop ((i max-rad))
(if (< 1 i)
(begin
(vector-set! t i (rad^block-size-for i))
(loop (- i 1)))))
`',t))
(define rad^block-size (macro-make-rad^block-size))
(define (substring->uinteger-fixnum str rad i j)
;; Simple case: result is known to fit in a fixnum.
(let loop ((i i) (n 0))
(if (##fixnum.< i j)
(let ((c (##string-ref str i)))
(if (##char<? c 128)
(loop (##fixnum.+ i 1)
(##fixnum.+ (##fixnum.* n rad)
(##u8vector-ref ##char-to-digit-table c)))
(loop (##fixnum.+ i 1)
(##fixnum.* n rad))))
n)))
(define (substring->uinteger-aux sqs width str rad i j)
;; Divide-and-conquer algorithm (fast for large bignums if bignum
;; multiplication is fast).
(if (##null? sqs)
(substring->uinteger-fixnum str rad i j)
(let* ((new-sqs (##cdr sqs))
(new-width (##fixnum.quotient width 2))
(mid (##fixnum.- j new-width)))
(if (##fixnum.< i mid)
(let* ((a (substring->uinteger-aux new-sqs new-width str rad i mid))
(b (substring->uinteger-aux new-sqs new-width str rad mid j)))
(##+ (##* a (##car sqs)) b))
(substring->uinteger-aux new-sqs new-width str rad i j)))))
(define (squares rad n)
(let loop ((rad rad) (n n) (lst '()))
(if (##fixnum.= n 1)
(##cons rad lst)
(loop (##exact-int.square rad)
(##fixnum.- n 1)
(##cons rad lst)))))
(define (substring->uinteger str rad i j)
;; Converts a substring into an unsigned integer. Selects a fast
;; conversion algorithm when result fits in a fixnum.
(let ((len (##fixnum.- j i))
(size (##vector-ref block-size rad)))
(if (##fixnum.< size len)
(let ((levels
(##integer-length (##fixnum.quotient (##fixnum.- len 1) size))))
(substring->uinteger-aux
(squares (##vector-ref rad^block-size rad) levels)
(##fixnum.arithmetic-shift-left size levels)
str
rad
i
j))
(substring->uinteger-fixnum str rad i j))))
(define (float-substring->uinteger str i j)
;; Converts a substring containing the decimals of a floating-point
;; number into an unsigned integer (any period is simply skipped).
(let loop1 ((i i) (n 0))
(if (##not (##fixnum.< i j))
n
(let ((c (##string-ref str i)))
(if (##char=? c #\.)
(loop1 (##fixnum.+ i 1) n)
(let ((new-n
(##fixnum.+ (##fixnum.* n 10)
(if (##char<? c 128)
(##u8vector-ref ##char-to-digit-table c)
0))))
(if (##fixnum.< new-n (macro-max-fixnum32-div-10))
(loop1 (##fixnum.+ i 1) new-n)
(let loop2 ((i i) (n n))
(if (##not (##fixnum.< i j))
n
(let ((c (##string-ref str i)))
(if (##char=? c #\.)
(loop2 (##fixnum.+ i 1) n)
(let ((new-n
(##+
(##* n 10)
(if (##char<? c 128)
(##u8vector-ref ##char-to-digit-table c)
0))))
(loop2 (##fixnum.+ i 1) new-n)))))))))))))
(define (uinteger str rad i)
(and (##fixnum.< i (##string-length str))
(let ((c (##string-ref str i)))
(and (##char<? c 128)
(##not (##char=? c #\#))
(##fixnum.< (##u8vector-ref ##char-to-digit-table c) rad)
(digits-and-sharps str rad (##fixnum.+ i 1))))))
(define (digits-and-sharps str rad i)
(let loop ((i i))
(if (##fixnum.< i (##string-length str))
(let ((c (##string-ref str i)))
(if (##char<? c 128)
(if (##char=? c #\#)
(sharps str (##fixnum.+ i 1))
(if (##fixnum.< (##u8vector-ref ##char-to-digit-table c) rad)
(loop (##fixnum.+ i 1))
i))
i))
i)))
(define (sharps str i)
(let loop ((i i))
(if (##fixnum.< i (##string-length str))
(if (##char=? (##string-ref str i) #\#)
(loop (##fixnum.+ i 1))
i)
i)))
(define (suffix str i1)
(if (##fixnum.< (##fixnum.+ i1 1) (##string-length str))
(let ((c1 (##string-ref str i1)))
(if (or (##char=? c1 #\e) (##char=? c1 #\E)
(##char=? c1 #\s) (##char=? c1 #\S)
(##char=? c1 #\f) (##char=? c1 #\F)
(##char=? c1 #\d) (##char=? c1 #\D)
(##char=? c1 #\l) (##char=? c1 #\L))
(let ((c2 (##string-ref str (##fixnum.+ i1 1))))
(let ((i2
(if (or (##char=? c2 #\+) (##char=? c2 #\-))
(uinteger str 10 (##fixnum.+ i1 2))
(uinteger str 10 (##fixnum.+ i1 1)))))
(if (and i2
(##not (##char=? (##string-ref str (##fixnum.- i2 1))
#\#)))
i2
i1)))
i1))
i1))
(define (ureal str rad e i1)
(let ((i2 (uinteger str rad i1)))
(if i2
(if (##fixnum.< i2 (##string-length str))
(let ((c (##string-ref str i2)))
(cond ((##char=? c #\/)
(let ((i3 (uinteger str rad (##fixnum.+ i2 1))))
(and i3
(let ((inexact-num?
(or (##eq? e 'i)
(and (##not e)
(or (##char=? (##string-ref
str
(##fixnum.- i2 1))
#\#)
(##char=? (##string-ref
str
(##fixnum.- i3 1))
#\#))))))
(if (and (##not inexact-num?)
(##eq? (substring->uinteger
str
rad
(##fixnum.+ i2 1)
i3)
0))
#f
(##vector i3 i2))))))
((##fixnum.= rad 10)
(if (##char=? c #\.)
(let ((i3
(if (##char=? (##string-ref str (##fixnum.- i2 1))
#\#)
(sharps str (##fixnum.+ i2 1))
(digits-and-sharps str 10 (##fixnum.+ i2 1)))))
(and i3
(let ((i4 (suffix str i3)))
(##vector i4 i3 i2))))
(let ((i3 (suffix str i2)))
(if (##fixnum.= i2 i3)
i2
(##vector i3 i2 i2)))))
(else
i2)))
i2)
(and (##fixnum.= rad 10)
(##fixnum.< i1 (##string-length str))
(##char=? (##string-ref str i1) #\.)
(let ((i3 (uinteger str rad (##fixnum.+ i1 1))))
(and i3
(let ((i4 (suffix str i3)))
(##vector i4 i3 i1))))))))
(define (inf-nan str sign i e)
(and (##not (##eq? e 'e))
(if (##fixnum.< (##fixnum.+ i (if (or (macro-r6rs-fp-syntax)
(macro-chez-fp-syntax))
4
3))
(##string-length str))
(and (##char=? (##string-ref str (##fixnum.+ i 3)) #\.)
(if (or (macro-r6rs-fp-syntax)
(macro-chez-fp-syntax))
(##char=? (##string-ref str (##fixnum.+ i 4)) #\0)
#t)
(or (and (let ((c (##string-ref str i)))
(or (##char=? c #\i) (##char=? c #\I)))
(let ((c (##string-ref str (##fixnum.+ i 1))))
(or (##char=? c #\n) (##char=? c #\N)))
(let ((c (##string-ref str (##fixnum.+ i 2))))
(or (##char=? c #\f) (##char=? c #\F))))
(and (##not (##char=? sign #\-))
(let ((c (##string-ref str i)))
(or (##char=? c #\n) (##char=? c #\N)))
(let ((c (##string-ref str (##fixnum.+ i 1))))
(or (##char=? c #\a) (##char=? c #\A)))
(let ((c (##string-ref str (##fixnum.+ i 2))))
(or (##char=? c #\n) (##char=? c #\N)))))
(##vector (##fixnum.+ i (if (or (macro-r6rs-fp-syntax)
(macro-chez-fp-syntax))
5
4))))
#f)))
(define (make-rec x y)
(##make-rectangular x y))
(define (make-pol x y e)
(let ((n (##make-polar x y)))
(if (##eq? e 'e)
(##inexact->exact n)
n)))
(define (make-inexact-real sign uinteger exponent)
(let ((n
(if (and (##fixnum? uinteger)
(##flonum.<-fixnum-exact? uinteger)
(##fixnum? exponent)
(##fixnum.< (##fixnum.- exponent)
(##f64vector-length exact-10^n-table))
(##fixnum.< exponent
(##f64vector-length exact-10^n-table)))
(if (##fixnum.< exponent 0)
(##flonum./ (##flonum.<-fixnum uinteger)
(##f64vector-ref exact-10^n-table
(##fixnum.- exponent)))
(##flonum.* (##flonum.<-fixnum uinteger)
(##f64vector-ref exact-10^n-table
exponent)))
(##exact->inexact
(##* uinteger (##expt 10 exponent))))))
(if (##char=? sign #\-)
(##flonum.copysign n (macro-inexact--1))
n)))
(define (get-zero e)
(if (##eq? e 'i)
(macro-inexact-+0)
0))
(define (get-one sign e)
(if (##eq? e 'i)
(if (##char=? sign #\-) (macro-inexact--1) (macro-inexact-+1))
(if (##char=? sign #\-) -1 1)))
(define (get-real start sign str rad e i)
(if (##fixnum? i)
(let* ((abs-n
(substring->uinteger str rad start i))
(n
(if (##char=? sign #\-)
(##negate abs-n)
abs-n)))
(if (or (##eq? e 'i)
(and (##not e)
(##char=? (##string-ref str (##fixnum.- i 1)) #\#)))
(##exact->inexact n)
n))
(let ((j (##vector-ref i 0))
(len (##vector-length i)))
(cond ((##fixnum.= len 3) ;; xxx.yyyEzzz
(let* ((after-frac-part
(##vector-ref i 1))
(unadjusted-exponent
(if (##fixnum.= after-frac-part j) ;; no exponent part?
0
(let* ((c
(##string-ref
str
(##fixnum.+ after-frac-part 1)))
(n
(substring->uinteger
str
10
(if (or (##char=? c #\+) (##char=? c #\-))
(##fixnum.+ after-frac-part 2)
(##fixnum.+ after-frac-part 1))
j)))
(if (##char=? c #\-)
(##negate n)
n))))
(c
(##string-ref str start))
(uinteger
(float-substring->uinteger str start after-frac-part))
(decimals-after-point
(##fixnum.-
(##fixnum.- after-frac-part (##vector-ref i 2))
1))
(exponent
(if (##fixnum.< 0 decimals-after-point)
(if (and (##fixnum? unadjusted-exponent)
(##fixnum.< (##fixnum.- unadjusted-exponent
decimals-after-point)
unadjusted-exponent))
(##fixnum.- unadjusted-exponent
decimals-after-point)
(##- unadjusted-exponent
decimals-after-point))
unadjusted-exponent)))
(if (##eq? e 'e)
(##*
(if (##char=? sign #\-)
(##negate uinteger)
uinteger)
(##expt 10 exponent))
(make-inexact-real sign uinteger exponent))))
((##fixnum.= len 2) ;; xxx/yyy
(let* ((after-num
(##vector-ref i 1))
(inexact-num?
(or (##eq? e 'i)
(and (##not e)
(or (##char=? (##string-ref
str
(##fixnum.- after-num 1))
#\#)
(##char=? (##string-ref
str
(##fixnum.- j 1))
#\#)))))
(abs-num
(substring->uinteger str rad start after-num))
(den
(substring->uinteger str
rad
(##fixnum.+ after-num 1)
j)))
(define (num-div-den)
(##/ (if (##char=? sign #\-)
(##negate abs-num)
abs-num)
den))
(if inexact-num?
(if (##eq? den 0)
(let ((n
(if (##eq? abs-num 0)
(macro-inexact-+nan)
(macro-inexact-+inf))))
(if (##char=? sign #\-)
(##flonum.copysign n (macro-inexact--1))
n))
(##exact->inexact (num-div-den)))
(num-div-den))))
(else ;; (##fixnum.= len 1) ;; inf or nan
(let* ((c
(##string-ref str start))
(n
(if (or (##char=? c #\i) (##char=? c #\I))
(macro-inexact-+inf)
(macro-inexact-+nan))))
(if (##char=? sign #\-)
(##flonum.copysign n (macro-inexact--1))
n)))))))
(define (i-end str i)
(and (##fixnum.= (##fixnum.+ i 1) (##string-length str))
(let ((c (##string-ref str i)))
(or (##char=? c #\i) (##char=? c #\I)))))
(define (complex start sign str rad e i)
(let ((j (if (##fixnum? i) i (##vector-ref i 0))))
(let ((c (##string-ref str j)))
(cond ((##char=? c #\@)
(let ((j+1 (##fixnum.+ j 1)))
(if (##fixnum.< j+1 (##string-length str))
(let* ((sign2
(##string-ref str j+1))
(start2
(if (or (##char=? sign2 #\+) (##char=? sign2 #\-))
(##fixnum.+ j+1 1)
j+1))
(k
(or (ureal str rad e start2)
(and (##fixnum.< j+1 start2)
(inf-nan str sign2 start2 e)))))
(and k
(let ((l (if (##fixnum? k) k (##vector-ref k 0))))
(and (##fixnum.= l (##string-length str))
(or check-only?
(make-pol
(get-real start sign str rad e i)
(get-real start2 sign2 str rad e k)
e))))))
#f)))
((or (##char=? c #\+) (##char=? c #\-))
(let* ((start2
(##fixnum.+ j 1))
(k
(or (ureal str rad e start2)
(inf-nan str c start2 e))))
(if (##not k)
(if (i-end str start2)
(or check-only?
(make-rec
(get-real start sign str rad e i)
(get-one c e)))
#f)
(let ((l (if (##fixnum? k) k (##vector-ref k 0))))
(and (i-end str l)
(or check-only?
(make-rec
(get-real start sign str rad e i)
(get-real start2 c str rad e k))))))))
(else
#f)))))
(define (after-prefix start str rad e)
;; invariant: start = 0, 2 or 4, (string-length str) > start
(let ((c (##string-ref str start)))
(if (or (##char=? c #\+) (##char=? c #\-))
(let ((i (or (ureal str rad e (##fixnum.+ start 1))
(inf-nan str c (##fixnum.+ start 1) e))))
(if (##not i)
(if (i-end str (##fixnum.+ start 1))
(or check-only?
(make-rec
(get-zero e)
(get-one c e)))
#f)
(let ((j (if (##fixnum? i) i (##vector-ref i 0))))
(cond ((##fixnum.= j (##string-length str))
(or check-only?
(get-real (##fixnum.+ start 1) c str rad e i)))
((i-end str j)
(or check-only?
(make-rec
(get-zero e)
(get-real (##fixnum.+ start 1) c str rad e i))))
(else
(complex (##fixnum.+ start 1) c str rad e i))))))
(let ((i (ureal str rad e start)))
(if (##not i)
#f
(let ((j (if (##fixnum? i) i (##vector-ref i 0))))
(cond ((##fixnum.= j (##string-length str))
(or check-only?
(get-real start #\+ str rad e i)))
(else
(complex start #\+ str rad e i)))))))))
(define (radix-prefix c)
(cond ((or (##char=? c #\b) (##char=? c #\B)) 2)