source: project/release/4/numbers/numbers.scm @ 11917

Last change on this file since 11917 was 11917, checked in by felix winkelmann, 13 years ago

testeez and numbers fixes; still have to be tested

File size: 42.3 KB
Line 
1;;;; numbers.scm
2;
3; Copyright (c) 2008 The CHICKEN Team
4; Copyright (c) 2000-2007, Felix L. Winkelmann
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare 
29  (uses regex)
30  (disable-interrupts)
31  (no-bound-checks)
32  (no-procedure-checks))
33
34
35
36(module numbers 
37    (+ - * / = > < >= <=
38       add1 sub1 signum number->string string->number 
39       bitwise-and bitwise-ior bitwise-xor bitwise-not arithmetic-shift
40       numbers:bitwise-and numbers:bitwise-ior numbers:bitwise-xor 
41       numbers:bitwise-not
42       eqv? equal?
43       exp log sin cos tan atan acos asin expt sqrt conj
44       quotient modulo remainder
45       numerator denominator
46       abs max min gcd lcm
47       positive? negative? odd? even? zero?
48       exact? inexact?
49       rationalize
50       random randomize
51       floor ceiling truncate round
52       inexact->exact exact->inexact
53       number? complex? real? rational? integer?
54       make-rectangular make-polar real-part imag-part magnitude angle
55       bignum? ratnum? cflonum? rectnum? compnum?
56       numbers:+ numbers:- numbers:> numbers:< numbers:=
57       numbers:>= numbers:<=)
58
59  (import (except scheme
60                  + - * / = > < >= <=
61                  number->string string->number 
62                  eqv? equal?
63                  exp log sin cos tan atan acos asin expt sqrt
64                  quotient modulo remainder
65                  numerator denominator
66                  abs max min gcd lcm
67                  positive? negative? odd? even? zero?
68                  exact? inexact?
69                  rationalize
70                  floor ceiling truncate round
71                  inexact->exact exact->inexact
72                  number? complex? real? rational? integer?
73                  make-rectangular make-polar real-part imag-part magnitude angle)
74          (except chicken add1 sub1 random randomize conj signum
75                  force-finalizers
76                  bitwise-and bitwise-ior bitwise-xor bitwise-not arithmetic-shift)
77          (except foreign foreign-declare)
78          regex easyffi)
79
80#>!
81#include "numbers-c.h"
82<#
83
84#>
85#include "numbers-c.c"
86
87#define C_specialequalptrs(x, y)   C_mk_bool(C_block_item(x, 0) == C_block_item(y, 0))
88<#
89
90
91;;; Error handling
92
93(define (bad-number loc x) (##sys#signal-hook #:type-error loc "bad argument type - not a number" x))
94(define (bad-real loc x) (##sys#signal-hook #:type-error loc "bad argument type - not a real number" x))
95(define (bad-integer loc x) (##sys#signal-hook #:type-error loc "bad argument type - not an integer" x))
96(define (bad-complex/o loc x) (##sys#signal-hook #:type-error loc "bad argument type - complex number has no ordering" x))
97(define (bad-base loc x) (##sys#signal-hook #:type-error loc "bad argument type - not a valid base" x))
98(define (div/0 loc x y) (##sys#signal-hook #:arithmetic-error loc "division by zero" x y))
99
100(define-inline (%init-tags tagvec) (##core#inline "init_tags" tagvec))
101(define-inline (%check-number x) (##core#inline "check_number" x))
102
103(define-inline (assert-number x loc)
104  (when (eq? NONE (%check-number x))
105    (bad-number loc x) ) )
106
107(define-inline (fix-div/0 x y loc)
108  (if (eq? y 0)
109      (div/0 loc x y)
110      y) )
111
112(define-inline (flo-div/0 x y loc)
113  (if (##core#inline "C_flonum_equalp" y 0.0)
114      (div/0 loc x y)
115      y) )
116
117
118;;; Primitives
119
120(define-inline (fp/ x y) (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y))
121(define-inline (fp+ x y) (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y))
122(define-inline (fp- x y) (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y))
123(define-inline (fp* x y) (##core#inline_allocate ("C_a_i_flonum_times" 4) x y))
124(define-inline (fp= x y) (##core#inline "C_flonum_equalp" x y))
125(define-inline (fp> x y) (##core#inline "C_flonum_greaterp" x y))
126(define-inline (fp< x y) (##core#inline "C_flonum_lessp" x y))
127
128(define-inline (%flonum? x) (##core#inline "flonump" x))
129(define-inline (%flo-integer? x) (##core#inline "C_i_integerp" x))
130
131(define-inline (complex-real c) (##sys#slot c 1))
132(define-inline (complex-imag c) (##sys#slot c 2))
133(define-inline (%make-complex r i) (##sys#make-structure 'compnum r i))
134
135(define-inline (%fix->flo n) (##core#inline_allocate ("fix_to_flo" 4) n))
136(define-inline (%big->flo n) (##core#inline_allocate ("big_to_flo" 4) n))
137(define-inline (%rat->flo n) (##core#inline_allocate ("rat_to_flo" 4) n))
138
139(define %fix+fix (##core#primitive "fix_plus_fix"))
140(define %fix+big (##core#primitive "fix_plus_big"))
141(define %fix+rat (##core#primitive "fix_plus_rat"))
142(define %big+big (##core#primitive "big_plus_big"))
143(define %big+rat (##core#primitive "big_plus_rat"))
144(define %rat+rat (##core#primitive "rat_plus_rat"))
145
146(define %big-neg (##core#primitive "big_neg"))
147(define %rat-neg (##core#primitive "rat_neg"))
148
149(define %fix-big (##core#primitive "fix_minus_big"))
150(define %fix-rat (##core#primitive "fix_minus_rat"))
151(define %big-fix (##core#primitive "big_minus_fix"))
152(define %big-big (##core#primitive "big_minus_big"))
153(define %big-rat (##core#primitive "big_minus_rat"))
154(define %rat-big (##core#primitive "rat_minus_big"))
155(define %rat-rat (##core#primitive "rat_minus_rat"))
156(define %rat-fix (##core#primitive "rat_minus_fix"))
157
158(define %fix*fix (##core#primitive "fix_times_fix"))
159(define %fix*big (##core#primitive "fix_times_big"))
160(define %fix*rat (##core#primitive "fix_times_rat"))
161(define %big*big (##core#primitive "big_times_big"))
162(define %big*rat (##core#primitive "big_times_rat"))
163(define %rat*rat (##core#primitive "rat_times_rat"))
164
165(define %fix/fix (##core#primitive "fix_quotient_fix"))
166(define %fix/big (##core#primitive "fix_quotient_big"))
167(define %fix/rat (##core#primitive "fix_quotient_rat"))
168(define %big/fix (##core#primitive "big_quotient_fix"))
169(define %big/big (##core#primitive "big_quotient_big"))
170(define %big/rat (##core#primitive "big_quotient_rat"))
171(define %rat/fix (##core#primitive "rat_quotient_fix"))
172(define %rat/big (##core#primitive "rat_quotient_big"))
173(define %rat/rat (##core#primitive "rat_quotient_rat"))
174
175(define (%free-bignum x) (##core#inline "free_bignum" x))
176(define (%free-ratnum x) (##core#inline "free_ratnum" x))
177
178(define-inline (%big-comp x y) (##core#inline "big_comp" x y))
179(define-inline (%rat-equal x y) (##core#inline "rat_equalp" x y))
180(define-inline (%rat-comp x y) (##core#inline "rat_comp" x y))
181(define-inline (%fix-comp-big x y) (##core#inline "fix_comp_big" x y))
182(define-inline (%fix-comp-rat x y) (##core#inline "fix_comp_rat" x y))
183(define-inline (%rat-comp-big x y) (##core#inline "rat_comp_big" x y))
184
185(define %big-abs (##core#primitive "big_abs"))
186(define %rat-abs (##core#primitive "rat_abs"))
187
188(define %rat-numerator (##core#primitive "rat_numerator"))
189(define %rat-denominator (##core#primitive "rat_denominator"))
190
191(define-inline (%big-odd? x) (##core#inline "big_oddp" x))
192
193(define %quotient-0 (##core#primitive "C_quotient"))
194(define %%expt-0 (##core#primitive "C_expt"))
195
196(define (%expt-0 a b)
197  (if (and (negative? a) (not (##sys#integer? b)))
198    (* (%%expt-0 (- a) b)
199       (exp (make-complex 0.0 (* 3.141592653589793 b))))
200    (%%expt-0 a b)))
201
202(define %fix-div-big (##core#primitive "fix_div_big"))
203(define %big-div-fix (##core#primitive "big_div_fix"))
204(define %big-div-big (##core#primitive "big_div_big"))
205
206(define %flo->big (##core#primitive "flo_to_big"))
207(define %flo->rat (##core#primitive "flo_to_rat"))
208
209(define %rat-floor (##core#primitive "rat_floor"))
210(define %rat-truncate (##core#primitive "rat_truncate"))
211(define %rat-ceiling (##core#primitive "rat_ceiling"))
212(define %rat-round (##core#primitive "rat_round"))
213
214(define %int-and-int (##core#primitive "int_and_int"))
215(define %int-ior-int (##core#primitive "int_ior_int"))
216(define %int-xor-int (##core#primitive "int_xor_int"))
217(define %int-not (##core#primitive "int_not"))
218(define %int-shift (##core#primitive "int_shift"))
219
220(define string->number-0 (##core#primitive "C_string_to_number"))
221(define number->string-0 (##core#primitive "C_number_to_string"))
222
223(define %big->string (##core#primitive "big_to_string"))
224(define %rat->string (##core#primitive "rat_to_string"))
225
226(define %string->big (##core#primitive "string_to_big"))
227(define %string->rat (##core#primitive "string_to_rat"))
228
229(define-inline (%subchar s i) (##core#inline "C_subchar" s i))
230
231(define (##numbers#fetch-counters vec) (##core#inline "fetch_counters" vec))
232
233(define-inline (%fix-randomize n) (##core#inline "fix_randomize" n))
234(define-inline (%big-randomize n) (##core#inline "big_randomize" n))
235
236(define %fix-random (##core#primitive "fix_random"))
237(define %big-random (##core#primitive "big_random"))
238
239
240;;; Support macros
241
242(define-syntax switchq
243  (syntax-rules (else)
244    ((_ "aux" _) (##core#undefined))
245    ((_ "aux" _ (else body ...))
246     (begin body ...))
247    ((_ "aux" tmp (val body ...) more ...)
248     (if (eq? tmp val)
249         (begin body ...)
250         (switchq "aux" tmp more ...)))
251    ((_ exp body ...)
252     (let ((tmp exp))
253       (switchq "aux" tmp body ...)))))
254
255
256;;; Finalizer invocation:
257
258(define (force-finalizers result)
259  ;(print "forcing...")
260  (let loop ()
261    (##sys#gc)
262    (if (fx> (##sys#slot ##sys#pending-finalizers 0) 0)
263        (begin
264          (##sys#run-pending-finalizers #f)
265          (loop) )
266        result) ) )
267
268
269;;; Setup
270
271(%init-tags
272 (vector 'bignum                        ; BIG_TAG
273         'ratnum                        ; RAT_TAG
274         'compnum                       ; COMP_TAG
275         %free-bignum                   ; BIG_FREE
276         %free-ratnum                   ; RAT_FREE
277         force-finalizers) )
278
279(##sys#gc #f)                           ; move tag-vector into 2nd generation
280
281
282;;; Basic arithmetic:
283
284(define (+ . args)
285  (if (null? args) 
286      0
287      (let ((x (##sys#slot args 0))
288            (rest (##sys#slot args 1)))
289        (cond ((null? rest)
290               (assert-number x '+) 
291               x)
292              (else
293               (let loop ((args rest) (x x))
294                 (if (null? args)
295                     x
296                     (loop (##sys#slot args 1) (%+ x (##sys#slot args 0))) ) ) ) ) ) ) )
297
298(define (%+ x y)
299  (switchq (%check-number x)
300    [FIX 
301     (switchq (%check-number y)
302       [FIX (%fix+fix x y)]
303       [FLO (fp+ (%fix->flo x) y)]
304       [BIG (%fix+big x y)]
305       [RAT (%fix+rat x y)]
306       [COMP (%comp+comp (%make-complex x 0) y)]
307       [else (bad-number '+ y)] ) ]
308    [FLO 
309     (switchq (%check-number y)
310       [FIX (fp+ x (%fix->flo y))]
311       [FLO (fp+ x y)]         
312       [BIG (fp+ x (%big->flo y))]         
313       [RAT (fp+ x (%rat->flo y))]             
314       [COMP (%comp+comp (%make-complex x 0) y)]
315       [else (bad-number '+ y)] ) ]
316    [BIG
317     (switchq (%check-number y)
318       [FIX (%fix+big y x)]
319       [FLO (fp+ (%big->flo x) y)]
320       [BIG (%big+big x y)]             
321       [RAT (%big+rat x y)]             
322       [COMP (%comp+comp (%make-complex x 0) y)]
323       [else (bad-number '+ y)] ) ]
324    [RAT
325     (switchq (%check-number y)
326       [FIX (%fix+rat y x)]
327       [FLO (fp+ (%rat->flo x) y)]
328       [BIG (%big+rat y x)]
329       [RAT (%rat+rat x y)]           
330       [COMP (%comp+comp (%make-complex x 0) y)]
331       [else (bad-number '+ y)] ) ]
332    [COMP
333     (switchq (%check-number y)
334       [COMP (%comp+comp x y)]
335       [NONE (bad-number '+ y)] 
336       [else (%comp+comp x (%make-complex y 0))] ) ]
337    [else (bad-number '+ x)] ) )
338
339(define numbers:+ %+)
340
341(define (%comp+comp x y)
342  (let ([r (%+ (complex-real x) (complex-real y))]
343        [i (%+ (complex-imag x) (complex-imag y))] )
344    (make-complex r i) ) )
345
346(define (- arg1 . args)
347  (if (null? args) 
348      (switchq (%check-number arg1)
349        [FIX (fxneg arg1)]
350        [FLO (fpneg arg1)]
351        [BIG (%big-neg arg1)]
352        [RAT (%rat-neg arg1)]
353        [COMP (%make-complex (%- 0 (complex-real arg1)) (complex-imag arg1))]
354        [else (bad-number '- arg1)] )
355      (let loop ([args (##sys#slot args 1)] [x (%- arg1 (##sys#slot args 0))])
356        (if (null? args)
357            x
358            (loop (##sys#slot args 1) (%- x (##sys#slot args 0))) ) ) ) )
359
360(define (%- x y)
361  (switchq (%check-number x)
362    [FIX 
363     (switchq (%check-number y)
364       [FIX (%fix+fix x (fxneg y))]
365       [FLO (fp- (%fix->flo x) y)]
366       [BIG (%fix-big x y)]
367       [RAT (%fix-rat x y)]
368       [COMP (%comp-comp (%make-complex x 0) y)]
369       [else (bad-number '- y)] ) ]
370    [FLO 
371     (switchq (%check-number y)
372       [FIX (fp- x (%fix->flo y))]
373       [FLO (fp- x y)]         
374       [BIG (fp- x (%big->flo y))]         
375       [RAT (fp- x (%rat->flo y))]             
376       [COMP (%comp-comp (%make-complex x 0) y)]
377       [else (bad-number '- y)] ) ]
378    [BIG
379     (switchq (%check-number y)
380       [FIX (%big-fix x y)]
381       [FLO (fp- (%big->flo x) y)]
382       [BIG (%big-big x y)]             
383       [RAT (%big-rat x y)]             
384       [COMP (%comp-comp (%make-complex x 0) y)]
385       [else (bad-number '- y)] ) ]
386    [RAT
387     (switchq (%check-number y)
388       [FIX (%rat-fix x y)]
389       [FLO (fp- (%rat->flo x) y)]
390       [BIG (%rat-big x y)]
391       [RAT (%rat-rat x y)]           
392       [COMP (%comp-comp (%make-complex x 0) y)]
393       [else (bad-number '- y)] ) ]
394    [COMP
395     (switchq (%check-number y)
396       [COMP (%comp-comp x y)]
397       [NONE (bad-number '- y)] 
398       [else (%comp-comp x (%make-complex y 0))] ) ]
399    [else (bad-number '- x)] ) )
400
401(define numbers:- %-)
402
403(define (%comp-comp x y)
404  (let ([r (%- (complex-real x) (complex-real y))]
405        [i (%- (complex-imag x) (complex-imag y))] )
406    (make-complex r i) ) )
407
408(define (* . args)
409  (if (null? args) 
410      1
411      (let ((x (##sys#slot args 0))
412            (rest (##sys#slot args 1)))
413        (cond ((null? rest)
414               (assert-number x '+) 
415               x)
416              (else
417               (let loop ((args rest) (x x))
418                 (if (null? args)
419                     x
420                     (loop (##sys#slot args 1) (%* x (##sys#slot args 0))) ) ) ) ) ) ) )
421
422(define (%* x y)
423  (switchq (%check-number x)
424    [FIX 
425     (switchq (%check-number y)
426       [FIX (%fix*fix x y)]
427       [FLO (fp* (%fix->flo x) y)]
428       [BIG (%fix*big x y)]
429       [RAT (%fix*rat x y)]
430       [COMP (%comp*comp (%make-complex x 0) y)]
431       [else (bad-number '* y)] ) ]
432    [FLO 
433     (switchq (%check-number y)
434       [FIX (fp* x (%fix->flo y))]
435       [FLO (fp* x y)]         
436       [BIG (fp* x (%big->flo y))]         
437       [RAT (fp* x (%rat->flo y))]             
438       [COMP (%comp*comp (%make-complex x 0) y)]
439       [else (bad-number '* y)] ) ]
440    [BIG
441     (switchq (%check-number y)
442       [FIX (%fix*big y x)]
443       [FLO (fp* (%big->flo x) y)]
444       [BIG (%big*big x y)]             
445       [RAT (%big*rat x y)]             
446       [COMP (%comp*comp (%make-complex x 0) y)]
447       [else (bad-number '* y)] ) ]
448    [RAT
449     (switchq (%check-number y)
450       [FIX (%fix*rat y x)]
451       [FLO (fp* (%rat->flo x) y)]
452       [BIG (%big*rat y x)]
453       [RAT (%rat*rat x y)]           
454       [COMP (%comp*comp (%make-complex x 0) y)]
455       [else (bad-number '* y)] ) ]
456    [COMP
457     (switchq (%check-number y)
458       [COMP (%comp*comp x y)]
459       [NONE (bad-number '* y)] 
460       [else (%comp*comp x (%make-complex y 0))] ) ]
461    [else (bad-number '* x)] ) )
462
463(define (%comp*comp x y)
464  (let* ([a (complex-real x)]
465         [b (complex-imag x)]
466         [c (complex-real y)]
467         [d (complex-imag y)] 
468         [r (%- (%* a c) (%* b d))]
469         [i (%+ (%* a d) (%* b c))] )
470    (make-complex r i) ) )
471
472(define (/ arg1 . args)
473  (if (null? args) 
474      (%/ 1 arg1)
475      (let loop ([args (##sys#slot args 1)] [x (%/ arg1 (##sys#slot args 0))])
476        (if (null? args)
477            x
478            (loop (##sys#slot args 1) (%/ x (##sys#slot args 0))) ) ) ) )
479
480(define (%/ x y)
481  (switchq (%check-number x)
482    [FIX 
483     (switchq (%check-number y)
484       [FIX (%fix/fix x (fix-div/0 x y '/))]
485       [FLO (fp/ (%fix->flo x) (flo-div/0 x y '/))]
486       [BIG (%fix/big x y)]
487       [RAT (%fix/rat x y)]
488       [COMP (%comp/comp (%make-complex x 0) y)]
489       [else (bad-number '/ y)] ) ]
490    [FLO 
491     (switchq (%check-number y)
492       [FIX (fp/ x (%fix->flo (fix-div/0 x y '/)))]
493       [FLO (fp/ x (flo-div/0 x y '/))]         
494       [BIG (fp/ x (%big->flo y))]         
495       [RAT (fp/ x (%rat->flo y))]             
496       [COMP (%comp/comp (%make-complex x 0) y)]
497       [else (bad-number '/ y)] ) ]
498    [BIG
499     (switchq (%check-number y)
500       [FIX (%big/fix x (fix-div/0 x y '/))]
501       [FLO (fp/ (%big->flo x) (flo-div/0 x y '/))]
502       [BIG (%big/big x y)]             
503       [RAT (%big/rat x y)]             
504       [COMP (%comp/comp (%make-complex x 0) y)]
505       [else (bad-number '/ y)] ) ]
506    [RAT
507     (switchq (%check-number y)
508       [FIX (%rat/fix x (fix-div/0 x y '/))]
509       [FLO (fp/ (%rat->flo x) (flo-div/0 x y '/))]
510       [BIG (%rat/big x y)]
511       [RAT (%rat/rat x y)]           
512       [COMP (%comp-comp (%make-complex x 0) y)]
513       [else (bad-number '/ y)] ) ]
514    [COMP
515     (switchq (%check-number y)
516       [COMP (%comp/comp x y)]
517       [NONE (bad-number '/ y)] 
518       [else (%comp/comp x (%make-complex y 0))] ) ]
519    [else (bad-number '/ x)] ) )
520
521(define (%comp/comp p q)
522  (let* ([a (complex-real p)]
523         [b (complex-imag p)]
524         [c (complex-real q)]
525         [d (complex-imag q)]
526         [r (%+ (%* c c) (%* d d))]
527         [x (%/ (%+ (%* a c) (%* b d)) r)]
528         [y (%/ (%- (%* b c) (%* a d)) r)] )
529    (make-complex x y) ) )
530
531
532;;; Comparisons:
533
534(define (%= x y) (##core#inline "num_equalp_2" x y))
535(define numbers:= %=)
536(define = (##core#primitive "num_equalp"))
537
538(define (> x1 x2 . xs)
539  (and (%> x1 x2 '>)
540       (let loop ([x x2] [xs xs])
541         (or (null? xs)
542             (let ([h (##sys#slot xs 0)])
543               (and (%> x h '>)
544                    (loop h (##sys#slot xs 1)) ) ) ) ) ) )
545
546(define (%> x y loc)
547  (switchq (%check-number x)
548    (FIX 
549     (switchq (%check-number y)
550       (FIX (fx> x y))
551       (FLO (fp> (%fix->flo x) y))
552       (BIG (fx> (%fix-comp-big x y) 0))
553       (RAT (fx> (%fix-comp-rat x y) 0))
554       (COMP (bad-complex/o loc y))
555       (else (bad-number loc y)) ) )
556    (FLO
557     (switchq (%check-number y)
558       (FIX (fp> x (%fix->flo y)))
559       (FLO (fp> x y))
560       (BIG (fp> x (%big->flo y)))
561       (RAT (fp> x (%rat->flo y)))
562       (COMP (bad-complex/o loc y))
563       (else (bad-number loc y)) ) )
564    (BIG 
565     (switchq (%check-number y)
566       (FIX (fx<= (%fix-comp-big y x) 0))
567       (FLO (fp> (%big->flo x) y))
568       (BIG (fx> (%big-comp x y) 0))
569       (RAT (fx<= (%rat-comp-big y x) 0))
570       (COMP (bad-complex/o loc y))
571       (else (bad-number loc y)) ) )
572    (RAT
573     (switchq (%check-number y)
574       (FIX (fx<= (%fix-comp-rat y x) 0))
575       (FLO (fp> (%rat->flo x) y))
576       (BIG (fx> (%rat-comp-big x y) 0))
577       (RAT (fx> (%rat-comp x y) 0))
578       (COMP (bad-complex/o loc y))
579       (else (bad-number loc y)) ) )
580    (COMP (bad-complex/o loc x))
581    (else (bad-number loc x)) ) )
582
583(define (numbers:> x y) (%> x y '>))
584(define (numbers:<= x y) (not (%> x y '<=)))
585
586(define (< x1 x2 . xs)
587  (and (%< x1 x2 '<)
588       (let loop ([x x2] [xs xs])
589         (or (null? xs)
590             (let ([h (##sys#slot xs 0)])
591               (and (%< x h '<)
592                    (loop h (##sys#slot xs 1)) ) ) ) ) ) )
593
594(define (%< x y loc)
595  (switchq (%check-number x)
596    (FIX 
597     (switchq (%check-number y)
598       (FIX (fx< x y))
599       (FLO (fp< (%fix->flo x) y))
600       (BIG (fx< (%fix-comp-big x y) 0))
601       (RAT (fx< (%fix-comp-rat x y) 0))
602       (COMP (bad-complex/o loc y))
603       (else (bad-number loc y)) ) )
604    (FLO
605     (switchq (%check-number y)
606       (FIX (fp< x (%fix->flo y)))
607       (FLO (fp< x y))
608       (BIG (fp< x (%big->flo y)))
609       (RAT (fp< x (%rat->flo y)))
610       (COMP (bad-complex/o loc y))
611       (else (bad-number loc y)) ) )
612    (BIG 
613     (switchq (%check-number y)
614       (FIX (fx>= (%fix-comp-big y x) 0))
615       (FLO (fp< (%big->flo x) y))
616       (BIG (fx< (%big-comp x y) 0))
617       (RAT (fx>= (%rat-comp-big y x) 0))
618       (COMP (bad-complex/o loc y))
619       (else (bad-number loc y)) ) )
620    (RAT
621     (switchq (%check-number y)
622       (FIX (fx>= (%fix-comp-rat y x) 0))
623       (FLO (fp< (%rat->flo x) y))
624       (BIG (fx< (%rat-comp-big x y) 0))
625       (RAT (fx< (%rat-comp x y) 0))
626       (COMP (bad-complex/o loc y))
627       (else (bad-number loc y)) ) )
628    (COMP (bad-complex/o loc x))
629    (else (bad-number loc x)) ) )
630
631(define (numbers:< x y) (%< x y '<))
632(define (numbers:>= x y) (not (%< x y '>=)))
633
634(define (>= x1 x2 . xs)
635  (and (not (%< x1 x2 '>=))
636       (let loop ([x x2] [xs xs])
637         (or (null? xs)
638             (let ([h (##sys#slot xs 0)])
639               (and (not (%< x h '>=))
640                    (loop h (##sys#slot xs 1)) ) ) ) ) ) )
641
642(define (<= x1 x2 . xs)
643  (and (not (%> x1 x2 '<=))
644       (let loop ([x x2] [xs xs])
645         (or (null? xs)
646             (let ([h (##sys#slot xs 0)])
647               (and (not (%> x h '<=))
648                    (loop h (##sys#slot xs 1)) ) ) ) ) ) )
649
650
651;;; Complex numbers
652
653(define (make-complex r i)
654  (if (or (eq? i 0) (and (%flonum? i) (fp= i 0.0)))
655      r
656      (%make-complex r i) ) )
657
658(define (make-rectangular r i)
659  (switchq (%check-number r)
660    (COMP (bad-real 'make-rectangular r))
661    (NONE (bad-number 'make-rectangular r)) )
662  (switchq (%check-number i)
663    (COMP (bad-real 'make-rectangular i))
664    (NONE (bad-number 'make-rectangular i)) )
665  (make-complex r i) )
666
667(define (%make-polar r phi)
668  (switchq (%check-number r)
669    (COMP (bad-real 'make-polar r))
670    (NONE (bad-number 'make-polar r)) )
671  (switchq (%check-number phi)
672    (COMP (bad-real 'make-polar phi))
673    (NONE (bad-number 'make-polar phi)) )
674  (make-complex (%* r (##core#inline_allocate ("C_a_i_cos" 4) phi))
675                (%* r (##core#inline_allocate ("C_a_i_sin" 4) phi))))
676
677(define make-polar %make-polar)
678
679(define (real-part x)
680  (switchq (%check-number x)
681    (FIX x)
682    (FLO x)
683    (BIG x)
684    (RAT x)
685    (COMP (complex-real x))
686    (NONE (bad-number 'real-part x)) ) )
687
688(define (imag-part x)
689  (switchq (%check-number x)
690    (COMP (complex-imag x))
691    (NONE (bad-number 'imag-part x))
692    (else 0) ) )
693
694(define (%magnitude x)
695  (switchq (%check-number x)
696    (COMP (##core#inline_allocate 
697           ("C_a_i_sqrt" 4) 
698           (let ((r (complex-real x))
699                 (i (complex-imag x)) )
700             (%+ (%* r r) (%* i i)) ) ) )
701    (NONE (bad-number 'magnitude x))
702    (else (%abs x)) ) )
703
704(define magnitude %magnitude)
705
706(define (%angle x)
707  (switchq (%check-number x)
708    (COMP (##core#inline_allocate ("C_a_i_atan2" 4) (complex-imag x) (complex-real x)))
709    (NONE (bad-number 'angle x))
710    (else (##core#inline_allocate ("C_a_i_atan2" 4) 0 x)) ) )
711
712(define angle %angle)
713
714
715;;; Rationals
716
717(define (numerator x)
718  (switchq (%check-number x)
719    (FIX x)
720    (FLO (if (%flo-integer? x)
721             x
722             (##sys#signal-hook #:type-error 'numerator "bad argument type - not a rational number" x)) )
723    (BIG x)
724    (RAT (%rat-numerator x))
725    (COMP (##sys#signal-hook #:type-error 'numerator "bad argument type - not a rational number" x))
726    (else (bad-number 'numerator x)) ) )
727
728(define (denominator x)
729  (switchq (%check-number x)
730    (FIX 1)
731    (FLO (if (%flo-integer? x)
732             1
733             (##sys#signal-hook #:type-error 'numerator "bad argument type - not a rational number" x)) )
734    (BIG 1)
735    (RAT (%rat-denominator x))
736    (COMP (##sys#signal-hook #:type-error 'denominator "bad argument type - not a rational number" x))
737    (else (bad-number 'denominator x)) ) )
738
739
740;;; Enhanced versions of other standard procedures
741
742(define (%abs x)
743  (switchq (%check-number x)
744    (FIX (if (fx< x 0) (fxneg x) x))
745    (FLO (##core#inline_allocate ("C_a_i_abs" 4) x))
746    (BIG (%big-abs x))
747    (RAT (%rat-abs x))
748    (COMP (##sys#signal-hook #:type-error 'abs "can not compute absolute value of complex number" x))
749    (NONE (bad-number 'abs x)) ) )
750
751(define abs %abs)
752
753(define (number? x)
754  (switchq (%check-number x)
755    (NONE #f)
756    (else #t) ) )
757
758(set! ##sys#number? number?)
759(define complex? number?)
760
761(define (real? x)
762  (switchq (%check-number x)
763    (COMP #f)
764    (NONE #f)
765    (else #t) ) )
766
767(define rational? real?)
768
769(define (%integer? x)
770  (switchq (%check-number x)
771    (FIX #t)
772    (BIG #t)
773    (FLO (%flo-integer? x))
774    (else #f) ) )
775
776(set! ##sys#integer? %integer?)
777(define integer? %integer?)
778
779(define (%exact? x)
780  (switchq (%check-number x)
781    (FLO #f)
782    (COMP (and (%exact? (complex-real x)) (%exact? (complex-imag x))))
783    (NONE (bad-number 'exact? x))
784    (else #t) ) )
785
786(define exact? %exact?)
787(define ##sys#exact? %exact?)
788
789(define (%inexact? x)
790  (switchq (%check-number x)
791    (FLO #t)
792    (COMP (and (%inexact? (complex-real x)) (%inexact? (complex-imag x))))
793    (NONE (bad-number 'inexact? x))
794    (else #f) ) )
795
796(define inexact? %inexact?)
797(define ##sys#inexact? %inexact?)
798
799(define (positive? x) (%> x 0 'positive?))
800(define (negative? x) (%< x 0 'negative?))
801
802(define (%zero? x)
803  (switchq (%check-number x)
804    (FIX (eq? x 0))
805    (FLO (fp= x 0.0))
806    (NONE (bad-number 'zero? x))
807    (else #f) ) )
808
809(define zero? %zero?)
810
811(define (odd? x)
812  (switchq (%check-number x)
813    (FIX (##core#inline "C_i_oddp" x))
814    (FLO (##core#inline "C_i_oddp" x))
815    (BIG (%big-odd? x))
816    (else (bad-integer 'odd? x)) ) )
817
818(define (even? x)
819  (switchq (%check-number x)
820    (FIX (##core#inline "C_i_evenp" x))
821    (FLO (##core#inline "C_i_evenp" x))
822    (BIG (not (%big-odd? x)))
823    (else (bad-integer 'even? x)) ) )
824
825(define (max x1 . xs)
826  (let ((i (%flonum? x1)))
827    (let loop ((m x1) (xs xs))
828      (if (null? xs)
829          (if i (%exact->inexact m) m)
830          (let ((h (##sys#slot xs 0)))
831            (switchq (%check-number h)
832              (FLO (set! i #t))
833              (COMP (bad-complex/o 'max h)) )
834            (loop (if (%> h m 'max) h m) (##sys#slot xs 1)) ) ) ) ) )
835
836(define (min x1 . xs)
837  (let ((i (%flonum? x1)))
838    (let loop ((m x1) (xs xs))
839      (if (null? xs)
840          (if i (%exact->inexact m) m)
841          (let ((h (##sys#slot xs 0)))
842            (switchq (%check-number h)
843              (FLO (set! i #t))
844              (COMP (bad-complex/o 'min h)) )
845            (loop (if (%< h m 'min) h m) (##sys#slot xs 1)) ) ) ) ) )
846
847(define (%quotient x y)
848  (let ((t1 (%check-number x))
849        (t2 (%check-number y))
850        (i #f) )
851    (switchq t1
852      (FLO (if (%flo-integer? x)
853               (begin
854                 (set! x (%flo->big x))
855                 (set! i #t) )
856               (bad-integer 'quotient x) ) )
857      (COMP (bad-integer 'quotient x))
858      (NONE (bad-number 'quotient x)) )
859    (switchq t2
860      (FIX (when (eq? y 0)
861             (##sys#signal-hook #:arithmetic-error 'quotient "division by zero")) )
862      (FLO (cond ((fp= y 0.0)
863                  (##sys#signal-hook #:arithmetic-error 'quotient "division by zero") )
864                 ((%flo-integer? y)
865                  (set! y (%flo->big y))
866                  (set! i #t) )
867                 (else (bad-integer 'quotient y) ) ) )
868      (COMP (bad-integer 'quotient y))
869      (NONE (bad-number 'quotient y)) )
870    (let ((r (if (eq? FIX t1)
871                 (if (eq? FIX t2)
872                     (%quotient-0 x y)
873                     (%fix-div-big x y))
874                 (if (eq? FIX t2)
875                     (%big-div-fix x y)
876                     (%big-div-big x y)) ) ) )
877      (if i (%exact->inexact r) r) ) ) )
878
879(define quotient %quotient)
880
881(define (%remainder x y)
882  (%- x (%* (%quotient x y) y)) )
883
884(define remainder %remainder)
885
886(define (modulo x y)
887  (let ((div (%/ x y)))
888    (%- x (%* (if (%integer? div)
889                  div
890                  (%floor div) )
891              y) ) ) )
892
893(define (%inexact->exact x)
894  (switchq (%check-number x)
895    (FIX x)
896    (FLO (%flo->rat x))
897    (BIG x)
898    (RAT x)
899    (COMP (make-complex (%inexact->exact (complex-real x)) (%inexact->exact (complex-imag x))))
900    (NONE (bad-number 'inexact->exact x)) ) )
901
902(define inexact->exact %inexact->exact)
903(define ##sys#inexact->exact %inexact->exact)
904
905(define (%exact->inexact x)
906  (switchq (%check-number x)
907    (FIX (%fix->flo x))
908    (FLO x)
909    (BIG (%big->flo x))
910    (RAT (%rat->flo x))
911    (COMP (make-complex (%exact->inexact (complex-real x)) (%exact->inexact (complex-imag x))))
912    (NONE (bad-number 'exact->inexact x)) ) )
913
914(define exact->inexact %exact->inexact)
915(define ##sys#exact->inexact %exact->inexact)
916
917(define (%gcd-0 x y)
918  (let loop ((x x) (y y))
919    (if (%zero? y)
920        (%abs x)
921        (loop y (%remainder x y)) ) ) )
922
923(define (gcd . ns)
924  (if (eq? ns '())
925      0
926      (let loop ([ns ns] [f #t])
927        (let ([head (##sys#slot ns 0)]
928              [next (##sys#slot ns 1)] )
929          (if (null? next)
930              (%abs head)
931              (let ([n2 (##sys#slot next 0)])
932                (loop (cons (%gcd-0 head n2) (##sys#slot next 1)) #f) ) ) ) ) ) )
933
934(define (%lcm-0 x y)
935  (%quotient (%* x y) (%gcd-0 x y)) )
936
937(define (lcm . ns)
938  (if (null? ns)
939      1
940      (let loop ([ns ns] [f #t])
941        (let ([head (##sys#slot ns 0)]
942              [next (##sys#slot ns 1)] )
943          (if (null? next)
944              (%abs head)
945              (let ([n2 (##sys#slot next 0)])
946                (loop (cons (%lcm-0 head (##sys#slot next 0)) (##sys#slot next 1)) #f) ) ) ) ) ) )
947
948(define (%floor x)
949  (switchq (%check-number x)
950    (FIX x)
951    (FLO (##sys#floor x))
952    (BIG x)
953    (RAT (%rat-floor x))
954    (COMP (bad-real 'floor x)) ) )
955
956(define floor %floor)
957
958(define (ceiling x)
959  (switchq (%check-number x)
960    (FIX x)
961    (FLO (##sys#ceiling x))
962    (BIG x)
963    (RAT (%rat-ceiling x))
964    (COMP (bad-real 'ceiling x)) ) )
965
966(define (truncate x)
967  (switchq (%check-number x)
968    (FIX x)
969    (FLO (##sys#truncate x))
970    (BIG x)
971    (RAT (%rat-truncate x))
972    (COMP (bad-real 'truncate x)) ) )
973
974(define (round x)
975  (switchq (%check-number x)
976    (FIX x)
977    (FLO (##sys#round x))
978    (BIG x)
979    (RAT (%rat-round x))
980    (COMP (bad-real 'round x)) ) )
981
982(define (find-ratio-between x y)
983  (define (sr x y)
984    (let ((fx (%inexact->exact (%floor x))) 
985          (fy (%inexact->exact (%floor y))))
986      (cond ((not (%< fx x 'rationalize)) (list fx 1))
987            ((%= fx fy) 
988             (let ((rat (sr (%/ 1 (%- y fy)) (%/ 1 (%- x fx)))))
989               (list (%+ (cadr rat) (%* fx (car rat))) (car rat))))
990            (else (list (%+ 1 fx) 1)))))
991  (cond ((%< y x 'rationalize)
992         (find-ratio-between y x))
993        ((not (%< x y 'rationalize))
994         (list x 1))
995        ((%> x 0 'rationalize)
996         (sr x y))
997        ((%< y 0 'rationalize) 
998         (let ((rat (sr (%- 0 y) (%- 0 x))))
999           (list (%- 0 (car rat)) (cadr rat))))
1000        (else '(0 1))))
1001
1002(define (find-ratio x e) (find-ratio-between (%- x e) (%+ x e)))
1003
1004(define (rationalize x e) (apply %/ (find-ratio x e))) ; doesn't preserve exactness
1005
1006(define (eqv? x y)
1007  (or (eq? x y)
1008      (let ((t1 (%check-number x))
1009            (t2 (%check-number y)) )
1010        (cond ((or (eq? t1 FIX) (eq? t2 FIX)) (eq? x y))
1011              ((eq? t1 NONE)
1012               (and (eq? t2 NONE)
1013                    (##core#inline "C_i_eqvp" x y) ) )
1014              ((eq? t2 NONE) (##core#inline "C_i_eqvp" x y))
1015              (else (%= x y)) ) ) ) )
1016
1017(define (equal? x y)
1018  (define (cmp x y s)
1019    (let ((n (##sys#size x)))
1020      (and (eq? n (##sys#size y))
1021           (let loop ((i s))
1022             (or (fx>= i n)
1023                 (and (eql (##sys#slot x i) (##sys#slot y i))
1024                      (loop (fx+ i 1)) ) ) ) ) ) )
1025  (define (eql x y)
1026    (or (eqv? x y)
1027        (and (not (or (##sys#immediate? x) (##sys#immediate? y)))
1028             (cond ((or (##core#inline "C_byteblockp" x) (##core#inline "C_byteblockp" y))
1029                    (##core#inline "C_i_equalp" x y) )
1030                   ((##core#inline "C_specialp" x)
1031                    (and (##core#inline "C_specialp" y)
1032                         (##core#inline "C_specialequalptrs" x y)
1033                         (cmp x y 1) ) )
1034                   ((##core#inline "C_specialp" y) #f)
1035                   ((or (keyword? x) (keyword? y))
1036                       (and (keyword? x) (keyword? y)
1037                            (string=? (keyword->string x) (keyword->string y))))
1038                   (else (cmp x y 0)) ) ) ) ) 
1039  (eql x y) )
1040
1041(define (%exp n)
1042  (switchq (%check-number n)
1043    (NONE (bad-number 'exp n))
1044    (COMP (%* (##core#inline_allocate ("C_a_i_exp" 4) (complex-real n))
1045              (let ((p (complex-imag n)))
1046                (make-complex
1047                 (##core#inline_allocate ("C_a_i_cos" 4) p)
1048                 (##core#inline_allocate ("C_a_i_sin" 4) p) ) ) ) )
1049    (else (##core#inline_allocate ("C_a_i_exp" 4) (%exact->inexact n)) ) ))
1050
1051(define exp %exp)
1052
1053(define (%log n)
1054  (switchq (%check-number n)
1055    (NONE (bad-number 'log n))
1056    (COMP (make-complex (##core#inline_allocate ("C_a_i_log" 4) (%magnitude n)) (%angle n)))
1057    (else (##core#inline_allocate ("C_a_i_log" 4) (%exact->inexact n)) ) ) )
1058
1059(define log %log)
1060
1061(define %i (%make-complex 0 1))
1062(define %-i (%make-complex 0 -1))
1063(define %i2 (%make-complex 0 2))
1064
1065(define (%sin n)
1066  (switchq (%check-number n)
1067    (NONE (bad-number 'sin n))
1068    (COMP (let ((in (%* %i n)))
1069            (%/ (%- (%exp in) (%exp (%- 0 in))) %i2)))
1070    (else (##core#inline_allocate ("C_a_i_sin" 4) (%exact->inexact n)) ) ))
1071
1072(define sin %sin)
1073
1074(define (%cos n)
1075  (switchq (%check-number n)
1076    (NONE (bad-number 'cos n))
1077    (COMP (let ((in (%* %i n)))
1078            (%/ (%+ (%exp in) (%exp (%- 0 in))) 2) ) )
1079    (else (##core#inline_allocate ("C_a_i_cos" 4) (%exact->inexact n)) ) ) )
1080
1081(define cos %cos)
1082
1083(define (tan n)
1084  (switchq (%check-number n)
1085    (NONE (bad-number 'tan n))
1086    (COMP (%/ (%sin n) (%cos n)))
1087    (else (##core#inline_allocate ("C_a_i_tan" 4) (%exact->inexact n)) ) ))
1088
1089(define (%asin n)
1090  (switchq (%check-number n)
1091    (NONE (bad-number 'asin n))
1092    (COMP (%* %-i (%log (%+ (%* %i n) (%sqrt (%- 1 (%* n n)))))))
1093    (else (##core#inline_allocate ("C_a_i_asin" 4) (%exact->inexact n)) ) ))
1094
1095(define asin %asin)
1096
1097(define acos
1098  (let ((asin1 (##core#inline_allocate ("C_a_i_asin" 4) 1)))
1099    (lambda (n)
1100      (switchq (%check-number n)
1101        (NONE (bad-number 'asin n))
1102        (COMP (%- asin1 (%asin n)))
1103        (else (##core#inline_allocate ("C_a_i_acos" 4) (%exact->inexact n)) ) ) ) ) )
1104
1105(define (atan n #!optional b)
1106  (switchq (%check-number n)
1107    (NONE (bad-number 'atan n))
1108    (COMP (if b
1109              (bad-real 'atan n)
1110              (let ((in (%* %i n)))
1111                (%/ (%- (%log (%+ 1 in)) (%log (%- 1 in))) %i2) ) ) )
1112    (BIG (set! n (%big->flo n)))
1113    (RAT (set! n (%rat->flo n))) )
1114  (if b
1115      (##core#inline_allocate ("C_a_i_atan2" 4) n b)
1116      (##core#inline_allocate ("C_a_i_atan" 4) n) ) )
1117
1118(define (%sqrt n)
1119  (switchq (%check-number n)
1120    (NONE (bad-number 'sqrt n))
1121    (COMP (let ((p (%/ (%angle n) 2))
1122                (m (##core#inline_allocate ("C_a_i_sqrt" 4) (%magnitude n))) )
1123            (make-complex (%* m (%cos p)) (%* m (%sin p)) ) ) )
1124    (else
1125     (if (negative? n)
1126       (make-complex
1127        0.0
1128        (##core#inline_allocate ("C_a_i_sqrt" 4) (%exact->inexact (- n))))
1129       (##core#inline_allocate ("C_a_i_sqrt" 4) (%exact->inexact n)) ) )))
1130
1131(define sqrt %sqrt)
1132
1133(define (%power base e)
1134  (define (square x) (%* x x))
1135  (if (negative? e)
1136    (/ 1 (%power base (- e)))
1137    (let lp ((res 1) (e2 e))
1138      (cond
1139        ((zero? e2) res)
1140        ((even? e2) ; recursion is faster than iteration here
1141         (%* res (square (lp 1 (arithmetic-shift e2 -1)))))
1142        (else
1143         (lp (%* res base) (- e2 1)))))))
1144
1145(define (%fix-power base e)
1146  (define (square x) (%* x x))
1147  (if (negative? e)
1148    (/ 1 (%power base (- e)))
1149    (let lp ((res 1) (e2 e))
1150      (cond
1151        ((zero? e2) res)
1152        ((%fix-expt base e2) => (lambda (x) (%* res x)))
1153        ((even? e2) ; recursion is faster than iteration here
1154         (%* res (square (lp 1 (arithmetic-shift e2 -1)))))
1155        (else
1156         (lp (%* res base) (- e2 1)))))))
1157
1158(define (%fix-expt base e)
1159  (let ((res (%%expt-0 base e)))
1160    (if (fixnum? res) res #f)))
1161
1162(define (expt a b)
1163  (define (fallback a b)
1164    (%exp (%* b (%log a))))
1165  (let ((ta (%check-number a))
1166        (tb (%check-number b)) )
1167    (cond ((eq? NONE ta) (bad-number 'expt a))
1168          ((eq? NONE tb) (bad-number 'expt b))
1169          ((eq? FLO ta)
1170           (switchq tb
1171             (FIX (%expt-0 a b))
1172             (FLO (%expt-0 a b))
1173             (BIG (%expt-0 a (%big->flo b)))
1174             (RAT (%expt-0 a (%rat->flo b)))
1175             (else (fallback a b)) ) )
1176          ((eq? FLO tb)
1177           (switchq ta
1178             (FIX (%expt-0 a b))
1179             (FLO (%expt-0 a b))
1180             (BIG (%expt-0 (%big->flo a) b))
1181             (RAT (%expt-0 (%rat->flo a) b))
1182             (else (fallback a b)) ) )
1183          ((and (eq? FIX ta) (eq? FIX tb)) (%fix-power a b))
1184          ((or (eq? COMP ta) (eq? COMP tb)) (fallback a b))
1185          ;; this doesn't work that well, yet...
1186          (else (%power a b)) ) ) )
1187
1188(define (conj n)
1189  (switchq (%check-number n)
1190    (NONE (bad-number 'conj n))
1191    (COMP (make-complex (complex-real n) (%- 0 (complex-imag n))))
1192    (else n) ) )
1193
1194(define (add1 n) (%+ n 1))
1195(define (sub1 n) (%- n 1))
1196
1197(define (signum n)
1198  (switchq (%check-number n)
1199    (FIX (cond ((eq? 0 n) 0)
1200               ((fx< n 0) -1)
1201               (else 1) ) )
1202    (FLO (cond ((fp= n 0.0) 0.0)
1203               ((fp< n 0.0) -1.0)
1204               (else 1.0) ) )
1205    (COMP (bad-complex/o 'signum n))
1206    (NONE (bad-number 'signum n))
1207    (else (cond ((%< n 0 'signum) -1)
1208                ((%> n 0 'signum) 1)
1209                (else 0) ) ) ) )
1210
1211(define (%->integer loc n)
1212  (switchq (%check-number n)
1213    (FIX n)
1214    (FLO (if (%integer? n)
1215             (%flo->big n)
1216             (bad-integer loc n)))
1217    (BIG n)
1218    (else (bad-integer loc n)) ) )
1219
1220(define (numbers:bitwise-and . xs)
1221  (let loop ((x -1) (xs xs))
1222    (if (null? xs)
1223        x
1224        (let ((xi (##sys#slot xs 0)))
1225          (loop
1226           (%int-and-int x (%->integer 'bitwise-and xi))
1227           (##sys#slot xs 1) ) ) ) ) )
1228
1229(define (numbers:bitwise-ior . xs)
1230  (let loop ((x 0) (xs xs))
1231    (if (null? xs)
1232        x
1233        (let ((xi (##sys#slot xs 0)))
1234          (loop
1235           (%int-ior-int x (%->integer 'bitwise-ior xi))
1236           (##sys#slot xs 1) ) ) ) ) )
1237
1238(define (numbers:bitwise-xor . xs)
1239  (let loop ((x 0) (xs xs))
1240    (if (null? xs)
1241        x
1242        (let ((xi (##sys#slot xs 0)))
1243          (loop
1244           (%int-xor-int x (%->integer 'bitwise-xor xi))
1245           (##sys#slot xs 1) ) ) ) ) )
1246
1247(define (numbers:bitwise-not n)
1248  (%int-not (%->integer 'bitwise-not n)) )
1249
1250(define bitwise-and numbers:bitwise-and)
1251(define bitwise-ior numbers:bitwise-ior)
1252(define bitwise-xor numbers:bitwise-xor)
1253(define bitwise-not numbers:bitwise-not)
1254
1255(define (arithmetic-shift n m)
1256  (%int-shift (%->integer 'arithmetic-shift n) (%->integer 'arithmetic-shift m)) )
1257
1258(define %number->string
1259  (let ((string-append string-append))
1260    (lambda (n #!optional (base 10))
1261      (unless (memq base '(2 8 10 16)) (bad-base 'number->string base))
1262      (let numstr ((n n))
1263        (switchq (%check-number n)
1264          (FIX (number->string-0 n base))
1265          (FLO (number->string-0 n base))
1266          (BIG (%big->string n base))
1267          (RAT (%rat->string n base))
1268          (COMP (let ((r (complex-real n))
1269                      (i (complex-imag n)) )
1270                  (string-append (numstr r) (if (%> i 0 'number->string) "+" "") (numstr i) "i") ) )
1271          (else (bad-number 'number->string n)) ) ) ) ) )
1272
1273(define number->string %number->string)
1274(define ##sys#number->string %number->string) ; for printer
1275
1276(define %string->number
1277  (let ((copy string-copy)
1278        (string-match-positions string-match-positions)
1279        (rxp (regexp "([-+0-9A-Fa-f#./]+)@([-+0-9A-Fa-f#./]+)"))
1280        (rxr0 (regexp "([-+][-+0-9A-Fa-f#./]+)i"))
1281        (rxr (regexp "([-+0-9A-Fa-f#./]+)([-+][-+0-9A-Fa-f#./]*)i")) )
1282    (lambda (str #!optional (base 10))
1283      (##sys#check-string str 'string->number)
1284      (##sys#check-exact base 'string->number)
1285      (let ((e 0)
1286            (str (copy str)) 
1287            (len (##sys#size str)) )
1288        (define (real str start end)
1289          (let ((rat #f))
1290            (let loop ((i start))
1291              (if (fx>= i end)
1292                  (if rat
1293                      (%string->rat (##sys#make-c-string (##sys#substring str start end)) base)
1294                      (%string->big (##sys#make-c-string (##sys#substring str start end)) base) )
1295                  (let ((c (%subchar str i)))
1296                    (case c
1297                      ((#\#)
1298                       (set! e #f)
1299                       (##core#inline "C_setsubchar" str i #\0) 
1300                       (loop (fx+ i 1)) )
1301                      ((#\.) (string->number-0 (##sys#substring str start end) base))
1302                      ((#\+ #\-)
1303                       (if (fx> i start)
1304                           (string->number-0 (##sys#substring str start end) base)
1305                           (loop (fx+ i 1)) ) )
1306                      ((#\e #\E) 
1307                       (if (eq? base 16)
1308                           (loop (fx+ i 1))
1309                           (string->number-0 (##sys#substring str start end) base) ) )
1310                      ((#\/) 
1311                       (set! rat i)
1312                       (loop (fx+ i 1)) )
1313                      (else (loop (fx+ i 1))) ) ) ) ) ) )
1314        (define (fin n)
1315          (and n
1316               (cond ((eq? e 0) n)
1317                     (e (%inexact->exact n))
1318                     (else (%exact->inexact n)) ) ) )
1319        (if (string=? "#" str)
1320            0.0
1321            (and (fx> len 0)
1322                 (let ((start
1323                        (let loop ((i 0))
1324                          (if (fx< i len)
1325                              (let ((c (%subchar str i)))
1326                                (if (eq? c #\#)
1327                                    (let* ((i (fx+ i 1))
1328                                           (c (%subchar str i)) )
1329                                      (case c
1330                                        ((#\e)
1331                                         (set! e #t)
1332                                         (loop (fx+ i 1)) )
1333                                        ((#\i)
1334                                         (set! e #f)
1335                                         (loop (fx+ i 1)) )
1336                                        ((#\x)
1337                                         (set! base 16)
1338                                         (loop (fx+ i 1)) )
1339                                        ((#\d)
1340                                         (set! base 10)
1341                                         (loop (fx+ i 1)) )
1342                                        ((#\o)
1343                                         (set! base 8)
1344                                         (loop (fx+ i 1)) )
1345                                        ((#\b)
1346                                         (set! base 2)
1347                                         (loop (fx+ i 1)) )
1348                                        (else (fx- i 1)) ) )
1349                                    i) )
1350                              i) ) ) )
1351                   (let ((sub (##sys#substring str start len)))
1352                     (cond ((string=? sub "+i") (fin (make-complex 0 1)))
1353                           ((string=? sub "-i") (fin (make-complex 0 -1)))
1354                           (else
1355                            (let ((m (string-match-positions rxp sub)))
1356                              (if (and m (= 3 (length m))
1357                                       (pair? (cadr m))
1358                                       (pair? (caddr m)))
1359                                  (and-let* ((a (real sub (caadr m) (cadadr m)))
1360                                             (b (real sub (caaddr m) (cadadr (cdr m)))))
1361                                    (fin (%make-polar a b) ) ) 
1362                                  (let* ((m (string-match-positions rxr sub))
1363                                         (lm (and m (length m))))
1364                                    (cond ((and lm (= 3 lm)
1365                                                (pair? (cadr m))
1366                                                (not (caddr m)))
1367                                           (and-let* ((a (real sub (caadr m) (cadadr m))))
1368                                             (fin (make-complex 0 a)) ) )
1369                                          ((and lm (= 3 lm) 
1370                                                (pair? (cadr m))
1371                                                (pair? (caddr m)))
1372                                           (let ((r1 (caadr m))
1373                                                 (r2 (cadadr m))
1374                                                 (i1 (caaddr m))
1375                                                 (i2 (cadadr (cdr m))))
1376                                             (and-let* ((rp (real sub r1 r2))
1377                                                        (ip (if (eq? i2 (fx+ i1 1))
1378                                                                (case (%subchar sub i1)
1379                                                                  ((#\-) -1)
1380                                                                  ((#\+) 1)
1381                                                                  (else #f) )
1382                                                                (real sub i1 i2))))
1383                                               (fin (make-complex rp ip)) ) ) )
1384                                          (else
1385                                           (let ((m (string-match-positions rxr0 sub)))
1386                                             (if (and m (pair? (cdr m)) (pair? (cadr m)))
1387                                                 (fin (make-complex 0 (real sub (caadr m) (cadadr m))))
1388                                                 (fin (or (real str start len)
1389                                                          (string->number-0 str) )) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) )
1390
1391(define (randomize #!optional (seed (##sys#fudge 2)))
1392  (switchq (%check-number seed)
1393    (FIX (%fix-randomize seed))
1394    (BIG (%big-randomize seed))
1395    (else (bad-integer 'randomize seed)) ) )
1396
1397(define (random n)
1398  (switchq (%check-number n)
1399    (FIX (%fix-random n))
1400    (BIG (%big-random n))
1401    (else (bad-integer 'random n)) ) )
1402
1403(define string->number %string->number)
1404(define ##sys#string->number %string->number) ; for reader
1405
1406
1407;;; Non-standard type procedures
1408
1409(define (bignum? x)
1410  (switchq (%check-number x)
1411    (BIG #t)
1412    (else #f) ) )
1413
1414(define (ratnum? x)
1415  (switchq (%check-number x)
1416    (RAT #t)
1417    (else #f) ) )
1418
1419(define (cflonum? x)
1420  (switchq (%check-number x)
1421    (FLO #t)
1422    (COMP (%inexact? x))
1423    (else #f) ) )
1424
1425(define (rectnum? x)
1426  (switchq (%check-number x)
1427    (COMP (%exact? x))
1428    (else #f) ) )
1429
1430(define (compnum? x)
1431  (switchq (%check-number x)
1432    (COMP (%inexact? x))
1433    (else #f) ) )
1434
1435;;; What we provide
1436
1437(register-feature! #:full-numeric-tower)
1438
1439)
Note: See TracBrowser for help on using the repository browser.