;;;; numbers.scm
;
; Copyright (c) 2008 The CHICKEN Team
; Copyright (c) 2000-2007, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.


(declare 
  (uses regex)
  (disable-interrupts)
  (no-bound-checks)
  (no-procedure-checks))



(module numbers 
    (+ - * / = > < >= <=
       add1 sub1 signum number->string string->number 
       bitwise-and bitwise-ior bitwise-xor bitwise-not arithmetic-shift
       numbers:bitwise-and numbers:bitwise-ior numbers:bitwise-xor 
       numbers:bitwise-not
       eqv? equal?
       exp log sin cos tan atan acos asin expt sqrt conj
       quotient modulo remainder
       numerator denominator
       abs max min gcd lcm
       positive? negative? odd? even? zero?
       exact? inexact?
       rationalize
       random randomize
       floor ceiling truncate round
       inexact->exact exact->inexact
       number? complex? real? rational? integer?
       make-rectangular make-polar real-part imag-part magnitude angle
       bignum? ratnum? cflonum? rectnum? compnum? cintnum? cplxnum?
       numbers:+ numbers:- numbers:> numbers:< numbers:=
       numbers:>= numbers:<=)

  (import (except scheme
		  + - * / = > < >= <=
		  number->string string->number 
		  eqv? equal?
		  exp log sin cos tan atan acos asin expt sqrt
		  quotient modulo remainder
		  numerator denominator
		  abs max min gcd lcm
		  positive? negative? odd? even? zero?
		  exact? inexact?
		  rationalize
		  floor ceiling truncate round
		  inexact->exact exact->inexact
		  number? complex? real? rational? integer?
		  make-rectangular make-polar real-part imag-part magnitude angle)
	  (except chicken add1 sub1 random randomize conj signum
		  force-finalizers
		  bitwise-and bitwise-ior bitwise-xor bitwise-not arithmetic-shift)
	  (except foreign foreign-declare)
	  regex easyffi)

#>!
#include "numbers-c.h"
<#

#>
#include "numbers-c.c"

#define C_specialequalptrs(x, y)   C_mk_bool(C_block_item(x, 0) == C_block_item(y, 0))
<#


;;; Error handling

(define (bad-number loc x) (##sys#signal-hook #:type-error loc "bad argument type - not a number" x))
(define (bad-real loc x) (##sys#signal-hook #:type-error loc "bad argument type - not a real number" x))
(define (bad-integer loc x) (##sys#signal-hook #:type-error loc "bad argument type - not an integer" x))
(define (bad-complex/o loc x) (##sys#signal-hook #:type-error loc "bad argument type - complex number has no ordering" x))
(define (bad-base loc x) (##sys#signal-hook #:type-error loc "bad argument type - not a valid base" x))
(define (div/0 loc x y) (##sys#signal-hook #:arithmetic-error loc "division by zero" x y))

(define-inline (%init-tags tagvec) (##core#inline "init_tags" tagvec))
(define-inline (%check-number x) (##core#inline "check_number" x))

(define-inline (assert-number x loc)
  (when (eq? NONE (%check-number x))
    (bad-number loc x) ) )

(define-inline (fix-div/0 x y loc)
  (if (eq? y 0)
      (div/0 loc x y)
      y) )

(define-inline (flo-div/0 x y loc)
  (if (##core#inline "C_flonum_equalp" y 0.0)
      (div/0 loc x y)
      y) )

;;; Constants

(define-constant PI 3.141592653589793)

;;; Primitives

(define-inline (fp/ x y) (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y))
(define-inline (fp+ x y) (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y))
(define-inline (fp- x y) (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y))
(define-inline (fp* x y) (##core#inline_allocate ("C_a_i_flonum_times" 4) x y))
(define-inline (fp= x y) (##core#inline "C_flonum_equalp" x y))
(define-inline (fp> x y) (##core#inline "C_flonum_greaterp" x y))
(define-inline (fp< x y) (##core#inline "C_flonum_lessp" x y))

(define-inline (%flonum? x) (##core#inline "flonump" x))
(define-inline (%flo-integer? x) (##core#inline "C_i_integerp" x))

(define-inline (complex-real c) (##sys#slot c 1))
(define-inline (complex-imag c) (##sys#slot c 2))
(define-inline (%make-complex r i) (##sys#make-structure 'compnum r i))

(define-inline (%fix->flo n) (##core#inline_allocate ("fix_to_flo" 4) n))
(define-inline (%big->flo n) (##core#inline_allocate ("big_to_flo" 4) n))
(define-inline (%rat->flo n) (##core#inline_allocate ("rat_to_flo" 4) n))

(define %fix+fix (##core#primitive "fix_plus_fix"))
(define %fix+big (##core#primitive "fix_plus_big"))
(define %fix+rat (##core#primitive "fix_plus_rat"))
(define %big+big (##core#primitive "big_plus_big"))
(define %big+rat (##core#primitive "big_plus_rat"))
(define %rat+rat (##core#primitive "rat_plus_rat"))

(define %big-neg (##core#primitive "big_neg"))
(define %rat-neg (##core#primitive "rat_neg"))

(define %fix-big (##core#primitive "fix_minus_big"))
(define %fix-rat (##core#primitive "fix_minus_rat"))
(define %big-fix (##core#primitive "big_minus_fix"))
(define %big-big (##core#primitive "big_minus_big"))
(define %big-rat (##core#primitive "big_minus_rat"))
(define %rat-big (##core#primitive "rat_minus_big"))
(define %rat-rat (##core#primitive "rat_minus_rat"))
(define %rat-fix (##core#primitive "rat_minus_fix"))

(define %fix*fix (##core#primitive "fix_times_fix"))
(define %fix*big (##core#primitive "fix_times_big"))
(define %fix*rat (##core#primitive "fix_times_rat"))
(define %big*big (##core#primitive "big_times_big"))
(define %big*rat (##core#primitive "big_times_rat"))
(define %rat*rat (##core#primitive "rat_times_rat"))

(define %fix/fix (##core#primitive "fix_quotient_fix"))
(define %fix/big (##core#primitive "fix_quotient_big"))
(define %fix/rat (##core#primitive "fix_quotient_rat"))
(define %big/fix (##core#primitive "big_quotient_fix"))
(define %big/big (##core#primitive "big_quotient_big"))
(define %big/rat (##core#primitive "big_quotient_rat"))
(define %rat/fix (##core#primitive "rat_quotient_fix"))
(define %rat/big (##core#primitive "rat_quotient_big"))
(define %rat/rat (##core#primitive "rat_quotient_rat"))

(define (%free-bignum x) (##core#inline "free_bignum" x))
(define (%free-ratnum x) (##core#inline "free_ratnum" x))

(define-inline (%big-comp x y) (##core#inline "big_comp" x y))
(define-inline (%rat-equal x y) (##core#inline "rat_equalp" x y))
(define-inline (%rat-comp x y) (##core#inline "rat_comp" x y))
(define-inline (%fix-comp-big x y) (##core#inline "fix_comp_big" x y))
(define-inline (%fix-comp-rat x y) (##core#inline "fix_comp_rat" x y))
(define-inline (%rat-comp-big x y) (##core#inline "rat_comp_big" x y))

(define %big-abs (##core#primitive "big_abs"))
(define %rat-abs (##core#primitive "rat_abs"))

(define %rat-numerator (##core#primitive "rat_numerator"))
(define %rat-denominator (##core#primitive "rat_denominator"))

(define-inline (%big-odd? x) (##core#inline "big_oddp" x))

(define %quotient-0 (##core#primitive "C_quotient"))
(define %%expt-0 (##core#primitive "C_expt"))

(define (%expt-0 a b)
  (if (and (negative? a) (not (##sys#integer? b)))
      (* (%%expt-0 (- a) b)
         (exp (make-complex 0.0 (* PI b))))
      (%%expt-0 a b)))

(define %fix-div-big (##core#primitive "fix_div_big"))
(define %big-div-fix (##core#primitive "big_div_fix"))
(define %big-div-big (##core#primitive "big_div_big"))

(define %flo->big (##core#primitive "flo_to_big"))
(define %flo->rat (##core#primitive "flo_to_rat"))

(define %rat-floor (##core#primitive "rat_floor"))
(define %rat-truncate (##core#primitive "rat_truncate"))
(define %rat-ceiling (##core#primitive "rat_ceiling"))
(define %rat-round (##core#primitive "rat_round"))

(define %int-and-int (##core#primitive "int_and_int"))
(define %int-ior-int (##core#primitive "int_ior_int"))
(define %int-xor-int (##core#primitive "int_xor_int"))
(define %int-not (##core#primitive "int_not"))
(define %int-shift (##core#primitive "int_shift"))

(define string->number-0 (##core#primitive "C_string_to_number"))
(define number->string-0 (##core#primitive "C_number_to_string"))

(define %big->string (##core#primitive "big_to_string"))
(define %rat->string (##core#primitive "rat_to_string"))

(define %string->big (##core#primitive "string_to_big"))
(define %string->rat (##core#primitive "string_to_rat"))

(define-inline (%subchar s i) (##core#inline "C_subchar" s i))

(define (##numbers#fetch-counters vec) (##core#inline "fetch_counters" vec))

(define-inline (%fix-randomize n) (##core#inline "fix_randomize" n))
(define-inline (%big-randomize n) (##core#inline "big_randomize" n))

(define %fix-random (##core#primitive "fix_random"))
(define %big-random (##core#primitive "big_random"))


;;; Support macros

(define-syntax switchq
  (syntax-rules (else)
    ((_ "aux" _) (##core#undefined))
    ((_ "aux" _ (else body ...))
     (begin body ...))
    ((_ "aux" tmp (val body ...) more ...)
     (if (eq? tmp val)
	 (begin body ...)
	 (switchq "aux" tmp more ...)))
    ((_ exp body ...)
     (let ((tmp exp))
       (switchq "aux" tmp body ...)))))


;;; Finalizer invocation:

(define (force-finalizers result)
  ;(print "forcing...")
  (let loop ()
    (##sys#gc)
    (if (fx> (##sys#slot ##sys#pending-finalizers 0) 0)
	(begin
	  (##sys#run-pending-finalizers #f)
	  (loop) )
	result) ) )


;;; Setup

(%init-tags
 (vector 'bignum			; BIG_TAG
	 'ratnum			; RAT_TAG
	 'compnum			; COMP_TAG
	 %free-bignum                   ; BIG_FREE
	 %free-ratnum			; RAT_FREE
	 force-finalizers) )

(##sys#gc #f)				; move tag-vector into 2nd generation


;;; Basic arithmetic:

(define (+ . args)
  (if (null? args) 
      0
      (let ((x (##sys#slot args 0))
	    (rest (##sys#slot args 1)))
	(cond ((null? rest)
	       (assert-number x '+) 
	       x)
	      (else
	       (let loop ((args rest) (x x))
		 (if (null? args)
		     x
		     (loop (##sys#slot args 1) (%+ x (##sys#slot args 0))) ) ) ) ) ) ) )

(define (%+ x y)
  (switchq (%check-number x)
    [FIX 
     (switchq (%check-number y)
       [FIX (%fix+fix x y)]
       [FLO (fp+ (%fix->flo x) y)]
       [BIG (%fix+big x y)]
       [RAT (%fix+rat x y)]
       [COMP (%comp+comp (%make-complex x 0) y)]
       [else (bad-number '+ y)] ) ]
    [FLO 
     (switchq (%check-number y)
       [FIX (fp+ x (%fix->flo y))]
       [FLO (fp+ x y)]		
       [BIG (fp+ x (%big->flo y))]	    
       [RAT (fp+ x (%rat->flo y))]		
       [COMP (%comp+comp (%make-complex x 0) y)]
       [else (bad-number '+ y)] ) ]
    [BIG
     (switchq (%check-number y)
       [FIX (%fix+big y x)]
       [FLO (fp+ (%big->flo x) y)]
       [BIG (%big+big x y)]		
       [RAT (%big+rat x y)]		
       [COMP (%comp+comp (%make-complex x 0) y)]
       [else (bad-number '+ y)] ) ]
    [RAT
     (switchq (%check-number y)
       [FIX (%fix+rat y x)]
       [FLO (fp+ (%rat->flo x) y)]
       [BIG (%big+rat y x)]
       [RAT (%rat+rat x y)]	       
       [COMP (%comp+comp (%make-complex x 0) y)]
       [else (bad-number '+ y)] ) ]
    [COMP
     (switchq (%check-number y)
       [COMP (%comp+comp x y)]
       [NONE (bad-number '+ y)] 
       [else (%comp+comp x (%make-complex y 0))] ) ]
    [else (bad-number '+ x)] ) )

(define numbers:+ %+)

(define (%comp+comp x y)
  (let ([r (%+ (complex-real x) (complex-real y))]
	[i (%+ (complex-imag x) (complex-imag y))] )
    (make-complex r i) ) )

(define (- arg1 . args)
  (if (null? args) 
      (switchq (%check-number arg1)
	[FIX (fxneg arg1)]
	[FLO (fpneg arg1)]
	[BIG (%big-neg arg1)]
	[RAT (%rat-neg arg1)]
	[COMP (%make-complex (%- 0 (complex-real arg1)) (complex-imag arg1))]
	[else (bad-number '- arg1)] )
      (let loop ([args (##sys#slot args 1)] [x (%- arg1 (##sys#slot args 0))])
	(if (null? args)
	    x
	    (loop (##sys#slot args 1) (%- x (##sys#slot args 0))) ) ) ) )

(define (%- x y)
  (switchq (%check-number x)
    [FIX 
     (switchq (%check-number y)
       [FIX (%fix+fix x (fxneg y))]
       [FLO (fp- (%fix->flo x) y)]
       [BIG (%fix-big x y)]
       [RAT (%fix-rat x y)]
       [COMP (%comp-comp (%make-complex x 0) y)]
       [else (bad-number '- y)] ) ]
    [FLO 
     (switchq (%check-number y)
       [FIX (fp- x (%fix->flo y))]
       [FLO (fp- x y)]		
       [BIG (fp- x (%big->flo y))]	    
       [RAT (fp- x (%rat->flo y))]		
       [COMP (%comp-comp (%make-complex x 0) y)]
       [else (bad-number '- y)] ) ]
    [BIG
     (switchq (%check-number y)
       [FIX (%big-fix x y)]
       [FLO (fp- (%big->flo x) y)]
       [BIG (%big-big x y)]		
       [RAT (%big-rat x y)]		
       [COMP (%comp-comp (%make-complex x 0) y)]
       [else (bad-number '- y)] ) ]
    [RAT
     (switchq (%check-number y)
       [FIX (%rat-fix x y)]
       [FLO (fp- (%rat->flo x) y)]
       [BIG (%rat-big x y)]
       [RAT (%rat-rat x y)]	       
       [COMP (%comp-comp (%make-complex x 0) y)]
       [else (bad-number '- y)] ) ]
    [COMP
     (switchq (%check-number y)
       [COMP (%comp-comp x y)]
       [NONE (bad-number '- y)] 
       [else (%comp-comp x (%make-complex y 0))] ) ]
    [else (bad-number '- x)] ) )

(define numbers:- %-)

(define (%comp-comp x y)
  (let ([r (%- (complex-real x) (complex-real y))]
	[i (%- (complex-imag x) (complex-imag y))] )
    (make-complex r i) ) )

(define (* . args)
  (if (null? args) 
      1
      (let ((x (##sys#slot args 0))
	    (rest (##sys#slot args 1)))
	(cond ((null? rest)
	       (assert-number x '+) 
	       x)
	      (else
	       (let loop ((args rest) (x x))
		 (if (null? args)
		     x
		     (loop (##sys#slot args 1) (%* x (##sys#slot args 0))) ) ) ) ) ) ) )

(define (%* x y)
  (switchq (%check-number x)
    [FIX 
     (switchq (%check-number y)
       [FIX (%fix*fix x y)]
       [FLO (fp* (%fix->flo x) y)]
       [BIG (%fix*big x y)]
       [RAT (%fix*rat x y)]
       [COMP (%comp*comp (%make-complex x 0) y)]
       [else (bad-number '* y)] ) ]
    [FLO 
     (switchq (%check-number y)
       [FIX (fp* x (%fix->flo y))]
       [FLO (fp* x y)]		
       [BIG (fp* x (%big->flo y))]	    
       [RAT (fp* x (%rat->flo y))]		
       [COMP (%comp*comp (%make-complex x 0) y)]
       [else (bad-number '* y)] ) ]
    [BIG
     (switchq (%check-number y)
       [FIX (%fix*big y x)]
       [FLO (fp* (%big->flo x) y)]
       [BIG (%big*big x y)]		
       [RAT (%big*rat x y)]		
       [COMP (%comp*comp (%make-complex x 0) y)]
       [else (bad-number '* y)] ) ]
    [RAT
     (switchq (%check-number y)
       [FIX (%fix*rat y x)]
       [FLO (fp* (%rat->flo x) y)]
       [BIG (%big*rat y x)]
       [RAT (%rat*rat x y)]	       
       [COMP (%comp*comp (%make-complex x 0) y)]
       [else (bad-number '* y)] ) ]
    [COMP
     (switchq (%check-number y)
       [COMP (%comp*comp x y)]
       [NONE (bad-number '* y)] 
       [else (%comp*comp x (%make-complex y 0))] ) ]
    [else (bad-number '* x)] ) )

(define (%comp*comp x y)
  (let* ([a (complex-real x)]
	 [b (complex-imag x)]
	 [c (complex-real y)]
	 [d (complex-imag y)] 
	 [r (%- (%* a c) (%* b d))]
	 [i (%+ (%* a d) (%* b c))] )
    (make-complex r i) ) )

(define (/ arg1 . args)
  (if (null? args) 
      (%/ 1 arg1)
      (let loop ([args (##sys#slot args 1)] [x (%/ arg1 (##sys#slot args 0))])
	(if (null? args)
	    x
	    (loop (##sys#slot args 1) (%/ x (##sys#slot args 0))) ) ) ) )

(define (%/ x y)
  (switchq (%check-number x)
    [FIX 
     (switchq (%check-number y)
       [FIX (%fix/fix x (fix-div/0 x y '/))]
       [FLO (fp/ (%fix->flo x) (flo-div/0 x y '/))]
       [BIG (%fix/big x y)]
       [RAT (%fix/rat x y)]
       [COMP (%comp/comp (%make-complex x 0) y)]
       [else (bad-number '/ y)] ) ]
    [FLO 
     (switchq (%check-number y)
       [FIX (fp/ x (%fix->flo (fix-div/0 x y '/)))]
       [FLO (fp/ x (flo-div/0 x y '/))]		
       [BIG (fp/ x (%big->flo y))]	    
       [RAT (fp/ x (%rat->flo y))]		
       [COMP (%comp/comp (%make-complex x 0) y)]
       [else (bad-number '/ y)] ) ]
    [BIG
     (switchq (%check-number y)
       [FIX (%big/fix x (fix-div/0 x y '/))]
       [FLO (fp/ (%big->flo x) (flo-div/0 x y '/))]
       [BIG (%big/big x y)]		
       [RAT (%big/rat x y)]		
       [COMP (%comp/comp (%make-complex x 0) y)]
       [else (bad-number '/ y)] ) ]
    [RAT
     (switchq (%check-number y)
       [FIX (%rat/fix x (fix-div/0 x y '/))]
       [FLO (fp/ (%rat->flo x) (flo-div/0 x y '/))]
       [BIG (%rat/big x y)]
       [RAT (%rat/rat x y)]	       
       [COMP (%comp-comp (%make-complex x 0) y)]
       [else (bad-number '/ y)] ) ]
    [COMP
     (switchq (%check-number y)
       [COMP (%comp/comp x y)]
       [NONE (bad-number '/ y)] 
       [else (%comp/comp x (%make-complex y 0))] ) ]
    [else (bad-number '/ x)] ) )

(define (%comp/comp p q)
  (let* ([a (complex-real p)]
	 [b (complex-imag p)]
	 [c (complex-real q)]
	 [d (complex-imag q)]
	 [r (%+ (%* c c) (%* d d))]
	 [x (%/ (%+ (%* a c) (%* b d)) r)]
	 [y (%/ (%- (%* b c) (%* a d)) r)] )
    (make-complex x y) ) )


;;; Comparisons:

(define (%= x y) (##core#inline "num_equalp_2" x y))
(define numbers:= %=)
(define = (##core#primitive "num_equalp"))

(define (> x1 x2 . xs)
  (and (%> x1 x2 '>)
       (let loop ([x x2] [xs xs])
	 (or (null? xs)
	     (let ([h (##sys#slot xs 0)])
	       (and (%> x h '>)
		    (loop h (##sys#slot xs 1)) ) ) ) ) ) )

(define (%> x y loc)
  (switchq (%check-number x)
    (FIX 
     (switchq (%check-number y)
       (FIX (fx> x y))
       (FLO (fp> (%fix->flo x) y))
       (BIG (fx> (%fix-comp-big x y) 0))
       (RAT (fx> (%fix-comp-rat x y) 0))
       (COMP (bad-complex/o loc y))
       (else (bad-number loc y)) ) )
    (FLO
     (switchq (%check-number y)
       (FIX (fp> x (%fix->flo y)))
       (FLO (fp> x y))
       (BIG (fp> x (%big->flo y)))
       (RAT (fp> x (%rat->flo y)))
       (COMP (bad-complex/o loc y))
       (else (bad-number loc y)) ) )
    (BIG 
     (switchq (%check-number y)
       (FIX (fx<= (%fix-comp-big y x) 0))
       (FLO (fp> (%big->flo x) y))
       (BIG (fx> (%big-comp x y) 0))
       (RAT (fx<= (%rat-comp-big y x) 0))
       (COMP (bad-complex/o loc y))
       (else (bad-number loc y)) ) )
    (RAT
     (switchq (%check-number y)
       (FIX (fx<= (%fix-comp-rat y x) 0))
       (FLO (fp> (%rat->flo x) y))
       (BIG (fx> (%rat-comp-big x y) 0))
       (RAT (fx> (%rat-comp x y) 0))
       (COMP (bad-complex/o loc y))
       (else (bad-number loc y)) ) )
    (COMP (bad-complex/o loc x))
    (else (bad-number loc x)) ) )

(define (numbers:> x y) (%> x y '>))
(define (numbers:<= x y) (not (%> x y '<=)))

(define (< x1 x2 . xs)
  (and (%< x1 x2 '<)
       (let loop ([x x2] [xs xs])
	 (or (null? xs)
	     (let ([h (##sys#slot xs 0)])
	       (and (%< x h '<)
		    (loop h (##sys#slot xs 1)) ) ) ) ) ) )

(define (%< x y loc)
  (switchq (%check-number x)
    (FIX 
     (switchq (%check-number y)
       (FIX (fx< x y))
       (FLO (fp< (%fix->flo x) y))
       (BIG (fx< (%fix-comp-big x y) 0))
       (RAT (fx< (%fix-comp-rat x y) 0))
       (COMP (bad-complex/o loc y))
       (else (bad-number loc y)) ) )
    (FLO
     (switchq (%check-number y)
       (FIX (fp< x (%fix->flo y)))
       (FLO (fp< x y))
       (BIG (fp< x (%big->flo y)))
       (RAT (fp< x (%rat->flo y)))
       (COMP (bad-complex/o loc y))
       (else (bad-number loc y)) ) )
    (BIG 
     (switchq (%check-number y)
       (FIX (fx>= (%fix-comp-big y x) 0))
       (FLO (fp< (%big->flo x) y))
       (BIG (fx< (%big-comp x y) 0))
       (RAT (fx>= (%rat-comp-big y x) 0))
       (COMP (bad-complex/o loc y))
       (else (bad-number loc y)) ) )
    (RAT
     (switchq (%check-number y)
       (FIX (fx>= (%fix-comp-rat y x) 0))
       (FLO (fp< (%rat->flo x) y))
       (BIG (fx< (%rat-comp-big x y) 0))
       (RAT (fx< (%rat-comp x y) 0))
       (COMP (bad-complex/o loc y))
       (else (bad-number loc y)) ) )
    (COMP (bad-complex/o loc x))
    (else (bad-number loc x)) ) )

(define (numbers:< x y) (%< x y '<))
(define (numbers:>= x y) (not (%< x y '>=)))

(define (>= x1 x2 . xs)
  (and (not (%< x1 x2 '>=))
       (let loop ([x x2] [xs xs])
	 (or (null? xs)
	     (let ([h (##sys#slot xs 0)])
	       (and (not (%< x h '>=))
		    (loop h (##sys#slot xs 1)) ) ) ) ) ) )

(define (<= x1 x2 . xs)
  (and (not (%> x1 x2 '<=))
       (let loop ([x x2] [xs xs])
	 (or (null? xs)
	     (let ([h (##sys#slot xs 0)])
	       (and (not (%> x h '<=))
		    (loop h (##sys#slot xs 1)) ) ) ) ) ) )


;;; Complex numbers

(define (make-complex r i)
  (if (or (eq? i 0) (and (%flonum? i) (fp= i 0.0)))
      r
      (%make-complex r i) ) )

(define (make-rectangular r i)
  (switchq (%check-number r)
    (COMP (bad-real 'make-rectangular r))
    (NONE (bad-number 'make-rectangular r)) )
  (switchq (%check-number i)
    (COMP (bad-real 'make-rectangular i))
    (NONE (bad-number 'make-rectangular i)) )
  (make-complex r i) )

(define (%make-polar r phi)
  (switchq (%check-number r)
    (COMP (bad-real 'make-polar r))
    (NONE (bad-number 'make-polar r)) )
  (switchq (%check-number phi)
    (COMP (bad-real 'make-polar phi))
    (NONE (bad-number 'make-polar phi)) )
  (make-complex (%* r (##core#inline_allocate ("C_a_i_cos" 4) phi))
		(%* r (##core#inline_allocate ("C_a_i_sin" 4) phi))))

(define make-polar %make-polar)

(define (real-part x)
  (switchq (%check-number x)
    (FIX x)
    (FLO x)
    (BIG x)
    (RAT x)
    (COMP (complex-real x))
    (NONE (bad-number 'real-part x)) ) )

(define (imag-part x)
  (switchq (%check-number x)
    (COMP (complex-imag x))
    (NONE (bad-number 'imag-part x))
    (else 0) ) )

(define (%magnitude x)
  (switchq (%check-number x)
    (COMP (##core#inline_allocate 
	   ("C_a_i_sqrt" 4) 
	   (let ((r (complex-real x))
		 (i (complex-imag x)) )
	     (%+ (%* r r) (%* i i)) ) ) )
    (NONE (bad-number 'magnitude x))
    (else (%abs x)) ) )

(define magnitude %magnitude)

(define (%angle x)
  (switchq (%check-number x)
    (COMP (##core#inline_allocate ("C_a_i_atan2" 4) (complex-imag x) (complex-real x)))
    (NONE (bad-number 'angle x))
    (else (##core#inline_allocate ("C_a_i_atan2" 4) 0 x)) ) )

(define angle %angle)


;;; Rationals

(define (numerator x)
  (switchq (%check-number x)
    (FIX x)
    (FLO (if (%flo-integer? x)
	     x
	     (##sys#signal-hook #:type-error 'numerator "bad argument type - not a rational number" x)) )
    (BIG x)
    (RAT (%rat-numerator x))
    (COMP (##sys#signal-hook #:type-error 'numerator "bad argument type - not a rational number" x))
    (else (bad-number 'numerator x)) ) )

(define (denominator x)
  (switchq (%check-number x)
    (FIX 1)
    (FLO (if (%flo-integer? x)
	     1
	     (##sys#signal-hook #:type-error 'numerator "bad argument type - not a rational number" x)) )
    (BIG 1)
    (RAT (%rat-denominator x))
    (COMP (##sys#signal-hook #:type-error 'denominator "bad argument type - not a rational number" x))
    (else (bad-number 'denominator x)) ) )


;;; Enhanced versions of other standard procedures

(define (%abs x)
  (switchq (%check-number x)
    (FIX (if (fx< x 0) (fxneg x) x))
    (FLO (##core#inline_allocate ("C_a_i_abs" 4) x))
    (BIG (%big-abs x))
    (RAT (%rat-abs x))
    (COMP (##sys#signal-hook #:type-error 'abs "can not compute absolute value of complex number" x))
    (NONE (bad-number 'abs x)) ) )

(define abs %abs)

(define (number? x)
  (switchq (%check-number x)
    (NONE #f)
    (else #t) ) )

(set! ##sys#number? number?)
(define complex? number?)

(define (real? x)
  (switchq (%check-number x)
    (COMP #f)
    (NONE #f)
    (else #t) ) )

(define rational? real?)

(define (%integer? x)
  (switchq (%check-number x)
    (FIX #t)
    (FLO (%flo-integer? x))
    (BIG #t)
    (else #f) ) )

(set! ##sys#integer? %integer?)
(define integer? %integer?)

(define (%exact? x)
  (switchq (%check-number x)
    (FLO #f)
    (COMP (and (%exact? (complex-real x)) (%exact? (complex-imag x))))
    (NONE (bad-number 'exact? x))
    (else #t) ) )

(define exact? %exact?)
(define ##sys#exact? %exact?)

(define (%inexact? x)
  (switchq (%check-number x)
    (FLO #t)
    (COMP (and (%inexact? (complex-real x)) (%inexact? (complex-imag x))))
    (NONE (bad-number 'inexact? x))
    (else #f) ) )

(define inexact? %inexact?)
(define ##sys#inexact? %inexact?)

(define (positive? x) (%> x 0 'positive?))
(define (negative? x) (%< x 0 'negative?))

(define (%zero? x)
  (switchq (%check-number x)
    (FIX (eq? x 0))
    (FLO (fp= x 0.0))
    (NONE (bad-number 'zero? x))
    (else #f) ) )

(define zero? %zero?)

(define (odd? x)
  (switchq (%check-number x)
    (FIX (##core#inline "C_i_oddp" x))
    (FLO (##core#inline "C_i_oddp" x))
    (BIG (%big-odd? x))
    (else (bad-integer 'odd? x)) ) )

(define (even? x)
  (switchq (%check-number x)
    (FIX (##core#inline "C_i_evenp" x))
    (FLO (##core#inline "C_i_evenp" x))
    (BIG (not (%big-odd? x)))
    (else (bad-integer 'even? x)) ) )

(define (max x1 . xs)
  (let ((i (%flonum? x1)))
    (let loop ((m x1) (xs xs))
      (if (null? xs)
	  (if i (%exact->inexact m) m)
	  (let ((h (##sys#slot xs 0)))
	    (switchq (%check-number h)
	      (FLO (set! i #t))
	      (COMP (bad-complex/o 'max h)) )
	    (loop (if (%> h m 'max) h m) (##sys#slot xs 1)) ) ) ) ) )

(define (min x1 . xs)
  (let ((i (%flonum? x1)))
    (let loop ((m x1) (xs xs))
      (if (null? xs)
	  (if i (%exact->inexact m) m)
	  (let ((h (##sys#slot xs 0)))
	    (switchq (%check-number h)
	      (FLO (set! i #t))
	      (COMP (bad-complex/o 'min h)) )
	    (loop (if (%< h m 'min) h m) (##sys#slot xs 1)) ) ) ) ) )

(define (%quotient x y)
  (let ((t1 (%check-number x))
	(t2 (%check-number y))
	(i #f) )
    (switchq t1
      (FLO (if (%flo-integer? x)
	       (begin
		 (set! x (%flo->big x))
		 (set! i #t) )
	       (bad-integer 'quotient x) ) )
      (COMP (bad-integer 'quotient x))
      (NONE (bad-number 'quotient x)) )
    (switchq t2
      (FIX (when (eq? y 0)
	     (##sys#signal-hook #:arithmetic-error 'quotient "division by zero")) )
      (FLO (cond ((fp= y 0.0)
		  (##sys#signal-hook #:arithmetic-error 'quotient "division by zero") )
		 ((%flo-integer? y)
		  (set! y (%flo->big y))
		  (set! i #t) )
		 (else (bad-integer 'quotient y) ) ) )
      (COMP (bad-integer 'quotient y))
      (NONE (bad-number 'quotient y)) )
    (let ((r (if (eq? FIX t1)
		 (if (eq? FIX t2)
		     (%quotient-0 x y)
		     (%fix-div-big x y))
		 (if (eq? FIX t2)
		     (%big-div-fix x y)
		     (%big-div-big x y)) ) ) )
      (if i (%exact->inexact r) r) ) ) )

(define quotient %quotient)

(define (%remainder x y)
  (%- x (%* (%quotient x y) y)) )

(define remainder %remainder)

(define (modulo x y)
  (let ((div (%/ x y)))
    (%- x (%* (if (%integer? div)
		  div
		  (%floor div) )
	      y) ) ) )

(define (%inexact->exact x)
  (switchq (%check-number x)
    (FIX x)
    (FLO (%flo->rat x))
    (BIG x)
    (RAT x)
    (COMP (make-complex (%inexact->exact (complex-real x)) (%inexact->exact (complex-imag x))))
    (NONE (bad-number 'inexact->exact x)) ) )

(define inexact->exact %inexact->exact)
(define ##sys#inexact->exact %inexact->exact)

(define (%exact->inexact x)
  (switchq (%check-number x)
    (FIX (%fix->flo x))
    (FLO x)
    (BIG (%big->flo x))
    (RAT (%rat->flo x))
    (COMP (make-complex (%exact->inexact (complex-real x)) (%exact->inexact (complex-imag x))))
    (NONE (bad-number 'exact->inexact x)) ) )

(define exact->inexact %exact->inexact)
(define ##sys#exact->inexact %exact->inexact)

(define (%gcd-0 x y)
  (let loop ((x x) (y y))
    (if (%zero? y)
	(%abs x)
	(loop y (%remainder x y)) ) ) )

(define (gcd . ns)
  (if (eq? ns '())
      0
      (let loop ([ns ns] [f #t])
	(let ([head (##sys#slot ns 0)]
	      [next (##sys#slot ns 1)] )
	  (if (null? next)
	      (%abs head)
	      (let ([n2 (##sys#slot next 0)])
		(loop (cons (%gcd-0 head n2) (##sys#slot next 1)) #f) ) ) ) ) ) )

(define (%lcm-0 x y)
  (%quotient (%* x y) (%gcd-0 x y)) )

(define (lcm . ns)
  (if (null? ns)
      1
      (let loop ([ns ns] [f #t])
	(let ([head (##sys#slot ns 0)]
	      [next (##sys#slot ns 1)] )
	  (if (null? next)
	      (%abs head)
	      (let ([n2 (##sys#slot next 0)])
		(loop (cons (%lcm-0 head (##sys#slot next 0)) (##sys#slot next 1)) #f) ) ) ) ) ) )

(define (%floor x)
  (switchq (%check-number x)
    (FIX x)
    (FLO (##sys#floor x))
    (BIG x)
    (RAT (%rat-floor x))
    (COMP (bad-real 'floor x)) ) )

(define floor %floor)

(define (ceiling x)
  (switchq (%check-number x)
    (FIX x)
    (FLO (##sys#ceiling x))
    (BIG x)
    (RAT (%rat-ceiling x))
    (COMP (bad-real 'ceiling x)) ) )

(define (truncate x)
  (switchq (%check-number x)
    (FIX x)
    (FLO (##sys#truncate x))
    (BIG x)
    (RAT (%rat-truncate x))
    (COMP (bad-real 'truncate x)) ) )

(define (round x)
  (switchq (%check-number x)
    (FIX x)
    (FLO (##sys#round x))
    (BIG x)
    (RAT (%rat-round x))
    (COMP (bad-real 'round x)) ) )

(define (find-ratio-between x y)
  (define (sr x y)
    (let ((fx (%inexact->exact (%floor x))) 
	  (fy (%inexact->exact (%floor y))))
      (cond ((not (%< fx x 'rationalize)) (list fx 1))
	    ((%= fx fy) 
	     (let ((rat (sr (%/ 1 (%- y fy)) (%/ 1 (%- x fx)))))
	       (list (%+ (cadr rat) (%* fx (car rat))) (car rat))))
	    (else (list (%+ 1 fx) 1)))))
  (cond ((%< y x 'rationalize)
	 (find-ratio-between y x))
	((not (%< x y 'rationalize))
	 (list x 1))
	((%> x 0 'rationalize)
	 (sr x y))
	((%< y 0 'rationalize) 
	 (let ((rat (sr (%- 0 y) (%- 0 x))))
	   (list (%- 0 (car rat)) (cadr rat))))
	(else '(0 1))))

(define (find-ratio x e) (find-ratio-between (%- x e) (%+ x e)))

(define (rationalize x e) (apply %/ (find-ratio x e))) ; doesn't preserve exactness

(define (eqv? x y)
  (or (eq? x y)
      (let ((t1 (%check-number x))
	    (t2 (%check-number y)) )
	(cond ((or (eq? t1 FIX) (eq? t2 FIX)) (eq? x y))
	      ((eq? t1 NONE)
	       (and (eq? t2 NONE)
		    (##core#inline "C_i_eqvp" x y) ) )
	      ((eq? t2 NONE) (##core#inline "C_i_eqvp" x y))
	      (else (%= x y)) ) ) ) )

(define (equal? x y)
  (define (cmp x y s)
    (let ((n (##sys#size x)))
      (and (eq? n (##sys#size y))
	   (let loop ((i s))
	     (or (fx>= i n)
		 (and (eql (##sys#slot x i) (##sys#slot y i))
		      (loop (fx+ i 1)) ) ) ) ) ) )
  (define (eql x y)
    (or (eqv? x y)
	(and (not (or (##sys#immediate? x) (##sys#immediate? y)))
	     (cond ((or (##core#inline "C_byteblockp" x) (##core#inline "C_byteblockp" y))
		    (##core#inline "C_i_equalp" x y) )
		   ((##core#inline "C_specialp" x)
		    (and (##core#inline "C_specialp" y)
			 (##core#inline "C_specialequalptrs" x y)
			 (cmp x y 1) ) )
		   ((##core#inline "C_specialp" y) #f)
                   ((or (keyword? x) (keyword? y))
                       (and (keyword? x) (keyword? y)
                            (string=? (keyword->string x) (keyword->string y))))
		   (else (cmp x y 0)) ) ) ) ) 
  (eql x y) )

(define (%exp n)
  (switchq (%check-number n)
    (NONE (bad-number 'exp n))
    (COMP (%* (##core#inline_allocate ("C_a_i_exp" 4) (complex-real n))
	      (let ((p (complex-imag n)))
		(make-complex
		 (##core#inline_allocate ("C_a_i_cos" 4) p)
		 (##core#inline_allocate ("C_a_i_sin" 4) p) ) ) ) )
    (else (##core#inline_allocate ("C_a_i_exp" 4) (%exact->inexact n)) ) ))

(define exp %exp)

(define (%log n)
  (switchq (%check-number n)
    (NONE (bad-number 'log n))
    (COMP (make-complex (##core#inline_allocate ("C_a_i_log" 4) (%magnitude n)) (%angle n)))
    (else (##core#inline_allocate ("C_a_i_log" 4) (%exact->inexact n)) ) ) )

(define log %log)

(define %i (%make-complex 0 1))
(define %-i (%make-complex 0 -1))
(define %i2 (%make-complex 0 2))

(define (%sin n)
  (switchq (%check-number n)
    (NONE (bad-number 'sin n))
    (COMP (let ((in (%* %i n)))
	    (%/ (%- (%exp in) (%exp (%- 0 in))) %i2)))
    (else (##core#inline_allocate ("C_a_i_sin" 4) (%exact->inexact n)) ) ))

(define sin %sin)

(define (%cos n)
  (switchq (%check-number n)
    (NONE (bad-number 'cos n))
    (COMP (let ((in (%* %i n)))
	    (%/ (%+ (%exp in) (%exp (%- 0 in))) 2) ) )
    (else (##core#inline_allocate ("C_a_i_cos" 4) (%exact->inexact n)) ) ) )

(define cos %cos)

(define (tan n)
  (switchq (%check-number n)
    (NONE (bad-number 'tan n))
    (COMP (%/ (%sin n) (%cos n)))
    (else (##core#inline_allocate ("C_a_i_tan" 4) (%exact->inexact n)) ) ))

(define (%asin n)
  (switchq (%check-number n)
    (NONE (bad-number 'asin n))
    (COMP (%* %-i (%log (%+ (%* %i n) (%sqrt (%- 1 (%* n n)))))))
    (else (##core#inline_allocate ("C_a_i_asin" 4) (%exact->inexact n)) ) ))

(define asin %asin)

(define acos
  (let ((asin1 (##core#inline_allocate ("C_a_i_asin" 4) 1)))
    (lambda (n)
      (switchq (%check-number n)
        (NONE (bad-number 'asin n))
	(COMP (%- asin1 (%asin n)))
	(else (##core#inline_allocate ("C_a_i_acos" 4) (%exact->inexact n)) ) ) ) ) )

(define (atan n #!optional b)
  (switchq (%check-number n)
    (NONE (bad-number 'atan n))
    (COMP (if b
	      (bad-real 'atan n)
	      (let ((in (%* %i n)))
		(%/ (%- (%log (%+ 1 in)) (%log (%- 1 in))) %i2) ) ) )
    (BIG (set! n (%big->flo n)))
    (RAT (set! n (%rat->flo n))) )
  (if b
      (##core#inline_allocate ("C_a_i_atan2" 4) n b)
      (##core#inline_allocate ("C_a_i_atan" 4) n) ) )

(define (%sqrt n)
  (switchq (%check-number n)
    (NONE (bad-number 'sqrt n))
    (COMP (let ((p (%/ (%angle n) 2))
		(m (##core#inline_allocate ("C_a_i_sqrt" 4) (%magnitude n))) )
	    (make-complex (%* m (%cos p)) (%* m (%sin p)) ) ) )
    (else
     (if (negative? n)
       (make-complex
        0.0
        (##core#inline_allocate ("C_a_i_sqrt" 4) (%exact->inexact (- n))))
       (##core#inline_allocate ("C_a_i_sqrt" 4) (%exact->inexact n)) ) )))

(define sqrt %sqrt)

(define (square x) (%* x x))

(define (%integer-power base e)
  (if (negative? e)
      (/ 1 (%integer-power base (- e)))
      (let lp ((res 1) (e2 e))
        (cond
          ((zero? e2) res)
          ((even? e2) ; recursion is faster than iteration here
           (%* res (square (lp 1 (arithmetic-shift e2 -1)))))
          (else
           (lp (%* res base) (- e2 1)))))))

(define (%fix-power base e)
  (define (%fix-expt? base e) (let ((res (%%expt-0 base e))) (and (fixnum? res) res)))
  (if (negative? e)
      (/ 1 (%fix-power base (- e)))
      (let lp ((res 1) (e2 e))
        (cond
          ((zero? e2) res)
          ((%fix-expt? base e2) => (lambda (x) (%* res x)))
          ((even? e2) ; recursion is faster than iteration here
           (%* res (square (lp 1 (arithmetic-shift e2 -1)))))
          (else
           (lp (%* res base) (- e2 1)))))))

(define (expt a b)
  (define (slow-expt a b) (%exp (%* b (%log a))))
  (let ((ta (%check-number a))
	(tb (%check-number b)) )
    (cond ((eq? NONE ta) (bad-number 'expt a))
	  ((eq? NONE tb) (bad-number 'expt b))
	  ((and (eq? FIX ta) (eq? FIX tb)) (%fix-power a b))
	  ((eq? FLO ta)
	   (switchq tb
	     (FIX (%expt-0 a b))
	     (FLO (%expt-0 a b))
	     (BIG (%expt-0 a (%big->flo b)))
	     (RAT (%expt-0 a (%rat->flo b)))
	     (else (slow-expt a b)) ) )
	  ((eq? FLO tb)
	   (switchq ta
	     (FIX (%expt-0 a b))
	     (FLO (%expt-0 a b))
	     (BIG (%expt-0 (%big->flo a) b))
	     (RAT (%expt-0 (%rat->flo a) b))
	     (else (slow-expt a b)) ) )
	  ;; is there a better way
	  ((eq? RAT tb)
	   (let ((e (%rat->flo b)))
	     (switchq ta
	       (FIX (%expt-0 a e))
	       (FLO (%expt-0 a e))
	       (BIG (%expt-0 (%big->flo a) e))
	       (RAT (%expt-0 (%rat->flo a) e))
	       (else (slow-expt a b)))))
	  ((or (eq? COMP ta) (eq? COMP tb)) (slow-expt a b))
	  ;; this doesn't work that well, yet...
	  (else (%integer-power a b)) ) ) )

(define (conj n)
  (switchq (%check-number n)
    (NONE (bad-number 'conj n))
    (COMP (make-complex (complex-real n) (%- 0 (complex-imag n))))
    (else n) ) )

(define (add1 n) (%+ n 1))
(define (sub1 n) (%- n 1))

(define (signum n)
  (switchq (%check-number n)
    (FIX (cond ((eq? 0 n) 0)
	       ((fx< n 0) -1)
	       (else 1) ) )
    (FLO (cond ((fp= n 0.0) 0.0)
	       ((fp< n 0.0) -1.0)
	       (else 1.0) ) )
    (COMP (bad-complex/o 'signum n))
    (NONE (bad-number 'signum n))
    (else (cond ((%< n 0 'signum) -1)
		((%> n 0 'signum) 1)
		(else 0) ) ) ) )

(define (%->integer loc n)
  (switchq (%check-number n)
    (FIX n)
    (FLO (if (%integer? n)
             (%flo->big n)
	     (bad-integer loc n)))
    (BIG n)
    (else (bad-integer loc n)) ) )

(define (numbers:bitwise-and . xs)
  (let loop ((x -1) (xs xs))
    (if (null? xs)
	x
	(let ((xi (##sys#slot xs 0)))
	  (loop
	   (%int-and-int x (%->integer 'bitwise-and xi))
	   (##sys#slot xs 1) ) ) ) ) )

(define (numbers:bitwise-ior . xs)
  (let loop ((x 0) (xs xs))
    (if (null? xs)
	x
	(let ((xi (##sys#slot xs 0)))
	  (loop
	   (%int-ior-int x (%->integer 'bitwise-ior xi))
	   (##sys#slot xs 1) ) ) ) ) )

(define (numbers:bitwise-xor . xs)
  (let loop ((x 0) (xs xs))
    (if (null? xs)
	x
	(let ((xi (##sys#slot xs 0)))
	  (loop
	   (%int-xor-int x (%->integer 'bitwise-xor xi))
	   (##sys#slot xs 1) ) ) ) ) )

(define (numbers:bitwise-not n)
  (%int-not (%->integer 'bitwise-not n)) )

(define bitwise-and numbers:bitwise-and)
(define bitwise-ior numbers:bitwise-ior)
(define bitwise-xor numbers:bitwise-xor)
(define bitwise-not numbers:bitwise-not)

(define (arithmetic-shift n m)
  (%int-shift (%->integer 'arithmetic-shift n) (%->integer 'arithmetic-shift m)) )

(define %number->string
  (let ((string-append string-append))
    (lambda (n #!optional (base 10))
      (unless (memq base '(2 8 10 16)) (bad-base 'number->string base))
      (let numstr ((n n))
	(switchq (%check-number n)
          (FIX (number->string-0 n base))
	  (FLO (number->string-0 n base))
	  (BIG (%big->string n base))
	  (RAT (%rat->string n base))
	  (COMP (let ((r (complex-real n))
		      (i (complex-imag n)) )
		  (string-append (numstr r) (if (%> i 0 'number->string) "+" "") (numstr i) "i") ) )
	  (else (bad-number 'number->string n)) ) ) ) ) )

(define number->string %number->string)
(define ##sys#number->string %number->string) ; for printer

(define %string->number
  (let ((copy string-copy)
	(string-match-positions string-match-positions)
	(rxp (regexp "([-+0-9A-Fa-f#./]+)@([-+0-9A-Fa-f#./]+)"))
	(rxr0 (regexp "([-+][-+0-9A-Fa-f#./]+)i"))
	(rxr (regexp "([-+0-9A-Fa-f#./]+)([-+][-+0-9A-Fa-f#./]*)i")) )
    (lambda (str #!optional (base 10))
      (##sys#check-string str 'string->number)
      (##sys#check-exact base 'string->number)
      (let ((e 0)
	    (str (copy str)) 
	    (len (##sys#size str)) )
	(define (real str start end)
	  (let ((rat #f))
	    (let loop ((i start))
	      (if (fx>= i end)
		  (if rat
		      (%string->rat (##sys#make-c-string (##sys#substring str start end)) base)
		      (%string->big (##sys#make-c-string (##sys#substring str start end)) base) )
		  (let ((c (%subchar str i)))
		    (case c
		      ((#\#)
		       (set! e #f)
		       (##core#inline "C_setsubchar" str i #\0) 
		       (loop (fx+ i 1)) )
		      ((#\.) (string->number-0 (##sys#substring str start end) base))
		      ((#\+ #\-)
		       (if (fx> i start)
			   (string->number-0 (##sys#substring str start end) base)
			   (loop (fx+ i 1)) ) )
		      ((#\e #\E) 
		       (if (eq? base 16)
			   (loop (fx+ i 1))
			   (string->number-0 (##sys#substring str start end) base) ) )
		      ((#\/) 
		       (set! rat i)
		       (loop (fx+ i 1)) )
		      (else (loop (fx+ i 1))) ) ) ) ) ) )
	(define (fin n)
	  (and n
	       (cond ((eq? e 0) n)
		     (e (%inexact->exact n))
		     (else (%exact->inexact n)) ) ) )
	(if (string=? "#" str)
	    0.0
	    (and (fx> len 0)
		 (let ((start
			(let loop ((i 0))
			  (if (fx< i len)
			      (let ((c (%subchar str i)))
				(if (eq? c #\#)
				    (let* ((i (fx+ i 1))
					   (c (%subchar str i)) )
				      (case c
					((#\e)
					 (set! e #t)
					 (loop (fx+ i 1)) )
					((#\i)
					 (set! e #f)
					 (loop (fx+ i 1)) )
					((#\x)
					 (set! base 16)
					 (loop (fx+ i 1)) )
					((#\d)
					 (set! base 10)
					 (loop (fx+ i 1)) )
					((#\o)
					 (set! base 8)
					 (loop (fx+ i 1)) )
					((#\b)
					 (set! base 2)
					 (loop (fx+ i 1)) )
					(else (fx- i 1)) ) )
				    i) )
			      i) ) ) )
		   (let ((sub (##sys#substring str start len)))
		     (cond ((string=? sub "+i") (fin (make-complex 0 1)))
			   ((string=? sub "-i") (fin (make-complex 0 -1)))
			   (else
			    (let ((m (string-match-positions rxp sub)))
			      (if (and m (= 3 (length m))
				       (pair? (cadr m))
				       (pair? (caddr m)))
				  (and-let* ((a (real sub (caadr m) (cadadr m)))
					     (b (real sub (caaddr m) (cadadr (cdr m)))))
				    (fin (%make-polar a b) ) ) 
				  (let* ((m (string-match-positions rxr sub))
					 (lm (and m (length m))))
				    (cond ((and lm (= 3 lm)
						(pair? (cadr m))
						(not (caddr m)))
					   (and-let* ((a (real sub (caadr m) (cadadr m))))
					     (fin (make-complex 0 a)) ) )
					  ((and lm (= 3 lm) 
						(pair? (cadr m))
						(pair? (caddr m)))
					   (let ((r1 (caadr m))
						 (r2 (cadadr m))
						 (i1 (caaddr m))
						 (i2 (cadadr (cdr m))))
					     (and-let* ((rp (real sub r1 r2))
							(ip (if (eq? i2 (fx+ i1 1))
								(case (%subchar sub i1)
								  ((#\-) -1)
								  ((#\+) 1)
								  (else #f) )
								(real sub i1 i2))))
					       (fin (make-complex rp ip)) ) ) )
					  (else
					   (let ((m (string-match-positions rxr0 sub)))
					     (if (and m (pair? (cdr m)) (pair? (cadr m)))
						 (fin (make-complex 0 (real sub (caadr m) (cadadr m))))
						 (fin (or (real str start len)
							  (string->number-0 str) )) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) )

(define (randomize #!optional (seed (##sys#fudge 2)))
  (switchq (%check-number seed)
    (FIX (%fix-randomize seed))
    (BIG (%big-randomize seed))
    (else (bad-integer 'randomize seed)) ) )

(define (random n)
  (switchq (%check-number n)
    (FIX (%fix-random n))
    (BIG (%big-random n))
    (else (bad-integer 'random n)) ) )

(define string->number %string->number)
(define ##sys#string->number %string->number) ; for reader


;;; Non-standard type procedures

(define (bignum? x)     ; big number
  (switchq (%check-number x)
    (BIG #t)
    (else #f) ) )

(define (ratnum? x)     ; ratio number
  (switchq (%check-number x)
    (RAT #t)
    (else #f) ) )

(define (cplxnum? x)    ; complex number
  (switchq (%check-number x)
    (COMP #t)
    (else #f) ) )

(define (rectnum? x)    ; "exact" complex number
  (define (%rect-part? x)
    #;(assert (and (not (eq? COMP (%check-number x))) (not (eq? NONE (%check-number x)))))
    (switchq (%check-number x)
      (FLO (%flo-integer? x))
      (else #t) ) )
  (switchq (%check-number x)
    (COMP (and (%rect-part? (complex-real x)) (%rect-part? (complex-imag x))))
    (else #f) ) )

(define (compnum? x)    ; inexact complex number
  (switchq (%check-number x)
    (COMP (and (%inexact? (complex-real x)) (%inexact? (complex-imag x))))
    (else #f) ) )

(define (cintnum? x)    ; integer number
  (switchq (%check-number x)
    (FIX #t)
    (BIG #t)
    (FLO (%flo-integer? x))
    (COMP (and (%integer? (complex-real x)) (%integer? (complex-imag x))))
    (else #f) ) )

(define (cflonum? x)    ; floatingpoint number
  (switchq (%check-number x)
    (FLO #t)
    (COMP (and (%flonum? (complex-real x)) (%flonum? (complex-imag x))))
    (else #f) ) )

;;; What we provide

(register-feature! #:full-numeric-tower)

)