;;;============================================================================

;;; File: "_num.scm"

;;; Copyright (c) 1994-2016 by Marc Feeley, All Rights Reserved.
;;; Copyright (c) 2004-2016 by Brad Lucier, All Rights Reserved.

;;;============================================================================

(macro-case-target
 ((C)
  (c-declare "#include \"mem.h\"")
  (##define-macro (use-fast-bignum-algorithms) #t))
 (else
  (##define-macro (use-fast-bignum-algorithms) #f)))

;;;============================================================================

;;; 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
      (##fx= x y)
      #f
      #f
      (if (##fixnum->flonum-exact? x)
          (##fl= (##fixnum->flonum x) y)
          (and (##flfinite? y)
               (##ratnum.= (##exact-int->ratnum x) (##flonum->ratnum y))))
      (##cpxnum.= (##noncpxnum->cpxnum x) y))

    (macro-number-dispatch y (type-error-on-y) ;; x = bignum
      #f
      (or (##eq? x y)
          (##exact-int.= x y))
      #f
      (and (##flfinite? y)
           (##ratnum.= (##exact-int->ratnum x) (##flonum->ratnum y)))
      (##cpxnum.= (##noncpxnum->cpxnum x) y))

    (macro-number-dispatch y (type-error-on-y) ;; x = ratnum
      #f
      #f
      (or (##eq? x y)
          (##ratnum.= x y))
      (and (##flfinite? y)
           (##ratnum.= x (##flonum->ratnum y)))
      (##cpxnum.= (##noncpxnum->cpxnum x) y))

    (macro-number-dispatch y (type-error-on-y) ;; x = flonum
      (if (##fixnum->flonum-exact? y)
          (##fl= x (##fixnum->flonum y))
          (and (##flfinite? x)
               (##ratnum.= (##flonum->ratnum x) (##exact-int->ratnum y))))
      (and (##flfinite? x)
           (##ratnum.= (##flonum->ratnum x) (##exact-int->ratnum y)))
      (and (##flfinite? x)
           (##ratnum.= (##flonum->ratnum x) y))
      (##fl= x y)
      (##cpxnum.= (##noncpxnum->cpxnum x) y))

    (macro-number-dispatch y (type-error-on-y) ;; x = cpxnum
      (##cpxnum.= x (##noncpxnum->cpxnum y))
      (##cpxnum.= x (##noncpxnum->cpxnum y))
      (##cpxnum.= x (##noncpxnum->cpxnum y))
      (##cpxnum.= x (##noncpxnum->cpxnum 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
      (##fx< x y)
      (##not (##bignum.negative? y))
      (##ratnum.< (##exact-int->ratnum x) y)
      (cond ((##flfinite? y)
             (if (##fixnum->flonum-exact? x)
                 (##fl< (##fixnum->flonum x) y)
                 (##ratnum.< (##exact-int->ratnum x) (##flonum->ratnum y))))
            ((##flnan? y)
             nan-result)
            (else
             (##flpositive? 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)
      (##exact-int.< x y)
      (##ratnum.< (##exact-int->ratnum x) y)
      (cond ((##flfinite? y)
             (##ratnum.< (##exact-int->ratnum x) (##flonum->ratnum y)))
            ((##flnan? y)
             nan-result)
            (else
             (##flpositive? 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 (##exact-int->ratnum y))
      (##ratnum.< x (##exact-int->ratnum y))
      (##ratnum.< x y)
      (cond ((##flfinite? y)
             (##ratnum.< x (##flonum->ratnum y)))
            ((##flnan? y)
             nan-result)
            (else
             (##flpositive? 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 ((##flfinite? x)
             (if (##fixnum->flonum-exact? y)
                 (##fl< x (##fixnum->flonum y))
                 (##ratnum.< (##flonum->ratnum x) (##exact-int->ratnum y))))
            ((##flnan? x)
             nan-result)
            (else
             (##flnegative? x)))
      (cond ((##flfinite? x)
             (##ratnum.< (##flonum->ratnum x) (##exact-int->ratnum y)))
            ((##flnan? x)
             nan-result)
            (else
             (##flnegative? x)))
      (cond ((##flfinite? x)
             (##ratnum.< (##flonum->ratnum x) y))
            ((##flnan? x)
             nan-result)
            (else
             (##flnegative? x)))
      (if (or (##flnan? x) (##flnan? y))
          nan-result
          (##fl< 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)
    (##fxzero? x)
    #f
    #f
    (##flzero? x)
    (and (let ((imag (macro-cpxnum-imag x)))
           (and (##flonum? imag) (##flzero? imag)))
         (let ((real (macro-cpxnum-real x)))
           (if (##fixnum? real)
               (##fxzero? real)
               (and (##flonum? real) (##flzero? 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)
    (##fxpositive? x)
    (##not (##bignum.negative? x))
    (##positive? (macro-ratnum-numerator x))
    (##flpositive? 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)
    (##fxnegative? x)
    (##bignum.negative? x)
    (##negative? (macro-ratnum-numerator x))
    (##flnegative? 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)
    (##fxodd? 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 (##fxodd? 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
      (##fxmax x y)
      (if (##< x y) y x)
      (if (##< x y) y x)
      (##flmax (##fixnum->flonum 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)
      (##flmax (##exact-int->flonum 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)
      (##flmax (##ratnum->flonum 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
      (##flmax x (##fixnum->flonum y))
      (##flmax x (##exact-int->flonum y))
      (##flmax x (##ratnum->flonum y))
      (##flmax 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
      (##fxmin x y)
      (if (##< x y) x y)
      (if (##< x y) x y)
      (##flmin (##fixnum->flonum 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)
      (##flmin (##exact-int->flonum 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)
      (##flmin (##ratnum->flonum 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
      (##flmin x (##fixnum->flonum y))
      (##flmin x (##exact-int->flonum y))
      (##flmin x (##ratnum->flonum y))
      (##flmin 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 (##fx+? x y)
          (##bignum.+ (##fixnum->bignum x) (##fixnum->bignum y)))
      (if (##fxzero? x)
          y
          (##bignum.+ (##fixnum->bignum x) y))
      (if (##fxzero? x)
          y
          (##ratnum.+ (##exact-int->ratnum x) y))
      (if (and (macro-special-case-exact-zero?) (##fxzero? x))
          y
          (##fl+ (##fixnum->flonum x) y))
      (if (and (macro-special-case-exact-zero?) (##fxzero? x))
          y
          (##cpxnum.+ (##noncpxnum->cpxnum x) y)))

    (macro-number-dispatch y (type-error-on-y) ;; x = bignum
      (if (##fxzero? y)
          x
          (##bignum.+ x (##fixnum->bignum y)))
      (##bignum.+ x y)
      (##ratnum.+ (##exact-int->ratnum x) y)
      (##fl+ (##exact-int->flonum x) y)
      (##cpxnum.+ (##noncpxnum->cpxnum x) y))

    (macro-number-dispatch y (type-error-on-y) ;; x = ratnum
      (if (##fxzero? y)
          x
          (##ratnum.+ x (##exact-int->ratnum y)))
      (##ratnum.+ x (##exact-int->ratnum y))
      (##ratnum.+ x y)
      (##fl+ (##ratnum->flonum x) y)
      (##cpxnum.+ (##noncpxnum->cpxnum x) y))

    (macro-number-dispatch y (type-error-on-y) ;; x = flonum
      (if (and (macro-special-case-exact-zero?) (##fxzero? y))
          x
          (##fl+ x (##fixnum->flonum y)))
      (##fl+ x (##exact-int->flonum y))
      (##fl+ x (##ratnum->flonum y))
      (##fl+ x y)
      (##cpxnum.+ (##noncpxnum->cpxnum x) y))

    (macro-number-dispatch y (type-error-on-y) ;; x = cpxnum
      (if (and (macro-special-case-exact-zero?) (##fxzero? y))
          x
          (##cpxnum.+ x (##noncpxnum->cpxnum y)))
      (##cpxnum.+ x (##noncpxnum->cpxnum y))
      (##cpxnum.+ x (##noncpxnum->cpxnum y))
      (##cpxnum.+ x (##noncpxnum->cpxnum 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 ((##fx= y 0)
             0)
            ((if (##fx= y -1)
                 (##fx-? x)
                 (##fx*? x y))
             => (lambda (result) result))
            (else
             (##bignum.* (##fixnum->bignum x) (##fixnum->bignum y))))
      (cond ((##fxzero? x)
             0)
            ((##fx= x 1)
             y)
            ((##fx= x -1)
             (##negate y))
            (else
             (##bignum.* (##fixnum->bignum x) y)))
      (cond ((##fxzero? x)
             0)
            ((##fx= x 1)
             y)
            ((##fx= x -1)
             (##negate y))
            (else
             (##ratnum.* (##exact-int->ratnum x) y)))
      (cond ((and (macro-special-case-exact-zero?)
                  (##fxzero? x))
             0)
            ((##fx= x 1)
             y)
            (else
             (##fl* (##fixnum->flonum x) y)))
      (cond ((and (macro-special-case-exact-zero?)
                  (##fxzero? x))
             0)
            ((##fx= x 1)
             y)
            (else
             (##cpxnum.* (##noncpxnum->cpxnum x) y))))

    (macro-number-dispatch y (type-error-on-y) ;; x = bignum
      (cond ((##fx= y 0)
             0)
            ((##fx= y 1)
             x)
            ((##fx= y -1)
             (##negate x))
            (else
             (##bignum.* x (##fixnum->bignum y))))
      (##bignum.* x y)
      (##ratnum.* (##exact-int->ratnum x) y)
      (##fl* (##exact-int->flonum x) y)
      (##cpxnum.* (##noncpxnum->cpxnum x) y))

    (macro-number-dispatch y (type-error-on-y) ;; x = ratnum
      (cond ((##fxzero? y)
             0)
            ((##fx= y 1)
             x)
            ((##fx= y -1)
             (##negate x))
            (else
             (##ratnum.* x (##exact-int->ratnum y))))
      (##ratnum.* x (##exact-int->ratnum y))
      (##ratnum.* x y)
      (##fl* (##ratnum->flonum x) y)
      (##cpxnum.* (##noncpxnum->cpxnum x) y))

    (macro-number-dispatch y (type-error-on-y) ;; x = flonum
      (cond ((and (macro-special-case-exact-zero?) (##fxzero? y))
             0)
            ((##fx= y 1)
             x)
            (else
             (##fl* x (##fixnum->flonum y))))
      (##fl* x (##exact-int->flonum y))
      (##fl* x (##ratnum->flonum y))
      (##fl* x y)
      (##cpxnum.* (##noncpxnum->cpxnum x) y))

    (macro-number-dispatch y (type-error-on-y) ;; x = cpxnum
      (cond ((and (macro-special-case-exact-zero?) (##fxzero? y))
             0)
            ((##fx= y 1)
             x)
            (else
             (##cpxnum.* x (##noncpxnum->cpxnum y))))
      (##cpxnum.* x (##noncpxnum->cpxnum y))
      (##cpxnum.* x (##noncpxnum->cpxnum y))
      (##cpxnum.* x (##noncpxnum->cpxnum 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 (##square x)

  (define (type-error)
    (##fail-check-number 1 square x))

  (macro-number-dispatch x (type-error)
    (or (##fxsquare? x)
        (let ((x (##fixnum->bignum x)))
          (##bignum.* x x)))
    (##bignum.* x x)
    (##ratnum.* x x)
    (##fl* x x)
    (let ((real (macro-cpxnum-real x))
          (imag (macro-cpxnum-imag x)))
      (if (or (##eqv? real 0)
              (##exact? x))
          (##make-rectangular (##* (##- real imag) (##+ real imag))
                              (##* 2 (##* real imag)))
          (##csquare (##exact->inexact x))))))

(define-prim (square x)
  (macro-force-vars (x)
    (##square x)))

(define-prim (##negate x)

  (##define-macro (type-error) `'(1))

  (macro-number-dispatch x (type-error)
    (or (##fx-? x)
        (##bignum.- (##fixnum->bignum 0) (##fixnum->bignum ##min-fixnum)))
    (##bignum.- (##fixnum->bignum 0) x)
    (macro-ratnum-make (##negate (macro-ratnum-numerator x))
                       (macro-ratnum-denominator x))
    (##fl- 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 (##fx-? x y)
          (##bignum.- (##fixnum->bignum x) (##fixnum->bignum y)))
      (##bignum.- (##fixnum->bignum x) y)
      (if (##fxzero? x)
          (##negate y)
          (##ratnum.- (##exact-int->ratnum x) y))
      (if (and (macro-special-case-exact-zero?) (##fxzero? x))
          (##fl- y)
          (##fl- (##fixnum->flonum x) y))
      (##cpxnum.- (##noncpxnum->cpxnum x) y))

    (macro-number-dispatch y (type-error-on-y) ;; x = bignum
      (if (##fxzero? y)
          x
          (##bignum.- x (##fixnum->bignum y)))
      (##bignum.- x y)
      (##ratnum.- (##exact-int->ratnum x) y)
      (##fl- (##exact-int->flonum x) y)
      (##cpxnum.- (##noncpxnum->cpxnum x) y))

    (macro-number-dispatch y (type-error-on-y) ;; x = ratnum
      (if (##fxzero? y)
          x
          (##ratnum.- x (##exact-int->ratnum y)))
      (##ratnum.- x (##exact-int->ratnum y))
      (##ratnum.- x y)
      (##fl- (##ratnum->flonum x) y)
      (##cpxnum.- (##noncpxnum->cpxnum x) y))

    (macro-number-dispatch y (type-error-on-y) ;; x = flonum
      (if (and (macro-special-case-exact-zero?) (##fxzero? y))
          x
          (##fl- x (##fixnum->flonum y)))
      (##fl- x (##exact-int->flonum y))
      (##fl- x (##ratnum->flonum y))
      (##fl- x y)
      (##cpxnum.- (##noncpxnum->cpxnum x) y))

    (macro-number-dispatch y (type-error-on-y) ;; x = cpxnum
      (if (and (macro-special-case-exact-zero?) (##fxzero? y))
          x
          (##cpxnum.- x (##noncpxnum->cpxnum y)))
      (##cpxnum.- x (##noncpxnum->cpxnum y))
      (##cpxnum.- x (##noncpxnum->cpxnum y))
      (##cpxnum.- x (##noncpxnum->cpxnum 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 (##fxzero? x)
        (divide-by-zero-error)
        (if (##fxnegative? x)
            (if (##fx= x -1)
                x
                (macro-ratnum-make -1 (##negate x)))
            (if (##fx= 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 ((##fx= num 1)
             den)
            ((##fx= num -1)
             (##negate den))
            (else
             (if (##negative? num)
                 (macro-ratnum-make (##negate den) (##negate num))
                 (macro-ratnum-make den num)))))
    (##fl/ (macro-inexact-+1) x)
    (##cpxnum./ (##noncpxnum->cpxnum 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 ((##fxzero? y)
             (divide-by-zero-error))
            ((##fx= y 1)
             x)
            ((##fx= y -1)
             (##negate x))
            ((##fxzero? x)
             0)
            ((##fx= x 1)
             (##inverse y))
            (else
             (##ratnum./ (##exact-int->ratnum x) (##exact-int->ratnum y))))
      (cond ((##fxzero? y)
             (divide-by-zero-error))
            ((##fx= y 1)
             x)
            ((##fx= y -1)
             (##negate x))
            (else
             (##ratnum./ (##exact-int->ratnum x) (##exact-int->ratnum y))))
      (cond ((##fxzero? y)
             (divide-by-zero-error))
            ((##fx= y 1)
             x)
            ((##fx= y -1)
             (##negate x))
            (else
             (##ratnum./ x (##exact-int->ratnum y))))
      (cond ((##fxzero? y)
             (divide-by-zero-error))
            ((##fx= y 1)
             x)
            (else
             (##fl/ x (##fixnum->flonum y))))
      (cond ((##fxzero? y)
             (divide-by-zero-error))
            ((##fx= y 1)
             x)
            (else
             (##cpxnum./ x (##noncpxnum->cpxnum y)))))

    (macro-number-dispatch x (type-error-on-x) ;; y = bignum
      (cond ((##fxzero? x)
             0)
            ((##fx= x 1)
             (##inverse y))
            (else
             (##ratnum./ (##exact-int->ratnum x) (##exact-int->ratnum y))))
      (##ratnum./ (##exact-int->ratnum x) (##exact-int->ratnum y))
      (##ratnum./ x (##exact-int->ratnum y))
      (##fl/ x (##exact-int->flonum y))
      (##cpxnum./ x (##noncpxnum->cpxnum y)))

    (macro-number-dispatch x (type-error-on-x) ;; y = ratnum
      (cond ((##fxzero? x)
             0)
            ((##fx= x 1)
             (##inverse y))
            (else
             (##ratnum./ (##exact-int->ratnum x) y)))
      (##ratnum./ (##exact-int->ratnum x) y)
      (##ratnum./ x y)
      (##fl/ x (##ratnum->flonum y))
      (##cpxnum./ x (##noncpxnum->cpxnum y)))

    (macro-number-dispatch x (type-error-on-x) ;; y = flonum, no error possible
      (##fl/ (##fixnum->flonum x) y)
      (##fl/ (##exact-int->flonum x) y)
      (##fl/ (##ratnum->flonum x) y)
      (##fl/ x y)
      (##cpxnum./ x (##noncpxnum->cpxnum y)))

    (macro-number-dispatch x (type-error-on-x) ;; y = cpxnum
      (##cpxnum./ (##noncpxnum->cpxnum x) y)
      (##cpxnum./ (##noncpxnum->cpxnum x) y)
      (##cpxnum./ (##noncpxnum->cpxnum x) y)
      (##cpxnum./ (##noncpxnum->cpxnum 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 (##exact-int.negative? x)
  (if (##fixnum? x)
      (##fxnegative? x)
      (##bignum.negative? x)))

(define-prim (##abs x)

  (define (type-error)
    (##fail-check-real 1 abs x))

  (macro-number-dispatch x (type-error)
    (if (##fxnegative? x) (##negate x) x)
    (if (##bignum.negative? x) (##negate x) x)
    (if (##exact-int.negative? (macro-ratnum-numerator x))
        (macro-ratnum-make (##negate (macro-ratnum-numerator x))
                           (macro-ratnum-denominator x))
        x)
    (##flabs 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 (##eqv? 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 ((##fx= y 0)
             (divide-by-zero-error))
            ((##fx= y -1) ;; (quotient ##min-fixnum -1) is a bignum
             (##negate x))
            (else
             (##fxquotient x y)))
      (cond ((##fx= 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 
                            #f   ;; need-quotient?
                            #t   ;; keep-dividend?
                            )))

  (define (inexact-remainder x y)
    (let ((exact-y (##inexact->exact y)))
      (if (##eqv? 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 ((##fx= y 0)
             (divide-by-zero-error))
            (else
             (##fxremainder x y)))
      (cond ((##fx= 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
                                     #f      ;; need-quotient?
                                     #t      ;; keep-dividend?
                                     ))))
      (if (##eqv? r 0)
          0
          (if (##eq? (##negative? x) (##negative? y))
              r
              (##+ r y)))))

  (define (inexact-modulo x y)
    (let ((exact-y (##inexact->exact y)))
      (if (##eqv? 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 ((##fx= y 0)
             (divide-by-zero-error))
            (else
             (##fxmodulo x y)))
      (cond ((##fx= 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)
      (##fx< n (##integer-length x)))

    (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) (##fixnum->bignum u) u))
            (v (if (##fixnum? v) (##fixnum->bignum v) v)))
        (let ((u-length (##bignum.mdigit-length u)))
          (and (##fx= u-length (##bignum.mdigit-length v))
               (let loop ((i (##fx- u-length 1)))
                 (let ((v-digit (##bignum.mdigit-ref v i))
                       (u-digit (##bignum.mdigit-ref u i)))
                   (if (and (##fxzero? u-digit)
                            (##fxzero? v-digit))
                       (loop (##fx- i 1))
                       (and (##fx= (##fxquotient s ##bignum.mdigit-width)
                                   i)
                            (##fx< (##fxmax (##fx- u-digit v-digit)
                                            (##fx- v-digit u-digit))
                                   (##fxarithmetic-shift-left
                                    1
                                    (##fxremainder 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))
                         ((##eqv? 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))
                         ((##eqv? 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 (##fxarithmetic-shift-left 1 s)))
            (if (##fx< u v)
                (if (##fx< (##fx- v u) two^s)
                    (cont M
                          u
                          v
                          #t)
                    (let ((r (##fxremainder v u))
                          (q (##fxquotient  v u)))
                      (if (##fx>= 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 (##fx- q 1))
                                u
                                (##fx+ r u)
                                #t))))
                ;; here u >= v, but the case u = v is covered by the first test
                (if (##fx< (##fx- u v) two^s)
                    (cont M
                          u
                          v
                          #t)
                    (let ((r (##fxremainder u v))
                          (q (##fxquotient  u v)))
                      (if (##fx>= 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 (##fx- q 1))
                                (##fx+ 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 (##fx> (##fx- 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 (##fx+ m 2))
                  (x>=2^n b (##fx+ m 2)))
             (let ((n (##fx- (##fxmax (##integer-length a)
                                      (##integer-length b))
                             m)))
               ((lambda (cont)
                  (if (##fx<= m n)
                      (cont m 0)
                      (cont n (##fx- (##fx+ m 1) n))))
                (lambda (m-prime p)
                  (let ((h (##fx+ m-prime (##fxquotient n 2))))
                    (if (##fx< 0 p)
                        (let ((a   (##arithmetic-shift a (##fx- p)))
                              (b   (##arithmetic-shift b (##fx- 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)
    (if (##eqv? b 0)
        a
        (let ((rem (cdr (##exact-int.div a b   ;; calculate (remainder a b)
                                         #f    ;; need-quotient?
                                         #f    ;; keep-dividend?
                                         ))))
          (if (##fixnum? b)
              (fixnum-base b rem)
              (general-base b rem)))))

  (define (fixnum-base a b)
    (##declare (not interrupts-enabled))
    (if (##eqv? b 0)
        a
        (let ((a b)
              (b (##fxremainder a b)))
          (if (##eqv? b 0)
              a
              (fixnum-base b (##fxremainder a b))))))

  (define (exact-gcd x y)
    ;; always returns an exact result, even with inexact arguments.
    (let ((x (cond ((##inexact? x)
                    (##inexact->exact (##flabs x)))
                   ((##negative? x)
                    (##negate x))
                   ((##bignum? x)
                    (##bignum.copy x))
                   (else ;; nonnegative fixnum
                    x)))
          (y (cond ((##inexact? y)
                    (##inexact->exact (##flabs y)))
                   ((##negative? y)
                    (##negate y))
                   ((##bignum? y)
                    (##bignum.copy y))
                   (else ;; nonnegative fixnum
                    y))))
      ;; now x and y are newly allocated, so we can overwrite them if
      ;; necessary in general-base
      (cond ((##eqv? x 0)
             y)
            ((##eqv? y 0)
             x)
            ((and (##fixnum? x) (##fixnum? y))
             (fixnum-base x y))
            (else
             (##fast-gcd x 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)
             (##exact->inexact (exact-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 (##eqv? x 0) (##eqv? 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 ((##flzero? x)
           x)
          ((macro-flonum-rational? x)
           (##exact->inexact (##numerator (##flonum->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->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 (##flfinite? x)
        (##flfloor 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 (##flfinite? x)
        (##flceiling 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 (##flfinite? x)
        (##fltruncate 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 (##flfinite? x)
        (##flround 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)
              (##fl= 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

#|

The next functions are from

 Functions from
 Branch Cuts for Complex Elementary Functions
 or
 Much Ado About Nothing's Sign Bit
 by W. Kahan

 Full reference:

 Kahan, W: Branch cuts for complex elementary functions; or, Much ado about nothing’s sign bit. In Iserles, A., and Powell, M. (eds.), The state of the art in numerical analysis. Clarendon Press (1987) pp 165-211.

Note that Kahan's paper contains two treatments of branch cuts---Section 4, which deals with arithmetic with signed zeros (like IEEE arithmetic) and Section 5, which deals with arithmetic with only unsigned zeros.  The codes in the paper are only for IEEE-style arithmetic.

Gambit Scheme is in a funny position, as it allows mixed-exactness complex numbers.  We'll consider inexact real zeros (+0., -0.) as signed (of course), but we'll interpret exact zero (0) as unsigned.

The branch cuts of all the functions considered here lie on the exact real axis or the exact imaginary axis.

All of the inverse functions are defined in terms of log and sqrt, and the side of the continuity at the branch cuts is determined by the sides of continuity of those two functions.

I believe that this is the same as the continuity rules that the CLHS gives for atan, asin, acos, etc., along branch cuts.

Thanks to Raymond Toy for email discussions and for the code for cmucl, which gets this stuff right in the Common Lisp context.

See

http://140.177.205.23/InverseHyperbolicFunctions.html

for a discussion of branch cuts.

|#


(define-prim (##cabs z)

  ;; As far as I can tell, this is just magic.  It works, and I'm not
  ;; going to touch it.

  #|
  Code to compute the constants using my computable reals package.

  (load "exact-reals")
  (define r2-exact
    (computable-sqrt (exact->computable 2)))
  (define r2p1-exact
    (computable-+ r2-exact (exact->computable 1)))
  (define r2p1
    (computable->inexact r2p1-exact))
  (define t2p1-exact
    (computable-- r2p1-exact (exact->computable (inexact->exact r2p1))))
  (define r2
    (computable->inexact r2-exact))
  (define t2p1
    (computable->inexact t2p1-exact))
  (for-each pretty-print
            `((define r2 ,r2) (define r2p1 ,r2p1) (define t2p1 ,t2p1)))
  |#
  (define r2 1.4142135623730951)
  (define r2p1 2.414213562373095)
  (define t2p1 1.2537167179050217e-16)

  (let ((x (##flabs (macro-cpxnum-real z)))
        (y (##flabs (macro-cpxnum-imag z))))

    (define (continue x y)
      (let* ((x (if (##flinfinite? y) y x))
             (t (##fl- x y)))
        (if (and (##not (##fl= x +inf.0))
                 (##not (##fl= t x)))
            (if (##fl> t y)
                (let* ((s (##fl/ x y))
                       (s (##fl+ s (##flsqrt (##fl+ 1.0 (##fl* s s))))))
                  (##fl+ x (##fl/ y s)))
                (let* ((s (##fl/ t y))
                       (t (##fl* (##fl+ 2.0 s) s))
                       (s (##fl+ r2p1
                                 (##fl+ s
                                        (##fl+ t2p1
                                               (##fl/ t
                                                      (##fl+ r2 (##flsqrt (##fl+ 2.0 t)))))))))
                  (##fl+ x (##fl/ y s))))
            x)))

    (if (##fl< x y)
        (continue y x)
        (continue x y))))

(define-prim (##carg z)
  (##angle z))

(define-prim (##csquare xi+ieta)
  (let ((xi  (macro-cpxnum-real xi+ieta))
        (eta (macro-cpxnum-imag xi+ieta)))
    (let ((x (##fl* (##fl- xi eta) (##fl+ xi eta)))
          (y (##fl* 2.0 xi eta)))
      (cond ((##flnan? x)
             (cond ((##flinfinite? y)
                    (macro-cpxnum-make (##flcopysign (macro-inexact-+0) xi) y))
                   ((##flinfinite? eta)
                    (macro-cpxnum-make (macro-inexact--inf) y))
                   ((##flinfinite? xi)
                    (macro-cpxnum-make (macro-inexact-+inf) y))
                   (else
                    (macro-cpxnum-make x y))))
            ((and (##flnan? y)
                  (##flinfinite? x))
             (macro-cpxnum-make x (##flcopysign (macro-inexact-+0) y)))
            (else
             (macro-cpxnum-make x y))))))

(define-prim (##cssqs x+iy)
  (let ((x (macro-cpxnum-real x+iy))
        (y (macro-cpxnum-imag x+iy)))
    (cond ((or (##flinfinite? x)
               (##flinfinite? y))
           (##cons (macro-inexact-+inf) 0))
          ((and (##flzero? x)
                (##flzero? y))
           (##cons 0. 0))
          (else
           ;; from now on, neither x nor y are infinite, and one is non-zero
           (let* ((x^2 (##flsquare x))
                  (y^2 (##flsquare y))
                  (rho (##fl+ x^2 y^2)))
             (if (or (##flinfinite? rho)                    ;; if rho is NaN, this is false
                     (and (or (##fl< x^2 (macro-inexact-lambda))    ;; poor man's way to see whether underflow flag was set
                              (##fl< y^2 (macro-inexact-lambda)))
                          (##fl< rho (##fl/ (macro-inexact-lambda) (macro-inexact-epsilon))))) ;; if rho is NaN, this is false
                 ;; rho is not NaN, so x and y are not NaN, and x and y are not infinite.  Whew.
                 (let ((k (##flilogb (##flmax (##flabs x) (##flabs y)))))
                   (##cons (##fl+ (##flsquare (##flscalbn x (##fx- k)))
                                  (##flsquare (##flscalbn y (##fx- k))))
                           k))
                 (##cons rho 0)))))))

(define-prim (##csqrt x+iy)
  (let* ((x (macro-cpxnum-real x+iy))
         (y (macro-cpxnum-imag x+iy))
         (rho+ik (##cssqs x+iy))
         (rho (##car rho+ik))
         (k   (##cdr rho+ik))
         (rho (if (##flnan? x)
                  rho
                  (##fl+ (##flscalbn (##flabs x) (##fx- k))
                         (##flsqrt rho))))
         (rho (if (##fxodd? k)
                  (##flscalbn (##flsqrt rho) (##fxquotient (##fx- k 1) 2))
                  (##flscalbn (##flsqrt (##fl* 2.0 rho)) (##fx- (##fxquotient k 2) 1))))
         (xi rho)
         (eta y))
    (if (##not (##fl= rho 0.0))
        (let ((eta (if (##not (##flinfinite? (##flabs eta)))
                       (##fl/ (##fl/ eta rho) 2.0)
                       eta)))
          (if (##flnegative? x)
              (macro-cpxnum-make (##flabs eta) (##flcopysign rho y))
              (macro-cpxnum-make xi eta)))
        (macro-cpxnum-make xi eta))))

(define-prim (##cacos z)
  (##- (macro-inexact-+pi/2) (##casin z)))

(define-prim (##cacosh z)
  (let ((sqrt-z-1 (##sqrt (##- z 1)))
        (sqrt-z+1 (##sqrt (##+ z 1))))

    ;; if z is real and > 1, then the imaginary part of the next expression can be
    ;; inexact 0, but that's OK because this routine is not called in this case.

    (##make-rectangular (##asinh (##real-part (##* (##conjugate sqrt-z-1) sqrt-z+1)))
                        (##* 2 (##atan2 (##imag-part sqrt-z-1) (##real-part sqrt-z+1))))))

(define-prim (##casin z)

  ;; if (##real-part z) is exact zero, then there is a correlation of errors in sqrt-1-z and sqrt-1+z that
  ;; allows the next substitution

  (let ((x (##real-part z)))
    (if (##eqv? x 0)
        (##make-rectangular 0 (##asinh (##imag-part z)))
        (let ((sqrt-1-z (##sqrt (##- 1 z)))
              (sqrt-1+z (##sqrt (##+ 1 z))))
          (##make-rectangular (##atan2 x (##real-part (##* sqrt-1-z sqrt-1+z)))
                              (##asinh (##imag-part (##* (##conjugate sqrt-1-z) sqrt-1+z))))))))

(define-prim (##casinh z)
  (##* -i (##casin (##* +i z))))

(define-prim (##catanh x+iy)
  (define (x/x^2+y^2 x y)
    (if (##fl< (##flabs y) (##flabs x))
        (##fl/ 1. (##fl+ x (##fl* (##fl/ y x) y)))
        (let ((x/y (##fl/ x y)))
          (##fl/ x/y (##fl+ (##fl* x x/y) y)))))

  (define (##->exact-sign x)
    ;; returns an exact number with the same sign as x, returns 1 if x is exact zero
    (if (##flonum? x)
        (##inexact->exact (##flcopysign 1. x))
        (if (##negative? x) -1 1)))

  (let* ((pi/2 (##* 2 (##atan 1)))
         (theta (##fl/ (##flsqrt (macro-inexact-omega)) 4.))
         (rho (##fl/ theta))
         (beta (##->exact-sign (##real-part x+iy))) ;; beta is exact
         (x+iy (##* beta (##conjugate x+iy)))
         (x (##real-part x+iy))
         (y (##imag-part x+iy))
         (inexact-x (##exact->inexact x))
         (inexact-y (##exact->inexact y))
         (abs-y (##flabs inexact-y))
         (zeta (cond ((or (##fl< theta inexact-x)
                          (##fl< theta abs-y))
                      (macro-cpxnum-make (##exact->inexact (x/x^2+y^2 inexact-x inexact-y))
                                         (##flcopysign pi/2 inexact-y)))
                     ((##fl= inexact-x 1.)
                      (macro-cpxnum-make (##fllog (##fl/ (##flsqrt (##flsqrt (##fl+ 4. (##flsquare abs-y))))
                                                         (##flsqrt (##fl+ abs-y rho))))
                                         (##fl/ (##flcopysign (##fl+ pi/2 (##flatan (##fl/ (##fl+ abs-y rho) 2.0)))
                                                              inexact-y)
                                                2.)))
                     (else
                      (macro-cpxnum-make (if (##eqv? x 0)
                                             ;; if rho and abs-y were exact in the next expression (no matter their values)
                                             ;; then the argument to fllog1p would be exact 0, so the result would be exact 0.
                                             0
                                             (##fl/ (##fllog1p (##fl/ (##fl* 4. inexact-x)                 ;; was (##* 4 x) originally
                                                                      (##fl+ (##flsquare (##fl- 1. inexact-x))
                                                                             (##flsquare (##fl+ abs-y rho)))))
                                                    4.))
                                         (##fl/ (##carg (macro-cpxnum-make (##fl- (##fl* (##fl- 1. inexact-x)
                                                                                         (##fl+ 1. inexact-x))
                                                                                  (##flsquare (##fl+ abs-y rho)))
                                                                           (##fl* 2. inexact-y)))
                                                2.0))))))
    (##* beta (##conjugate zeta))))

(define-prim (##ctanh xi+ieta)
  ;; we assume that neither xi nor eta can be exact 0
  (let* ((xi  (macro-cpxnum-real xi+ieta))
         (eta (macro-cpxnum-imag xi+ieta)))
    (if (##< (##fl/ (##flasinh (macro-inexact-omega)) 4.)
             (##abs xi))
        (macro-cpxnum-make (##flcopysign 1. (##exact->inexact xi))     ;; xi cannot be exact 0
                           (##flcopysign 0. (##exact->inexact eta)))   ;; eta cannot be exact 0
        (let* ((t (##tan eta))                                  ;; sin(eta)/cos(eta), can't be exact 0, so can't be exact
               (beta (##fl+ 1. (##flsquare t)))                   ;; 1/cos^2(eta), can't be exact
               (s (##sinh xi))                                  ;; sinh(xi), can't be exact zero, so can't be exact
               (rho (##flsqrt (##fl+ 1. (##flsquare s)))))        ;; cosh(xi), can't be exact
          (if (##infinite? t)                                     ;; if sin(eta)/cos(eta) = infinity (how, I don't know)
              (macro-cpxnum-make (##fl/ rho s)
                                 (##fl/ t))
              (let ((one+beta*s^2 (##fl+ 1. (##fl* beta (##flsquare s)))))
                (macro-cpxnum-make (##fl/ (##fl* beta (##fl* rho s))
                                          one+beta*s^2)
                                   (##fl/ t
                                          one+beta*s^2))))))))

(define-prim (##ctan zeta)
  (##* -i (##ctanh (##* +i zeta))))

;;; End of Kahan's functions

(define-prim (##conjugate x)

  (define (type-error)
    (##fail-check-number 1 conjugate x))

  (macro-number-dispatch x (type-error)
    x x x x (macro-cpxnum-make (macro-cpxnum-real x)
                               (##negate (macro-cpxnum-imag x)))))

(define-prim (conjugate x)
  (macro-force-vars (x)
    (##conjugate x)))

(define-prim (##exp x)

  (define (type-error)
    (##fail-check-number 1 exp x))

  (macro-number-dispatch x (type-error)
    (if (##fxzero? x)
        1
        (##flexp (##fixnum->flonum x)))
    (##flexp (##exact-int->flonum x))
    (##flexp (##ratnum->flonum x))
    (##flexp 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 (##flabs 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 (##fixnum->flonum 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.

             (##fllog float-x))

            (else

             ;; use ln1p for arguments near one.

             (##fllog1p (##exact->inexact (##- x 1)))))))

  (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)
                      (##fl= abs-r (macro-inexact-+inf)))
                 (and (##flonum? abs-i)
                      (##fl= abs-i (macro-inexact-+inf))))
             (macro-inexact-+inf))
            ;; neither abs-r or abs-i is infinite
            ((and (##flonum? abs-r)
                  (##flnan? abs-r))
             abs-r)
            ;; abs-r is not a NaN
            ((and (##flonum? abs-i)
                  (##flnan? abs-i))
             abs-i)
            ;; abs-i is not a NaN
            ((##eqv? 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 (##fxzero? x)
        (range-error)
        (if (##fxnegative? x)
            (negative-log x)
            (if (##eqv? 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 (##flnan? x)
            (##not (##flnegative?
                    (##flcopysign (macro-inexact-+1) x))))
        (##fllog 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 (##fxzero? x)
        0
        (##flsin (##fixnum->flonum x)))
    (##flsin (##exact-int->flonum x))
    (##flsin (##ratnum->flonum x))
    (##flsin x)
    (let ((real (macro-cpxnum-real x))
          (imag (macro-cpxnum-imag x)))
      (if (and (##flonum? real)
               (##flonum? imag))
          ;; fast path for flonums case
          (macro-cpxnum-make  (##fl* (##flsin real) (##flcosh imag))
                              (##fl* (##flcos real) (##flsinh imag)))
          (##make-rectangular (##* (##sin real) (##cosh imag))
                              (##* (##cos real) (##sinh imag)))))))

(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 (##fxzero? x)
        1
        (##flcos (##fixnum->flonum x)))
    (##flcos (##exact-int->flonum x))
    (##flcos (##ratnum->flonum x))
    (##flcos x)
    (let ((real (macro-cpxnum-real x))
          (imag (macro-cpxnum-imag x)))
      (if (and (##flonum? real)
               (##flonum? imag))
          ;; fast path for flonums case
          (macro-cpxnum-make        (##fl* (##flcos real) (##flcosh imag))
                             (##fl- (##fl* (##flsin real) (##flsinh imag))))
          (##make-rectangular           (##* (##cos real) (##cosh imag))
                              (##negate (##* (##sin real) (##sinh imag))))))))

(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 (##fxzero? x)
        0
        (##fltan (##fixnum->flonum x)))
    (##fltan (##exact-int->flonum x))
    (##fltan (##ratnum->flonum x))
    (##fltan x)
    ;; complex ##tanh is the basic one here.
    (##* -i (##tanh (##* +i x)))))

(define-prim (tan x)
  (macro-force-vars (x)
    (##tan x)))

(define-prim (##asin x)

  (define (type-error)
    (##fail-check-number 1 asin x))

  (define (real-case x)
    (if (or (##< 1 x)
            (##< x -1))
        (##casin (macro-cpxnum-make x 0))
        (##flasin (##exact->inexact x))))

  (macro-number-dispatch x (type-error)
    (if (##eqv? x 0)
        0
        (real-case x))
    (real-case x)
    (real-case x)
    (real-case x)
    (##casin 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 (real-case x)
    (if (or (##< 1 x)
            (##< x -1))
        (##cacos (macro-cpxnum-make x 0))
        (##flacos (##exact->inexact x))))

  (macro-number-dispatch x (type-error)
    (if (##eqv? x 1)
        0
        (real-case x))
    (real-case x)
    (real-case x)
    (real-case x)
    (##cacos 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 (##fxzero? x)
        0
        (##flatan (##fixnum->flonum x)))
    (##flatan (##exact-int->flonum x))
    (##flatan (##ratnum->flonum x))
    (##flatan x)
    (let ((real (macro-cpxnum-real x))
          (imag (macro-cpxnum-imag x)))
      (if (and (##eqv? real 0)
               (or (##eqv? imag 1)
                   (##eqv? imag -1)))
          (range-error)
          (##* -i (##atanh (##* +i x)))))))

(define-prim (##atan2 y x)
  (cond ((or (and (##flonum? x) (##flnan? x))
             (and (##flonum? y) (##flnan? y)))
         +nan.0)
        ((##eqv? 0 y)
         (if (##exact? x)
             (if (##negative? x)
                 (macro-inexact-+pi)
                 0)
             (if (##negative? (##flcopysign (macro-inexact-+1) x))
                 (macro-inexact-+pi)
                 0.)))
        ((and (##not (##finite? x))
              (##not (##finite? y)))
         (if (##positive? x)
             (##flcopysign (macro-inexact-+pi/4) y)
             (##flcopysign (macro-inexact-+3pi/4) y)))
        (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)))
               (##flatan 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.
                 (##flatan (##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)))))))

;;; Hyperbolic functions

(define-prim (##sinh x)

  (define (type-error)
    (##fail-check-number 1 sinh x))

  (macro-number-dispatch x (type-error)
    (if (##fxzero? x)
        0
        (##flsinh (##fixnum->flonum x)))
    (##flsinh (##exact-int->flonum x))
    (##flsinh (##ratnum->flonum x))
    (##flsinh x)
    (let ((real (macro-cpxnum-real x))
          (imag (macro-cpxnum-imag x)))
      (if (and (##flonum? real) (##flonum? imag))
          ;; fast path for flonum case
          (macro-cpxnum-make (##fl* (##flsinh real) (##flcos imag))
                             (##fl* (##flcosh real) (##flsin imag)))
          (macro-cpxnum-make (##* (##sinh real) (##cos imag))
                             (##* (##cosh real) (##sin imag)))))))

(define-prim (sinh x)
  (macro-force-vars (x)
    (##sinh x)))

(define-prim (##cosh x)

  (define (type-error)
    (##fail-check-number 1 cosh x))

  (macro-number-dispatch x (type-error)
    (if (##fxzero? x)
        1
        (##flcosh (##fixnum->flonum x)))
    (##flcosh (##exact-int->flonum x))
    (##flcosh (##ratnum->flonum x))
    (##flcosh x)
    (let ((real (macro-cpxnum-real x))
          (imag (macro-cpxnum-imag x)))
      (if (and (##flonum? real) (##flonum? imag))
          ;; fast path for flonum case
          (macro-cpxnum-make (##fl* (##flcosh real) (##flcos imag))
                             (##fl* (##flsinh real) (##flsin imag)))
          (macro-cpxnum-make (##* (##cosh real) (##cos imag))
                             (##* (##sinh real) (##sin imag)))))))

(define-prim (cosh x)
  (macro-force-vars (x)
    (##cosh x)))

(define-prim (##tanh x)

  (define (type-error)
    (##fail-check-number 1 tanh x))

  (macro-number-dispatch x (type-error)
    (if (##fxzero? x)
        0
        (##fltanh (##fixnum->flonum x)))
    (##fltanh (##exact-int->flonum x))
    (##fltanh (##ratnum->flonum x))
    (##fltanh x)
    (let ((real (macro-cpxnum-real x))
          (imag (macro-cpxnum-imag x)))
      (if (##eqv? real 0)
          ;; the argument of the next ##tan is real
          ;; (##* +i (##tan (##* -i x)))
          (macro-cpxnum-make 0 (##tan imag))
          (##ctanh x)))))

(define-prim (tanh x)
  (macro-force-vars (x)
    (##tanh x)))

;;; Inverse hyperbolic functions

(define-prim (##asinh x)

  (define (type-error)
    (##fail-check-number 1 asinh x))

  (macro-number-dispatch x (type-error)
    (if (##fxzero? x)
        0
        (##flasinh (##fixnum->flonum x)))
    (##flasinh (##exact-int->flonum x))
    (##flasinh (##ratnum->flonum x))
    (##flasinh x)
    (##casinh x)))

(define-prim (asinh x)
  (macro-force-vars (x)
    (##asinh x)))

(define-prim (##acosh x)

  (define (type-error)
    (##fail-check-number 1 acosh x))

  (define (real-case x)
    (if (##< x 1)
        (##cacosh (macro-cpxnum-make x 0))
        (##flacosh (##exact->inexact x))))

  (macro-number-dispatch x (type-error)
    (if (##fx= x 1)
        0
        (real-case x))
    (real-case x)
    (real-case x)
    (real-case x)
    (##cacosh x)))

(define-prim (acosh x)
  (macro-force-vars (x)
    (##acosh x)))

(define-prim (##atanh x)

  (define (type-error)
    (##fail-check-number 1 atanh x))

  (define (range-error)
    (##raise-range-exception 1 atanh x))

  (define (real-case x)
    (cond ((##< 1 x)
           (##negate (real-case (##negate x))))
          ((##< x -1)
           (##make-rectangular (##fl/ (##fllog1p (##exact->inexact (##/ (##* 4 x)
                                                                        (##square (##- x 1)))))
                                      4.)
                               (macro-inexact-+pi/2)))
          (else
           (##flatanh (##exact->inexact x)))))

  (macro-number-dispatch x (type-error)
    (case x
      ((0)
       0)
      ((-1 1)
       (range-error))
      (else
       (real-case x)))
    (real-case x)
    (real-case x)
    (real-case x)
    (##catanh x)))

(define-prim (atanh x)
  (macro-force-vars (x)
    (##atanh x)))

(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 ((##eqv? (##cdr y) 0)
                 (##car y))
                ((##not (##exact-int.< (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.
                 (##flsqrt (##exact-int->flonum x)))
                ((##not (##< (##car y) (macro-flonum-+m-max-plus-1)))
                 ;; ##exact-int->flonum uses second argument correctly
                 (##exact-int->flonum (##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.
                 (##fl* (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
                          (##fxarithmetic-shift-left
                           (##fxarithmetic-shift-right
                            (##fx- 128 (##fx- wp wq))
                            1)
                           1))
                         (leading-bits
                          (##car
                           (##exact-int.sqrt
                            (##quotient
                             (##arithmetic-shift p shift)
                             q))))
                         (pre-rounded-result
                          (if (##fxnegative? shift)
                              (##arithmetic-shift
                               leading-bits
                               (##fx-
                                (##fxarithmetic-shift-right
                                 shift
                                 1)))
                              (##ratnum.normalize
                               leading-bits
                               (##arithmetic-shift
                                1
                                (##fxarithmetic-shift-right
                                 shift
                                 1))))))
                    (if (##ratnum? pre-rounded-result)
                        (##ratnum->flonum pre-rounded-result #t)
                        (##exact-int->flonum  pre-rounded-result #t)))))))))

  (macro-number-dispatch x (type-error)
    (exact-int-sqrt x)
    (exact-int-sqrt x)
    (ratnum-sqrt x)
    (if (##flnegative? x)
        (##make-rectangular 0 (##flsqrt (##fl- x)))
        (##flsqrt x))
    (let ((real (##real-part x))
          (imag (##imag-part x)))
      (cond ((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
             (##csqrt (##exact->inexact x)))))))

(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 (##eqv? y 1)
            x
            (let ((temp (square (expt-aux x (##arithmetic-shift y -1)))))
              (if (##even? y)
                  temp
                  (##* x temp)))))

      (cond ((or (##eqv? x 0)
                 (##eqv? x 1))
             x)
	    ((eqv? x -1)
	     (if (##odd? y)
		 -1
		 1))
            ((##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 ((##eqv? x 0)
           (if (##negative? y)
               (##raise-range-exception 1 expt x y)
               0))
          ((##eqv? 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))
                 (##flexpt (##exact-int->flonum x)
                           (##ratnum->flonum 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)
                         (##flexpt (##ratnum->flonum x)
                                   (##ratnum->flonum y))))
                   (##flexpt (##ratnum->flonum x)
                             (##ratnum->flonum 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 (##fx= y 0)
          1
          (exact-int-expt x y))
      (if (##fx= y 0)
          1
          (exact-int-expt x y))
      (if (##fx= y 0)
          1
          (exact-int-expt x y))
      (cond ((##fx= y 0)
             1)
            ((##flnan? x)
             x)
            ((##flnegative? x)
             ;; we do this because (##fixnum->flonum y) is always
             ;; even for large enough y on 64-bit machines
             (let ((abs-result
                    (##flexpt (##fl- x) (##fixnum->flonum y))))
               (if (##fxodd? y)
                   (##fl- abs-result)
                   abs-result)))
            (else
             (##flexpt x (##fixnum->flonum y))))
      (cond ((##fx= y 0)
             1)
            ((##fx= 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 ((##flnan? x)
             x)
            ((##flnegative? x)
             ;; we do this because (##exact-int->flonum y) is always
             ;; even for large enough y
             (let ((abs-result
                    (##flexpt (##fl- x) (##exact-int->flonum y))))
               (if (##odd? y)
                   (##fl- abs-result)
                   abs-result)))
            (else
             (##flexpt x (##exact-int->flonum 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 ((##flnan? x)
             x)
            ((##flnegative? x)
             (if (##eqv? 2 (macro-ratnum-denominator y))
                 (let ((magnitude (##flexpt (##fl- x) (##ratnum->flonum y))))
                   (if (##eqv? 1 (##modulo (macro-ratnum-numerator y) 4))
                       ;; multiple of i
                       (macro-cpxnum-make 0 magnitude)
                       ;; multiple of -i
                       (macro-cpxnum-make 0 (##fl- magnitude))))
                 (complex-expt x y)))
            (else
             (##flexpt x (##ratnum->flonum y))))
      (or (and (##eqv? 2 (macro-ratnum-denominator y))
               (or (and (##eqv? 1 (macro-ratnum-numerator y))
                        (##sqrt x))
                   (and (##exact? x)
                        (let ((sqrt-x (##sqrt x)))
                          (and (##exact? sqrt-x)
                               (##* sqrt-x (##expt x (##quotient (##- (macro-ratnum-numerator y) 1) 2))))))))
          (complex-expt x y)))

    (macro-number-dispatch x (##fail-check-number 1 expt x y) ;; y a flonum
      (cond ((##flnan? y)
             y)
            ((##eqv? x 0)
             (if (##flnegative? y)
                 (##raise-range-exception 1 expt x y)
                 0.))
            ((or (##fxpositive? x)
                 (macro-flonum-int? y))
             (##flexpt (##fixnum->flonum x) y))
            (else
             (complex-expt x y)))
      (cond ((##flnan? y)
             y)
            ((or (##positive? x)
                 (macro-flonum-int? y))
             (##flexpt (##exact-int->flonum x) y))
            (else
             (complex-expt x y)))
      (cond ((##flnan? y)
             y)
            ((or (##positive? x)
                 (macro-flonum-int? y))
             (##flexpt (##ratnum->flonum x) y))
            (else
             (complex-expt x y)))
      (cond ((##flnan? x)
             x)
            ((##flnan? y)
             y)
            ((or (##flpositive? x)
                 (macro-flonum-int? y))
             (##flexpt x y))
            (else
             (complex-expt x y)))
      (cond ((##flnan? y)
             y)
            (else
             (complex-expt x y))))

    (macro-number-dispatch x (##fail-check-number 1 expt x y)  ;; y a cpxnum
      (if (##eqv? 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 (##eqv? 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 (##fxnegative? x) (##negate x) x)
    (if (##bignum.negative? x) (##negate x) x)
    (if (##exact-int.negative? (macro-ratnum-numerator x))
        (macro-ratnum-make (##negate (macro-ratnum-numerator x))
                           (macro-ratnum-denominator x))
        x)
    (##flabs x)
    (let ((real (macro-cpxnum-real x))
          (imag (macro-cpxnum-imag x)))
      (cond ((and (##flonum? real) (##flonum? imag))
             (##cabs x))
            ;; at least one of real or imag is exact
            ((and (##exact? real) (##exact? imag))
             (##sqrt (##+ (##square real) (##square imag))))
            ;; one is exact, other is inexact
            ((and (##finite? real) (##finite? imag))
             (##exact->inexact (##sqrt (##+ (##square (##inexact->exact real))
                                            (##square (##inexact->exact imag))))))
            ;; one is exact, other is not finite inexact
            (else
             (##cabs (macro-cpxnum-make (##exact->inexact real)
                                        (##exact->inexact imag))))))))

(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 (##fxnegative? x)
        (macro-inexact-+pi)
        0)
    (if (##bignum.negative? x)
        (macro-inexact-+pi)
        0)
    (if (##negative? (macro-ratnum-numerator x))
        (macro-inexact-+pi)
        0)
    (if (##flnegative? (##flcopysign (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)
    (##fixnum->flonum x)
    (##exact-int->flonum x)
    (##ratnum->flonum 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->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->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 (##fx= x 0)
          (##make-string len)
          (let* ((new-pos
                  (##fx+ pos 1))
                 (s
                  (loop (##fxquotient x rad)
                        (##fx+ len 1)
                        new-pos)))
            (##string-set!
             s
             (##fx- (##string-length s) new-pos)
             (##string-ref ##digit-to-char-table
                           (##fx- (##fxremainder x rad))))
            s))))

  (define (convert-non-last-fixnum s rad x pos)
    (let loop ((x x)
               (size (##vector-ref block-size rad))
               (i (##fx- (##string-length s) pos)))
      (if (##fx< 0 size)
          (let ((new-i (##fx- i 1)))
            (##string-set!
             s
             new-i
             (##string-ref ##digit-to-char-table
                           (##fxremainder x rad)))
            (loop (##fxquotient x rad)
                  (##fx- 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
             (##fx- (##car lst))
             (##fx+ len pos)
             pos)
            (let* ((size
                    (##vector-ref block-size rad))
                   (new-pos
                    (##fx+ 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) (##eqv? x 0))
           lst)
          ((##fx= level 0)
           (##cons x lst))
          (else
           (let* ((qr (##exact-int.div x (##car sqs)))
                  (new-level (##fx- 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
                (##fx+ level 1))
               (new-sqs
                (##cons rad^size^2^level sqs)))
           (if (##fx< x-length
                      (##fx-
                       (##fx* (##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 ((##fxnegative? x)
             (let ((s (make-string-from-last-fixnum rad x 1 0)))
               (##string-set! s 0 #\-)
               s))
            ((##fxzero? x)
             (if force-sign?
                 (##string #\+ #\0)
                 (##string #\0)))
            (else
             (if force-sign?
                 (let ((s (make-string-from-last-fixnum rad (##fx- x) 1 0)))
                   (##string-set! s 0 #\+)
                   s)
                 (make-string-from-last-fixnum rad (##fx- 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->string x rad force-sign?)
  (##string-append
   (##exact-int->string (macro-ratnum-numerator x) rad force-sign?)
   "/"
   (##exact-int->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)))
    (##fl* (##fllog 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
            (##flceiling (##fl- (base-10-log v) (epsilon))))))
      (if (##fxnegative? est)
          (let ((factor (10^ (##fx- 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 (##fx+ 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 (##fxeven? d)
                                     (##= r*2 s)) ;; tie, round d to even
                                (##< r*2 s))
                            d
                            (##fx+ d 1)))
                      d))
                 (str
                  (##make-string (##fx+ n 1))))
            (##string-set!
             str
             n
             (##string-ref ##digit-to-char-table last-digit))
            str)
          (if tc
              (let ((str
                     (##make-string (##fx+ n 1))))
                (##string-set!
                 str
                 n
                 (##string-ref ##digit-to-char-table (##fx+ d 1)))
                str)
              (let ((str
                     (generate (##* r 10)
                               s
                               (##* m+ 10)
                               (##* m- 10)
                               round?
                               (##fx+ 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 (##fxnegative? e)
          (if (and (##not (##fx= e (macro-flonum-e-min)))
                   (##= f (macro-flonum-+m-min)))
              (scale (##arithmetic-shift f 2)
                     (##arithmetic-shift 1 (##fx- 2 e))
                     2
                     1
                     round?
                     v)
              (scale (##arithmetic-shift f 1)
                     (##arithmetic-shift 1 (##fx- 1 e))
                     1
                     1
                     round?
                     v))
          (let ((2^e (##arithmetic-shift 1 e)))
            (if (##= f (macro-flonum-+m-min))
                (scale (##arithmetic-shift f (##fx+ e 2))
                       4
                       (##arithmetic-shift 1 (##fx+ e 1))
                       2^e
                       round?
                       v)
                (scale (##arithmetic-shift f (##fx+ 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 (##fx< e 0)) ;; 0<=e<=10
                (##not (##fx< 10 e)))

           (cond ((##fx= e 0) ;; e=0

                  ;; Format 1: .DDD    (0.DDD in chez-fp-syntax)

                  (##string-append sign-prefix
                                   (if (macro-chez-fp-syntax) "0." ".")
                                   d))

                 ((##fx< e n) ;; e<n

                  ;; Format 2: D.DDD up to DDD.D

                  (##string-append sign-prefix
                                   (##substring d 0 e)
                                   "."
                                   (##substring d e n)))

                 ((##fx= 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 (##fx- e n) #\0)
                                   (if (macro-chez-fp-syntax) ".0" ".")))))

          ((and (##not (##fx< e -2)) ;; -2<=e<=-1
                (##not (##fx< -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 (##fx- 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 (##fx= n 1) "" ".")
                            (##substring d 1 n)
                            "e"
                            (##number->string (##fx- e 1) 10))))))

(define-prim (##flonum->string x rad force-sign?)

  (define (non-neg-num->str x rad sign-prefix)
    (if (##flzero? x)
        (##string-append sign-prefix (if (macro-chez-fp-syntax) "0.0" "0."))
        (##flonum-printout x sign-prefix)))

  (cond ((##flnan? x)
         (##string-copy (if (or (macro-r6rs-fp-syntax)
                                (macro-chez-fp-syntax))
                            "+nan.0"
                            "+nan.")))
        ((##flnegative? (##flcopysign (macro-inexact-+1) x))
         (let ((abs-x (##flcopysign x (macro-inexact-+1))))
           (cond ((##fl= 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 ((##fl= 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->string x rad force-sign?)
  (let* ((real
          (macro-cpxnum-real x))
         (real-str
          (if (##eqv? real 0) "" (##number->string real rad force-sign?))))
    (let ((imag (macro-cpxnum-imag x)))
      (cond ((##eqv? imag 1)
             (##string-append real-str "+i"))
            ((##eqv? 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->string x rad force-sign?)
    (##exact-int->string x rad force-sign?)
    (##ratnum->string x rad force-sign?)
    (##flonum->string x rad force-sign?)
    (##cpxnum->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 (##eqv? rad 2)
                  (##eqv? rad 8)
                  (##eqv? rad 10)
                  (##eqv? 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 (##fx< i j)
          (let* ((c (##string-ref str i))
                 (ic (##char->integer c)))
            (loop (##fx+ i 1)
                  (##fx+ (##fx* n rad)
                         (if (##fx< ic 128)
                             (##u8vector-ref ##char-to-digit-table ic)
                             0))))
          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 (##fxquotient width 2))
               (mid (##fx- j new-width)))
          (if (##fx< 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 (##fx= n 1)
          (##cons rad lst)
          (loop (##exact-int.square rad)
                (##fx- 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 (##fx- j i))
          (size (##vector-ref block-size rad)))
      (if (##fx< size len)
          (let ((levels
                 (##integer-length (##fxquotient (##fx- len 1) size))))
            (substring->uinteger-aux
             (squares (##vector-ref rad^block-size rad) levels)
             (##fxarithmetic-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 (##fx< i j))
          n
          (let ((c (##string-ref str i)))
            (if (##char=? c #\.)
                (loop1 (##fx+ i 1) n)
                (let* ((ic
                        (##char->integer c))
                       (new-n
                        (##fx+ (##fx* n 10)
                               (if (##fx< ic 128)
                                   (##u8vector-ref ##char-to-digit-table ic)
                                   0))))
                  (if (##fx< new-n (macro-max-fixnum32-div-10))
                      (loop1 (##fx+ i 1) new-n)
                      (let loop2 ((i i) (n n))
                        (if (##not (##fx< i j))
                            n
                            (let ((c (##string-ref str i)))
                              (if (##char=? c #\.)
                                  (loop2 (##fx+ i 1) n)
                                  (let* ((ic
                                          (##char->integer c))
                                         (new-n
                                          (##+ (##* n 10)
                                               (if (##fx< ic 128)
                                                   (##u8vector-ref ##char-to-digit-table ic)
                                                   0))))
                                    (loop2 (##fx+ i 1) new-n)))))))))))))

  (define (uinteger str rad i)
    (and (##fx< i (##string-length str))
         (let* ((c (##string-ref str i))
                (ic (##char->integer c)))
           (and (##fx< ic 128)
                (##not (##char=? c #\#))
                (##fx< (##u8vector-ref ##char-to-digit-table ic) rad)
                (digits-and-sharps str rad (##fx+ i 1))))))

  (define (digits-and-sharps str rad i)
    (let loop ((i i))
      (if (##fx< i (##string-length str))
          (let* ((c (##string-ref str i))
                 (ic (##char->integer c)))
            (if (##fx< ic 128)
                (if (##char=? c #\#)
                    (sharps str (##fx+ i 1))
                    (if (##fx< (##u8vector-ref ##char-to-digit-table ic) rad)
                        (loop (##fx+ i 1))
                        i))
                i))
          i)))

  (define (sharps str i)
    (let loop ((i i))
      (if (##fx< i (##string-length str))
          (if (##char=? (##string-ref str i) #\#)
              (loop (##fx+ i 1))
              i)
          i)))

  (define (suffix str i1)
    (if (##fx< (##fx+ 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 (##fx+ i1 1))))
                (let ((i2
                       (if (or (##char=? c2 #\+) (##char=? c2 #\-))
                           (uinteger str 10 (##fx+ i1 2))
                           (uinteger str 10 (##fx+ i1 1)))))
                  (if (and i2
                           (##not (##char=? (##string-ref str (##fx- i2 1))
                                            #\#)))
                      i2
                      i1)))
              i1))
        i1))

  (define (ureal str rad e i1)
    (let ((i2 (uinteger str rad i1)))
      (if i2
          (if (##fx< i2 (##string-length str))
              (let ((c (##string-ref str i2)))
                (cond ((##char=? c #\/)
                       (let ((i3 (uinteger str rad (##fx+ i2 1))))
                         (and i3
                              (let ((inexact-num?
                                     (or (##eq? e 'i)
                                         (and (##not e)
                                              (or (##char=? (##string-ref
                                                             str
                                                             (##fx- i2 1))
                                                            #\#)
                                                  (##char=? (##string-ref
                                                             str
                                                             (##fx- i3 1))
                                                            #\#))))))
                                (if (and (##not inexact-num?)
                                         (##eqv? (substring->uinteger
                                                  str
                                                  rad
                                                  (##fx+ i2 1)
                                                  i3)
                                                 0))
                                    #f
                                    (##vector i3 i2))))))
                      ((##fx= rad 10)
                       (if (##char=? c #\.)
                           (let ((i3
                                  (if (##char=? (##string-ref str (##fx- i2 1))
                                                #\#)
                                      (sharps str (##fx+ i2 1))
                                      (digits-and-sharps str 10 (##fx+ i2 1)))))
                             (and i3
                                  (let ((i4 (suffix str i3)))
                                    (##vector i4 i3 i2))))
                           (let ((i3 (suffix str i2)))
                             (if (##fx= i2 i3)
                                 i2
                                 (##vector i3 i2 i2)))))
                      (else
                       i2)))
              i2)
          (and (##fx= rad 10)
               (##fx< i1 (##string-length str))
               (##char=? (##string-ref str i1) #\.)
               (let ((i3 (uinteger str rad (##fx+ 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 (##fx< (##fx+ i (if (or (macro-r6rs-fp-syntax)
                                     (macro-chez-fp-syntax))
                                 4
                                 3))
                    (##string-length str))
             (and (##char=? (##string-ref str (##fx+ i 3)) #\.)
                  (if (or (macro-r6rs-fp-syntax)
                          (macro-chez-fp-syntax))
                      (##char=? (##string-ref str (##fx+ i 4)) #\0)
                      #t)
                  (or (and (let ((c (##string-ref str i)))
                             (or (##char=? c #\i) (##char=? c #\I)))
                           (let ((c (##string-ref str (##fx+ i 1))))
                             (or (##char=? c #\n) (##char=? c #\N)))
                           (let ((c (##string-ref str (##fx+ 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 (##fx+ i 1))))
                             (or (##char=? c #\a) (##char=? c #\A)))
                           (let ((c (##string-ref str (##fx+ i 2))))
                             (or (##char=? c #\n) (##char=? c #\N)))))
                  (##vector (##fx+ 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)
                    (##fixnum->flonum-exact? uinteger)
                    (##fixnum? exponent)
                    (##fx< (##fx- exponent)
                           (##f64vector-length exact-10^n-table))
                    (##fx< exponent
                           (##f64vector-length exact-10^n-table)))
               (if (##fx< exponent 0)
                   (##fl/ (##fixnum->flonum uinteger)
                          (##f64vector-ref exact-10^n-table
                                           (##fx- exponent)))
                   (##fl* (##fixnum->flonum uinteger)
                          (##f64vector-ref exact-10^n-table
                                           exponent)))
               (##exact->inexact
                (##* uinteger (##expt 10 exponent))))))
      (if (##char=? sign #\-)
          (##flcopysign 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 (##fx- i 1)) #\#)))
              (##exact->inexact n)
              n))
        (let ((j (##vector-ref i 0))
              (len (##vector-length i)))
          (cond ((##fx= len 3) ;; xxx.yyyEzzz
                 (let* ((after-frac-part
                         (##vector-ref i 1))
                        (unadjusted-exponent
                         (if (##fx= after-frac-part j) ;; no exponent part?
                             0
                             (let* ((c
                                     (##string-ref
                                      str
                                      (##fx+ after-frac-part 1)))
                                    (n
                                     (substring->uinteger
                                      str
                                      10
                                      (if (or (##char=? c #\+) (##char=? c #\-))
                                          (##fx+ after-frac-part 2)
                                          (##fx+ 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
                         (##fx-
                          (##fx- after-frac-part (##vector-ref i 2))
                          1))
                        (exponent
                         (if (##fx< 0 decimals-after-point)
                             (if (and (##fixnum? unadjusted-exponent)
                                      (##fx< (##fx- unadjusted-exponent
                                                    decimals-after-point)
                                             unadjusted-exponent))
                                 (##fx- 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))))
                ((##fx= 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
                                                 (##fx- after-num 1))
                                                #\#)
                                      (##char=? (##string-ref
                                                 str
                                                 (##fx- j 1))
                                                #\#)))))
                        (abs-num
                         (substring->uinteger str rad start after-num))
                        (den
                         (substring->uinteger str
                                              rad
                                              (##fx+ after-num 1)
                                              j)))

                   (define (num-div-den)
                     (##/ (if (##char=? sign #\-)
                              (##negate abs-num)
                              abs-num)
                          den))

                   (if inexact-num?
                       (if (##eqv? den 0)
                           (let ((n
                                  (if (##eqv? abs-num 0)
                                      (macro-inexact-+nan)
                                      (macro-inexact-+inf))))
                             (if (##char=? sign #\-)
                                 (##flcopysign n (macro-inexact--1))
                                 n))
                           (##exact->inexact (num-div-den)))
                       (num-div-den))))
                (else ;; (##fx= 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 #\-)
                       (##flcopysign n (macro-inexact--1))
                       n)))))))

  (define (i-end str i)
    (and (##fx= (##fx+ 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 (##fx+ j 1)))
                 (if (##fx< j+1 (##string-length str))
                     (let* ((sign2
                             (##string-ref str j+1))
                            (start2
                             (if (or (##char=? sign2 #\+) (##char=? sign2 #\-))
                                 (##fx+ j+1 1)
                                 j+1))
                            (k
                             (or (ureal str rad e start2)
                                 (and (##fx< j+1 start2)
                                      (inf-nan str sign2 start2 e)))))
                       (and k
                            (let ((l (if (##fixnum? k) k (##vector-ref k 0))))
                              (and (##fx= 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
                       (##fx+ 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 (##fx+ start 1))
                       (inf-nan str c (##fx+ start 1) e))))
            (if (##not i)
                (if (i-end str (##fx+ 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 ((##fx= j (##string-length str))
                         (or check-only?
                             (get-real (##fx+ start 1) c str rad e i)))
                        ((i-end str j)
                         (or check-only?
                             (make-rec
                              (get-zero e)
                              (get-real (##fx+ start 1) c str rad e i))))
                        (else
                         (complex (##fx+ 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 ((##fx= 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)
          ((or (##char=? c #\o) (##char=? c #\O))  8)
          ((or (##char=? c #\d) (##char=? c #\D)) 10)
          ((or (##char=? c #\x) (##char=? c #\X)) 16)
          (else                                   #f)))

  (define (exactness-prefix c)
    (cond ((or (##char=? c #\i) (##char=? c #\I)) 'i)
          ((or (##char=? c #\e) (##char=? c #\E)) 'e)
          (else                                   #f)))

  (cond ((##fx< 2 (##string-length str)) ;; >= 3 chars
         (if (##char=? (##string-ref str 0) #\#)
             (let ((rad1 (radix-prefix (##string-ref str 1))))
               (if rad1
                   (if (and (##fx< 4 (##string-length str)) ;; >= 5 chars
                            (##char=? (##string-ref str 2) #\#))
                       (let ((e1 (exactness-prefix (##string-ref str 3))))
                         (if e1
                             (after-prefix 4 str rad1 e1)
                             #f))
                       (after-prefix 2 str rad1 #f))
                   (let ((e2 (exactness-prefix (##string-ref str 1))))
                     (if e2
                         (if (and (##fx< 4 (##string-length str)) ;; >= 5 chars
                                  (##char=? (##string-ref str 2) #\#))
                             (let ((rad2 (radix-prefix (##string-ref str 3))))
                               (if rad2
                                   (after-prefix 4 str rad2 e2)
                                   #f))
                             (after-prefix 2 str rad e2))
                         #f))))
             (after-prefix 0 str rad #f)))
        ((##fx< 0 (##string-length str)) ;; >= 1 char
         (after-prefix 0 str rad #f))
        (else
         #f)))

(define-prim (string->number str #!optional (r (macro-absent-obj)))
  (macro-force-vars (str r)
    (macro-check-string str 1 (string->number str r)
      (let ((rad (if (##eq? r (macro-absent-obj)) 10 r)))
        (if (macro-exact-int? rad)
            (if (or (##eqv? rad 2)
                    (##eqv? rad 8)
                    (##eqv? rad 10)
                    (##eqv? rad 16))
                (##string->number str rad #f)
                (##raise-range-exception 2 string->number str r))
            (##fail-check-exact-integer 2 string->number str r))))))

;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

;;; Bitwise operations.

(define-prim (##bitwise-ior x y)

  (##define-macro (type-error-on-x) `'(1))
  (##define-macro (type-error-on-y) `'(2))

  (define (bignum-bitwise-ior-loop x result n)
    (##declare (not interrupts-enabled))
    (let loop ((i (fx- n 1)))
      (if (##fx< i 0)
          (##bignum.normalize! result)
          (begin
            (##bignum.adigit-bitwise-ior! result i x i)
            (loop (##fx- i 1))))))

  (define (bignum-bitwise-ior x x-length y y-length)
    ;; x-length <= y-length
    (if (##bignum.negative? x)
        (bignum-bitwise-ior-loop y (##bignum.copy x) x-length)
        (bignum-bitwise-ior-loop x (##bignum.copy y) x-length)))

  (cond ((##fixnum? x)
         (cond ((##fixnum? y)
                (##fxior x y))
               ((##bignum? y)
                (let* ((x-bignum (##fixnum->bignum x))
                       (x-length (##bignum.adigit-length x-bignum))
                       (y-length (##bignum.adigit-length y)))
                  (bignum-bitwise-ior x-bignum x-length y y-length)))
               (else
                (type-error-on-y))))
        ((##bignum? x)
         (let ((x-length (##bignum.adigit-length x)))
           (cond ((##fixnum? y)
                  (let* ((y-bignum (##fixnum->bignum y))
                         (y-length (##bignum.adigit-length y-bignum)))
                    (bignum-bitwise-ior y-bignum y-length x x-length)))
                 ((##bignum? y)
                  (let ((y-length (##bignum.adigit-length y)))
                    (if (##fx< x-length y-length)
                        (bignum-bitwise-ior x x-length y y-length)
                        (bignum-bitwise-ior y y-length x x-length))))
                 (else
                  (type-error-on-y)))))
        (else
         (type-error-on-x))))

(define-prim-nary (bitwise-ior x y)
  0
  (if (macro-exact-int? x) x '(1))
  (##bitwise-ior x y)
  macro-force-vars
  macro-no-check
  (##pair? ##fail-check-exact-integer))

(define-prim (##bitwise-xor x y)

  (##define-macro (type-error-on-x) `'(1))
  (##define-macro (type-error-on-y) `'(2))

  (define (bignum-bitwise-xor x x-length y y-length)
    (let ((result (##bignum.copy y)))
      (##declare (not interrupts-enabled))
      (let loop1 ((i 0))
        (if (##fx< i x-length)
            (begin
              (##bignum.adigit-bitwise-xor! result i x i)
              (loop1 (##fx+ i 1)))
            (if (##bignum.negative? x)
                (let loop2 ((i i))
                  (if (##fx< i y-length)
                      (begin
                        (##bignum.adigit-bitwise-not! result i)
                        (loop2 (##fx+ i 1)))
                      (##bignum.normalize! result)))
                (##bignum.normalize! result))))))

  (cond ((##fixnum? x)
         (cond ((##fixnum? y)
                (##fxxor x y))
               ((##bignum? y)
                (let* ((x-bignum (##fixnum->bignum x))
                       (x-length (##bignum.adigit-length x-bignum))
                       (y-length (##bignum.adigit-length y)))
                  (bignum-bitwise-xor x-bignum x-length y y-length)))
               (else
                (type-error-on-y))))
        ((##bignum? x)
         (let ((x-length (##bignum.adigit-length x)))
           (cond ((##fixnum? y)
                  (let* ((y-bignum (##fixnum->bignum y))
                         (y-length (##bignum.adigit-length y-bignum)))
                    (bignum-bitwise-xor y-bignum y-length x x-length)))
                 ((##bignum? y)
                  (let ((y-length (##bignum.adigit-length y)))
                    (if (##fx< x-length y-length)
                        (bignum-bitwise-xor x x-length y y-length)
                        (bignum-bitwise-xor y y-length x x-length))))
                 (else
                  (type-error-on-y)))))
        (else
         (type-error-on-x))))

(define-prim-nary (bitwise-xor x y)
  0
  (if (macro-exact-int? x) x '(1))
  (##bitwise-xor x y)
  macro-force-vars
  macro-no-check
  (##pair? ##fail-check-exact-integer))

(define-prim (##bitwise-and x y)

  (##define-macro (type-error-on-x) `'(1))
  (##define-macro (type-error-on-y) `'(2))

  (define (bignum-bitwise-and-loop x result n)
    (##declare (not interrupts-enabled))
    (let loop ((i (##fx- n 1)))
      (if (##fx< i 0)
          (##bignum.normalize! result)
          (begin
            (##bignum.adigit-bitwise-and! result i x i)
            (loop (##fx- i 1))))))

  (define (bignum-bitwise-and x x-length y y-length)
    ;; x-length <= y-length
    (if (##bignum.negative? x)
        (bignum-bitwise-and-loop x (##bignum.copy y) x-length)
        (bignum-bitwise-and-loop y (##bignum.copy x) x-length)))

  (cond ((##fixnum? x)
         (cond ((##fixnum? y)
                (##fxand x y))
               ((##bignum? y)
                (let* ((x-bignum (##fixnum->bignum x))
                       (x-length (##bignum.adigit-length x-bignum))
                       (y-length (##bignum.adigit-length y)))
                  (bignum-bitwise-and x-bignum x-length y y-length)))
               (else
                (type-error-on-y))))
        ((##bignum? x)
         (let ((x-length (##bignum.adigit-length x)))
           (cond ((##fixnum? y)
                  (let* ((y-bignum (##fixnum->bignum y))
                         (y-length (##bignum.adigit-length y-bignum)))
                    (bignum-bitwise-and y-bignum y-length x x-length)))
                 ((##bignum? y)
                  (let ((y-length (##bignum.adigit-length y)))
                    (if (##fx< x-length y-length)
                        (bignum-bitwise-and x x-length y y-length)
                        (bignum-bitwise-and y y-length x x-length))))
                 (else
                  (type-error-on-y)))))
        (else
         (type-error-on-x))))

(define-prim-nary (bitwise-and x y)
  -1
  (if (macro-exact-int? x) x '(1))
  (##bitwise-and x y)
  macro-force-vars
  macro-no-check
  (##pair? ##fail-check-exact-integer))

(define-prim (##bitwise-not x)

  (define (type-error)
    (##fail-check-exact-integer 1 bitwise-not x))

  (cond ((##fixnum? x)
         (##fxnot x))
        ((##bignum? x)
         (##bignum.make (##bignum.adigit-length x) x #t))  ;; don't copy, bitwise invert
        (else
         (type-error))))

(define-prim (bitwise-not x)
  (macro-force-vars (x)
    (##bitwise-not x)))

(define-prim (##arithmetic-shift x y)

  (define (type-error-on-x)
    (##fail-check-exact-integer 1 arithmetic-shift x y))

  (define (type-error-on-y)
    (##fail-check-exact-integer 2 arithmetic-shift x y))

  (define (overflow)
    (##raise-heap-overflow-exception)
    (##arithmetic-shift x y))

  (define (general-fixnum-fixnum-case)
    (##bignum.arithmetic-shift (##fixnum->bignum x) y))

  (cond ((##fixnum? x)
         (cond ((##fixnum? y)
                (cond ((##fxzero? y)
                       x)
                      ((##fxnegative? y) ;; right shift
                       (if (##fx< (##fx- ##fixnum-width) y)
                           (##fxarithmetic-shift-right x (##fx- y))
                           (if (##fxnegative? x)
                               -1
                               0)))
                      (else ;; left shift
                       (or (and (##fx< y ##fixnum-width)
                                (##fxarithmetic-shift-left? x y))
                           (general-fixnum-fixnum-case)))))
               ((##bignum? y)
                (cond ((##fxzero? x)
                       0)
                      ((##bignum.negative? y)
                       (if (##fxnegative? x)
                           -1
                           0))
                      (else
                       (overflow))))
               (else
                (type-error-on-y))))
        ((##bignum? x)
         (cond ((##eqv? y 0)
                x)
               ((##fixnum? y)
                (##bignum.arithmetic-shift x y))
               ((##bignum? y)
                (cond ((##bignum.negative? y)
                       (if (##bignum.negative? x)
                           -1
                           0))
                      (else
                       (overflow))))
               (else
                (type-error-on-y))))
        (else
         (type-error-on-x))))

(define-prim (arithmetic-shift x y)
  (macro-force-vars (x y)
    (##arithmetic-shift x y)))

(define-prim (##bit-count x)

  (define (type-error)
    (##fail-check-exact-integer 1 bit-count x))

  (cond ((##fixnum? x)
         (##fxbit-count x))
        ((##bignum? x)
         (let ((x-length (##bignum.mdigit-length x)))
           (let loop ((i (##fx- x-length 1))
                      (n 0))
             (if (##fx< i 0)
                 (if (##bignum.negative? x)
                     (##fx- (##fx* x-length ##bignum.mdigit-width) n)
                     n)
                 (loop (##fx- i 1)
                       (##fx+ n (##fxbit-count (##bignum.mdigit-ref x i))))))))
        (else
         (type-error))))

(define-prim (bit-count x)
  (macro-force-vars (x)
    (##bit-count x)))

(define-prim (##integer-length x)

  (define (type-error)
    (##fail-check-exact-integer 1 integer-length x))

  (cond ((##fixnum? x)
         (##fxlength x))
        ((##bignum? x)
         (let ((x-length (##bignum.mdigit-length x)))
           (if (##bignum.negative? x)
               (let loop1 ((i (##fx- x-length 1)))
                 (let ((mdigit (##bignum.mdigit-ref x i)))
                   (if (##fx= mdigit ##bignum.mdigit-base-minus-1)
                       (loop1 (##fx- i 1))
                       (##fx+
                        (##fxlength (##fx- ##bignum.mdigit-base-minus-1 mdigit))
                        (##fx* i ##bignum.mdigit-width)))))
               (let loop2 ((i (##fx- x-length 1)))
                 (let ((mdigit (##bignum.mdigit-ref x i)))
                   (if (##fx= mdigit 0)
                       (loop2 (##fx- i 1))
                       (##fx+
                        (##fxlength mdigit)
                        (##fx* i ##bignum.mdigit-width))))))))
        (else
         (type-error))))

(define-prim (integer-length x)
  (macro-force-vars (x)
    (##integer-length x)))

(define-prim (##bitwise-merge x y z)
  (##bitwise-ior (##bitwise-and (##bitwise-not x) y)
                 (##bitwise-and x z)))

(define-prim (bitwise-merge x y z)
  (macro-force-vars (x y z)
    (cond ((##not (macro-exact-int? x))
           (##fail-check-exact-integer 1 bitwise-merge x y z))
          ((##not (macro-exact-int? y))
           (##fail-check-exact-integer 2 bitwise-merge x y z))
          ((##not (macro-exact-int? z))
           (##fail-check-exact-integer 3 bitwise-merge x y z))
          (else
           (##bitwise-merge x y z)))))

(define-prim (##bit-set? x y)

  (define (type-error-on-x)
    (##fail-check-exact-integer 1 bit-set? x y))

  (define (type-error-on-y)
    (##fail-check-exact-integer 2 bit-set? x y))

  (define (range-error)
    (##raise-range-exception 1 bit-set? x y))

  (cond ((##fixnum? x)
         (cond ((##fixnum? y)
                (if (##fxnegative? x)
                    (range-error)
                    (if (##fx< x ##fixnum-width)
                        (##fxodd? (##fxarithmetic-shift-right y x))
                        (##fxnegative? y))))
               ((##bignum? y)
                (if (##fxnegative? x)
                    (range-error)
                    (let ((i (##fxquotient x ##bignum.mdigit-width)))
                      (if (##fx< i (##bignum.mdigit-length y))
                          (##fxodd?
                           (##fxarithmetic-shift-right
                            (##bignum.mdigit-ref y i)
                            (##fxmodulo x ##bignum.mdigit-width)))
                          (##bignum.negative? y)))))
               (else
                (type-error-on-y))))
        ((##bignum? x)
         (cond ((##fixnum? y)
                (if (##bignum.negative? x)
                    (range-error)
                    (##fxnegative? y)))
               ((##bignum? y)
                (if (##bignum.negative? x)
                    (range-error)
                    (##bignum.negative? y)))
               (else
                (type-error-on-y))))
        (else
         (type-error-on-x))))

(define-prim (bit-set? x y)
  (macro-force-vars (x y)
    (##bit-set? x y)))

(define-prim (##any-bits-set? x y)
  (##not (##eqv? (##bitwise-and x y) 0)))

(define-prim (any-bits-set? x y)
  (macro-force-vars (x y)
    (cond ((##not (macro-exact-int? x))
           (##fail-check-exact-integer 1 any-bits-set? x y))
          ((##not (macro-exact-int? y))
           (##fail-check-exact-integer 2 any-bits-set? x y))
          (else
           (##any-bits-set? x y)))))

(define-prim (##all-bits-set? x y)
  (##= x (##bitwise-and x y)))

(define-prim (all-bits-set? x y)
  (macro-force-vars (x y)
    (cond ((##not (macro-exact-int? x))
           (##fail-check-exact-integer 1 all-bits-set? x y))
          ((##not (macro-exact-int? y))
           (##fail-check-exact-integer 2 all-bits-set? x y))
          (else
           (##all-bits-set? x y)))))

(define-prim (##first-bit-set x)

  (define (type-error)
    (##fail-check-exact-integer 1 first-bit-set x))

  (cond ((##fixnum? x)
         (##fxfirst-bit-set x))
        ((##bignum? x)
         (let ((x-length (##bignum.mdigit-length x)))
           (let loop ((i 0))
             (let ((mdigit (##bignum.mdigit-ref x i)))
               (if (##fx= mdigit 0)
                   (loop (##fx+ i 1))
                   (##fx+
                    (##fxfirst-bit-set mdigit)
                    (##fx* i ##bignum.mdigit-width)))))))
        (else
         (type-error))))

(define-prim (first-bit-set x)
  (macro-force-vars (x)
    (##first-bit-set x)))

(define-prim (##extract-bit-field size position n)

  ;; I've decided to be brutally simple and not optimize
  ;; for special cases, fixnums, etc.
  
  (let* ((result-length
          (##fxceiling-ratio (##fx+ 1 size) ##bignum.adigit-width))  ;;  top bit is always 0
         (bignum-n
          (if (##bignum? n) n (##fixnum->bignum n)))
         (result
          (##bignum.arithmetic-shift-into!
           bignum-n (##fx- position) (##bignum.make result-length #f #f))))

    ;; zero top bits of result and normalize

    (let ((size-words (##fxquotient  size ##bignum.mdigit-width))
          (size-bits  (##fxremainder size ##bignum.mdigit-width)))
      (##declare (not interrupts-enabled))
      (let loop ((i (##fx- (##bignum.mdigit-length result) 1)))
        (if (##fx< size-words i)
            (begin
              (##bignum.mdigit-set! result i 0)
              (loop (##fx- i 1)))
            (##bignum.mdigit-set!
             result i
             (##fxand
              (##bignum.mdigit-ref result i)
              (##fxnot (##fxarithmetic-shift-left -1 size-bits)))))
        (##bignum.normalize! result)))))

(define-prim (extract-bit-field size position n)
  (macro-force-vars (size position n)
    (macro-check-index
      size
      1
      (extract-bit-field size position n)
      (macro-check-index
        position
        2
        (extract-bit-field size position n)
        (if (##not (macro-exact-int? n))
            (##fail-check-exact-integer 3 extract-bit-field size position n)
            (##extract-bit-field size position n))))))

(define-prim (##test-bit-field? size position n)
  (##not (##eqv? (##extract-bit-field size position n)
                 0)))

(define-prim (test-bit-field? size position n)
  (macro-force-vars (size position n)
    (macro-check-index
      size
      1
      (test-bit-field? size position n)
      (macro-check-index
        position
        2
        (test-bit-field? size position n)
        (if (##not (macro-exact-int? n))
            (##fail-check-exact-integer 3 test-bit-field? size position n)
            (##test-bit-field? size position n))))))

(define-prim (##clear-bit-field size position n)
  (##replace-bit-field size position 0 n))

(define-prim (clear-bit-field size position n)
  (macro-force-vars (size position n)
    (macro-check-index
      size
      1
      (clear-bit-field size position n)
      (macro-check-index
        position
        2
        (clear-bit-field size position n)
        (if (##not (macro-exact-int? n))
            (##fail-check-exact-integer 3 clear-bit-field size position n)
            (##clear-bit-field size position n))))))

(define-prim (##replace-bit-field size position newfield n)
  (let ((m (##bit-mask size)))
    (##bitwise-ior
     (##bitwise-and n (##bitwise-not (##arithmetic-shift m position)))
     (##arithmetic-shift (##bitwise-and newfield m) position))))

(define-prim (replace-bit-field size position newfield n)
  (macro-force-vars (size position newfield n)
    (macro-check-index
      size
      1
      (replace-bit-field size position newfield n)
      (macro-check-index
        position
        2
        (replace-bit-field size position newfield n)
        (cond ((##not (macro-exact-int? newfield))
               (##fail-check-exact-integer 3 replace-bit-field size position newfield n))
              ((##not (macro-exact-int? n))
               (##fail-check-exact-integer 4 replace-bit-field size position newfield n))
              (else
               (##replace-bit-field size position newfield n)))))))

(define-prim (##copy-bit-field size position from to)
  (##bitwise-merge
   (##arithmetic-shift (##bit-mask size) position)
   to
   from))

(define-prim (copy-bit-field size position from to)
  (macro-force-vars (size position from to)
    (macro-check-index
      size
      1
      (copy-bit-field size position from to)
      (macro-check-index
        position
        2
        (copy-bit-field size position from to)
        (cond ((##not (macro-exact-int? from))
               (##fail-check-exact-integer 3 copy-bit-field size position from to))
              ((##not (macro-exact-int? to))
               (##fail-check-exact-integer 4 copy-bit-field size position from to))
              (else
               (##copy-bit-field size position from to)))))))

(define-prim (##bit-mask size)
  (##bitwise-not (##arithmetic-shift -1 size)))

;;;----------------------------------------------------------------------------

;;; Fixnum operations
;;; -----------------

(##define-macro (define-prim-fixnum form . special-body)
  (let ((body (if (null? special-body) form `(begin ,@special-body))))
    (cond ((= 1 (length (cdr form)))
           (let* ((name-fn (car form))
                  (name-param1 (cadr form)))
             `(define-prim ,form
                (macro-force-vars (,name-param1)
                  (macro-check-fixnum
                    ,name-param1
                    1
                    ,form
                    ,body)))))
          ((= 2 (length (cdr form)))
           (let* ((name-fn (car form))
                  (name-param1 (cadr form))
                  (name-param2 (caddr form)))
             `(define-prim ,form
                (macro-force-vars (,name-param1 ,name-param2)
                  (macro-check-fixnum
                    ,name-param1
                    1
                    ,form
                    (macro-check-fixnum
                      ,name-param2
                      2
                      ,form
                      ,body))))))
          (else
           (error "define-prim-fixnum supports only 1 or 2 parameter procedures")))))

(define-prim (fixnum? obj)
  (macro-force-vars (obj)
    (##fixnum? obj)))

(define-prim-nary-bool (##fx= x y)
  #t
  #t
  (##fx= x y)
  macro-no-force
  macro-no-check)

(define-prim-nary-bool (fx= x y)
  #t
  #t
  (##fx= x y)
  macro-force-vars
  macro-check-fixnum)

(define-prim-nary-bool (##fx< x y)
  #t
  #t
  (##fx< x y)
  macro-no-force
  macro-no-check)

(define-prim-nary-bool (fx< x y)
  #t
  #t
  (##fx< x y)
  macro-force-vars
  macro-check-fixnum)

(define-prim-nary-bool (##fx> x y)
  #t
  #t
  (##fx> x y)
  macro-no-force
  macro-no-check)

(define-prim-nary-bool (fx> x y)
  #t
  #t
  (##fx> x y)
  macro-force-vars
  macro-check-fixnum)

(define-prim-nary-bool (##fx<= x y)
  #t
  #t
  (##fx<= x y)
  macro-no-force
  macro-no-check)

(define-prim-nary-bool (fx<= x y)
  #t
  #t
  (##fx<= x y)
  macro-force-vars
  macro-check-fixnum)

(define-prim-nary-bool (##fx>= x y)
  #t
  #t
  (##fx>= x y)
  macro-no-force
  macro-no-check)

(define-prim-nary-bool (fx>= x y)
  #t
  #t
  (##fx>= x y)
  macro-force-vars
  macro-check-fixnum)

(define-prim (##fxzero? x))

(define-prim-fixnum (fxzero? x)
  (##fxzero? x))

(define-prim (##fxpositive? x))

(define-prim-fixnum (fxpositive? x)
  (##fxpositive? x))

(define-prim (##fxnegative? x))

(define-prim-fixnum (fxnegative? x)
  (##fxnegative? x))

(define-prim (##fxodd? x))

(define-prim-fixnum (fxodd? x)
  (##fxodd? x))

(define-prim (##fxeven? x))

(define-prim-fixnum (fxeven? x)
  (##fxeven? x))

(define-prim-nary (##fxmax x y)
  ()
  x
  (##fxmax x y)
  macro-no-force
  macro-no-check)

(define-prim-nary (fxmax x y)
  ()
  x
  (##fxmax x y)
  macro-force-vars
  macro-check-fixnum)

(define-prim-nary (##fxmin x y)
  ()
  x
  (##fxmin x y)
  macro-no-force
  macro-no-check)

(define-prim-nary (fxmin x y)
  ()
  x
  (##fxmin x y)
  macro-force-vars
  macro-check-fixnum)

(define-prim-nary (##fxwrap+ x y)
  0
  x
  (##fxwrap+ x y)
  macro-no-force
  macro-no-check)

(define-prim-nary (fxwrap+ x y)
  0
  x
  (##fxwrap+ x y)
  macro-force-vars
  macro-check-fixnum)

(define-prim-nary (##fx+ x y)
  0
  x
  (##fx+ x y)
  macro-no-force
  macro-no-check)

(define-prim-nary (fx+ x y)
  0
  x
  (##fx+? x y)
  macro-force-vars
  macro-check-fixnum
  (##not ##raise-fixnum-overflow-exception))

(define-prim (##fx+? x y))

(define-prim-nary (##fxwrap* x y)
  1
  x
  (##fxwrap* x y)
  macro-no-force
  macro-no-check)

(define-prim-nary (fxwrap* x y)
  1
  x
  (##fxwrap* x y)
  macro-force-vars
  macro-check-fixnum)

(define-prim-nary (##fx* x y)
  1
  x
  (##fx* x y)
  macro-no-force
  macro-no-check)

(define-prim-nary (fx* x y)
  1
  x
  ((lambda (x y)
     (cond ((##fx= y 0)
            0)
           ((##fx= y -1)
            (##fx-? x))
           (else
            (##fx*? x y))))
   x
   y)
  macro-force-vars
  macro-check-fixnum
  (##not ##raise-fixnum-overflow-exception))

(define-prim (##fx*? x y))

(define-prim-nary (##fxwrap- x y)
  ()
  (##fxwrap- x)
  (##fxwrap- x y)
  macro-no-force
  macro-no-check)

(define-prim-nary (fxwrap- x y)
  ()
  (##fxwrap- x)
  (##fxwrap- x y)
  macro-force-vars
  macro-check-fixnum)

(define-prim-nary (##fx- x y)
  ()
  (##fx- x)
  (##fx- x y)
  macro-no-force
  macro-no-check)

(define-prim-nary (fx- x y)
  ()
  (##fx-? x)
  (##fx-? x y)
  macro-force-vars
  macro-check-fixnum
  (##not ##raise-fixnum-overflow-exception))

(define-prim (##fx-? x #!optional (y (macro-absent-obj)))
  (if (##eq? y (macro-absent-obj))
      (##fx-? x)
      (##fx-? x y)))

(define-prim (##fxwrapquotient x y))

(define-prim-fixnum (fxwrapquotient x y)
  (if (##fx= y 0)
      (##raise-divide-by-zero-exception fxwrapquotient x y)
      (##fxwrapquotient x y)))

(define-prim (##fxquotient x y))

(define-prim-fixnum (fxquotient x y)
  (if (##fx= y 0)
      (##raise-divide-by-zero-exception fxquotient x y)
      (if (##fx= y -1)
          (or (##fx-? x)
              (##raise-fixnum-overflow-exception fxquotient x y))
          (##fxquotient x y))))

(define-prim (##fxremainder x y))

(define-prim-fixnum (fxremainder x y)
  (if (##fx= y 0)
      (##raise-divide-by-zero-exception fxremainder x y)
      (##fxremainder x y)))

(define-prim (##fxmodulo x y))

(define-prim-fixnum (fxmodulo x y)
  (if (##fx= y 0)
      (##raise-divide-by-zero-exception fxmodulo x y)
      (##fxmodulo x y)))

(define-prim (##fxnot x)
  (##fx- -1 x))

(define-prim-fixnum (fxnot x)
  (##fxnot x))

(define-prim-nary (##fxand x y)
  -1
  x
  (##fxand x y)
  macro-no-force
  macro-no-check)

(define-prim-nary (fxand x y)
  -1
  x
  (##fxand x y)
  macro-force-vars
  macro-check-fixnum)

(define-prim-nary (##fxior x y)
  0
  x
  (##fxior x y)
  macro-no-force
  macro-no-check)

(define-prim-nary (fxior x y)
  0
  x
  (##fxior x y)
  macro-force-vars
  macro-check-fixnum)

(define-prim-nary (##fxxor x y)
  0
  x
  (##fxxor x y)
  macro-no-force
  macro-no-check)

(define-prim-nary (fxxor x y)
  0
  x
  (##fxxor x y)
  macro-force-vars
  macro-check-fixnum)

(define-prim (##fxif x y z))

(define-prim (fxif x y z)
  (macro-force-vars (x y z)
    (macro-check-fixnum
      x
      1
      (fxif x y z)
      (macro-check-fixnum
        y
        2
        (fxif x y z)
        (macro-check-fixnum
          z
          3
          (fxif x y z)
          (##fxif x y z))))))

(define-prim (##fxbit-count x))

(define-prim (fxbit-count x)
  (macro-force-vars (x)
    (macro-check-fixnum
      x
      1
      (fxbit-count x)
      (##fxbit-count x))))

(define-prim (##fxlength x))

(define-prim (fxlength x)
  (macro-force-vars (x)
    (macro-check-fixnum
      x
      1
      (fxlength x)
      (##fxlength x))))

(define-prim (##fxfirst-bit-set x))

(define-prim (fxfirst-bit-set x)
  (macro-force-vars (x)
    (macro-check-fixnum
      x
      1
      (fxfirst-bit-set x)
      (##fxfirst-bit-set x))))

(define-prim (##fxbit-set? x y))

(define-prim (fxbit-set? x y)
  (macro-force-vars (x y)
    (macro-check-fixnum-range-incl
      x
      1
      0
      ##fixnum-width
      (fxbit-set? x y)
      (macro-check-fixnum
        y
        2
        (fxbit-set? x y)
        (##fxbit-set? x y)))))

(define-prim (##fxwraparithmetic-shift x y))

(define-prim (fxwraparithmetic-shift x y)
  (macro-force-vars (x y)
    (macro-check-fixnum
      x
      1
      (fxwraparithmetic-shift x y)
      (macro-check-fixnum-range-incl
        y
        2
        ##fixnum-width-neg
        ##fixnum-width
        (fxwraparithmetic-shift x y)
        (##fxwraparithmetic-shift x y)))))

(define-prim (##fxarithmetic-shift x y))

(define-prim-fixnum (fxarithmetic-shift x y)
  (or (##fxarithmetic-shift? x y)
      (##raise-fixnum-overflow-exception fxarithmetic-shift x y)))

(define-prim (##fxarithmetic-shift? x y))

(define-prim (##fxwraparithmetic-shift-left x y))

(define-prim (fxwraparithmetic-shift-left x y)
  (macro-force-vars (x y)
    (macro-check-fixnum
      x
      1
      (fxwraparithmetic-shift-left x y)
      (macro-check-fixnum-range-incl
        y
        2
        0
        ##fixnum-width
        (fxwraparithmetic-shift-left x y)
        (##fxwraparithmetic-shift-left x y)))))

(define-prim (##fxarithmetic-shift-left x y))

(define-prim-fixnum (fxarithmetic-shift-left x y)
  (or (##fxarithmetic-shift-left? x y)
      (if (##fx< y 0)
          (##raise-range-exception 2 fxarithmetic-shift-left x y)
          (##raise-fixnum-overflow-exception fxarithmetic-shift-left x y))))

(define-prim (##fxarithmetic-shift-left? x y))

(define-prim (##fxarithmetic-shift-right x y))

(define-prim-fixnum (fxarithmetic-shift-right x y)
  (or (##fxarithmetic-shift-right? x y)
      (##raise-range-exception 2 fxarithmetic-shift-right x y)))

(define-prim (##fxarithmetic-shift-right? x y))

(define-prim (##fxwraplogical-shift-right x y))

(define-prim-fixnum (fxwraplogical-shift-right x y)
  (or (##fxwraplogical-shift-right? x y)
      (##raise-range-exception 2 fxwraplogical-shift-right x y)))

(define-prim (##fxwraplogical-shift-right? x y))

(define-prim (##fxwrapabs x))

(define-prim-fixnum (fxwrapabs x)
  (##fxwrapabs x))

(define-prim (##fxabs x))

(define-prim-fixnum (fxabs x)
  (or (##fxabs? x)
      (##raise-fixnum-overflow-exception fxabs x)))

(define-prim (##fxabs? x))

(define-prim (##fxwrapsquare x))

(define-prim-fixnum (fxwrapsquare x)
  (##fxwrapsquare x))

(define-prim (##fxsquare x))

(define-prim-fixnum (fxsquare x)
  (or (##fxsquare? x)
      (##raise-fixnum-overflow-exception fxsquare x)))

(define-prim (##fxsquare? x))

(define-prim (##integer->char x))
(define-prim (##char->integer x))

;;; ------------------------------------------------------------------------------
;;; Bignum Operations
;;; ------------------------------------------------------------------------------
;;;
;;; The bignum operations were implemented mostly by Brad Lucier
;;; (http://www.math.purdue.edu/~lucier) with some coding guidance from
;;; Marc Feeley.
;;;
;;; The low-level representation of bignums and the low-level operations on
;;; bignums are inspired by the paper
;;;
;;; Reconfigurable, retargetable bignums:
;;; a case study in efficient, portable Lisp system building
;;; Jon L White
;;; Conference on LISP and Functional Programming
;;; Proceedings of the 1986 ACM conference on LISP and functional programming
;;; Cambridge, Massachusetts, United States
;;; Pages: 174 - 191
;;; Year of Publication: 1986
;;; ISBN:0-89791-200-4
;;;
;;; We describe here the representation for the C back end.  See _univlib.scm for
;;; other back ends.
;;;
;;; Bignums are represented as vectors of "adigit"s.  Each element is an unsigned
;;; integer containing ##bignum.adigit-width bits, which is 64 bits if a 64-bit
;;; type is available (either as long or as long long).  Logically, the 0th adigit
;;; of a bignum contains its least-significant bits; bignums are little-endian,
;;; and the top bit of the last adigit is interpreted as the sign bit of the bignum.
;;; Before being returned to the user, bignums must be normalized so that they have
;;; no redundant all-zero or all-one high-order adigits.  Adigits are so called
;;; because they're used in addition (among other operations).  For the purpose of
;;; documentation we'll use "adigit-base" to represent (expt 2 ##bignum.adigit-width).
;;;
;;; The bits of a bignum can be accessed as a vector of "mdigit"s, which are
;;; unsigned integers containing ##bignum.mdigit-width bits, which is 16 bits
;;; on a 32-bit Gambit or 32 bits on a 64-bit Gambit (so an mdigit always fits
;;; in a fixnum).  Mdigits are so called because they're used in multiplciation
;;; (among other operations). For the purpose of documentation we'll use "mdigit-base"
;;; to represent (expt 2 ##bignum.mdigit-width).
;;;
;;; Finally, the bits of a bignum can be accessed as a vector of "fdigit"s,
;;; which are unsigned integers containing ##bignum.fdigit-width bits, which
;;; is currently 8 on all architectures.  Fdigits are so called because a
;;; bignum is represented as fdigits before the Fast Fourier Transforms used
;;; in large bignum multiplications are performed.  Some comments indicate that for
;;; bignums of larger than half a billion bits, four-bit fdigits may be useful, but that
;;; isn't implemented.
;;;
;;; The global variables ##bignum.adigit-width, ##bignum.mdigit-width, and
;;; ##bignum.fdigit-width are defined in _kernel.scm.
;;;
;;; All issues of big-endian or little-endian accesses are taken care of in the
;;; C macros implementing the low-level operations, so we can program as if we're
;;; on a little-endian machine.
;;;
;;; -------------------------------------------------------------------------------

;;; These are the low-level operations on adigits, mdigits, and fdigits.
;;; Two-argument functions are generally destructive, and overwrite part of
;;; their first argument.  These operations are supported in the Gambit Virtual
;;; Machine (GVM) and the Gambit Scheme Compiler (gsc).

;;; Returns #t if x is negative, #f otherwise
(define-prim (##bignum.negative? x))

;;; Returns the number of adigits in x (always a fixnum)
(define-prim (##bignum.adigit-length x))

;;; Increments the i'th adigit of x by 1 and returns 1 if the result
;;; overflowed, and 0 otherwise.
(define-prim (##bignum.adigit-inc! x i))

;;; Decrements the i'th digit of x by 1 and returns 1 if the result
;;; underflowed and 0 otherwise.
(define-prim (##bignum.adigit-dec! x i))

;;; Calculate
;;; sum = x[i] + y[j] + carry (accessing x and y as adigits)
;;; Sets x[i] = sum modulo adigit-base; returns 1 if overflow occured,
;;; 0 otherwise.
(define-prim (##bignum.adigit-add! x i y j carry))

;;; Calculate
;;; difference = x[i] - y[j] - borrow (accessing x and y as adigits)
;;; Sets x[i] = difference modulo adigit-base; returns 1 if underflow occured,
;;; 0 otherwise.
(define-prim (##bignum.adigit-sub! x i y j borrow))

;;; Returns the number of mdigits in x (always a fixnum)
(define-prim (##bignum.mdigit-length x))

;;; Returns the i'th mdigit of x
(define-prim (##bignum.mdigit-ref x i))

;;; Sets the i'th mdigit of x to mdigit
(define-prim (##bignum.mdigit-set! x i mdigit))

;;; Calculate
;;; z = x[i] + y[j] * multiplier + carry (accessing x and y as mdigits)
;;; Sets x[i] = z modulo mdigit-base; returns (quotient z mdigit-base)
(define-prim (##bignum.mdigit-mul! x i y j multiplier carry))

;;; Calculate
;;; z = x[i] - y[j] * quotient + borrow
;;; Sets x[i] to z modulo mdigit-base; returns
;;; (quotient (z - x[i]) mdigit-base)
(define-prim (##bignum.mdigit-div! x i y j quotient borrow))

;;; Returns
;;; (u[j] * mdigit-base + u[j-1]) / v
;;; (accessing u as mdigits)
(define-prim (##bignum.mdigit-quotient u j v_n-1))

;;; Returns
;;; (u[j] * mdigit-base + u[j-1] - v_n-1 * q-hat)
;;; (accessing u as mdigits)
(define-prim (##bignum.mdigit-remainder u j v_n-1 q-hat))

;;; Returns #t if
;;; q-hat * v_n-2 > (r-hat * mdigit-base + u_j-2)
;;; and #f otherwise
(define-prim (##bignum.mdigit-test? q-hat v_n-2 r-hat u_j-2))

;;; Returns #t if x[i] (accessed as adigits) is all ones, and
;;; #f otherwise
(define-prim (##bignum.adigit-ones? x i))

;;; Returns #t if x[i] (accessed as adigits) is all zeros, and
;;; #f otherwise
(define-prim (##bignum.adigit-zero? x i))

;;; Returns #t if the high-order bit of x[i] (accessing x as
;;; adigits) is 1, and #f otherwise
(define-prim (##bignum.adigit-negative? x i))

;;; Returns #t if x[i]=y[i] (accessing x and y as adigits) and
;;; #f otherwise
(define-prim (##bignum.adigit-= x y i))

;;; Returns #t if x[i]<y[i] (accessing x and y as adigits) and
;;; #f otherwise
(define-prim (##bignum.adigit-< x y i))

;;; Convert the fixnum x to an (unnormalized) bignum with one adigit
(define-prim (##fixnum->bignum x))

;;; Sets the number of adigits in the bignum x to n; must not increase
;;; the number of adigits in x
(define-prim (##bignum.adigit-shrink! x n))

;;; Sets x[i] to y[j] (accessing x and y as adigits)
(define-prim (##bignum.adigit-copy! x i y j))

;;; Calculate
;;; z = hi[j] << divider | lo[k] >> (##bignum.adigit-width - divider)
;;; (accessing hi and lo as adigits)
;;; Sets x[i] to z modulo adigit-base
(define-prim (##bignum.adigit-cat! x i hi j lo k divider))

;;; Sets x[i] to x[i] & y[j] (accessing x and y as adigits)
(define-prim (##bignum.adigit-bitwise-and! x i y j))

;;; Sets x[i] to x[i] | y[j] (accessing x and y as adigits)
(define-prim (##bignum.adigit-bitwise-ior! x i y j))

;;; Sets x[i] to x[i] ^ y[j] (accessing x and y as adigits)
(define-prim (##bignum.adigit-bitwise-xor! x i y j))

;;; Sets x[i] to !x[i] (accessing x as adigits)
(define-prim (##bignum.adigit-bitwise-not! x i))

(macro-case-target
 ((C)
  ;; Returns the number of fdigits in x
  (define-prim (##bignum.fdigit-length x))

  ;; Returns x[i] (accessing x as fdigits)
  (define-prim (##bignum.fdigit-ref x i))

  ;; Sets x[i] to fdigit (accessing x as fdigits)
  (define-prim (##bignum.fdigit-set! x i fdigit))))

;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

;;; Bignum related constants.

(define ##bignum.adigit-ones (##fixnum->bignum -1))           ;; the 0th adigit is all ones
(define ##bignum.adigit-zeros (##fixnum->bignum 0))           ;; the 0th adigit is all zeros

(macro-case-target
 ((C)
  (define ##bignum.fdigit-base
    (##fxarithmetic-shift-left 1 ##bignum.fdigit-width))))

(define ##bignum.mdigit-base
  (##fxarithmetic-shift-left 1 ##bignum.mdigit-width))

(define ##bignum.inexact-mdigit-base
  (##fixnum->flonum ##bignum.mdigit-base))

(define ##bignum.mdigit-base-minus-1
  (##fx- ##bignum.mdigit-base 1))

(define ##bignum.minus-mdigit-base
  (##fx- ##bignum.mdigit-base))

(define ##bignum.max-fixnum-div-mdigit-base
  (##fxquotient ##max-fixnum ##bignum.mdigit-base))

(define ##bignum.min-fixnum-div-mdigit-base
  (##fxquotient ##min-fixnum ##bignum.mdigit-base))

(define ##bignum.2*min-fixnum
  (if (##fixnum? -1073741824)
      -4611686018427387904 ;; (- (expt 2 62))
      -1073741824))        ;; (- (expt 2 30))

;;; The following global variables control when each of the three
;;; multiplication algorithms are used.
;;;
;;; Naive (grade-school) multiplication is used as long as one of
;;; the arguments has fewer than ##bignum.naive-mul-max-width
;;; bits.
;;;
;;; Karatsuba multiplication is used if the smaller of the two
;;; multiplication arguments has fewer than ##bignum.fft-mul-min-width
;;; or the larger of the two arguments has more than
;;; ##bignum.fft-mul-max-width bits
;;;
;;; For other sizes of the arguments use FFT multiplication.
;;;
;;; A "fast", reciprocal-based division is used if the divisor has
;;; more than ##bignum.fft-mul-min-width bits and the difference in
;;; size of the divident and divisor is more than
;;; ##bignum.fft-mul-min-width bits.
;;;
;;; Note that these global variables are not constants that are
;;; inlined, so one can change them if you like.

(define ##bignum.naive-mul-max-width 1400)
(set! ##bignum.naive-mul-max-width ##bignum.naive-mul-max-width)

(define ##bignum.fft-mul-min-width 20000)
(set! ##bignum.fft-mul-min-width ##bignum.fft-mul-min-width)

(define ##bignum.fft-mul-max-width
  (if (##fixnum? -1073741824) ;; #t iff using 64-bit fixnums
      536870912
       ;; to avoid creating f64vectors that are too long
      4194304))
(set! ##bignum.fft-mul-max-width ##bignum.fft-mul-max-width)

;;; An O(N(\log N)^2) algorithm for GCD is used if both arguments have more
;;; than ##bignum.fast-gcd-size bits

(define ##bignum.fast-gcd-size ##bignum.naive-mul-max-width)  ;; must be >= 64
(set! ##bignum.fast-gcd-size ##bignum.fast-gcd-size)

;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

;;; Operations where arguments are in bignum format

(define-prim (##bignum.make k x complement?)
  (##declare (not interrupts-enabled))
  (let ((v (##c-code "
___SIZE_TS i;
___SIZE_TS n = ___INT(___ARG1);
___SCMOBJ result;

if (n > ___CAST(___WORD, ___LMASK>>___LF)/(___BIG_ABASE_WIDTH/8))
  result = ___FIX(___HEAP_OVERFLOW_ERR); /* requested object is too big! */
else
  {
#if ___BIG_ABASE_WIDTH == 32
    ___SIZE_TS words = ___WORDS((n*(___BIG_ABASE_WIDTH/8))) + 1;
#else
#if ___WS == 4
    ___SIZE_TS words = ___WORDS((n*(___BIG_ABASE_WIDTH/8))) + 2;
#else
    ___SIZE_TS words = ___WORDS((n*(___BIG_ABASE_WIDTH/8))) + 1;
#endif
#endif
    if (words > ___MSECTION_BIGGEST)
      {
        ___FRAME_STORE_RA(___R0)
        ___W_ALL
#if ___BIG_ABASE_WIDTH == 32
        result = ___EXT(___alloc_scmobj) (___ps, ___sBIGNUM, n<<2);
#else
        result = ___EXT(___alloc_scmobj) (___ps, ___sBIGNUM, n<<3);
#endif
        ___R_ALL
        ___SET_R0(___FRAME_FETCH_RA)
        if (!___FIXNUMP(result))
          ___still_obj_refcount_dec (result);
      }
    else
      {
        ___BOOL overflow = 0;
        ___hp += words;
        if (___hp > ___ps->heap_limit)
          {
            ___FRAME_STORE_RA(___R0)
            ___W_ALL
            overflow = ___heap_limit (___PSPNC) && ___garbage_collect (___PSP 0);
            ___R_ALL
            ___SET_R0(___FRAME_FETCH_RA)
          }
        else
          ___hp -= words;
        if (overflow)
          result = ___FIX(___HEAP_OVERFLOW_ERR);
        else
          {
#if ___BIG_ABASE_WIDTH == 32
            result = ___TAG(___hp, ___tSUBTYPED);
#else
#if ___WS == 4
            result = ___TAG(___CAST(___SCMOBJ*,___CAST(___SCMOBJ,___hp+2)&~7)-1,
                            ___tSUBTYPED);
#else
            result = ___TAG(___hp, ___tSUBTYPED);
#endif
#endif
#if ___BIG_ABASE_WIDTH == 32
            ___HEADER(result) = ___MAKE_HD_BYTES((n<<2), ___sBIGNUM);
#else
            ___HEADER(result) = ___MAKE_HD_BYTES((n<<3), ___sBIGNUM);
#endif
            ___hp += words;
          }
      }
  }
if (!___FIXNUMP(result))
  {
    ___SCMOBJ x = ___ARG2;
    ___SCMOBJ len;
    if (x == ___FAL)
      len = 0;
    else
      {
        len = ___INT(___BIGALENGTH(x));
        if (len > n)
          len = n;
      }
#if ___BIG_ABASE_WIDTH == 32
    if (___ARG3 == ___FAL)
      {
        for (i=0; i<len; i++)
          ___STORE_U32(___BODY_AS(result,___tSUBTYPED),i,
                       ___FETCH_U32(___BODY_AS(x,___tSUBTYPED),i));
        if (x != ___FAL &&
            ___FETCH_S32(___BODY_AS(x,___tSUBTYPED),(i-1)) < 0)
          for (; i<n; i++)
            ___STORE_U32(___BODY_AS(result,___tSUBTYPED),i,___BIG_ABASE_MIN_1);
        else
          for (; i<n; i++)
            ___STORE_U32(___BODY_AS(result,___tSUBTYPED),i,0);
      }
    else
      {
        for (i=0; i<len; i++)
          ___STORE_U32(___BODY_AS(result,___tSUBTYPED),i,
                       ~___FETCH_U32(___BODY_AS(x,___tSUBTYPED),i));
        if (x != ___FAL &&
            ___FETCH_S32(___BODY_AS(x,___tSUBTYPED),(i-1)) < 0)
          for (; i<n; i++)
            ___STORE_U32(___BODY_AS(result,___tSUBTYPED),i,0);
        else
          for (; i<n; i++)
            ___STORE_U32(___BODY_AS(result,___tSUBTYPED),i,___BIG_ABASE_MIN_1);
      }
#else
    if (___ARG3 == ___FAL)
      {
        for (i=0; i<len; i++)
          ___STORE_U64(___BODY_AS(result,___tSUBTYPED),i,
                       ___FETCH_U64(___BODY_AS(x,___tSUBTYPED),i));
        if (x != ___FAL &&
            ___FETCH_S64(___BODY_AS(x,___tSUBTYPED),(i-1)) < 0)
          for (; i<n; i++)
            ___STORE_U64(___BODY_AS(result,___tSUBTYPED),i,___BIG_ABASE_MIN_1);
        else
          for (; i<n; i++)
            ___STORE_U64(___BODY_AS(result,___tSUBTYPED),i,0);
      }
    else
      {
        for (i=0; i<len; i++)
          ___STORE_U64(___BODY_AS(result,___tSUBTYPED),i,
                       ~___FETCH_U64(___BODY_AS(x,___tSUBTYPED),i));
        if (x != ___FAL &&
            ___FETCH_S64(___BODY_AS(x,___tSUBTYPED),(i-1)) < 0)
          for (; i<n; i++)
            ___STORE_U64(___BODY_AS(result,___tSUBTYPED),i,0);
        else
          for (; i<n; i++)
            ___STORE_U64(___BODY_AS(result,___tSUBTYPED),i,___BIG_ABASE_MIN_1);
      }
#endif
  }
___RESULT = result;
" k x complement?)))
    (if (##fixnum? v)
        (begin
          (##raise-heap-overflow-exception)
          (##bignum.make k x complement?))
        v)))

(define-prim (##bignum.copy x)
  (##bignum.make (##bignum.adigit-length x) x #f))

;;; Bignum addition and subtraction.

(define-prim (##bignum.+ x y)

  ;; x is an unnormalized bignum, y is an unnormalized bignum

  (define (add x x-length y y-length)
    (let* ((result-length
            (##fx+ y-length
                   (if (##eq? (##bignum.negative? x)
                              (##bignum.negative? y))
                       1
                       0)))
           (result
            (##bignum.make result-length y #f)))

      (##declare (not interrupts-enabled))

      (let loop ((i 0)
                 (carry 0))
        (if (##fx< i x-length)
            (loop (##fx+ i 1)
                  (##bignum.adigit-add! result i x i carry))
            (##bignum.propagate-carry-and-normalize!
             result
             result-length
             x-length
             (##bignum.negative? x)
             (##fxzero? carry))))))

  (let ((x-length (##bignum.adigit-length x))
        (y-length (##bignum.adigit-length y)))
    (if (##fx< x-length y-length)
        (add x x-length y y-length)
        (add y y-length x x-length))))

(define-prim (##bignum.- x y)

  ;; x is an unnormalized bignum, y is an unnormalized bignum

  (let ((x-length (##bignum.adigit-length x))
        (y-length (##bignum.adigit-length y)))
    (if (##fx< x-length y-length)

        (let* ((result-length
                (##fx+ y-length
                       (if (##eq? (##bignum.negative? x)
                                  (##bignum.negative? y))
                           0
                           1)))
               (result
                (##bignum.make result-length y #t)))

          (##declare (not interrupts-enabled))

          (let loop1 ((i 0)
                      (carry 1))
            (if (##fx< i x-length)
                (loop1 (##fx+ i 1)
                       (##bignum.adigit-add! result i x i carry))
                (##bignum.propagate-carry-and-normalize!
                 result
                 result-length
                 x-length
                 (##bignum.negative? x)
                 (##fxzero? carry)))))

        (let* ((result-length
                (##fx+ x-length
                       (if (##eq? (##bignum.negative? x)
                                  (##bignum.negative? y))
                           0
                           1)))
               (result
                (##bignum.make result-length x #f)))

          (##declare (not interrupts-enabled))

          (let loop2 ((i 0)
                      (borrow 0))
            (if (##fx< i y-length)
                (loop2 (##fx+ i 1)
                       (##bignum.adigit-sub! result i y i borrow))
                (##bignum.propagate-carry-and-normalize!
                 result
                 result-length
                 y-length
                 (##not (##bignum.negative? y))
                 (##not (##fxzero? borrow)))))))))

(define-prim (##bignum.propagate-carry-and-normalize!
              result
              result-length
              i
              borrow?
              propagate?)

  (##declare (not interrupts-enabled))

  (if (##eq? borrow? propagate?)
      (if borrow?

          (let loop1 ((i i)
                      (borrow 1))
            (if (and (##not (##fxzero? borrow))
                     (##fx< i result-length))
                (loop1 (##fx+ i 1)
                       (##bignum.adigit-dec! result i))
                (##bignum.normalize! result)))

          (let loop2 ((i i)
                      (carry 1))
            (if (and (##not (##fxzero? carry))
                     (##fx< i result-length))
                (loop2 (##fx+ i 1)
                       (##bignum.adigit-inc! result i))
                (##bignum.normalize! result))))

      (##bignum.normalize! result)))

(define-prim (##bignum->fixnum? bn)
  (let* ((i
          (##fx- (##bignum.mdigit-length bn) 1))
         (n
          (##bignum.mdigit-ref bn i))
         (bias
          (if (##fx< (##fx* 2 n) ##bignum.mdigit-base)
              0
              ##bignum.mdigit-base-minus-1)))
    (let loop ((n (##fx- n bias))
               (i (##fx- i 1)))
      (if (##fx< i 0)
          (if (##fx= 0 bias)
              n
              (##fx+? n -1))
          (let ((n1 (##fx*? n ##bignum.mdigit-base)))
            (and n1
                 (let ((n2 (##fx+? n1 (##fx- (##bignum.mdigit-ref bn i) bias))))
                   (and n2
                        (loop n2
                              (##fx- i 1))))))))))

(define-prim (##bignum.normalize! result)

  (##declare (not interrupts-enabled))

  (or (##bignum->fixnum? result)

      (let ((n (##fx- (##bignum.adigit-length result) 1)))

        (cond ((##bignum.adigit-zero? result n)
               (let loop1 ((i (##fx- n 1)))
                 (cond ((##fx< i 0)
                        0)
                       ((##bignum.adigit-zero? result i)
                        (loop1 (##fx- i 1)))
                       ((##bignum.adigit-negative? result i)
                        (##bignum.adigit-shrink! result (##fx+ i 2)))
                       (else
                        (##bignum.adigit-shrink! result (##fx+ i 1))))))

              ((##bignum.adigit-ones? result n)
               (let loop2 ((i (##fx- n 1)))
                 (cond ((##fx< i 0)
                        -1)
                       ((##bignum.adigit-ones? result i)
                        (loop2 (##fx- i 1)))
                       ((##not (##bignum.adigit-negative? result i))
                        (##bignum.adigit-shrink! result (##fx+ i 2)))
                       (else
                        (##bignum.adigit-shrink! result (##fx+ i 1))))))

              (else
               result)))))

;;; Bignum multiplication.

(define-prim (##bignum.* x y)

  (define (fft-mul x y)

    ;; Marc, the results of make-w should be cached, since bigger
    ;; tables can be used for any smaller size FFT.

    ;; This code works for x and y up to 536,870,912 bits, with
    ;; results up to 1Gb; numbers of this size require 8Gb, or 1GB, of
    ;; intermediate storage. It is always faster than the old code,
    ;; and it is mathematically correct.  (Whether it is
    ;; programmatically correct is, of course, another matter, but I
    ;; have tested it extensively.)

    ;; This is an experiment.

    ;; This code implements bignum multiplication based on
    ;; double-precision FFT computations rather than on
    ;; number-theoretic FFTs and the Chinese remainder theorem.

    ;; The theory is in the article

    ;; Rapid multiplication modulo the sum and difference of highly
    ;; composite numbers, by Colin Percival

    ;; The complex roots of unity ("twiddle factors") need to be
    ;; computed in such a way that there is a known bound on the
    ;; error.  I did this with a "computable reals" package I wrote.
    ;; I did not know a bound for the roots of unity in Ooura's FFT,
    ;; which is what we previously used..

    ;; If you use a different complex FFT, then you need to ensure
    ;; that the same operations are done as in this FFT (perhaps in a
    ;; somewhat different order), or that you prove the corresponding
    ;; theorem for your FFT that Percival proved in his paper.  On a
    ;; 2GHz PPC 970, my complex FFT seems to be about half as fast as
    ;; FFTW's complex FFT, so that doesn't seem too bad for one
    ;; written by hand in Scheme.

    ;; After years of fiddling around, I finally understook the
    ;; weighted FT transform and the so-called right-angle
    ;; convolution.  See section 8.3.2 the book "Algorithms for
    ;; Programmers" by Jo"rg Arndt, currently available at
    ;; www.jjj.de/fxt/fxtbook.pdf for a description of the right-angle
    ;; transform.  It's also covered in "Prime Numbers" by Crandall
    ;; and Pomerance, and was originally introduced in 1994 by
    ;; Crandall and Fagin.

    ;; The basic reference for the fft codes is
    ;; {\it Inside the FFT Black Box,} by Eleanor Chu and Alan George,
    ;; CRC Press, New York, 2000.  In the end, I should say that these
    ;; codes are just motivated by this book.

    ;; One of the biggest problem in translating their notation is
    ;; that they work with complex numbers, and we're working with
    ;; pairs of reals.  Let us assume that all complex numbers are
    ;; stored with adjacent real and imaginary parts, real first.

    #|

    The strategy in the next function is to calculate a 2^n'th
    root of unity by multiplying entries from up to three look-up
    tables, each of which has lut-table-size complex entries, stored
    as pairs of f64s.  Each of the tables contains correctly-rounded
    complex roots of unity, as computed by my computable-reals code.

    The j'th entry of the first table is

    exp(\pi/2 * i * (bit-reverse j log-lut-table-size)/lut-table-size),  j = 0,...,lut-table-size - 1.

    where (bit-reverse j k) reverses the bits of j when
    considered as a bit string of length k.

    The j'th entry of the second table is

    exp(\pi/2 * i * j/lut-table-size^2), j = 0,...,lut-table-size-1

    and the j'th entry in the third table is

    exp(\pi/2 * i * j/lut-table-size^3), j = 0,...,lut-table-size-1

    From these three tables we construct a lut w in bit-reverse
    order of size 2^log-n.

    Any table we construct is also usable for ffts of a smaller size.

    The errors in the tables are as follows.

    When log-lut-table-size=10, we have the error in the first
    table is bounded by

    7.241394152931137e-17

    Theoretically, it should be bounded by

    > (* (sqrt 1/2) (expt 2. -53))
    7.850462293418875e-17

    The maximum error in the product of the first two tables is bounded by

    2.5438950740364204e-16

    The error in the general product of two correctly-rounded
    complex floating-point numbers of magnitude one is bounded by

    > (* (+ (sqrt 5) (sqrt 1/2) (sqrt 1/2)) (expt 2. -53))
    4.052626611931048e-16

    but what we're seeing here is that the entries of the second
    table have real part close to 1 and imaginary part <
    pi/2*2^{-10}, so (a) the error in the entries of the second table
    is much closer to 1/2 epsilon rather than (sqrt 1/2) epsilon,
    and (2) we might expect an error of about sqrt(2)epsilon in the
    complex product instead of the general result of sqrt(5)epsilon,
    or

    > (* (+ (sqrt 2) (sqrt 1/2) 1/2) (expt 2. -53))
    2.910250200338241e-16

    The maximum error in the product of entries from all three tables is

    4.158491068379826e-16

    which we can plug into the error bounds.  Using the above
    heuristics, we would expect it to be <

    > (* (+ (sqrt 2) (sqrt 2) (sqrt 1/2) 1/2 1/2) (expt 2. -53))
    5.035454171334594e-16

    and we have the general bound of

    > (* (+ (* 2 (sqrt 5)) (* 3 (sqrt 1/2))) (expt 2. -53))
    7.320206994520208e-16

    so I'm glad I measured it.

    And, yes, I waited six days to compute the difference between
    the computed roots of unity and the exact roots of unity for all
    2^{30} products from the three tables.

    When log-lut-table-size=9, the corresponding maximum errors are

    7.113686303921851e-17

    for entries in the first table,

    2.4506454051660923e-16

    for products of entries in the first two tables, and

    4.164343159519809e-16

    for products from all three tables.

    Added later:

    We could try a different strategy here.

    If it's necessary to multiply entries of all three tables to populate
    the result, we multiply the entries from the last two tables first to
    get a multiplier.  Because the real parts of the second and third table
    entries are nearly one and the imaginary parts are < 2^{-9} or so, the
    rounding error in each entry is about 1/2 epsilon instead of (sqrt 1/2)
    epsilon, and the biggest error in the product is 1/2 epsilon in the
    product of the real parts and then another 1/2 epsilon when subtracting
    the product of the imaginary parts.  So the total error is about

    (* (+ 1/2 1/2 1/2 1/2) (expt 2 -53))

    or 2.220446049250313e-16.

    The final product adds further error of (sqrt 1/2) epsilon in the
    entries in the first table and then (sqrt 2) epsilon in the product.
    So my guess is that the total error in the product of three entries
    from the table will be bounded by

    (* (+ 1/2 1/2 1/2 1/2 (sqrt 1/2) (sqrt 2)) (expt 2 -53))

    or 4.575584737275976e-16.

    |#

    (define lut-table-size 512)
    (define lut-table-size^2 262144)
    (define lut-table-size^3 134217728)
    (define log-lut-table-size 9)

    (define low-lut
    '#f64(1. 0.
       .7071067811865476 .7071067811865476
       .9238795325112867 .3826834323650898
       .3826834323650898 .9238795325112867
       .9807852804032304 .19509032201612828
       .5555702330196022 .8314696123025452
       .8314696123025452 .5555702330196022
       .19509032201612828 .9807852804032304
       .9951847266721969 .0980171403295606
       .6343932841636455 .773010453362737
       .881921264348355 .47139673682599764
       .2902846772544624 .9569403357322088
       .9569403357322088 .2902846772544624
       .47139673682599764 .881921264348355
       .773010453362737 .6343932841636455
       .0980171403295606 .9951847266721969
       .9987954562051724 .049067674327418015
       .6715589548470184 .7409511253549591
       .9039892931234433 .4275550934302821
       .33688985339222005 .9415440651830208
       .970031253194544 .2429801799032639
       .5141027441932218 .8577286100002721
       .8032075314806449 .5956993044924334
       .14673047445536175 .989176509964781
       .989176509964781 .14673047445536175
       .5956993044924334 .8032075314806449
       .8577286100002721 .5141027441932218
       .2429801799032639 .970031253194544
       .9415440651830208 .33688985339222005
       .4275550934302821 .9039892931234433
       .7409511253549591 .6715589548470184
       .049067674327418015 .9987954562051724
       .9996988186962042 .024541228522912288
       .6895405447370669 .7242470829514669
       .9142097557035307 .40524131400498986
       .35989503653498817 .9329927988347388
       .9757021300385286 .2191012401568698
       .5349976198870973 .8448535652497071
       .8175848131515837 .5758081914178453
       .17096188876030122 .9852776423889412
       .99247953459871 .1224106751992162
       .6152315905806268 .7883464276266062
       .8700869911087115 .49289819222978404
       .26671275747489837 .9637760657954398
       .9495281805930367 .31368174039889146
       .4496113296546066 .8932243011955153
       .7572088465064846 .6531728429537768
       .07356456359966743 .9972904566786902
       .9972904566786902 .07356456359966743
       .6531728429537768 .7572088465064846
       .8932243011955153 .4496113296546066
       .31368174039889146 .9495281805930367
       .9637760657954398 .26671275747489837
       .49289819222978404 .8700869911087115
       .7883464276266062 .6152315905806268
       .1224106751992162 .99247953459871
       .9852776423889412 .17096188876030122
       .5758081914178453 .8175848131515837
       .8448535652497071 .5349976198870973
       .2191012401568698 .9757021300385286
       .9329927988347388 .35989503653498817
       .40524131400498986 .9142097557035307
       .7242470829514669 .6895405447370669
       .024541228522912288 .9996988186962042
       .9999247018391445 .012271538285719925
       .6983762494089728 .7157308252838187
       .9191138516900578 .3939920400610481
       .37131719395183754 .9285060804732156
       .9783173707196277 .20711137619221856
       .5453249884220465 .8382247055548381
       .8245893027850253 .5657318107836132
       .18303988795514095 .9831054874312163
       .9939069700023561 .11022220729388306
       .6248594881423863 .7807372285720945
       .8760700941954066 .4821837720791228
       .2785196893850531 .9604305194155658
       .9533060403541939 .3020059493192281
       .46053871095824 .8876396204028539
       .765167265622459 .6438315428897915
       .0857973123444399 .996312612182778
       .9981181129001492 .06132073630220858
       .6624157775901718 .7491363945234594
       .8986744656939538 .43861623853852766
       .3253102921622629 .9456073253805213
       .9669764710448521 .25486565960451457
       .5035383837257176 .8639728561215867
       .7958369046088836 .6055110414043255
       .1345807085071262 .99090263542778
       .9873014181578584 .15885814333386145
       .5857978574564389 .8104571982525948
       .8513551931052652 .524589682678469
       .2310581082806711 .9729399522055602
       .937339011912575 .34841868024943456
       .4164295600976372 .9091679830905224
       .7326542716724128 .680600997795453
       .03680722294135883 .9993223845883495
       .9993223845883495 .03680722294135883
       .680600997795453 .7326542716724128
       .9091679830905224 .4164295600976372
       .34841868024943456 .937339011912575
       .9729399522055602 .2310581082806711
       .524589682678469 .8513551931052652
       .8104571982525948 .5857978574564389
       .15885814333386145 .9873014181578584
       .99090263542778 .1345807085071262
       .6055110414043255 .7958369046088836
       .8639728561215867 .5035383837257176
       .25486565960451457 .9669764710448521
       .9456073253805213 .3253102921622629
       .43861623853852766 .8986744656939538
       .7491363945234594 .6624157775901718
       .06132073630220858 .9981181129001492
       .996312612182778 .0857973123444399
       .6438315428897915 .765167265622459
       .8876396204028539 .46053871095824
       .3020059493192281 .9533060403541939
       .9604305194155658 .2785196893850531
       .4821837720791228 .8760700941954066
       .7807372285720945 .6248594881423863
       .11022220729388306 .9939069700023561
       .9831054874312163 .18303988795514095
       .5657318107836132 .8245893027850253
       .8382247055548381 .5453249884220465
       .20711137619221856 .9783173707196277
       .9285060804732156 .37131719395183754
       .3939920400610481 .9191138516900578
       .7157308252838187 .6983762494089728
       .012271538285719925 .9999247018391445
       .9999811752826011 .006135884649154475
       .7027547444572253 .7114321957452164
       .9215140393420419 .3883450466988263
       .37700741021641826 .9262102421383114
       .9795697656854405 .2011046348420919
       .5504579729366048 .83486287498638
       .8280450452577558 .560661576197336
       .18906866414980622 .9819638691095552
       .9945645707342554 .10412163387205457
       .629638238914927 .7768884656732324
       .8790122264286335 .47679923006332214
       .2844075372112718 .9587034748958716
       .9551411683057707 .29615088824362384
       .4659764957679662 .8847970984309378
       .7691033376455796 .6391244448637757
       .09190895649713272 .9957674144676598
       .9984755805732948 .05519524434968994
       .6669999223036375 .745057785441466
       .901348847046022 .43309381885315196
       .33110630575987643 .9435934581619604
       .9685220942744173 .24892760574572018
       .508830142543107 .8608669386377673
       .799537269107905 .600616479383869
       .14065823933284924 .9900582102622971
       .9882575677307495 .15279718525844344
       .5907597018588743 .8068475535437992
       .8545579883654005 .5193559901655896
       .2370236059943672 .9715038909862518
       .9394592236021899 .3426607173119944
       .4220002707997997 .9065957045149153
       .7368165688773699 .6760927035753159
       .04293825693494082 .9990777277526454
       .9995294175010931 .030674803176636626
       .6850836677727004 .7284643904482252
       .9117060320054299 .41084317105790397
       .3541635254204904 .9351835099389476
       .9743393827855759 .22508391135979283
       .5298036246862947 .8481203448032972
       .8140363297059484 .5808139580957645
       .16491312048996992 .9863080972445987
       .9917097536690995 .12849811079379317
       .6103828062763095 .7921065773002124
       .8670462455156926 .49822766697278187
       .2607941179152755 .9653944416976894
       .9475855910177411 .3195020308160157
       .44412214457042926 .8959662497561851
       .7531867990436125 .6578066932970786
       .06744391956366406 .9977230666441916
       .9968202992911657 .07968243797143013
       .6485144010221124 .7612023854842618
       .8904487232447579 .45508358712634384
       .30784964004153487 .9514350209690083
       .9621214042690416 .272621355449949
       .48755016014843594 .8730949784182901
       .7845565971555752 .6200572117632892
       .11631863091190477 .9932119492347945
       .984210092386929 .17700422041214875
       .5707807458869673 .8211025149911046
       .8415549774368984 .5401714727298929
       .21311031991609136 .9770281426577544
       .9307669610789837 .36561299780477385
       .39962419984564684 .9166790599210427
       .7200025079613817 .693971460889654
       .01840672990580482 .9998305817958234
       .9998305817958234 .01840672990580482
       .693971460889654 .7200025079613817
       .9166790599210427 .39962419984564684
       .36561299780477385 .9307669610789837
       .9770281426577544 .21311031991609136
       .5401714727298929 .8415549774368984
       .8211025149911046 .5707807458869673
       .17700422041214875 .984210092386929
       .9932119492347945 .11631863091190477
       .6200572117632892 .7845565971555752
       .8730949784182901 .48755016014843594
       .272621355449949 .9621214042690416
       .9514350209690083 .30784964004153487
       .45508358712634384 .8904487232447579
       .7612023854842618 .6485144010221124
       .07968243797143013 .9968202992911657
       .9977230666441916 .06744391956366406
       .6578066932970786 .7531867990436125
       .8959662497561851 .44412214457042926
       .3195020308160157 .9475855910177411
       .9653944416976894 .2607941179152755
       .49822766697278187 .8670462455156926
       .7921065773002124 .6103828062763095
       .12849811079379317 .9917097536690995
       .9863080972445987 .16491312048996992
       .5808139580957645 .8140363297059484
       .8481203448032972 .5298036246862947
       .22508391135979283 .9743393827855759
       .9351835099389476 .3541635254204904
       .41084317105790397 .9117060320054299
       .7284643904482252 .6850836677727004
       .030674803176636626 .9995294175010931
       .9990777277526454 .04293825693494082
       .6760927035753159 .7368165688773699
       .9065957045149153 .4220002707997997
       .3426607173119944 .9394592236021899
       .9715038909862518 .2370236059943672
       .5193559901655896 .8545579883654005
       .8068475535437992 .5907597018588743
       .15279718525844344 .9882575677307495
       .9900582102622971 .14065823933284924
       .600616479383869 .799537269107905
       .8608669386377673 .508830142543107
       .24892760574572018 .9685220942744173
       .9435934581619604 .33110630575987643
       .43309381885315196 .901348847046022
       .745057785441466 .6669999223036375
       .05519524434968994 .9984755805732948
       .9957674144676598 .09190895649713272
       .6391244448637757 .7691033376455796
       .8847970984309378 .4659764957679662
       .29615088824362384 .9551411683057707
       .9587034748958716 .2844075372112718
       .47679923006332214 .8790122264286335
       .7768884656732324 .629638238914927
       .10412163387205457 .9945645707342554
       .9819638691095552 .18906866414980622
       .560661576197336 .8280450452577558
       .83486287498638 .5504579729366048
       .2011046348420919 .9795697656854405
       .9262102421383114 .37700741021641826
       .3883450466988263 .9215140393420419
       .7114321957452164 .7027547444572253
       .006135884649154475 .9999811752826011
       .9999952938095762 .003067956762965976
       .7049340803759049 .7092728264388657
       .9227011283338785 .38551605384391885
       .37984720892405116 .9250492407826776
       .9801821359681174 .1980984107179536
       .5530167055800276 .8331701647019132
       .829761233794523 .5581185312205561
       .19208039704989244 .9813791933137546
       .9948793307948056 .10106986275482782
       .6320187359398091 .7749531065948739
       .8804708890521608 .47410021465055
       .2873474595447295 .9578264130275329
       .9560452513499964 .29321916269425863
       .46868882203582796 .8833633386657316
       .7710605242618138 .6367618612362842
       .094963495329639 .9954807554919269
       .9986402181802653 .052131704680283324
       .6692825883466361 .7430079521351217
       .9026733182372588 .4303264813400826
       .3339996514420094 .9425731976014469
       .9692812353565485 .24595505033579462
       .5114688504379704 .8593018183570084
       .8013761717231402 .5981607069963423
       .14369503315029444 .9896220174632009
       .9887216919603238 .1497645346773215
       .5932322950397998 .8050313311429635
       .8561473283751945 .5167317990176499
       .2400030224487415 .9707721407289504
       .9405060705932683 .33977688440682685
       .4247796812091088 .9052967593181188
       .7388873244606151 .673829000378756
       .04600318213091463 .9989412931868569
       .9996188224951786 .027608145778965743
       .6873153408917592 .726359155084346
       .9129621904283982 .4080441628649787
       .35703096123343003 .9340925504042589
       .9750253450669941 .22209362097320354
       .532403127877198 .8464909387740521
       .8158144108067338 .5783137964116556
       .16793829497473117 .9857975091675675
       .9920993131421918 .12545498341154623
       .6128100824294097 .79023022143731
       .8685707059713409 .49556526182577254
       .2637546789748314 .9645897932898128
       .9485613499157303 .31659337555616585
       .4468688401623742 .8945994856313827
       .7552013768965365 .6554928529996153
       .07050457338961387 .9975114561403035
       .997060070339483 .07662386139203149
       .6508466849963809 .7592091889783881
       .8918407093923427 .4523495872337709
       .3107671527496115 .9504860739494817
       .9629532668736839 .2696683255729151
       .49022648328829116 .8715950866559511
       .7864552135990858 .617647307937804
       .11936521481099137 .9928504144598651
       .9847485018019042 .17398387338746382
       .5732971666980422 .819347520076797
       .8432082396418454 .5375870762956455
       .21610679707621952 .9763697313300211
       .9318842655816681 .3627557243673972
       .40243465085941843 .9154487160882678
       .7221281939292153 .6917592583641577
       .021474080275469508 .9997694053512153
       .9998823474542126 .015339206284988102
       .696177131491463 .7178700450557317
       .9179007756213905 .3968099874167103
       .3684668299533723 .9296408958431812
       .9776773578245099 .2101118368804696
       .5427507848645159 .8398937941959995
       .8228497813758263 .5682589526701316
       .18002290140569951 .9836624192117303
       .9935641355205953 .11327095217756435
       .62246127937415 .7826505961665757
       .8745866522781761 .4848692480007911
       .27557181931095814 .9612804858113206
       .9523750127197659 .30492922973540243
       .45781330359887723 .8890483558546646
       .7631884172633813 .6461760129833164
       .08274026454937569 .9965711457905548
       .997925286198596 .06438263092985747
       .6601143420674205 .7511651319096864
       .8973245807054183 .44137126873171667
       .32240767880106985 .9466009130832835
       .9661900034454125 .257831102162159
       .5008853826112408 .8655136240905691
       .7939754775543372 .6079497849677736
       .13154002870288312 .9913108598461154
       .9868094018141855 .16188639378011183
       .5833086529376983 .8122505865852039
       .8497417680008524 .5271991347819014
       .22807208317088573 .973644249650812
       .9362656671702783 .35129275608556715
       .41363831223843456 .9104412922580672
       .7305627692278276 .6828455463852481
       .03374117185137759 .9994306045554617
       .9992047586183639 .03987292758773981
       .6783500431298615 .7347388780959635
       .9078861164876663 .41921688836322396
       .34554132496398904 .9384035340631081
       .9722264970789363 .23404195858354343
       .5219752929371544 .8529606049303636
       .808656181588175 .5882815482226453
       .15582839765426523 .9877841416445722
       .9904850842564571 .13762012158648604
       .6030665985403482 .7976908409433912
       .8624239561110405 .5061866453451553
       .25189781815421697 .9677538370934755
       .9446048372614803 .32820984357909255
       .4358570799222555 .9000158920161603
       .7471006059801801 .6647109782033449
       .05825826450043576 .9983015449338929
       .996044700901252 .0888535525825246
       .6414810128085832 .7671389119358204
       .8862225301488806 .4632597835518602
       .2990798263080405 .9542280951091057
       .9595715130819845 .281464937925758
       .479493757660153 .8775452902072612
       .778816512381476 .6272518154951441
       .10717242495680884 .9942404494531879
       .9825393022874412 .18605515166344666
       .5631993440138341 .8263210628456635
       .836547727223512 .5478940591731002
       .20410896609281687 .9789481753190622
       .9273625256504011 .374164062971458
       .39117038430225387 .9203182767091106
       .7135848687807936 .7005687939432483
       .00920375478205982 .9999576445519639
       .9999576445519639 .00920375478205982
       .7005687939432483 .7135848687807936
       .9203182767091106 .39117038430225387
       .374164062971458 .9273625256504011
       .9789481753190622 .20410896609281687
       .5478940591731002 .836547727223512
       .8263210628456635 .5631993440138341
       .18605515166344666 .9825393022874412
       .9942404494531879 .10717242495680884
       .6272518154951441 .778816512381476
       .8775452902072612 .479493757660153
       .281464937925758 .9595715130819845
       .9542280951091057 .2990798263080405
       .4632597835518602 .8862225301488806
       .7671389119358204 .6414810128085832
       .0888535525825246 .996044700901252
       .9983015449338929 .05825826450043576
       .6647109782033449 .7471006059801801
       .9000158920161603 .4358570799222555
       .32820984357909255 .9446048372614803
       .9677538370934755 .25189781815421697
       .5061866453451553 .8624239561110405
       .7976908409433912 .6030665985403482
       .13762012158648604 .9904850842564571
       .9877841416445722 .15582839765426523
       .5882815482226453 .808656181588175
       .8529606049303636 .5219752929371544
       .23404195858354343 .9722264970789363
       .9384035340631081 .34554132496398904
       .41921688836322396 .9078861164876663
       .7347388780959635 .6783500431298615
       .03987292758773981 .9992047586183639
       .9994306045554617 .03374117185137759
       .6828455463852481 .7305627692278276
       .9104412922580672 .41363831223843456
       .35129275608556715 .9362656671702783
       .973644249650812 .22807208317088573
       .5271991347819014 .8497417680008524
       .8122505865852039 .5833086529376983
       .16188639378011183 .9868094018141855
       .9913108598461154 .13154002870288312
       .6079497849677736 .7939754775543372
       .8655136240905691 .5008853826112408
       .257831102162159 .9661900034454125
       .9466009130832835 .32240767880106985
       .44137126873171667 .8973245807054183
       .7511651319096864 .6601143420674205
       .06438263092985747 .997925286198596
       .9965711457905548 .08274026454937569
       .6461760129833164 .7631884172633813
       .8890483558546646 .45781330359887723
       .30492922973540243 .9523750127197659
       .9612804858113206 .27557181931095814
       .4848692480007911 .8745866522781761
       .7826505961665757 .62246127937415
       .11327095217756435 .9935641355205953
       .9836624192117303 .18002290140569951
       .5682589526701316 .8228497813758263
       .8398937941959995 .5427507848645159
       .2101118368804696 .9776773578245099
       .9296408958431812 .3684668299533723
       .3968099874167103 .9179007756213905
       .7178700450557317 .696177131491463
       .015339206284988102 .9998823474542126
       .9997694053512153 .021474080275469508
       .6917592583641577 .7221281939292153
       .9154487160882678 .40243465085941843
       .3627557243673972 .9318842655816681
       .9763697313300211 .21610679707621952
       .5375870762956455 .8432082396418454
       .819347520076797 .5732971666980422
       .17398387338746382 .9847485018019042
       .9928504144598651 .11936521481099137
       .617647307937804 .7864552135990858
       .8715950866559511 .49022648328829116
       .2696683255729151 .9629532668736839
       .9504860739494817 .3107671527496115
       .4523495872337709 .8918407093923427
       .7592091889783881 .6508466849963809
       .07662386139203149 .997060070339483
       .9975114561403035 .07050457338961387
       .6554928529996153 .7552013768965365
       .8945994856313827 .4468688401623742
       .31659337555616585 .9485613499157303
       .9645897932898128 .2637546789748314
       .49556526182577254 .8685707059713409
       .79023022143731 .6128100824294097
       .12545498341154623 .9920993131421918
       .9857975091675675 .16793829497473117
       .5783137964116556 .8158144108067338
       .8464909387740521 .532403127877198
       .22209362097320354 .9750253450669941
       .9340925504042589 .35703096123343003
       .4080441628649787 .9129621904283982
       .726359155084346 .6873153408917592
       .027608145778965743 .9996188224951786
       .9989412931868569 .04600318213091463
       .673829000378756 .7388873244606151
       .9052967593181188 .4247796812091088
       .33977688440682685 .9405060705932683
       .9707721407289504 .2400030224487415
       .5167317990176499 .8561473283751945
       .8050313311429635 .5932322950397998
       .1497645346773215 .9887216919603238
       .9896220174632009 .14369503315029444
       .5981607069963423 .8013761717231402
       .8593018183570084 .5114688504379704
       .24595505033579462 .9692812353565485
       .9425731976014469 .3339996514420094
       .4303264813400826 .9026733182372588
       .7430079521351217 .6692825883466361
       .052131704680283324 .9986402181802653
       .9954807554919269 .094963495329639
       .6367618612362842 .7710605242618138
       .8833633386657316 .46868882203582796
       .29321916269425863 .9560452513499964
       .9578264130275329 .2873474595447295
       .47410021465055 .8804708890521608
       .7749531065948739 .6320187359398091
       .10106986275482782 .9948793307948056
       .9813791933137546 .19208039704989244
       .5581185312205561 .829761233794523
       .8331701647019132 .5530167055800276
       .1980984107179536 .9801821359681174
       .9250492407826776 .37984720892405116
       .38551605384391885 .9227011283338785
       .7092728264388657 .7049340803759049
       .003067956762965976 .9999952938095762
       ))

    (define med-lut
    '#f64(1. 0.
       .9999999999820472 5.9921124526424275e-6
       .9999999999281892 1.1984224905069707e-5
       .9999999998384257 1.7976337357066685e-5
       .9999999997127567 2.396844980841822e-5
       .9999999995511824 2.9960562258909154e-5
       .9999999993537025 3.5952674708324344e-5
       .9999999991203175 4.1944787156448635e-5
       .9999999988510269 4.793689960306688e-5
       .9999999985458309 5.3929012047963936e-5
       .9999999982047294 5.992112449092465e-5
       .9999999978277226 6.591323693173387e-5
       .9999999974148104 7.190534937017645e-5
       .9999999969659927 7.789746180603723e-5
       .9999999964812697 8.388957423910108e-5
       .9999999959606412 8.988168666915283e-5
       .9999999954041073 9.587379909597734e-5
       .999999994811668 1.0186591151935948e-4
       .9999999941833233 1.0785802393908407e-4
       .9999999935190732 1.1385013635493597e-4
       .9999999928189177 1.1984224876670004e-4
       .9999999920828567 1.2583436117416112e-4
       .9999999913108903 1.3182647357710405e-4
       .9999999905030187 1.3781858597531374e-4
       .9999999896592414 1.4381069836857496e-4
       .9999999887795589 1.498028107566726e-4
       .9999999878639709 1.5579492313939151e-4
       .9999999869124775 1.6178703551651655e-4
       .9999999859250787 1.6777914788783258e-4
       .9999999849017744 1.737712602531244e-4
       .9999999838425648 1.797633726121769e-4
       .9999999827474497 1.8575548496477492e-4
       .9999999816164293 1.9174759731070332e-4
       .9999999804495034 1.9773970964974692e-4
       .9999999792466722 2.037318219816906e-4
       .9999999780079355 2.0972393430631923e-4
       .9999999767332933 2.1571604662341763e-4
       .9999999754227459 2.2170815893277063e-4
       .9999999740762929 2.2770027123416315e-4
       .9999999726939346 2.3369238352737996e-4
       .9999999712756709 2.3968449581220595e-4
       .9999999698215016 2.45676608088426e-4
       .9999999683314271 2.5166872035582493e-4
       .9999999668054471 2.5766083261418755e-4
       .9999999652435617 2.636529448632988e-4
       .9999999636457709 2.696450571029434e-4
       .9999999620120748 2.756371693329064e-4
       .9999999603424731 2.8162928155297243e-4
       .9999999586369661 2.876213937629265e-4
       .9999999568955537 2.936135059625534e-4
       .9999999551182358 2.99605618151638e-4
       .9999999533050126 3.055977303299651e-4
       .9999999514558838 3.115898424973196e-4
       .9999999495708498 3.1758195465348636e-4
       .9999999476499103 3.235740667982502e-4
       .9999999456930654 3.2956617893139595e-4
       .9999999437003151 3.3555829105270853e-4
       .9999999416716594 3.4155040316197275e-4
       .9999999396070982 3.475425152589734e-4
       .9999999375066316 3.535346273434955e-4
       .9999999353702598 3.595267394153237e-4
       .9999999331979824 3.6551885147424295e-4
       .9999999309897996 3.7151096352003814e-4
       .9999999287457114 3.7750307555249406e-4
       .9999999264657179 3.8349518757139556e-4
       .9999999241498189 3.8948729957652753e-4
       .9999999217980144 3.954794115676748e-4
       .9999999194103046 4.0147152354462224e-4
       .9999999169866894 4.0746363550715466e-4
       .9999999145271687 4.134557474550569e-4
       .9999999120317428 4.194478593881139e-4
       .9999999095004113 4.2543997130611036e-4
       .9999999069331744 4.314320832088313e-4
       .9999999043300322 4.3742419509606144e-4
       .9999999016909845 4.4341630696758576e-4
       .9999998990160315 4.4940841882318896e-4
       .9999998963051729 4.55400530662656e-4
       .999999893558409 4.613926424857717e-4
       .9999998907757398 4.673847542923209e-4
       .9999998879571651 4.7337686608208844e-4
       .9999998851026849 4.793689778548592e-4
       .9999998822122994 4.8536108961041806e-4
       .9999998792860085 4.913532013485497e-4
       .9999998763238122 4.973453130690393e-4
       .9999998733257104 5.033374247716714e-4
       .9999998702917032 5.09329536456231e-4
       .9999998672217907 5.153216481225028e-4
       .9999998641159727 5.213137597702719e-4
       .9999998609742493 5.27305871399323e-4
       .9999998577966206 5.332979830094408e-4
       .9999998545830864 5.392900946004105e-4
       .9999998513336468 5.452822061720168e-4
       .9999998480483018 5.512743177240444e-4
       .9999998447270514 5.572664292562783e-4
       .9999998413698955 5.632585407685033e-4
       .9999998379768343 5.692506522605043e-4
       .9999998345478677 5.752427637320661e-4
       .9999998310829956 5.812348751829735e-4
       .9999998275822183 5.872269866130116e-4
       .9999998240455354 5.93219098021965e-4
       .9999998204729471 5.992112094096185e-4
       .9999998168644535 6.052033207757572e-4
       .9999998132200545 6.111954321201659e-4
       .99999980953975 6.171875434426292e-4
       .9999998058235401 6.231796547429323e-4
       .9999998020714248 6.291717660208597e-4
       .9999997982834041 6.351638772761965e-4
       .9999997944594781 6.411559885087275e-4
       .9999997905996466 6.471480997182375e-4
       .9999997867039097 6.531402109045114e-4
       .9999997827722674 6.591323220673341e-4
       .9999997788047197 6.651244332064902e-4
       .9999997748012666 6.711165443217649e-4
       .9999997707619082 6.771086554129428e-4
       .9999997666866443 6.83100766479809e-4
       .9999997625754748 6.89092877522148e-4
       .9999997584284002 6.950849885397449e-4
       .9999997542454201 7.010770995323844e-4
       .9999997500265345 7.070692104998515e-4
       .9999997457717437 7.130613214419311e-4
       .9999997414810473 7.190534323584079e-4
       .9999997371544456 7.250455432490666e-4
       .9999997327919384 7.310376541136925e-4
       .9999997283935259 7.3702976495207e-4
       .999999723959208 7.430218757639842e-4
       .9999997194889846 7.490139865492199e-4
       .9999997149828559 7.55006097307562e-4
       .9999997104408218 7.609982080387952e-4
       .9999997058628822 7.669903187427045e-4
       .9999997012490373 7.729824294190747e-4
       .9999996965992869 7.789745400676906e-4
       .9999996919136313 7.849666506883372e-4
       .99999968719207 7.909587612807992e-4
       .9999996824346035 7.969508718448614e-4
       .9999996776412315 8.029429823803089e-4
       .9999996728119542 8.089350928869263e-4
       .9999996679467715 8.149272033644986e-4
       .9999996630456833 8.209193138128106e-4
       .9999996581086897 8.269114242316472e-4
       .9999996531357909 8.329035346207931e-4
       .9999996481269865 8.388956449800333e-4
       .9999996430822767 8.448877553091527e-4
       .9999996380016616 8.508798656079359e-4
       .999999632885141 8.56871975876168e-4
       .9999996277327151 8.628640861136338e-4
       .9999996225443838 8.68856196320118e-4
       .9999996173201471 8.748483064954056e-4
       .999999612060005 8.808404166392814e-4
       .9999996067639574 8.868325267515304e-4
       .9999996014320045 8.928246368319371e-4
       .9999995960641462 8.988167468802867e-4
       .9999995906603825 9.048088568963639e-4
       .9999995852207133 9.108009668799535e-4
       .9999995797451389 9.167930768308405e-4
       .9999995742336589 9.227851867488095e-4
       .9999995686862736 9.287772966336457e-4
       .9999995631029829 9.347694064851338e-4
       .9999995574837868 9.407615163030585e-4
       .9999995518286853 9.467536260872047e-4
       .9999995461376784 9.527457358373575e-4
       .9999995404107661 9.587378455533015e-4
       .9999995346479484 9.647299552348216e-4
       .9999995288492254 9.707220648817027e-4
       .9999995230145969 9.767141744937296e-4
       .9999995171440631 9.827062840706872e-4
       .9999995112376238 9.886983936123602e-4
       .9999995052952791 9.946905031185337e-4
       .9999994993170291 .0010006826125889925
       .9999994933028736 .0010066747220235214
       .9999994872528128 .001012666831421905
       .9999994811668466 .0010186589407839286
       .999999475044975 .0010246510501093766
       .9999994688871979 .0010306431593980344
       .9999994626935156 .0010366352686496862
       .9999994564639277 .0010426273778641173
       .9999994501984345 .0010486194870411127
       .999999443897036 .0010546115961804568
       .999999437559732 .0010606037052819344
       .9999994311865227 .0010665958143453308
       .9999994247774079 .0010725879233704307
       .9999994183323877 .0010785800323570187
       .9999994118514622 .0010845721413048801
       .9999994053346313 .0010905642502137994
       .9999993987818949 .0010965563590835613
       .9999993921932533 .0011025484679139511
       .9999993855687062 .0011085405767047535
       .9999993789082536 .0011145326854557532
       .9999993722118957 .001120524794166735
       .9999993654796325 .0011265169028374842
       .9999993587114638 .0011325090114677853
       .9999993519073898 .001138501120057423
       .9999993450674104 .0011444932286061825
       .9999993381915255 .0011504853371138485
       .9999993312797354 .0011564774455802057
       .9999993243320398 .0011624695540050393
       .9999993173484387 .001168461662388134
       .9999993103289324 .0011744537707292742
       .9999993032735206 .0011804458790282454
       .9999992961822035 .0011864379872848323
       .9999992890549809 .0011924300954988195
       .999999281891853 .001198422203669992
       .9999992746928197 .0012044143117981348
       .999999267457881 .0012104064198830327
       .999999260187037 .0012163985279244702
       .9999992528802875 .0012223906359222325
       .9999992455376326 .0012283827438761045
       .9999992381590724 .0012343748517858707
       .9999992307446068 .0012403669596513162
       .9999992232942359 .001246359067472226
       .9999992158079595 .0012523511752483847
       .9999992082857777 .001258343282979577
       .9999992007276906 .001264335390665588
       .999999193133698 .0012703274983062026
       .9999991855038001 .0012763196059012057
       .9999991778379967 .001282311713450382
       .9999991701362881 .0012883038209535163
       .999999162398674 .0012942959284103935
       .9999991546251547 .0013002880358207985
       .9999991468157298 .001306280143184516
       .9999991389703996 .001312272250501331
       .999999131089164 .0013182643577710285
       .999999123172023 .0013242564649933932
       .9999991152189767 .0013302485721682098
       .9999991072300249 .001336240679295263
       .9999990992051678 .0013422327863743383
       .9999990911444054 .0013482248934052201
       .9999990830477375 .0013542170003876934
       .9999990749151643 .001360209107321543
       .9999990667466857 .0013662012142065536
       .9999990585423016 .0013721933210425101
       .9999990503020123 .0013781854278291975
       .9999990420258176 .0013841775345664006
       .9999990337137175 .0013901696412539043
       .999999025365712 .0013961617478914935
       .999999016981801 .0014021538544789526
       .9999990085619848 .001408145961016067
       .9999990001062631 .0014141380675026214
       .9999989916146361 .0014201301739384005
       .9999989830871038 .0014261222803231893
       .9999989745236659 .0014321143866567725
       .9999989659243228 .001438106492938935
       .9999989572890743 .0014440985991694619
       .9999989486179204 .0014500907053481378
       .9999989399108612 .0014560828114747475
       .9999989311678965 .0014620749175490758
       .9999989223890265 .001468067023570908
       .9999989135742512 .0014740591295400284
       .9999989047235704 .0014800512354562223
       .9999988958369843 .0014860433413192743
       .9999988869144928 .0014920354471289693
       .9999988779560959 .0014980275528850922
       .9999988689617937 .0015040196585874275
       .9999988599315861 .0015100117642357607
       .999998850865473 .0015160038698298762
       .9999988417634548 .001521995975369559
       .999998832625531 .0015279880808545937
       .9999988234517019 .0015339801862847657
       .9999988142419675 .0015399722916598592
       .9999988049963277 .0015459643969796596
       .9999987957147825 .0015519565022439512
       .9999987863973319 .0015579486074525195
       .9999987770439759 .001563940712605149
       .9999987676547146 .0015699328177016243
       .999998758229548 .0015759249227417307
       .9999987487684759 .0015819170277252528
       .9999987392714985 .0015879091326519755
       .9999987297386157 .0015939012375216837
       .9999987201698276 .0015998933423341623
       .9999987105651341 .001605885447089196
       .9999987009245352 .0016118775517865696
       .999998691248031 .0016178696564260683
       .9999986815356214 .0016238617610074765
       .9999986717873064 .0016298538655305794
       .9999986620030861 .0016358459699951618
       .9999986521829605 .0016418380744010084
       .9999986423269294 .0016478301787479041
       .999998632434993 .0016538222830356339
       .9999986225071512 .0016598143872639823
       .999998612543404 .0016658064914327345
       .9999986025437515 .0016717985955416754
       .9999985925081937 .0016777906995905894
       .9999985824367305 .0016837828035792617
       .9999985723293618 .0016897749075074774
       .999998562186088 .0016957670113750207
       .9999985520069086 .0017017591151816769
       .9999985417918239 .0017077512189272307
       .999998531540834 .001713743322611467
       .9999985212539385 .0017197354262341706
       .9999985109311378 .0017257275297951264
       .9999985005724317 .0017317196332941192
       .9999984901778203 .0017377117367309341
       .9999984797473034 .0017437038401053556
       .9999984692808812 .0017496959434171687
       .9999984587785538 .0017556880466661582
       .9999984482403208 .001761680149852109
       .9999984376661826 .0017676722529748061
       .999998427056139 .0017736643560340342
       .99999841641019 .001779656459029578
       .9999984057283358 .0017856485619612225
       .9999983950105761 .0017916406648287528
       .999998384256911 .0017976327676319532
       .9999983734673407 .001803624870370609
       .9999983626418649 .0018096169730445048
       .9999983517804839 .0018156090756534257
       .9999983408831975 .0018216011781971562
       .9999983299500057 .0018275932806754815
       .9999983189809085 .0018335853830881864
       .999998307975906 .0018395774854350557
       .9999982969349982 .001845569587715874
       .9999982858581851 .0018515616899304264
       .9999982747454665 .001857553792078498
       .9999982635968426 .001863545894159873
       .9999982524123134 .0018695379961743367
       .9999982411918789 .001875530098121674
       .9999982299355389 .0018815222000016696
       .9999982186432936 .0018875143018141083
       .999998207315143 .0018935064035587748
       .999998195951087 .0018994985052354545
       .9999981845511257 .0019054906068439318
       .9999981731152591 .0019114827083839918
       .999998161643487 .001917474809855419
       .9999981501358096 .0019234669112579987
       .999998138592227 .0019294590125915154
       .9999981270127389 .0019354511138557542
       .9999981153973455 .0019414432150504997
       .9999981037460468 .0019474353161755369
       .9999980920588427 .001953427417230651
       .9999980803357332 .001959419518215626
       .9999980685767185 .0019654116191302473
       .9999980567817984 .0019714037199743
       .9999980449509729 .0019773958207475683
       .9999980330842422 .0019833879214498375
       .999998021181606 .001989380022080892
       .9999980092430646 .0019953721226405176
       .9999979972686177 .002001364223128498
       .9999979852582656 .002007356323544619
       .9999979732120081 .002013348423888665
       .9999979611298453 .002019340524160421
       .9999979490117771 .0020253326243596715
       .9999979368578036 .0020313247244862017
       .9999979246679247 .002037316824539796
       .9999979124421405 .00204330892452024
       .999997900180451 .002049301024427318
       .9999978878828562 .0020552931242608153
       .9999978755493559 .002061285224020516
       .9999978631799504 .0020672773237062057
       .9999978507746395 .002073269423317669
       .9999978383334234 .0020792615228546903
       .9999978258563018 .002085253622317055
       .999997813343275 .0020912457217045484
       .9999978007943428 .002097237821016954
       .9999977882095052 .0021032299202540577
       .9999977755887623 .0021092220194156444
       .9999977629321142 .0021152141185014984
       .9999977502395607 .0021212062175114043
       .9999977375111019 .002127198316445148
       .9999977247467376 .0021331904153025134
       .9999977119464681 .002139182514083286
       .9999976991102932 .0021451746127872503
       .9999976862382131 .002151166711414191
       .9999976733302276 .0021571588099638934
       .9999976603863368 .0021631509084361423
       .9999976474065406 .002169143006830722
       .9999976343908391 .002175135105147418
       .9999976213392323 .0021811272033860148
       .9999976082517201 .002187119301546297
       .9999975951283027 .00219311139962805
       .9999975819689799 .0021991034976310588
       .9999975687737518 .0022050955955551076
       .9999975555426184 .0022110876933999816
       .9999975422755796 .0022170797911654654
       .9999975289726355 .002223071888851344
       .9999975156337861 .0022290639864574026
       .9999975022590314 .0022350560839834253
       .9999974888483714 .002241048181429198
       .999997475401806 .0022470402787945045
       .9999974619193353 .00225303237607913
       .9999974484009593 .0022590244732828596
       .9999974348466779 .0022650165704054784
       .9999974212564913 .0022710086674467703
       .9999974076303992 .002277000764406521
       .9999973939684019 .002282992861284515
       .9999973802704993 .0022889849580805368
       .9999973665366915 .0022949770547943723
       .9999973527669782 .0023009691514258054
       .9999973389613596 .002306961247974621
       .9999973251198357 .0023129533444406045
       .9999973112424065 .0023189454408235406
       .999997297329072 .0023249375371232135
       .9999972833798322 .002330929633339409
       .999997269394687 .0023369217294719113
       .9999972553736366 .0023429138255205055
       .9999972413166809 .0023489059214849765
       .9999972272238198 .002354898017365109
       .9999972130950534 .0023608901131606883
       .9999971989303816 .0023668822088714985
       .9999971847298047 .0023728743044973246
       .9999971704933224 .0023788664000379523
       .9999971562209347 .0023848584954931653
       .9999971419126418 .0023908505908627493
       .9999971275684435 .0023968426861464883
       .99999711318834 .002402834781344168
       .9999970987723311 .0024088268764555732
       .9999970843204169 .002414818971480488
       .9999970698325974 .002420811066418698
       .9999970553088726 .0024268031612699878
       .9999970407492426 .002432795256034142
       .9999970261537071 .002438787350710946
       .9999970115222664 .002444779445300184
       .9999969968549204 .0024507715398016418
       .9999969821516691 .002456763634215103
       .9999969674125124 .002462755728540353
       .9999969526374506 .0024687478227771774
       .9999969378264834 .00247473991692536
       .9999969229796108 .002480732010984686
       .999996908096833 .0024867241049549406
       .9999968931781499 .002492716198835908
       .9999968782235614 .0024987082926273734
       .9999968632330677 .002504700386329122
       .9999968482066687 .002510692479940938
       .9999968331443644 .0025166845734626068
       .9999968180461547 .0025226766668939127
       .9999968029120399 .002528668760234641
       .9999967877420196 .002534660853484576
       .9999967725360941 .0025406529466435036
       .9999967572942633 .002546645039711208
       .9999967420165272 .002552637132687474
       .9999967267028858 .002558629225572086
       .9999967113533391 .0025646213183648297
       .9999966959678871 .0025706134110654896
       .9999966805465298 .002576605503673851
       .9999966650892672 .0025825975961896977
       .9999966495960994 .0025885896886128153
       .9999966340670262 .0025945817809429885
       .9999966185020478 .0026005738731800024
       .9999966029011641 .0026065659653236417
       .999996587264375 .002612558057373691
       .9999965715916808 .002618550149329935
       .9999965558830811 .0026245422411921592
       .9999965401385762 .002630534332960148
       .9999965243581661 .002636526424633687
       .9999965085418506 .0026425185162125596
       .9999964926896299 .0026485106076965517
       .9999964768015038 .0026545026990854484
       .9999964608774725 .0026604947903790337
       .9999964449175359 .0026664868815770926
       .999996428921694 .0026724789726794104
       .9999964128899468 .002678471063685772
       .9999963968222944 .0026844631545959617
       .9999963807187366 .002690455245409765
       .9999963645792737 .002696447336126966
       .9999963484039053 .00270243942674735
       .9999963321926317 .002708431517270702
       .9999963159454529 .0027144236076968066
       .9999962996623687 .0027204156980254485
       .9999962833433793 .002726407788256413
       .9999962669884847 .002732399878389485
       .9999962505976846 .0027383919684244484
       .9999962341709794 .002744384058361089
       .9999962177083689 .0027503761481991913
       .999996201209853 .0027563682379385403
       .9999961846754319 .0027623603275789207
       .9999961681051056 .0027683524171201175
       .999996151498874 .002774344506561915
       .9999961348567371 .002780336595904099
       .9999961181786949 .0027863286851464537
       .9999961014647475 .0027923207742887642
       .9999960847148948 .0027983128633308155
       .9999960679291368 .002804304952272392
       .9999960511074735 .002810297041113279
       .9999960342499049 .0028162891298532606
       .9999960173564312 .0028222812184921227
       .9999960004270521 .002828273307029649
       .9999959834617678 .002834265395465626
       .9999959664605781 .0028402574837998367
       .9999959494234832 .002846249572032067
       .9999959323504831 .0028522416601621014
       .9999959152415777 .002858233748189725
       .999995898096767 .002864225836114723
       .9999958809160512 .0028702179239368793
       .9999958636994299 .0028762100116559793
       .9999958464469034 .0028822020992718077
       .9999958291584717 .0028881941867841495
       .9999958118341348 .0028941862741927895
       .9999957944738925 .0029001783614975127
       .999995777077745 .002906170448698104
       .9999957596456922 .0029121625357943475
       .9999957421777342 .002918154622786029
       .999995724673871 .0029241467096729327
       .9999957071341024 .002930138796454844
       .9999956895584287 .0029361308831315474
       .9999956719468496 .0029421229697028273
       .9999956542993652 .0029481150561684695
       .9999956366159757 .0029541071425282584
       .9999956188966809 .002960099228781979
       .9999956011414808 .002966091314929416
       .9999955833503754 .002972083400970354
       .9999955655233649 .0029780754869045785
       .9999955476604491 .0029840675727318736
       .999995529761628 .002990059658452025
       .9999955118269016 .0029960517440648163
       .99999549385627 .0030020438295700336
       .9999954758497331 .0030080359149674612
       .999995457807291 .003014028000256884
       .9999954397289438 .003020020085438087
       .9999954216146911 .0030260121705108552
       .9999954034645333 .003032004255474973
       .9999953852784702 .003037996340330225
       .9999953670565019 .003043988425076397
       .9999953487986284 .003049980509713273
       .9999953305048496 .0030559725942406386
       .9999953121751655 .003061964678658278
       ))

    (define high-lut
    '#f64(1. 0.
       .9999999999999999 1.1703344634137277e-8
       .9999999999999998 2.3406689268274554e-8
       .9999999999999993 3.5110033902411824e-8
       .9999999999999989 4.6813378536549095e-8
       .9999999999999983 5.851672317068635e-8
       .9999999999999976 7.022006780482361e-8
       .9999999999999967 8.192341243896085e-8
       .9999999999999957 9.362675707309808e-8
       .9999999999999944 1.0533010170723531e-7
       .9999999999999931 1.170334463413725e-7
       .9999999999999917 1.287367909755097e-7
       .9999999999999901 1.4044013560964687e-7
       .9999999999999885 1.5214348024378403e-7
       .9999999999999866 1.6384682487792116e-7
       .9999999999999846 1.7555016951205827e-7
       .9999999999999825 1.8725351414619535e-7
       .9999999999999802 1.989568587803324e-7
       .9999999999999778 2.1066020341446942e-7
       .9999999999999752 2.2236354804860645e-7
       .9999999999999726 2.3406689268274342e-7
       .9999999999999698 2.4577023731688034e-7
       .9999999999999668 2.5747358195101726e-7
       .9999999999999638 2.6917692658515413e-7
       .9999999999999606 2.8088027121929094e-7
       .9999999999999571 2.9258361585342776e-7
       .9999999999999537 3.042869604875645e-7
       .99999999999995 3.159903051217012e-7
       .9999999999999463 3.276936497558379e-7
       .9999999999999424 3.3939699438997453e-7
       .9999999999999384 3.5110033902411114e-7
       .9999999999999342 3.6280368365824763e-7
       .9999999999999298 3.7450702829238413e-7
       .9999999999999254 3.8621037292652057e-7
       .9999999999999208 3.979137175606569e-7
       .9999999999999161 4.0961706219479325e-7
       .9999999999999113 4.2132040682892953e-7
       .9999999999999063 4.330237514630657e-7
       .9999999999999011 4.447270960972019e-7
       .9999999999998959 4.5643044073133796e-7
       .9999999999998904 4.68133785365474e-7
       .9999999999998849 4.7983712999961e-7
       .9999999999998792 4.915404746337459e-7
       .9999999999998733 5.032438192678817e-7
       .9999999999998674 5.149471639020175e-7
       .9999999999998613 5.266505085361531e-7
       .9999999999998551 5.383538531702888e-7
       .9999999999998487 5.500571978044243e-7
       .9999999999998422 5.617605424385598e-7
       .9999999999998356 5.734638870726952e-7
       .9999999999998288 5.851672317068305e-7
       .9999999999998219 5.968705763409657e-7
       .9999999999998148 6.085739209751009e-7
       .9999999999998076 6.202772656092359e-7
       .9999999999998003 6.319806102433709e-7
       .9999999999997928 6.436839548775058e-7
       .9999999999997853 6.553872995116406e-7
       .9999999999997775 6.670906441457753e-7
       .9999999999997696 6.7879398877991e-7
       .9999999999997616 6.904973334140445e-7
       .9999999999997534 7.02200678048179e-7
       .9999999999997452 7.139040226823132e-7
       .9999999999997368 7.256073673164475e-7
       .9999999999997282 7.373107119505817e-7
       .9999999999997194 7.490140565847157e-7
       .9999999999997107 7.607174012188497e-7
       .9999999999997017 7.724207458529835e-7
       .9999999999996926 7.841240904871172e-7
       .9999999999996834 7.958274351212508e-7
       .9999999999996739 8.075307797553844e-7
       .9999999999996644 8.192341243895178e-7
       .9999999999996547 8.309374690236511e-7
       .999999999999645 8.426408136577842e-7
       .9999999999996351 8.543441582919173e-7
       .999999999999625 8.660475029260503e-7
       .9999999999996148 8.777508475601831e-7
       .9999999999996044 8.894541921943158e-7
       .999999999999594 9.011575368284484e-7
       .9999999999995833 9.128608814625808e-7
       .9999999999995726 9.245642260967132e-7
       .9999999999995617 9.362675707308454e-7
       .9999999999995507 9.479709153649775e-7
       .9999999999995395 9.596742599991095e-7
       .9999999999995283 9.713776046332412e-7
       .9999999999995168 9.83080949267373e-7
       .9999999999995052 9.947842939015044e-7
       .9999999999994935 1.006487638535636e-6
       .9999999999994816 1.0181909831697673e-6
       .9999999999994696 1.0298943278038984e-6
       .9999999999994575 1.0415976724380293e-6
       .9999999999994453 1.0533010170721601e-6
       .9999999999994329 1.065004361706291e-6
       .9999999999994204 1.0767077063404215e-6
       .9999999999994077 1.088411050974552e-6
       .9999999999993949 1.1001143956086822e-6
       .9999999999993819 1.1118177402428122e-6
       .9999999999993688 1.1235210848769423e-6
       .9999999999993556 1.135224429511072e-6
       .9999999999993423 1.1469277741452017e-6
       .9999999999993288 1.1586311187793313e-6
       .9999999999993151 1.1703344634134605e-6
       .9999999999993014 1.1820378080475897e-6
       .9999999999992875 1.1937411526817187e-6
       .9999999999992735 1.2054444973158477e-6
       .9999999999992593 1.2171478419499764e-6
       .9999999999992449 1.2288511865841048e-6
       .9999999999992305 1.2405545312182331e-6
       .999999999999216 1.2522578758523615e-6
       .9999999999992012 1.2639612204864894e-6
       .9999999999991863 1.2756645651206173e-6
       .9999999999991713 1.287367909754745e-6
       .9999999999991562 1.2990712543888725e-6
       .9999999999991409 1.3107745990229998e-6
       .9999999999991255 1.3224779436571269e-6
       .9999999999991099 1.3341812882912537e-6
       .9999999999990943 1.3458846329253806e-6
       .9999999999990785 1.3575879775595072e-6
       .9999999999990625 1.3692913221936337e-6
       .9999999999990464 1.3809946668277597e-6
       .9999999999990302 1.3926980114618857e-6
       .9999999999990138 1.4044013560960117e-6
       .9999999999989974 1.4161047007301373e-6
       .9999999999989807 1.4278080453642627e-6
       .9999999999989639 1.439511389998388e-6
       .999999999998947 1.451214734632513e-6
       .99999999999893 1.462918079266638e-6
       .9999999999989128 1.4746214239007625e-6
       .9999999999988954 1.486324768534887e-6
       .999999999998878 1.4980281131690111e-6
       .9999999999988604 1.5097314578031353e-6
       .9999999999988426 1.5214348024372591e-6
       .9999999999988247 1.5331381470713828e-6
       .9999999999988067 1.544841491705506e-6
       .9999999999987886 1.5565448363396294e-6
       .9999999999987703 1.5682481809737524e-6
       .9999999999987519 1.579951525607875e-6
       .9999999999987333 1.5916548702419977e-6
       .9999999999987146 1.60335821487612e-6
       .9999999999986958 1.615061559510242e-6
       .9999999999986768 1.626764904144364e-6
       .9999999999986577 1.6384682487784858e-6
       .9999999999986384 1.6501715934126072e-6
       .9999999999986191 1.6618749380467283e-6
       .9999999999985996 1.6735782826808495e-6
       .9999999999985799 1.6852816273149702e-6
       .9999999999985602 1.6969849719490907e-6
       .9999999999985402 1.708688316583211e-6
       .9999999999985201 1.720391661217331e-6
       .9999999999985 1.732095005851451e-6
       .9999999999984795 1.7437983504855706e-6
       .9999999999984591 1.7555016951196899e-6
       .9999999999984385 1.767205039753809e-6
       .9999999999984177 1.778908384387928e-6
       .9999999999983968 1.7906117290220465e-6
       .9999999999983759 1.802315073656165e-6
       .9999999999983546 1.814018418290283e-6
       .9999999999983333 1.825721762924401e-6
       .9999999999983119 1.8374251075585186e-6
       .9999999999982904 1.8491284521926361e-6
       .9999999999982686 1.8608317968267533e-6
       .9999999999982468 1.8725351414608702e-6
       .9999999999982249 1.8842384860949866e-6
       .9999999999982027 1.8959418307291031e-6
       .9999999999981805 1.9076451753632194e-6
       .999999999998158 1.919348519997335e-6
       .9999999999981355 1.9310518646314507e-6
       .9999999999981128 1.942755209265566e-6
       .9999999999980901 1.954458553899681e-6
       .9999999999980671 1.966161898533796e-6
       .999999999998044 1.9778652431679103e-6
       .9999999999980208 1.9895685878020246e-6
       .9999999999979975 2.0012719324361386e-6
       .999999999997974 2.012975277070252e-6
       .9999999999979503 2.0246786217043656e-6
       .9999999999979265 2.0363819663384787e-6
       .9999999999979027 2.048085310972592e-6
       .9999999999978786 2.0597886556067045e-6
       .9999999999978545 2.0714920002408167e-6
       .9999999999978302 2.0831953448749286e-6
       .9999999999978058 2.0948986895090404e-6
       .9999999999977811 2.106602034143152e-6
       .9999999999977564 2.118305378777263e-6
       .9999999999977315 2.1300087234113738e-6
       .9999999999977065 2.1417120680454843e-6
       .9999999999976814 2.153415412679595e-6
       .9999999999976561 2.1651187573137046e-6
       .9999999999976307 2.1768221019478143e-6
       .9999999999976051 2.188525446581924e-6
       .9999999999975795 2.200228791216033e-6
       .9999999999975536 2.2119321358501417e-6
       .9999999999975278 2.22363548048425e-6
       .9999999999975017 2.2353388251183586e-6
       .9999999999974754 2.247042169752466e-6
       .999999999997449 2.2587455143865738e-6
       .9999999999974225 2.2704488590206814e-6
       .9999999999973959 2.282152203654788e-6
       .9999999999973691 2.293855548288895e-6
       .9999999999973422 2.305558892923001e-6
       .9999999999973151 2.317262237557107e-6
       .999999999997288 2.328965582191213e-6
       .9999999999972606 2.340668926825318e-6
       .9999999999972332 2.352372271459423e-6
       .9999999999972056 2.364075616093528e-6
       .9999999999971778 2.3757789607276323e-6
       .99999999999715 2.3874823053617365e-6
       .999999999997122 2.3991856499958403e-6
       .9999999999970938 2.4108889946299437e-6
       .9999999999970656 2.4225923392640466e-6
       .9999999999970371 2.4342956838981495e-6
       .9999999999970085 2.445999028532252e-6
       .9999999999969799 2.457702373166354e-6
       .999999999996951 2.4694057178004558e-6
       .999999999996922 2.4811090624345574e-6
       .9999999999968929 2.4928124070686583e-6
       .9999999999968637 2.504515751702759e-6
       .9999999999968343 2.5162190963368595e-6
       .9999999999968048 2.5279224409709594e-6
       .9999999999967751 2.5396257856050594e-6
       .9999999999967454 2.5513291302391585e-6
       .9999999999967154 2.5630324748732576e-6
       .9999999999966853 2.5747358195073563e-6
       .9999999999966551 2.5864391641414546e-6
       .9999999999966248 2.5981425087755525e-6
       .9999999999965944 2.6098458534096503e-6
       .9999999999965637 2.6215491980437473e-6
       .999999999996533 2.6332525426778443e-6
       .9999999999965021 2.644955887311941e-6
       .999999999996471 2.656659231946037e-6
       .99999999999644 2.6683625765801328e-6
       .9999999999964087 2.680065921214228e-6
       .9999999999963772 2.6917692658483234e-6
       .9999999999963456 2.703472610482418e-6
       .999999999996314 2.7151759551165123e-6
       .9999999999962821 2.7268792997506064e-6
       .9999999999962501 2.7385826443846996e-6
       .9999999999962179 2.750285989018793e-6
       .9999999999961857 2.761989333652886e-6
       .9999999999961533 2.7736926782869783e-6
       .9999999999961208 2.78539602292107e-6
       .9999999999960881 2.797099367555162e-6
       .9999999999960553 2.808802712189253e-6
       .9999999999960224 2.8205060568233443e-6
       .9999999999959893 2.832209401457435e-6
       .9999999999959561 2.8439127460915247e-6
       .9999999999959227 2.8556160907256145e-6
       .9999999999958893 2.867319435359704e-6
       .9999999999958556 2.879022779993793e-6
       .9999999999958219 2.8907261246278814e-6
       .9999999999957879 2.90242946926197e-6
       .999999999995754 2.9141328138960576e-6
       .9999999999957198 2.925836158530145e-6
       .9999999999956855 2.9375395031642317e-6
       .999999999995651 2.9492428477983186e-6
       .9999999999956164 2.9609461924324046e-6
       .9999999999955816 2.9726495370664905e-6
       .9999999999955468 2.9843528817005757e-6
       .9999999999955118 2.996056226334661e-6
       .9999999999954767 3.007759570968745e-6
       .9999999999954414 3.0194629156028294e-6
       .999999999995406 3.0311662602369133e-6
       .9999999999953705 3.0428696048709963e-6
       .9999999999953348 3.0545729495050794e-6
       .999999999995299 3.066276294139162e-6
       .999999999995263 3.0779796387732437e-6
       .9999999999952269 3.0896829834073255e-6
       .9999999999951907 3.101386328041407e-6
       .9999999999951543 3.1130896726754873e-6
       .9999999999951178 3.1247930173095678e-6
       .9999999999950812 3.136496361943648e-6
       .9999999999950444 3.148199706577727e-6
       .9999999999950075 3.1599030512118063e-6
       .9999999999949705 3.171606395845885e-6
       .9999999999949333 3.183309740479963e-6
       .999999999994896 3.195013085114041e-6
       .9999999999948584 3.206716429748118e-6
       .9999999999948209 3.218419774382195e-6
       .9999999999947832 3.2301231190162714e-6
       .9999999999947453 3.2418264636503477e-6
       .9999999999947072 3.253529808284423e-6
       .9999999999946692 3.265233152918498e-6
       .9999999999946309 3.276936497552573e-6
       .9999999999945924 3.288639842186647e-6
       .9999999999945539 3.300343186820721e-6
       .9999999999945152 3.312046531454794e-6
       .9999999999944763 3.323749876088867e-6
       .9999999999944373 3.3354532207229395e-6
       .9999999999943983 3.3471565653570115e-6
       .9999999999943591 3.358859909991083e-6
       .9999999999943197 3.370563254625154e-6
       .9999999999942801 3.3822665992592245e-6
       .9999999999942405 3.3939699438932944e-6
       .9999999999942008 3.4056732885273643e-6
       .9999999999941608 3.4173766331614334e-6
       .9999999999941207 3.429079977795502e-6
       .9999999999940805 3.4407833224295702e-6
       .9999999999940402 3.452486667063638e-6
       .9999999999939997 3.4641900116977054e-6
       .999999999993959 3.4758933563317723e-6
       .9999999999939183 3.4875967009658384e-6
       .9999999999938775 3.4993000455999045e-6
       .9999999999938364 3.5110033902339697e-6
       .9999999999937953 3.5227067348680345e-6
       .999999999993754 3.534410079502099e-6
       .9999999999937126 3.546113424136163e-6
       .999999999993671 3.5578167687702264e-6
       .9999999999936293 3.5695201134042896e-6
       .9999999999935875 3.581223458038352e-6
       .9999999999935454 3.592926802672414e-6
       .9999999999935033 3.6046301473064755e-6
       .9999999999934611 3.6163334919405365e-6
       .9999999999934187 3.628036836574597e-6
       .9999999999933762 3.639740181208657e-6
       .9999999999933334 3.6514435258427166e-6
       .9999999999932907 3.6631468704767755e-6
       .9999999999932477 3.674850215110834e-6
       .9999999999932047 3.686553559744892e-6
       .9999999999931615 3.6982569043789496e-6
       .9999999999931181 3.7099602490130064e-6
       .9999999999930747 3.7216635936470627e-6
       .999999999993031 3.733366938281119e-6
       .9999999999929873 3.745070282915174e-6
       .9999999999929433 3.756773627549229e-6
       .9999999999928992 3.768476972183284e-6
       .9999999999928552 3.7801803168173377e-6
       .9999999999928109 3.791883661451391e-6
       .9999999999927663 3.803587006085444e-6
       .9999999999927218 3.8152903507194965e-6
       .9999999999926771 3.826993695353548e-6
       .9999999999926322 3.838697039987599e-6
       .9999999999925873 3.85040038462165e-6
       .9999999999925421 3.862103729255701e-6
       .9999999999924968 3.87380707388975e-6
       .9999999999924514 3.885510418523799e-6
       .9999999999924059 3.897213763157848e-6
       .9999999999923602 3.9089171077918965e-6
       .9999999999923144 3.9206204524259435e-6
       .9999999999922684 3.9323237970599905e-6
       .9999999999922223 3.9440271416940376e-6
       .9999999999921761 3.955730486328084e-6
       .9999999999921297 3.967433830962129e-6
       .9999999999920832 3.9791371755961736e-6
       .9999999999920366 3.990840520230218e-6
       .9999999999919899 4.002543864864262e-6
       .9999999999919429 4.014247209498305e-6
       .9999999999918958 4.025950554132348e-6
       .9999999999918486 4.03765389876639e-6
       .9999999999918013 4.049357243400431e-6
       .9999999999917539 4.061060588034472e-6
       .9999999999917063 4.072763932668513e-6
       .9999999999916586 4.084467277302553e-6
       .9999999999916107 4.096170621936592e-6
       .9999999999915626 4.107873966570632e-6
       .9999999999915146 4.119577311204669e-6
       .9999999999914663 4.131280655838707e-6
       .9999999999914179 4.142984000472745e-6
       .9999999999913692 4.154687345106781e-6
       .9999999999913206 4.166390689740817e-6
       .9999999999912718 4.178094034374852e-6
       .9999999999912228 4.189797379008887e-6
       .9999999999911737 4.201500723642921e-6
       .9999999999911244 4.213204068276955e-6
       .999999999991075 4.224907412910988e-6
       .9999999999910255 4.236610757545021e-6
       .9999999999909759 4.248314102179053e-6
       .9999999999909261 4.260017446813084e-6
       .9999999999908762 4.271720791447115e-6
       .9999999999908261 4.283424136081145e-6
       .9999999999907759 4.295127480715175e-6
       .9999999999907256 4.306830825349204e-6
       .9999999999906751 4.3185341699832325e-6
       .9999999999906245 4.33023751461726e-6
       .9999999999905738 4.3419408592512875e-6
       .9999999999905229 4.353644203885314e-6
       .9999999999904718 4.36534754851934e-6
       .9999999999904207 4.377050893153365e-6
       .9999999999903694 4.38875423778739e-6
       .999999999990318 4.400457582421414e-6
       .9999999999902665 4.4121609270554384e-6
       .9999999999902147 4.423864271689461e-6
       .9999999999901629 4.435567616323483e-6
       .9999999999901109 4.447270960957506e-6
       .9999999999900587 4.458974305591527e-6
       .9999999999900065 4.470677650225547e-6
       .9999999999899541 4.482380994859567e-6
       .9999999999899016 4.494084339493587e-6
       .9999999999898489 4.5057876841276054e-6
       .9999999999897962 4.517491028761624e-6
       .9999999999897432 4.529194373395641e-6
       .9999999999896901 4.5408977180296584e-6
       .999999999989637 4.552601062663675e-6
       .9999999999895836 4.564304407297691e-6
       .99999999998953 4.5760077519317055e-6
       .9999999999894764 4.5877110965657195e-6
       .9999999999894227 4.5994144411997335e-6
       .9999999999893688 4.611117785833747e-6
       .9999999999893148 4.622821130467759e-6
       .9999999999892606 4.634524475101771e-6
       .9999999999892063 4.646227819735783e-6
       .9999999999891518 4.657931164369793e-6
       .9999999999890973 4.669634509003803e-6
       .9999999999890425 4.681337853637813e-6
       .9999999999889877 4.693041198271821e-6
       .9999999999889327 4.704744542905829e-6
       .9999999999888776 4.716447887539837e-6
       .9999999999888223 4.728151232173843e-6
       .9999999999887669 4.73985457680785e-6
       .9999999999887114 4.751557921441855e-6
       .9999999999886556 4.76326126607586e-6
       .9999999999885999 4.774964610709864e-6
       .9999999999885439 4.786667955343868e-6
       .9999999999884878 4.798371299977871e-6
       .9999999999884316 4.810074644611873e-6
       .9999999999883752 4.821777989245874e-6
       .9999999999883187 4.833481333879875e-6
       .9999999999882621 4.845184678513876e-6
       .9999999999882053 4.856888023147875e-6
       .9999999999881484 4.868591367781874e-6
       .9999999999880914 4.880294712415872e-6
       .9999999999880341 4.89199805704987e-6
       .9999999999879768 4.903701401683867e-6
       .9999999999879194 4.915404746317863e-6
       .9999999999878618 4.9271080909518585e-6
       .9999999999878041 4.938811435585853e-6
       .9999999999877462 4.9505147802198475e-6
       .9999999999876882 4.962218124853841e-6
       .99999999998763 4.973921469487834e-6
       .9999999999875717 4.985624814121826e-6
       .9999999999875133 4.997328158755817e-6
       .9999999999874548 5.009031503389808e-6
       .9999999999873961 5.0207348480237985e-6
       .9999999999873372 5.032438192657788e-6
       .9999999999872783 5.0441415372917765e-6
       .9999999999872192 5.055844881925764e-6
       .9999999999871599 5.067548226559752e-6
       .9999999999871007 5.079251571193739e-6
       .9999999999870411 5.090954915827725e-6
       .9999999999869814 5.10265826046171e-6
       .9999999999869217 5.1143616050956945e-6
       .9999999999868617 5.126064949729678e-6
       .9999999999868017 5.1377682943636615e-6
       .9999999999867415 5.149471638997644e-6
       .9999999999866811 5.161174983631626e-6
       .9999999999866207 5.172878328265607e-6
       .9999999999865601 5.184581672899587e-6
       .9999999999864994 5.196285017533567e-6
       .9999999999864384 5.2079883621675455e-6
       .9999999999863775 5.219691706801524e-6
       .9999999999863163 5.2313950514355015e-6
       .999999999986255 5.243098396069478e-6
       .9999999999861935 5.254801740703454e-6
       .999999999986132 5.266505085337429e-6
       .9999999999860703 5.278208429971404e-6
       .9999999999860084 5.289911774605378e-6
       .9999999999859465 5.301615119239351e-6
       .9999999999858843 5.313318463873323e-6
       .9999999999858221 5.325021808507295e-6
       .9999999999857597 5.336725153141267e-6
       .9999999999856971 5.3484284977752366e-6
       .9999999999856345 5.360131842409206e-6
       .9999999999855717 5.371835187043175e-6
       .9999999999855087 5.383538531677143e-6
       .9999999999854456 5.3952418763111104e-6
       .9999999999853825 5.406945220945077e-6
       .9999999999853191 5.418648565579043e-6
       .9999999999852557 5.4303519102130076e-6
       .9999999999851921 5.4420552548469724e-6
       .9999999999851282 5.453758599480936e-6
       .9999999999850644 5.465461944114899e-6
       .9999999999850003 5.47716528874886e-6
       .9999999999849362 5.488868633382822e-6
       .9999999999848719 5.500571978016782e-6
       .9999999999848074 5.512275322650742e-6
       .9999999999847429 5.523978667284702e-6
       .9999999999846781 5.53568201191866e-6
       .9999999999846133 5.547385356552617e-6
       .9999999999845482 5.5590887011865745e-6
       .9999999999844832 5.57079204582053e-6
       .9999999999844179 5.582495390454486e-6
       .9999999999843525 5.59419873508844e-6
       .9999999999842869 5.605902079722394e-6
       .9999999999842213 5.617605424356347e-6
       .9999999999841555 5.629308768990299e-6
       .9999999999840895 5.641012113624251e-6
       .9999999999840234 5.652715458258201e-6
       .9999999999839572 5.664418802892152e-6
       .9999999999838908 5.6761221475261e-6
       .9999999999838243 5.687825492160048e-6
       .9999999999837577 5.699528836793996e-6
       .9999999999836909 5.711232181427943e-6
       .999999999983624 5.722935526061889e-6
       .9999999999835569 5.734638870695834e-6
       .9999999999834898 5.746342215329779e-6
       .9999999999834225 5.758045559963722e-6
       .999999999983355 5.769748904597665e-6
       .9999999999832874 5.781452249231607e-6
       .9999999999832196 5.793155593865548e-6
       .9999999999831518 5.804858938499489e-6
       .9999999999830838 5.816562283133429e-6
       .9999999999830157 5.8282656277673675e-6
       .9999999999829474 5.839968972401306e-6
       .9999999999828789 5.851672317035243e-6
       .9999999999828104 5.86337566166918e-6
       .9999999999827417 5.875079006303115e-6
       .9999999999826729 5.88678235093705e-6
       .9999999999826039 5.898485695570985e-6
       .9999999999825349 5.910189040204917e-6
       .9999999999824656 5.92189238483885e-6
       .9999999999823962 5.933595729472782e-6
       .9999999999823267 5.945299074106713e-6
       .9999999999822571 5.957002418740643e-6
       .9999999999821872 5.9687057633745715e-6
       .9999999999821173 5.9804091080085e-6
       ))

    (define low-lut-rac
    '#f64(1. 0.
       .9999952938095762 .003067956762965976
       .9999811752826011 .006135884649154475
       .9999576445519639 .00920375478205982
       .9999247018391445 .012271538285719925
       .9998823474542126 .015339206284988102
       .9998305817958234 .01840672990580482
       .9997694053512153 .021474080275469508
       .9996988186962042 .024541228522912288
       .9996188224951786 .027608145778965743
       .9995294175010931 .030674803176636626
       .9994306045554617 .03374117185137759
       .9993223845883495 .03680722294135883
       .9992047586183639 .03987292758773981
       .9990777277526454 .04293825693494082
       .9989412931868569 .04600318213091463
       .9987954562051724 .049067674327418015
       .9986402181802653 .052131704680283324
       .9984755805732948 .05519524434968994
       .9983015449338929 .05825826450043576
       .9981181129001492 .06132073630220858
       .997925286198596 .06438263092985747
       .9977230666441916 .06744391956366406
       .9975114561403035 .07050457338961387
       .9972904566786902 .07356456359966743
       .997060070339483 .07662386139203149
       .9968202992911657 .07968243797143013
       .9965711457905548 .08274026454937569
       .996312612182778 .0857973123444399
       .996044700901252 .0888535525825246
       .9957674144676598 .09190895649713272
       .9954807554919269 .094963495329639
       .9951847266721969 .0980171403295606
       .9948793307948056 .10106986275482782
       .9945645707342554 .10412163387205457
       .9942404494531879 .10717242495680884
       .9939069700023561 .11022220729388306
       .9935641355205953 .11327095217756435
       .9932119492347945 .11631863091190477
       .9928504144598651 .11936521481099137
       .99247953459871 .1224106751992162
       .9920993131421918 .12545498341154623
       .9917097536690995 .12849811079379317
       .9913108598461154 .13154002870288312
       .99090263542778 .1345807085071262
       .9904850842564571 .13762012158648604
       .9900582102622971 .14065823933284924
       .9896220174632009 .14369503315029444
       .989176509964781 .14673047445536175
       .9887216919603238 .1497645346773215
       .9882575677307495 .15279718525844344
       .9877841416445722 .15582839765426523
       .9873014181578584 .15885814333386145
       .9868094018141855 .16188639378011183
       .9863080972445987 .16491312048996992
       .9857975091675675 .16793829497473117
       .9852776423889412 .17096188876030122
       .9847485018019042 .17398387338746382
       .984210092386929 .17700422041214875
       .9836624192117303 .18002290140569951
       .9831054874312163 .18303988795514095
       .9825393022874412 .18605515166344666
       .9819638691095552 .18906866414980622
       .9813791933137546 .19208039704989244
       .9807852804032304 .19509032201612828
       .9801821359681174 .1980984107179536
       .9795697656854405 .2011046348420919
       .9789481753190622 .20410896609281687
       .9783173707196277 .20711137619221856
       .9776773578245099 .2101118368804696
       .9770281426577544 .21311031991609136
       .9763697313300211 .21610679707621952
       .9757021300385286 .2191012401568698
       .9750253450669941 .22209362097320354
       .9743393827855759 .22508391135979283
       .973644249650812 .22807208317088573
       .9729399522055602 .2310581082806711
       .9722264970789363 .23404195858354343
       .9715038909862518 .2370236059943672
       .9707721407289504 .2400030224487415
       .970031253194544 .2429801799032639
       .9692812353565485 .24595505033579462
       .9685220942744173 .24892760574572018
       .9677538370934755 .25189781815421697
       .9669764710448521 .25486565960451457
       .9661900034454125 .257831102162159
       .9653944416976894 .2607941179152755
       .9645897932898128 .2637546789748314
       .9637760657954398 .26671275747489837
       .9629532668736839 .2696683255729151
       .9621214042690416 .272621355449949
       .9612804858113206 .27557181931095814
       .9604305194155658 .2785196893850531
       .9595715130819845 .281464937925758
       .9587034748958716 .2844075372112718
       .9578264130275329 .2873474595447295
       .9569403357322088 .2902846772544624
       .9560452513499964 .29321916269425863
       .9551411683057707 .29615088824362384
       .9542280951091057 .2990798263080405
       .9533060403541939 .3020059493192281
       .9523750127197659 .30492922973540243
       .9514350209690083 .30784964004153487
       .9504860739494817 .3107671527496115
       .9495281805930367 .31368174039889146
       .9485613499157303 .31659337555616585
       .9475855910177411 .3195020308160157
       .9466009130832835 .32240767880106985
       .9456073253805213 .3253102921622629
       .9446048372614803 .32820984357909255
       .9435934581619604 .33110630575987643
       .9425731976014469 .3339996514420094
       .9415440651830208 .33688985339222005
       .9405060705932683 .33977688440682685
       .9394592236021899 .3426607173119944
       .9384035340631081 .34554132496398904
       .937339011912575 .34841868024943456
       .9362656671702783 .35129275608556715
       .9351835099389476 .3541635254204904
       .9340925504042589 .35703096123343003
       .9329927988347388 .35989503653498817
       .9318842655816681 .3627557243673972
       .9307669610789837 .36561299780477385
       .9296408958431812 .3684668299533723
       .9285060804732156 .37131719395183754
       .9273625256504011 .374164062971458
       .9262102421383114 .37700741021641826
       .9250492407826776 .37984720892405116
       .9238795325112867 .3826834323650898
       .9227011283338785 .38551605384391885
       .9215140393420419 .3883450466988263
       .9203182767091106 .39117038430225387
       .9191138516900578 .3939920400610481
       .9179007756213905 .3968099874167103
       .9166790599210427 .39962419984564684
       .9154487160882678 .40243465085941843
       .9142097557035307 .40524131400498986
       .9129621904283982 .4080441628649787
       .9117060320054299 .41084317105790397
       .9104412922580672 .41363831223843456
       .9091679830905224 .4164295600976372
       .9078861164876663 .41921688836322396
       .9065957045149153 .4220002707997997
       .9052967593181188 .4247796812091088
       .9039892931234433 .4275550934302821
       .9026733182372588 .4303264813400826
       .901348847046022 .43309381885315196
       .9000158920161603 .4358570799222555
       .8986744656939538 .43861623853852766
       .8973245807054183 .44137126873171667
       .8959662497561851 .44412214457042926
       .8945994856313827 .4468688401623742
       .8932243011955153 .4496113296546066
       .8918407093923427 .4523495872337709
       .8904487232447579 .45508358712634384
       .8890483558546646 .45781330359887723
       .8876396204028539 .46053871095824
       .8862225301488806 .4632597835518602
       .8847970984309378 .4659764957679662
       .8833633386657316 .46868882203582796
       .881921264348355 .47139673682599764
       .8804708890521608 .47410021465055
       .8790122264286335 .47679923006332214
       .8775452902072612 .479493757660153
       .8760700941954066 .4821837720791228
       .8745866522781761 .4848692480007911
       .8730949784182901 .48755016014843594
       .8715950866559511 .49022648328829116
       .8700869911087115 .49289819222978404
       .8685707059713409 .49556526182577254
       .8670462455156926 .49822766697278187
       .8655136240905691 .5008853826112408
       .8639728561215867 .5035383837257176
       .8624239561110405 .5061866453451553
       .8608669386377673 .508830142543107
       .8593018183570084 .5114688504379704
       .8577286100002721 .5141027441932218
       .8561473283751945 .5167317990176499
       .8545579883654005 .5193559901655896
       .8529606049303636 .5219752929371544
       .8513551931052652 .524589682678469
       .8497417680008524 .5271991347819014
       .8481203448032972 .5298036246862947
       .8464909387740521 .532403127877198
       .8448535652497071 .5349976198870973
       .8432082396418454 .5375870762956455
       .8415549774368984 .5401714727298929
       .8398937941959995 .5427507848645159
       .8382247055548381 .5453249884220465
       .836547727223512 .5478940591731002
       .83486287498638 .5504579729366048
       .8331701647019132 .5530167055800276
       .8314696123025452 .5555702330196022
       .829761233794523 .5581185312205561
       .8280450452577558 .560661576197336
       .8263210628456635 .5631993440138341
       .8245893027850253 .5657318107836132
       .8228497813758263 .5682589526701316
       .8211025149911046 .5707807458869673
       .819347520076797 .5732971666980422
       .8175848131515837 .5758081914178453
       .8158144108067338 .5783137964116556
       .8140363297059484 .5808139580957645
       .8122505865852039 .5833086529376983
       .8104571982525948 .5857978574564389
       .808656181588175 .5882815482226453
       .8068475535437992 .5907597018588743
       .8050313311429635 .5932322950397998
       .8032075314806449 .5956993044924334
       .8013761717231402 .5981607069963423
       .799537269107905 .600616479383869
       .7976908409433912 .6030665985403482
       .7958369046088836 .6055110414043255
       .7939754775543372 .6079497849677736
       .7921065773002124 .6103828062763095
       .79023022143731 .6128100824294097
       .7883464276266062 .6152315905806268
       .7864552135990858 .617647307937804
       .7845565971555752 .6200572117632892
       .7826505961665757 .62246127937415
       .7807372285720945 .6248594881423863
       .778816512381476 .6272518154951441
       .7768884656732324 .629638238914927
       .7749531065948739 .6320187359398091
       .773010453362737 .6343932841636455
       .7710605242618138 .6367618612362842
       .7691033376455796 .6391244448637757
       .7671389119358204 .6414810128085832
       .765167265622459 .6438315428897915
       .7631884172633813 .6461760129833164
       .7612023854842618 .6485144010221124
       .7592091889783881 .6508466849963809
       .7572088465064846 .6531728429537768
       .7552013768965365 .6554928529996153
       .7531867990436125 .6578066932970786
       .7511651319096864 .6601143420674205
       .7491363945234594 .6624157775901718
       .7471006059801801 .6647109782033449
       .745057785441466 .6669999223036375
       .7430079521351217 .6692825883466361
       .7409511253549591 .6715589548470184
       .7388873244606151 .673829000378756
       .7368165688773699 .6760927035753159
       .7347388780959635 .6783500431298615
       .7326542716724128 .680600997795453
       .7305627692278276 .6828455463852481
       .7284643904482252 .6850836677727004
       .726359155084346 .6873153408917592
       .7242470829514669 .6895405447370669
       .7221281939292153 .6917592583641577
       .7200025079613817 .693971460889654
       .7178700450557317 .696177131491463
       .7157308252838187 .6983762494089728
       .7135848687807936 .7005687939432483
       .7114321957452164 .7027547444572253
       .7092728264388657 .7049340803759049
       ))

    (define (make-w log-n)
      (let* ((n (##expt 2 log-n))  ;; number of complexes
             (result (##make-f64vector (##fx* 2 n))))

        (define (copy-low-lut)
          (##declare (not interrupts-enabled))
          (do ((i 0 (##fx+ i 1)))
              ((##fx= i lut-table-size))
            (let ((index (##fx* i 2)))
              (##f64vector-set!
               result
               index
               (##f64vector-ref low-lut index))
              (##f64vector-set!
               result
               (##fx+ index 1)
               (##f64vector-ref low-lut (##fx+ index 1))))))

        (define (extend-lut multiplier-lut bit-reverse-size bit-reverse-multiplier start end)

          (define (bit-reverse x n)
            (declare (not interrupts-enabled))
            (do ((i 0 (##fx+ i 1))
                 (x x (##fxarithmetic-shift-right x 1))
                 (result 0 (##fx+ (##fx* result 2)
                                       (##fxand x 1))))
                ((##fx= i n) result)))

          (let loop ((i start)
                     (j 1))
            (if (##fx< i end)
                (let* ((multiplier-index
                        (##fx* 2
                                    (bit-reverse j bit-reverse-size)
                                    bit-reverse-multiplier))
                       (multiplier-real
                        (##f64vector-ref multiplier-lut multiplier-index))
                       (multiplier-imag
                        (##f64vector-ref multiplier-lut (##fx+ multiplier-index 1))))
                  (let inner ((i i)
                              (k 0))
                    (declare (not interrupts-enabled))
                    ;; we copy complex multiples of all entries below
                    ;; start to entries starting at start
                    (if (##fx< k start)
                        (let* ((index
                                (##fx* k 2))
                               (real
                                (##f64vector-ref result index))
                               (imag
                                (##f64vector-ref result (##fx+ index 1)))
                               (result-real
                                (##fl- (##fl* multiplier-real real)
                                            (##fl* multiplier-imag imag)))
                               (result-imag
                                (##fl+ (##fl* multiplier-real imag)
                                            (##fl* multiplier-imag real)))
                               (result-index (##fx* i 2)))
                          (##f64vector-set! result result-index result-real)
                          (##f64vector-set! result (##fx+ result-index 1) result-imag)
                          (inner (##fx+ i 1)
                                 (##fx+ k 1)))
                        (loop i
                              (##fx+ j 1)))))
                result)))

        (cond ((##fx<= n lut-table-size)
               low-lut)
              ((##fx<= n lut-table-size^2)
               (copy-low-lut)
               (extend-lut med-lut
                           (##fx- log-n log-lut-table-size)
                           (##fxarithmetic-shift-left 1 (##fx- (##fx* 2 log-lut-table-size) log-n))
                           lut-table-size
                           n))
              (else ;; (##fx<= n lut-table-size^3)
               (copy-low-lut)
               (extend-lut med-lut
                           log-lut-table-size
                           1
                           lut-table-size
                           lut-table-size^2)
               (extend-lut high-lut
                           (##fx- log-n (##fx* 2 log-lut-table-size))
                           (##fxarithmetic-shift-left 1 (##fx- (##fx* 3 log-lut-table-size) log-n))
                           lut-table-size^2
                           n)))))

    (define (two^p>=m m)
      ;; returns smallest p, assumes fixnum m >= 0
      (##fxlength (##fx- m)))

    ;; The next two routines are so-called radix-4 ffts, which seems
    ;; to mean that they combine two passes, each of which works on
    ;; pairs of complex numbers (hence radix-2?), so if you combine
    ;; two passes in one, you work on two pairs of complex numbers at
    ;; a time and make half as many passes through the f64vector a.

    (define (direct-fft-recursive-4 a W-table)

      ;; This is a direcct complex fft, using a decimation-in-time
      ;; algorithm with inputs in natural order and outputs in
      ;; bit-reversed order.  The table of "twiddle" factors is in
      ;; bit-reversed order.

      ;; this is from page 66 of Chu and George, except that we have
      ;; combined passes in pairs to cut the number of passes through
      ;; the vector a

      (let ((W (##f64vector (macro-inexact-+0)
                            (macro-inexact-+0)
                            (macro-inexact-+0)
                            (macro-inexact-+0))))

        (define (main-loop M N K SizeOfGroup)

          (##declare (not interrupts-enabled))

          (let inner-loop ((K K)
                           (JFirst M))

            (if (##fx< JFirst N)

                (let* ((JLast  (##fx+ JFirst SizeOfGroup)))

                  (if (##fxeven? K)
                      (begin
                        (##f64vector-set! W 0 (##f64vector-ref W-table K))
                        (##f64vector-set! W 1 (##f64vector-ref W-table (##fx+ K 1))))
                      (begin
                        (##f64vector-set! W 0 (##fl- (##f64vector-ref W-table K)))
                        (##f64vector-set! W 1 (##f64vector-ref W-table (##fx- K 1)))))

                  ;; we know the that the next two complex roots of
                  ;; unity have index 2K and 2K+1 so that the 2K+1
                  ;; index root can be gotten from the 2K index root
                  ;; in the same way that we get W_0 and W_1 from the
                  ;; table depending on whether K is even or not

                  (##f64vector-set! W 2 (##f64vector-ref W-table (##fx* K 2)))
                  (##f64vector-set! W 3 (##f64vector-ref W-table (##fx+ (##fx* K 2) 1)))

                  (let J-loop ((J0 JFirst))
                    (if (##fx< J0 JLast)

                        (let* ((J0 J0)
                               (J1 (##fx+ J0 1))
                               (J2 (##fx+ J0 SizeOfGroup))
                               (J3 (##fx+ J2 1))
                               (J4 (##fx+ J2 SizeOfGroup))
                               (J5 (##fx+ J4 1))
                               (J6 (##fx+ J4 SizeOfGroup))
                               (J7 (##fx+ J6 1)))

                          (let ((W_0  (##f64vector-ref W 0))
                                (W_1  (##f64vector-ref W 1))
                                (W_2  (##f64vector-ref W 2))
                                (W_3  (##f64vector-ref W 3))
                                (a_J0 (##f64vector-ref a J0))
                                (a_J1 (##f64vector-ref a J1))
                                (a_J2 (##f64vector-ref a J2))
                                (a_J3 (##f64vector-ref a J3))
                                (a_J4 (##f64vector-ref a J4))
                                (a_J5 (##f64vector-ref a J5))
                                (a_J6 (##f64vector-ref a J6))
                                (a_J7 (##f64vector-ref a J7)))

                            ;; first we do the (overlapping) pairs of
                            ;; butterflies with entries 2*SizeOfGroup
                            ;; apart.

                            (let ((Temp_0 (##fl- (##fl* W_0 a_J4)
                                                      (##fl* W_1 a_J5)))
                                  (Temp_1 (##fl+ (##fl* W_0 a_J5)
                                                      (##fl* W_1 a_J4)))
                                  (Temp_2 (##fl- (##fl* W_0 a_J6)
                                                      (##fl* W_1 a_J7)))
                                  (Temp_3 (##fl+ (##fl* W_0 a_J7)
                                                      (##fl* W_1 a_J6))))

                              (let ((a_J0 (##fl+ a_J0 Temp_0))
                                    (a_J1 (##fl+ a_J1 Temp_1))
                                    (a_J2 (##fl+ a_J2 Temp_2))
                                    (a_J3 (##fl+ a_J3 Temp_3))
                                    (a_J4 (##fl- a_J0 Temp_0))
                                    (a_J5 (##fl- a_J1 Temp_1))
                                    (a_J6 (##fl- a_J2 Temp_2))
                                    (a_J7 (##fl- a_J3 Temp_3)))

                                ;; now we do the two (disjoint) pairs
                                ;; of butterflies distance SizeOfGroup
                                ;; apart, the first pair with W2+W3i,
                                ;; the second with -W3+W2i

                                ;; we rewrite the multipliers so I
                                ;; don't hurt my head too much when
                                ;; thinking about them.

                                (let ((W_0 W_2)
                                      (W_1 W_3)
                                      (W_2 (##fl- W_3))
                                      (W_3 W_2))

                                  (let ((Temp_0
                                         (##fl- (##fl* W_0 a_J2)
                                                     (##fl* W_1 a_J3)))
                                        (Temp_1
                                         (##fl+ (##fl* W_0 a_J3)
                                                     (##fl* W_1 a_J2)))
                                        (Temp_2
                                         (##fl- (##fl* W_2 a_J6)
                                                     (##fl* W_3 a_J7)))
                                        (Temp_3
                                         (##fl+ (##fl* W_2 a_J7)
                                                     (##fl* W_3 a_J6))))

                                    (let ((a_J0 (##fl+ a_J0 Temp_0))
                                          (a_J1 (##fl+ a_J1 Temp_1))
                                          (a_J2 (##fl- a_J0 Temp_0))
                                          (a_J3 (##fl- a_J1 Temp_1))
                                          (a_J4 (##fl+ a_J4 Temp_2))
                                          (a_J5 (##fl+ a_J5 Temp_3))
                                          (a_J6 (##fl- a_J4 Temp_2))
                                          (a_J7 (##fl- a_J5 Temp_3)))

                                      (##f64vector-set! a J0 a_J0)
                                      (##f64vector-set! a J1 a_J1)
                                      (##f64vector-set! a J2 a_J2)
                                      (##f64vector-set! a J3 a_J3)
                                      (##f64vector-set! a J4 a_J4)
                                      (##f64vector-set! a J5 a_J5)
                                      (##f64vector-set! a J6 a_J6)
                                      (##f64vector-set! a J7 a_J7)

                                      (J-loop (##fx+ J0 2)))))))))
                        (inner-loop (##fx+ K 1)
                                    (##fx+ JFirst (##fx* SizeOfGroup 4)))))))))

        (define (recursive-bit M N K SizeOfGroup)
          (if (##fx<= 2 SizeOfGroup)
              (begin
                (main-loop M N K SizeOfGroup)
                (if (##fx< 2048 (##fx- N M))
                    (let ((new-size (##fxarithmetic-shift-right (##fx- N M) 2)))
                      (recursive-bit M
                                     (##fx+ M new-size)
                                     (##fx* K 4)
                                     (##fxarithmetic-shift-right SizeOfGroup 2))
                      (recursive-bit (##fx+ M new-size)
                                     (##fx+ M (##fx* new-size 2))
                                     (##fx+ (##fx* K 4) 1)
                                     (##fxarithmetic-shift-right SizeOfGroup 2))
                      (recursive-bit (##fx+ M (##fx* new-size 2))
                                     (##fx+ M (##fx* new-size 3))
                                     (##fx+ (##fx* K 4) 2)
                                     (##fxarithmetic-shift-right SizeOfGroup 2))
                      (recursive-bit (##fx+ M (##fx* new-size 3))
                                     N
                                     (##fx+ (##fx* K 4) 3)
                                     (##fxarithmetic-shift-right SizeOfGroup 2)))
                    (recursive-bit M
                                   N
                                   (##fx* K 4)
                                   (##fxarithmetic-shift-right SizeOfGroup 2))))))

        (define (radix-2-pass a)

          ;; If we're here, the size of our (conceptually complex)
          ;; array is not a power of 4, so we need to do a basic radix
          ;; two pass with w=1 (so W[0]=1.0 and W[1] = 0.)  and then
          ;; call recursive-bit appropriately on the two half arrays.

          (declare (not interrupts-enabled))

          (let ((SizeOfGroup
                 (##fxarithmetic-shift-right (##f64vector-length a) 1)))
            (let loop ((J0 0))
              (if (##fx< J0 SizeOfGroup)
                  (let ((J0 J0)
                        (J2 (##fx+ J0 SizeOfGroup)))
                    (let ((J1 (##fx+ J0 1))
                          (J3 (##fx+ J2 1)))
                      (let ((a_J0 (##f64vector-ref a J0))
                            (a_J1 (##f64vector-ref a J1))
                            (a_J2 (##f64vector-ref a J2))
                            (a_J3 (##f64vector-ref a J3)))
                        (let ((a_J0 (##fl+ a_J0 a_J2))
                              (a_J1 (##fl+ a_J1 a_J3))
                              (a_J2 (##fl- a_J0 a_J2))
                              (a_J3 (##fl- a_J1 a_J3)))
                          (##f64vector-set! a J0 a_J0)
                          (##f64vector-set! a J1 a_J1)
                          (##f64vector-set! a J2 a_J2)
                          (##f64vector-set! a J3 a_J3)
                          (loop (##fx+ J0 2))))))))))

        (let* ((n (##f64vector-length a))
               (log_n (two^p>=m n)))

          ;; there are n/2 complex entries in a; if n/2 is not a power
          ;; of 4, then do a single radix-2 pass and do the rest of
          ;; the passes as radix-4 passes

          (if (##fxodd? log_n)
              (recursive-bit 0 n 0 (##fxarithmetic-shift-right n 2))
              (let ((n/2 (##fxarithmetic-shift-right n 1))
                    (n/8 (##fxarithmetic-shift-right n 3)))
                (radix-2-pass a)
                (recursive-bit 0 n/2 0 n/8)
                (recursive-bit n/2 n 1 n/8))))))

    ;; The following routine simply reverses the operations of the
    ;; previous routine.

    (define (inverse-fft-recursive-4 a W-table)

      ;; This is an complex fft, using a decimation-in-frequency algorithm
      ;; with inputs in bit-reversed order and outputs in natural order.

      ;; The organization of the algorithm has little to do with the the
      ;; associated algorithm on page 41 of Chu and George,
      ;; I just reversed the operations of the direct algorithm given
      ;; above (without dividing by 2 each time, so that this has to
      ;; be "normalized" by dividing by N/2 at the end.

      ;; The table of "twiddle" factors is in bit-reversed order.

      (let ((W (##f64vector (macro-inexact-+0)
                            (macro-inexact-+0)
                            (macro-inexact-+0)
                            (macro-inexact-+0))))

        (define (main-loop M N K SizeOfGroup)
          (##declare (not interrupts-enabled))
          (let inner-loop ((K K)
                           (JFirst M))
            (if (##fx< JFirst N)
                (let* ((JLast  (##fx+ JFirst SizeOfGroup)))
                  (if (##fxeven? K)
                      (begin
                        (##f64vector-set! W 0 (##f64vector-ref W-table K))
                        (##f64vector-set! W 1 (##f64vector-ref W-table (##fx+ K 1))))
                      (begin
                        (##f64vector-set! W 0 (##fl- (##f64vector-ref W-table K)))
                        (##f64vector-set! W 1 (##f64vector-ref W-table (##fx- K 1)))))
                  (##f64vector-set! W 2 (##f64vector-ref W-table (##fx* K 2)))
                  (##f64vector-set! W 3 (##f64vector-ref W-table (##fx+ (##fx* K 2) 1)))
                  (let J-loop ((J0 JFirst))
                    (if (##fx< J0 JLast)
                        (let* ((J0 J0)
                               (J1 (##fx+ J0 1))
                               (J2 (##fx+ J0 SizeOfGroup))
                               (J3 (##fx+ J2 1))
                               (J4 (##fx+ J2 SizeOfGroup))
                               (J5 (##fx+ J4 1))
                               (J6 (##fx+ J4 SizeOfGroup))
                               (J7 (##fx+ J6 1)))
                          (let ((W_0  (##f64vector-ref W 0))
                                (W_1  (##f64vector-ref W 1))
                                (W_2  (##f64vector-ref W 2))
                                (W_3  (##f64vector-ref W 3))
                                (a_J0 (##f64vector-ref a J0))
                                (a_J1 (##f64vector-ref a J1))
                                (a_J2 (##f64vector-ref a J2))
                                (a_J3 (##f64vector-ref a J3))
                                (a_J4 (##f64vector-ref a J4))
                                (a_J5 (##f64vector-ref a J5))
                                (a_J6 (##f64vector-ref a J6))
                                (a_J7 (##f64vector-ref a J7)))
                            (let ((W_00 W_2)
                                  (W_01 W_3)
                                  (W_02 (##fl- W_3))
                                  (W_03 W_2))
                              (let ((Temp_0 (##fl- a_J0 a_J2))
                                    (Temp_1 (##fl- a_J1 a_J3))
                                    (Temp_2 (##fl- a_J4 a_J6))
                                    (Temp_3 (##fl- a_J5 a_J7)))
                                (let ((a_J0 (##fl+ a_J0 a_J2))
                                      (a_J1 (##fl+ a_J1 a_J3))
                                      (a_J4 (##fl+ a_J4 a_J6))
                                      (a_J5 (##fl+ a_J5 a_J7))
                                      (a_J2 (##fl+ (##fl* W_00 Temp_0)
                                                        (##fl* W_01 Temp_1)))
                                      (a_J3 (##fl- (##fl* W_00 Temp_1)
                                                        (##fl* W_01 Temp_0)))
                                      (a_J6 (##fl+ (##fl* W_02 Temp_2)
                                                        (##fl* W_03 Temp_3)))
                                      (a_J7 (##fl- (##fl* W_02 Temp_3)
                                                        (##fl* W_03 Temp_2))))
                                  (let ((Temp_0 (##fl- a_J0 a_J4))
                                        (Temp_1 (##fl- a_J1 a_J5))
                                        (Temp_2 (##fl- a_J2 a_J6))
                                        (Temp_3 (##fl- a_J3 a_J7)))
                                    (let ((a_J0 (##fl+ a_J0 a_J4))
                                          (a_J1 (##fl+ a_J1 a_J5))
                                          (a_J2 (##fl+ a_J2 a_J6))
                                          (a_J3 (##fl+ a_J3 a_J7))
                                          (a_J4 (##fl+ (##fl* W_0 Temp_0)
                                                            (##fl* W_1 Temp_1)))
                                          (a_J5 (##fl- (##fl* W_0 Temp_1)
                                                            (##fl* W_1 Temp_0)))
                                          (a_J6 (##fl+ (##fl* W_0 Temp_2)
                                                            (##fl* W_1 Temp_3)))
                                          (a_J7 (##fl- (##fl* W_0 Temp_3)
                                                            (##fl* W_1 Temp_2))))
                                      (##f64vector-set! a J0 a_J0)
                                      (##f64vector-set! a J1 a_J1)
                                      (##f64vector-set! a J2 a_J2)
                                      (##f64vector-set! a J3 a_J3)
                                      (##f64vector-set! a J4 a_J4)
                                      (##f64vector-set! a J5 a_J5)
                                      (##f64vector-set! a J6 a_J6)
                                      (##f64vector-set! a J7 a_J7)
                                      (J-loop (##fx+ J0 2)))))))))
                        (inner-loop (##fx+ K 1)
                                    (##fx+ JFirst (##fx* SizeOfGroup 4)))))))))

        (define (recursive-bit M N K SizeOfGroup)
          (if (##fx<= 2 SizeOfGroup)
              (begin
                (if (##fx< 2048 (##fx- N M))
                    (let ((new-size (##fxarithmetic-shift-right (##fx- N M) 2)))
                      (recursive-bit M
                                     (##fx+ M new-size)
                                     (##fx* K 4)
                                     (##fxarithmetic-shift-right SizeOfGroup 2))
                      (recursive-bit (##fx+ M new-size)
                                     (##fx+ M (##fx* new-size 2))
                                     (##fx+ (##fx* K 4) 1)
                                     (##fxarithmetic-shift-right SizeOfGroup 2))
                      (recursive-bit (##fx+ M (##fx* new-size 2))
                                     (##fx+ M (##fx* new-size 3))
                                     (##fx+ (##fx* K 4) 2)
                                     (##fxarithmetic-shift-right SizeOfGroup 2))
                      (recursive-bit (##fx+ M (##fx* new-size 3))
                                     N
                                     (##fx+ (##fx* K 4) 3)
                                     (##fxarithmetic-shift-right SizeOfGroup 2)))
                    (recursive-bit M
                                   N
                                   (##fx* K 4)
                                   (##fxarithmetic-shift-right SizeOfGroup 2)))
                (main-loop M N K SizeOfGroup))))

        (define (radix-2-pass a)
          (declare (not interrupts-enabled))
          (let ((SizeOfGroup
                 (##fxarithmetic-shift-right (##f64vector-length a) 1)))
            (let loop ((J0 0))
              (if (##fx< J0 SizeOfGroup)
                  (let ((J0 J0)
                        (J2 (##fx+ J0 SizeOfGroup)))
                    (let ((J1 (##fx+ J0 1))
                          (J3 (##fx+ J2 1)))
                      (let ((a_J0 (##f64vector-ref a J0))
                            (a_J1 (##f64vector-ref a J1))
                            (a_J2 (##f64vector-ref a J2))
                            (a_J3 (##f64vector-ref a J3)))
                        (let ((a_J0 (##fl+ a_J0 a_J2))
                              (a_J1 (##fl+ a_J1 a_J3))
                              (a_J2 (##fl- a_J0 a_J2))
                              (a_J3 (##fl- a_J1 a_J3)))
                          (##f64vector-set! a J0 a_J0)
                          (##f64vector-set! a J1 a_J1)
                          (##f64vector-set! a J2 a_J2)
                          (##f64vector-set! a J3 a_J3)
                          (loop (##fx+ J0 2))))))))))

        (let* ((n (##f64vector-length a))
               (log_n (two^p>=m n)))
          (if (##fxodd? log_n)
              (recursive-bit 0 n 0 (##fxarithmetic-shift-right n 2))
              (let ((n/2 (##fxarithmetic-shift-right n 1))
                    (n/8 (##fxarithmetic-shift-right n 3)))
                (recursive-bit 0 n/2 0 n/8)
                (recursive-bit n/2 n 1 n/8)
                (radix-2-pass a))))))

    #|

    See the wonderful paper
    Rapid multiplication modulo the sum and difference of highly
    composite numbers, by Colin Percival, electronically published
    by Mathematics of Computation, number S 0025-5718(02)01419-9, URL
    http://www.ams.org/journal-getitem?pii=S0025-5718-02-01419-9
    that gives these very nice error bounds.  This should be published
    in the paper journal sometime after March 2002.

    What we're going to do is:

    Take x and y, each with <= 2^n 8-bit fdigits.
    Put the fdigits of x and y into the real parts of the
    first 2^n complex entries of a vector of length 2^{n+1}.
    Do ffts of length 2^{n+1}.
    Multiply the complex fft coefficients of x and y.
    do an inverse fft of length 2^{n+1}.
    Extract the digits of x*y from the real parts of the inverse fft.

    From theorem 5.1 we get the following error bound:

    (define epsilon (expt 2. -53))
    (define bigepsilon (* epsilon (sqrt 5)))
    (define n 26)
    (define beta 4.158491068379826e-16)      ;; accuracy of trigonometric inputs (check) error in product of three entries from the tables
    (define norm-x (sqrt (* (expt 2 n) (* 255 255))))
    (define norm-y norm-x)
    (define error (* norm-x
                     norm-y
                     ;; the following three lines use the slight overestimate that
                     ;; ln(1+epsilon) = epsilon, etc.
                     ;; there are more accurate ways to calculate this, but we
                     ;; don't really need them.
                     (- (exp (+ (* 3 (+ n 1) epsilon)
                                (* (+ (* 3 (+ n 1)) 1) bigepsilon)
                                (* 3 (+ n 1) beta)))
                        1)))
    (pp error)

    Error bound is .27518123388290405  < 1/2

    So if x and y have fewer than 2^{26}\times 8=536,870,912 bits, this computes the product exactly.

    It appears that we need tables only of size 2^9 complex entries rather than 2^10 if we do this.  That would
    cut down on memory.

    Let's look at what happens when you have 4-bit fft words:

    (define epsilon (expt 2. -53))
    (define bigepsilon (* epsilon (sqrt 5)))
    (define n 34)
    (define beta 4.158491068379826e-16)      ;; accuracy of trigonometric inputs
    (define l 4)
    (define norm-x (sqrt (* (expt 2 n) (* 15 15))))
    (define norm-y norm-x)
    (define error (* norm-x
                     norm-y
                     (- (exp (+ (* 3 (+ n 1) epsilon)
                                (* (+ (* 3 (+ n 1)) 1) bigepsilon)
                                (* 3 (+ n 1) beta)))
                        1)))
    (pp error)

    Error bound is .31585693359375 < 1/2

    So if x and y have fewer than 2^{34}\times 4=68,719,476,736 bits, this
    computes the product exactly.

    But then I would have to increase the size of the tables to 2^{11}
    complex entries each, so we'd have tables of 4 times the size.

    I think I won't add a four-bit fft word option for now.

    Because the fft algorithm as written requires temporary storage at least
    sixteen times the size of the final result, people working with large
    integers but barely enough memory on 64-bit machines may wish to
    set! ##bignum.fft-mul-max-width to a slightly smaller value so that
    karatsuba will kick in earlier for the largest integers.

    COMMENTS FOR THE RAC (Right-Angle Convolution) VERSION

    What we're going to do is:

    Take x and y, which together have a total of  <= 2^{n+1} 8-bit fdigits.
    We take the fdigits of f and put them into the real parts of a complex
    vector of length 2^n; if there are any left over, place the rest in the
    imaginary parts of the complex vector, starting over at the 0 entry.
    We do the same for y.
    We componentwise multiply x_j by e^{\pi/2 i j/2^n}; similarly for y_j.
    (This is the "right-angle" part of the right-angle transform.)
    The maximum possible product of |x|_2 and |y|_2 are when they both
    have 2^n eight-bit digits.
    Do ffts of length 2^n.
    Multiply the complex fft coefficients of x and y.
    do an inverse fft of length 2^n.
    We componentwise multiply the result by e^{-\pi/2 i j/2^n}, i.e.,
    the inverse of the entries of the weights applied to x and y

    Extract the digits of x*y from the real parts and then the imaginary
    parts of the weighted inverse fft.

    From Theorem 6.1 and the following displayed equation we have

    (define epsilon (expt 2. -53))
    (define bigepsilon (* epsilon (sqrt 5)))
    (define n 26)
    (define beta 4.164343159519809e-16)      ;; accuracy of trigonometric inputs (check) error in product of three entries from the tables
    (define norm-x (sqrt (* (expt 2 n) (* 255 255))))
    (define norm-y norm-x)
    (define error (* norm-x
                     norm-y
                     ;; the following three lines use the slight overestimate that
                     ;; ln(1+epsilon) = epsilon, etc.
                     ;; there are more accurate ways to calculate this, but we
                     ;; don't really need them.
                     (- (exp (+ (* 3 n epsilon)
                                (* (+ (* 3 n) 4) bigepsilon)
                                (* (+ (* 3 n) 3) beta)))
                        1)))
    (pp error)

    The error bound is .2742122858762741, so we're cool.

    |#

    #|

    Let n = 2^{\log n}; the following routine calculates

    e^{\pi/2 i (j/n)} j=0,\ldots, n/2-1

    It uses the tables med-lut and high-lut (both described above) and
    low-lut-rac, which contains in fftluts-9.scm

    e^{\pi/2 i (j/2^9)}, j=0,\ldots, 2^8-1

    It uses the same general strategy as make-w, except, because the
    final result is in normal order rather than bit-reversed order, we
    start with the highest table and work our way to the lowest.  As
    noted above, this should result in slightly smaller error than from make-w.

    Instead of always building a new table, one could reuse a bigger one with
    a stride (do the math).  I don't want to do this, however; I'd rather build
    a new, compact table and hope that this will result in fewer cache/TLB/page
    misses.

    |#

    (define (make-w-rac log-n)
      (let* ((n (##expt 2 log-n))
             (result (##make-f64vector n)))   ;; contains n/2 complexes

        (define (copy-lut lut stride)

          ;; copies the (conceptually complex) entries
          ;; lut[0], lut[(stride/2)], lut[2*(stride/2)], ...
          ;; to the first entries of result.  We stop when we hit
          ;; the end of lut.

          (##declare (not interrupts-enabled))
          (let ((lut-size (##f64vector-length lut)))
            (do ((i 0 (##fx+ i 2))
                 (j 0 (##fx+ j stride)))
                ((##fx= j lut-size) result)
              (##f64vector-set! result             i    (##f64vector-ref lut             j   ))
              (##f64vector-set! result (##fx+ i 1) (##f64vector-ref lut (##fx+ j 1))))))

        (define (extend-lut multiplier-lut start)

          ;; we multiply the table from 0 to start-1 (in pairs of reals
          ;; as complexes) by all the multipliers in multiplier-lut
          ;; starting at 2 (again in pairs of reals)

          (let ((end (##f64vector-length multiplier-lut)))
            (let loop ((i start)
                       (j 2))
              (if (##fx< j end)
                  (let* ((multiplier-real (##f64vector-ref multiplier-lut j))
                         (multiplier-imag (##f64vector-ref multiplier-lut (##fx+ j 1))))
                    (let inner ((i i)
                                (k 0))
                      (declare (not interrupts-enabled))
                      (if (##fx< k start)
                          (let* ((real  (##f64vector-ref result k))
                                 (imag  (##f64vector-ref result (##fx+ k 1)))
                                 (result-real (##fl- (##fl* multiplier-real real)
                                                          (##fl* multiplier-imag imag)))
                                 (result-imag (##fl+ (##fl* multiplier-real imag)
                                                          (##fl* multiplier-imag real))))
                            (##f64vector-set! result i result-real)
                            (##f64vector-set! result (##fx+ i 1) result-imag)
                            (inner (##fx+ i 2)
                                   (##fx+ k 2)))
                          (loop i
                                (##fx+ j 2)))))
                  result))))

        (cond ((##fx= n lut-table-size)
               low-lut-rac)

              ((##fx< n lut-table-size)
               (let ((stride (##fxquotient (##fx* lut-table-size 2) n))) ;; = 2 when n = lut-table-size, etc.
                 (copy-lut low-lut-rac stride)))

              ((##fx<= n lut-table-size^2)
               (let* ((stride (##fxquotient (##fx* lut-table-size^2 2) n))
                      (start  (##fxquotient (##fx* lut-table-size 4) stride))) ;; = 2 lut-table-size when n=lut-table-size^2
                 (copy-lut med-lut stride)
                 (extend-lut low-lut-rac (##fxarithmetic-shift-right n (##fx- log-lut-table-size 1)))))

              ((##fx<= n lut-table-size^3)
               (let* ((stride (##fxquotient (##fx* lut-table-size^3 2) n))
                      (start  (##fxquotient (##fx* lut-table-size 4) stride)))
                 (copy-lut high-lut stride)
                 (extend-lut med-lut start)
                 (extend-lut low-lut-rac (##fx* start lut-table-size))))
              (else
               (error "asking for too large a table")))))

    (define (bignum->f64vector-rac x a)

      ;; Copies the first (##f64vector-length a)/2 fdigits of x into the
      ;; even components of a, which represent the real parts of complex
      ;; elements, and then the rest of the fdigits of x into the odd
      ;; components of a, starting over at 1.

      (let ((two^n (##f64vector-length a))
            (x-length (##bignum.fdigit-length x)))

        (if (##fx<= (##fx* x-length 2)
                         two^n)
            ;; all imaginary parts are 0.
            (let loop1 ((i 0)
                        (j 0))
              (##declare (not interrupts-enabled))
              (if (##fx< i x-length)
                  (let ((digit-real   (##fixnum->flonum (##bignum.fdigit-ref x i))))
                    (##f64vector-set! a             j    digit-real)
                    (##f64vector-set! a (##fx+ j 1) (macro-inexact-+0))
                    (loop1 (##fx+ i 1)
                           (##fx+ j 2)))
                                        ;; all parts are zero
                  (let loop2 ((j j))
                    (if (##fx< j two^n)
                        (begin
                          (##f64vector-set! a j (macro-inexact-+0))
                          (##f64vector-set! a (##fx+ j 1) (macro-inexact-+0))
                          (loop2 (##fx+ j 2)))))))

            (let ((offset (##fxarithmetic-shift-right two^n 1)))
              (let loop1 ((i 0)
                          (j 0))
                (##declare (not interrupts-enabled))
                (if (##fx< (##fx+ i offset) x-length)
                    (let ((digit-real (##fixnum->flonum (##bignum.fdigit-ref x             i        )))
                          (digit-imag (##fixnum->flonum (##bignum.fdigit-ref x (##fx+ i offset)))))
                      (##f64vector-set! a             j    digit-real)
                      (##f64vector-set! a (##fx+ j 1) digit-imag)
                      (loop1 (##fx+ i 1)
                             (##fx+ j 2)))
                    ;; all imaginary parts are 0.
                    (let loop2 ((i i)
                                (j j))
                      (if (##fx< j two^n)
                          (let ((digit-real   (##fixnum->flonum (##bignum.fdigit-ref x i))))
                            (##f64vector-set! a             j    digit-real)
                            (##f64vector-set! a (##fx+ j 1) (macro-inexact-+0))
                            (loop2 (##fx+ i 1)
                                   (##fx+ j 2)))))))))))

    (define (componentwise-rac-multiply a table)

      ;; the (conceptually complex) entries of table are
      ;; e^{\pi/2 i (j/2^n)}, j=0,...,2^{n-1}-1.
      ;; We multiply a_i componentwise by table_i, using symmetry when i\geq 2^{n-1}

      (let ((table-size (##f64vector-length table))
            (a-size (##f64vector-length a)))
        (declare (not interrupts-enabled))   ;; note that this means we have to be careful not to cons.
        (let loop ((i 2)
                   (j 2))
          (if (##fx< i table-size)
              (let ((multiplier-real (##f64vector-ref table i))
                    (multiplier-imag (##f64vector-ref table (##fx+ i 1))))
                (let ((a_j-real   (##f64vector-ref a             j   ))
                      (a_j-imag   (##f64vector-ref a (##fx+ j 1)))
                      (a_N-j-real (##f64vector-ref a (##fx- a-size j   )))
                      (a_N-j-imag (##f64vector-ref a (##fx- a-size j -1))))
                  (let ((result_j-real (##fl- (##fl* a_j-real multiplier-real)
                                                   (##fl* a_j-imag multiplier-imag)))
                        (result_j-imag (##fl+ (##fl* a_j-imag multiplier-real)
                                                   (##fl* a_j-real multiplier-imag)))
                        ;; if multipler_j=(make-rectangular r i) then multiplier_{N-j}=(make-rectangular i r)
                        (result_N-j-real (##fl- (##fl* a_N-j-real multiplier-imag)
                                                     (##fl* a_N-j-imag multiplier-real)))
                        (result_N-j-imag (##fl+ (##fl* a_N-j-imag multiplier-imag)
                                                     (##fl* a_N-j-real multiplier-real))))
                    (##f64vector-set! a             j    result_j-real)
                    (##f64vector-set! a (##fx+ j 1) result_j-imag)
                    (##f64vector-set! a (##fx- a-size j   ) result_N-j-real)
                    (##f64vector-set! a (##fx- a-size j -1) result_N-j-imag)
                    (loop (##fx+ i 2)
                          (##fx+ j 2)))))
              (let ((multiplier-real .7071067811865476)  ;; here the multiplier is always (sqrt i)
                    (multiplier-imag .7071067811865476)
                    (a_j-real (##f64vector-ref a j))
                    (a_j-imag (##f64vector-ref a (##fx+ j 1))))
                (let ((result_j-real (##fl- (##fl* a_j-real multiplier-real)
                                                 (##fl* a_j-imag multiplier-imag)))
                      (result_j-imag (##fl+ (##fl* a_j-imag multiplier-real)
                                                 (##fl* a_j-real multiplier-imag))))
                  (##f64vector-set! a             j    result_j-real)
                  (##f64vector-set! a (##fx+ j 1) result_j-imag)))))))

    (define (componentwise-rac-multiply-conjugate a table)
      ;; the (conceptually complex) entries of table are
      ;; e^{\pi/2 i (j/2^n)}, j=0,...,2^{n-1}-1.
      ;; We multiply a_i componentwise by the conjugate/inverse of table_i, using symmetry when i\geq 2^{n-1}

      (let ((table-size (##f64vector-length table))
            (a-size (##f64vector-length a)))
        (declare (not interrupts-enabled))   ;; note that this means we have to be careful not to cons.
        (let loop ((i 2)
                   (j 2))
          (if (##fx< i table-size)
              (let ((multiplier-real (##f64vector-ref table i))
                    (multiplier-imag (##f64vector-ref table (##fx+ i 1))))
                (let ((a_j-real   (##f64vector-ref a             j   ))
                      (a_j-imag   (##f64vector-ref a (##fx+ j 1)))
                      (a_N-j-real (##f64vector-ref a (##fx- a-size j   )))
                      (a_N-j-imag (##f64vector-ref a (##fx- a-size j -1))))

                  (let ((result_j-real (##fl+ (##fl* a_j-real multiplier-real)
                                                   (##fl* a_j-imag multiplier-imag)))
                        (result_j-imag (##fl- (##fl* a_j-imag multiplier-real)
                                                   (##fl* a_j-real multiplier-imag)))
                        ;; if multipler_j=(make-rectangular r i) then multiplier_{N-j}=(make-rectangular i r)
                        (result_N-j-real (##fl+ (##fl* a_N-j-real multiplier-imag)
                                                     (##fl* a_N-j-imag multiplier-real)))
                        (result_N-j-imag (##fl- (##fl* a_N-j-imag multiplier-imag)
                                                     (##fl* a_N-j-real multiplier-real))))
                    (##f64vector-set! a             j    result_j-real)
                    (##f64vector-set! a (##fx+ j 1) result_j-imag)
                    (##f64vector-set! a (##fx- a-size j   ) result_N-j-real)
                    (##f64vector-set! a (##fx- a-size j -1) result_N-j-imag)
                    (loop (##fx+ i 2)
                          (##fx+ j 2)))))
              (let ((multiplier-real .7071067811865476)  ;; here the multiplier is always (sqrt i)
                    (multiplier-imag .7071067811865476)
                    (a_j-real (##f64vector-ref a j))
                    (a_j-imag (##f64vector-ref a (##fx+ j 1))))
                (let ((result_j-real (##fl+ (##fl* a_j-real multiplier-real)
                                                 (##fl* a_j-imag multiplier-imag)))
                      (result_j-imag (##fl- (##fl* a_j-imag multiplier-real)
                                                 (##fl* a_j-real multiplier-imag))))
                  (##f64vector-set! a             j    result_j-real)
                  (##f64vector-set! a (##fx+ j 1) result_j-imag)))))))

    (define (componentwise-complex-multiply a b)
      (let ((two^n (##f64vector-length a)))
        (let loop ((j 0))
          (##declare (not interrupts-enabled))
          (if (##fx< j two^n)
              (let ((aj (##f64vector-ref a j))
                    (aj+1 (##f64vector-ref a (##fx+ j 1)))
                    (bj (##f64vector-ref b j))
                    (bj+1 (##f64vector-ref b (##fx+ j 1))))
                (##f64vector-set! a j
                                  (##fl- (##fl* bj aj)   (##fl* aj+1 bj+1)))
                (##f64vector-set! a (##fx+ j 1)
                                  (##fl+ (##fl* bj aj+1) (##fl* aj   bj+1)))
                (loop (##fx+ j 2)))))))

    (define (f64vector-rac->bignum a result result-length)

      ;; result-length is > the number of complex entries in a, because
      ;; otherwise the length of a would be cut in half.

      (let* ((normalizer (##fl/ (##fixnum->flonum (##fxarithmetic-shift-right (##f64vector-length a) 1))))
             (fbase (##fixnum->flonum ##bignum.fdigit-base))
             (fbase-inverse (##fl/ fbase)))
        (let ((loop-carry (##f64vector (macro-inexact-+0))))
          (let loop ((i 0)
                     (j 0)
                     (limit (##fxarithmetic-shift-right (##f64vector-length a) 1)))  ;; here we assume that there are always at least this many fdigits
            (##declare (not interrupts-enabled))
            (if (##fx< i limit)
                (let* ((t
                        (##fl+ (##fl+ (##f64vector-ref loop-carry 0)
                                                (macro-inexact-+1/2))
                                    (##fl* (##f64vector-ref a j)
                                                normalizer)))
                       (carry
                        (##flfloor (##fl* t fbase-inverse)))
                       (digit
                        (##fl- t (##fl* carry fbase))))
                  (##bignum.fdigit-set! result i (##flonum->fixnum digit))
                  (##f64vector-set! loop-carry 0 carry)
                  (loop (##fx+ i 1)
                        (##fx+ j 2)
                        limit))
                (if (##fxeven? j)
                    (loop i
                          1
                          result-length)))))))

    ;; this is the right-angle convolution method of section 6 in Percival's paper

    (let* ((x-length (##bignum.fdigit-length x))
           (y-length (##bignum.fdigit-length y))
           (result-length (##fx+ x-length y-length))
           (result (##bignum.make
                    (##fxquotient
                     result-length
                     (##fxquotient ##bignum.adigit-width
                                   ##bignum.fdigit-width))
                    #f
                    #f))
           ;; minimum power of 2 >= x-length + y-length, half # of complex elements in fft vectors
           (log-two^n (##fx- (two^p>=m (##fx+ x-length y-length)) 1))
           (two^n (##fxarithmetic-shift-left 1 log-two^n)))

      (let ((a         (##make-f64vector (##fx* two^n 2)))
            (table     (make-w     (##fx- log-two^n 1)))
            (rac-table (make-w-rac log-two^n)))

        (bignum->f64vector-rac x a)
        (componentwise-rac-multiply a rac-table)
        (direct-fft-recursive-4 a table)
        (if (##eq? x y)
            (componentwise-complex-multiply a a)
            (let ((b (##make-f64vector (##fx* two^n 2))))
              (bignum->f64vector-rac y b)
              (componentwise-rac-multiply b rac-table)
              (direct-fft-recursive-4 b table)
              (componentwise-complex-multiply a b)))
        (inverse-fft-recursive-4 a table)
        (componentwise-rac-multiply-conjugate a rac-table)
        (f64vector-rac->bignum a result result-length)
        (cleanup x y result))))


  (define (naive-mul x x-length y y-length)  ;; multiplies x by each digit of y
    (let ((result
           (##bignum.make
            (##fx+ (##bignum.adigit-length x) (##bignum.adigit-length y))
            #f
            #f)))
      (##declare (not interrupts-enabled))
      (let loop1 ((k 0))
        (if (##fx< k y-length)
            (let ((multiplier (##bignum.mdigit-ref y k)))
              (if (##fx= multiplier 0)
                (loop1 (##fx+ k 1))
                (let loop2 ((i 0)
                            (j k)
                            (carry 0))
                  (if (##fx< i x-length)
                    (loop2 (##fx+ i 1)
                           (##fx+ j 1)
                           (##bignum.mdigit-mul! result
                                                 j
                                                 x
                                                 i
                                                 multiplier
                                                 carry))
                    (begin
                      (##bignum.mdigit-set! result j carry)
                      (loop1 (##fx+ k 1)))))))
            (cleanup x y result)))))

  (define (cleanup x y result)

    ;; Both naive-mul and fft-mul do unsigned multiplies, fix that here.

    (define (fix x y result)

      (##declare (not interrupts-enabled))

      (if (##bignum.negative? y)
        (let ((x-length (##bignum.adigit-length x)))
          (let loop ((i 0)
                     (j (##bignum.adigit-length y))
                     (borrow 0))
            (if (##fx< i x-length)
              (loop (##fx+ i 1)
                    (##fx+ j 1)
                    (##bignum.adigit-sub! result j x i borrow)))))))

    (fix x y result)
    (fix y x result)
    (##bignum.normalize! result))

  (define (karatsuba-mul x y)
    (let* ((x-length
            (##bignum.adigit-length x))
           (y-length
            (##bignum.adigit-length y))
           (shift-digits
            (##fxarithmetic-shift-right y-length 1))
           (shift-bits
            (##fx* shift-digits ##bignum.adigit-width))
           (y-high
            (##bignum.arithmetic-shift y (##fx- shift-bits)))
           (y-low
            (##extract-bit-field shift-bits 0 y)))
      (if (##eq? x y)
          (let ((high-term
                 (##* y-high y-high))
                (low-term
                 (##* y-low y-low))
                (mid-term
                 (let ((arg (##- y-high y-low)))
                   (##* arg arg))))
            (##+ (##arithmetic-shift high-term (##fx* shift-bits 2))
                 (##+ (##arithmetic-shift
                       (##+ high-term
                            (##- low-term mid-term))
                       shift-bits)
                      low-term)))
          (let ((x-high
                 (##bignum.arithmetic-shift x (##fx- shift-bits)))
                (x-low
                 (##extract-bit-field shift-bits 0 x)))
            (let ((high-term
                   (##* x-high y-high))
                  (low-term
                   (##* x-low y-low))
                  (mid-term
                   (##* (##- x-high x-low)
                        (##- y-high y-low))))
              (##+ (##arithmetic-shift high-term (##fx* shift-bits 2))
                   (##+ (##arithmetic-shift
                         (##+ high-term
                              (##- low-term mid-term))
                         shift-bits)
                        low-term)))))))

  (define (mul x x-length y y-length) ;; x-length <= y-length
    (let ((x-width (##fx* x-length ##bignum.mdigit-width)))
      (cond ((##fx< x-width ##bignum.naive-mul-max-width)
             (naive-mul y y-length x x-length))
            ((or (##fx< x-width ##bignum.fft-mul-min-width)
                 (##fx< ##bignum.fft-mul-max-width
                             (##fx* y-length ##bignum.mdigit-width)))
             (karatsuba-mul x y))
            (else
             (fft-mul x y)))))

  ;; Certain decisions must be made for multiplication.
  ;; First, if both bignums are small, just do naive mul to avoid
  ;; further overhead.
  ;; This is done in the main body of ##bignum.*.
  ;; Second, if it would help to shift out low-order zeros of an
  ;; argument, do so.  That's done in the main body of ##bignum.*.
  ;; Finally, one must decide whether one is using naive mul, karatsuba, or fft.
  ;; This is done in mul.

  (define (low-bits-to-shift x)
    (let ((size (##integer-length x))
          (low-bits (##first-bit-set x)))
      (if (##fx< size (##fx+ low-bits low-bits))
          low-bits
          0)))

  (define (possibly-unnormalized-bignum-arithmetic-shift x bits)
    (if (##fx= bits 0)
        (if (##fx= (##bignum.adigit-length x) 1)
            (##bignum.normalize! x)
            x)
        (##arithmetic-shift x bits)))

  (let ((x-length (##bignum.mdigit-length x))
        (y-length (##bignum.mdigit-length y)))
    (cond ((or (##not (use-fast-bignum-algorithms))
               (and (##fx< x-length 50)
                    (##fx< y-length 50)))
           (if (##fx< x-length y-length)
               (naive-mul y y-length x x-length)
               (naive-mul x x-length y y-length)))
          ((##eq? x y)
           (let ((low-bits (low-bits-to-shift x)))
             (if (##fx= low-bits 0)
                 (mul x x-length x x-length)
                 (##arithmetic-shift
                  (##exact-int.square (##arithmetic-shift x (##fx- low-bits)))
                  (##fx+ low-bits low-bits)))))
          (else
           (let ((x-low-bits (low-bits-to-shift x))
                 (y-low-bits (low-bits-to-shift y)))
             (if (##fx= (##fx+ x-low-bits y-low-bits) 0)
                 (if (##fx< x-length y-length)
                     (mul x x-length y y-length)
                     (mul y y-length x x-length))
                 (##arithmetic-shift
                  (##* (possibly-unnormalized-bignum-arithmetic-shift x (##fx- x-low-bits))
                       (possibly-unnormalized-bignum-arithmetic-shift y (##fx- y-low-bits)))
                  (##fx+ x-low-bits y-low-bits))))))))

(define-prim (##bignum.arithmetic-shift x shift)
  (let* ((bit-shift
          (##fxmodulo shift ##bignum.adigit-width))
         (digit-shift
          (##fxquotient (##fx- shift bit-shift) ##bignum.adigit-width))
         (x-length
          (##bignum.adigit-length x))
         (result-length
          (##fx+ (##fx+ x-length digit-shift)
                 (if (##fxzero? bit-shift) 0 1))))
    (cond ((##fx< 0 result-length)
           (##bignum.normalize!
            (##bignum.arithmetic-shift-into! x shift (##bignum.make result-length #f #f))))
          ((##bignum.negative? x)
            -1)
          (else
           0))))

(define-prim (##bignum.arithmetic-shift-into! x shift result)

  #|
  Shifts x by shift bits into result.

  Left pads by sign bit as necessary, right pads by zeros as necessary.
  Makes *no* error checks.
  |#

  ;; allocates nothing
  (declare (not interrupts-enabled))

  (let* ((bit-shift
          (##fxmodulo shift ##bignum.adigit-width))
         (digit-shift
          (##fxquotient (##fx- shift bit-shift)
                        ##bignum.adigit-width))
         (x-length
          (##bignum.adigit-length x))
         (result-length
          (##bignum.adigit-length result))
         (zeros
          ##bignum.adigit-zeros)
         (left-fill
          (if (##bignum.negative? x)
              ##bignum.adigit-ones
              ##bignum.adigit-zeros)))
    (if (##fxzero? bit-shift)
        ;; Copy left-fill into leftmost digits of result as needed.
        (let loop1 ((i (##fx- result-length 1))              ;; index for adigit in result
                    (j (##fx- result-length 1 digit-shift))) ;; index for adigit in x
          (if (and (##fx>= i 0) (##fx>= j x-length))
              (begin (##bignum.adigit-copy! result i left-fill 0)
                     (loop1 (##fx- i 1) (##fx- j 1)))
              ;; Copy the digits from x into result as needed.
              (let loop2 ((i i)
                          (j j))
                (if (and (##fx>= i 0) (##fx>= j 0))
                    (begin (##bignum.adigit-copy! result i x j)
                           (loop2 (##fx- i 1) (##fx- j 1)))
                    ;; copy zero into digits of result as needed.
                    (let loop3 ((i i))
                      (if (##fx>= i 0)
                          (begin (##bignum.adigit-copy! result i zeros 0)
                                 (loop3 (##fx- i 1)))))))))
        (let ()
          ;; copy left-fill into leftmost digits of result as needed,
          ;; then concatenate left-fill with leftmost digit of x if needed.
          (define (loop4 i j)
            (if (and (##fx>= i 0) (##fx>= j x-length))
                (begin (##bignum.adigit-copy! result i left-fill 0)
                       (loop4 (##fx- i 1) (##fx- j 1)))
                (if (##fx>= i 0)
                    (if (##fx= (##fx+ j 1) x-length)
                        (begin (##bignum.adigit-cat! result i left-fill 0 x j bit-shift)
                               (loop5 (##fx- i 1) (##fx- j 1)))
                        (loop5 i j)))))
          ;; concatenate adjacent digits of x into result as needed,
          ;; then concatenate rightmost digit of x with 0 if needed.
          (define (loop5 i j)
            (if (and (##fx>= i 0) (##fx>= j 0))
                (begin (##bignum.adigit-cat! result i x (##fx+ j 1) x j bit-shift)
                       (loop5 (##fx- i 1) (##fx- j 1)))
                (if (##fx>= i 0)
                    (if (##fx= (##fx+ j 1) 0)
                        (begin (##bignum.adigit-cat! result i x 0 zeros 0 bit-shift)
                               (loop6 (##fx- i 1)))
                        (loop6 i)))))
          ;; copy 0 into rightmost digits of x as needed.
          (define (loop6 i)
            (if (##fx>= i 0)
                (begin (##bignum.adigit-copy! result i zeros 0)
                       (loop6 (##fx- i 1)))))

          (loop4 (##fx- result-length 1)                  ;; index for adigit in result
                 (##fx- result-length digit-shift 2))))   ;; index for adigit in x
    ;; return something useful
    result))

;;; Bignum division.

(define ##reciprocal-cache (##make-table 0 #f #t #f ##eq?))

(define ##bignum.mdigit-width/2
  (##fxquotient ##bignum.mdigit-width 2))

(define ##bignum.mdigit-base*16
  (##fx* ##bignum.mdigit-base 16))

(define (##fxceiling-ratio a b)
  ;; computes (ceiling (/ a b)) with a b fixnums
  (##fxquotient (##fx+ a b -1) b))

(define-prim (##bignum.div u v #!optional (need-quotient? #t) (keep-dividend? #t))

  ;; u is an unnormalized bignum, v is a normalized exact-int
  ;; 0 < v <= u

  (define (##exact-int.reciprocal v bits)

    ;; returns an approximation to the reciprocal of
    ;; .v1 v2 v3 ...
    ;; where v1 is the highest set bit of v; result is of the form
    ;; xx . xxxxxxxxxxxxxxxxxxx where there are bits + 1 bits to the
    ;; right of the binary point. The result is always <= 2; see Knuth, volume 2.

    (let ((cached-value (##table-ref ##reciprocal-cache v #f)))
      (if (and cached-value
               (##not (##fx< (##cdr cached-value) bits)))
          cached-value
          (let ((v-length (##integer-length v)))

            (define (recip v bits)
              (cond ((and cached-value
                          (##not (##fx< (##cdr cached-value) bits)))
                     cached-value)
                    ((##fx<= bits ##bignum.mdigit-width/2)
                     (##cons (##fxquotient
                              ##bignum.mdigit-base*16
                              (##arithmetic-shift
                               v
                               (##fx- ##bignum.mdigit-width/2 -3 v-length)))
                             ##bignum.mdigit-width/2))
                    (else
                     (let* ((high-bits
                             (##fxarithmetic-shift-right
                              (##fx+ bits 1)
                              1))
                            (z-bits      ;; >= high-bits + 1 to right of point
                             (recip v high-bits))
                            (z           ;; high-bits + 1 to right of point
                             (##arithmetic-shift
                              (##car z-bits)
                              (##fx- high-bits (##cdr z-bits))))
                            (v-bits      ;; bits + 3 to right of point
                             (##arithmetic-shift
                              v
                              (##fx- (##fx+ bits 3)
                                     v-length)))
                            (v*z*z       ;; 2 * high-bits + bits + 5 to right
                             (##* v-bits (##exact-int.square z)))
                            (two-z       ;; 2 * high-bits + bits + 5 to right
                             (##arithmetic-shift
                              z
                              (##fx+ high-bits (##fx+ bits 5))))
                            (temp
                             (##- two-z v*z*z))
                            (bits-to-shift
                             (##fx+ 4 (##fx+ high-bits high-bits)))
                            (shifted-temp
                             (##arithmetic-shift
                              temp
                              (##fx- bits-to-shift))))
                       (if (##fx< (##first-bit-set temp) bits-to-shift)
                           (##cons (##+ shifted-temp 1) bits)
                           (##cons shifted-temp bits))))))

            (let ((result (recip v bits)))
              (##table-set! ##reciprocal-cache v result)
              result)))))

  (define (naive-div u v)

    ;; u is a normalized bignum, v is a possibly unnormalized bignum
    ;; u >= v >= ##bignum.mdigit-base

    (define (estimate-q-hat top-bits-of-u v_n-1 v_n-2)
      ;; from Knuth
      (let ((q-hat
             (##bignum.mdigit-quotient top-bits-of-u 2 v_n-1))
            (u_n+j-2
             (##bignum.mdigit-ref top-bits-of-u 0 )))
        (let ((r-hat
               (##bignum.mdigit-remainder top-bits-of-u 2 v_n-1 q-hat)))
          (if (or (##fx= q-hat ##bignum.mdigit-base)
                  (##bignum.mdigit-test? q-hat v_n-2 r-hat u_n+j-2))
              (let ((q-hat
                     (##fx- q-hat 1))
                    (r-hat
                     (##fx+ r-hat v_n-1)))
                (if (and (##fx< r-hat ##bignum.mdigit-base)
                         (or (##fx= q-hat ##bignum.mdigit-base)
                             (##bignum.mdigit-test? q-hat v_n-2 r-hat u_n+j-2)))
                    (##fx- q-hat 1)
                    q-hat))
              q-hat))))

    (define (subtract-multiple-of-v u v q-hat n j)
      ;; subtracts q-hat * v from u, starting at mdigit j, returns final q-hat
      (##declare (not interrupts-enabled))
      (if (##fx= q-hat 0)
          q-hat
          (let loop4 ((i j)
                      (k 0)
                      (borrow 0))
            (if (##fx< k n)
                (loop4 (##fx+ i 1)
                       (##fx+ k 1)
                       (##bignum.mdigit-div! u i v k q-hat borrow))
                (let* ((borrow  (if (or (##fxzero? borrow)
                                        (##fx= i (##bignum.mdigit-length u))
                                        (##fx= (##bignum.mdigit-ref u i) 0))
                                    borrow
                                    (##bignum.mdigit-div! u i ##bignum.adigit-zeros 0 q-hat borrow))))
                  (if (##fx< borrow 0)
                      (let loop5 ((i j)
                                  (l 0)
                                  (carry 0))
                        (if (##fx< l n)
                            (loop5 (##fx+ i 1)
                                   (##fx+ l 1)
                                   (##bignum.mdigit-mul! u i v l 1 carry))
                            (begin
                              (if (and (##fx= carry 1)
                                       (not (or (##fx= i (##bignum.mdigit-length u))
                                                (##fx= (##bignum.mdigit-ref u i) 0))))
                                  (##bignum.mdigit-mul! u i ##bignum.adigit-zeros 0 1 carry))
                              (##fx- q-hat 1))))
                      q-hat))))))


    (let ((u-bits
           (##integer-length u))
          (v-bits
           (##integer-length v)))
      (let* ((n
              (##fxceiling-ratio v-bits ##bignum.mdigit-width))
             (temp
              ;; need three mdigits for top-bits-of-u
              (##bignum.make (##fxceiling-ratio (##fx* 3 ##bignum.mdigit-width)
                                                ##bignum.adigit-width)
                             #f
                             #f))
             (top-2*mdigit-width-bits-of-v
              (##bignum.arithmetic-shift-into! v (##fx- (##fx* ##bignum.mdigit-width 2) v-bits) temp))
             (v_n-1
              (##bignum.mdigit-ref top-2*mdigit-width-bits-of-v 1))
             (v_n-2
              (##bignum.mdigit-ref top-2*mdigit-width-bits-of-v 0)))

        ;; Knuth says to simplify things by shifting u and v so that
        ;; the top nonzero mdigit of v is >= mdigit-base/2

        ;; We're not going to do the shift, but we're going to use that idea.

        ;; This strategy does a bit more work, but generates less garbage.

        (let* ((q-bits                             ;; maximum number of possible bits in q
                (##fx+ (##fx- u-bits v-bits) 2))   ;; 1 is not always sufficient...
               (q-adigits
                (##fxceiling-ratio q-bits ##bignum.adigit-width))
               (q-mdigits
                (##fxceiling-ratio q-bits ##bignum.mdigit-width))
               (q
                (and need-quotient?
                     (##fx> q-mdigits 1) ;; result might be bignum
                     (##bignum.make q-adigits #f #f)))
               (u
                (if keep-dividend?
                    ;; copy u
                    (##bignum.copy u)
                    ;; overwrite u with remainder
                    u)))
          (if (##fx= q-mdigits 1)
              ;; final result can't be bignum
              (let* ((top-bits-of-u
                      (##bignum.arithmetic-shift-into! u (##fx- (##fx* 2 ##bignum.mdigit-width) v-bits) temp))
                     (q-hat-estimate
                      (estimate-q-hat top-bits-of-u v_n-1 v_n-2))
                     (q-hat
                      (subtract-multiple-of-v u v q-hat-estimate n 0)))
                (##cons (and need-quotient? q-hat)
                        (##bignum.normalize! u)))
              ;; final result may be bignum
              (let loop3 ((j (##fx- q-mdigits 1)))
                (if (##not (##fx< j 0))
                    (let* ((top-bits-of-u
                            (##bignum.arithmetic-shift-into! u (##fx- (##fx* (##fx- 2 j) ##bignum.mdigit-width) v-bits) temp))
                           (q-hat-estimate
                            (estimate-q-hat top-bits-of-u v_n-1 v_n-2))
                           (q-hat
                            (subtract-multiple-of-v u v q-hat-estimate n j)))
                      (and need-quotient? (##bignum.mdigit-set! q j q-hat))
                      (loop3 (##fx- j 1)))
                    (##cons (and need-quotient? (##bignum.normalize! q))
                            (##bignum.normalize! u)))))))))

  (define (div-one u v)
    (let ((m
           (let loop6 ((i (##fx- (##bignum.mdigit-length u) 1)))
             (if (##fx< 0 (##bignum.mdigit-ref u i))
                 (##fx+ i 1)
                 (loop6 (##fx- i 1))))))
      (let ((work-u (##bignum.make
                     (##fxceiling-ratio (##fx* 2 ##bignum.mdigit-width)
                                        ##bignum.adigit-width)
                     #f
                     #f))
            (q (and need-quotient?
                    (##bignum.make (##bignum.adigit-length u) #f #f))))

        (##declare (not interrupts-enabled))

        (let loop7 ((i m)
                    (r-hat 0))
          (##bignum.mdigit-set!
           work-u
           1
           r-hat)
          (##bignum.mdigit-set!
           work-u
           0
           (##bignum.mdigit-ref u (##fx- i 1)))
          (let ((q-hat (##bignum.mdigit-quotient work-u 1 v)))
            (let ((r-hat (##bignum.mdigit-remainder work-u 1 v q-hat)))
              (and need-quotient? (##bignum.mdigit-set! q (##fx- i 1) q-hat))
              (if (##fx< 1 i)
                  (loop7 (##fx- i 1)
                         r-hat)
                  (let ()
                    (##declare (interrupts-enabled))
                    (##cons (and need-quotient? (##bignum.normalize! q))
                            r-hat)))))))))

  (define (big-divide u v)

    ;; u and v are positive bignums

    (let ((v-length (##integer-length v))
          (v-first-bit-set (##first-bit-set v)))
      ;; first we check whether it may be beneficial to shift out
      ;; low-order zero bits of v
      (if (##fx>= v-first-bit-set
                  (##fxarithmetic-shift-right v-length 1))
          (let ((reduced-quotient
                 (##exact-int.div
                  (##bignum.arithmetic-shift u (##fx- v-first-bit-set))
                  (##bignum.arithmetic-shift v (##fx- v-first-bit-set))
                  #t          ;; need-quotient?
                  #f          ;; keep-dividend?
                  ))
                (extra-remainder
                 (##extract-bit-field v-first-bit-set 0 u)))
            (##cons (##car reduced-quotient)
                    (##+ (##arithmetic-shift (##cdr reduced-quotient)
                                             v-first-bit-set)
                         extra-remainder)))
          (if (##fx< v-length ##bignum.fft-mul-min-width)
              (naive-div u v)
              (let* ((u-length (##integer-length u))
                     (length-difference (##fx- u-length v-length)))
                (if (##fx< length-difference ##bignum.fft-mul-min-width)
                    (naive-div u v)
                    (let* ((z-bits (##exact-int.reciprocal v length-difference))
                           (z (##car z-bits))
                           (bits (##cdr z-bits)))
                      (let ((test-quotient
                             (##bignum.arithmetic-shift
                              (##* (##bignum.arithmetic-shift
                                    u
                                    (##fx- length-difference
                                           (##fx- u-length 2)))
                                   (##bignum.arithmetic-shift
                                    z
                                    (##fx- length-difference bits)))
                              (##fx- -3 length-difference))))
                        (let ((rem (##- u (##* test-quotient v))))
                          ;; I believe, and I haven't found any counterexamples in my tests
                          ;; to disprove it, that test-quotient can be off by at most +-1.
                          ;; I can't prove this, however, so we put in the following loops.

                          ;; Especially note that our reciprocal does not satisfy the
                          ;; error bounds in Knuth's volume 2 in perhaps a vain effort to
                          ;; save some computations. perhaps this should be fixed.  blah.

                          (cond ((##negative? rem)
                                 (let loop ((test-quotient test-quotient)
                                            (rem rem))
                                   (let ((test-quotient (##- test-quotient 1))
                                         (rem (##+ rem v)))
                                     (if (##negative? rem)
                                         (loop test-quotient rem)
                                         (##cons test-quotient rem)))))
                                ((##< rem v)
                                 (##cons test-quotient
                                         rem))
                                (else
                                 (let loop ((test-quotient test-quotient)
                                            (rem rem))
                                   (let ((test-quotient (##+ test-quotient 1))
                                         (rem (##- rem v)))
                                     (if (##< rem v)
                                         (##cons test-quotient rem)
                                         (loop test-quotient rem)))))))))))))))

  (if (##fixnum? v)
      (if (##fx< v ##bignum.mdigit-base)
          (div-one u v)
          (begin
            ;; here it's probably not worth the extra cycles to check whether
            ;; a subtraction would be sufficient, i.e., we don't call
            ;; short-divisor-or-quotient-divide
            (naive-div u (##fixnum->bignum v))))
      (if (use-fast-bignum-algorithms)
          (big-divide u v)
          (naive-div u v))))

;;;----------------------------------------------------------------------------

;;; Exact integer operations
;;; ------------------------

(define (##exact-int.= x y)
  (##fx= 0 (##exact-int.compare x y)))

(define (##exact-int.< x y)
  (##fx= -1 (##exact-int.compare x y)))

(define (##exact-int.compare x y)

  ;; returns -1 if x < y, 0 if x = y, or 1 if x > y

  (define (compare x y x-smaller)
    (##declare (not interrupts-enabled))
    (let ((x-digits (##bignum.adigit-length x))
          (y-digits (##bignum.adigit-length y)))
      (cond ((##fx< x-digits y-digits) x-smaller)
            ((##fx< y-digits x-digits) (##fx- x-smaller))
            (else
             (let loop ((i (##fx- x-digits 1)))
               (cond ((##fx< i 0) 0)
                     ((##bignum.adigit-< x y i) -1)
                     ((##bignum.adigit-< y x i) 1)
                     (else
                      (loop (##fx- i 1)))))))))
  (if (##fixnum? x)
      (if (##fixnum? y)
          (cond ((##fx< x y) -1)
                ((##fx= x y)  0)
                (else         1))
          (if (##bignum.negative? y) 1 -1))
      (if (##fixnum? y)
          (if (##bignum.negative? x) -1 1)
          (if (##bignum.negative? x)
              (if (##bignum.negative? y) (compare x y 1) -1)
              (if (##bignum.negative? y) 1 (compare x y -1))))))

(define-prim (##exact-int.*-expt2 x y)
  (if (##fxnegative? y)
      (##ratnum.normalize x (##arithmetic-shift 1 (##fx- y)))
      (##arithmetic-shift x y)))

(define-prim (##exact-int.div x y #!optional (need-quotient? #t) (keep-dividend? #t))

  (define (big-quotient x y)
    (let* ((x-negative? (##negative? x))
           (abs-x (if x-negative?
                      (##negate x)
                      x))
           (y-negative? (##negative? y))
           (abs-y (if y-negative?
                      (begin
                        (set! keep-dividend? #f)
                        (##negate y))
                      y)))
      (if (##< abs-x abs-y)
          (##cons 0 x)

          ;; at least one of x and y is a bignum, so
          ;; here abs-x must be a bignum

          (let ((result (##bignum.div abs-x abs-y need-quotient? keep-dividend?)))

            (if (and need-quotient?
                     (##not (##eq? x-negative? y-negative?)))
                (##set-car! result (##negate (##car result))))

            (if x-negative?
                (##set-cdr! result (##negate (##cdr result))))

            result))))

  (cond ((##eqv? y 1)
         (##cons x 0))
        ((##eqv? y -1)
         (##cons (##negate x) 0))
        ((##eq? x y)              ;; can come up in rational arithmetic
         (##cons 1 0))
        ((##fixnum? x)
         (if (##fixnum? y)
             (##cons (##fxquotient x y) ;; note: y can't be -1
                     (##fxremainder x y))
             ;; y is a bignum, x is a fixnum
             (if (##fx< 1 (##bignum.adigit-length y))
                 ;; y has at least two adigits, so
                 ;; (abs y) > (abs x)
                 (##cons 0 x)
                 (big-quotient x y))))
        ((and (##bignum? y)
              (##fx< 1 (##fx- (##bignum.adigit-length y)
                              (##bignum.adigit-length x))))
         ;; x and y are bignums, and y has at least two more adigits
         ;; than x, so (abs y) > (abs x)
         (##cons 0 x))
        (else
         (big-quotient x y))))

(define-prim (##exact-int.nth-root x y)
  (cond ((##eqv? x 0)
         0)
        ((##eqv? x 1)
         1)
        ((##eqv? y 1)
         x)
        ((##eqv? y 2)
         (##car (##exact-int.sqrt x)))
        ((##not (##fixnum? y))
         1)
        (else
         (let ((length (##integer-length x)))
           ;; (expt 2 (- length l 1)) <= x < (expt 2 length)
           (cond ((##fx<= length y)
                  1)
                 ;; result is >= 2
                 ((##fx<= length (##fx* 2 y))
                  ;; result is < 4
                  (if (##< x (##expt 3 y))
                      2
                      3))
                 ((##fxeven? y)
                  (##exact-int.nth-root
                   (##car (##exact-int.sqrt x))
                   (##fxarithmetic-shift-right y 1)))
                 (else
                  (let* ((length/y/2 ;; length/y/2 >= 1 because (< (* 2 y) length)
                          (##fxarithmetic-shift-right
                           (##fxquotient
                            (##fx- length 1)
                            y)
                           1)))
                    (let ((init-g
                           (let* ((top-bits
                                   (##arithmetic-shift
                                    x
                                    (##fx- (##fx* length/y/2 y))))
                                  (nth-root-top-bits
                                   (##exact-int.nth-root top-bits y)))
                             (##arithmetic-shift
                              (##+ nth-root-top-bits 1)
                              length/y/2))))
                      (let loop ((g init-g))
                        (let* ((a (##expt g (##fx- y 1)))
                               (b (##* a y))
                               (c (##* a (##fx- y 1)))
                               (d (##quotient (##+ x (##* g c)) b)))
                          (let ((diff (##- d g)))
                            (cond ((##not (##negative? diff))
                                   g)
                                  ((##< diff -1)
                                   (loop d))
                                  (else
                                   ;; once the difference is one, it's more
                                   ;; efficient to just decrement until g^y <= x
                                   (let loop ((g d))
                                     (if (##not (##< x (##expt g y)))
                                         g
                                         (loop (##- g 1)))))))))))))))))

(define-prim (##integer-nth-root x y)

  (define (type-error-on-x)
    (##fail-check-exact-integer 1 integer-nth-root x y))

  (define (type-error-on-y)
    (##fail-check-exact-integer 2 integer-nth-root x y))

  (define (range-error-on-x)
    (##raise-range-exception 1 integer-nth-root x y))

  (define (range-error-on-y)
    (##raise-range-exception 2 integer-nth-root x y))

  (if (macro-exact-int? x)
      (if (macro-exact-int? y)
          (cond ((##negative? x)
                 (range-error-on-x))
                ((##positive? y)
                 (##exact-int.nth-root x y))
                (else
                 (range-error-on-y)))
          (type-error-on-y))
      (type-error-on-x)))

(define-prim (integer-nth-root x y)
  (macro-force-vars (x y)
    (##integer-nth-root x y)))

(define-prim (##exact-int.sqrt x)

  ;; Derived from the paper "Karatsuba Square Root" by Paul Zimmermann,
  ;; INRIA technical report RR-3805, 1999.  (Used in gmp 4.*)

  ;; Note that the statement of the theorem requires that
  ;; b/4 <= high-order digit of x < b which can be impossible when b is a
  ;; power of 2; the paper later notes that it is the lower bound that is
  ;; necessary, which we preserve.

  (if (##fixnum? x)
      ;; Here we assume that we have at least as much precision as
      ;; IEEE double precision, that we round to nearest, and that
      ;; fixnums have no more than 64 bits.
      
      ;; Here's why this works.
      
      ;; The three functions ##fixnum->flonum, ##flsqrt, and
      ;; ##flonum->fixnum are all monotone, in that if the
      ;; argument is increased, the result does not decrease.
      ;; So for each fixnum i such that (* i i) and (+ (* i i) (* 2 i))
      ;; are fixnums, check that
      
      ;; (##exact-int.sqrt (* i i)) => i and
      ;; (##exact-int.sqrt (+ (* i i) (* 2 i))) => i
      
      ;; and this will be true of all fixnums in between.
      ;; And that is all fixnums.  So we ran a code to check this.
      
      (let* ((s (##flonum->fixnum (##flsqrt (##fixnum->flonum x))))
             (r (##fx- x (##fx* s s))))
        ;; s can be too big, so we check for that here.
        (if (##fxnegative? r)
            (##cons (##fx- s 1)
                    (##fx+ r (##fx* s 2) -1))
            (##cons s r)))
      (let ((length/4
             (##fxarithmetic-shift-right
              (##fx+ (##integer-length x) 1)
              2)))
        (let* ((s-prime&r-prime
                (##exact-int.sqrt
                 (##arithmetic-shift
                  x
                  (##fx- (##fxarithmetic-shift-left length/4 1)))))
               (s-prime
                (##car s-prime&r-prime))
               (r-prime
                (##cdr s-prime&r-prime)))
          (let* ((qu
                  (##exact-int.div
                   (##+ (##arithmetic-shift r-prime length/4)
                        (##extract-bit-field length/4 length/4 x))
                   (##arithmetic-shift s-prime 1)
                   #t           ;; need-quotient?
                   #f))         ;; keep-dividend?
                 (q
                  (##car qu))
                 (u
                  (##cdr qu)))
            (let ((s
                   (##+ (##arithmetic-shift s-prime length/4) q))
                  (r
                   (##- (##+ (##arithmetic-shift u length/4)
                             (##extract-bit-field length/4 0 x))
                        (##* q q))))
              (if (##negative? r)
                  (##cons (##- s 1)
                          (##+ r
                               (##- (##arithmetic-shift s 1) 1)))
                  (##cons s
                          r))))))))

(define-prim (##integer-sqrt x)

  (define (type-error)
    (##fail-check-exact-integer 1 integer-sqrt x))

  (define (range-error)
    (##raise-range-exception 1 integer-sqrt x))

  (if (macro-exact-int? x)
      (if (##negative? x)
          (range-error)
          (##car (##exact-int.sqrt x)))
      (type-error)))

(define-prim (integer-sqrt x)
  (macro-force-vars (x)
    (##integer-sqrt x)))

(define-prim (##exact-int.square n)
  (##* n n))

;;;----------------------------------------------------------------------------

;;; Ratnum operations
;;; -----------------

(define-prim (##ratnum-make num den)
  (macro-ratnum-make num den))

(define-prim (##ratnum-numerator x)
  (macro-ratnum-numerator x))

(define-prim (##ratnum-denominator x)
  (macro-ratnum-denominator x))

(define-prim (##ratnum.= x y)
  (##declare (mostly-fixnum)
	     (not safe)
	     (standard-bindings))
  (and (= (macro-ratnum-numerator x)
	  (macro-ratnum-numerator y))
       (= (macro-ratnum-denominator x)
	  (macro-ratnum-denominator y))))

(define-prim (##ratnum.< x y)
  (##declare (mostly-fixnum)
	     (not safe)
	     (standard-bindings))
  (< (* (macro-ratnum-numerator x)
	(macro-ratnum-denominator y))
     (* (macro-ratnum-denominator x)
	(macro-ratnum-numerator y))))

(define-prim (##ratnum.+ x y)
  (##declare (mostly-fixnum)
	     (not safe)
	     (standard-bindings))
  (let ((p (macro-ratnum-numerator x))
        (q (macro-ratnum-denominator x))
        (r (macro-ratnum-numerator y))
        (s (macro-ratnum-denominator y)))
    (let ((d1 (##gcd q s)))
      (if (eqv? d1 1)
          (macro-ratnum-make (+ (* p s)
				(* r q))
                             (* q s))
          (let* ((s-prime (quotient s d1))
                 (t (+ (* p s-prime)
		       (* r (quotient q d1))))
                 (d2 (##gcd d1 t))
                 (num (quotient t d2))
                 (den (* (quotient q d2)
			 s-prime)))
            (if (eqv? den 1)
                num
                (macro-ratnum-make num den)))))))

(define-prim (##ratnum.- x y)
  (##declare (mostly-fixnum)
	     (not safe)
	     (standard-bindings))
  (let ((p (macro-ratnum-numerator x))
        (q (macro-ratnum-denominator x))
        (r (macro-ratnum-numerator y))
        (s (macro-ratnum-denominator y)))
    (let ((d1 (##gcd q s)))
      (if (eqv? d1 1)
          (macro-ratnum-make (- (* p s)
				(* r q))
                             (* q s))
          (let* ((s-prime (quotient s d1))
                 (t (- (* p s-prime)
		       (* r (quotient q d1))))
                 (d2 (##gcd d1 t))
                 (num (quotient t d2))
                 (den (* (quotient q d2)
			 s-prime)))
            (if (eqv? den 1)
                num
                (macro-ratnum-make num den)))))))

(define-prim (##ratnum.* x y)
  (##declare (mostly-fixnum)
	     (not safe)
	     (standard-bindings))
  (let ((p (macro-ratnum-numerator x))
        (q (macro-ratnum-denominator x))
        (r (macro-ratnum-numerator y))
        (s (macro-ratnum-denominator y)))
    (if (eq? x y)
        (macro-ratnum-make (square p) (square q))     ;; already in lowest form
        (let* ((gcd-ps (##gcd p s))
               (gcd-rq (##gcd r q))
               (num (* (quotient p gcd-ps) (quotient r gcd-rq)))
               (den (* (quotient q gcd-rq) (quotient s gcd-ps))))
          (if (eqv? den 1)
              num
              (macro-ratnum-make num den))))))

(define-prim (##ratnum./ x y)
  (##declare (mostly-fixnum)
	     (not safe)
	     (standard-bindings))
  (let ((p (macro-ratnum-numerator x))
        (q (macro-ratnum-denominator x))
        (r (macro-ratnum-denominator y))
        (s (macro-ratnum-numerator y)))
    (if (eq? x y)
        1
        (let* ((gcd-ps (##gcd p s))
               (gcd-rq (##gcd r q))
               (num (* (quotient p gcd-ps) (quotient r gcd-rq)))
               (den (* (quotient q gcd-rq) (quotient s gcd-ps))))
          (if (negative? den)
              (if (eqv? den -1)
                  (- num)
                  (macro-ratnum-make (- num) (- den)))
              (if (eqv? den 1)
                  num
                  (macro-ratnum-make num den)))))))

(define-prim (##ratnum.normalize num den)
  (##declare (mostly-fixnum)
	     (not safe)
	     (standard-bindings))
  (let* ((x (##gcd num den))
         (y (if (negative? den) (- x) x))
         (num (quotient num y))
         (den (quotient den y)))
    (if (eqv? den 1)
        num
        (macro-ratnum-make num den))))

(define-prim (##exact-int->ratnum x)
  (macro-ratnum-make x 1))

(define-prim (##ratnum.round x #!optional (round-half-away-from-zero? #f))
  (let ((num (macro-ratnum-numerator x))
        (den (macro-ratnum-denominator x)))
    (if (##eqv? den 2)
        (if round-half-away-from-zero?
            (##arithmetic-shift (##+ num (if (##positive? num) 1 -1)) -1)
            (##arithmetic-shift (##arithmetic-shift (##+ num 1) -2) 1))
        ;; here the ratnum cannot have fractional part = 1/2
        (##floor
         (##ratnum.normalize
          (##+ (##arithmetic-shift num 1) den)
          (##arithmetic-shift den 1))))))

;;;----------------------------------------------------------------------------

;;; Flonum operations
;;; -----------------

(##define-macro (define-prim-flonum form . special-body)
  (let ((body (if (null? special-body) form `(begin ,@special-body))))
    (cond ((= 1 (length (cdr form)))
           (let* ((name-fn (car form))
                  (name-param1 (cadr form)))
             `(define-prim ,form
                (macro-force-vars (,name-param1)
                  (macro-check-flonum
                    ,name-param1
                    1
                    ,form
                    ,body)))))
          ((= 2 (length (cdr form)))
           (let* ((name-fn (car form))
                  (name-param1 (cadr form))
                  (name-param2 (caddr form)))
             `(define-prim ,form
                (macro-force-vars (,name-param1 ,name-param2)
                  (macro-check-flonum
                    ,name-param1
                    1
                    ,form
                    (macro-check-flonum
                      ,name-param2
                      2
                      ,form
                      ,body))))))
          (else
           (error "define-prim-flonum supports only 1 or 2 parameter procedures")))))

(define-prim (flonum? obj)
  (macro-force-vars (obj)
    (##flonum? obj)))

(define-prim (##fleqv? x y))

(define-prim-nary-bool (##fl= x y)
  #t
  #t
  (##fl= x y)
  macro-no-force
  macro-no-check)

(define-prim-nary-bool (fl= x y)
  #t
  #t
  (##fl= x y)
  macro-force-vars
  macro-check-flonum)

(define-prim-nary-bool (##fl< x y)
  #t
  #t
  (##fl< x y)
  macro-no-force
  macro-no-check)

(define-prim-nary-bool (fl< x y)
  #t
  #t
  (##fl< x y)
  macro-force-vars
  macro-check-flonum)

(define-prim-nary-bool (##fl> x y)
  #t
  #t
  (##fl> x y)
  macro-no-force
  macro-no-check)

(define-prim-nary-bool (fl> x y)
  #t
  #t
  (##fl> x y)
  macro-force-vars
  macro-check-flonum)

(define-prim-nary-bool (##fl<= x y)
  #t
  #t
  (##fl<= x y)
  macro-no-force
  macro-no-check)

(define-prim-nary-bool (fl<= x y)
  #t
  #t
  (##fl<= x y)
  macro-force-vars
  macro-check-flonum)

(define-prim-nary-bool (##fl>= x y)
  #t
  #t
  (##fl>= x y)
  macro-no-force
  macro-no-check)

(define-prim-nary-bool (fl>= x y)
  #t
  #t
  (##fl>= x y)
  macro-force-vars
  macro-check-flonum)

(define-prim (##flinteger? x))

(define-prim-flonum (flinteger? x)
  (##flinteger? x))

(define-prim (##flzero? x))

(define-prim-flonum (flzero? x)
  (##flzero? x))

(define-prim (##flpositive? x))

(define-prim-flonum (flpositive? x)
  (##flpositive? x))

(define-prim (##flnegative? x))

(define-prim-flonum (flnegative? x)
  (##flnegative? x))

(define-prim (##flodd? x))

(define-prim-flonum (flodd? x)
  (##flodd? x))

(define-prim (##fleven? x))

(define-prim-flonum (fleven? x)
  (##fleven? x))

(define-prim (##flfinite? x))

(define-prim-flonum (flfinite? x)
  (##flfinite? x))

(define-prim (##flinfinite? x))

(define-prim-flonum (flinfinite? x)
  (##flinfinite? x))

(define-prim (##flnan? x))

(define-prim-flonum (flnan? x)
  (##flnan? x))

(define-prim-nary (##flmax x y)
  ()
  x
  (##flmax x y)
  macro-no-force
  macro-no-check)

(define-prim-nary (flmax x y)
  ()
  x
  (##flmax x y)
  macro-force-vars
  macro-check-flonum)

(define-prim-nary (##flmin x y)
  ()
  x
  (##flmin x y)
  macro-no-force
  macro-no-check)

(define-prim-nary (flmin x y)
  ()
  x
  (##flmin x y)
  macro-force-vars
  macro-check-flonum)

(define-prim-nary (##fl+ x y)
  (macro-inexact-+0)
  x
  (##fl+ x y)
  macro-no-force
  macro-no-check)

(define-prim-nary (fl+ x y)
  (macro-inexact-+0)
  x
  (##fl+ x y)
  macro-force-vars
  macro-check-flonum)

(define-prim-nary (##fl* x y)
  (macro-inexact-+1)
  x
  (##fl* x y)
  macro-no-force
  macro-no-check)

(define-prim-nary (fl* x y)
  (macro-inexact-+1)
  x
  (##fl* x y)
  macro-force-vars
  macro-check-flonum)

(define-prim-nary (##fl- x y)
  ()
  (##fl- x)
  (##fl- x y)
  macro-no-force
  macro-no-check)

(define-prim-nary (fl- x y)
  ()
  (##fl- x)
  (##fl- x y)
  macro-force-vars
  macro-check-flonum)

(define-prim-nary (##fl/ x y)
  ()
  (##fl/ x)
  (##fl/ x y)
  macro-no-force
  macro-no-check)

(define-prim-nary (fl/ x y)
  ()
  (##fl/ x)
  (##fl/ x y)
  macro-force-vars
  macro-check-flonum)

(define-prim (##flabs x))

(define-prim-flonum (flabs x)
  (##flabs x))

(define-prim-flonum (flnumerator x)
  (cond ((##flzero? x)
         x)
        ((macro-flonum-rational? x)
         (##exact->inexact (##numerator (##flonum->exact x))))
        (else
         (##fail-check-rational 1 flnumerator x))))

(define-prim-flonum (fldenominator x)
  (if (macro-flonum-rational? x)
      (##exact->inexact (##denominator (##flonum->exact x)))
      (##fail-check-rational 1 fldenominator x)))

(define-prim (##flfloor x))

(define-prim-flonum (flfloor x)
  (##flfloor x))

(define-prim (##flceiling x))

(define-prim-flonum (flceiling x)
  (##flceiling x))

(define-prim (##fltruncate x))

(define-prim-flonum (fltruncate x)
  (##fltruncate x))

(define-prim (##flround x))

(define-prim-flonum (flround x)
  (##flround x))

(define-prim (##flscalbn x n))

(define-prim (flscalbn x n)
  (macro-force-vars (x n)
    (macro-check-flonum x 1 (flscalbn x n)
      (macro-check-fixnum n 2 (flscalbn x n)
        (##flscalbn x n)))))

(define-prim (##flilogb x))

(define-prim-flonum (flilogb x)
  (##flilogb x))

(define-prim (##flexp x))

(define-prim-flonum (flexp x)
  (##flexp x))

(define-prim (##flexpm1 x))

(define-prim-flonum (flexpm1 x)
  (##flexpm1 x))

(define-prim (##fllog x))

(define-prim-flonum (fllog x)
  (##fllog x))

(define-prim (##fllog1p x))

(define-prim-flonum (fllog1p x)
  (##fllog1p x))

(define-prim (##flsin x))

(define-prim-flonum (flsin x)
  (##flsin x))

(define-prim (##flcos x))

(define-prim-flonum (flcos x)
  (##flcos x))

(define-prim (##fltan x))

(define-prim-flonum (fltan x)
  (##fltan x))

(define-prim (##flasin x))

(define-prim-flonum (flasin x)
  (##flasin x))

(define-prim (##flacos x))

(define-prim-flonum (flacos x)
  (##flacos x))

(define-prim (##flatan x #!optional (y (macro-absent-obj)))
  (if (##eq? y (macro-absent-obj))
      (##flatan x)
      (##flatan x y)))

(define-prim (flatan x #!optional (y (macro-absent-obj)))
  (macro-force-vars (x y)
    (macro-check-flonum x 1 (flatan x y)
      (if (##eq? y (macro-absent-obj))
          (##flatan x)
          (macro-check-flonum y 2 (flatan x y)
            (##flatan x y))))))

(define-prim (##flsinh x))

(define-prim-flonum (flsinh x)
  (##flsinh x))

(define-prim (##flcosh x))

(define-prim-flonum (flcosh x)
  (##flcosh x))

(define-prim (##fltanh x))

(define-prim-flonum (fltanh x)
  (##fltanh x))

(define-prim (##flasinh x))

(define-prim-flonum (flasinh x)
  (##flasinh x))

(define-prim (##flacosh x))

(define-prim-flonum (flacosh x)
  (##flacosh x))

(define-prim (##flatanh x))

(define-prim-flonum (flatanh x)
  (##flatanh x))

(define-prim (##flexpt x y))

(define-prim-flonum (flexpt x y)
  (##flexpt x y))

(define-prim (##flsqrt x))

(define-prim-flonum (flsqrt x)
  (##flsqrt x))

(define-prim (##flsquare x))

(define-prim-flonum (flsquare x)
  (##flsquare x))

(define-prim-fixnum (fixnum->flonum x)
  (##fixnum->flonum x))

(define-prim (##flcopysign x y))

(define-prim (##flonum->fixnum x))
(define-prim (##fixnum->flonum x))
(define-prim (##fixnum->flonum-exact? x))

(define-prim (##ratnum->flonum x #!optional (nonzero-fractional-part? #f))
  (let* ((num (macro-ratnum-numerator x))
         (n (##abs num))
         (d (macro-ratnum-denominator x))
         (wn (##integer-length n)) ;; 2^(wn-1) <= n < 2^wn
         (wd (##integer-length d)) ;; 2^(wd-1) <= d < 2^wd
         (p (##fx- wn wd)))

    (define (f1 sn sd)
      (if (##< sn sd) ;; n/(d*2^p) < 1 ?
          (f2 (##arithmetic-shift sn 1) sd (##fx- p 1))
          (f2 sn sd p)))

    (define (f2 a b p)
      ;; 1 <= a/b < 2  and  n/d = (2^p*a)/b  and  n/d < 2^(p+1)
      (let* ((shift
              (##fxmin (macro-flonum-m-bits)
                       (##fx- p (macro-flonum-e-min))))
             (normalized-result
              (##ratnum.normalize
               (##arithmetic-shift a shift)
               b))
             (abs-result
              (##fl*
               (##exact-int->flonum
                (if (##ratnum? normalized-result)
                    (##ratnum.round
                     normalized-result
                     nonzero-fractional-part?)
                    normalized-result))
               (##flonum-expt2 (##fx- p shift)))))
        (if (##negative? num)
            (##flcopysign abs-result (macro-inexact--1))
            abs-result)))

    ;; 2^(p-1) <= n/d < 2^(p+1)
    ;; 1/2 <= n/(d*2^p) < 2  or equivalently  1/2 <= (n*2^-p)/d < 2

    (if (##fxnegative? p)
        (f1 (##arithmetic-shift n (##fx- p)) d)
        (f1 n (##arithmetic-shift d p)))))

(define-prim (##exact-int->flonum x #!optional (nonzero-fractional-part? #f))

  (define (f1 x)
    (let* ((w ;; 2^(w-1) <= x < 2^w
            (##integer-length x))
           (p ;; 2^52 <= x/2^p < 2^53
            (##fx- w (macro-flonum-m-bits-plus-1))))
      (if (##fx< p 1)
          ;; it really should be an error here if
          ;; positive-fractional-part? is true because we can't
          ;; determine the value of the first discarded bit
          (f2 x)
          (let* ((q (##arithmetic-shift x (##fx- p)))
                 (next-bit-index (##fx- p 1)))
            (##fl*
             (##flonum-expt2 p)
             (f2 (if (and (##bit-set? next-bit-index x)
                          (or nonzero-fractional-part?
                              (##odd? q)
                              (##fx< (##first-bit-set x)
                                     next-bit-index)))
                     (##+ q 1)
                     q)))))))

  (define (f2 x) ;; 0 <= x < 2^53
    (if (##fixnum? x)
        (##fixnum->flonum x)
        (let* ((x (if (##fixnum? x) (##fixnum->bignum x) x))
               (n (##bignum.mdigit-length x)))
          (let loop ((i (##fx- n 1))
                     (result (macro-inexact-+0)))
            (if (##fx< i 0)
                result
                (let ((mdigit (##bignum.mdigit-ref x i)))
                  (loop (##fx- i 1)
                        (##fl+ (##fl* result
                                      ##bignum.inexact-mdigit-base)
                               (##fixnum->flonum mdigit)))))))))

  (if (##fixnum? x)
      (##fixnum->flonum x)
      (if (##negative? x)
          (##flcopysign (f1 (##negate x)) (macro-inexact--1))
          (f1 x))))

(define-prim (##flonum-expt2 n)
  (cond ((##fxzero? n)
         (macro-inexact-+1))
        ((##fxnegative? n)
         (##expt (macro-inexact-+1/2) (##fx- n)))
        (else
         (##expt (macro-inexact-+2) n))))

(define-prim (##flonum->exact-int x)
  (let loop1 ((z (##flabs x))
              (n 1))
    (if (##fl< ##bignum.inexact-mdigit-base z)
        (loop1 (##fl/ z ##bignum.inexact-mdigit-base)
               (##fx+ n 1))
        (let loop2 ((result 0)
                    (z z)
                    (i n))
          (if (##fx< 0 i)
              (let* ((inexact-floor-z
                      (##flfloor z))
                     (floor-z
                      (##flonum->fixnum inexact-floor-z))
                     (new-z
                      (##fl* (##fl- z inexact-floor-z)
                             ##bignum.inexact-mdigit-base)))
                (loop2 (##+ floor-z
                            (##arithmetic-shift result ##bignum.mdigit-width))
                       new-z
                       (##fx- i 1)))
              (if (##flnegative? x)
                  (##negate result)
                  result))))))

(define-prim (##flonum->inexact-exponential-format x)

  (define (exp-form-pos x y i)
    (let ((i*2 (##fx+ i i)))
      (let ((z (if (and (##not (##fx< (macro-flonum-e-bias) i*2))
                        (##not (##fl< x y)))
                   (exp-form-pos x (##fl* y y) i*2)
                   (##vector x 0 1))))
        (let ((a (##vector-ref z 0)) (b (##vector-ref z 1)))
          (let ((i+b (##fx+ i b)))
            (if (and (##not (##fx< (macro-flonum-e-bias) i+b))
                     (##not (##fl< a y)))
                (begin
                  (##vector-set! z 0 (##fl/ a y))
                  (##vector-set! z 1 i+b)))
            z)))))

  (define (exp-form-neg x y i)
    (let ((i*2 (##fx+ i i)))
      (let ((z (if (and (##fx< i*2 (macro-flonum-e-bias-minus-1))
                        (##fl< x y))
                   (exp-form-neg x (##fl* y y) i*2)
                   (##vector x 0 1))))
        (let ((a (##vector-ref z 0)) (b (##vector-ref z 1)))
          (let ((i+b (##fx+ i b)))
            (if (and (##fx< i+b (macro-flonum-e-bias-minus-1))
                     (##fl< a y))
                (begin
                  (##vector-set! z 0 (##fl/ a y))
                  (##vector-set! z 1 i+b)))
            z)))))

  (define (exp-form x)
    (if (##fl< x (macro-inexact-+1))
        (let ((z (exp-form-neg x (macro-inexact-+1/2) 1)))
          (##vector-set! z 0 (##fl* (macro-inexact-+2) (##vector-ref z 0)))
          (##vector-set! z 1 (##fx- -1 (##vector-ref z 1)))
          z)
        (exp-form-pos x (macro-inexact-+2) 1)))

  (if (##flnegative? (##flcopysign (macro-inexact-+1) x))
      (let ((z (exp-form (##flcopysign x (macro-inexact-+1)))))
        (##vector-set! z 2 -1)
        z)
      (exp-form x)))

(define-prim (##flonum->exact-exponential-format x)
  (let ((z (##flonum->inexact-exponential-format x)))
    (let ((y (##vector-ref z 0)))
      (if (##not (##fl< y (macro-inexact-+2))) ;; +inf.0 or +nan.0?
          (begin
            (if (##fl< (macro-inexact-+0) y)
                (##vector-set! z 0 (macro-flonum-+m-min))  ;; +inf.0
                (##vector-set! z 0 (macro-flonum-+m-max))) ;; +nan.0
            (##vector-set! z 1 (macro-flonum-e-bias-plus-1)))
          (##vector-set! z 0
                         (##flonum->exact-int
                          (##fl* (##vector-ref z 0) (macro-flonum-m-min)))))
      (##vector-set! z 1 (##fx- (##vector-ref z 1) (macro-flonum-m-bits)))
      z)))

(define-prim (##flonum->exact x)
  (let ((y (##flonum->exact-exponential-format x)))
    (##exact-int.*-expt2
     (if (##fxnegative? (##vector-ref y 2))
         (##negate (##vector-ref y 0))
         (##vector-ref y 0))
     (##vector-ref y 1))))

(define-prim (##flonum->ratnum x)
  (let ((y (##flonum->exact x)))
    (if (macro-exact-int? y)
        (##exact-int->ratnum y)
        y)))

(define-prim (##flonum->ieee754-32 x)
  (##u32vector-ref (##f32vector x) 0))

(define-prim (##ieee754-32->flonum n)
  (let ((x (##u32vector n)))
    (##f32vector-ref x 0)))

(define-prim (##flonum->ieee754-64 x)
  (##u64vector-ref x 0))

(define-prim (##ieee754-64->flonum n)
  (let ((x (##u64vector n)))
    (##subtype-set! x (macro-subtype-flonum))
    x))

;;;----------------------------------------------------------------------------

;;; Cpxnum operations
;;; -----------------

(define-prim (##cpxnum-make real imag)
  (macro-cpxnum-make real imag))

(define-prim (##cpxnum-real x)
  (macro-cpxnum-real x))

(define-prim (##cpxnum-imag x)
  (macro-cpxnum-imag x))

(define-prim (##cpxnum.= x y)
  (and (##= (macro-cpxnum-real x) (macro-cpxnum-real y))
       (##= (macro-cpxnum-imag x) (macro-cpxnum-imag y))))

(define-prim (##cpxnum.+ x y)
  (let ((a (macro-cpxnum-real x)) (b (macro-cpxnum-imag x))
        (c (macro-cpxnum-real y)) (d (macro-cpxnum-imag y)))
    (if (and (##flonum? a) (##flonum? b)
	     (##flonum? c) (##flonum? d))
	(##make-rectangular (##fl+ a c) (##fl+ b d))
	(let ()
	  (declare (standard-bindings)
		   (mostly-fixnum))
	  (##make-rectangular (+ a c) (+ b d))))))

(define-prim (##cpxnum.* x y)
  (let ((a (macro-cpxnum-real x)) (b (macro-cpxnum-imag x))
        (c (macro-cpxnum-real y)) (d (macro-cpxnum-imag y)))
    (if (and (##flonum? a) (##flonum? b)
	     (##flonum? c) (##flonum? d))
	(##make-rectangular (##fl- (##fl* a c) (##fl* b d))
			    (##fl+ (##fl* a d) (##fl* b c)))
	(let ()
	  (declare (standard-bindings)
		   (mostly-fixnum))
	  (##make-rectangular (- (* a c) (* b d))
			      (+ (* a d) (* b c)))))))
(define-prim (##cpxnum.- x y)
  (let ((a (macro-cpxnum-real x)) (b (macro-cpxnum-imag x))
        (c (macro-cpxnum-real y)) (d (macro-cpxnum-imag y)))
    (if (and (##flonum? a) (##flonum? b)
	     (##flonum? c) (##flonum? d))
	(##make-rectangular (##fl- a c) (##fl- b d))
	(let ()
	  (declare (standard-bindings)
		   (mostly-fixnum))
	  (##make-rectangular (- a c) (- b d))))))


(define-prim (##cpxnum./ x y)

  (define (basic/ a b c d q)
    (##make-rectangular (##/ (##+ (##* a c) (##* b d)) q)
                        (##/ (##- (##* b c) (##* a d)) q)))

  (let ((a (macro-cpxnum-real x)) (b (macro-cpxnum-imag x))
        (c (macro-cpxnum-real y)) (d (macro-cpxnum-imag y)))
    (cond ((##eqv? d 0)
           ;; A normalized cpxnum can't have an imaginary part that is
           ;; exact 0 but it is possible that ##cpxnum./ receives a
           ;; nonnormalized cpxnum as x or y when it is called from ##/.
           (##make-rectangular (##/ a c)
                               (##/ b c)))
          ((##eqv? c 0)
           (##make-rectangular (##/ b d)
                               (##negate (##/ a d))))
          ((and (##exact? c) (##exact? d))
           (basic/ a b c d (##+ (##* c c) (##* d d))))
          (else
           ;; just coerce everything to inexact and move on
           (let ((inexact-c (##exact->inexact c))
                 (inexact-d (##exact->inexact d)))
             (if (and (##flfinite? inexact-c)
                      (##flfinite? inexact-d))
                 (let ((q
                        (##fl+ (##fl* inexact-c inexact-c)
                               (##fl* inexact-d inexact-d))))
                   (cond ((##not (##flfinite? q))
                          (let ((a
                                 (if (##flonum? a)
                                     (##fl* a (macro-inexact-scale-down))
                                     (##* a (macro-scale-down))))
                                (b
                                 (if (##flonum? b)
                                     (##fl* b (macro-inexact-scale-down))
                                     (##* b (macro-scale-down))))
                                (inexact-c
                                 (##fl* inexact-c
                                        (macro-inexact-scale-down)))
                                (inexact-d
                                 (##fl* inexact-d
                                        (macro-inexact-scale-down))))
                            (basic/ a
                                    b
                                    inexact-c
                                    inexact-d
                                    (##fl+
                                     (##fl* inexact-c inexact-c)
                                     (##fl* inexact-d inexact-d)))))
                         ((##fl< q (macro-flonum-min-normal))
                          (let ((a
                                 (if (##flonum? a)
                                     (##fl* a (macro-inexact-scale-up))
                                     (##* a (macro-scale-up))))
                                (b
                                 (if (##flonum? b)
                                     (##fl* b (macro-inexact-scale-up))
                                     (##* b (macro-scale-up))))
                                (inexact-c
                                 (##fl* inexact-c
                                        (macro-inexact-scale-up)))
                                (inexact-d
                                 (##fl* inexact-d
                                        (macro-inexact-scale-up))))
                            (basic/ a
                                    b
                                    inexact-c
                                    inexact-d
                                    (##fl+
                                     (##fl* inexact-c inexact-c)
                                     (##fl* inexact-d inexact-d)))))
                         (else
                          (basic/ a b inexact-c inexact-d q))))
                 (cond ((##fl= inexact-c (macro-inexact-+inf))
                        (basic/ a
                                b
                                (macro-inexact-+0)
                                (if (##flnan? inexact-d)
                                    inexact-d
                                    (##flcopysign (macro-inexact-+0)
                                                  inexact-d))
                                (macro-inexact-+1)))
                       ((##fl= inexact-c (macro-inexact--inf))
                        (basic/ a
                                b
                                (macro-inexact--0)
                                (if (##flnan? inexact-d)
                                    inexact-d
                                    (##flcopysign (macro-inexact-+0)
                                                  inexact-d))
                                (macro-inexact-+1)))
                       ((##flnan? inexact-c)
                        (cond ((##fl= inexact-d (macro-inexact-+inf))
                               (basic/ a
                                       b
                                       inexact-c
                                       (macro-inexact-+0)
                                       (macro-inexact-+1)))
                              ((##fl= inexact-d (macro-inexact--inf))
                               (basic/ a
                                       b
                                       inexact-c
                                       (macro-inexact--0)
                                       (macro-inexact-+1)))
                              ((##flnan? inexact-d)
                               (basic/ a
                                       b
                                       inexact-c
                                       inexact-d
                                       (macro-inexact-+1)))
                              (else
                               (basic/ a
                                       b
                                       inexact-c
                                       (macro-inexact-+nan)
                                       (macro-inexact-+1)))))
                       (else
                        ;; finite inexact-c
                        (cond ((##flnan? inexact-d)
                               (basic/ a
                                       b
                                       (macro-inexact-+nan)
                                       inexact-d
                                       (macro-inexact-+1)))
                              (else
                               ;; inexact-d is +inf.0 or -inf.0
                               (basic/ a
                                       b
                                       (##flcopysign (macro-inexact-+0)
                                                     inexact-c)
                                       (##flcopysign (macro-inexact-+0)
                                                     inexact-d)
                                       (macro-inexact-+1))))))))))))

(define-prim (##noncpxnum->cpxnum x)
  (macro-cpxnum-make x 0))

;;;----------------------------------------------------------------------------

;;; Pseudo-random number generation, compatible with srfi-27.

;;; This code is based on Pierre Lecuyer's MRG32K3A generator.

(define-type random-source
  id: 1b002758-f900-4e96-be5e-fa407e331fc0
  implementer: implement-type-random-source
  constructor: macro-make-random-source
  type-exhibitor: macro-type-random-source
  macros:
  prefix: macro-
  opaque:

  (state-ref         unprintable: read-only:)
  (state-set!        unprintable: read-only:)
  (randomize!        unprintable: read-only:)
  (pseudo-randomize! unprintable: read-only:)
  (make-integers     unprintable: read-only:)
  (make-reals        unprintable: read-only:)
  (make-u8vectors    unprintable: read-only:)
  (make-f64vectors   unprintable: read-only:)
  )

(define-check-type random-source
  (macro-type-random-source)
  macro-random-source?)

(implement-type-random-source)
(implement-check-type-random-source)

(define-prim (##make-random-source-mrg32k3a)

  (##define-macro (macro-w)
    65536)

  (##define-macro (macro-w^2-mod-m1)
    209)

  (##define-macro (macro-w^2-mod-m2)
    22853)

  (##define-macro (macro-m1)
    4294967087) ;; (- (expt (macro-w) 2) (macro-w^2-mod-m1))

  (##define-macro (macro-m1-inexact)
    4294967087.0) ;; (exact->inexact (macro-m1))

  (##define-macro (macro-m1-plus-1-inexact)
    4294967088.0) ;; (exact->inexact (+ (macro-m1) 1))

  (##define-macro (macro-inv-m1-plus-1-inexact)
    2.328306549295728e-10) ;; (exact->inexact (/ (+ (macro-m1) 1)))

  (##define-macro (macro-m1-minus-1)
    4294967086) ;; (- (macro-m1) 1)

  (##define-macro (macro-k)
    28)

  (##define-macro (macro-2^k)
    268435456) ;; (expt 2 (macro-k))

  (##define-macro (macro-2^k-inexact)
    268435456.0) ;; (exact->inexact (expt 2 (macro-k)))

  (##define-macro (macro-inv-2^k-inexact)
    3.725290298461914e-9) ;; (exact->inexact (/ (expt 2 (macro-k))))

  (##define-macro (macro-2^53-k-inexact)
    33554432.0) ;; (exact->inexact (expt 2 (- 53 (macro-k))))

  (##define-macro (macro-m1-div-2^k-inexact)
    15.0) ;; (exact->inexact (quotient (macro-m1) (expt 2 (macro-k))))

  (##define-macro (macro-m1-div-2^k-times-2^k-inexact)
    4026531840.0) ;; (exact->inexact (* (quotient (macro-m1) (expt 2 (macro-k))) (expt 2 (macro-k))))

  (##define-macro (macro-m2)
    4294944443) ;; (- (expt (macro-w) 2) (macro-w^2-mod-m2))

  (##define-macro (macro-m2-inexact)
    4294944443.0) ;; (exact->inexact (macro-m2))

  (##define-macro (macro-m2-minus-1)
    4294944442) ;; (- (macro-m2) 1)

  (define (pack-state a b c d e f)
    (f64vector
     (##exact-int->flonum a)
     (##exact-int->flonum b)
     (##exact-int->flonum c)
     (##exact-int->flonum d)
     (##exact-int->flonum e)
     (##exact-int->flonum f)
     (macro-inexact-+0) ;; where the result of advance-state! is put
     (macro-inexact-+0) ;; q in rand-fixnum32
     (macro-inexact-+0) ;; qn in rand-fixnum32
     ))

  (define (unpack-state state)
    (vector
     (##flonum->exact-int (f64vector-ref state 0))
     (##flonum->exact-int (f64vector-ref state 1))
     (##flonum->exact-int (f64vector-ref state 2))
     (##flonum->exact-int (f64vector-ref state 3))
     (##flonum->exact-int (f64vector-ref state 4))
     (##flonum->exact-int (f64vector-ref state 5))))

  (let ((state ;; initial state is 0 3 6 9 12 15 of A^(2^4), see below
         (pack-state
          1062452522
          2961816100
          342112271
          2854655037
          3321940838
          3542344109)))

    (define (state-ref)
      (unpack-state state))

    (define (state-set! rs new-state)

      (define (integer-in-range? x m)
        (and (macro-exact-int? x)
             (not (negative? x))
             (< x m)))

      (or (and (vector? new-state)
               (fx= (vector-length new-state) 6)
               (let ((a (vector-ref new-state 0))
                     (b (vector-ref new-state 1))
                     (c (vector-ref new-state 2))
                     (d (vector-ref new-state 3))
                     (e (vector-ref new-state 4))
                     (f (vector-ref new-state 5)))
                 (and (integer-in-range? a (macro-m1))
                      (integer-in-range? b (macro-m1))
                      (integer-in-range? c (macro-m1))
                      (integer-in-range? d (macro-m2))
                      (integer-in-range? e (macro-m2))
                      (integer-in-range? f (macro-m2))
                      (not (and (eqv? a 0) (eqv? b 0) (eqv? c 0)))
                      (not (and (eqv? d 0) (eqv? e 0) (eqv? f 0)))
                      (begin
                        (set! state
                              (pack-state a b c d e f))
                        (void)))))
          (##raise-type-exception
           2
           'random-source-state
           random-source-state-set!
           (list rs new-state))))

    (define (randomize!)

      (define (random-fixnum-from-time)
        (let ((v (f64vector (macro-inexact-+0))))
          (##get-current-time! v 0)
          (let ((x (f64vector-ref v 0)))
            (##flonum->fixnum
             (fl* 536870912.0 ;; (expt 2.0 29)
                  (fl- x (flfloor x)))))))

      (define seed16
        (random-fixnum-from-time))

      (define (simple-random16)
        (let ((r (bitwise-and seed16 65535)))
          (set! seed16
                (+ (* 30903 r)
                   (arithmetic-shift seed16 -16)))
          r))

      (define (simple-random32)
        (+ (arithmetic-shift (simple-random16) 16)
           (simple-random16)))

      ;; perturb the state randomly

      (let ((s (unpack-state state)))
        (set! state
              (pack-state
               (+ 1
                  (modulo (+ (vector-ref s 0)
                             (simple-random32))
                          (macro-m1-minus-1)))
               (modulo (+ (vector-ref s 1)
                          (simple-random32))
                       (macro-m1))
               (modulo (+ (vector-ref s 2)
                          (simple-random32))
                       (macro-m1))
               (+ 1
                  (modulo (+ (vector-ref s 3)
                             (simple-random32))
                          (macro-m2-minus-1)))
               (modulo (+ (vector-ref s 4)
                          (simple-random32))
                       (macro-m2))
               (modulo (+ (vector-ref s 5)
                          (simple-random32))
                       (macro-m2))))
        (void)))

    (define (pseudo-randomize! i j)

      (define (mult A B) ;; A*B

        (define (lc i0 i1 i2 j0 j1 j2 m)
          (modulo (+ (* (vector-ref A i0)
                        (vector-ref B j0))
                     (+ (* (vector-ref A i1)
                           (vector-ref B j1))
                        (* (vector-ref A i2)
                           (vector-ref B j2))))
                  m))

        (vector
         (lc  0  1  2   0  3  6  (macro-m1))
         (lc  0  1  2   1  4  7  (macro-m1))
         (lc  0  1  2   2  5  8  (macro-m1))
         (lc  3  4  5   0  3  6  (macro-m1))
         (lc  3  4  5   1  4  7  (macro-m1))
         (lc  3  4  5   2  5  8  (macro-m1))
         (lc  6  7  8   0  3  6  (macro-m1))
         (lc  6  7  8   1  4  7  (macro-m1))
         (lc  6  7  8   2  5  8  (macro-m1))
         (lc  9 10 11   9 12 15  (macro-m2))
         (lc  9 10 11  10 13 16  (macro-m2))
         (lc  9 10 11  11 14 17  (macro-m2))
         (lc 12 13 14   9 12 15  (macro-m2))
         (lc 12 13 14  10 13 16  (macro-m2))
         (lc 12 13 14  11 14 17  (macro-m2))
         (lc 15 16 17   9 12 15  (macro-m2))
         (lc 15 16 17  10 13 16  (macro-m2))
         (lc 15 16 17  11 14 17  (macro-m2))))

      (define (power A e) ;; A^e
        (cond ((eq? e 0)
               identity)
              ((eq? e 1)
               A)
              ((even? e)
               (power (mult A A) (arithmetic-shift e -1)))
              (else
               (mult (power A (- e 1)) A))))

      (define identity
        '#(         1           0           0
                                0           1           0
                                0           0           1
                                1           0           0
                                0           1           0
                                0           0           1))

      (define A ;; primary MRG32k3a equations
        '#(         0     1403580  4294156359
                          1           0           0
                          0           1           0
                          527612           0  4293573854
                          1           0           0
                          0           1           0))

      (define A^2^127 ;; A^(2^127)
        '#(1230515664   986791581  1988835001
                        3580155704  1230515664   226153695
                        949770784  3580155704  2427906178
                        2093834863    32183930  2824425944
                        1022607788  1464411153    32183930
                        1610723613   277697599  1464411153))

      (define A^2^76 ;; A^(2^76)
        '#(  69195019  3528743235  3672091415
                       1871391091    69195019  3672831523
                       4127413238  1871391091    82758667
                       3708466080  4292754251  3859662829
                       3889917532  1511326704  4292754251
                       1610795712  3759209742  1511326704))

      (define A^2^4 ;; A^(2^4)
        '#(1062452522   340793741  2955879160
                        2961816100  1062452522   387300998
                        342112271  2961816100   736416029
                        2854655037  1817134745  3493477402
                        3321940838   818368950  1817134745
                        3542344109  3790774567   818368950))

      (let ((M ;; M = A^(2^4 + i*2^127 + j*2^76)
             (mult A^2^4
                   (mult (power A^2^127 i)
                         (power A^2^76 j)))))
        (set! state
              (pack-state
               (vector-ref M 0)
               (vector-ref M 3)
               (vector-ref M 6)
               (vector-ref M 9)
               (vector-ref M 12)
               (vector-ref M 15)))
        (void)))

    (define (advance-state!)
      (##declare (not interrupts-enabled))
      (let* ((state state)
             (x10
              (fl- (fl* 1403580.0 (f64vector-ref state 1))
                   (fl* 810728.0 (f64vector-ref state 2))))
             (y10
              (fl- x10
                   (fl* (flfloor (fl/ x10 (macro-m1-inexact)))
                        (macro-m1-inexact))))
             (x20
              (fl- (fl* 527612.0 (f64vector-ref state 3))
                   (fl* 1370589.0 (f64vector-ref state 5))))
             (y20
              (fl- x20
                   (fl* (flfloor (fl/ x20 (macro-m2-inexact)))
                        (macro-m2-inexact)))))
        (f64vector-set! state 5 (f64vector-ref state 4))
        (f64vector-set! state 4 (f64vector-ref state 3))
        (f64vector-set! state 3 y20)
        (f64vector-set! state 2 (f64vector-ref state 1))
        (f64vector-set! state 1 (f64vector-ref state 0))
        (f64vector-set! state 0 y10)
        (if (fl< y10 y20)
            (f64vector-set! state 6 (fl+ (macro-m1-inexact)
                                         (fl- (f64vector-ref state 0)
                                              (f64vector-ref state 3))))
            (f64vector-set! state 6 (fl- (f64vector-ref state 0)
                                         (f64vector-ref state 3))))))

    (define (make-integers)

      (define (random-integer range)

        (define (type-error)
          (##fail-check-exact-integer 1 random-integer range))

        (define (range-error)
          (##raise-range-exception 1 random-integer range))

        (macro-force-vars (range)
          (cond ((fixnum? range)
                 (if (fxpositive? range)
                     (if (fx< (macro-max-fixnum32) range)
                         (rand-integer range)
                         (rand-fixnum32 range))
                     (range-error)))
                ((##bignum? range)
                 (if (##bignum.negative? range)
                     (range-error)
                     (rand-integer range)))
                (else
                 (type-error)))))

      random-integer)

    (define (rand-integer range)

      ;; constants for computing fixnum approximation of inverse of range

      (define size 14)
      (define 2^2*size 268435456)

      (let ((len (integer-length range)))
        (if (fx= (fx- len 1) ;; check if range is a power of 2
                 (first-bit-set range))
            (rand-integer-2^ (fx- len 1))
            (let* ((inv
                    (fxquotient
                     2^2*size
                     (fx+ 1
                          (extract-bit-field size (fx- len size) range))))
                   (range2
                    (* range inv)))
              (let loop ()
                (let ((r (rand-integer-2^ (fx+ len size))))
                  (if (< r range2)
                      (quotient r inv)
                      (loop))))))))

    (define (rand-integer-2^ w)

      (define (rand w s)
        (cond ((fx< w (macro-k))
               (fxand (rand-fixnum32-2^k)
                      (fx- (fxarithmetic-shift-left 1 w) 1)))
              ((fx= w (macro-k))
               (rand-fixnum32-2^k))
              (else
               (let ((s/2 (fxarithmetic-shift-right s 1)))
                 (if (fx< s w)
                     (+ (rand s s/2)
                        (arithmetic-shift (rand (fx- w s) s/2) s))
                     (rand w s/2))))))

      (define (split w s)
        (let ((s*2 (fx* 2 s)))
          (if (fx< s*2 w)
              (split w s*2)
              s)))

      (rand w (split w (macro-k))))

    (define (rand-fixnum32-2^k)
      (##declare (not interrupts-enabled))
      (let loop ()
        (advance-state!)
        (if (fl< (f64vector-ref state 6)
                 (macro-m1-div-2^k-times-2^k-inexact))
            (##flonum->fixnum
             (fl/ (f64vector-ref state 6)
                  (macro-m1-div-2^k-inexact)))
            (loop))))

    (define (rand-fixnum32 range) ;; range is a fixnum32
      (##declare (not interrupts-enabled))
      (let* ((a (fixnum->flonum range))
             (b (flfloor (fl/ (macro-m1-inexact) a))))
        (f64vector-set! state 7 b)
        (f64vector-set! state 8 (fl* a b)))
      (let loop ()
        (advance-state!)
        (if (fl< (f64vector-ref state 6)
                 (f64vector-ref state 8))
            (##flonum->fixnum
             (fl/ (f64vector-ref state 6)
                  (f64vector-ref state 7)))
            (loop))))

    (define (make-reals precision)
      (if (fl< precision (macro-inv-m1-plus-1-inexact))
          (lambda ()
            (let loop ((r (fixnum->flonum (rand-fixnum32-2^k)))
                       (d (macro-inv-2^k-inexact)))
              (if (fl< r (macro-flonum-+m-max-plus-1-inexact))
                  (loop (fl+ (fl* r (macro-2^k-inexact))
                             (fixnum->flonum (rand-fixnum32-2^k)))
                        (fl* d (macro-inv-2^k-inexact)))
                  (fl* r d))))
          (lambda ()
            (##declare (not interrupts-enabled))
            (advance-state!)
            (fl* (fl+ (macro-inexact-+1) (f64vector-ref state 6))
                 (macro-inv-m1-plus-1-inexact)))))

    (define (make-u8vectors)

      (define (random-u8vector len)
        (macro-force-vars (len)
          (macro-check-index len 1 (random-u8vector len)
            (let ((u8vect (##make-u8vector len 0)))
              (let loop ((i (fx- len 1)))
                (if (fx< i 0)
                    u8vect
                    (begin
                      (##u8vector-set! u8vect i (rand-fixnum32 256))
                      (loop (fx- i 1)))))))))

      random-u8vector)

    (define (make-f64vectors precision)
      (if (fl< precision (macro-inv-m1-plus-1-inexact))
          (let ((make-real (make-reals precision)))
            (lambda (len)
              (macro-force-vars (len)
                (macro-check-index len 1 (random-f64vector len)
                  (let ((f64vect (##make-f64vector len 0.)))
                    (let loop ((i (fx- len 1)))
                      (if (fx< i 0)
                          f64vect
                          (begin
                            (##f64vector-set! f64vect i (make-real))
                            (loop (fx- i 1))))))))))
          (lambda (len)
            (macro-force-vars (len)
              (macro-check-index len 1 (random-f64vector len)
                (let ((f64vect (##make-f64vector len 0.)))
                  (let loop ((i (fx- len 1)))
                    (if (fx< i 0)
                        f64vect
                        (let ()
                          (##declare (not interrupts-enabled))
                          (advance-state!)
                          (##f64vector-set! f64vect i (fl* (fl+ (macro-inexact-+1)
                                                                (f64vector-ref state 6))
                                                           (macro-inv-m1-plus-1-inexact)))
                          (loop (fx- i 1)))))))))))

    (macro-make-random-source
     state-ref
     state-set!
     randomize!
     pseudo-randomize!
     make-integers
     make-reals
     make-u8vectors
     make-f64vectors)))

(define-prim (make-random-source)
  (##make-random-source-mrg32k3a))

(define-prim (random-source? obj)
  (macro-force-vars (obj)
    (macro-random-source? obj)))

(define-prim (##random-source-state-ref rs)
  ((macro-random-source-state-ref rs)))

(define-prim (random-source-state-ref rs)
  (macro-force-vars (rs)
    (macro-check-random-source rs 1 (random-source-state-ref rs)
      (##random-source-state-ref rs))))

(define-prim (##random-source-state-set! rs new-state)
  ((macro-random-source-state-set! rs) rs new-state))

(define-prim (random-source-state-set! rs new-state)
  (macro-force-vars (rs new-state)
    (macro-check-random-source rs 1 (random-source-state-set! rs new-state)
      (##random-source-state-set! rs new-state))))

(define-prim (##random-source-randomize! rs)
  ((macro-random-source-randomize! rs)))

(define-prim (random-source-randomize! rs)
  (macro-force-vars (rs)
    (macro-check-random-source rs 1 (random-source-randomize! rs)
      (##random-source-randomize! rs))))

(define-prim (##random-source-pseudo-randomize! rs i j)
  ((macro-random-source-pseudo-randomize! rs) i j))

(define-prim (random-source-pseudo-randomize! rs i j)
  (macro-force-vars (rs i j)
    (macro-check-random-source rs 1 (random-source-pseudo-randomize! rs i j)
      (if (not (macro-exact-int? i))
          (##fail-check-exact-integer 2 random-source-pseudo-randomize! rs i j)
          (if (not (macro-exact-int? j))
              (##fail-check-exact-integer 3 random-source-pseudo-randomize! rs i j)
              (if (negative? i)
                  (##raise-range-exception 2 random-source-pseudo-randomize! rs i j)
                  (if (negative? j)
                      (##raise-range-exception 3 random-source-pseudo-randomize! rs i j)
                      (##random-source-pseudo-randomize! rs i j))))))))

(define-prim (##random-source-make-integers rs)
  ((macro-random-source-make-integers rs)))

(define-prim (random-source-make-integers rs)
  (macro-force-vars (rs)
    (macro-check-random-source rs 1 (random-source-make-integers rs)
      (##random-source-make-integers rs))))

(define-prim (##random-source-make-reals rs #!optional (p (macro-absent-obj)))
  ((macro-random-source-make-reals rs)
   (if (eq? p (macro-absent-obj))
       (macro-inexact-+1)
       p)))

(define-prim (random-source-make-reals rs #!optional (p (macro-absent-obj)))
  (macro-force-vars (rs p)
    (macro-check-random-source rs 1 (random-source-make-reals rs p)
      (if (eq? p (macro-absent-obj))
          (##random-source-make-reals rs)
          (if (rational? p)
              (let ((precision (macro-real->inexact p)))
                (if (and (fl< (macro-inexact-+0) precision)
                         (fl< precision (macro-inexact-+1)))
                    (##random-source-make-reals rs precision)
                    (##raise-range-exception 2 random-source-make-reals rs p)))
              (##fail-check-finite-real 2 random-source-make-reals rs p))))))

(define-prim (##random-source-make-f64vectors rs #!optional (p (macro-absent-obj)))
  ((macro-random-source-make-f64vectors rs)
   (if (eq? p (macro-absent-obj))
       (macro-inexact-+1)
       p)))

(define-prim (random-source-make-f64vectors rs #!optional (p (macro-absent-obj)))
  (macro-force-vars (rs p)
    (macro-check-random-source rs 1 (random-source-make-f64vectors rs p)
      (if (eq? p (macro-absent-obj))
          (##random-source-make-f64vectors rs)
          (if (rational? p)
              (let ((precision (macro-real->inexact p)))
                (if (and (fl< (macro-inexact-+0) precision)
                         (fl< precision (macro-inexact-+1)))
                    (##random-source-make-f64vectors rs precision)
                    (##raise-range-exception 2 random-source-make-f64vectors rs p)))
              (##fail-check-finite-real 2 random-source-make-f64vectors rs p))))))

(define-prim (##random-source-make-u8vectors rs)
  ((macro-random-source-make-u8vectors rs)))

(define-prim (random-source-make-u8vectors rs)
  (macro-force-vars (rs)
    (macro-check-random-source rs 1 (random-source-make-u8vectors rs)
      (##random-source-make-u8vectors rs))))

(define default-random-source #f)
(set! default-random-source (##make-random-source-mrg32k3a))

(define random-integer
  (##random-source-make-integers default-random-source))

(define random-real
  (##random-source-make-reals default-random-source))

(define random-u8vector
  (##random-source-make-u8vectors default-random-source))

(define random-f64vector
  (##random-source-make-f64vectors default-random-source))

;;;============================================================================
