| blob | 39ec0195d3b0c95ff8b31ccb041bb5282972f40f |
1 ;;;============================================================================
3 ;;; File: "_num.scm", Time-stamp: <2009-11-26 16:15:21 feeley>
5 ;;; Copyright (c) 1994-2009 by Marc Feeley, All Rights Reserved.
6 ;;; Copyright (c) 2004-2009 by Brad Lucier, All Rights Reserved.
8 ;;;============================================================================
10 (##include "header.scm")
11 (c-declare "#include \"mem.h\"")
12 (##define-macro (use-fast-bignum-algorithms) #t)
14 ;;;============================================================================
16 ;;; Implementation of exceptions.
18 (implement-library-type-range-exception)
20 (define-prim (##raise-range-exception arg-num proc . args)
21 (##extract-procedure-and-arguments
22 proc
23 args
24 arg-num
25 #f
26 #f
27 (lambda (procedure arguments arg-num dummy1 dummy2)
28 (macro-raise
29 (macro-make-range-exception procedure arguments arg-num)))))
31 (implement-library-type-divide-by-zero-exception)
33 (define-prim (##raise-divide-by-zero-exception proc . args)
34 (##extract-procedure-and-arguments
35 proc
36 args
37 #f
38 #f
39 #f
40 (lambda (procedure arguments dummy1 dummy2 dummy3)
41 (macro-raise
42 (macro-make-divide-by-zero-exception procedure arguments)))))
44 (implement-library-type-fixnum-overflow-exception)
46 (define-prim (##raise-fixnum-overflow-exception proc . args)
47 (##extract-procedure-and-arguments
48 proc
49 args
50 #f
51 #f
52 #f
53 (lambda (procedure arguments dummy1 dummy2 dummy3)
54 (macro-raise
55 (macro-make-fixnum-overflow-exception procedure arguments)))))
57 ;;;----------------------------------------------------------------------------
59 ;;; Define type checking procedures.
61 (define-fail-check-type exact-signed-int8 'exact-signed-int8)
62 (define-fail-check-type exact-signed-int8-list 'exact-signed-int8-list)
63 (define-fail-check-type exact-unsigned-int8 'exact-unsigned-int8)
64 (define-fail-check-type exact-unsigned-int8-list 'exact-unsigned-int8-list)
65 (define-fail-check-type exact-signed-int16 'exact-signed-int16)
66 (define-fail-check-type exact-signed-int16-list 'exact-signed-int16-list)
67 (define-fail-check-type exact-unsigned-int16 'exact-unsigned-int16)
68 (define-fail-check-type exact-unsigned-int16-list 'exact-unsigned-int16-list)
69 (define-fail-check-type exact-signed-int32 'exact-signed-int32)
70 (define-fail-check-type exact-signed-int32-list 'exact-signed-int32-list)
71 (define-fail-check-type exact-unsigned-int32 'exact-unsigned-int32)
72 (define-fail-check-type exact-unsigned-int32-list 'exact-unsigned-int32-list)
73 (define-fail-check-type exact-signed-int64 'exact-signed-int64)
74 (define-fail-check-type exact-signed-int64-list 'exact-signed-int64-list)
75 (define-fail-check-type exact-unsigned-int64 'exact-unsigned-int64)
76 (define-fail-check-type exact-unsigned-int64-list 'exact-unsigned-int64-list)
77 (define-fail-check-type inexact-real 'inexact-real)
78 (define-fail-check-type inexact-real-list 'inexact-real-list)
79 (define-fail-check-type number 'number)
80 (define-fail-check-type real 'real)
81 (define-fail-check-type finite-real 'finite-real)
82 (define-fail-check-type rational 'rational)
83 (define-fail-check-type integer 'integer)
84 (define-fail-check-type exact-integer 'exact-integer)
85 (define-fail-check-type fixnum 'fixnum)
86 (define-fail-check-type flonum 'flonum)
88 ;;;----------------------------------------------------------------------------
90 ;;; Numerical type predicates.
92 (define-prim (##number? x)
93 (##complex? x))
95 (define-prim (##complex? x)
96 (macro-number-dispatch x #f
97 #t ;; x = fixnum
98 #t ;; x = bignum
99 #t ;; x = ratnum
100 #t ;; x = flonum
101 #t)) ;; x = cpxnum
103 (define-prim (number? x)
104 (macro-force-vars (x)
105 (##number? x)))
107 (define-prim (complex? x)
108 (macro-force-vars (x)
109 (##complex? x)))
111 (define-prim (##real? x)
112 (macro-number-dispatch x #f
113 #t ;; x = fixnum
114 #t ;; x = bignum
115 #t ;; x = ratnum
116 #t ;; x = flonum
117 (macro-cpxnum-real? x))) ;; x = cpxnum
119 (define-prim (real? x)
120 (macro-force-vars (x)
121 (##real? x)))
123 (define-prim (##rational? x)
124 (macro-number-dispatch x #f
125 #t ;; x = fixnum
126 #t ;; x = bignum
127 #t ;; x = ratnum
128 (macro-flonum-rational? x) ;; x = flonum
129 (macro-cpxnum-rational? x))) ;; x = cpxnum
131 (define-prim (rational? x)
132 (macro-force-vars (x)
133 (##rational? x)))
135 (define-prim (##integer? x)
136 (macro-number-dispatch x #f
137 #t ;; x = fixnum
138 #t ;; x = bignum
139 #f ;; x = ratnum
140 (macro-flonum-int? x) ;; x = flonum
141 (macro-cpxnum-int? x))) ;; x = cpxnum
143 (define-prim (integer? x)
144 (macro-force-vars (x)
145 (##integer? x)))
147 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
149 ;;; Exactness predicates.
151 (define-prim (##exact? x)
153 (define (type-error) #f)
155 (macro-number-dispatch x (type-error)
156 #t ;; x = fixnum
157 #t ;; x = bignum
158 #t ;; x = ratnum
159 #f ;; x = flonum
160 (and (##not (##flonum? (macro-cpxnum-real x))) ;; x = cpxnum
161 (##not (##flonum? (macro-cpxnum-imag x))))))
163 (define-prim (exact? x)
164 (macro-force-vars (x)
165 (let ()
167 (define (type-error)
168 (##fail-check-number 1 exact? x))
170 (macro-number-dispatch x (type-error)
171 #t ;; x = fixnum
172 #t ;; x = bignum
173 #t ;; x = ratnum
174 #f ;; x = flonum
175 (and (##not (##flonum? (macro-cpxnum-real x))) ;; x = cpxnum
176 (##not (##flonum? (macro-cpxnum-imag x))))))))
178 (define-prim (##inexact? x)
180 (define (type-error) #f)
182 (macro-number-dispatch x (type-error)
183 #f ;; x = fixnum
184 #f ;; x = bignum
185 #f ;; x = ratnum
186 #t ;; x = flonum
187 (or (##flonum? (macro-cpxnum-real x)) ;; x = cpxnum
188 (##flonum? (macro-cpxnum-imag x)))))
190 (define-prim (inexact? x)
191 (macro-force-vars (x)
192 (let ()
194 (define (type-error)
195 (##fail-check-number 1 inexact? x))
197 (macro-number-dispatch x (type-error)
198 #f ;; x = fixnum
199 #f ;; x = bignum
200 #f ;; x = ratnum
201 #t ;; x = flonum
202 (or (##flonum? (macro-cpxnum-real x)) ;; x = cpxnum
203 (##flonum? (macro-cpxnum-imag x)))))))
205 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
207 ;;; Comparison predicates.
209 (define-prim (##= x y)
211 (##define-macro (type-error-on-x) `'(1))
212 (##define-macro (type-error-on-y) `'(2))
214 (macro-number-dispatch x (type-error-on-x)
216 (macro-number-dispatch y (type-error-on-y) ;; x = fixnum
217 (##fixnum.= x y)
218 #f
219 #f
220 (if (##flonum.<-fixnum-exact? x)
221 (##flonum.= (##flonum.<-fixnum x) y)
222 (and (##flonum.finite? y)
223 (##ratnum.= (##ratnum.<-exact-int x) (##flonum.->ratnum y))))
224 (##cpxnum.= (##cpxnum.<-noncpxnum x) y))
226 (macro-number-dispatch y (type-error-on-y) ;; x = bignum
227 #f
228 (or (##eq? x y)
229 (##bignum.= x y))
230 #f
231 (and (##flonum.finite? y)
232 (##ratnum.= (##ratnum.<-exact-int x) (##flonum.->ratnum y)))
233 (##cpxnum.= (##cpxnum.<-noncpxnum x) y))
235 (macro-number-dispatch y (type-error-on-y) ;; x = ratnum
236 #f
237 #f
238 (or (##eq? x y)
239 (##ratnum.= x y))
240 (and (##flonum.finite? y)
241 (##ratnum.= x (##flonum.->ratnum y)))
242 (##cpxnum.= (##cpxnum.<-noncpxnum x) y))
244 (macro-number-dispatch y (type-error-on-y) ;; x = flonum
245 (if (##flonum.<-fixnum-exact? y)
246 (##flonum.= x (##flonum.<-fixnum y))
247 (and (##flonum.finite? x)
248 (##ratnum.= (##flonum.->ratnum x) (##ratnum.<-exact-int y))))
249 (and (##flonum.finite? x)
250 (##ratnum.= (##flonum.->ratnum x) (##ratnum.<-exact-int y)))
251 (and (##flonum.finite? x)
252 (##ratnum.= (##flonum.->ratnum x) y))
253 (##flonum.= x y)
254 (##cpxnum.= (##cpxnum.<-noncpxnum x) y))
256 (macro-number-dispatch y (type-error-on-y) ;; x = cpxnum
257 (##cpxnum.= x (##cpxnum.<-noncpxnum y))
258 (##cpxnum.= x (##cpxnum.<-noncpxnum y))
259 (##cpxnum.= x (##cpxnum.<-noncpxnum y))
260 (##cpxnum.= x (##cpxnum.<-noncpxnum y))
261 (##cpxnum.= x y))))
263 (define-prim-nary-bool (= x y)
264 #t
265 (if (##number? x) #t '(1))
266 (##= x y)
267 macro-force-vars
268 macro-no-check
269 (##pair? ##fail-check-number))
271 (define-prim (##< x y #!optional (nan-result #f))
273 (##define-macro (type-error-on-x) `'(1))
274 (##define-macro (type-error-on-y) `'(2))
276 (macro-number-dispatch x (type-error-on-x)
278 (macro-number-dispatch y (type-error-on-y) ;; x = fixnum
279 (##fixnum.< x y)
280 (##not (##bignum.negative? y))
281 (##ratnum.< (##ratnum.<-exact-int x) y)
282 (cond ((##flonum.finite? y)
283 (if (##flonum.<-fixnum-exact? x)
284 (##flonum.< (##flonum.<-fixnum x) y)
285 (##ratnum.< (##ratnum.<-exact-int x) (##flonum.->ratnum y))))
286 ((##flonum.nan? y)
287 nan-result)
288 (else
289 (##flonum.positive? y)))
290 (if (macro-cpxnum-real? y)
291 (##< x (macro-cpxnum-real y) nan-result)
292 (type-error-on-y)))
294 (macro-number-dispatch y (type-error-on-y) ;; x = bignum
295 (##bignum.negative? x)
296 (##bignum.< x y)
297 (##ratnum.< (##ratnum.<-exact-int x) y)
298 (cond ((##flonum.finite? y)
299 (##ratnum.< (##ratnum.<-exact-int x) (##flonum.->ratnum y)))
300 ((##flonum.nan? y)
301 nan-result)
302 (else
303 (##flonum.positive? y)))
304 (if (macro-cpxnum-real? y)
305 (##< x (macro-cpxnum-real y) nan-result)
306 (type-error-on-y)))
308 (macro-number-dispatch y (type-error-on-y) ;; x = ratnum
309 (##ratnum.< x (##ratnum.<-exact-int y))
310 (##ratnum.< x (##ratnum.<-exact-int y))
311 (##ratnum.< x y)
312 (cond ((##flonum.finite? y)
313 (##ratnum.< x (##flonum.->ratnum y)))
314 ((##flonum.nan? y)
315 nan-result)
316 (else
317 (##flonum.positive? y)))
318 (if (macro-cpxnum-real? y)
319 (##< x (macro-cpxnum-real y) nan-result)
320 (type-error-on-y)))
322 (macro-number-dispatch y (type-error-on-y) ;; x = flonum
323 (cond ((##flonum.finite? x)
324 (if (##flonum.<-fixnum-exact? y)
325 (##flonum.< x (##flonum.<-fixnum y))
326 (##ratnum.< (##flonum.->ratnum x) (##ratnum.<-exact-int y))))
327 ((##flonum.nan? x)
328 nan-result)
329 (else
330 (##flonum.negative? x)))
331 (cond ((##flonum.finite? x)
332 (##ratnum.< (##flonum.->ratnum x) (##ratnum.<-exact-int y)))
333 ((##flonum.nan? x)
334 nan-result)
335 (else
336 (##flonum.negative? x)))
337 (cond ((##flonum.finite? x)
338 (##ratnum.< (##flonum.->ratnum x) y))
339 ((##flonum.nan? x)
340 nan-result)
341 (else
342 (##flonum.negative? x)))
343 (if (or (##flonum.nan? x) (##flonum.nan? y))
344 nan-result
345 (##flonum.< x y))
346 (if (macro-cpxnum-real? y)
347 (##< x (macro-cpxnum-real y) nan-result)
348 (type-error-on-y)))
350 (if (macro-cpxnum-real? x) ;; x = cpxnum
351 (macro-number-dispatch y (type-error-on-y)
352 (##< (macro-cpxnum-real x) y nan-result)
353 (##< (macro-cpxnum-real x) y nan-result)
354 (##< (macro-cpxnum-real x) y nan-result)
355 (##< (macro-cpxnum-real x) y nan-result)
356 (if (macro-cpxnum-real? y)
357 (##< (macro-cpxnum-real x) (macro-cpxnum-real y) nan-result)
358 (type-error-on-y)))
359 (type-error-on-x))))
361 (define-prim-nary-bool (< x y)
362 #t
363 (if (##real? x) #t '(1))
364 (##< x y #f)
365 macro-force-vars
366 macro-no-check
367 (##pair? ##fail-check-real))
369 (define-prim-nary-bool (> x y)
370 #t
371 (if (##real? x) #t '(1))
372 (##< y x #f)
373 macro-force-vars
374 macro-no-check
375 (##pair? ##fail-check-real))
377 (define-prim-nary-bool (<= x y)
378 #t
379 (if (##real? x) #t '(1))
380 (##not (##< y x #t))
381 macro-force-vars
382 macro-no-check
383 (##pair? ##fail-check-real))
385 (define-prim-nary-bool (>= x y)
386 #t
387 (if (##real? x) #t '(1))
388 (##not (##< x y #t))
389 macro-force-vars
390 macro-no-check
391 (##pair? ##fail-check-real))
393 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
395 ;;; Numerical property predicates.
397 (define-prim (##zero? x)
399 (define (type-error)
400 (##fail-check-number 1 zero? x))
402 (macro-number-dispatch x (type-error)
403 (##fixnum.zero? x)
404 #f
405 #f
406 (##flonum.zero? x)
407 (and (let ((imag (macro-cpxnum-imag x)))
408 (and (##flonum? imag) (##flonum.zero? imag)))
409 (let ((real (macro-cpxnum-real x)))
410 (if (##fixnum? real)
411 (##fixnum.zero? real)
412 (and (##flonum? real) (##flonum.zero? real)))))))
414 (define-prim (zero? x)
415 (macro-force-vars (x)
416 (##zero? x)))
418 (define-prim (##positive? x)
420 (define (type-error)
421 (##fail-check-real 1 positive? x))
423 (macro-number-dispatch x (type-error)
424 (##fixnum.positive? x)
425 (##not (##bignum.negative? x))
426 (##positive? (macro-ratnum-numerator x))
427 (##flonum.positive? x)
428 (if (macro-cpxnum-real? x)
429 (##positive? (macro-cpxnum-real x))
430 (type-error))))
432 (define-prim (positive? x)
433 (macro-force-vars (x)
434 (##positive? x)))
436 (define-prim (##negative? x)
438 (define (type-error)
439 (##fail-check-real 1 negative? x))
441 (macro-number-dispatch x (type-error)
442 (##fixnum.negative? x)
443 (##bignum.negative? x)
444 (##negative? (macro-ratnum-numerator x))
445 (##flonum.negative? x)
446 (if (macro-cpxnum-real? x)
447 (##negative? (macro-cpxnum-real x))
448 (type-error))))
450 (define-prim (negative? x)
451 (macro-force-vars (x)
452 (##negative? x)))
454 (define-prim (##odd? x)
456 (define (type-error)
457 (##fail-check-integer 1 odd? x))
459 (macro-number-dispatch x (type-error)
460 (##fixnum.odd? x)
461 (macro-bignum-odd? x)
462 (type-error)
463 (if (macro-flonum-int? x)
464 (##odd? (##flonum.->exact-int x))
465 (type-error))
466 (if (macro-cpxnum-int? x)
467 (##odd? (##inexact->exact (macro-cpxnum-real x)))
468 (type-error))))
470 (define-prim (odd? x)
471 (macro-force-vars (x)
472 (##odd? x)))
474 (define-prim (##even? x)
476 (define (type-error)
477 (##fail-check-integer 1 even? x))
479 (macro-number-dispatch x (type-error)
480 (##not (##fixnum.odd? x))
481 (##not (macro-bignum-odd? x))
482 (type-error)
483 (if (macro-flonum-int? x)
484 (##even? (##flonum.->exact-int x))
485 (type-error))
486 (if (macro-cpxnum-int? x)
487 (##even? (##inexact->exact (macro-cpxnum-real x)))
488 (type-error))))
490 (define-prim (even? x)
491 (macro-force-vars (x)
492 (##even? x)))
494 (define-prim (##finite? x)
496 (define (type-error)
497 (##fail-check-real 1 finite? x))
499 (macro-number-dispatch x (type-error)
500 #t
501 #t
502 #t
503 (##flfinite? x)
504 (if (macro-cpxnum-real? x)
505 (let ((real (macro-cpxnum-real x)))
506 (or (##not (##flonum? real))
507 (##flfinite? real)))
508 (type-error))))
510 (define-prim (finite? x)
511 (macro-force-vars (x)
512 (##finite? x)))
514 (define-prim (##infinite? x)
516 (define (type-error)
517 (##fail-check-real 1 infinite? x))
519 (macro-number-dispatch x (type-error)
520 #f
521 #f
522 #f
523 (##flinfinite? x)
524 (if (macro-cpxnum-real? x)
525 (let ((real (macro-cpxnum-real x)))
526 (and (##flonum? real)
527 (##flinfinite? real)))
528 (type-error))))
530 (define-prim (infinite? x)
531 (macro-force-vars (x)
532 (##infinite? x)))
534 (define-prim (##nan? x)
536 (define (type-error)
537 (##fail-check-real 1 nan? x))
539 (macro-number-dispatch x (type-error)
540 #f
541 #f
542 #f
543 (##flnan? x)
544 (if (macro-cpxnum-real? x)
545 (let ((real (macro-cpxnum-real x)))
546 (and (##flonum? real)
547 (##flnan? real)))
548 (type-error))))
550 (define-prim (nan? x)
551 (macro-force-vars (x)
552 (##nan? x)))
554 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
556 ;;; Max and min.
558 (define-prim (##max x y)
560 (##define-macro (type-error-on-x) `'(1))
561 (##define-macro (type-error-on-y) `'(2))
563 (macro-number-dispatch x (type-error-on-x)
565 (macro-number-dispatch y (type-error-on-y) ;; x = fixnum
566 (##fixnum.max x y)
567 (if (##< x y) y x)
568 (if (##< x y) y x)
569 (##flonum.max (##flonum.<-fixnum x) y)
570 (if (macro-cpxnum-real? y)
571 (##max x (macro-cpxnum-real y))
572 (type-error-on-y)))
574 (macro-number-dispatch y (type-error-on-y) ;; x = bignum
575 (if (##< x y) y x)
576 (if (##< x y) y x)
577 (if (##< x y) y x)
578 (##flonum.max (##flonum.<-exact-int x) y)
579 (if (macro-cpxnum-real? y)
580 (##max x (macro-cpxnum-real y))
581 (type-error-on-y)))
583 (macro-number-dispatch y (type-error-on-y) ;; x = ratnum
584 (if (##< x y) y x)
585 (if (##< x y) y x)
586 (if (##< x y) y x)
587 (##flonum.max (##flonum.<-ratnum x) y)
588 (if (macro-cpxnum-real? y)
589 (##max x (macro-cpxnum-real y))
590 (type-error-on-y)))
592 (macro-number-dispatch y (type-error-on-y) ;; x = flonum
593 (##flonum.max x (##flonum.<-fixnum y))
594 (##flonum.max x (##flonum.<-exact-int y))
595 (##flonum.max x (##flonum.<-ratnum y))
596 (##flonum.max x y)
597 (if (macro-cpxnum-real? y)
598 (##max x (macro-cpxnum-real y))
599 (type-error-on-y)))
601 (if (macro-cpxnum-real? x) ;; x = cpxnum
602 (macro-number-dispatch y (type-error-on-y)
603 (##max (macro-cpxnum-real x) y)
604 (##max (macro-cpxnum-real x) y)
605 (##max (macro-cpxnum-real x) y)
606 (##max (macro-cpxnum-real x) y)
607 (if (macro-cpxnum-real? y)
608 (##max (macro-cpxnum-real x) (macro-cpxnum-real y))
609 (type-error-on-y)))
610 (type-error-on-x))))
612 (define-prim-nary (max x y)
613 ()
614 (if (##real? x) x '(1))
615 (##max x y)
616 macro-force-vars
617 macro-no-check
618 (##pair? ##fail-check-real))
620 (define-prim (##min x y)
622 (##define-macro (type-error-on-x) `'(1))
623 (##define-macro (type-error-on-y) `'(2))
625 (macro-number-dispatch x (type-error-on-x)
627 (macro-number-dispatch y (type-error-on-y) ;; x = fixnum
628 (##fixnum.min x y)
629 (if (##< x y) x y)
630 (if (##< x y) x y)
631 (##flonum.min (##flonum.<-fixnum x) y)
632 (if (macro-cpxnum-real? y)
633 (##min x (macro-cpxnum-real y))
634 (type-error-on-y)))
636 (macro-number-dispatch y (type-error-on-y) ;; x = bignum
637 (if (##< x y) x y)
638 (if (##< x y) x y)
639 (if (##< x y) x y)
640 (##flonum.min (##flonum.<-exact-int x) y)
641 (if (macro-cpxnum-real? y)
642 (##min x (macro-cpxnum-real y))
643 (type-error-on-y)))
645 (macro-number-dispatch y (type-error-on-y) ;; x = ratnum
646 (if (##< x y) x y)
647 (if (##< x y) x y)
648 (if (##< x y) x y)
649 (##flonum.min (##flonum.<-ratnum x) y)
650 (if (macro-cpxnum-real? y)
651 (##min x (macro-cpxnum-real y))
652 (type-error-on-y)))
654 (macro-number-dispatch y (type-error-on-y) ;; x = flonum
655 (##flonum.min x (##flonum.<-fixnum y))
656 (##flonum.min x (##flonum.<-exact-int y))
657 (##flonum.min x (##flonum.<-ratnum y))
658 (##flonum.min x y)
659 (if (macro-cpxnum-real? y)
660 (##min x (macro-cpxnum-real y))
661 (type-error-on-y)))
663 (if (macro-cpxnum-real? x) ;; x = cpxnum
664 (macro-number-dispatch y (type-error-on-y)
665 (##min (macro-cpxnum-real x) y)
666 (##min (macro-cpxnum-real x) y)
667 (##min (macro-cpxnum-real x) y)
668 (##min (macro-cpxnum-real x) y)
669 (if (macro-cpxnum-real? y)
670 (##min (macro-cpxnum-real x) (macro-cpxnum-real y))
671 (type-error-on-y)))
672 (type-error-on-x))))
674 (define-prim-nary (min x y)
675 ()
676 (if (##real? x) x '(1))
677 (##min x y)
678 macro-force-vars
679 macro-no-check
680 (##pair? ##fail-check-real))
682 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
684 ;;; +, *, -, /
686 (define-prim (##+ x y)
688 (##define-macro (type-error-on-x) `'(1))
689 (##define-macro (type-error-on-y) `'(2))
691 (macro-number-dispatch x (type-error-on-x)
693 (macro-number-dispatch y (type-error-on-y) ;; x = fixnum
694 (or (##fixnum.+? x y)
695 (##bignum.+ (##bignum.<-fixnum x) (##bignum.<-fixnum y)))
696 (if (##fixnum.zero? x)
697 y
698 (##bignum.+ (##bignum.<-fixnum x) y))
699 (if (##fixnum.zero? x)
700 y
701 (##ratnum.+ (##ratnum.<-exact-int x) y))
702 (if (and (macro-special-case-exact-zero?) (##fixnum.zero? x))
703 y
704 (##flonum.+ (##flonum.<-fixnum x) y))
705 (##cpxnum.+ (##cpxnum.<-noncpxnum x) y))
707 (macro-number-dispatch y (type-error-on-y) ;; x = bignum
708 (if (##fixnum.zero? y)
709 x
710 (##bignum.+ x (##bignum.<-fixnum y)))
711 (##bignum.+ x y)
712 (##ratnum.+ (##ratnum.<-exact-int x) y)
713 (##flonum.+ (##flonum.<-exact-int x) y)
714 (##cpxnum.+ (##cpxnum.<-noncpxnum x) y))
716 (macro-number-dispatch y (type-error-on-y) ;; x = ratnum
717 (if (##fixnum.zero? y)
718 x
719 (##ratnum.+ x (##ratnum.<-exact-int y)))
720 (##ratnum.+ x (##ratnum.<-exact-int y))
721 (##ratnum.+ x y)
722 (##flonum.+ (##flonum.<-ratnum x) y)
723 (##cpxnum.+ (##cpxnum.<-noncpxnum x) y))
725 (macro-number-dispatch y (type-error-on-y) ;; x = flonum
726 (if (and (macro-special-case-exact-zero?) (##fixnum.zero? y))
727 x
728 (##flonum.+ x (##flonum.<-fixnum y)))
729 (##flonum.+ x (##flonum.<-exact-int y))
730 (##flonum.+ x (##flonum.<-ratnum y))
731 (##flonum.+ x y)
732 (##cpxnum.+ (##cpxnum.<-noncpxnum x) y))
734 (macro-number-dispatch y (type-error-on-y) ;; x = cpxnum
735 (##cpxnum.+ x (##cpxnum.<-noncpxnum y))
736 (##cpxnum.+ x (##cpxnum.<-noncpxnum y))
737 (##cpxnum.+ x (##cpxnum.<-noncpxnum y))
738 (##cpxnum.+ x (##cpxnum.<-noncpxnum y))
739 (##cpxnum.+ x y))))
741 (define-prim-nary (+ x y)
742 0
743 (if (##number? x) x '(1))
744 (##+ x y)
745 macro-force-vars
746 macro-no-check
747 (##pair? ##fail-check-number))
749 (define-prim (##* x y)
751 (##define-macro (type-error-on-x) `'(1))
752 (##define-macro (type-error-on-y) `'(2))
754 (macro-number-dispatch x (type-error-on-x)
756 (macro-number-dispatch y (type-error-on-y) ;; x = fixnum
757 (cond ((##fixnum.= y 0)
758 0)
759 ((if (##fixnum.= y -1)
760 (##fixnum.-? x)
761 (##fixnum.*? x y))
762 => (lambda (result) result))
763 (else
764 (##bignum.* (##bignum.<-fixnum x) (##bignum.<-fixnum y))))
765 (cond ((##fixnum.zero? x)
766 0)
767 ((##fixnum.= x 1)
768 y)
769 ((##fixnum.= x -1)
770 (##negate y))
771 (else
772 (##bignum.* (##bignum.<-fixnum x) y)))
773 (cond ((##fixnum.zero? x)
774 0)
775 ((##fixnum.= x 1)
776 y)
777 ((##fixnum.= x -1)
778 (##negate y))
779 (else
780 (##ratnum.* (##ratnum.<-exact-int x) y)))
781 (cond ((and (macro-special-case-exact-zero?)
782 (##fixnum.zero? x))
783 0)
784 ((##fixnum.= x 1)
785 y)
786 (else
787 (##flonum.* (##flonum.<-fixnum x) y)))
788 (cond ((and (macro-special-case-exact-zero?)
789 (##fixnum.zero? x))
790 0)
791 ((##fixnum.= x 1)
792 y)
793 (else
794 (##cpxnum.* (##cpxnum.<-noncpxnum x) y))))
796 (macro-number-dispatch y (type-error-on-y) ;; x = bignum
797 (cond ((##eq? y 0)
798 0)
799 ((##eq? y 1)
800 x)
801 ((##eq? y -1)
802 (##negate x))
803 (else
804 (##bignum.* x (##bignum.<-fixnum y))))
805 (##bignum.* x y)
806 (##ratnum.* (##ratnum.<-exact-int x) y)
807 (##flonum.* (##flonum.<-exact-int x) y)
808 (##cpxnum.* (##cpxnum.<-noncpxnum x) y))
810 (macro-number-dispatch y (type-error-on-y) ;; x = ratnum
811 (cond ((##fixnum.zero? y)
812 0)
813 ((##fixnum.= y 1)
814 x)
815 ((##fixnum.= y -1)
816 (##negate x))
817 (else
818 (##ratnum.* x (##ratnum.<-exact-int y))))
819 (##ratnum.* x (##ratnum.<-exact-int y))
820 (##ratnum.* x y)
821 (##flonum.* (##flonum.<-ratnum x) y)
822 (##cpxnum.* (##cpxnum.<-noncpxnum x) y))
824 (macro-number-dispatch y (type-error-on-y) ;; x = flonum
825 (cond ((and (macro-special-case-exact-zero?) (##fixnum.zero? y))
826 0)
827 ((##fixnum.= y 1)
828 x)
829 (else
830 (##flonum.* x (##flonum.<-fixnum y))))
831 (##flonum.* x (##flonum.<-exact-int y))
832 (##flonum.* x (##flonum.<-ratnum y))
833 (##flonum.* x y)
834 (##cpxnum.* (##cpxnum.<-noncpxnum x) y))
836 (macro-number-dispatch y (type-error-on-y) ;; x = cpxnum
837 (cond ((and (macro-special-case-exact-zero?) (##fixnum.zero? y))
838 0)
839 ((##fixnum.= y 1)
840 x)
841 (else
842 (##cpxnum.* x (##cpxnum.<-noncpxnum y))))
843 (##cpxnum.* x (##cpxnum.<-noncpxnum y))
844 (##cpxnum.* x (##cpxnum.<-noncpxnum y))
845 (##cpxnum.* x (##cpxnum.<-noncpxnum y))
846 (##cpxnum.* x y))))
848 (define-prim-nary (* x y)
849 1
850 (if (##number? x) x '(1))
851 (##* x y)
852 macro-force-vars
853 macro-no-check
854 (##pair? ##fail-check-number))
856 (define-prim (##negate x)
858 (##define-macro (type-error) `'(1))
860 (macro-number-dispatch x (type-error)
861 (or (##fixnum.-? x)
862 (##bignum.- (##bignum.<-fixnum 0) (##bignum.<-fixnum ##min-fixnum)))
863 (##bignum.- (##bignum.<-fixnum 0) x)
864 (macro-ratnum-make (##negate (macro-ratnum-numerator x))
865 (macro-ratnum-denominator x))
866 (##flonum.- x)
867 (##make-rectangular (##negate (macro-cpxnum-real x))
868 (##negate (macro-cpxnum-imag x)))))
870 (define-prim (##- x y)
872 (##define-macro (type-error-on-x) `'(1))
873 (##define-macro (type-error-on-y) `'(2))
875 (macro-number-dispatch x (type-error-on-x)
877 (macro-number-dispatch y (type-error-on-y) ;; x = fixnum
878 (or (##fixnum.-? x y)
879 (##bignum.- (##bignum.<-fixnum x) (##bignum.<-fixnum y)))
880 (##bignum.- (##bignum.<-fixnum x) y)
881 (if (##fixnum.zero? x)
882 (##negate y)
883 (##ratnum.- (##ratnum.<-exact-int x) y))
884 (if (and (macro-special-case-exact-zero?) (##fixnum.zero? x))
885 (##flonum.- y)
886 (##flonum.- (##flonum.<-fixnum x) y))
887 (##cpxnum.- (##cpxnum.<-noncpxnum x) y))
889 (macro-number-dispatch y (type-error-on-y) ;; x = bignum
890 (if (##fixnum.zero? y)
891 x
892 (##bignum.- x (##bignum.<-fixnum y)))
893 (##bignum.- x y)
894 (##ratnum.- (##ratnum.<-exact-int x) y)
895 (##flonum.- (##flonum.<-exact-int x) y)
896 (##cpxnum.- (##cpxnum.<-noncpxnum x) y))
898 (macro-number-dispatch y (type-error-on-y) ;; x = ratnum
899 (if (##fixnum.zero? y)
900 x
901 (##ratnum.- x (##ratnum.<-exact-int y)))
902 (##ratnum.- x (##ratnum.<-exact-int y))
903 (##ratnum.- x y)
904 (##flonum.- (##flonum.<-ratnum x) y)
905 (##cpxnum.- (##cpxnum.<-noncpxnum x) y))
907 (macro-number-dispatch y (type-error-on-y) ;; x = flonum
908 (if (and (macro-special-case-exact-zero?) (##fixnum.zero? y))
909 x
910 (##flonum.- x (##flonum.<-fixnum y)))
911 (##flonum.- x (##flonum.<-exact-int y))
912 (##flonum.- x (##flonum.<-ratnum y))
913 (##flonum.- x y)
914 (##cpxnum.- (##cpxnum.<-noncpxnum x) y))
916 (macro-number-dispatch y (type-error-on-y) ;; x = cpxnum
917 (##cpxnum.- x (##cpxnum.<-noncpxnum y))
918 (##cpxnum.- x (##cpxnum.<-noncpxnum y))
919 (##cpxnum.- x (##cpxnum.<-noncpxnum y))
920 (##cpxnum.- x (##cpxnum.<-noncpxnum y))
921 (##cpxnum.- x y))))
923 (define-prim-nary (- x y)
924 ()
925 (##negate x)
926 (##- x y)
927 macro-force-vars
928 macro-no-check
929 (##pair? ##fail-check-number))
931 (define-prim (##inverse x)
933 (##define-macro (type-error) `'(1))
935 (define (divide-by-zero-error) #f)
937 (macro-number-dispatch x (type-error)
938 (if (##fixnum.zero? x)
939 (divide-by-zero-error)
940 (if (##fixnum.negative? x)
941 (if (##fixnum.= x -1)
942 x
943 (macro-ratnum-make -1 (##negate x)))
944 (if (##fixnum.= x 1)
945 x
946 (macro-ratnum-make 1 x))))
947 (if (##bignum.negative? x)
948 (macro-ratnum-make -1 (##negate x))
949 (macro-ratnum-make 1 x))
950 (let ((num (macro-ratnum-numerator x))
951 (den (macro-ratnum-denominator x)))
952 (cond ((##eq? num 1)
953 den)
954 ((##eq? num -1)
955 (##negate den))
956 (else
957 (if (##negative? num)
958 (macro-ratnum-make (##negate den) (##negate num))
959 (macro-ratnum-make den num)))))
960 (##flonum./ (macro-inexact-+1) x)
961 (##cpxnum./ (##cpxnum.<-noncpxnum 1) x)))
963 (define-prim (##/ x y)
965 (##define-macro (type-error-on-x) `'(1))
966 (##define-macro (type-error-on-y) `'(2))
968 (define (divide-by-zero-error) #f)
970 (macro-number-dispatch y (type-error-on-y)
972 (macro-number-dispatch x (type-error-on-x) ;; y = fixnum
973 (cond ((##fixnum.zero? y)
974 (divide-by-zero-error))
975 ((##fixnum.= y 1)
976 x)
977 ((##fixnum.= y -1)
978 (##negate x))
979 ((##fixnum.zero? x)
980 0)
981 ((##fixnum.= x 1)
982 (##inverse y))
983 (else
984 (##ratnum./ (##ratnum.<-exact-int x) (##ratnum.<-exact-int y))))
985 (cond ((##fixnum.zero? y)
986 (divide-by-zero-error))
987 ((##fixnum.= y 1)
988 x)
989 ((##fixnum.= y -1)
990 (##negate x))
991 (else
992 (##ratnum./ (##ratnum.<-exact-int x) (##ratnum.<-exact-int y))))
993 (cond ((##fixnum.zero? y)
994 (divide-by-zero-error))
995 ((##fixnum.= y 1)
996 x)
997 ((##fixnum.= y -1)
998 (##negate x))
999 (else
1000 (##ratnum./ x (##ratnum.<-exact-int y))))
1001 (if (##fixnum.zero? y)
1002 (divide-by-zero-error)
1003 (##flonum./ x (##flonum.<-fixnum y)))
1004 (if (##fixnum.zero? y)
1005 (divide-by-zero-error)
1006 (##cpxnum./ x (##cpxnum.<-noncpxnum y))))
1008 (macro-number-dispatch x (type-error-on-x) ;; y = bignum
1009 (cond ((##fixnum.zero? x)
1010 0)
1011 ((##fixnum.= x 1)
1012 (##inverse y))
1013 (else
1014 (##ratnum./ (##ratnum.<-exact-int x) (##ratnum.<-exact-int y))))
1015 (##ratnum./ (##ratnum.<-exact-int x) (##ratnum.<-exact-int y))
1016 (##ratnum./ x (##ratnum.<-exact-int y))
1017 (##flonum./ x (##flonum.<-exact-int y))
1018 (##cpxnum./ x (##cpxnum.<-noncpxnum y)))
1020 (macro-number-dispatch x (type-error-on-x) ;; y = ratnum
1021 (cond ((##fixnum.zero? x)
1022 0)
1023 ((##fixnum.= x 1)
1024 (##inverse y))
1025 (else
1026 (##ratnum./ (##ratnum.<-exact-int x) y)))
1027 (##ratnum./ (##ratnum.<-exact-int x) y)
1028 (##ratnum./ x y)
1029 (##flonum./ x (##flonum.<-ratnum y))
1030 (##cpxnum./ x (##cpxnum.<-noncpxnum y)))
1032 (macro-number-dispatch x (type-error-on-x) ;; y = flonum, no error possible
1033 (if (and (macro-special-case-exact-zero?) (##fixnum.zero? x))
1034 x
1035 (##flonum./ (##flonum.<-fixnum x) y))
1036 (##flonum./ (##flonum.<-exact-int x) y)
1037 (##flonum./ (##flonum.<-ratnum x) y)
1038 (##flonum./ x y)
1039 (##cpxnum./ x (##cpxnum.<-noncpxnum y)))
1041 (macro-number-dispatch x (type-error-on-x) ;; y = cpxnum
1042 (##cpxnum./ (##cpxnum.<-noncpxnum x) y)
1043 (##cpxnum./ (##cpxnum.<-noncpxnum x) y)
1044 (##cpxnum./ (##cpxnum.<-noncpxnum x) y)
1045 (##cpxnum./ (##cpxnum.<-noncpxnum x) y)
1046 (##cpxnum./ x y))))
1048 (define-prim-nary (/ x y)
1049 ()
1050 (##inverse x)
1051 (##/ x y)
1052 macro-force-vars
1053 macro-no-check
1054 (##pair? ##fail-check-number)
1055 (##not ##raise-divide-by-zero-exception))
1057 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1059 ;;; abs
1061 (define-prim (##abs x)
1063 (define (type-error)
1064 (##fail-check-real 1 abs x))
1066 (macro-number-dispatch x (type-error)
1067 (if (##fixnum.negative? x) (##negate x) x)
1068 (if (##bignum.negative? x) (##negate x) x)
1069 (macro-ratnum-make (##abs (macro-ratnum-numerator x))
1070 (macro-ratnum-denominator x))
1071 (##flonum.abs x)
1072 (if (macro-cpxnum-real? x)
1073 (##make-rectangular (##abs (macro-cpxnum-real x))
1074 (##abs (macro-cpxnum-imag x)))
1075 (type-error))))
1077 (define-prim (abs x)
1078 (macro-force-vars (x)
1079 (##abs x)))
1081 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1083 ;;; quotient, remainder, modulo
1085 (define-prim (##quotient x y)
1087 (define (type-error-on-x)
1088 (##fail-check-integer 1 quotient x y))
1090 (define (type-error-on-y)
1091 (##fail-check-integer 2 quotient x y))
1093 (define (divide-by-zero-error)
1094 (##raise-divide-by-zero-exception quotient x y))
1096 (define (exact-quotient x y)
1097 (##car (##exact-int.div x y)))
1099 (define (inexact-quotient x y)
1100 (let ((exact-y (##inexact->exact y)))
1101 (if (##eq? exact-y 0)
1102 (divide-by-zero-error)
1103 (##exact->inexact
1104 (##quotient (##inexact->exact x) exact-y)))))
1106 (macro-number-dispatch y (type-error-on-y)
1108 (macro-number-dispatch x (type-error-on-x) ;; y = fixnum
1109 (cond ((##fixnum.= y 0)
1110 (divide-by-zero-error))
1111 ((##fixnum.= y -1) ;; (quotient ##min-fixnum -1) is a bignum
1112 (##negate x))
1113 (else
1114 (##fixnum.quotient x y)))
1115 (cond ((##fixnum.= y 0)
1116 (divide-by-zero-error))
1117 (else
1118 (exact-quotient x y)))
1119 (type-error-on-x)
1120 (if (macro-flonum-int? x)
1121 (inexact-quotient x y)
1122 (type-error-on-x))
1123 (if (macro-cpxnum-int? x)
1124 (inexact-quotient x y)
1125 (type-error-on-x)))
1127 (macro-number-dispatch x (type-error-on-x) ;; y = bignum
1128 (exact-quotient x y)
1129 (exact-quotient x y)
1130 (type-error-on-x)
1131 (if (macro-flonum-int? x)
1132 (inexact-quotient x y)
1133 (type-error-on-x))
1134 (if (macro-cpxnum-int? x)
1135 (inexact-quotient x y)
1136 (type-error-on-x)))
1138 (type-error-on-y) ;; y = ratnum
1140 (macro-number-dispatch x (type-error-on-x) ;; y = flonum
1141 (if (macro-flonum-int? y)
1142 (inexact-quotient x y)
1143 (type-error-on-y))
1144 (if (macro-flonum-int? y)
1145 (inexact-quotient x y)
1146 (type-error-on-y))
1147 (type-error-on-x)
1148 (if (macro-flonum-int? x)
1149 (if (macro-flonum-int? y)
1150 (inexact-quotient x y)
1151 (type-error-on-y))
1152 (type-error-on-x))
1153 (if (macro-cpxnum-int? x)
1154 (if (macro-flonum-int? y)
1155 (inexact-quotient x y)
1156 (type-error-on-y))
1157 (type-error-on-x)))
1159 (if (macro-cpxnum-int? y) ;; y = cpxnum
1160 (macro-number-dispatch x (type-error-on-x)
1161 (inexact-quotient x y)
1162 (inexact-quotient x y)
1163 (type-error-on-x)
1164 (if (macro-flonum-int? x)
1165 (inexact-quotient x y)
1166 (type-error-on-x))
1167 (if (macro-cpxnum-int? x)
1168 (inexact-quotient x y)
1169 (type-error-on-x)))
1170 (type-error-on-y))))
1172 (define-prim (quotient x y)
1173 (macro-force-vars (x y)
1174 (##quotient x y)))
1176 (define-prim (##remainder x y)
1178 (define (type-error-on-x)
1179 (##fail-check-integer 1 remainder x y))
1181 (define (type-error-on-y)
1182 (##fail-check-integer 2 remainder x y))
1184 (define (divide-by-zero-error)
1185 (##raise-divide-by-zero-exception remainder x y))
1187 (define (exact-remainder x y)
1188 (##cdr (##exact-int.div x y)))
1190 (define (inexact-remainder x y)
1191 (let ((exact-y (##inexact->exact y)))
1192 (if (##eq? exact-y 0)
1193 (divide-by-zero-error)
1194 (##exact->inexact
1195 (##remainder (##inexact->exact x) exact-y)))))
1197 (macro-number-dispatch y (type-error-on-y)
1199 (macro-number-dispatch x (type-error-on-x) ;; y = fixnum
1200 (cond ((##fixnum.= y 0)
1201 (divide-by-zero-error))
1202 (else
1203 (##fixnum.remainder x y)))
1204 (cond ((##fixnum.= y 0)
1205 (divide-by-zero-error))
1206 (else
1207 (exact-remainder x y)))
1208 (type-error-on-x)
1209 (if (macro-flonum-int? x)
1210 (inexact-remainder x y)
1211 (type-error-on-x))
1212 (if (macro-cpxnum-int? x)
1213 (inexact-remainder x y)
1214 (type-error-on-x)))
1216 (macro-number-dispatch x (type-error-on-x) ;; y = bignum
1217 (exact-remainder x y)
1218 (exact-remainder x y)
1219 (type-error-on-x)
1220 (if (macro-flonum-int? x)
1221 (inexact-remainder x y)
1222 (type-error-on-x))
1223 (if (macro-cpxnum-int? x)
1224 (inexact-remainder x y)
1225 (type-error-on-x)))
1227 (type-error-on-y) ;; y = ratnum
1229 (macro-number-dispatch x (type-error-on-x) ;; y = flonum
1230 (if (macro-flonum-int? y)
1231 (inexact-remainder x y)
1232 (type-error-on-y))
1233 (if (macro-flonum-int? y)
1234 (inexact-remainder x y)
1235 (type-error-on-y))
1236 (type-error-on-x)
1237 (if (macro-flonum-int? x)
1238 (if (macro-flonum-int? y)
1239 (inexact-remainder x y)
1240 (type-error-on-y))
1241 (type-error-on-x))
1242 (if (macro-cpxnum-int? x)
1243 (if (macro-flonum-int? y)
1244 (inexact-remainder x y)
1245 (type-error-on-y))
1246 (type-error-on-x)))
1248 (if (macro-cpxnum-int? y) ;; y = cpxnum
1249 (macro-number-dispatch x (type-error-on-x)
1250 (inexact-remainder x y)
1251 (inexact-remainder x y)
1252 (type-error-on-x)
1253 (if (macro-flonum-int? x)
1254 (inexact-remainder x y)
1255 (type-error-on-x))
1256 (if (macro-cpxnum-int? x)
1257 (inexact-remainder x y)
1258 (type-error-on-x)))
1259 (type-error-on-y))))
1261 (define-prim (remainder x y)
1262 (macro-force-vars (x y)
1263 (##remainder x y)))
1265 (define-prim (##modulo x y)
1267 (define (type-error-on-x)
1268 (##fail-check-integer 1 modulo x y))
1270 (define (type-error-on-y)
1271 (##fail-check-integer 2 modulo x y))
1273 (define (divide-by-zero-error)
1274 (##raise-divide-by-zero-exception modulo x y))
1276 (define (exact-modulo x y)
1277 (let ((r (##cdr (##exact-int.div x y))))
1278 (if (##eq? r 0)
1279 0
1280 (if (##eq? (##negative? x) (##negative? y))
1281 r
1282 (##+ r y)))))
1284 (define (inexact-modulo x y)
1285 (let ((exact-y (##inexact->exact y)))
1286 (if (##eq? exact-y 0)
1287 (divide-by-zero-error)
1288 (##exact->inexact
1289 (##modulo (##inexact->exact x) exact-y)))))
1291 (macro-number-dispatch y (type-error-on-y)
1293 (macro-number-dispatch x (type-error-on-x) ;; y = fixnum
1294 (cond ((##fixnum.= y 0)
1295 (divide-by-zero-error))
1296 (else
1297 (##fixnum.modulo x y)))
1298 (cond ((##fixnum.= y 0)
1299 (divide-by-zero-error))
1300 (else
1301 (exact-modulo x y)))
1302 (type-error-on-x)
1303 (if (macro-flonum-int? x)
1304 (inexact-modulo x y)
1305 (type-error-on-x))
1306 (if (macro-cpxnum-int? x)
1307 (inexact-modulo x y)
1308 (type-error-on-x)))
1310 (macro-number-dispatch x (type-error-on-x) ;; y = bignum
1311 (exact-modulo x y)
1312 (exact-modulo x y)
1313 (type-error-on-x)
1314 (if (macro-flonum-int? x)
1315 (inexact-modulo x y)
1316 (type-error-on-x))
1317 (if (macro-cpxnum-int? x)
1318 (inexact-modulo x y)
1319 (type-error-on-x)))
1321 (type-error-on-y) ;; y = ratnum
1323 (macro-number-dispatch x (type-error-on-x) ;; y = flonum
1324 (if (macro-flonum-int? y)
1325 (inexact-modulo x y)
1326 (type-error-on-y))
1327 (if (macro-flonum-int? y)
1328 (inexact-modulo x y)
1329 (type-error-on-y))
1330 (type-error-on-x)
1331 (if (macro-flonum-int? x)
1332 (if (macro-flonum-int? y)
1333 (inexact-modulo x y)
1334 (type-error-on-y))
1335 (type-error-on-x))
1336 (if (macro-cpxnum-int? x)
1337 (if (macro-flonum-int? y)
1338 (inexact-modulo x y)
1339 (type-error-on-y))
1340 (type-error-on-x)))
1342 (if (macro-cpxnum-int? y) ;; y = cpxnum
1343 (macro-number-dispatch x (type-error-on-x)
1344 (inexact-modulo x y)
1345 (inexact-modulo x y)
1346 (type-error-on-x)
1347 (if (macro-flonum-int? x)
1348 (inexact-modulo x y)
1349 (type-error-on-x))
1350 (if (macro-cpxnum-int? x)
1351 (inexact-modulo x y)
1352 (type-error-on-x)))
1353 (type-error-on-y))))
1355 (define-prim (modulo x y)
1356 (macro-force-vars (x y)
1357 (##modulo x y)))
1359 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1361 ;;; gcd, lcm
1363 (define-prim (##gcd x y)
1365 (##define-macro (type-error-on-x) `'(1))
1366 (##define-macro (type-error-on-y) `'(2))
1368 (define (##fast-gcd u v)
1370 ;; See the paper "Fast Reduction and Composition of Binary
1371 ;; Quadratic Forms" by Arnold Schoenhage. His algorithm and proof
1372 ;; are derived from, and basically the same for, his Controlled
1373 ;; Euclidean Descent algorithm for gcd, which he has never
1374 ;; published. This algorithm has complexity log N times a
1375 ;; constant times the complexity of a multiplication of the same
1376 ;; size. We don't use it until we get to about 6800 bits. Note
1377 ;; that this is the same place that we start using FFT
1378 ;; multiplication and fast division with Newton's method for
1379 ;; finding inverses.
1381 ;; Niels Mo"ller has written two papers about an improved version
1382 ;; of this algorithm.
1384 ;; assumes u and v are nonnegative exact ints
1386 (define (make-gcd-matrix A_11 A_12
1387 A_21 A_22)
1388 (##vector A_11 A_12
1389 A_21 A_22))
1391 (define (gcd-matrix_11 A)
1392 (##vector-ref A 0))
1394 (define (gcd-matrix_12 A)
1395 (##vector-ref A 1))
1397 (define (gcd-matrix_21 A)
1398 (##vector-ref A 2))
1400 (define (gcd-matrix_22 A)
1401 (##vector-ref A 3))
1403 (define (make-gcd-vector v_1 v_2)
1404 (##vector v_1 v_2))
1406 (define (gcd-vector_1 v)
1407 (##vector-ref v 0))
1409 (define (gcd-vector_2 v)
1410 (##vector-ref v 1))
1412 (define gcd-matrix-identity '#(1 0
1413 0 1))
1415 (define (gcd-matrix-multiply A B)
1416 (cond ((##eq? A gcd-matrix-identity)
1417 B)
1418 ((##eq? B gcd-matrix-identity)
1419 A)
1420 (else
1421 (let ((A_11 (gcd-matrix_11 A)) (A_12 (gcd-matrix_12 A))
1422 (A_21 (gcd-matrix_21 A)) (A_22 (gcd-matrix_22 A))
1423 (B_11 (gcd-matrix_11 B)) (B_12 (gcd-matrix_12 B))
1424 (B_21 (gcd-matrix_21 B)) (B_22 (gcd-matrix_22 B)))
1425 (make-gcd-matrix (##+ (##* A_11 B_11)
1426 (##* A_12 B_21))
1427 (##+ (##* A_11 B_12)
1428 (##* A_12 B_22))
1429 (##+ (##* A_21 B_11)
1430 (##* A_22 B_21))
1431 (##+ (##* A_21 B_12)
1432 (##* A_22 B_22)))))))
1434 (define (gcd-matrix-multiply-strassen A B)
1435 ;; from http://mathworld.wolfram.com/StrassenFormulas.html
1436 (cond ((##eq? A gcd-matrix-identity)
1437 B)
1438 ((##eq? B gcd-matrix-identity)
1439 A)
1440 (else
1441 (let ((A_11 (gcd-matrix_11 A)) (A_12 (gcd-matrix_12 A))
1442 (A_21 (gcd-matrix_21 A)) (A_22 (gcd-matrix_22 A))
1443 (B_11 (gcd-matrix_11 B)) (B_12 (gcd-matrix_12 B))
1444 (B_21 (gcd-matrix_21 B)) (B_22 (gcd-matrix_22 B)))
1445 (let ((Q_1 (##* (##+ A_11 A_22) (##+ B_11 B_22)))
1446 (Q_2 (##* (##+ A_21 A_22) B_11))
1447 (Q_3 (##* A_11 (##- B_12 B_22)))
1448 (Q_4 (##* A_22 (##- B_21 B_11)))
1449 (Q_5 (##* (##+ A_11 A_12) B_22))
1450 (Q_6 (##* (##- A_21 A_11) (##+ B_11 B_12)))
1451 (Q_7 (##* (##- A_12 A_22) (##+ B_21 B_22))))
1452 (make-gcd-matrix (##+ (##+ Q_1 Q_4) (##- Q_7 Q_5))
1453 (##+ Q_3 Q_5)
1454 (##+ Q_2 Q_4)
1455 (##+ (##+ Q_1 Q_3) (##- Q_6 Q_2))))))))
1457 (define (gcd-matrix-solve A y)
1458 (let ((y_1 (gcd-vector_1 y))
1459 (y_2 (gcd-vector_2 y)))
1460 (make-gcd-vector (##- (##* y_1 (gcd-matrix_22 A))
1461 (##* y_2 (gcd-matrix_12 A)))
1462 (##- (##* y_2 (gcd-matrix_11 A))
1463 (##* y_1 (gcd-matrix_21 A))))))
1465 (define (x>=2^n x n)
1466 (cond ((##eq? x 0)
1467 #f)
1468 ((and (##fixnum? x)
1469 (##fixnum.<= n ##bignum.mdigit-width))
1470 (##fixnum.>= x (##fixnum.arithmetic-shift-left 1 n)))
1471 (else
1472 (let ((x (if (##fixnum? x) (##bignum.<-fixnum x) x)))
1473 (let loop ((i (##fixnum.- (##bignum.mdigit-length x) 1)))
1474 (let ((digit (##bignum.mdigit-ref x i)))
1475 (if (##fixnum.zero? digit)
1476 (loop (##fixnum.- i 1))
1477 (let ((words (##fixnum.quotient n ##bignum.mdigit-width)))
1478 (or (##fixnum.> i words)
1479 (and (##fixnum.= i words)
1480 (##fixnum.>= digit
1481 (##fixnum.arithmetic-shift-left
1482 1
1483 (##fixnum.remainder n ##bignum.mdigit-width)))))))))))))
1485 (define (determined-minimal? u v s)
1486 ;; assumes 2^s <= u , v; s>= 0 fixnum
1487 ;; returns #t if we can determine that |u-v|<2^s
1488 ;; at least one of u and v is a bignum
1489 (let ((u (if (##fixnum? u) (##bignum.<-fixnum u) u))
1490 (v (if (##fixnum? v) (##bignum.<-fixnum v) v)))
1491 (let ((u-length (##bignum.mdigit-length u)))
1492 (and (##fixnum.= u-length (##bignum.mdigit-length v))
1493 (let loop ((i (##fixnum.- u-length 1)))
1494 (let ((v-digit (##bignum.mdigit-ref v i))
1495 (u-digit (##bignum.mdigit-ref u i)))
1496 (if (and (##fixnum.zero? u-digit)
1497 (##fixnum.zero? v-digit))
1498 (loop (##fixnum.- i 1))
1499 (and (##fixnum.= (##fixnum.quotient s ##bignum.mdigit-width)
1500 i)
1501 (##fixnum.< (##fixnum.max (##fixnum.- u-digit v-digit)
1502 (##fixnum.- v-digit u-digit))
1503 (##fixnum.arithmetic-shift-left
1504 1
1505 (##fixnum.remainder s ##bignum.mdigit-width)))))))))))
1507 (define (gcd-small-step cont M u v s)
1508 ;; u, v >= 2^s
1509 ;; M is the matrix product of the partial sums of
1510 ;; the continued fraction representation of a/b so far
1511 ;; returns updated M, u, v, and a truth value
1512 ;; u, v >= 2^s and
1513 ;; if last return value is #t, we know that
1514 ;; (- (max u v) (min u v)) < 2^s, i.e, u, v are minimal above 2^s
1516 (define (gcd-matrix-multiply-low M q)
1517 (let ((M_11 (gcd-matrix_11 M))
1518 (M_12 (gcd-matrix_12 M))
1519 (M_21 (gcd-matrix_21 M))
1520 (M_22 (gcd-matrix_22 M)))
1521 (make-gcd-matrix (##+ M_11 (##* q M_12)) M_12
1522 (##+ M_21 (##* q M_22)) M_22)))
1524 (define (gcd-matrix-multiply-high M q)
1525 (let ((M_11 (gcd-matrix_11 M))
1526 (M_12 (gcd-matrix_12 M))
1527 (M_21 (gcd-matrix_21 M))
1528 (M_22 (gcd-matrix_22 M)))
1529 (make-gcd-matrix M_11 (##+ (##* q M_11) M_12)
1530 M_21 (##+ (##* q M_21) M_22))))
1532 (if (or (##bignum? u)
1533 (##bignum? v))
1535 ;; if u and v are nearly equal bignums, the two ##<
1536 ;; following this condition could take O(N) time to compute.
1537 ;; When this happens, however, it will be likely that
1538 ;; determined-minimal? will return true.
1540 (cond ((determined-minimal? u v s)
1541 (cont M
1542 u
1543 v
1544 #t))
1545 ((##< u v)
1546 (let* ((qr (##exact-int.div v u))
1547 (q (##car qr))
1548 (r (##cdr qr)))
1549 (cond ((x>=2^n r s)
1550 (cont (gcd-matrix-multiply-low M q)
1551 u
1552 r
1553 #f))
1554 ((##eq? q 1)
1555 (cont M
1556 u
1557 v
1558 #t))
1559 (else
1560 (cont (gcd-matrix-multiply-low M (##- q 1))
1561 u
1562 (##+ r u)
1563 #t)))))
1564 ((##< v u)
1565 (let* ((qr (##exact-int.div u v))
1566 (q (##car qr))
1567 (r (##cdr qr)))
1568 (cond ((x>=2^n r s)
1569 (cont (gcd-matrix-multiply-high M q)
1570 r
1571 v
1572 #f))
1573 ((##eq? q 1)
1574 (cont M
1575 u
1576 v
1577 #t))
1578 (else
1579 (cont (gcd-matrix-multiply-high M (##- q 1))
1580 (##+ r v)
1581 v
1582 #t)))))
1583 (else
1584 (cont M
1585 u
1586 v
1587 #t)))
1588 ;; here u and v are fixnums, so 2^s, which is <= u and v, is
1589 ;; also a fixnum
1590 (let ((two^s (##fixnum.arithmetic-shift-left 1 s)))
1591 (if (##fixnum.< u v)
1592 (if (##fixnum.< (##fixnum.- v u) two^s)
1593 (cont M
1594 u
1595 v
1596 #t)
1597 (let ((r (##fixnum.remainder v u))
1598 (q (##fixnum.quotient v u)))
1599 (if (##fixnum.>= r two^s)
1600 (cont (gcd-matrix-multiply-low M q)
1601 u
1602 r
1603 #f)
1604 ;; the case when q is one and the remainder is < two^s
1605 ;; is covered in the first test
1606 (cont (gcd-matrix-multiply-low M (##fixnum.- q 1))
1607 u
1608 (##fixnum.+ r u)
1609 #t))))
1610 ;; here u >= v, but the case u = v is covered by the first test
1611 (if (##fixnum.< (##fixnum.- u v) two^s)
1612 (cont M
1613 u
1614 v
1615 #t)
1616 (let ((r (##fixnum.remainder u v))
1617 (q (##fixnum.quotient u v)))
1618 (if (##fixnum.>= r two^s)
1619 (cont (gcd-matrix-multiply-high M q)
1620 r
1621 v
1622 #f)
1623 ;; the case when q is one and the remainder is < two^s
1624 ;; is covered in the first test
1625 (cont (gcd-matrix-multiply-high M (##fixnum.- q 1))
1626 (##fixnum.+ r v)
1627 v
1628 #t))))))))
1630 (define (gcd-middle-step cont a b h m-prime cont-needs-M?)
1631 ((lambda (cont)
1632 (if (and (x>=2^n a h)
1633 (x>=2^n b h))
1634 (MR cont a b h cont-needs-M?)
1635 (cont gcd-matrix-identity a b)))
1636 (lambda (M x y)
1637 (let loop ((M M)
1638 (x x)
1639 (y y))
1640 (if (or (x>=2^n x h)
1641 (x>=2^n y h))
1642 ((lambda (cont) (gcd-small-step cont M x y m-prime))
1643 (lambda (M x y minimal?)
1644 (if minimal?
1645 (cont M x y)
1646 (loop M x y))))
1647 ((lambda (cont) (MR cont x y m-prime cont-needs-M?))
1648 (lambda (M-prime alpha beta)
1649 (cont (if cont-needs-M?
1650 (if (##fixnum.> (##fixnum.- h m-prime) 1024)
1651 ;; here we trade off 1 multiplication
1652 ;; for 21 additions
1653 (gcd-matrix-multiply-strassen M M-prime)
1654 (gcd-matrix-multiply M M-prime))
1655 gcd-matrix-identity)
1656 alpha
1657 beta))))))))
1659 (define (MR cont a b m cont-needs-M?)
1660 ((lambda (cont)
1661 (if (and (x>=2^n a (##fixnum.+ m 2))
1662 (x>=2^n b (##fixnum.+ m 2)))
1663 (let ((n (##fixnum.- (##fixnum.max (##integer-length a)
1664 (##integer-length b))
1665 m)))
1666 ((lambda (cont)
1667 (if (##fixnum.<= m n)
1668 (cont m 0)
1669 (cont n (##fixnum.- (##fixnum.+ m 1) n))))
1670 (lambda (m-prime p)
1671 (let ((h (##fixnum.+ m-prime (##fixnum.quotient n 2))))
1672 (if (##fixnum.< 0 p)
1673 (let ((a (##arithmetic-shift a (##fixnum.- p)))
1674 (b (##arithmetic-shift b (##fixnum.- p)))
1675 (a_0 (##extract-bit-field p 0 a))
1676 (b_0 (##extract-bit-field p 0 b)))
1677 ((lambda (cont)
1678 (gcd-middle-step cont a b h m-prime #t))
1679 (lambda (M alpha beta)
1680 (let ((M-inverse-v_0 (gcd-matrix-solve M (make-gcd-vector a_0 b_0))))
1681 (cont (if cont-needs-M? M gcd-matrix-identity)
1682 (##+ (##arithmetic-shift alpha p)
1683 (gcd-vector_1 M-inverse-v_0))
1684 (##+ (##arithmetic-shift beta p)
1685 (gcd-vector_2 M-inverse-v_0)))))))
1686 (gcd-middle-step cont a b h m-prime cont-needs-M?))))))
1687 (cont gcd-matrix-identity
1688 a
1689 b)))
1690 (lambda (M alpha beta)
1691 (let loop ((M M)
1692 (alpha alpha)
1693 (beta beta)
1694 (minimal? #f))
1695 (if minimal?
1696 (cont M alpha beta)
1697 (gcd-small-step loop M alpha beta m))))))
1699 ((lambda (cont)
1700 (if (and (use-fast-bignum-algorithms)
1701 (##bignum? u)
1702 (##bignum? v)
1703 (x>=2^n u ##bignum.fast-gcd-size)
1704 (x>=2^n v ##bignum.fast-gcd-size))
1705 (MR cont u v ##bignum.fast-gcd-size #f)
1706 (cont 0 u v)))
1707 (lambda (M a b)
1708 (general-base a b))))
1710 (define (general-base a b)
1711 (##declare (not interrupts-enabled))
1712 (if (##eq? b 0)
1713 a
1714 (if (##fixnum? b)
1715 (fixnum-base b (##remainder a b))
1716 (general-base b (##remainder a b)))))
1718 (define (fixnum-base a b)
1719 (##declare (not interrupts-enabled))
1720 (if (##eq? b 0)
1721 a
1722 (let ((a b)
1723 (b (##fixnum.remainder a b)))
1724 (if (##eq? b 0)
1725 a
1726 (fixnum-base b (##fixnum.remainder a b))))))
1728 (define (exact-gcd x y)
1729 (let ((x (##abs x))
1730 (y (##abs y)))
1731 (cond ((##eq? x 0)
1732 y)
1733 ((##eq? y 0)
1734 x)
1735 ((and (##fixnum? x) (##fixnum? y))
1736 (fixnum-base x y))
1737 (else
1738 (let ((x-first-bit (##first-bit-set x))
1739 (y-first-bit (##first-bit-set y)))
1740 (##arithmetic-shift
1741 (##fast-gcd (##arithmetic-shift x (##fixnum.- x-first-bit))
1742 (##arithmetic-shift y (##fixnum.- y-first-bit)))
1743 (##fixnum.min x-first-bit y-first-bit)))))))
1745 (define (inexact-gcd x y)
1746 (##exact->inexact
1747 (exact-gcd (##inexact->exact x)
1748 (##inexact->exact y))))
1750 (cond ((##not (##integer? x))
1751 (type-error-on-x))
1752 ((##not (##integer? y))
1753 (type-error-on-y))
1754 ((##eq? x y)
1755 (##abs x))
1756 (else
1757 (if (and (##exact? x) (##exact? y))
1758 (exact-gcd x y)
1759 (inexact-gcd x y)))))
1761 (define-prim-nary (gcd x y)
1762 0
1763 (if (##integer? x) (##abs x) '(1))
1764 (##gcd x y)
1765 macro-force-vars
1766 macro-no-check
1767 (##pair? ##fail-check-integer))
1769 (define-prim (##lcm x y)
1771 (##define-macro (type-error-on-x) `'(1))
1772 (##define-macro (type-error-on-y) `'(2))
1774 (define (exact-lcm x y)
1775 (if (or (##eq? x 0) (##eq? y 0))
1776 0
1777 (##abs (##* (##quotient x (##gcd x y))
1778 y))))
1780 (define (inexact-lcm x y)
1781 (##exact->inexact
1782 (exact-lcm (##inexact->exact x)
1783 (##inexact->exact y))))
1785 (cond ((##not (##integer? x))
1786 (type-error-on-x))
1787 ((##not (##integer? y))
1788 (type-error-on-y))
1789 (else
1790 (if (and (##exact? x) (##exact? y))
1791 (exact-lcm x y)
1792 (inexact-lcm x y)))))
1794 (define-prim-nary (lcm x y)
1795 1
1796 (if (##integer? x) (##abs x) '(1))
1797 (##lcm x y)
1798 macro-force-vars
1799 macro-no-check
1800 (##pair? ##fail-check-integer))
1802 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1804 ;;; numerator, denominator
1806 (define-prim (##numerator x)
1808 (define (type-error)
1809 (##fail-check-rational 1 numerator x))
1811 (macro-number-dispatch x (type-error)
1812 x
1813 x
1814 (macro-ratnum-numerator x)
1815 (cond ((##flonum.zero? x)
1816 x)
1817 ((macro-flonum-rational? x)
1818 (##exact->inexact (##numerator (##flonum.inexact->exact x))))
1819 (else
1820 (type-error)))
1821 (if (macro-cpxnum-rational? x)
1822 (##numerator (macro-cpxnum-real x))
1823 (type-error))))
1825 (define-prim (numerator x)
1826 (macro-force-vars (x)
1827 (##numerator x)))
1829 (define-prim (##denominator x)
1831 (define (type-error)
1832 (##fail-check-rational 1 denominator x))
1834 (macro-number-dispatch x (type-error)
1835 1
1836 1
1837 (macro-ratnum-denominator x)
1838 (if (macro-flonum-rational? x)
1839 (##exact->inexact (##denominator (##flonum.inexact->exact x)))
1840 (type-error))
1841 (if (macro-cpxnum-rational? x)
1842 (##denominator (macro-cpxnum-real x))
1843 (type-error))))
1845 (define-prim (denominator x)
1846 (macro-force-vars (x)
1847 (##denominator x)))
1849 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1851 ;;; floor, ceiling, truncate, round
1853 (define-prim (##floor x)
1855 (define (type-error)
1856 (##fail-check-finite-real 1 floor x))
1858 (macro-number-dispatch x (type-error)
1859 x
1860 x
1861 (let ((num (macro-ratnum-numerator x))
1862 (den (macro-ratnum-denominator x)))
1863 (if (##negative? num)
1864 (##quotient (##- num (##- den 1)) den)
1865 (##quotient num den)))
1866 (if (##flonum.finite? x)
1867 (##flonum.floor x)
1868 (type-error))
1869 (if (macro-cpxnum-real? x)
1870 (##floor (macro-cpxnum-real x))
1871 (type-error))))
1873 (define-prim (floor x)
1874 (macro-force-vars (x)
1875 (##floor x)))
1877 (define-prim (##ceiling x)
1879 (define (type-error)
1880 (##fail-check-finite-real 1 ceiling x))
1882 (macro-number-dispatch x (type-error)
1883 x
1884 x
1885 (let ((num (macro-ratnum-numerator x))
1886 (den (macro-ratnum-denominator x)))
1887 (if (##negative? num)
1888 (##quotient num den)
1889 (##quotient (##+ num (##- den 1)) den)))
1890 (if (##flonum.finite? x)
1891 (##flonum.ceiling x)
1892 (type-error))
1893 (if (macro-cpxnum-real? x)
1894 (##ceiling (macro-cpxnum-real x))
1895 (type-error))))
1897 (define-prim (ceiling x)
1898 (macro-force-vars (x)
1899 (##ceiling x)))
1901 (define-prim (##truncate x)
1903 (define (type-error)
1904 (##fail-check-finite-real 1 truncate x))
1906 (macro-number-dispatch x (type-error)
1907 x
1908 x
1909 (##quotient (macro-ratnum-numerator x)
1910 (macro-ratnum-denominator x))
1911 (if (##flonum.finite? x)
1912 (##flonum.truncate x)
1913 (type-error))
1914 (if (macro-cpxnum-real? x)
1915 (##truncate (macro-cpxnum-real x))
1916 (type-error))))
1918 (define-prim (truncate x)
1919 (macro-force-vars (x)
1920 (##truncate x)))
1922 (define-prim (##round x)
1924 (define (type-error)
1925 (##fail-check-finite-real 1 round x))
1927 (macro-number-dispatch x (type-error)
1928 x
1929 x
1930 (##ratnum.round x)
1931 (if (##flonum.finite? x)
1932 (##flonum.round x)
1933 (type-error))
1934 (if (macro-cpxnum-real? x)
1935 (##round (macro-cpxnum-real x))
1936 (type-error))))
1938 (define-prim (round x)
1939 (macro-force-vars (x)
1940 (##round x)))
1942 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1944 ;;; rationalize
1946 (define-prim (##rationalize x y)
1948 (define (simplest-rational1 x y)
1949 (if (##< y x)
1950 (simplest-rational2 y x)
1951 (simplest-rational2 x y)))
1953 (define (simplest-rational2 x y)
1954 (cond ((##not (##< x y))
1955 x)
1956 ((##positive? x)
1957 (simplest-rational3 x y))
1958 ((##negative? y)
1959 (##negate (simplest-rational3 (##negate y) (##negate x))))
1960 (else
1961 0)))
1963 (define (simplest-rational3 x y)
1964 (let ((fx (##floor x))
1965 (fy (##floor y)))
1966 (cond ((##not (##< fx x))
1967 fx)
1968 ((##= fx fy)
1969 (##+ fx
1970 (##inverse
1971 (simplest-rational3
1972 (##inverse (##- y fy))
1973 (##inverse (##- x fx))))))
1974 (else
1975 (##+ fx 1)))))
1977 (cond ((##not (##rational? x))
1978 (##fail-check-finite-real 1 rationalize x y))
1979 ((and (##flonum? y)
1980 (##flonum.= y (macro-inexact-+inf)))
1981 (macro-inexact-+0))
1982 ((##not (##rational? y))
1983 (##fail-check-real 2 rationalize x y))
1984 ((##negative? y)
1985 (##raise-range-exception 2 rationalize x y))
1986 ((and (##exact? x) (##exact? y))
1987 (simplest-rational1 (##- x y) (##+ x y)))
1988 (else
1989 (let ((exact-x (##inexact->exact x))
1990 (exact-y (##inexact->exact y)))
1991 (##exact->inexact
1992 (simplest-rational1 (##- exact-x exact-y)
1993 (##+ exact-x exact-y)))))))
1995 (define-prim (rationalize x y)
1996 (macro-force-vars (x y)
1997 (##rationalize x y)))
1999 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2001 ;;; trigonometry and complex numbers
2003 (define-prim (##exp x)
2005 (define (type-error)
2006 (##fail-check-number 1 exp x))
2008 (macro-number-dispatch x (type-error)
2009 (if (##fixnum.zero? x)
2010 1
2011 (##flonum.exp (##flonum.<-fixnum x)))
2012 (##flonum.exp (##flonum.<-exact-int x))
2013 (##flonum.exp (##flonum.<-ratnum x))
2014 (##flonum.exp x)
2015 (##make-polar (##exp (macro-cpxnum-real x))
2016 (macro-cpxnum-imag x))))
2018 (define-prim (exp x)
2019 (macro-force-vars (x)
2020 (##exp x)))
2022 (define-prim (##flonum.full-precision? x)
2023 (let ((y (##flonum.abs x)))
2024 (and (##fl< y (macro-inexact-+inf))
2025 (##fl<= (macro-flonum-min-normal) y))))
2027 (define-prim (##log x)
2029 (define (type-error)
2030 (##fail-check-number 1 log x))
2032 (define (range-error)
2033 (##raise-range-exception 1 log x))
2035 (define (negative-log x)
2036 (##make-rectangular (##log (##negate x)) (macro-inexact-+pi)))
2038 (define (exact-log x)
2040 ;; x is positive, x is not 1.
2042 ;; There are three places where just converting to a flonum and
2043 ;; taking the flonum logarithm doesn't work well.
2044 ;; 1. Overflow in the conversion
2045 ;; 2. Underflow in the conversion (or even loss of precision
2046 ;; because of a denormalized conversion result)
2047 ;; 3. When the number is close to 1.
2049 (let ((float-x (##exact->inexact x)))
2050 (cond ((##= x float-x)
2051 (##fllog float-x)) ;; first, we trust the builtin flonum log
2053 ((##not (##flonum.full-precision? float-x))
2055 ;; direct conversion to flonum could incur massive relative
2056 ;; rounding errors, or would just lead to an infinite result
2057 ;; so we tolerate more than one rounding error in the calculation
2059 (let* ((wn (##integer-length (##numerator x)))
2060 (wd (##integer-length (##denominator x)))
2061 (p (##fx- wn wd))
2062 (float-p (##flonum.<-fixnum p))
2063 (partial-result (##fllog
2064 (##exact->inexact
2065 (##* x (##expt 2 (##fx- p)))))))
2066 (##fl+ (##fl* float-p
2067 (macro-inexact-log-2))
2068 partial-result)))
2070 ((or (##fl< (macro-inexact-exp-+1/2) float-x)
2071 (##fl< float-x (macro-inexact-exp--1/2)))
2073 ;; here the absolute value of the logarithm is at least 0.5,
2074 ;; so there is less rounding error in the final result.
2076 (##flonum.log float-x))
2078 (else
2080 ;; for rational numbers near one, we use the taylor
2081 ;; series for (log (/ (- x 1) (+ x 1))) by hand.
2082 ;; we first approximate (/ (- x 1) (+ x 1)) by a dyadic
2083 ;; rational with (macro-flonum-m-bits-plus-1*2) bits accuracy
2085 (let* ((y (##/ (##- x 1) (##+ x 1)))
2086 (normalizer (##expt 2 (##fx+ (macro-flonum-m-bits-plus-1*2)
2087 (##fx- (##integer-length (##denominator y))
2088 (##integer-length (##numerator y))))))
2089 (dyadic-y (##/ (##round (##* y normalizer))
2090 normalizer))
2091 (dyadic-y^2 (##* dyadic-y dyadic-y))
2092 (bits-gained-per-loop (##fx- (##integer-length (##denominator dyadic-y^2))
2093 (##integer-length (##numerator dyadic-y^2))
2094 1)))
2095 (let loop ((k 0)
2096 (y^2k+1 dyadic-y)
2097 (result dyadic-y)
2098 (accuracy bits-gained-per-loop))
2099 (if (##fx< (macro-flonum-m-bits-plus-1*2) accuracy)
2100 (##flonum.<-ratnum (##* 2 result))
2101 (let ((y^2k+1 (##* dyadic-y^2 y^2k+1))
2102 (k (##fx+ k 1)))
2103 (loop k
2104 y^2k+1
2105 (##+ result (##/ y^2k+1 (##fx+ (##fx* 2 k) 1)))
2106 (##fx+ accuracy bits-gained-per-loop))))))))))
2108 (define (complex-log-magnitude x)
2110 (define (log-mag a b)
2111 ;; both are finite, 0 <= a <= b, b is nonzero
2112 (let* ((c (##/ a b))
2113 (approx-mag (##* b (##sqrt (##+ 1 (##* c c))))))
2114 (if (or (##exact? approx-mag)
2115 (and (##flonum.full-precision? approx-mag)
2116 (or (##fl< (macro-inexact-exp-+1/2) approx-mag)
2117 (##fl< approx-mag (macro-inexact-exp--1/2)))))
2118 ;; log composed with magnitude will compute a relatively accurate answer
2119 (##log approx-mag)
2120 (let ((a (##inexact->exact a))
2121 (b (##inexact->exact b)))
2122 (##* 1/2 (exact-log (##+ (##* a a) (##* b b))))))))
2124 (let ((abs-r (##abs (##real-part x)))
2125 (abs-i (##abs (##imag-part x))))
2127 ;; abs-i is not exact 0
2128 (cond ((or (and (##flonum? abs-r)
2129 (##flonum.= abs-r (macro-inexact-+inf)))
2130 (and (##flonum? abs-i)
2131 (##flonum.= abs-i (macro-inexact-+inf))))
2132 (macro-inexact-+inf))
2133 ;; neither abs-r or abs-i is infinite
2134 ((and (##flonum? abs-r)
2135 (##flonum.nan? abs-r))
2136 abs-r)
2137 ;; abs-r is not a NaN
2138 ((and (##flonum? abs-i)
2139 (##flonum.nan? abs-i))
2140 abs-i)
2141 ;; abs-i is not a NaN
2142 ((##eq? abs-r 0)
2143 (##log abs-i))
2144 ;; abs-r is not exact 0
2145 ((and (##zero? abs-r)
2146 (##zero? abs-i))
2147 (macro-inexact--inf))
2148 ;; abs-i and abs-r are not both zero
2149 (else
2150 (if (##< abs-r abs-i)
2151 (log-mag abs-r abs-i)
2152 (log-mag abs-i abs-r))))))
2154 (macro-number-dispatch x (type-error)
2155 (if (##fixnum.zero? x)
2156 (range-error)
2157 (if (##fixnum.negative? x)
2158 (negative-log x)
2159 (if (##eq? x 1)
2160 0
2161 (exact-log x))))
2162 (if (##bignum.negative? x)
2163 (negative-log x)
2164 (exact-log x))
2165 (if (##negative? (macro-ratnum-numerator x))
2166 (negative-log x)
2167 (exact-log x))
2168 (if (or (##flonum.nan? x)
2169 (##not (##flonum.negative?
2170 (##flonum.copysign (macro-inexact-+1) x))))
2171 (##flonum.log x)
2172 (negative-log x))
2173 (##make-rectangular (complex-log-magnitude x) (##angle x))))
2175 (define-prim (log x)
2176 (macro-force-vars (x)
2177 (##log x)))
2179 (define-prim (##sin x)
2181 (define (type-error)
2182 (##fail-check-number 1 sin x))
2184 (macro-number-dispatch x (type-error)
2185 (if (##fixnum.zero? x)
2186 0
2187 (##flonum.sin (##flonum.<-fixnum x)))
2188 (##flonum.sin (##flonum.<-exact-int x))
2189 (##flonum.sin (##flonum.<-ratnum x))
2190 (##flonum.sin x)
2191 (##/ (##- (##exp (##make-rectangular
2192 (##negate (macro-cpxnum-imag x))
2193 (macro-cpxnum-real x)))
2194 (##exp (##make-rectangular
2195 (macro-cpxnum-imag x)
2196 (##negate (macro-cpxnum-real x)))))
2197 (macro-cpxnum-+2i))))
2199 (define-prim (sin x)
2200 (macro-force-vars (x)
2201 (##sin x)))
2203 (define-prim (##cos x)
2205 (define (type-error)
2206 (##fail-check-number 1 cos x))
2208 (macro-number-dispatch x (type-error)
2209 (if (##fixnum.zero? x)
2210 1
2211 (##flonum.cos (##flonum.<-fixnum x)))
2212 (##flonum.cos (##flonum.<-exact-int x))
2213 (##flonum.cos (##flonum.<-ratnum x))
2214 (##flonum.cos x)
2215 (##/ (##+ (##exp (##make-rectangular
2216 (##negate (macro-cpxnum-imag x))
2217 (macro-cpxnum-real x)))
2218 (##exp (##make-rectangular
2219 (macro-cpxnum-imag x)
2220 (##negate (macro-cpxnum-real x)))))
2221 2)))
2223 (define-prim (cos x)
2224 (macro-force-vars (x)
2225 (##cos x)))
2227 (define-prim (##tan x)
2229 (define (type-error)
2230 (##fail-check-number 1 tan x))
2232 (macro-number-dispatch x (type-error)
2233 (if (##fixnum.zero? x)
2234 0
2235 (##flonum.tan (##flonum.<-fixnum x)))
2236 (##flonum.tan (##flonum.<-exact-int x))
2237 (##flonum.tan (##flonum.<-ratnum x))
2238 (##flonum.tan x)
2239 (let ((a (##exp (##make-rectangular
2240 (##negate (macro-cpxnum-imag x))
2241 (macro-cpxnum-real x))))
2242 (b (##exp (##make-rectangular
2243 (macro-cpxnum-imag x)
2244 (##negate (macro-cpxnum-real x))))))
2245 (let ((c (##/ (##- a b) (##+ a b))))
2246 (##make-rectangular (##imag-part c) (##negate (##real-part c)))))))
2248 (define-prim (tan x)
2249 (macro-force-vars (x)
2250 (##tan x)))
2252 (define-prim (##asin x)
2254 (define (type-error)
2255 (##fail-check-number 1 asin x))
2257 (define (safe-case x)
2258 (##* (macro-cpxnum--i)
2259 (##log (##+ (##* (macro-cpxnum-+i) x)
2260 (##sqrt (##- 1 (##* x x)))))))
2262 (define (unsafe-case x)
2263 (##negate (safe-case (##negate x))))
2265 (define (real-case x)
2266 (cond ((##< x -1)
2267 (unsafe-case x))
2268 ((##< 1 x)
2269 (safe-case x))
2270 (else
2271 (##flonum.asin (##exact->inexact x)))))
2273 (macro-number-dispatch x (type-error)
2274 (if (##fixnum.zero? x)
2275 0
2276 (real-case x))
2277 (real-case x)
2278 (real-case x)
2279 (real-case x)
2280 (let ((imag (macro-cpxnum-imag x)))
2281 (if (or (##positive? imag)
2282 (and (##flonum? imag)
2283 (##flonum.zero? imag)
2284 (##negative? (macro-cpxnum-real x))))
2285 (unsafe-case x)
2286 (safe-case x)))))
2288 (define-prim (asin x)
2289 (macro-force-vars (x)
2290 (##asin x)))
2292 (define-prim (##acos x)
2294 (define (type-error)
2295 (##fail-check-number 1 acos x))
2297 (define (complex-case x)
2298 (##- (macro-inexact-+pi/2) (##asin x)))
2300 (define (real-case x)
2301 (if (or (##< x -1) (##< 1 x))
2302 (complex-case x)
2303 (##flonum.acos (##exact->inexact x))))
2305 (macro-number-dispatch x (type-error)
2306 (if (##fixnum.zero? x)
2307 (macro-inexact-+pi/2)
2308 (real-case x))
2309 (real-case x)
2310 (real-case x)
2311 (real-case x)
2312 (complex-case x)))
2314 (define-prim (acos x)
2315 (macro-force-vars (x)
2316 (##acos x)))
2318 (define-prim (##atan x)
2320 (define (type-error)
2321 (##fail-check-number 1 atan x))
2323 (define (range-error)
2324 (##raise-range-exception 1 atan x))
2326 (macro-number-dispatch x (type-error)
2327 (if (##fixnum.zero? x)
2328 0
2329 (##flonum.atan (##flonum.<-fixnum x)))
2330 (##flonum.atan (##flonum.<-exact-int x))
2331 (##flonum.atan (##flonum.<-ratnum x))
2332 (##flonum.atan x)
2333 (let ((real (macro-cpxnum-real x))
2334 (imag (macro-cpxnum-imag x)))
2335 (if (and (##eq? real 0) (##eq? imag 1))
2336 (range-error)
2337 (let ((a (##make-rectangular (##negate imag) real)))
2338 (##/ (##- (##log (##+ a 1)) (##log (##- 1 a)))
2339 (macro-cpxnum-+2i)))))))
2341 (define-prim (##atan2 y x)
2343 (define (flonum-substitute x)
2344 (cond ((##flonum? x)
2345 x)
2346 ((##eq? x 0)
2347 0.)
2348 ((##positive? x)
2349 1.)
2350 (else
2351 -1.)))
2353 (define (irregular-flonum? x)
2354 (and (##flonum? x)
2355 (or (##flonum.zero? x)
2356 (##not (##flfinite? x)))))
2358 (cond ((##eq? 0 y)
2359 (if (##exact? x)
2360 (if (##negative? x)
2361 (macro-inexact-+pi)
2362 0)
2363 (if (##negative? (##flonum.copysign (macro-inexact-+1) x))
2364 (macro-inexact-+pi)
2365 0.)))
2366 ((or (irregular-flonum? x)
2367 (irregular-flonum? y))
2368 (##flonum.atan (flonum-substitute y)
2369 (flonum-substitute x)))
2370 (else
2371 (let ((inexact-x (##exact->inexact x))
2372 (inexact-y (##exact->inexact y)))
2373 (if (and (or (##flonum? x)
2374 (##flonum.full-precision? inexact-x)
2375 (##= x inexact-x))
2376 (or (##flonum? y)
2377 (##flonum.full-precision? inexact-y)
2378 (##= y inexact-y)))
2379 (##flonum.atan inexact-y inexact-x)
2380 ;; at least one of x or y is nonzero
2381 ;; and at least one of them is not a flonum
2382 (let* ((exact-x (##inexact->exact x))
2383 (exact-y (##inexact->exact y))
2384 (max-arg (##max (##abs exact-x)
2385 (##abs exact-y)))
2386 (normalizer (##expt 2 (##- (##integer-length (##denominator max-arg))
2387 (##integer-length (##numerator max-arg))))))
2388 ;; now the largest argument will be about 1.
2389 (##flonum.atan (##exact->inexact (##* normalizer exact-y))
2390 (##exact->inexact (##* normalizer exact-x)))))))))
2392 (define-prim (atan x #!optional (y (macro-absent-obj)))
2393 (macro-force-vars (x)
2394 (if (##eq? y (macro-absent-obj))
2395 (##atan x)
2396 (macro-force-vars (y)
2397 (cond ((##not (##real? x))
2398 (##fail-check-real 1 atan x y))
2399 ((##not (##real? y))
2400 (##fail-check-real 2 atan x y))
2401 (else
2402 (##atan2 x y)))))))
2404 (define-prim (##sqrt x)
2406 (define (type-error)
2407 (##fail-check-number 1 sqrt x))
2409 (define (exact-int-sqrt x)
2410 (if (##negative? x)
2411 (##make-rectangular 0 (exact-int-sqrt (##negate x)))
2412 (let ((y (##exact-int.sqrt x)))
2413 (cond ((##eq? (##cdr y) 0)
2414 (##car y))
2415 ((if (##fixnum? x)
2416 (or (##not (##fixnum? (macro-flonum-+m-max-plus-1)))
2417 (##fixnum.<= x (macro-flonum-+m-max-plus-1)))
2418 (and (##not (##fixnum? (macro-flonum-+m-max-plus-1)))
2419 (##not (##bignum.< (macro-flonum-+m-max-plus-1) x))))
2420 ;; 0 <= x <= (macro-flonum-+m-max-plus-1), can be
2421 ;; converted to flonum exactly so avoids double
2422 ;; rounding in next expression this has a relatively
2423 ;; fast path for small integers.
2424 (##flonum.sqrt
2425 (if (##fixnum? x)
2426 (##flonum.<-fixnum x)
2427 (##flonum.<-exact-int x))))
2428 ((##not (##< (##car y) (macro-flonum-+m-max-plus-1)))
2429 ;; ##flonum.<-exact-int uses second argument correctly
2430 (##flonum.<-exact-int (##car y) #t))
2431 (else
2432 ;; The integer part of y does not have enough bits accuracy
2433 ;; to round it correctly to a flonum, so to
2434 ;; make sure (##car y) is big enough in the next call we
2435 ;; multiply by (expt 2 (macro-flonum-m-bits-plus-1*2)),
2436 ;; which is somewhat extravagant;
2437 ;; (expt 2 (+ 1 (macro-flonum-m-bits-plus-1))) should
2438 ;; work fine.
2439 (##flonum.* (macro-flonum-inverse-+m-max-plus-1-inexact)
2440 (exact-int-sqrt
2441 (##arithmetic-shift
2442 x
2443 (macro-flonum-m-bits-plus-1*2)))))))))
2445 (define (ratnum-sqrt x)
2446 (if (##negative? x)
2447 (##make-rectangular 0 (ratnum-sqrt (##negate x)))
2448 (let ((p (macro-ratnum-numerator x))
2449 (q (macro-ratnum-denominator x)))
2450 (let ((sqrt-p (##exact-int.sqrt p))
2451 (sqrt-q (##exact-int.sqrt q)))
2452 (if (and (##zero? (##cdr sqrt-p))
2453 (##zero? (##cdr sqrt-q)))
2454 ;; both (abs p) and q are perfect squares and
2455 ;; their square roots do not have any common factors
2456 (macro-ratnum-make (##car sqrt-p)
2457 (##car sqrt-q))
2458 (let ((wp (##integer-length p))
2459 (wq (##integer-length q)))
2461 ;; for IEEE 754 double precision, we need at least
2462 ;; 53 or 54 (I can't seem to work it out) of the
2463 ;; leading bits of (sqrt (/ p q)). Here we get
2464 ;; about 64 leading bits. We just shift p (either
2465 ;; right or left) until it is about 128 bits longer
2466 ;; than q (shift must be even), then take the
2467 ;; integer square root of the result.
2469 (let* ((shift
2470 (##fixnum.arithmetic-shift-left
2471 (##fixnum.arithmetic-shift-right
2472 (##fixnum.- 128 (##fixnum.- wp wq))
2473 1)
2474 1))
2475 (leading-bits
2476 (##car
2477 (##exact-int.sqrt
2478 (##quotient
2479 (##arithmetic-shift p shift)
2480 q))))
2481 (pre-rounded-result
2482 (if (##fixnum.negative? shift)
2483 (##arithmetic-shift
2484 leading-bits
2485 (##fixnum.-
2486 (##fixnum.arithmetic-shift-right
2487 shift
2488 1)))
2489 (##ratnum.normalize
2490 leading-bits
2491 (##arithmetic-shift
2492 1
2493 (##fixnum.arithmetic-shift-right
2494 shift
2495 1))))))
2496 (if (##ratnum? pre-rounded-result)
2497 (##flonum.<-ratnum pre-rounded-result #t)
2498 (##flonum.<-exact-int pre-rounded-result #t)))))))))
2500 (define (complex-sqrt-magnitude x)
2502 (define (sqrt-mag a b)
2503 ;; both are finite, 0 <= a <= b, b is nonzero
2504 (let* ((c (##/ a b))
2505 (d (##sqrt (##+ 1 (##* c c)))))
2506 ;; the following may return an inexact result when the true
2507 ;; result is exact, but we're just feeding it into make-polar
2508 ;; with a non-exact-zero angle, anyway.
2509 (##* (##sqrt b) (##sqrt d))))
2511 (let ((abs-r (##abs (##real-part x)))
2512 (abs-i (##abs (##imag-part x))))
2514 ;; abs-i is not exact 0
2515 (cond ((or (and (##flonum? abs-r)
2516 (##flonum.= abs-r (macro-inexact-+inf)))
2517 (and (##flonum? abs-i)
2518 (##flonum.= abs-i (macro-inexact-+inf))))
2519 (macro-inexact-+inf))
2520 ;; neither abs-r or abs-i is infinite
2521 ((and (##flonum? abs-r)
2522 (##flonum.nan? abs-r))
2523 abs-r)
2524 ;; abs-r is not a NaN
2525 ((and (##flonum? abs-i)
2526 (##flonum.nan? abs-i))
2527 abs-i)
2528 ;; abs-i is not a NaN
2529 ((##eq? abs-r 0)
2530 (##sqrt abs-i))
2531 ;; abs-r is not exact 0
2532 ((and (##zero? abs-r)
2533 (##zero? abs-i))
2534 (macro-inexact-+0))
2535 ;; abs-i and abs-r are not both zero
2536 (else
2537 (if (##< abs-r abs-i)
2538 (sqrt-mag abs-r abs-i)
2539 (sqrt-mag abs-i abs-r))))))
2541 (macro-number-dispatch x (type-error)
2542 (exact-int-sqrt x)
2543 (exact-int-sqrt x)
2544 (ratnum-sqrt x)
2545 (if (##flonum.negative? x)
2546 (##make-rectangular 0 (##flonum.sqrt (##flonum.- x)))
2547 (##flonum.sqrt x))
2548 (let ((real (##real-part x))
2549 (imag (##imag-part x)))
2550 (cond ((and (##flonum? imag)
2551 (##flonum.zero? imag))
2552 (if (##flonum.positive? (##flonum.copysign (macro-inexact-+1) imag))
2553 (cond ((##negative? real)
2554 (##make-rectangular (macro-inexact-+0)
2555 (##exact->inexact
2556 (##sqrt (##negate real)))))
2557 ((and (##flonum? real)
2558 (##flonum.nan? real))
2559 (##make-rectangular real real))
2560 (else
2561 (##make-rectangular (##exact->inexact (##sqrt real))
2562 (macro-inexact-+0))))
2563 (cond ((##negative? real)
2564 (##make-rectangular (macro-inexact-+0)
2565 (##exact->inexact
2566 (##negate (##sqrt (##negate real))))))
2567 ((and (##flonum? real)
2568 (##flonum.nan? real))
2569 (##make-rectangular real real))
2570 (else
2571 (##make-rectangular (##exact->inexact (##sqrt real))
2572 (macro-inexact--0))))))
2573 ((and (##exact? real)
2574 (##exact? imag)
2575 (let ((discriminant (##sqrt (##+ (##* real real)
2576 (##* imag imag)))))
2577 (and (##exact? discriminant)
2578 (let ((result-real (##sqrt (##/ (##+ real discriminant) 2))))
2579 (and (##exact? result-real)
2580 (##make-rectangular result-real (##/ imag (##* 2 result-real))))))))
2581 =>
2582 values)
2583 (else
2584 (##make-polar (complex-sqrt-magnitude x)
2585 (##/ (##angle x) 2)))))))
2587 (define-prim (sqrt x)
2588 (macro-force-vars (x)
2589 (##sqrt x)))
2591 (define-prim (##expt x y)
2593 (define (exact-int-expt x y)
2595 (define (positive-int-expt x y)
2597 ;; x is an exact number and y is a positive exact integer
2599 (define (square x)
2600 (##* x x))
2602 (define (expt-aux x y)
2604 ;; x is an exact integer (not 0 or 1) and y is a nonzero exact integer
2606 (if (##eq? y 1)
2607 x
2608 (let ((temp (square (expt-aux x (##arithmetic-shift y -1)))))
2609 (if (##even? y)
2610 temp
2611 (##* x temp)))))
2613 (cond ((or (##eq? x 0)
2614 (##eq? x 1))
2615 x)
2616 ((##ratnum? x)
2617 (macro-ratnum-make
2618 (exact-int-expt (macro-ratnum-numerator x) y)
2619 (exact-int-expt (macro-ratnum-denominator x) y)))
2620 (else
2621 (expt-aux x y))))
2623 (define (invert z)
2624 ;; z is exact
2625 (let ((result (##inverse z)))
2626 (if (##not result)
2627 (##raise-range-exception 1 expt x y)
2628 result)))
2630 (if (##negative? y)
2631 (invert (positive-int-expt x (##negate y)))
2632 (positive-int-expt x y)))
2634 (define (complex-expt x y)
2635 (##exp (##* (##log x) y)))
2637 (define (ratnum-expt x y)
2638 ;; x is exact-int or ratnum
2639 (cond ((##eq? x 0)
2640 (if (##negative? y)
2641 (##raise-range-exception 1 expt x y)
2642 0))
2643 ((##eq? x 1)
2644 1)
2645 ((##negative? x)
2646 ;; We'll do some nice multiples of angles of pi carefully
2647 (case (macro-ratnum-denominator y)
2648 ((2)
2649 (##* (##expt (##negate x) y)
2650 (case (##modulo (macro-ratnum-numerator y) 4)
2651 ((1)
2652 (macro-cpxnum-+i))
2653 (else ;; (3)
2654 (macro-cpxnum--i)))))
2655 ((3)
2656 (##* (##expt (##negate x) y)
2657 (case (##modulo (macro-ratnum-numerator y) 6)
2658 ((1)
2659 (macro-cpxnum-+1/2+sqrt3/2i))
2660 ((2)
2661 (macro-cpxnum--1/2+sqrt3/2i))
2662 ((4)
2663 (macro-cpxnum--1/2-sqrt3/2i))
2664 (else ;; (5)
2665 (macro-cpxnum-+1/2-sqrt3/2i)))))
2666 ((6)
2667 (##* (##expt (##negate x) y)
2668 (case (##modulo (macro-ratnum-numerator y) 12)
2669 ((1)
2670 (macro-cpxnum-+sqrt3/2+1/2i))
2671 ((5)
2672 (macro-cpxnum--sqrt3/2+1/2i))
2673 ((7)
2674 (macro-cpxnum--sqrt3/2-1/2i))
2675 (else ;; (11)
2676 (macro-cpxnum-+sqrt3/2-1/2i)))))
2677 ;; otherwise, we punt
2678 (else
2679 (complex-expt x y))))
2680 ((or (##fixnum? x)
2681 (##bignum? x))
2682 (let* ((y-den (macro-ratnum-denominator y))
2683 (temp (##exact-int.nth-root x y-den)))
2684 (if (##= x (exact-int-expt temp y-den))
2685 (exact-int-expt temp (macro-ratnum-numerator y))
2686 (##flonum.expt (##flonum.<-exact-int x)
2687 (##flonum.<-ratnum y)))))
2688 (else
2689 ;; x is a ratnum
2690 (let ((x-num (macro-ratnum-numerator x))
2691 (x-den (macro-ratnum-denominator x))
2692 (y-num (macro-ratnum-numerator y))
2693 (y-den (macro-ratnum-denominator y)))
2694 (let ((temp-num (##exact-int.nth-root x-num y-den)))
2695 (if (##= (exact-int-expt temp-num y-den) x-num)
2696 (let ((temp-den (##exact-int.nth-root x-den y-den)))
2697 (if (##= (exact-int-expt temp-den y-den) x-den)
2698 (exact-int-expt (macro-ratnum-make temp-num temp-den)
2699 y-num)
2700 (##flonum.expt (##flonum.<-ratnum x)
2701 (##flonum.<-ratnum y))))
2702 (##flonum.expt (##flonum.<-ratnum x)
2703 (##flonum.<-ratnum y))))))))
2705 (macro-number-dispatch y (##fail-check-number 2 expt x y)
2707 (macro-number-dispatch x (##fail-check-number 1 expt x y) ;; y a fixnum
2708 (if (##eq? y 0)
2709 1
2710 (exact-int-expt x y))
2711 (if (##eq? y 0)
2712 1
2713 (exact-int-expt x y))
2714 (if (##eq? y 0)
2715 1
2716 (exact-int-expt x y))
2717 (cond ((##eq? y 0)
2718 1)
2719 ((##flonum.nan? x)
2720 x)
2721 ((##flonum.negative? x)
2722 ;; we do this because (##flonum.<-fixnum y) is always
2723 ;; even for large enough y on 64-bit machines
2724 (let ((abs-result
2725 (##flonum.expt (##flonum.- x) (##flonum.<-fixnum y))))
2726 (if (##fixnum.odd? y)
2727 (##flonum.- abs-result)
2728 abs-result)))
2729 (else
2730 (##flonum.expt x (##flonum.<-fixnum y))))
2731 (cond ((##eq? y 0)
2732 1)
2733 ((##eq? y 1)
2734 x)
2735 ((##exact? x)
2736 (exact-int-expt x y))
2737 (else
2738 (complex-expt x y))))
2740 (macro-number-dispatch x (##fail-check-number 1 expt x y) ;; y a bignum
2741 (exact-int-expt x y)
2742 (exact-int-expt x y)
2743 (exact-int-expt x y)
2744 (cond ((##flonum.nan? x)
2745 x)
2746 ((##flonum.negative? x)
2747 ;; we do this because (##flonum.<-exact-int y) is always
2748 ;; even for large enough y
2749 (let ((abs-result
2750 (##flonum.expt (##flonum.- x) (##flonum.<-exact-int y))))
2751 (if (##odd? y)
2752 (##flonum.- abs-result)
2753 abs-result)))
2754 (else
2755 (##flonum.expt x (##flonum.<-exact-int y))))
2756 (if (##exact? x)
2757 (exact-int-expt x y)
2758 (complex-expt x y)))
2760 (macro-number-dispatch x (##fail-check-number 1 expt x y) ;; y a ratnum
2761 (ratnum-expt x y)
2762 (ratnum-expt x y)
2763 (ratnum-expt x y)
2764 (cond ((##flonum.nan? x)
2765 x)
2766 ((##flonum.negative? x)
2767 (if (##eq? 2 (macro-ratnum-denominator y))
2768 (let ((magnitude (##flonum.expt (##flonum.- x) (##flonum.<-ratnum y))))
2769 (if (##eq? 1 (##modulo (macro-ratnum-numerator y) 4))
2770 ;; multiple of i
2771 (macro-cpxnum-make 0 magnitude)
2772 ;; multiple of -i
2773 (macro-cpxnum-make 0 (##flonum.- magnitude))))
2774 (complex-expt x y)))
2775 (else
2776 (##flonum.expt x (##flonum.<-ratnum y))))
2777 (complex-expt x y))
2779 (macro-number-dispatch x (##fail-check-number 1 expt x y) ;; y a flonum
2780 (cond ((##flonum.nan? y)
2781 y)
2782 ((##eq? x 0)
2783 (if (##flonum.negative? y)
2784 (##raise-range-exception 1 expt x y)
2785 0))
2786 ((or (##fixnum.positive? x)
2787 (macro-flonum-int? y))
2788 (##flonum.expt (##flonum.<-fixnum x) y))
2789 (else
2790 (complex-expt x y)))
2791 (cond ((##flonum.nan? y)
2792 y)
2793 ((or (##positive? x)
2794 (macro-flonum-int? y))
2795 (##flonum.expt (##flonum.<-exact-int x) y))
2796 (else
2797 (complex-expt x y)))
2798 (cond ((##flonum.nan? y)
2799 y)
2800 ((or (##positive? x)
2801 (macro-flonum-int? y))
2802 (##flonum.expt (##flonum.<-ratnum x) y))
2803 (else
2804 (complex-expt x y)))
2805 (cond ((##flonum.nan? x)
2806 x)
2807 ((##flonum.nan? y)
2808 y)
2809 ((or (##flonum.positive? x)
2810 (macro-flonum-int? y))
2811 (##flonum.expt x y))
2812 (else
2813 (complex-expt x y)))
2814 (cond ((##flonum.nan? y)
2815 y)
2816 (else
2817 (complex-expt x y))))
2819 (macro-number-dispatch x (##fail-check-number 1 expt x y) ;; y a cpxnum
2820 (if (##eq? x 0)
2821 (let ((real (##real-part y)))
2822 (if (##positive? real)
2823 0
2824 ;; If we call (complex-expt 0 y),
2825 ;; we'll try to take (##log 0) in complex-expt,
2826 ;; so we raise the exception here.
2827 (##raise-range-exception 1 expt x y)))
2828 (complex-expt x y))
2829 (complex-expt x y)
2830 (complex-expt x y)
2831 (complex-expt x y)
2832 (complex-expt x y))))
2834 (define-prim (expt x y)
2835 (macro-force-vars (x y)
2836 (##expt x y)))
2838 (define-prim (##make-rectangular x y)
2839 (cond ((##not (##real? x))
2840 (##fail-check-real 1 make-rectangular x y))
2841 ((##not (##real? y))
2842 (##fail-check-real 2 make-rectangular x y))
2843 (else
2844 (let ((real (##real-part x))
2845 (imag (##real-part y)))
2846 (if (##eq? imag 0)
2847 real
2848 (macro-cpxnum-make real imag))))))
2850 (define-prim (make-rectangular x y)
2851 (macro-force-vars (x y)
2852 (##make-rectangular x y)))
2854 (define-prim (##make-polar x y)
2855 (cond ((##not (##real? x))
2856 (##fail-check-real 1 make-polar x y))
2857 ((##not (##real? y))
2858 (##fail-check-real 2 make-polar x y))
2859 (else
2860 (let ((real-x (##real-part x))
2861 (real-y (##real-part y)))
2862 (##make-rectangular (##* real-x (##cos real-y))
2863 (##* real-x (##sin real-y)))))))
2865 (define-prim (make-polar x y)
2866 (macro-force-vars (x y)
2867 (##make-polar x y)))
2869 (define-prim (##real-part x)
2871 (define (type-error)
2872 (##fail-check-number 1 real-part x))
2874 (macro-number-dispatch x (type-error)
2875 x x x x (macro-cpxnum-real x)))
2877 (define-prim (real-part x)
2878 (macro-force-vars (x)
2879 (##real-part x)))
2881 (define-prim (##imag-part x)
2883 (define (type-error)
2884 (##fail-check-number 1 imag-part x))
2886 (macro-number-dispatch x (type-error)
2887 0 0 0 0 (macro-cpxnum-imag x)))
2889 (define-prim (imag-part x)
2890 (macro-force-vars (x)
2891 (##imag-part x)))
2893 (define-prim (##magnitude x)
2895 (define (type-error)
2896 (##fail-check-number 1 magnitude x))
2898 (macro-number-dispatch x (type-error)
2899 (if (##fixnum.negative? x) (##negate x) x)
2900 (if (##bignum.negative? x) (##negate x) x)
2901 (macro-ratnum-make (##abs (macro-ratnum-numerator x))
2902 (macro-ratnum-denominator x))
2903 (##flonum.abs x)
2904 (let ((abs-r (##abs (##real-part x)))
2905 (abs-i (##abs (##imag-part x))))
2907 (define (complex-magn a b)
2908 (cond ((##eq? a 0)
2909 b)
2910 ((and (##flonum? a) (##flonum.zero? a))
2911 (##exact->inexact b))
2912 (else
2913 (let ((c (##/ a b)))
2914 (##* b (##sqrt (##+ (##* c c) 1)))))))
2916 (cond ((or (and (##flonum? abs-r)
2917 (##flonum.= abs-r (macro-inexact-+inf)))
2918 (and (##flonum? abs-i)
2919 (##flonum.= abs-i (macro-inexact-+inf))))
2920 (macro-inexact-+inf))
2921 ((and (##flonum? abs-r) (##flonum.nan? abs-r))
2922 abs-r)
2923 ((and (##flonum? abs-i) (##flonum.nan? abs-i))
2924 abs-i)
2925 (else
2926 (if (##< abs-r abs-i)
2927 (complex-magn abs-r abs-i)
2928 (complex-magn abs-i abs-r)))))))
2930 (define-prim (magnitude x)
2931 (macro-force-vars (x)
2932 (##magnitude x)))
2934 (define-prim (##angle x)
2936 (define (type-error)
2937 (##fail-check-number 1 angle x))
2939 (macro-number-dispatch x (type-error)
2940 (if (##fixnum.negative? x)
2941 (macro-inexact-+pi)
2942 0)
2943 (if (##bignum.negative? x)
2944 (macro-inexact-+pi)
2945 0)
2946 (if (##negative? (macro-ratnum-numerator x))
2947 (macro-inexact-+pi)
2948 0)
2949 (if (##flonum.negative? (##flonum.copysign (macro-inexact-+1) x))
2950 (macro-inexact-+pi)
2951 (macro-inexact-+0))
2952 (##atan2 (macro-cpxnum-imag x) (macro-cpxnum-real x))))
2954 (define-prim (angle x)
2955 (macro-force-vars (x)
2956 (##angle x)))
2958 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2960 ;;; exact->inexact, inexact->exact
2962 (define-prim (##exact->inexact x)
2964 (define (type-error)
2965 (##fail-check-number 1 exact->inexact x))
2967 (macro-number-dispatch x (type-error)
2968 (##flonum.<-fixnum x)
2969 (##flonum.<-exact-int x)
2970 (##flonum.<-ratnum x)
2971 x
2972 (##make-rectangular (##exact->inexact (macro-cpxnum-real x))
2973 (##exact->inexact (macro-cpxnum-imag x)))))
2975 (define-prim (exact->inexact x)
2976 (macro-force-vars (x)
2977 (##exact->inexact x)))
2979 (define-prim (##inexact->exact x)
2981 (define (type-error)
2982 (##fail-check-number 1 inexact->exact x))
2984 (define (range-error)
2985 (##raise-range-exception 1 inexact->exact x))
2987 (macro-number-dispatch x (type-error)
2988 x
2989 x
2990 x
2991 (if (macro-flonum-rational? x)
2992 (##flonum.inexact->exact x)
2993 (range-error))
2994 (let ((real (macro-cpxnum-real x))
2995 (imag (macro-cpxnum-imag x)))
2996 (if (and (macro-noncpxnum-rational? real)
2997 (macro-noncpxnum-rational? imag))
2998 (##make-rectangular (##inexact->exact real)
2999 (##inexact->exact imag))
3000 (range-error)))))
3002 (define-prim (inexact->exact x)
3003 (macro-force-vars (x)
3004 (##inexact->exact x)))
3006 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3008 ;;; number->string, string->number
3010 (define-prim (##exact-int.number->string x rad force-sign?)
3012 (##define-macro (macro-make-block-size)
3013 (let* ((max-rad 16)
3014 (t (make-vector (+ max-rad 1) 0)))
3016 (define max-fixnum 536870911) ;; OK to be conservative
3018 (define (block-size-for rad)
3019 (let loop ((i 0) (rad^i 1))
3020 (let ((new-rad^i (* rad^i rad)))
3021 (if (<= new-rad^i max-fixnum)
3022 (loop (+ i 1) new-rad^i)
3023 i))))
3025 (let loop ((i max-rad))
3026 (if (< 1 i)
3027 (begin
3028 (vector-set! t i (block-size-for i))
3029 (loop (- i 1)))))
3031 `',t))
3033 (define block-size (macro-make-block-size))
3035 (##define-macro (macro-make-rad^block-size)
3036 (let* ((max-rad 16)
3037 (t (make-vector (+ max-rad 1) 0)))
3039 (define max-fixnum 536870911) ;; OK to be conservative
3041 (define (rad^block-size-for rad)
3042 (let loop ((i 0) (rad^i 1))
3043 (let ((new-rad^i (* rad^i rad)))
3044 (if (<= new-rad^i max-fixnum)
3045 (loop (+ i 1) new-rad^i)
3046 rad^i))))
3048 (let loop ((i max-rad))
3049 (if (< 1 i)
3050 (begin
3051 (vector-set! t i (rad^block-size-for i))
3052 (loop (- i 1)))))
3054 `',t))
3056 (define rad^block-size (macro-make-rad^block-size))
3058 (define (make-string-from-last-fixnum rad x len pos)
3059 (let loop ((x x) (len len) (pos pos))
3060 (if (##fixnum.= x 0)
3061 (##make-string len)
3062 (let* ((new-pos
3063 (##fixnum.+ pos 1))
3064 (s
3065 (loop (##fixnum.quotient x rad)
3066 (##fixnum.+ len 1)
3067 new-pos)))
3068 (##string-set!
3069 s
3070 (##fixnum.- (##string-length s) new-pos)
3071 (##string-ref ##digit-to-char-table
3072 (##fixnum.- (##fixnum.remainder x rad))))
3073 s))))
3075 (define (convert-non-last-fixnum s rad x pos)
3076 (let loop ((x x)
3077 (size (##vector-ref block-size rad))
3078 (i (##fixnum.- (##string-length s) pos)))
3079 (if (##fixnum.< 0 size)
3080 (let ((new-i (##fixnum.- i 1)))
3081 (##string-set!
3082 s
3083 new-i
3084 (##string-ref ##digit-to-char-table
3085 (##fixnum.remainder x rad)))
3086 (loop (##fixnum.quotient x rad)
3087 (##fixnum.- size 1)
3088 new-i)))))
3090 (define (make-string-from-fixnums rad lst len pos)
3091 (let loop ((lst lst) (pos pos))
3092 (let ((new-lst (##cdr lst)))
3093 (if (##null? new-lst)
3094 (make-string-from-last-fixnum
3095 rad
3096 (##fixnum.- (##car lst))
3097 (##fixnum.+ len pos)
3098 pos)
3099 (let* ((size
3100 (##vector-ref block-size rad))
3101 (new-pos
3102 (##fixnum.+ pos size))
3103 (s
3104 (loop new-lst new-pos)))
3105 (convert-non-last-fixnum s rad (##car lst) pos)
3106 s)))))
3108 (define (uinteger->fixnums level sqs x lst)
3109 (cond ((and (##null? lst) (##eq? x 0))
3110 lst)
3111 ((##fixnum.= level 0)
3112 (##cons x lst))
3113 (else
3114 (let* ((qr (##exact-int.div x (##car sqs)))
3115 (new-level (##fixnum.- level 1))
3116 (new-sqs (##cdr sqs))
3117 (q (##car qr))
3118 (r (##cdr qr)))
3119 (uinteger->fixnums
3120 new-level
3121 new-sqs
3122 r
3123 (uinteger->fixnums new-level new-sqs q lst))))))
3125 (define (uinteger->string x rad len)
3126 (make-string-from-fixnums
3127 rad
3128 (let ((rad^size
3129 (##vector-ref rad^block-size rad))
3130 (x-length
3131 (##integer-length x)))
3132 (let loop ((level 0)
3133 (sqs '())
3134 (rad^size^2^level rad^size))
3135 (let ((new-level
3136 (##fixnum.+ level 1))
3137 (new-sqs
3138 (##cons rad^size^2^level sqs)))
3139 (if (##fixnum.< x-length
3140 (##fixnum.-
3141 (##fixnum.* (##integer-length rad^size^2^level) 2)
3142 1))
3143 (uinteger->fixnums new-level new-sqs x '())
3144 (let ((new-rad^size^2^level
3145 (##exact-int.square rad^size^2^level)))
3146 (if (##< x new-rad^size^2^level)
3147 (uinteger->fixnums new-level new-sqs x '())
3148 (loop new-level
3149 new-sqs
3150 new-rad^size^2^level)))))))
3151 len
3152 0))
3154 (if (##fixnum? x)
3156 (cond ((##fixnum.negative? x)
3157 (let ((s (make-string-from-last-fixnum rad x 1 0)))
3158 (##string-set! s 0 #\-)
3159 s))
3160 ((##fixnum.zero? x)
3161 (if force-sign?
3162 (##string #\+ #\0)
3163 (##string #\0)))
3164 (else
3165 (if force-sign?
3166 (let ((s (make-string-from-last-fixnum rad (##fixnum.- x) 1 0)))
3167 (##string-set! s 0 #\+)
3168 s)
3169 (make-string-from-last-fixnum rad (##fixnum.- x) 0 0))))
3171 (cond ((##bignum.negative? x)
3172 (let ((s (uinteger->string (##negate x) rad 1)))
3173 (##string-set! s 0 #\-)
3174 s))
3175 (else
3176 (if force-sign?
3177 (let ((s (uinteger->string x rad 1)))
3178 (##string-set! s 0 #\+)
3179 s)
3180 (uinteger->string x rad 0))))))
3182 (define ##digit-to-char-table "0123456789abcdefghijklmnopqrstuvwxyz")
3184 (define-prim (##ratnum.number->string x rad force-sign?)
3185 (##string-append
3186 (##exact-int.number->string (macro-ratnum-numerator x) rad force-sign?)
3187 "/"
3188 (##exact-int.number->string (macro-ratnum-denominator x) rad #f)))
3190 (##define-macro (macro-r6rs-fp-syntax) #t)
3191 (##define-macro (macro-chez-fp-syntax) #f)
3193 (##define-macro (macro-make-10^constants)
3194 (define n 326)
3195 (let ((v (make-vector n)))
3196 (let loop ((i 0) (x 1))
3197 (if (< i n)
3198 (begin
3199 (vector-set! v i x)
3200 (loop (+ i 1) (* x 10)))))
3201 `',v))
3203 (define ##10^-constants
3204 (if (use-fast-bignum-algorithms)
3205 (macro-make-10^constants)
3206 #f))
3208 (define-prim (##flonum.printout v sign-prefix)
3210 ;; This algorithm is derived from the paper "Printing Floating-Point
3211 ;; Numbers Quickly and Accurately" by Robert G. Burger and R. Kent Dybvig,
3212 ;; SIGPLAN'96 Conference on Programming Language Design an Implementation.
3214 ;; v is a flonum
3215 ;; f is an exact integer (fixnum or bignum)
3216 ;; e is an exact integer (fixnum only)
3218 (define (10^ n) ;; 0 <= n < 326
3219 (if (use-fast-bignum-algorithms)
3220 (##vector-ref ##10^-constants n)
3221 (##expt 10 n)))
3223 (define (base-10-log x)
3224 (##define-macro (1/log10) `',(/ (log 10)))
3225 (##flonum.* (##flonum.log x) (1/log10)))
3227 (##define-macro (epsilon)
3228 1e-10)
3230 (define (scale r s m+ m- round? v)
3232 ;; r is an exact integer (fixnum or bignum)
3233 ;; s is an exact integer (fixnum or bignum)
3234 ;; m+ is an exact integer (fixnum or bignum)
3235 ;; m- is an exact integer (fixnum or bignum)
3236 ;; round? is a boolean
3237 ;; v is a flonum
3239 (let ((est
3240 (##flonum->fixnum
3241 (##flonum.ceiling (##flonum.- (base-10-log v) (epsilon))))))
3242 (if (##fixnum.negative? est)
3243 (let ((factor (10^ (##fixnum.- est))))
3244 (fixup (##* r factor)
3245 s
3246 (##* m+ factor)
3247 (##* m- factor)
3248 est
3249 round?))
3250 (let ((factor (10^ est)))
3251 (fixup r
3252 (##* s factor)
3253 m+
3254 m-
3255 est
3256 round?)))))
3258 (define (fixup r s m+ m- k round?)
3259 (if (if round?
3260 (##not (##< (##+ r m+) s))
3261 (##< s (##+ r m+)))
3262 (##cons (##fixnum.+ k 1)
3263 (generate r
3264 s
3265 m+
3266 m-
3267 round?
3268 0))
3269 (##cons k
3270 (generate (##* r 10)
3271 s
3272 (##* m+ 10)
3273 (##* m- 10)
3274 round?
3275 0))))
3277 (define (generate r s m+ m- round? n)
3278 (let* ((dr (##exact-int.div r s))
3279 (d (##car dr))
3280 (r (##cdr dr))
3281 (tc (if round?
3282 (##not (##< (##+ r m+) s))
3283 (##< s (##+ r m+)))))
3284 (if (if round? (##not (##< m- r)) (##< r m-))
3285 (let* ((last-digit
3286 (if tc
3287 (let ((r*2 (##arithmetic-shift r 1)))
3288 (if (or (and (##fixnum.even? d)
3289 (##= r*2 s)) ;; tie, round d to even
3290 (##< r*2 s))
3291 d
3292 (##fixnum.+ d 1)))
3293 d))
3294 (str
3295 (##make-string (##fixnum.+ n 1))))
3296 (##string-set!
3297 str
3298 n
3299 (##string-ref ##digit-to-char-table last-digit))
3300 str)
3301 (if tc
3302 (let ((str
3303 (##make-string (##fixnum.+ n 1))))
3304 (##string-set!
3305 str
3306 n
3307 (##string-ref ##digit-to-char-table (##fixnum.+ d 1)))
3308 str)
3309 (let ((str
3310 (generate (##* r 10)
3311 s
3312 (##* m+ 10)
3313 (##* m- 10)
3314 round?
3315 (##fixnum.+ n 1))))
3316 (##string-set!
3317 str
3318 n
3319 (##string-ref ##digit-to-char-table d))
3320 str)))))
3322 (define (flonum->exponent-and-digits v)
3323 (let* ((x (##flonum.->exact-exponential-format v))
3324 (f (##vector-ref x 0))
3325 (e (##vector-ref x 1))
3326 (round? (##not (##odd? f))))
3327 (if (##fixnum.negative? e)
3328 (if (and (##not (##fixnum.= e (macro-flonum-e-min)))
3329 (##= f (macro-flonum-+m-min)))
3330 (scale (##arithmetic-shift f 2)
3331 (##arithmetic-shift 1 (##fixnum.- 2 e))
3332 2
3333 1
3334 round?
3335 v)
3336 (scale (##arithmetic-shift f 1)
3337 (##arithmetic-shift 1 (##fixnum.- 1 e))
3338 1
3339 1
3340 round?
3341 v))
3342 (let ((2^e (##arithmetic-shift 1 e)))
3343 (if (##= f (macro-flonum-+m-min))
3344 (scale (##arithmetic-shift f (##fixnum.+ e 2))
3345 4
3346 (##arithmetic-shift 1 (##fixnum.+ e 1))
3347 2^e
3348 round?
3349 v)
3350 (scale (##arithmetic-shift f (##fixnum.+ e 1))
3351 2
3352 2^e
3353 2^e
3354 round?
3355 v))))))
3357 (let* ((x (flonum->exponent-and-digits v))
3358 (e (##car x))
3359 (d (##cdr x)) ;; d = digits
3360 (n (##string-length d))) ;; n = number of digits
3362 (cond ((and (##not (##fixnum.< e 0)) ;; 0<=e<=10
3363 (##not (##fixnum.< 10 e)))
3365 (cond ((##fixnum.= e 0) ;; e=0
3367 ;; Format 1: .DDD (0.DDD in chez-fp-syntax)
3369 (##string-append sign-prefix
3370 (if (macro-chez-fp-syntax) "0." ".")
3371 d))
3373 ((##fixnum.< e n) ;; e<n
3375 ;; Format 2: D.DDD up to DDD.D
3377 (##string-append sign-prefix
3378 (##substring d 0 e)
3379 "."
3380 (##substring d e n)))
3382 ((##fixnum.= e n) ;; e=n
3384 ;; Format 3: DDD. (DDD.0 in chez-fp-syntax)
3386 (##string-append sign-prefix
3387 d
3388 (if (macro-chez-fp-syntax) ".0" ".")))
3390 (else ;; e>n
3392 ;; Format 4: DDD000000. (DDD000000.0 in chez-fp-syntax)
3394 (##string-append sign-prefix
3395 d
3396 (##make-string (##fixnum.- e n) #\0)
3397 (if (macro-chez-fp-syntax) ".0" ".")))))
3399 ((and (##not (##fixnum.< e -2)) ;; -2<=e<=-1
3400 (##not (##fixnum.< -1 e)))
3402 ;; Format 5: .0DDD or .00DDD (0.0DDD or 0.00DDD in chez-fp-syntax)
3404 (##string-append sign-prefix
3405 (if (macro-chez-fp-syntax) "0." ".")
3406 (##make-string (##fixnum.- e) #\0)
3407 d))
3409 (else
3411 ;; Format 6: D.DDDeEEE
3412 ;;
3413 ;; This is the most general format. We insert a period after
3414 ;; the first digit (unless there is only one digit) and add
3415 ;; an exponent.
3417 (##string-append sign-prefix
3418 (##substring d 0 1)
3419 (if (##fixnum.= n 1) "" ".")
3420 (##substring d 1 n)
3421 "e"
3422 (##number->string (##fixnum.- e 1) 10))))))
3424 (define-prim (##flonum.number->string x rad force-sign?)
3426 (define (non-neg-num->str x rad sign-prefix)
3427 (if (##flonum.zero? x)
3428 (##string-append sign-prefix (if (macro-chez-fp-syntax) "0.0" "0."))
3429 (##flonum.printout x sign-prefix)))
3431 (cond ((##flonum.nan? x)
3432 (##string-copy (if (or (macro-r6rs-fp-syntax)
3433 (macro-chez-fp-syntax))
3434 "+nan.0"
3435 "+nan.")))
3436 ((##flonum.negative? (##flonum.copysign (macro-inexact-+1) x))
3437 (let ((abs-x (##flonum.copysign x (macro-inexact-+1))))
3438 (cond ((##flonum.= abs-x (macro-inexact-+inf))
3439 (##string-copy (if (or (macro-r6rs-fp-syntax)
3440 (macro-chez-fp-syntax))
3441 "-inf.0"
3442 "-inf.")))
3443 (else
3444 (non-neg-num->str abs-x rad "-")))))
3445 (else
3446 (cond ((##flonum.= x (macro-inexact-+inf))
3447 (##string-copy (if (or (macro-r6rs-fp-syntax)
3448 (macro-chez-fp-syntax))
3449 "+inf.0"
3450 "+inf.")))
3451 (force-sign?
3452 (non-neg-num->str x rad "+"))
3453 (else
3454 (non-neg-num->str x rad ""))))))
3456 (define-prim (##cpxnum.number->string x rad force-sign?)
3457 (let* ((real
3458 (macro-cpxnum-real x))
3459 (real-str
3460 (if (##eq? real 0) "" (##number->string real rad force-sign?))))
3461 (let ((imag (macro-cpxnum-imag x)))
3462 (cond ((##eq? imag 1)
3463 (##string-append real-str "+i"))
3464 ((##eq? imag -1)
3465 (##string-append real-str "-i"))
3466 (else
3467 (##string-append real-str
3468 (##number->string imag rad #t)
3469 "i"))))))
3471 (define-prim (##number->string x #!optional (rad 10) (force-sign? #f))
3472 (macro-number-dispatch x '()
3473 (##exact-int.number->string x rad force-sign?)
3474 (##exact-int.number->string x rad force-sign?)
3475 (##ratnum.number->string x rad force-sign?)
3476 (##flonum.number->string x rad force-sign?)
3477 (##cpxnum.number->string x rad force-sign?)))
3479 (define-prim (number->string n #!optional (r (macro-absent-obj)))
3480 (macro-force-vars (n r)
3481 (let ((rad (if (##eq? r (macro-absent-obj)) 10 r)))
3482 (if (macro-exact-int? rad)
3483 (if (or (##eq? rad 2)
3484 (##eq? rad 8)
3485 (##eq? rad 10)
3486 (##eq? rad 16))
3487 (let ((result (##number->string n rad #f)))
3488 (if (##null? result)
3489 (##fail-check-number 1 number->string n r)
3490 result))
3491 (##raise-range-exception 2 number->string n r))
3492 (##fail-check-exact-integer 2 number->string n r)))))
3494 (##define-macro (macro-make-char-to-digit-table)
3495 (let ((t (make-vector 128 99)))
3496 (vector-set! t (char->integer #\#) 0) ;; #\# counts as 0
3497 (let loop1 ((i 9))
3498 (if (not (< i 0))
3499 (begin
3500 (vector-set! t (+ (char->integer #\0) i) i)
3501 (loop1 (- i 1)))))
3502 (let loop2 ((i 25))
3503 (if (not (< i 0))
3504 (begin
3505 (vector-set! t (+ (char->integer #\A) i) (+ i 10))
3506 (vector-set! t (+ (char->integer #\a) i) (+ i 10))
3507 (loop2 (- i 1)))))
3508 `',(list->u8vector (vector->list t))))
3510 (define ##char-to-digit-table (macro-make-char-to-digit-table))
3512 (define-prim (##string->number str #!optional (rad 10) (check-only? #f))
3514 ;; The number grammar parsed by this procedure is:
3515 ;;
3516 ;; <num R E> : <prefix R E> <complex R E>
3517 ;;
3518 ;; <complex R E> : <real R E>
3519 ;; | <real R E> @ <real R E>
3520 ;; | <real R E> <sign> <ureal R> i
3521 ;; | <real R E> <sign-inf-nan R E> i
3522 ;; | <real R E> <sign> i
3523 ;; | <sign> <ureal R> i
3524 ;; | <sign-inf-nan R E> i
3525 ;; | <sign> i
3526 ;;
3527 ;; <real R E> : <ureal R>
3528 ;; | <sign> <ureal R>
3529 ;; | <sign-inf-nan R E>
3530 ;;
3531 ;; <sign-inf-nan R i> : +inf.0
3532 ;; | -inf.0
3533 ;; | +nan.0
3534 ;; <sign-inf-nan R empty> : <sign-inf-nan R i>
3535 ;;
3536 ;; <ureal R> : <uinteger R>
3537 ;; | <uinteger R> / <uinteger R>
3538 ;; | <decimal R>
3539 ;;
3540 ;; <decimal 10> : <uinteger 10> <suffix>
3541 ;; | . <digit 10>+ #* <suffix>
3542 ;; | <digit 10>+ . <digit 10>* #* <suffix>
3543 ;; | <digit 10>+ #+ . #* <suffix>
3544 ;;
3545 ;; <uinteger R> : <digit R>+ #*
3546 ;;
3547 ;; <prefix R E> : <radix R E> <exactness E>
3548 ;; | <exactness E> <radix R E>
3549 ;;
3550 ;; <suffix> : <empty>
3551 ;; | <exponent marker> <digit 10>+
3552 ;; | <exponent marker> <sign> <digit 10>+
3553 ;;
3554 ;; <exponent marker> : e | s | f | d | l
3555 ;; <sign> : + | -
3556 ;; <exactness empty> : <empty>
3557 ;; <exactness i> : #i
3558 ;; <exactness e> : #e
3559 ;; <radix 2> : #b
3560 ;; <radix 8> : #o
3561 ;; <radix 10> : <empty> | #d
3562 ;; <radix 16> : #x
3563 ;; <digit 2> : 0 | 1
3564 ;; <digit 8> : 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7
3565 ;; <digit 10> : 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
3566 ;; <digit 16> : <digit 10> | a | b | c | d | e | f
3568 (##define-macro (macro-make-exact-10^n-table)
3570 (define max-exact-power-of-10 22) ;; (floor (inexact->exact (/ (log (expt 2 (macro-flonum-m-bits-plus-1))) (log 5))))
3572 (let ((t (make-vector (+ max-exact-power-of-10 1))))
3574 (let loop ((i max-exact-power-of-10))
3575 (if (not (< i 0))
3576 (begin
3577 (vector-set! t i (exact->inexact (expt 10 i)))
3578 (loop (- i 1)))))
3580 `',(list->f64vector (vector->list t))))
3582 (define exact-10^n-table (macro-make-exact-10^n-table))
3584 (##define-macro (macro-make-block-size)
3585 (let* ((max-rad 16)
3586 (t (make-vector (+ max-rad 1) 0)))
3588 (define max-fixnum 536870911) ;; OK to be conservative
3590 (define (block-size-for rad)
3591 (let loop ((i 0) (rad^i 1))
3592 (let ((new-rad^i (* rad^i rad)))
3593 (if (<= new-rad^i max-fixnum)
3594 (loop (+ i 1) new-rad^i)
3595 i))))
3597 (let loop ((i max-rad))
3598 (if (< 1 i)
3599 (begin
3600 (vector-set! t i (block-size-for i))
3601 (loop (- i 1)))))
3603 `',t))
3605 (define block-size (macro-make-block-size))
3607 (##define-macro (macro-make-rad^block-size)
3608 (let* ((max-rad 16)
3609 (t (make-vector (+ max-rad 1) 0)))
3611 (define max-fixnum 536870911) ;; OK to be conservative
3613 (define (rad^block-size-for rad)
3614 (let loop ((i 0) (rad^i 1))
3615 (let ((new-rad^i (* rad^i rad)))
3616 (if (<= new-rad^i max-fixnum)
3617 (loop (+ i 1) new-rad^i)
3618 rad^i))))
3620 (let loop ((i max-rad))
3621 (if (< 1 i)
3622 (begin
3623 (vector-set! t i (rad^block-size-for i))
3624 (loop (- i 1)))))
3626 `',t))
3628 (define rad^block-size (macro-make-rad^block-size))
3630 (define (substring->uinteger-fixnum str rad i j)
3632 ;; Simple case: result is known to fit in a fixnum.
3634 (let loop ((i i) (n 0))
3635 (if (##fixnum.< i j)
3636 (let ((c (##string-ref str i)))
3637 (if (##char<? c 128)
3638 (loop (##fixnum.+ i 1)
3639 (##fixnum.+ (##fixnum.* n rad)
3640 (##u8vector-ref ##char-to-digit-table c)))
3641 (loop (##fixnum.+ i 1)
3642 (##fixnum.* n rad))))
3643 n)))
3645 (define (substring->uinteger-aux sqs width str rad i j)
3647 ;; Divide-and-conquer algorithm (fast for large bignums if bignum
3648 ;; multiplication is fast).
3650 (if (##null? sqs)
3651 (substring->uinteger-fixnum str rad i j)
3652 (let* ((new-sqs (##cdr sqs))
3653 (new-width (##fixnum.quotient width 2))
3654 (mid (##fixnum.- j new-width)))
3655 (if (##fixnum.< i mid)
3656 (let* ((a (substring->uinteger-aux new-sqs new-width str rad i mid))
3657 (b (substring->uinteger-aux new-sqs new-width str rad mid j)))
3658 (##+ (##* a (##car sqs)) b))
3659 (substring->uinteger-aux new-sqs new-width str rad i j)))))
3661 (define (squares rad n)
3662 (let loop ((rad rad) (n n) (lst '()))
3663 (if (##fixnum.= n 1)
3664 (##cons rad lst)
3665 (loop (##exact-int.square rad)
3666 (##fixnum.- n 1)
3667 (##cons rad lst)))))
3669 (define (substring->uinteger str rad i j)
3671 ;; Converts a substring into an unsigned integer. Selects a fast
3672 ;; conversion algorithm when result fits in a fixnum.
3674 (let ((len (##fixnum.- j i))
3675 (size (##vector-ref block-size rad)))
3676 (if (##fixnum.< size len)
3677 (let ((levels
3678 (##integer-length (##fixnum.quotient (##fixnum.- len 1) size))))
3679 (substring->uinteger-aux
3680 (squares (##vector-ref rad^block-size rad) levels)
3681 (##fixnum.arithmetic-shift-left size levels)
3682 str
3683 rad
3684 i
3685 j))
3686 (substring->uinteger-fixnum str rad i j))))
3688 (define (float-substring->uinteger str i j)
3690 ;; Converts a substring containing the decimals of a floating-point
3691 ;; number into an unsigned integer (any period is simply skipped).
3693 (let loop1 ((i i) (n 0))
3694 (if (##not (##fixnum.< i j))
3695 n
3696 (let ((c (##string-ref str i)))
3697 (if (##char=? c #\.)
3698 (loop1 (##fixnum.+ i 1) n)
3699 (let ((new-n
3700 (##fixnum.+ (##fixnum.* n 10)
3701 (if (##char<? c 128)
3702 (##u8vector-ref ##char-to-digit-table c)
3703 0))))
3704 (if (##fixnum.< new-n (macro-max-fixnum32-div-10))
3705 (loop1 (##fixnum.+ i 1) new-n)
3706 (let loop2 ((i i) (n n))
3707 (if (##not (##fixnum.< i j))
3708 n
3709 (let ((c (##string-ref str i)))
3710 (if (##char=? c #\.)
3711 (loop2 (##fixnum.+ i 1) n)
3712 (let ((new-n
3713 (##+
3714 (##* n 10)
3715 (if (##char<? c 128)
3716 (##u8vector-ref ##char-to-digit-table c)
3717 0))))
3718 (loop2 (##fixnum.+ i 1) new-n)))))))))))))
3720 (define (uinteger str rad i)
3721 (and (##fixnum.< i (##string-length str))
3722 (let ((c (##string-ref str i)))
3723 (and (##char<? c 128)
3724 (##not (##char=? c #\#))
3725 (##fixnum.< (##u8vector-ref ##char-to-digit-table c) rad)
3726 (digits-and-sharps str rad (##fixnum.+ i 1))))))
3728 (define (digits-and-sharps str rad i)
3729 (let loop ((i i))
3730 (if (##fixnum.< i (##string-length str))
3731 (let ((c (##string-ref str i)))
3732 (if (##char<? c 128)
3733 (if (##char=? c #\#)
3734 (sharps str (##fixnum.+ i 1))
3735 (if (##fixnum.< (##u8vector-ref ##char-to-digit-table c) rad)
3736 (loop (##fixnum.+ i 1))
3737 i))
3738 i))
3739 i)))
3741 (define (sharps str i)
3742 (let loop ((i i))
3743 (if (##fixnum.< i (##string-length str))
3744 (if (##char=? (##string-ref str i) #\#)
3745 (loop (##fixnum.+ i 1))
3746 i)
3747 i)))
3749 (define (suffix str i1)
3750 (if (##fixnum.< (##fixnum.+ i1 1) (##string-length str))
3751 (let ((c1 (##string-ref str i1)))
3752 (if (or (##char=? c1 #\e) (##char=? c1 #\E)
3753 (##char=? c1 #\s) (##char=? c1 #\S)
3754 (##char=? c1 #\f) (##char=? c1 #\F)
3755 (##char=? c1 #\d) (##char=? c1 #\D)
3756 (##char=? c1 #\l) (##char=? c1 #\L))
3757 (let ((c2 (##string-ref str (##fixnum.+ i1 1))))
3758 (let ((i2
3759 (if (or (##char=? c2 #\+) (##char=? c2 #\-))
3760 (uinteger str 10 (##fixnum.+ i1 2))
3761 (uinteger str 10 (##fixnum.+ i1 1)))))
3762 (if (and i2
3763 (##not (##char=? (##string-ref str (##fixnum.- i2 1))
3764 #\#)))
3765 i2
3766 i1)))
3767 i1))
3768 i1))
3770 (define (ureal str rad e i1)
3771 (let ((i2 (uinteger str rad i1)))
3772 (if i2
3773 (if (##fixnum.< i2 (##string-length str))
3774 (let ((c (##string-ref str i2)))
3775 (cond ((##char=? c #\/)
3776 (let ((i3 (uinteger str rad (##fixnum.+ i2 1))))
3777 (and i3
3778 (let ((inexact-num?
3779 (or (##eq? e 'i)
3780 (and (##not e)
3781 (or (##char=? (##string-ref
3782 str
3783 (##fixnum.- i2 1))
3784 #\#)
3785 (##char=? (##string-ref
3786 str
3787 (##fixnum.- i3 1))
3788 #\#))))))
3789 (if (and (##not inexact-num?)
3790 (##eq? (substring->uinteger
3791 str
3792 rad
3793 (##fixnum.+ i2 1)
3794 i3)
3795 0))
3796 #f
3797 (##vector i3 i2))))))
3798 ((##fixnum.= rad 10)
3799 (if (##char=? c #\.)
3800 (let ((i3
3801 (if (##char=? (##string-ref str (##fixnum.- i2 1))
3802 #\#)
3803 (sharps str (##fixnum.+ i2 1))
3804 (digits-and-sharps str 10 (##fixnum.+ i2 1)))))
3805 (and i3
3806 (let ((i4 (suffix str i3)))
3807 (##vector i4 i3 i2))))
3808 (let ((i3 (suffix str i2)))
3809 (if (##fixnum.= i2 i3)
3810 i2
3811 (##vector i3 i2 i2)))))
3812 (else
3813 i2)))
3814 i2)
3815 (and (##fixnum.= rad 10)
3816 (##fixnum.< i1 (##string-length str))
3817 (##char=? (##string-ref str i1) #\.)
3818 (let ((i3 (uinteger str rad (##fixnum.+ i1 1))))
3819 (and i3
3820 (let ((i4 (suffix str i3)))
3821 (##vector i4 i3 i1))))))))
3823 (define (inf-nan str sign i e)
3824 (and (##not (##eq? e 'e))
3825 (if (##fixnum.< (##fixnum.+ i (if (or (macro-r6rs-fp-syntax)
3826 (macro-chez-fp-syntax))
3827 4
3828 3))
3829 (##string-length str))
3830 (and (##char=? (##string-ref str (##fixnum.+ i 3)) #\.)
3831 (if (or (macro-r6rs-fp-syntax)
3832 (macro-chez-fp-syntax))
3833 (##char=? (##string-ref str (##fixnum.+ i 4)) #\0)
3834 #t)
3835 (or (and (let ((c (##string-ref str i)))
3836 (or (##char=? c #\i) (##char=? c #\I)))
3837 (let ((c (##string-ref str (##fixnum.+ i 1))))
3838 (or (##char=? c #\n) (##char=? c #\N)))
3839 (let ((c (##string-ref str (##fixnum.+ i 2))))
3840 (or (##char=? c #\f) (##char=? c #\F))))
3841 (and (##not (##char=? sign #\-))
3842 (let ((c (##string-ref str i)))
3843 (or (##char=? c #\n) (##char=? c #\N)))
3844 (let ((c (##string-ref str (##fixnum.+ i 1))))
3845 (or (##char=? c #\a) (##char=? c #\A)))
3846 (let ((c (##string-ref str (##fixnum.+ i 2))))
3847 (or (##char=? c #\n) (##char=? c #\N)))))
3848 (##vector (##fixnum.+ i (if (or (macro-r6rs-fp-syntax)
3849 (macro-chez-fp-syntax))
3850 5
3851 4))))
3852 #f)))
3854 (define (make-rec x y)
3855 (##make-rectangular x y))
3857 (define (make-pol x y e)
3858 (let ((n (##make-polar x y)))
3859 (if (##eq? e 'e)
3860 (##inexact->exact n)
3861 n)))
3863 (define (make-inexact-real sign uinteger exponent)
3864 (let ((n
3865 (if (and (##fixnum? uinteger)
3866 (##flonum.<-fixnum-exact? uinteger)
3867 (##fixnum? exponent)
3868 (##fixnum.< (##fixnum.- exponent)
3869 (##f64vector-length exact-10^n-table))
3870 (##fixnum.< exponent
3871 (##f64vector-length exact-10^n-table)))
3872 (if (##fixnum.< exponent 0)
3873 (##flonum./ (##flonum.<-fixnum uinteger)
3874 (##f64vector-ref exact-10^n-table
3875 (##fixnum.- exponent)))
3876 (##flonum.* (##flonum.<-fixnum uinteger)
3877 (##f64vector-ref exact-10^n-table
3878 exponent)))
3879 (##exact->inexact
3880 (##* uinteger (##expt 10 exponent))))))
3881 (if (##char=? sign #\-)
3882 (##flonum.copysign n (macro-inexact--1))
3883 n)))
3885 (define (get-zero e)
3886 (if (##eq? e 'i)
3887 (macro-inexact-+0)
3888 0))
3890 (define (get-one sign e)
3891 (if (##eq? e 'i)
3892 (if (##char=? sign #\-) (macro-inexact--1) (macro-inexact-+1))
3893 (if (##char=? sign #\-) -1 1)))
3895 (define (get-real start sign str rad e i)
3896 (if (##fixnum? i)
3897 (let* ((abs-n
3898 (substring->uinteger str rad start i))
3899 (n
3900 (if (##char=? sign #\-)
3901 (##negate abs-n)
3902 abs-n)))
3903 (if (or (##eq? e 'i)
3904 (and (##not e)
3905 (##char=? (##string-ref str (##fixnum.- i 1)) #\#)))
3906 (##exact->inexact n)
3907 n))
3908 (let ((j (##vector-ref i 0))
3909 (len (##vector-length i)))
3910 (cond ((##fixnum.= len 3) ;; xxx.yyyEzzz
3911 (let* ((after-frac-part
3912 (##vector-ref i 1))
3913 (unadjusted-exponent
3914 (if (##fixnum.= after-frac-part j) ;; no exponent part?
3915 0
3916 (let* ((c
3917 (##string-ref
3918 str
3919 (##fixnum.+ after-frac-part 1)))
3920 (n
3921 (substring->uinteger
3922 str
3923 10
3924 (if (or (##char=? c #\+) (##char=? c #\-))
3925 (##fixnum.+ after-frac-part 2)
3926 (##fixnum.+ after-frac-part 1))
3927 j)))
3928 (if (##char=? c #\-)
3929 (##negate n)
3930 n))))
3931 (c
3932 (##string-ref str start))
3933 (uinteger
3934 (float-substring->uinteger str start after-frac-part))
3935 (decimals-after-point
3936 (##fixnum.-
3937 (##fixnum.- after-frac-part (##vector-ref i 2))
3938 1))
3939 (exponent
3940 (if (##fixnum.< 0 decimals-after-point)
3941 (if (and (##fixnum? unadjusted-exponent)
3942 (##fixnum.< (##fixnum.- unadjusted-exponent
3943 decimals-after-point)
3944 unadjusted-exponent))
3945 (##fixnum.- unadjusted-exponent
3946 decimals-after-point)
3947 (##- unadjusted-exponent
3948 decimals-after-point))
3949 unadjusted-exponent)))
3950 (if (##eq? e 'e)
3951 (##*
3952 (if (##char=? sign #\-)
3953 (##negate uinteger)
3954 uinteger)
3955 (##expt 10 exponent))
3956 (make-inexact-real sign uinteger exponent))))
3957 ((##fixnum.= len 2) ;; xxx/yyy
3958 (let* ((after-num
3959 (##vector-ref i 1))
3960 (inexact-num?
3961 (or (##eq? e 'i)
3962 (and (##not e)
3963 (or (##char=? (##string-ref
3964 str
3965 (##fixnum.- after-num 1))
3966 #\#)
3967 (##char=? (##string-ref
3968 str
3969 (##fixnum.- j 1))
3970 #\#)))))
3971 (abs-num
3972 (substring->uinteger str rad start after-num))
3973 (den
3974 (substring->uinteger str
3975 rad
3976 (##fixnum.+ after-num 1)
3977 j)))
3979 (define (num-div-den)
3980 (##/ (if (##char=? sign #\-)
3981 (##negate abs-num)
3982 abs-num)
3983 den))
3985 (if inexact-num?
3986 (if (##eq? den 0)
3987 (let ((n
3988 (if (##eq? abs-num 0)
3989 (macro-inexact-+nan)
3990 (macro-inexact-+inf))))
3991 (if (##char=? sign #\-)
3992 (##flonum.copysign n (macro-inexact--1))
3993 n))
3994 (##exact->inexact (num-div-den)))
3995 (num-div-den))))
3996 (else ;; (##fixnum.= len 1) ;; inf or nan
3997 (let* ((c
3998 (##string-ref str start))
3999 (n
4000 (if (or (##char=? c #\i) (##char=? c #\I))
4001 (macro-inexact-+inf)
4002 (macro-inexact-+nan))))
4003 (if (##char=? sign #\-)
4004 (##flonum.copysign n (macro-inexact--1))
4005 n)))))))
4007 (define (i-end str i)
4008 (and (##fixnum.= (##fixnum.+ i 1) (##string-length str))
4009 (let ((c (##string-ref str i)))
4010 (or (##char=? c #\i) (##char=? c #\I)))))
4012 (define (complex start sign str rad e i)
4013 (let ((j (if (##fixnum? i) i (##vector-ref i 0))))
4014 (let ((c (##string-ref str j)))
4015 (cond ((##char=? c #\@)
4016 (let ((j+1 (##fixnum.+ j 1)))
4017 (if (##fixnum.< j+1 (##string-length str))
4018 (let* ((sign2
4019 (##string-ref str j+1))
4020 (start2
4021 (if (or (##char=? sign2 #\+) (##char=? sign2 #\-))
4022 (##fixnum.+ j+1 1)
4023 j+1))
4024 (k
4025 (or (ureal str rad e start2)
4026 (and (##fixnum.< j+1 start2)
4027 (inf-nan str sign2 start2 e)))))
4028 (and k
4029 (let ((l (if (##fixnum? k) k (##vector-ref k 0))))
4030 (and (##fixnum.= l (##string-length str))
4031 (or check-only?
4032 (make-pol
4033 (get-real start sign str rad e i)
4034 (get-real start2 sign2 str rad e k)
4035 e))))))
4036 #f)))
4037 ((or (##char=? c #\+) (##char=? c #\-))
4038 (let* ((start2
4039 (##fixnum.+ j 1))
4040 (k
4041 (or (ureal str rad e start2)
4042 (inf-nan str c start2 e))))
4043 (if (##not k)
4044 (if (i-end str start2)
4045 (or check-only?
4046 (make-rec
4047 (get-real start sign str rad e i)
4048 (get-one c e)))
4049 #f)
4050 (let ((l (if (##fixnum? k) k (##vector-ref k 0))))
4051 (and (i-end str l)
4052 (or check-only?
4053 (make-rec
4054 (get-real start sign str rad e i)
4055 (get-real start2 c str rad e k))))))))
4056 (else
4057 #f)))))
4059 (define (after-prefix start str rad e)
4061 ;; invariant: start = 0, 2 or 4, (string-length str) > start
4063 (let ((c (##string-ref str start)))
4064 (if (or (##char=? c #\+) (##char=? c #\-))
4065 (let ((i (or (ureal str rad e (##fixnum.+ start 1))
4066 (inf-nan str c (##fixnum.+ start 1) e))))
4067 (if (##not i)
4068 (if (i-end str (##fixnum.+ start 1))
4069 (or check-only?
4070 (make-rec
4071 (get-zero e)
4072 (get-one c e)))
4073 #f)
4074 (let ((j (if (##fixnum? i) i (##vector-ref i 0))))
4075 (cond ((##fixnum.= j (##string-length str))
4076 (or check-only?
4077 (get-real (##fixnum.+ start 1) c str rad e i)))
4078 ((i-end str j)
4079 (or check-only?
4080 (make-rec
4081 (get-zero e)
4082 (get-real (##fixnum.+ start 1) c str rad e i))))
4083 (else
4084 (complex (##fixnum.+ start 1) c str rad e i))))))
4085 (let ((i (ureal str rad e start)))
4086 (if (##not i)
4087 #f
4088 (let ((j (if (##fixnum? i) i (##vector-ref i 0))))
4089 (cond ((##fixnum.= j (##string-length str))
4090 (or check-only?
4091 (get-real start #\+ str rad e i)))
4092 (else
4093 (complex start #\+ str rad e i)))))))))
4095 (define (radix-prefix c)
4096 (cond ((or (##char=? c #\b) (##char=? c #\B)) 2)
4097 ((or (##char=? c #\o) (##char=? c #\O)) 8)
4098 ((or (##char=? c #\d) (##char=? c #\D)) 10)
4099 ((or (##char=? c #\x) (##char=? c #\X)) 16)
4100 (else #f)))
4102 (define (exactness-prefix c)
4103 (cond ((or (##char=? c #\i) (##char=? c #\I)) 'i)
4104 ((or (##char=? c #\e) (##char=? c #\E)) 'e)
4105 (else #f)))
4107 (cond ((##fixnum.< 2 (##string-length str)) ;; >= 3 chars
4108 (if (##char=? (##string-ref str 0) #\#)
4109 (let ((rad1 (radix-prefix (##string-ref str 1))))
4110 (if rad1
4111 (if (and (##fixnum.< 4 (##string-length str)) ;; >= 5 chars
4112 (##char=? (##string-ref str 2) #\#))
4113 (let ((e1 (exactness-prefix (##string-ref str 3))))
4114 (if e1
4115 (after-prefix 4 str rad1 e1)
4116 #f))
4117 (after-prefix 2 str rad1 #f))
4118 (let ((e2 (exactness-prefix (##string-ref str 1))))
4119 (if e2
4120 (if (and (##fixnum.< 4 (##string-length str)) ;; >= 5 chars
4121 (##char=? (##string-ref str 2) #\#))
4122 (let ((rad2 (radix-prefix (##string-ref str 3))))
4123 (if rad2
4124 (after-prefix 4 str rad2 e2)
4125 #f))
4126 (after-prefix 2 str rad e2))
4127 #f))))
4128 (after-prefix 0 str rad #f)))
4129 ((##fixnum.< 0 (##string-length str)) ;; >= 1 char
4130 (after-prefix 0 str rad #f))
4131 (else
4132 #f)))
4134 (define-prim (string->number str #!optional (r (macro-absent-obj)))
4135 (macro-force-vars (str r)
4136 (macro-check-string str 1 (string->number str r)
4137 (let ((rad (if (##eq? r (macro-absent-obj)) 10 r)))
4138 (if (macro-exact-int? rad)
4139 (if (or (##eq? rad 2)
4140 (##eq? rad 8)
4141 (##eq? rad 10)
4142 (##eq? rad 16))
4143 (##string->number str rad #f)
4144 (##raise-range-exception 2 string->number str r))
4145 (##fail-check-exact-integer 2 string->number str r))))))
4147 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4149 ;;; Bitwise operations.
4151 (define-prim (##bitwise-ior x y)
4153 (##define-macro (type-error-on-x) `'(1))
4154 (##define-macro (type-error-on-y) `'(2))
4156 (define (bignum-bitwise-ior x x-length y y-length)
4157 (if (##bignum.negative? x)
4158 (let ((result (##bignum.make x-length x #f)))
4159 (##declare (not interrupts-enabled))
4160 (let loop1 ((i 0))
4161 (if (##fixnum.< i x-length)
4162 (begin
4163 (##bignum.adigit-bitwise-ior! result i y i)
4164 (loop1 (##fixnum.+ i 1)))
4165 (##bignum.normalize! result))))
4166 (let ((result (##bignum.make y-length y #f)))
4167 (##declare (not interrupts-enabled))
4168 (let loop2 ((i 0))
4169 (if (##fixnum.< i x-length)
4170 (begin
4171 (##bignum.adigit-bitwise-ior! result i x i)
4172 (loop2 (##fixnum.+ i 1)))
4173 (##bignum.normalize! result))))))
4175 (cond ((##fixnum? x)
4176 (cond ((##fixnum? y)
4177 (##fixnum.bitwise-ior x y))
4178 ((##bignum? y)
4179 (let* ((x-bignum (##bignum.<-fixnum x))
4180 (x-length (##bignum.adigit-length x-bignum))
4181 (y-length (##bignum.adigit-length y)))
4182 (bignum-bitwise-ior x-bignum x-length y y-length)))
4183 (else
4184 (type-error-on-y))))
4185 ((##bignum? x)
4186 (let ((x-length (##bignum.adigit-length x)))
4187 (cond ((##fixnum? y)
4188 (let* ((y-bignum (##bignum.<-fixnum y))
4189 (y-length (##bignum.adigit-length y-bignum)))
4190 (bignum-bitwise-ior y-bignum y-length x x-length)))
4191 ((##bignum? y)
4192 (let ((y-length (##bignum.adigit-length y)))
4193 (if (##fixnum.< x-length y-length)
4194 (bignum-bitwise-ior x x-length y y-length)
4195 (bignum-bitwise-ior y y-length x x-length))))
4196 (else
4197 (type-error-on-y)))))
4198 (else
4199 (type-error-on-x))))
4201 (define-prim-nary (bitwise-ior x y)
4202 0
4203 (if (macro-exact-int? x) x '(1))
4204 (##bitwise-ior x y)
4205 macro-force-vars
4206 macro-no-check
4207 (##pair? ##fail-check-exact-integer))
4209 (define-prim (##bitwise-xor x y)
4211 (##define-macro (type-error-on-x) `'(1))
4212 (##define-macro (type-error-on-y) `'(2))
4214 (define (bignum-bitwise-xor x x-length y y-length)
4215 (let ((result (##bignum.make y-length y #f)))
4216 (##declare (not interrupts-enabled))
4217 (let loop1 ((i 0))
4218 (if (##fixnum.< i x-length)
4219 (begin
4220 (##bignum.adigit-bitwise-xor! result i x i)
4221 (loop1 (##fixnum.+ i 1)))
4222 (if (##bignum.negative? x)
4223 (let loop2 ((i i))
4224 (if (##fixnum.< i y-length)
4225 (begin
4226 (##bignum.adigit-bitwise-not! result i)
4227 (loop2 (##fixnum.+ i 1)))
4228 (##bignum.normalize! result)))
4229 (##bignum.normalize! result))))))
4231 (cond ((##fixnum? x)
4232 (cond ((##fixnum? y)
4233 (##fixnum.bitwise-xor x y))
4234 ((##bignum? y)
4235 (let* ((x-bignum (##bignum.<-fixnum x))
4236 (x-length (##bignum.adigit-length x-bignum))
4237 (y-length (##bignum.adigit-length y)))
4238 (bignum-bitwise-xor x-bignum x-length y y-length)))
4239 (else
4240 (type-error-on-y))))
4241 ((##bignum? x)
4242 (let ((x-length (##bignum.adigit-length x)))
4243 (cond ((##fixnum? y)
4244 (let* ((y-bignum (##bignum.<-fixnum y))
4245 (y-length (##bignum.adigit-length y-bignum)))
4246 (bignum-bitwise-xor y-bignum y-length x x-length)))
4247 ((##bignum? y)
4248 (let ((y-length (##bignum.adigit-length y)))
4249 (if (##fixnum.< x-length y-length)
4250 (bignum-bitwise-xor x x-length y y-length)
4251 (bignum-bitwise-xor y y-length x x-length))))
4252 (else
4253 (type-error-on-y)))))
4254 (else
4255 (type-error-on-x))))
4257 (define-prim-nary (bitwise-xor x y)
4258 0
4259 (if (macro-exact-int? x) x '(1))
4260 (##bitwise-xor x y)
4261 macro-force-vars
4262 macro-no-check
4263 (##pair? ##fail-check-exact-integer))
4265 (define-prim (##bitwise-and x y)
4267 (##define-macro (type-error-on-x) `'(1))
4268 (##define-macro (type-error-on-y) `'(2))
4270 (define (bignum-bitwise-and x x-length y y-length)
4271 (if (##bignum.negative? x)
4272 (let ((result (##bignum.make y-length y #f)))
4273 (##declare (not interrupts-enabled))
4274 (let loop1 ((i 0))
4275 (if (##fixnum.< i x-length)
4276 (begin
4277 (##bignum.adigit-bitwise-and! result i x i)
4278 (loop1 (##fixnum.+ i 1)))
4279 (##bignum.normalize! result))))
4280 (let ((result (##bignum.make x-length x #f)))
4281 (##declare (not interrupts-enabled))
4282 (let loop2 ((i 0))
4283 (if (##fixnum.< i x-length)
4284 (begin
4285 (##bignum.adigit-bitwise-and! result i y i)
4286 (loop2 (##fixnum.+ i 1)))
4287 (##bignum.normalize! result))))))
4289 (cond ((##fixnum? x)
4290 (cond ((##fixnum? y)
4291 (##fixnum.bitwise-and x y))
4292 ((##bignum? y)
4293 (let* ((x-bignum (##bignum.<-fixnum x))
4294 (x-length (##bignum.adigit-length x-bignum))
4295 (y-length (##bignum.adigit-length y)))
4296 (bignum-bitwise-and x-bignum x-length y y-length)))
4297 (else
4298 (type-error-on-y))))
4299 ((##bignum? x)
4300 (let ((x-length (##bignum.adigit-length x)))
4301 (cond ((##fixnum? y)
4302 (let* ((y-bignum (##bignum.<-fixnum y))
4303 (y-length (##bignum.adigit-length y-bignum)))
4304 (bignum-bitwise-and y-bignum y-length x x-length)))
4305 ((##bignum? y)
4306 (let ((y-length (##bignum.adigit-length y)))
4307 (if (##fixnum.< x-length y-length)
4308 (bignum-bitwise-and x x-length y y-length)
4309 (bignum-bitwise-and y y-length x x-length))))
4310 (else
4311 (type-error-on-y)))))
4312 (else
4313 (type-error-on-x))))
4315 (define-prim-nary (bitwise-and x y)
4316 -1
4317 (if (macro-exact-int? x) x '(1))
4318 (##bitwise-and x y)
4319 macro-force-vars
4320 macro-no-check
4321 (##pair? ##fail-check-exact-integer))
4323 (define-prim (##bitwise-not x)
4325 (define (type-error)
4326 (##fail-check-exact-integer 1 bitwise-not x))
4328 (cond ((##fixnum? x)
4329 (##fixnum.bitwise-not x))
4330 ((##bignum? x)
4331 (##bignum.make (##bignum.adigit-length x) x #t))
4332 (else
4333 (type-error))))
4335 (define-prim (bitwise-not x)
4336 (macro-force-vars (x)
4337 (##bitwise-not x)))
4339 (define-prim (##arithmetic-shift x y)
4341 (define (type-error-on-x)
4342 (##fail-check-exact-integer 1 arithmetic-shift x y))
4344 (define (type-error-on-y)
4345 (##fail-check-exact-integer 2 arithmetic-shift x y))
4347 (define (overflow)
4348 (##raise-heap-overflow-exception)
4349 (##arithmetic-shift x y))
4351 (define (general-fixnum-fixnum-case)
4352 (##bignum.arithmetic-shift (##bignum.<-fixnum x) y))
4354 (cond ((##fixnum? x)
4355 (cond ((##fixnum? y)
4356 (cond ((##fixnum.zero? y)
4357 x)
4358 ((##fixnum.negative? y) ;; right shift
4359 (if (##fixnum.< (##fixnum.- ##fixnum-width) y)
4360 (##fixnum.arithmetic-shift-right x (##fixnum.- y))
4361 (if (##fixnum.negative? x)
4362 -1
4363 0)))
4364 (else ;; left shift
4365 (if (##fixnum.< y ##fixnum-width)
4366 (let ((result (##fixnum.arithmetic-shift-left x y)))
4367 (if (##fixnum.=
4368 (##fixnum.arithmetic-shift-right result y)
4369 x)
4370 result
4371 (general-fixnum-fixnum-case)))
4372 (general-fixnum-fixnum-case)))))
4373 ((##bignum? y)
4374 (cond ((##fixnum.zero? x)
4375 0)
4376 ((##bignum.negative? y)
4377 (if (##fixnum.negative? x)
4378 -1
4379 0))
4380 (else
4381 (overflow))))
4382 (else
4383 (type-error-on-y))))
4384 ((##bignum? x)
4385 (cond ((##eq? y 0)
4386 x)
4387 ((##fixnum? y)
4388 (##bignum.arithmetic-shift x y))
4389 ((##bignum? y)
4390 (cond ((##bignum.negative? y)
4391 (if (##bignum.negative? x)
4392 -1
4393 0))
4394 (else
4395 (overflow))))
4396 (else
4397 (type-error-on-y))))
4398 (else
4399 (type-error-on-x))))
4401 (define-prim (arithmetic-shift x y)
4402 (macro-force-vars (x y)
4403 (##arithmetic-shift x y)))
4405 (define-prim (##bit-count x)
4407 (define (type-error)
4408 (##fail-check-exact-integer 1 bit-count x))
4410 (cond ((##fixnum? x)
4411 (##fxbit-count x))
4412 ((##bignum? x)
4413 (let ((x-length (##bignum.mdigit-length x)))
4414 (let loop ((i (##fixnum.- x-length 1))
4415 (n 0))
4416 (if (##fixnum.< i 0)
4417 (if (##bignum.negative? x)
4418 (##fixnum.- (##fixnum.* x-length ##bignum.mdigit-width) n)
4419 n)
4420 (loop (##fixnum.- i 1)
4421 (##fixnum.+ n (##fxbit-count (##bignum.mdigit-ref x i))))))))
4422 (else
4423 (type-error))))
4425 (define-prim (bit-count x)
4426 (macro-force-vars (x)
4427 (##bit-count x)))
4429 (define-prim (##integer-length x)
4431 (define (type-error)
4432 (##fail-check-exact-integer 1 integer-length x))
4434 (cond ((##fixnum? x)
4435 (##fxlength x))
4436 ((##bignum? x)
4437 (let ((x-length (##bignum.mdigit-length x)))
4438 (if (##bignum.negative? x)
4439 (let loop1 ((i (##fixnum.- x-length 1)))
4440 (let ((mdigit (##bignum.mdigit-ref x i)))
4441 (if (##fixnum.= mdigit ##bignum.mdigit-base-minus-1)
4442 (loop1 (##fixnum.- i 1))
4443 (##fixnum.+
4444 (##fxlength (##fixnum.- ##bignum.mdigit-base-minus-1 mdigit))
4445 (##fixnum.* i ##bignum.mdigit-width)))))
4446 (let loop2 ((i (##fixnum.- x-length 1)))
4447 (let ((mdigit (##bignum.mdigit-ref x i)))
4448 (if (##fixnum.= mdigit 0)
4449 (loop2 (##fixnum.- i 1))
4450 (##fixnum.+
4451 (##fxlength mdigit)
4452 (##fixnum.* i ##bignum.mdigit-width))))))))
4453 (else
4454 (type-error))))
4456 (define-prim (integer-length x)
4457 (macro-force-vars (x)
4458 (##integer-length x)))
4460 (define-prim (##bitwise-merge x y z)
4461 (##bitwise-ior (##bitwise-and (##bitwise-not x) y)
4462 (##bitwise-and x z)))
4464 (define-prim (bitwise-merge x y z)
4465 (macro-force-vars (x y z)
4466 (cond ((##not (macro-exact-int? x))
4467 (##fail-check-exact-integer 1 bitwise-merge x y z))
4468 ((##not (macro-exact-int? y))
4469 (##fail-check-exact-integer 2 bitwise-merge x y z))
4470 ((##not (macro-exact-int? z))
4471 (##fail-check-exact-integer 3 bitwise-merge x y z))
4472 (else
4473 (##bitwise-merge x y z)))))
4475 (define-prim (##bit-set? x y)
4477 (define (type-error-on-x)
4478 (##fail-check-exact-integer 1 bit-set? x y))
4480 (define (type-error-on-y)
4481 (##fail-check-exact-integer 2 bit-set? x y))
4483 (define (range-error)
4484 (##raise-range-exception 1 bit-set? x y))
4486 (cond ((##fixnum? x)
4487 (cond ((##fixnum? y)
4488 (if (##fixnum.negative? x)
4489 (range-error)
4490 (if (##fixnum.< x ##fixnum-width)
4491 (##fixnum.odd? (##fixnum.arithmetic-shift-right y x))
4492 (##fixnum.negative? y))))
4493 ((##bignum? y)
4494 (if (##fixnum.negative? x)
4495 (range-error)
4496 (let ((i (##fixnum.quotient x ##bignum.mdigit-width)))
4497 (if (##fixnum.< i (##bignum.mdigit-length y))
4498 (##fixnum.odd?
4499 (##fixnum.arithmetic-shift-right
4500 (##bignum.mdigit-ref y i)
4501 (##fixnum.modulo x ##bignum.mdigit-width)))
4502 (##bignum.negative? y)))))
4503 (else
4504 (type-error-on-y))))
4505 ((##bignum? x)
4506 (cond ((##fixnum? y)
4507 (if (##bignum.negative? x)
4508 (range-error)
4509 (##fixnum.negative? y)))
4510 ((##bignum? y)
4511 (if (##bignum.negative? x)
4512 (range-error)
4513 (##bignum.negative? y)))
4514 (else
4515 (type-error-on-y))))
4516 (else
4517 (type-error-on-x))))
4519 (define-prim (bit-set? x y)
4520 (macro-force-vars (x y)
4521 (##bit-set? x y)))
4523 (define-prim (##any-bits-set? x y)
4524 (##not (##eq? (##bitwise-and x y) 0)))
4526 (define-prim (any-bits-set? x y)
4527 (macro-force-vars (x y)
4528 (cond ((##not (macro-exact-int? x))
4529 (##fail-check-exact-integer 1 any-bits-set? x y))
4530 ((##not (macro-exact-int? y))
4531 (##fail-check-exact-integer 2 any-bits-set? x y))
4532 (else
4533 (##any-bits-set? x y)))))
4535 (define-prim (##all-bits-set? x y)
4536 (##= x (##bitwise-and x y)))
4538 (define-prim (all-bits-set? x y)
4539 (macro-force-vars (x y)
4540 (cond ((##not (macro-exact-int? x))
4541 (##fail-check-exact-integer 1 all-bits-set? x y))
4542 ((##not (macro-exact-int? y))
4543 (##fail-check-exact-integer 2 all-bits-set? x y))
4544 (else
4545 (##all-bits-set? x y)))))
4547 (define-prim (##first-bit-set x)
4549 (define (type-error)
4550 (##fail-check-exact-integer 1 first-bit-set x))
4552 (cond ((##fixnum? x)
4553 (##fxfirst-bit-set x))
4554 ((##bignum? x)
4555 (let ((x-length (##bignum.mdigit-length x)))
4556 (let loop ((i 0))
4557 (let ((mdigit (##bignum.mdigit-ref x i)))
4558 (if (##fixnum.= mdigit 0)
4559 (loop (##fixnum.+ i 1))
4560 (##fixnum.+
4561 (##fxfirst-bit-set mdigit)
4562 (##fixnum.* i ##bignum.mdigit-width)))))))
4563 (else
4564 (type-error))))
4566 (define-prim (first-bit-set x)
4567 (macro-force-vars (x)
4568 (##first-bit-set x)))
4570 (define ##extract-bit-field-fixnum-limit
4571 (##fixnum.- ##fixnum-width 1))
4573 (define-prim (##extract-bit-field size position n)
4575 ;; size and position must be nonnegative
4577 (define (fixup-top-word result size)
4578 (##declare (not interrupts-enabled))
4579 (let ((size-words (##fixnum.quotient size ##bignum.mdigit-width))
4580 (size-bits (##fixnum.remainder size ##bignum.mdigit-width)))
4581 (let loop ((i (##fixnum.- (##bignum.mdigit-length result) 1)))
4582 (cond ((##fixnum.< size-words i)
4583 (##bignum.mdigit-set! result i 0)
4584 (loop (##fixnum.- i 1)))
4585 ((##eq? size-words i)
4586 (##bignum.mdigit-set!
4587 result i
4588 (##fixnum.bitwise-and
4589 (##bignum.mdigit-ref result i)
4590 (##fixnum.bitwise-not (##fixnum.arithmetic-shift-left -1 size-bits))))
4591 (##bignum.normalize! result))
4592 (else
4593 (##bignum.normalize! result))))))
4595 (cond ((##bignum? size)
4596 (if (##negative? n)
4597 (##bignum.make ##max-fixnum #f #f) ;; generates heap overflow
4598 (##arithmetic-shift n (##- position))))
4599 ((##bignum? position)
4600 (if (##negative? n)
4601 (##extract-bit-field size 0 -1)
4602 0))
4603 ((and (##fixnum? n)
4604 (##fixnum.< size ##extract-bit-field-fixnum-limit))
4605 (##fixnum.bitwise-and (##fixnum.arithmetic-shift-right
4606 n
4607 (##fixnum.min position ##extract-bit-field-fixnum-limit))
4608 (##fixnum.bitwise-not (##fixnum.arithmetic-shift-left -1 size))))
4609 (else
4610 (let* ((n (if (##fixnum? n)
4611 (##bignum.<-fixnum n)
4612 n))
4613 (n-length (##bignum.adigit-length n))
4614 (n-negative? (##bignum.negative? n))
4615 (result-bit-size
4616 (if n-negative?
4617 size
4618 (##fixnum.min
4619 (##fixnum.- (##fixnum.* ##bignum.adigit-width
4620 n-length)
4621 position
4622 1) ;; the top bit of a nonnegative bignum is always 0
4623 size))))
4624 (if (##fixnum.<= result-bit-size 0)
4625 0
4626 (let* ((result-word-size
4627 (##fixnum.+ (##fixnum.quotient result-bit-size
4628 ##bignum.adigit-width)
4629 1))
4630 (result (if (##eq? position 0)
4631 ;; copy lowest result-word-size
4632 ;; words of n to result
4633 (##bignum.make result-word-size n #f)
4634 (##bignum.make result-word-size #f n-negative?)))
4635 (word-shift (##fixnum.quotient position ##bignum.adigit-width))
4636 (bit-shift (##fixnum.remainder position ##bignum.adigit-width))
4637 (divider (##fixnum.- ##bignum.adigit-width bit-shift))
4638 )
4639 (cond ((##eq? position 0)
4640 (fixup-top-word result size))
4641 ((##eq? bit-shift 0)
4642 (let ((word-limit (##fixnum.min (##fixnum.+ word-shift result-word-size)
4643 n-length)))
4644 (##declare (not interrupts-enabled))
4645 (let loop ((i 0)
4646 (j word-shift))
4647 (if (##fixnum.< j word-limit)
4648 (begin
4649 (##bignum.adigit-copy! result i n j)
4650 (loop (##fixnum.+ i 1)
4651 (##fixnum.+ j 1)))
4652 (fixup-top-word result size)))))
4653 (else
4654 (let ((left-fill (if n-negative?
4655 ##bignum.adigit-ones
4656 ##bignum.adigit-zeros))
4657 (word-limit (##fixnum.- (##fixnum.min (##fixnum.+ word-shift result-word-size)
4658 n-length)
4659 1)))
4660 (##declare (not interrupts-enabled))
4661 (let loop ((i 0)
4662 (j word-shift))
4663 (cond ((##fixnum.< j word-limit)
4664 (##bignum.adigit-cat! result i
4665 n (##fixnum.+ j 1)
4666 n j
4667 divider)
4668 (loop (##fixnum.+ i 1)
4669 (##fixnum.+ j 1)))
4670 ((##fixnum.< j (##fixnum.- n-length 1))
4671 (##bignum.adigit-cat! result i
4672 n (##fixnum.+ j 1)
4673 n j
4674 divider)
4675 (fixup-top-word result size))
4676 ((##fixnum.= j (##fixnum.- n-length 1))
4677 (##bignum.adigit-cat! result i
4678 left-fill 0
4679 n j
4680 divider)
4681 (fixup-top-word result size))
4682 (else
4683 (fixup-top-word result size)))))))))))))
4685 (define-prim (extract-bit-field size position n)
4686 (macro-force-vars (size position n)
4687 (macro-check-index
4688 size
4689 1
4690 (extract-bit-field size position n)
4691 (macro-check-index
4692 position
4693 2
4694 (extract-bit-field size position n)
4695 (if (##not (macro-exact-int? n))
4696 (##fail-check-exact-integer 3 extract-bit-field size position n)
4697 (##extract-bit-field size position n))))))
4699 (define-prim (##test-bit-field? size position n)
4700 (##not (##eq? (##extract-bit-field size position n)
4701 0)))
4703 (define-prim (test-bit-field? size position n)
4704 (macro-force-vars (size position n)
4705 (macro-check-index
4706 size
4707 1
4708 (test-bit-field? size position n)
4709 (macro-check-index
4710 position
4711 2
4712 (test-bit-field? size position n)
4713 (if (##not (macro-exact-int? n))
4714 (##fail-check-exact-integer 3 test-bit-field? size position n)
4715 (##test-bit-field? size position n))))))
4717 (define-prim (##clear-bit-field size position n)
4718 (##replace-bit-field size position 0 n))
4720 (define-prim (clear-bit-field size position n)
4721 (macro-force-vars (size position n)
4722 (macro-check-index
4723 size
4724 1
4725 (clear-bit-field size position n)
4726 (macro-check-index
4727 position
4728 2
4729 (clear-bit-field size position n)
4730 (if (##not (macro-exact-int? n))
4731 (##fail-check-exact-integer 3 clear-bit-field size position n)
4732 (##clear-bit-field size position n))))))
4734 (define-prim (##replace-bit-field size position newfield n)
4735 (let ((m (##bit-mask size)))
4736 (##bitwise-ior
4737 (##bitwise-and n (##bitwise-not (##arithmetic-shift m position)))
4738 (##arithmetic-shift (##bitwise-and newfield m) position))))
4740 (define-prim (replace-bit-field size position newfield n)
4741 (macro-force-vars (size position newfield n)
4742 (macro-check-index
4743 size
4744 1
4745 (replace-bit-field size position newfield n)
4746 (macro-check-index
4747 position
4748 2
4749 (replace-bit-field size position newfield n)
4750 (cond ((##not (macro-exact-int? newfield))
4751 (##fail-check-exact-integer 3 replace-bit-field size position newfield n))
4752 ((##not (macro-exact-int? n))
4753 (##fail-check-exact-integer 4 replace-bit-field size position newfield n))
4754 (else
4755 (##replace-bit-field size position newfield n)))))))
4757 (define-prim (##copy-bit-field size position from to)
4758 (##bitwise-merge
4759 (##arithmetic-shift (##bit-mask size) position)
4760 to
4761 from))
4763 (define-prim (copy-bit-field size position from to)
4764 (macro-force-vars (size position from to)
4765 (macro-check-index
4766 size
4767 1
4768 (copy-bit-field size position from to)
4769 (macro-check-index
4770 position
4771 2
4772 (copy-bit-field size position from to)
4773 (cond ((##not (macro-exact-int? from))
4774 (##fail-check-exact-integer 3 copy-bit-field size position from to))
4775 ((##not (macro-exact-int? to))
4776 (##fail-check-exact-integer 4 copy-bit-field size position from to))
4777 (else
4778 (##copy-bit-field size position from to)))))))
4780 (define-prim (##bit-mask size)
4781 (##bitwise-not (##arithmetic-shift -1 size)))
4783 ;;;----------------------------------------------------------------------------
4785 ;;; Fixnum operations
4786 ;;; -----------------
4788 (##define-macro (define-prim-fixnum form . special-body)
4789 (let ((body (if (null? special-body) form `(begin ,@special-body))))
4790 (cond ((= 1 (length (cdr form)))
4791 (let* ((name-fn (car form))
4792 (name-param1 (cadr form)))
4793 `(define-prim ,form
4794 (macro-force-vars (,name-param1)
4795 (macro-check-fixnum
4796 ,name-param1
4797 1
4798 ,form
4799 ,body)))))
4800 ((= 2 (length (cdr form)))
4801 (let* ((name-fn (car form))
4802 (name-param1 (cadr form))
4803 (name-param2 (caddr form)))
4804 `(define-prim ,form
4805 (macro-force-vars (,name-param1 ,name-param2)
4806 (macro-check-fixnum
4807 ,name-param1
4808 1
4809 ,form
4810 (macro-check-fixnum
4811 ,name-param2
4812 2
4813 ,form
4814 ,body))))))
4815 (else
4816 (error "define-prim-fixnum supports only 1 or 2 parameter procedures")))))
4818 (define-prim (fixnum? obj)
4819 (##fixnum? obj))
4821 (define-prim-nary-bool (##fx= x y)
4822 #t
4823 #t
4824 (##fx= x y)
4825 macro-no-force
4826 macro-no-check)
4828 (define-prim-nary-bool (fx= x y)
4829 #t
4830 #t
4831 (##fx= x y)
4832 macro-force-vars
4833 macro-check-fixnum)
4835 (define-prim-nary-bool (##fx< x y)
4836 #t
4837 #t
4838 (##fx< x y)
4839 macro-no-force
4840 macro-no-check)
4842 (define-prim-nary-bool (fx< x y)
4843 #t
4844 #t
4845 (##fx< x y)
4846 macro-force-vars
4847 macro-check-fixnum)
4849 (define-prim-nary-bool (##fx> x y)
4850 #t
4851 #t
4852 (##fx> x y)
4853 macro-no-force
4854 macro-no-check)
4856 (define-prim-nary-bool (fx> x y)
4857 #t
4858 #t
4859 (##fx> x y)
4860 macro-force-vars
4861 macro-check-fixnum)
4863 (define-prim-nary-bool (##fx<= x y)
4864 #t
4865 #t
4866 (##fx<= x y)
4867 macro-no-force
4868 macro-no-check)
4870 (define-prim-nary-bool (fx<= x y)
4871 #t
4872 #t
4873 (##fx<= x y)
4874 macro-force-vars
4875 macro-check-fixnum)
4877 (define-prim-nary-bool (##fx>= x y)
4878 #t
4879 #t
4880 (##fx>= x y)
4881 macro-no-force
4882 macro-no-check)
4884 (define-prim-nary-bool (fx>= x y)
4885 #t
4886 #t
4887 (##fx>= x y)
4888 macro-force-vars
4889 macro-check-fixnum)
4891 (define-prim (##fxzero? x))
4893 (define-prim-fixnum (fxzero? x)
4894 (##fxzero? x))
4896 (define-prim (##fxpositive? x))
4898 (define-prim-fixnum (fxpositive? x)
4899 (##fxpositive? x))
4901 (define-prim (##fxnegative? x))
4903 (define-prim-fixnum (fxnegative? x)
4904 (##fxnegative? x))
4906 (define-prim (##fxodd? x))
4908 (define-prim-fixnum (fxodd? x)
4909 (##fxodd? x))
4911 (define-prim (##fxeven? x))
4913 (define-prim-fixnum (fxeven? x)
4914 (##fxeven? x))
4916 (define-prim-nary (##fxmax x y)
4917 ()
4918 x
4919 (##fxmax x y)
4920 macro-no-force
4921 macro-no-check)
4923 (define-prim-nary (fxmax x y)
4924 ()
4925 x
4926 (##fxmax x y)
4927 macro-force-vars
4928 macro-check-fixnum)
4930 (define-prim-nary (##fxmin x y)
4931 ()
4932 x
4933 (##fxmin x y)
4934 macro-no-force
4935 macro-no-check)
4937 (define-prim-nary (fxmin x y)
4938 ()
4939 x
4940 (##fxmin x y)
4941 macro-force-vars
4942 macro-check-fixnum)
4944 (define-prim-nary (##fxwrap+ x y)
4945 0
4946 x
4947 (##fxwrap+ x y)
4948 macro-no-force
4949 macro-no-check)
4951 (define-prim-nary (fxwrap+ x y)
4952 0
4953 x
4954 (##fxwrap+ x y)
4955 macro-force-vars
4956 macro-check-fixnum)
4958 (define-prim-nary (##fx+ x y)
4959 0
4960 x
4961 (##fx+ x y)
4962 macro-no-force
4963 macro-no-check)
4965 (define-prim-nary (fx+ x y)
4966 0
4967 x
4968 (##fx+? x y)
4969 macro-force-vars
4970 macro-check-fixnum
4971 (##not ##raise-fixnum-overflow-exception))
4973 (define-prim (##fx+? x y))
4975 (define-prim-nary (##fxwrap* x y)
4976 1
4977 x
4978 (##fxwrap* x y)
4979 macro-no-force
4980 macro-no-check)
4982 (define-prim-nary (fxwrap* x y)
4983 1
4984 x
4985 (##fxwrap* x y)
4986 macro-force-vars
4987 macro-check-fixnum)
4989 (define-prim-nary (##fx* x y)
4990 1
4991 x
4992 (##fx* x y)
4993 macro-no-force
4994 macro-no-check)
4996 (define-prim-nary (fx* x y)
4997 1
4998 x
4999 ((lambda (x y)
5000 (cond ((##eqv? y 0)
5001 0)
5002 ((##eqv? y -1)
5003 (##fx-? x))
5004 (else
5005 (##fx*? x y))))
5006 x
5007 y)
5008 macro-force-vars
5009 macro-check-fixnum
5010 (##not ##raise-fixnum-overflow-exception))
5012 (define-prim (##fx*? x y))
5014 (define-prim-nary (##fxwrap- x y)
5015 ()
5016 (##fxwrap- x)
5017 (##fxwrap- x y)
5018 macro-no-force
5019 macro-no-check)
5021 (define-prim-nary (fxwrap- x y)
5022 ()
5023 (##fxwrap- x)
5024 (##fxwrap- x y)
5025 macro-force-vars
5026 macro-check-fixnum)
5028 (define-prim-nary (##fx- x y)
5029 ()
5030 (##fx- x)
5031 (##fx- x y)
5032 macro-no-force
5033 macro-no-check)
5035 (define-prim-nary (fx- x y)
5036 ()
5037 (##fx-? x)
5038 (##fx-? x y)
5039 macro-force-vars
5040 macro-check-fixnum
5041 (##not ##raise-fixnum-overflow-exception))
5043 (define-prim (##fx-? x #!optional (y (macro-absent-obj)))
5044 (if (##eq? y (macro-absent-obj))
5045 (##fx-? x)
5046 (##fx-? x y)))
5048 (define-prim (##fxwrapquotient x y))
5050 (define-prim-fixnum (fxwrapquotient x y)
5051 (if (##eq? y 0)
5052 (##raise-divide-by-zero-exception fxwrapquotient x y)
5053 (##fxwrapquotient x y)))
5055 (define-prim (##fxquotient x y))
5057 (define-prim-fixnum (fxquotient x y)
5058 (if (##eq? y 0)
5059 (##raise-divide-by-zero-exception fxquotient x y)
5060 (if (##eq? y -1)
5061 (or (##fx-? x)
5062 (##raise-fixnum-overflow-exception fxquotient x y))
5063 (##fxquotient x y))))
5065 (define-prim (##fxremainder x y))
5067 (define-prim-fixnum (fxremainder x y)
5068 (if (##eq? y 0)
5069 (##raise-divide-by-zero-exception fxremainder x y)
5070 (##fxremainder x y)))
5072 (define-prim (##fxmodulo x y))
5074 (define-prim-fixnum (fxmodulo x y)
5075 (if (##eq? y 0)
5076 (##raise-divide-by-zero-exception fxmodulo x y)
5077 (##fxmodulo x y)))
5079 (define-prim (##fxnot x)
5080 (##fx- -1 x))
5082 (define-prim-fixnum (fxnot x)
5083 (##fxnot x))
5085 (define-prim-nary (##fxand x y)
5086 -1
5087 x
5088 (##fxand x y)
5089 macro-no-force
5090 macro-no-check)
5092 (define-prim-nary (fxand x y)
5093 -1
5094 x
5095 (##fxand x y)
5096 macro-force-vars
5097 macro-check-fixnum)
5099 (define-prim-nary (##fxior x y)
5100 0
5101 x
5102 (##fxior x y)
5103 macro-no-force
5104 macro-no-check)
5106 (define-prim-nary (fxior x y)
5107 0
5108 x
5109 (##fxior x y)
5110 macro-force-vars
5111 macro-check-fixnum)
5113 (define-prim-nary (##fxxor x y)
5114 0
5115 x
5116 (##fxxor x y)
5117 macro-no-force
5118 macro-no-check)
5120 (define-prim-nary (fxxor x y)
5121 0
5122 x
5123 (##fxxor x y)
5124 macro-force-vars
5125 macro-check-fixnum)
5127 (define-prim (##fxif x y z))
5129 (define-prim (fxif x y z)
5130 (macro-force-vars (x y z)
5131 (macro-check-fixnum
5132 x
5133 1
5134 (fxif x y z)
5135 (macro-check-fixnum
5136 y
5137 2
5138 (fxif x y z)
5139 (macro-check-fixnum
5140 z
5141 3
5142 (fxif x y z)
5143 (##fxif x y z))))))
5145 (define-prim (##fxbit-count x))
5147 (define-prim (fxbit-count x)
5148 (macro-force-vars (x)
5149 (macro-check-fixnum
5150 x
5151 1
5152 (fxbit-count x)
5153 (##fxbit-count x))))
5155 (define-prim (##fxlength x))
5157 (define-prim (fxlength x)
5158 (macro-force-vars (x)
5159 (macro-check-fixnum
5160 x
5161 1
5162 (fxlength x)
5163 (##fxlength x))))
5165 (define-prim (##fxfirst-bit-set x))
5167 (define-prim (fxfirst-bit-set x)
5168 (macro-force-vars (x)
5169 (macro-check-fixnum
5170 x
5171 1
5172 (fxfirst-bit-set x)
5173 (##fxfirst-bit-set x))))
5175 (define-prim (##fxbit-set? x y))
5177 (define-prim (fxbit-set? x y)
5178 (macro-force-vars (x y)
5179 (macro-check-fixnum-range-incl
5180 x
5181 1
5182 0
5183 ##fixnum-width
5184 (fxbit-set? x y)
5185 (macro-check-fixnum
5186 y
5187 2
5188 (fxbit-set? x y)
5189 (##fxbit-set? x y)))))
5191 (define-prim (##fxwraparithmetic-shift x y))
5193 (define-prim (fxwraparithmetic-shift x y)
5194 (macro-force-vars (x y)
5195 (macro-check-fixnum
5196 x
5197 1
5198 (fxwraparithmetic-shift x y)
5199 (macro-check-fixnum-range-incl
5200 y
5201 2
5202 ##fixnum-width-neg
5203 ##fixnum-width
5204 (fxwraparithmetic-shift x y)
5205 (##fxwraparithmetic-shift x y)))))
5207 (define-prim (##fxarithmetic-shift x y))
5209 (define-prim-fixnum (fxarithmetic-shift x y)
5210 (or (##fxarithmetic-shift? x y)
5211 (##raise-fixnum-overflow-exception fxarithmetic-shift x y)))
5213 (define-prim (##fxarithmetic-shift? x y))
5215 (define-prim (##fxwraparithmetic-shift-left x y))
5217 (define-prim (fxwraparithmetic-shift-left x y)
5218 (macro-force-vars (x y)
5219 (macro-check-fixnum
5220 x
5221 1
5222 (fxwraparithmetic-shift-left x y)
5223 (macro-check-fixnum-range-incl
5224 y
5225 2
5226 0
5227 ##fixnum-width
5228 (fxwraparithmetic-shift-left x y)
5229 (##fxwraparithmetic-shift-left x y)))))
5231 (define-prim (##fxarithmetic-shift-left x y))
5233 (define-prim-fixnum (fxarithmetic-shift-left x y)
5234 (or (##fxarithmetic-shift-left? x y)
5235 (if (##fx< y 0)
5236 (##raise-range-exception 2 fxarithmetic-shift-left x y)
5237 (##raise-fixnum-overflow-exception fxarithmetic-shift-left x y))))
5239 (define-prim (##fxarithmetic-shift-left? x y))
5241 (define-prim (##fxarithmetic-shift-right x y))
5243 (define-prim-fixnum (fxarithmetic-shift-right x y)
5244 (or (##fxarithmetic-shift-right? x y)
5245 (##raise-range-exception 2 fxarithmetic-shift-right x y)))
5247 (define-prim (##fxarithmetic-shift-right? x y))
5249 (define-prim (##fxwraplogical-shift-right x y))
5251 (define-prim-fixnum (fxwraplogical-shift-right x y)
5252 (or (##fxwraplogical-shift-right? x y)
5253 (##raise-range-exception 2 fxwraplogical-shift-right x y)))
5255 (define-prim (##fxwraplogical-shift-right? x y))
5257 (define-prim (##fxwrapabs x))
5259 (define-prim-fixnum (fxwrapabs x)
5260 (##fxwrapabs x))
5262 (define-prim (##fxabs x))
5264 (define-prim-fixnum (fxabs x)
5265 (or (##fxabs? x)
5266 (##raise-fixnum-overflow-exception fxabs x)))
5268 (define-prim (##fxabs? x))
5270 (define-prim (##fx->char x))
5271 (define-prim (##fx<-char x))
5273 (define-prim (##fixnum->char x))
5274 (define-prim (##char->fixnum x))
5279 ;;;;;;;;;;;;;;;;;;;;;;;; old procedures
5281 (define-prim-nary-bool (##fixnum.= x y)
5282 #t
5283 #t
5284 (##fixnum.= x y)
5285 macro-no-force
5286 macro-no-check)
5288 (define-prim-nary-bool (##fixnum.< x y)
5289 #t
5290 #t
5291 (##fixnum.< x y)
5292 macro-no-force
5293 macro-no-check)
5295 (define-prim-nary-bool (##fixnum.> x y)
5296 #t
5297 #t
5298 (##fixnum.> x y)
5299 macro-no-force
5300 macro-no-check)
5302 (define-prim-nary-bool (##fixnum.<= x y)
5303 #t
5304 #t
5305 (##fixnum.<= x y)
5306 macro-no-force
5307 macro-no-check)
5309 (define-prim-nary-bool (##fixnum.>= x y)
5310 #t
5311 #t
5312 (##fixnum.>= x y)
5313 macro-no-force
5314 macro-no-check)
5316 (define-prim (##fixnum.zero? x))
5318 (define-prim (##fixnum.positive? x))
5320 (define-prim (##fixnum.negative? x))
5322 (define-prim (##fixnum.odd? x))
5324 (define-prim (##fixnum.even? x))
5326 (define-prim-nary (##fixnum.max x y)
5327 ()
5328 x
5329 (##fixnum.max x y)
5330 macro-no-force
5331 macro-no-check)
5333 (define-prim-nary (##fixnum.min x y)
5334 ()
5335 x
5336 (##fixnum.min x y)
5337 macro-no-force
5338 macro-no-check)
5340 (define-prim-nary (##fixnum.wrap+ x y)
5341 0
5342 x
5343 (##fixnum.wrap+ x y)
5344 macro-no-force
5345 macro-no-check)
5347 (define-prim-nary (##fixnum.+ x y)
5348 0
5349 x
5350 (##fixnum.+ x y)
5351 macro-no-force
5352 macro-no-check)
5354 (define-prim (##fixnum.+? x y))
5356 (define-prim-nary (##fixnum.wrap* x y)
5357 1
5358 x
5359 (##fixnum.wrap* x y)
5360 macro-no-force
5361 macro-no-check)
5363 (define-prim-nary (##fixnum.* x y)
5364 1
5365 x
5366 (##fixnum.* x y)
5367 macro-no-force
5368 macro-no-check)
5370 (define-prim (##fixnum.*? x y))
5372 (define-prim-nary (##fixnum.wrap- x y)
5373 ()
5374 (##fixnum.wrap- x)
5375 (##fixnum.wrap- x y)
5376 macro-no-force
5377 macro-no-check)
5379 (define-prim-nary (##fixnum.- x y)
5380 ()
5381 (##fixnum.- x)
5382 (##fixnum.- x y)
5383 macro-no-force
5384 macro-no-check)
5386 (define-prim (##fixnum.-? x #!optional (y (macro-absent-obj)))
5387 (if (##eq? y (macro-absent-obj))
5388 (##fixnum.-? x)
5389 (##fixnum.-? x y)))
5391 (define-prim (##fixnum.wrapquotient x y))
5393 (define-prim (##fixnum.quotient x y))
5395 (define-prim (##fixnum.remainder x y))
5397 (define-prim (##fixnum.modulo x y))
5399 (define-prim (##fixnum.bitwise-not x)
5400 (##fixnum.- -1 x))
5402 (define-prim-nary (##fixnum.bitwise-and x y)
5403 -1
5404 x
5405 (##fixnum.bitwise-and x y)
5406 macro-no-force
5407 macro-no-check)
5409 (define-prim-nary (##fixnum.bitwise-ior x y)
5410 0
5411 x
5412 (##fixnum.bitwise-ior x y)
5413 macro-no-force
5414 macro-no-check)
5416 (define-prim-nary (##fixnum.bitwise-xor x y)
5417 0
5418 x
5419 (##fixnum.bitwise-xor x y)
5420 macro-no-force
5421 macro-no-check)
5423 (define-prim (##fixnum.wraparithmetic-shift x y))
5425 (define-prim (##fixnum.arithmetic-shift x y))
5427 (define-prim (##fixnum.arithmetic-shift? x y))
5429 (define-prim (##fixnum.wraparithmetic-shift-left x y))
5431 (define-prim (##fixnum.arithmetic-shift-left x y))
5433 (define-prim (##fixnum.arithmetic-shift-left? x y))
5435 (define-prim (##fixnum.arithmetic-shift-right x y))
5437 (define-prim (##fixnum.arithmetic-shift-right? x y))
5439 (define-prim (##fixnum.wraplogical-shift-right x y))
5441 (define-prim (##fixnum.wraplogical-shift-right? x y))
5443 (define-prim (##fixnum.wrapabs x))
5445 (define-prim (##fixnum.abs x))
5447 (define-prim (##fixnum.abs? x))
5449 (define-prim (##fixnum.->char x))
5450 (define-prim (##fixnum.<-char x))
5452 ;;;----------------------------------------------------------------------------
5454 ;; Bignum operations
5455 ;; -----------------
5457 ;; The bignum operations were mostly implemented by the "Uber numerical
5458 ;; analyst Brad Lucier (http://www.math.purdue.edu/~lucier) with some
5459 ;; coding guidance from Marc Feeley.
5461 ;; Bignums are represented with 'adigit' vectors. Each element is an
5462 ;; integer containing ##bignum.adigit-width bits (typically 64 bits).
5463 ;; These bits encode an integer in two's complement representation.
5464 ;; The first element contains the least significant bits and the most
5465 ;; significant bit of the last element is the sign (0=positive,
5466 ;; 1=negative).
5468 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5470 (define-prim (##bignum.negative? x))
5471 (define-prim (##bignum.adigit-length x))
5472 (define-prim (##bignum.adigit-inc! x i))
5473 (define-prim (##bignum.adigit-dec! x i))
5474 (define-prim (##bignum.adigit-add! x i y j carry))
5475 (define-prim (##bignum.adigit-sub! x i y j borrow))
5476 (define-prim (##bignum.mdigit-length x))
5477 (define-prim (##bignum.mdigit-ref x i))
5478 (define-prim (##bignum.mdigit-set! x i mdigit))
5479 (define-prim (##bignum.mdigit-mul! x i y j multiplier carry))
5480 (define-prim (##bignum.mdigit-div! x i y j quotient borrow))
5481 (define-prim (##bignum.mdigit-quotient u j v_n-1))
5482 (define-prim (##bignum.mdigit-remainder u j v_n-1 q-hat))
5483 (define-prim (##bignum.mdigit-test? q-hat v_n-2 r-hat u_j-2))
5485 (define-prim (##bignum.adigit-ones? x i))
5486 (define-prim (##bignum.adigit-zero? x i))
5487 (define-prim (##bignum.adigit-negative? x i))
5488 (define-prim (##bignum.adigit-= x y i))
5489 (define-prim (##bignum.adigit-< x y i))
5490 (define-prim (##bignum.->fixnum x))
5491 (define-prim (##bignum.<-fixnum x))
5492 (define-prim (##bignum.adigit-shrink! x n))
5493 (define-prim (##bignum.adigit-copy! x i y j))
5494 (define-prim (##bignum.adigit-cat! x i hi j lo k divider))
5495 (define-prim (##bignum.adigit-bitwise-and! x i y j))
5496 (define-prim (##bignum.adigit-bitwise-ior! x i y j))
5497 (define-prim (##bignum.adigit-bitwise-xor! x i y j))
5498 (define-prim (##bignum.adigit-bitwise-not! x i))
5500 (define-prim (##bignum.fdigit-length x))
5501 (define-prim (##bignum.fdigit-ref x i))
5502 (define-prim (##bignum.fdigit-set! x i fdigit))
5504 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5506 ;;; Bignum related constants.
5508 (define ##bignum.adigit-ones #xffffffffffffffff)
5509 (define ##bignum.adigit-zeros #x10000000000000000)
5511 (define ##bignum.fdigit-base
5512 (##fixnum.arithmetic-shift-left 1 ##bignum.fdigit-width))
5514 (define ##bignum.mdigit-base
5515 (##fixnum.arithmetic-shift-left 1 ##bignum.mdigit-width))
5517 (define ##bignum.inexact-mdigit-base
5518 (##flonum.<-fixnum ##bignum.mdigit-base))
5520 (define ##bignum.mdigit-base-minus-1
5521 (##fixnum.- ##bignum.mdigit-base 1))
5523 (define ##bignum.minus-mdigit-base
5524 (##fixnum.- ##bignum.mdigit-base))
5526 (define ##bignum.max-fixnum-div-mdigit-base
5527 (##fixnum.quotient ##max-fixnum ##bignum.mdigit-base))
5529 (define ##bignum.min-fixnum-div-mdigit-base
5530 (##fixnum.quotient ##min-fixnum ##bignum.mdigit-base))
5532 (define ##bignum.2*min-fixnum
5533 (if (##fixnum? -1073741824)
5534 -4611686018427387904 ;; (- (expt 2 62))
5535 -1073741824)) ;; (- (expt 2 30))
5537 ;;; The following global variables control when each of the three
5538 ;;; multiplication algorithms are used.
5540 (define ##bignum.naive-mul-max-width 1400)
5541 (set! ##bignum.naive-mul-max-width ##bignum.naive-mul-max-width)
5543 (define ##bignum.fft-mul-min-width 20000)
5544 (set! ##bignum.fft-mul-min-width ##bignum.fft-mul-min-width)
5546 (define ##bignum.fft-mul-max-width
5547 (if (##fixnum? -1073741824) ;; to avoid creating f64vectors that are too long
5548 536870912
5549 4194304))
5550 (set! ##bignum.fft-mul-max-width ##bignum.fft-mul-max-width)
5553 (define ##bignum.fast-gcd-size ##bignum.naive-mul-max-width) ;; must be >= 64
5554 (set! ##bignum.fast-gcd-size ##bignum.fast-gcd-size)
5556 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5558 ;;; Operations where arguments are in bignum format
5560 (define-prim (##bignum.make k x complement?)
5561 (##declare (not interrupts-enabled))
5562 (let ((v (##c-code "
5563 long i;
5564 long n = ___INT(___ARG1);
5565 #if ___BIG_ABASE_WIDTH == 32
5566 long words = ___WORDS((n*(___BIG_ABASE_WIDTH/8))) + 1;
5567 #else
5568 #if ___WS == 4
5569 long words = ___WORDS((n*(___BIG_ABASE_WIDTH/8))) + 2;
5570 #else
5571 long words = ___WORDS((n*(___BIG_ABASE_WIDTH/8))) + 1;
5572 #endif
5573 #endif
5574 ___SCMOBJ result;
5576 if (n > ___CAST(___WORD, ___LMASK>>___LF)/(___BIG_ABASE_WIDTH/8))
5577 result = ___FIX(___HEAP_OVERFLOW_ERR); /* requested object is too big! */
5578 else if (words > ___MSECTION_BIGGEST)
5579 {
5580 ___FRAME_STORE_RA(___R0)
5581 ___W_ALL
5582 #if ___BIG_ABASE_WIDTH == 32
5583 result = ___alloc_scmobj (___sBIGNUM, n<<2, ___STILL);
5584 #else
5585 result = ___alloc_scmobj (___sBIGNUM, n<<3, ___STILL);
5586 #endif
5587 ___R_ALL
5588 ___SET_R0(___FRAME_FETCH_RA)
5589 if (!___FIXNUMP(result))
5590 ___still_obj_refcount_dec (result);
5591 }
5592 else
5593 {
5594 ___BOOL overflow = 0;
5595 ___hp += words;
5596 if (___hp > ___ps->heap_limit)
5597 {
5598 ___FRAME_STORE_RA(___R0)
5599 ___W_ALL
5600 overflow = ___heap_limit () && ___garbage_collect (0);
5601 ___R_ALL
5602 ___SET_R0(___FRAME_FETCH_RA)
5603 }
5604 else
5605 ___hp -= words;
5606 if (overflow)
5607 result = ___FIX(___HEAP_OVERFLOW_ERR);
5608 else
5609 {
5610 #if ___BIG_ABASE_WIDTH == 32
5611 result = ___TAG(___hp, ___tSUBTYPED);
5612 #else
5613 #if ___WS == 4
5614 result = ___TAG(___CAST(___SCMOBJ*,___CAST(___SCMOBJ,___hp+2)&~7)-1,
5615 ___tSUBTYPED);
5616 #else
5617 result = ___TAG(___hp, ___tSUBTYPED);
5618 #endif
5619 #endif
5620 #if ___BIG_ABASE_WIDTH == 32
5621 ___HEADER(result) = ___MAKE_HD_BYTES((n<<2), ___sBIGNUM);
5622 #else
5623 ___HEADER(result) = ___MAKE_HD_BYTES((n<<3), ___sBIGNUM);
5624 #endif
5625 ___hp += words;
5626 }
5627 }
5628 if (!___FIXNUMP(result))
5629 {
5630 ___SCMOBJ x = ___ARG2;
5631 ___SCMOBJ len;
5632 if (x == ___FAL)
5633 len = 0;
5634 else
5635 {
5636 len = ___INT(___BIGALENGTH(x));
5637 if (len > n)
5638 len = n;
5639 }
5640 #if ___BIG_ABASE_WIDTH == 32
5641 if (___ARG3 == ___FAL)
5642 {
5643 for (i=0; i<len; i++)
5644 ___STORE_U32(___BODY_AS(result,___tSUBTYPED),i,
5645 ___FETCH_U32(___BODY_AS(x,___tSUBTYPED),i));
5646 if (x != ___FAL &&
5647 ___FETCH_S32(___BODY_AS(x,___tSUBTYPED),(i-1)) < 0)
5648 for (; i<n; i++)
5649 ___STORE_U32(___BODY_AS(result,___tSUBTYPED),i,___BIG_ABASE_MIN_1);
5650 else
5651 for (; i<n; i++)
5652 ___STORE_U32(___BODY_AS(result,___tSUBTYPED),i,0);
5653 }
5654 else
5655 {
5656 for (i=0; i<len; i++)
5657 ___STORE_U32(___BODY_AS(result,___tSUBTYPED),i,
5658 ~___FETCH_U32(___BODY_AS(x,___tSUBTYPED),i));
5659 if (x != ___FAL &&
5660 ___FETCH_S32(___BODY_AS(x,___tSUBTYPED),(i-1)) < 0)
5661 for (; i<n; i++)
5662 ___STORE_U32(___BODY_AS(result,___tSUBTYPED),i,0);
5663 else
5664 for (; i<n; i++)
5665 ___STORE_U32(___BODY_AS(result,___tSUBTYPED),i,___BIG_ABASE_MIN_1);
5666 }
5667 #else
5668 if (___ARG3 == ___FAL)
5669 {
5670 for (i=0; i<len; i++)
5671 ___STORE_U64(___BODY_AS(result,___tSUBTYPED),i,
5672 ___FETCH_U64(___BODY_AS(x,___tSUBTYPED),i));
5673 if (x != ___FAL &&
5674 ___FETCH_S64(___BODY_AS(x,___tSUBTYPED),(i-1)) < 0)
5675 for (; i<n; i++)
5676 ___STORE_U64(___BODY_AS(result,___tSUBTYPED),i,___BIG_ABASE_MIN_1);
5677 else
5678 for (; i<n; i++)
5679 ___STORE_U64(___BODY_AS(result,___tSUBTYPED),i,0);
5680 }
5681 else
5682 {
5683 for (i=0; i<len; i++)
5684 ___STORE_U64(___BODY_AS(result,___tSUBTYPED),i,
5685 ~___FETCH_U64(___BODY_AS(x,___tSUBTYPED),i));
5686 if (x != ___FAL &&
5687 ___FETCH_S64(___BODY_AS(x,___tSUBTYPED),(i-1)) < 0)
5688 for (; i<n; i++)
5689 ___STORE_U64(___BODY_AS(result,___tSUBTYPED),i,0);
5690 else
5691 for (; i<n; i++)
5692 ___STORE_U64(___BODY_AS(result,___tSUBTYPED),i,___BIG_ABASE_MIN_1);
5693 }
5694 #endif
5695 }
5696 ___RESULT = result;
5697 " k x complement?)))
5698 (if (##fixnum? v)
5699 (begin
5700 (##raise-heap-overflow-exception)
5701 (##bignum.make k x complement?))
5702 v)))
5704 ;;; Bignum comparison.
5706 (define-prim (##bignum.= x y)
5708 ;; x is a normalized bignum, y is a normalized bignum
5710 (##declare (not interrupts-enabled))
5712 (let ((x-length (##bignum.adigit-length x)))
5713 (and (##fixnum.= x-length (##bignum.adigit-length y))
5714 (let loop ((i (##fixnum.- x-length 1)))
5715 (or (##fixnum.< i 0)
5716 (and (##bignum.adigit-= x y i)
5717 (loop (##fixnum.- i 1))))))))
5719 (define-prim (##bignum.< x y)
5721 ;; x is a normalized bignum, y is a normalized bignum
5723 (##declare (not interrupts-enabled))
5725 (define (loop i)
5726 (and (##not (##fixnum.< i 0))
5727 (or (##bignum.adigit-< x y i)
5728 (and (##bignum.adigit-= x y i)
5729 (loop (##fixnum.- i 1))))))
5731 (if (##bignum.negative? x)
5732 (if (##bignum.negative? y)
5733 (let ((x-length (##bignum.adigit-length x))
5734 (y-length (##bignum.adigit-length y)))
5735 (or (##fixnum.< y-length x-length)
5736 (and (##fixnum.= x-length y-length)
5737 (loop (##fixnum.- x-length 1)))))
5738 #t)
5739 (if (##bignum.negative? y)
5740 #f
5741 (let ((x-length (##bignum.adigit-length x))
5742 (y-length (##bignum.adigit-length y)))
5743 (or (##fixnum.< x-length y-length)
5744 (and (##fixnum.= x-length y-length)
5745 (loop (##fixnum.- x-length 1))))))))
5747 ;;; Bignum addition and subtraction.
5749 (define-prim (##bignum.+ x y)
5751 ;; x is an unnormalized bignum, y is an unnormalized bignum
5753 (define (add x x-length y y-length)
5754 (let* ((result-length
5755 (##fixnum.+ y-length
5756 (if (##eq? (##bignum.negative? x)
5757 (##bignum.negative? y))
5758 1
5759 0)))
5760 (result
5761 (##bignum.make result-length y #f)))
5763 (##declare (not interrupts-enabled))
5765 (let loop ((i 0)
5766 (carry 0))
5767 (if (##fixnum.< i x-length)
5768 (loop (##fixnum.+ i 1)
5769 (##bignum.adigit-add! result i x i carry))
5770 (##bignum.propagate-carry-and-normalize!
5771 result
5772 result-length
5773 x-length
5774 (##bignum.negative? x)
5775 (##fixnum.zero? carry))))))
5777 (let ((x-length (##bignum.adigit-length x))
5778 (y-length (##bignum.adigit-length y)))
5779 (if (##fixnum.< x-length y-length)
5780 (add x x-length y y-length)
5781 (add y y-length x x-length))))
5783 (define-prim (##bignum.- x y)
5785 ;; x is an unnormalized bignum, y is an unnormalized bignum
5787 (let ((x-length (##bignum.adigit-length x))
5788 (y-length (##bignum.adigit-length y)))
5789 (if (##fixnum.< x-length y-length)
5791 (let* ((result-length
5792 (##fixnum.+ y-length
5793 (if (##eq? (##bignum.negative? x)
5794 (##bignum.negative? y))
5795 0
5796 1)))
5797 (result
5798 (##bignum.make result-length y #t)))
5800 (##declare (not interrupts-enabled))
5802 (let loop1 ((i 0)
5803 (carry 1))
5804 (if (##fixnum.< i x-length)
5805 (loop1 (##fixnum.+ i 1)
5806 (##bignum.adigit-add! result i x i carry))
5807 (##bignum.propagate-carry-and-normalize!
5808 result
5809 result-length
5810 x-length
5811 (##bignum.negative? x)
5812 (##fixnum.zero? carry)))))
5814 (let* ((result-length
5815 (##fixnum.+ x-length
5816 (if (##eq? (##bignum.negative? x)
5817 (##bignum.negative? y))
5818 0
5819 1)))
5820 (result
5821 (##bignum.make result-length x #f)))
5823 (##declare (not interrupts-enabled))
5825 (let loop2 ((i 0)
5826 (borrow 0))
5827 (if (##fixnum.< i y-length)
5828 (loop2 (##fixnum.+ i 1)
5829 (##bignum.adigit-sub! result i y i borrow))
5830 (##bignum.propagate-carry-and-normalize!
5831 result
5832 result-length
5833 y-length
5834 (##not (##bignum.negative? y))
5835 (##not (##fixnum.zero? borrow)))))))))
5837 (define-prim (##bignum.propagate-carry-and-normalize!
5838 result
5839 result-length
5840 i
5841 borrow?
5842 propagate?)
5844 (##declare (not interrupts-enabled))
5846 (if (##eq? borrow? propagate?)
5847 (if borrow?
5849 (let loop1 ((i i)
5850 (borrow 1))
5851 (if (and (##not (##fixnum.zero? borrow))
5852 (##fixnum.< i result-length))
5853 (loop1 (##fixnum.+ i 1)
5854 (##bignum.adigit-dec! result i))
5855 (##bignum.normalize! result)))
5857 (let loop2 ((i i)
5858 (carry 1))
5859 (if (and (##not (##fixnum.zero? carry))
5860 (##fixnum.< i result-length))
5861 (loop2 (##fixnum.+ i 1)
5862 (##bignum.adigit-inc! result i))
5863 (##bignum.normalize! result))))
5865 (##bignum.normalize! result)))
5867 (define-prim (##bignum.normalize! result)
5869 (##declare (not interrupts-enabled))
5871 (let ((n (##fixnum.- (##bignum.adigit-length result) 1)))
5873 (cond ((##bignum.adigit-zero? result n)
5874 (let loop1 ((i (##fixnum.- n 1)))
5875 (cond ((##fixnum.< i 0)
5876 0)
5877 ((##bignum.adigit-zero? result i)
5878 (loop1 (##fixnum.- i 1)))
5879 ((##bignum.adigit-negative? result i)
5880 (##bignum.adigit-shrink! result (##fixnum.+ i 2)))
5881 (else
5882 (or (and (##fixnum.= i 0)
5883 (##bignum.->fixnum result))
5884 (##bignum.adigit-shrink! result (##fixnum.+ i 1)))))))
5886 ((##bignum.adigit-ones? result n)
5887 (let loop2 ((i (##fixnum.- n 1)))
5888 (cond ((##fixnum.< i 0)
5889 -1)
5890 ((##bignum.adigit-ones? result i)
5891 (loop2 (##fixnum.- i 1)))
5892 ((##not (##bignum.adigit-negative? result i))
5893 (##bignum.adigit-shrink! result (##fixnum.+ i 2)))
5894 (else
5895 (or (and (##fixnum.= i 0)
5896 (##bignum.->fixnum result))
5897 (##bignum.adigit-shrink! result (##fixnum.+ i 1)))))))
5899 ((and (##fixnum.= n 0)
5900 (##bignum.->fixnum result))
5901 =>
5902 (lambda (x) x))
5904 (else
5905 result))))
5907 ;;; Bignum multiplication.
5909 (define-prim (##bignum.* x y)
5911 (define (fft-mul x y)
5913 ;; Marc, the results of make-w should be cached, since bigger
5914 ;; tables can be used for any smaller size FFT.
5916 ;; This code works for x and y up to 536,870,912 bits, with
5917 ;; results up to 1Gb; numbers of this size require 8Gb, or 1GB, of
5918 ;; intermediate storage. It is always faster than the old code,
5919 ;; and it is mathematically correct. (Whether it is
5920 ;; programmatically correct is, of course, another matter, but I
5921 ;; have tested it extensively.)
5923 ;; This is an experiment.
5925 ;; This code implements bignum multiplication based on
5926 ;; double-precision FFT computations rather than on
5927 ;; number-theoretic FFTs and the Chinese remainder theorem.
5929 ;; The theory is in the article
5931 ;; Rapid multiplication modulo the sum and difference of highly
5932 ;; composite numbers, by Colin Percival
5934 ;; The complex roots of unity ("twiddle factors") need to be
5935 ;; computed in such a way that there is a known bound on the
5936 ;; error. I did this with a "computable reals" package I wrote.
5937 ;; I did not know a bound for the roots of unity in Ooura's FFT,
5938 ;; which is what we previously used..
5940 ;; If you use a different complex FFT, then you need to ensure
5941 ;; that the same operations are done as in this FFT (perhaps in a
5942 ;; somewhat different order), or that you prove the corresponding
5943 ;; theorem for your FFT that Percival proved in his paper. On a
5944 ;; 2GHz PPC 970, my complex FFT seems to be about half as fast as
5945 ;; FFTW's complex FFT, so that doesn't seem too bad for one
5946 ;; written by hand in Scheme.
5948 ;; After years of fiddling around, I finally understook the
5949 ;; weighted FT transform and the so-called right-angle
5950 ;; convolution. See section 8.3.2 the book "Algorithms for
5951 ;; Programmers" by Jo"rg Arndt, currently available at
5952 ;; www.jjj.de/fxt/fxtbook.pdf for a description of the right-angle
5953 ;; transform. It's also covered in "Prime Numbers" by Crandall
5954 ;; and Pomerance, and was originally introduced in 1994 by
5955 ;; Crandall and Fagin.
5957 ;; The basic reference for the fft codes is
5958 ;; {\it Inside the FFT Black Box,} by Eleanor Chu and Alan George,
5959 ;; CRC Press, New York, 2000. In the end, I should say that these
5960 ;; codes are just motivated by this book.
5962 ;; One of the biggest problem in translating their notation is
5963 ;; that they work with complex numbers, and we're working with
5964 ;; pairs of reals. Let us assume that all complex numbers are
5965 ;; stored with adjacent real and imaginary parts, real first.
5967 #|
5969 The strategy in the next function is to calculate a 2^n'th
5970 root of unity by multiplying entries from up to three look-up
5971 tables, each of which has lut-table-size complex entries, stored
5972 as pairs of f64s. Each of the tables contains correctly-rounded
5973 complex roots of unity, as computed by my computable-reals code.
5975 The j'th entry of the first table is
5977 exp(\pi/2 * i * (bit-reverse j log-lut-table-size)/lut-table-size), j = 0,...,lut-table-size - 1.
5979 where (bit-reverse j k) reverses the bits of j when
5980 considered as a bit string of length k.
5982 The j'th entry of the second table is
5984 exp(\pi/2 * i * j/lut-table-size^2), j = 0,...,lut-table-size-1
5986 and the j'th entry in the third table is
5988 exp(\pi/2 * i * j/lut-table-size^3), j = 0,...,lut-table-size-1
5990 From these three tables we construct a lut w in bit-reverse
5991 order of size 2^log-n.
5993 Any table we construct is also usable for ffts of a smaller size.
5995 The errors in the tables are as follows.
5997 When log-lut-table-size=10, we have the error in the first
5998 table is bounded by
6000 7.241394152931137e-17
6002 Theoretically, it should be bounded by
6004 > (* (sqrt 1/2) (expt 2. -53))
6005 7.850462293418875e-17
6007 The maximum error in the product of the first two tables is bounded by
6009 2.5438950740364204e-16
6011 The error in the general product of two correctly-rounded
6012 complex floating-point numbers of magnitude one is bounded by
6014 > (* (+ (sqrt 5) (sqrt 1/2) (sqrt 1/2)) (expt 2. -53))
6015 4.052626611931048e-16
6017 but what we're seeing here is that the entries of the second
6018 table have real part close to 1 and imaginary part <
6019 pi/2*2^{-10}, so (a) the error in the entries of the second table
6020 is much closer to 1/2 epsilon rather than (sqrt 1/2) epsilon,
6021 and (2) we might expect an error of about sqrt(2)epsilon in the
6022 complex product instead of the general result of sqrt(5)epsilon,
6023 or
6025 > (* (+ (sqrt 2) (sqrt 1/2) 1/2) (expt 2. -53))
6026 2.910250200338241e-16
6028 The maximum error in the product of entries from all three tables is
6030 4.158491068379826e-16
6032 which we can plug into the error bounds. Using the above
6033 heuristics, we would expect it to be <
6035 > (* (+ (sqrt 2) (sqrt 2) (sqrt 1/2) 1/2 1/2) (expt 2. -53))
6036 5.035454171334594e-16
6038 and we have the general bound of
6040 > (* (+ (* 2 (sqrt 5)) (* 3 (sqrt 1/2))) (expt 2. -53))
6041 7.320206994520208e-16
6043 so I'm glad I measured it.
6045 And, yes, I waited six days to compute the difference between
6046 the computed roots of unity and the exact roots of unity for all
6047 2^{30} products from the three tables.
6049 When log-lut-table-size=9, the corresponding maximum errors are
6051 7.113686303921851e-17
6053 for entries in the first table,
6055 2.4506454051660923e-16
6057 for products of entries in the first two tables, and
6059 4.164343159519809e-16
6061 for products from all three tables.
6063 Added later:
6065 We could try a different strategy here.
6067 If it's necessary to multiply entries of all three tables to populate
6068 the result, we multiply the entries from the last two tables first to
6069 get a multiplier. Because the real parts of the second and third table
6070 entries are nearly one and the imaginary parts are < 2^{-9} or so, the
6071 rounding error in each entry is about 1/2 epsilon instead of (sqrt 1/2)
6072 epsilon, and the biggest error in the product is 1/2 epsilon in the
6073 product of the real parts and then another 1/2 epsilon when subtracting
6074 the product of the imaginary parts. So the total error is about
6076 (* (+ 1/2 1/2 1/2 1/2) (expt 2 -53))
6078 or 2.220446049250313e-16.
6080 The final product adds further error of (sqrt 1/2) epsilon in the
6081 entries in the first table and then (sqrt 2) epsilon in the product.
6082 So my guess is that the total error in the product of three entries
6083 from the table will be bounded by
6085 (* (+ 1/2 1/2 1/2 1/2 (sqrt 1/2) (sqrt 2)) (expt 2 -53))
6087 or 4.575584737275976e-16.
6089 |#
6091 (define lut-table-size 512)
6092 (define lut-table-size^2 262144)
6093 (define lut-table-size^3 134217728)
6094 (define log-lut-table-size 9)
6096 (define low-lut
6097 '#f64(1. 0.
6098 .7071067811865476 .7071067811865476
6099 .9238795325112867 .3826834323650898
6100 .3826834323650898 .9238795325112867
6101 .9807852804032304 .19509032201612828
6102 .5555702330196022 .8314696123025452
6103 .8314696123025452 .5555702330196022
6104 .19509032201612828 .9807852804032304
6105 .9951847266721969 .0980171403295606
6106 .6343932841636455 .773010453362737
6107 .881921264348355 .47139673682599764
6108 .2902846772544624 .9569403357322088
6109 .9569403357322088 .2902846772544624
6110 .47139673682599764 .881921264348355
6111 .773010453362737 .6343932841636455
6112 .0980171403295606 .9951847266721969
6113 .9987954562051724 .049067674327418015
6114 .6715589548470184 .7409511253549591
6115 .9039892931234433 .4275550934302821
6116 .33688985339222005 .9415440651830208
6117 .970031253194544 .2429801799032639
6118 .5141027441932218 .8577286100002721
6119 .8032075314806449 .5956993044924334
6120 .14673047445536175 .989176509964781
6121 .989176509964781 .14673047445536175
6122 .5956993044924334 .8032075314806449
6123 .8577286100002721 .5141027441932218
6124 .2429801799032639 .970031253194544
6125 .9415440651830208 .33688985339222005
6126 .4275550934302821 .9039892931234433
6127 .7409511253549591 .6715589548470184
6128 .049067674327418015 .9987954562051724
6129 .9996988186962042 .024541228522912288
6130 .6895405447370669 .7242470829514669
6131 .9142097557035307 .40524131400498986
6132 .35989503653498817 .9329927988347388
6133 .9757021300385286 .2191012401568698
6134 .5349976198870973 .8448535652497071
6135 .8175848131515837 .5758081914178453
6136 .17096188876030122 .9852776423889412
6137 .99247953459871 .1224106751992162
6138 .6152315905806268 .7883464276266062
6139 .8700869911087115 .49289819222978404
6140 .26671275747489837 .9637760657954398
6141 .9495281805930367 .31368174039889146
6142 .4496113296546066 .8932243011955153
6143 .7572088465064846 .6531728429537768
6144 .07356456359966743 .9972904566786902
6145 .9972904566786902 .07356456359966743
6146 .6531728429537768 .7572088465064846
6147 .8932243011955153 .4496113296546066
6148 .31368174039889146 .9495281805930367
6149 .9637760657954398 .26671275747489837
6150 .49289819222978404 .8700869911087115
6151 .7883464276266062 .6152315905806268
6152 .1224106751992162 .99247953459871
6153 .9852776423889412 .17096188876030122
6154 .5758081914178453 .8175848131515837
6155 .8448535652497071 .5349976198870973
6156 .2191012401568698 .9757021300385286
6157 .9329927988347388 .35989503653498817
6158 .40524131400498986 .9142097557035307
6159 .7242470829514669 .6895405447370669
6160 .024541228522912288 .9996988186962042
6161 .9999247018391445 .012271538285719925
6162 .6983762494089728 .7157308252838187
6163 .9191138516900578 .3939920400610481
6164 .37131719395183754 .9285060804732156
6165 .9783173707196277 .20711137619221856
6166 .5453249884220465 .8382247055548381
6167 .8245893027850253 .5657318107836132
6168 .18303988795514095 .9831054874312163
6169 .9939069700023561 .11022220729388306
6170 .6248594881423863 .7807372285720945
6171 .8760700941954066 .4821837720791228
6172 .2785196893850531 .9604305194155658
6173 .9533060403541939 .3020059493192281
6174 .46053871095824 .8876396204028539
6175 .765167265622459 .6438315428897915
6176 .0857973123444399 .996312612182778
6177 .9981181129001492 .06132073630220858
6178 .6624157775901718 .7491363945234594
6179 .8986744656939538 .43861623853852766
6180 .3253102921622629 .9456073253805213
6181 .9669764710448521 .25486565960451457
6182 .5035383837257176 .8639728561215867
6183 .7958369046088836 .6055110414043255
6184 .1345807085071262 .99090263542778
6185 .9873014181578584 .15885814333386145
6186 .5857978574564389 .8104571982525948
6187 .8513551931052652 .524589682678469
6188 .2310581082806711 .9729399522055602
6189 .937339011912575 .34841868024943456
6190 .4164295600976372 .9091679830905224
6191 .7326542716724128 .680600997795453
6192 .03680722294135883 .9993223845883495
6193 .9993223845883495 .03680722294135883
6194 .680600997795453 .7326542716724128
6195 .9091679830905224 .4164295600976372
6196 .34841868024943456 .937339011912575
6197 .9729399522055602 .2310581082806711
6198 .524589682678469 .8513551931052652
6199 .8104571982525948 .5857978574564389
6200 .15885814333386145 .9873014181578584
6201 .99090263542778 .1345807085071262
6202 .6055110414043255 .7958369046088836
6203 .8639728561215867 .5035383837257176
6204 .25486565960451457 .9669764710448521
6205 .9456073253805213 .3253102921622629
6206 .43861623853852766 .8986744656939538
6207 .7491363945234594 .6624157775901718
6208 .06132073630220858 .9981181129001492
6209 .996312612182778 .0857973123444399
6210 .6438315428897915 .765167265622459
6211 .8876396204028539 .46053871095824
6212 .3020059493192281 .9533060403541939
6213 .9604305194155658 .2785196893850531
6214 .4821837720791228 .8760700941954066
6215 .7807372285720945 .6248594881423863
6216 .11022220729388306 .9939069700023561
6217 .9831054874312163 .18303988795514095
6218 .5657318107836132 .8245893027850253
6219 .8382247055548381 .5453249884220465
6220 .20711137619221856 .9783173707196277
6221 .9285060804732156 .37131719395183754
6222 .3939920400610481 .9191138516900578
6223 .7157308252838187 .6983762494089728
6224 .012271538285719925 .9999247018391445
6225 .9999811752826011 .006135884649154475
6226 .7027547444572253 .7114321957452164
6227 .9215140393420419 .3883450466988263
6228 .37700741021641826 .9262102421383114
6229 .9795697656854405 .2011046348420919
6230 .5504579729366048 .83486287498638
6231 .8280450452577558 .560661576197336
6232 .18906866414980622 .9819638691095552
6233 .9945645707342554 .10412163387205457
6234 .629638238914927 .7768884656732324
6235 .8790122264286335 .47679923006332214
6236 .2844075372112718 .9587034748958716
6237 .9551411683057707 .29615088824362384
6238 .4659764957679662 .8847970984309378
6239 .7691033376455796 .6391244448637757
6240 .09190895649713272 .9957674144676598
6241 .9984755805732948 .05519524434968994
6242 .6669999223036375 .745057785441466
6243 .901348847046022 .43309381885315196
6244 .33110630575987643 .9435934581619604
6245 .9685220942744173 .24892760574572018
6246 .508830142543107 .8608669386377673
6247 .799537269107905 .600616479383869
6248 .14065823933284924 .9900582102622971
6249 .9882575677307495 .15279718525844344
6250 .5907597018588743 .8068475535437992
6251 .8545579883654005 .5193559901655896
6252 .2370236059943672 .9715038909862518
6253 .9394592236021899 .3426607173119944
6254 .4220002707997997 .9065957045149153
6255 .7368165688773699 .6760927035753159
6256 .04293825693494082 .9990777277526454
6257 .9995294175010931 .030674803176636626
6258 .6850836677727004 .7284643904482252
6259 .9117060320054299 .41084317105790397
6260 .3541635254204904 .9351835099389476
6261 .9743393827855759 .22508391135979283
6262 .5298036246862947 .8481203448032972
6263 .8140363297059484 .5808139580957645
6264 .16491312048996992 .9863080972445987
6265 .9917097536690995 .12849811079379317
6266 .6103828062763095 .7921065773002124
6267 .8670462455156926 .49822766697278187
6268 .2607941179152755 .9653944416976894
6269 .9475855910177411 .3195020308160157
6270 .44412214457042926 .8959662497561851
6271 .7531867990436125 .6578066932970786
6272 .06744391956366406 .9977230666441916
6273 .9968202992911657 .07968243797143013
6274 .6485144010221124 .7612023854842618
6275 .8904487232447579 .45508358712634384
6276 .30784964004153487 .9514350209690083
6277 .9621214042690416 .272621355449949
6278 .48755016014843594 .8730949784182901
6279 .7845565971555752 .6200572117632892
6280 .11631863091190477 .9932119492347945
6281 .984210092386929 .17700422041214875
6282 .5707807458869673 .8211025149911046
6283 .8415549774368984 .5401714727298929
6284 .21311031991609136 .9770281426577544
6285 .9307669610789837 .36561299780477385
6286 .39962419984564684 .9166790599210427
6287 .7200025079613817 .693971460889654
6288 .01840672990580482 .9998305817958234
6289 .9998305817958234 .01840672990580482
6290 .693971460889654 .7200025079613817
6291 .9166790599210427 .39962419984564684
6292 .36561299780477385 .9307669610789837
6293 .9770281426577544 .21311031991609136
6294 .5401714727298929 .8415549774368984
6295 .8211025149911046 .5707807458869673
6296 .17700422041214875 .984210092386929
6297 .9932119492347945 .11631863091190477
6298 .6200572117632892 .7845565971555752
6299 .8730949784182901 .48755016014843594
6300 .272621355449949 .9621214042690416
6301 .9514350209690083 .30784964004153487
6302 .45508358712634384 .8904487232447579
6303 .7612023854842618 .6485144010221124
6304 .07968243797143013 .9968202992911657
6305 .9977230666441916 .06744391956366406
6306 .6578066932970786 .7531867990436125
6307 .8959662497561851 .44412214457042926
6308 .3195020308160157 .9475855910177411
6309 .9653944416976894 .2607941179152755
6310 .49822766697278187 .8670462455156926
6311 .7921065773002124 .6103828062763095
6312 .12849811079379317 .9917097536690995
6313 .9863080972445987 .16491312048996992
6314 .5808139580957645 .8140363297059484
6315 .8481203448032972 .5298036246862947
6316 .22508391135979283 .9743393827855759
6317 .9351835099389476 .3541635254204904
6318 .41084317105790397 .9117060320054299
6319 .7284643904482252 .6850836677727004
6320 .030674803176636626 .9995294175010931
6321 .9990777277526454 .04293825693494082
6322 .6760927035753159 .7368165688773699
6323 .9065957045149153 .4220002707997997
6324 .3426607173119944 .9394592236021899
6325 .9715038909862518 .2370236059943672
6326 .5193559901655896 .8545579883654005
6327 .8068475535437992 .5907597018588743
6328 .15279718525844344 .9882575677307495
6329 .9900582102622971 .14065823933284924
6330 .600616479383869 .799537269107905
6331 .8608669386377673 .508830142543107
6332 .24892760574572018 .9685220942744173
6333 .9435934581619604 .33110630575987643
6334 .43309381885315196 .901348847046022
6335 .745057785441466 .6669999223036375
6336 .05519524434968994 .9984755805732948
6337 .9957674144676598 .09190895649713272
6338 .6391244448637757 .7691033376455796
6339 .8847970984309378 .4659764957679662
6340 .29615088824362384 .9551411683057707
6341 .9587034748958716 .2844075372112718
6342 .47679923006332214 .8790122264286335
6343 .7768884656732324 .629638238914927
6344 .10412163387205457 .9945645707342554
6345 .9819638691095552 .18906866414980622
6346 .560661576197336 .8280450452577558
6347 .83486287498638 .5504579729366048
6348 .2011046348420919 .9795697656854405
6349 .9262102421383114 .37700741021641826
6350 .3883450466988263 .9215140393420419
6351 .7114321957452164 .7027547444572253
6352 .006135884649154475 .9999811752826011
6353 .9999952938095762 .003067956762965976
6354 .7049340803759049 .7092728264388657
6355 .9227011283338785 .38551605384391885
6356 .37984720892405116 .9250492407826776
6357 .9801821359681174 .1980984107179536
6358 .5530167055800276 .8331701647019132
6359 .829761233794523 .5581185312205561
6360 .19208039704989244 .9813791933137546
6361 .9948793307948056 .10106986275482782
6362 .6320187359398091 .7749531065948739
6363 .8804708890521608 .47410021465055
6364 .2873474595447295 .9578264130275329
6365 .9560452513499964 .29321916269425863
6366 .46868882203582796 .8833633386657316
6367 .7710605242618138 .6367618612362842
6368 .094963495329639 .9954807554919269
6369 .9986402181802653 .052131704680283324
6370 .6692825883466361 .7430079521351217
6371 .9026733182372588 .4303264813400826
6372 .3339996514420094 .9425731976014469
6373 .9692812353565485 .24595505033579462
6374 .5114688504379704 .8593018183570084
6375 .8013761717231402 .5981607069963423
6376 .14369503315029444 .9896220174632009
6377 .9887216919603238 .1497645346773215
6378 .5932322950397998 .8050313311429635
6379 .8561473283751945 .5167317990176499
6380 .2400030224487415 .9707721407289504
6381 .9405060705932683 .33977688440682685
6382 .4247796812091088 .9052967593181188
6383 .7388873244606151 .673829000378756
6384 .04600318213091463 .9989412931868569
6385 .9996188224951786 .027608145778965743
6386 .6873153408917592 .726359155084346
6387 .9129621904283982 .4080441628649787
6388 .35703096123343003 .9340925504042589
6389 .9750253450669941 .22209362097320354
6390 .532403127877198 .8464909387740521
6391 .8158144108067338 .5783137964116556
6392 .16793829497473117 .9857975091675675
6393 .9920993131421918 .12545498341154623
6394 .6128100824294097 .79023022143731
6395 .8685707059713409 .49556526182577254
6396 .2637546789748314 .9645897932898128
6397 .9485613499157303 .31659337555616585
6398 .4468688401623742 .8945994856313827
6399 .7552013768965365 .6554928529996153
6400 .07050457338961387 .9975114561403035
6401 .997060070339483 .07662386139203149
6402 .6508466849963809 .7592091889783881
6403 .8918407093923427 .4523495872337709
6404 .3107671527496115 .9504860739494817
6405 .9629532668736839 .2696683255729151
6406 .49022648328829116 .8715950866559511
6407 .7864552135990858 .617647307937804
6408 .11936521481099137 .9928504144598651
6409 .9847485018019042 .17398387338746382
6410 .5732971666980422 .819347520076797
6411 .8432082396418454 .5375870762956455
6412 .21610679707621952 .9763697313300211
6413 .9318842655816681 .3627557243673972
6414 .40243465085941843 .9154487160882678
6415 .7221281939292153 .6917592583641577
6416 .021474080275469508 .9997694053512153
6417 .9998823474542126 .015339206284988102
6418 .696177131491463 .7178700450557317
6419 .9179007756213905 .3968099874167103
6420 .3684668299533723 .9296408958431812
6421 .9776773578245099 .2101118368804696
6422 .5427507848645159 .8398937941959995
6423 .8228497813758263 .5682589526701316
6424 .18002290140569951 .9836624192117303
6425 .9935641355205953 .11327095217756435
6426 .62246127937415 .7826505961665757
6427 .8745866522781761 .4848692480007911
6428 .27557181931095814 .9612804858113206
6429 .9523750127197659 .30492922973540243
6430 .45781330359887723 .8890483558546646
6431 .7631884172633813 .6461760129833164
6432 .08274026454937569 .9965711457905548
6433 .997925286198596 .06438263092985747
6434 .6601143420674205 .7511651319096864
6435 .8973245807054183 .44137126873171667
6436 .32240767880106985 .9466009130832835
6437 .9661900034454125 .257831102162159
6438 .5008853826112408 .8655136240905691
6439 .7939754775543372 .6079497849677736
6440 .13154002870288312 .9913108598461154
6441 .9868094018141855 .16188639378011183
6442 .5833086529376983 .8122505865852039
6443 .8497417680008524 .5271991347819014
6444 .22807208317088573 .973644249650812
6445 .9362656671702783 .35129275608556715
6446 .41363831223843456 .9104412922580672
6447 .7305627692278276 .6828455463852481
6448 .03374117185137759 .9994306045554617
6449 .9992047586183639 .03987292758773981
6450 .6783500431298615 .7347388780959635
6451 .9078861164876663 .41921688836322396
6452 .34554132496398904 .9384035340631081
6453 .9722264970789363 .23404195858354343
6454 .5219752929371544 .8529606049303636
6455 .808656181588175 .5882815482226453
6456 .15582839765426523 .9877841416445722
6457 .9904850842564571 .13762012158648604
6458 .6030665985403482 .7976908409433912
6459 .8624239561110405 .5061866453451553
6460 .25189781815421697 .9677538370934755
6461 .9446048372614803 .32820984357909255
6462 .4358570799222555 .9000158920161603
6463 .7471006059801801 .6647109782033449
6464 .05825826450043576 .9983015449338929
6465 .996044700901252 .0888535525825246
6466 .6414810128085832 .7671389119358204
6467 .8862225301488806 .4632597835518602
6468 .2990798263080405 .9542280951091057
6469 .9595715130819845 .281464937925758
6470 .479493757660153 .8775452902072612
6471 .778816512381476 .6272518154951441
6472 .10717242495680884 .9942404494531879
6473 .9825393022874412 .18605515166344666
6474 .5631993440138341 .8263210628456635
6475 .836547727223512 .5478940591731002
6476 .20410896609281687 .9789481753190622
6477 .9273625256504011 .374164062971458
6478 .39117038430225387 .9203182767091106
6479 .7135848687807936 .7005687939432483
6480 .00920375478205982 .9999576445519639
6481 .9999576445519639 .00920375478205982
6482 .7005687939432483 .7135848687807936
6483 .9203182767091106 .39117038430225387
6484 .374164062971458 .9273625256504011
6485 .9789481753190622 .20410896609281687
6486 .5478940591731002 .836547727223512
6487 .8263210628456635 .5631993440138341
6488 .18605515166344666 .9825393022874412
6489 .9942404494531879 .10717242495680884
6490 .6272518154951441 .778816512381476
6491 .8775452902072612 .479493757660153
6492 .281464937925758 .9595715130819845
6493 .9542280951091057 .2990798263080405
6494 .4632597835518602 .8862225301488806
6495 .7671389119358204 .6414810128085832
6496 .0888535525825246 .996044700901252
6497 .9983015449338929 .05825826450043576
6498 .6647109782033449 .7471006059801801
6499 .9000158920161603 .4358570799222555
6500 .32820984357909255 .9446048372614803
6501 .9677538370934755 .25189781815421697
6502 .5061866453451553 .8624239561110405
6503 .7976908409433912 .6030665985403482
6504 .13762012158648604 .9904850842564571
6505 .9877841416445722 .15582839765426523
6506 .5882815482226453 .808656181588175
6507 .8529606049303636 .5219752929371544
6508 .23404195858354343 .9722264970789363
6509 .9384035340631081 .34554132496398904
6510 .41921688836322396 .9078861164876663
6511 .7347388780959635 .6783500431298615
6512 .03987292758773981 .9992047586183639
6513 .9994306045554617 .03374117185137759
6514 .6828455463852481 .7305627692278276
6515 .9104412922580672 .41363831223843456
6516 .35129275608556715 .9362656671702783
6517 .973644249650812 .22807208317088573
6518 .5271991347819014 .8497417680008524
6519 .8122505865852039 .5833086529376983
6520 .16188639378011183 .9868094018141855
6521 .9913108598461154 .13154002870288312
6522 .6079497849677736 .7939754775543372
6523 .8655136240905691 .5008853826112408
6524 .257831102162159 .9661900034454125
6525 .9466009130832835 .32240767880106985
6526 .44137126873171667 .8973245807054183
6527 .7511651319096864 .6601143420674205
6528 .06438263092985747 .997925286198596
6529 .9965711457905548 .08274026454937569
6530 .6461760129833164 .7631884172633813
6531 .8890483558546646 .45781330359887723
6532 .30492922973540243 .9523750127197659
6533 .9612804858113206 .27557181931095814
6534 .4848692480007911 .8745866522781761
6535 .7826505961665757 .62246127937415
6536 .11327095217756435 .9935641355205953
6537 .9836624192117303 .18002290140569951
6538 .5682589526701316 .8228497813758263
6539 .8398937941959995 .5427507848645159
6540 .2101118368804696 .9776773578245099
6541 .9296408958431812 .3684668299533723
6542 .3968099874167103 .9179007756213905
6543 .7178700450557317 .696177131491463
6544 .015339206284988102 .9998823474542126
6545 .9997694053512153 .021474080275469508
6546 .6917592583641577 .7221281939292153
6547 .9154487160882678 .40243465085941843
6548 .3627557243673972 .9318842655816681
6549 .9763697313300211 .21610679707621952
6550 .5375870762956455 .8432082396418454
6551 .819347520076797 .5732971666980422
6552 .17398387338746382 .9847485018019042
6553 .9928504144598651 .11936521481099137
6554 .617647307937804 .7864552135990858
6555 .8715950866559511 .49022648328829116
6556 .2696683255729151 .9629532668736839
6557 .9504860739494817 .3107671527496115
6558 .4523495872337709 .8918407093923427
6559 .7592091889783881 .6508466849963809
6560 .07662386139203149 .997060070339483
6561 .9975114561403035 .07050457338961387
6562 .6554928529996153 .7552013768965365
6563 .8945994856313827 .4468688401623742
6564 .31659337555616585 .9485613499157303
6565 .9645897932898128 .2637546789748314
6566 .49556526182577254 .8685707059713409
6567 .79023022143731 .6128100824294097
6568 .12545498341154623 .9920993131421918
6569 .9857975091675675 .16793829497473117
6570 .5783137964116556 .8158144108067338
6571 .8464909387740521 .532403127877198
6572 .22209362097320354 .9750253450669941
6573 .9340925504042589 .35703096123343003
6574 .4080441628649787 .9129621904283982
6575 .726359155084346 .6873153408917592
6576 .027608145778965743 .9996188224951786
6577 .9989412931868569 .04600318213091463
6578 .673829000378756 .7388873244606151
6579 .9052967593181188 .4247796812091088
6580 .33977688440682685 .9405060705932683
6581 .9707721407289504 .2400030224487415
6582 .5167317990176499 .8561473283751945
6583 .8050313311429635 .5932322950397998
6584 .1497645346773215 .9887216919603238
6585 .9896220174632009 .14369503315029444
6586 .5981607069963423 .8013761717231402
6587 .8593018183570084 .5114688504379704
6588 .24595505033579462 .9692812353565485
6589 .9425731976014469 .3339996514420094
6590 .4303264813400826 .9026733182372588
6591 .7430079521351217 .6692825883466361
6592 .052131704680283324 .9986402181802653
6593 .9954807554919269 .094963495329639
6594 .6367618612362842 .7710605242618138
6595 .8833633386657316 .46868882203582796
6596 .29321916269425863 .9560452513499964
6597 .9578264130275329 .2873474595447295
6598 .47410021465055 .8804708890521608
6599 .7749531065948739 .6320187359398091
6600 .10106986275482782 .9948793307948056
6601 .9813791933137546 .19208039704989244
6602 .5581185312205561 .829761233794523
6603 .8331701647019132 .5530167055800276
6604 .1980984107179536 .9801821359681174
6605 .9250492407826776 .37984720892405116
6606 .38551605384391885 .9227011283338785
6607 .7092728264388657 .7049340803759049
6608 .003067956762965976 .9999952938095762
6609 ))
6611 (define med-lut
6612 '#f64(1. 0.
6613 .9999999999820472 5.9921124526424275e-6
6614 .9999999999281892 1.1984224905069707e-5
6615 .9999999998384257 1.7976337357066685e-5
6616 .9999999997127567 2.396844980841822e-5
6617 .9999999995511824 2.9960562258909154e-5
6618 .9999999993537025 3.5952674708324344e-5
6619 .9999999991203175 4.1944787156448635e-5
6620 .9999999988510269 4.793689960306688e-5
6621 .9999999985458309 5.3929012047963936e-5
6622 .9999999982047294 5.992112449092465e-5
6623 .9999999978277226 6.591323693173387e-5
6624 .9999999974148104 7.190534937017645e-5
6625 .9999999969659927 7.789746180603723e-5
6626 .9999999964812697 8.388957423910108e-5
6627 .9999999959606412 8.988168666915283e-5
6628 .9999999954041073 9.587379909597734e-5
6629 .999999994811668 1.0186591151935948e-4
6630 .9999999941833233 1.0785802393908407e-4
6631 .9999999935190732 1.1385013635493597e-4
6632 .9999999928189177 1.1984224876670004e-4
6633 .9999999920828567 1.2583436117416112e-4
6634 .9999999913108903 1.3182647357710405e-4
6635 .9999999905030187 1.3781858597531374e-4
6636 .9999999896592414 1.4381069836857496e-4
6637 .9999999887795589 1.498028107566726e-4
6638 .9999999878639709 1.5579492313939151e-4
6639 .9999999869124775 1.6178703551651655e-4
6640 .9999999859250787 1.6777914788783258e-4
6641 .9999999849017744 1.737712602531244e-4
6642 .9999999838425648 1.797633726121769e-4
6643 .9999999827474497 1.8575548496477492e-4
6644 .9999999816164293 1.9174759731070332e-4
6645 .9999999804495034 1.9773970964974692e-4
6646 .9999999792466722 2.037318219816906e-4
6647 .9999999780079355 2.0972393430631923e-4
6648 .9999999767332933 2.1571604662341763e-4
6649 .9999999754227459 2.2170815893277063e-4
6650 .9999999740762929 2.2770027123416315e-4
6651 .9999999726939346 2.3369238352737996e-4
6652 .9999999712756709 2.3968449581220595e-4
6653 .9999999698215016 2.45676608088426e-4
6654 .9999999683314271 2.5166872035582493e-4
6655 .9999999668054471 2.5766083261418755e-4
6656 .9999999652435617 2.636529448632988e-4
6657 .9999999636457709 2.696450571029434e-4
6658 .9999999620120748 2.756371693329064e-4
6659 .9999999603424731 2.8162928155297243e-4
6660 .9999999586369661 2.876213937629265e-4
6661 .9999999568955537 2.936135059625534e-4
6662 .9999999551182358 2.99605618151638e-4
6663 .9999999533050126 3.055977303299651e-4
6664 .9999999514558838 3.115898424973196e-4
6665 .9999999495708498 3.1758195465348636e-4
6666 .9999999476499103 3.235740667982502e-4
6667 .9999999456930654 3.2956617893139595e-4
6668 .9999999437003151 3.3555829105270853e-4
6669 .9999999416716594 3.4155040316197275e-4
6670 .9999999396070982 3.475425152589734e-4
6671 .9999999375066316 3.535346273434955e-4
6672 .9999999353702598 3.595267394153237e-4
6673 .9999999331979824 3.6551885147424295e-4
6674 .9999999309897996 3.7151096352003814e-4
6675 .9999999287457114 3.7750307555249406e-4
6676 .9999999264657179 3.8349518757139556e-4
6677 .9999999241498189 3.8948729957652753e-4
6678 .9999999217980144 3.954794115676748e-4
6679 .9999999194103046 4.0147152354462224e-4
6680 .9999999169866894 4.0746363550715466e-4
6681 .9999999145271687 4.134557474550569e-4
6682 .9999999120317428 4.194478593881139e-4
6683 .9999999095004113 4.2543997130611036e-4
6684 .9999999069331744 4.314320832088313e-4
6685 .9999999043300322 4.3742419509606144e-4
6686 .9999999016909845 4.4341630696758576e-4
6687 .9999998990160315 4.4940841882318896e-4
6688 .9999998963051729 4.55400530662656e-4
6689 .999999893558409 4.613926424857717e-4
6690 .9999998907757398 4.673847542923209e-4
6691 .9999998879571651 4.7337686608208844e-4
6692 .9999998851026849 4.793689778548592e-4
6693 .9999998822122994 4.8536108961041806e-4
6694 .9999998792860085 4.913532013485497e-4
6695 .9999998763238122 4.973453130690393e-4
6696 .9999998733257104 5.033374247716714e-4
6697 .9999998702917032 5.09329536456231e-4
6698 .9999998672217907 5.153216481225028e-4
6699 .9999998641159727 5.213137597702719e-4
6700 .9999998609742493 5.27305871399323e-4
6701 .9999998577966206 5.332979830094408e-4
6702 .9999998545830864 5.392900946004105e-4
6703 .9999998513336468 5.452822061720168e-4
6704 .9999998480483018 5.512743177240444e-4
6705 .9999998447270514 5.572664292562783e-4
6706 .9999998413698955 5.632585407685033e-4
6707 .9999998379768343 5.692506522605043e-4
6708 .9999998345478677 5.752427637320661e-4
6709 .9999998310829956 5.812348751829735e-4
6710 .9999998275822183 5.872269866130116e-4
6711 .9999998240455354 5.93219098021965e-4
6712 .9999998204729471 5.992112094096185e-4
6713 .9999998168644535 6.052033207757572e-4
6714 .9999998132200545 6.111954321201659e-4
6715 .99999980953975 6.171875434426292e-4
6716 .9999998058235401 6.231796547429323e-4
6717 .9999998020714248 6.291717660208597e-4
6718 .9999997982834041 6.351638772761965e-4
6719 .9999997944594781 6.411559885087275e-4
6720 .9999997905996466 6.471480997182375e-4
6721 .9999997867039097 6.531402109045114e-4
6722 .9999997827722674 6.591323220673341e-4
6723 .9999997788047197 6.651244332064902e-4
6724 .9999997748012666 6.711165443217649e-4
6725 .9999997707619082 6.771086554129428e-4
6726 .9999997666866443 6.83100766479809e-4
6727 .9999997625754748 6.89092877522148e-4
6728 .9999997584284002 6.950849885397449e-4
6729 .9999997542454201 7.010770995323844e-4
6730 .9999997500265345 7.070692104998515e-4
6731 .9999997457717437 7.130613214419311e-4
6732 .9999997414810473 7.190534323584079e-4
6733 .9999997371544456 7.250455432490666e-4
6734 .9999997327919384 7.310376541136925e-4
6735 .9999997283935259 7.3702976495207e-4
6736 .999999723959208 7.430218757639842e-4
6737 .9999997194889846 7.490139865492199e-4
6738 .9999997149828559 7.55006097307562e-4
6739 .9999997104408218 7.609982080387952e-4
6740 .9999997058628822 7.669903187427045e-4
6741 .9999997012490373 7.729824294190747e-4
6742 .9999996965992869 7.789745400676906e-4
6743 .9999996919136313 7.849666506883372e-4
6744 .99999968719207 7.909587612807992e-4
6745 .9999996824346035 7.969508718448614e-4
6746 .9999996776412315 8.029429823803089e-4
6747 .9999996728119542 8.089350928869263e-4
6748 .9999996679467715 8.149272033644986e-4
6749 .9999996630456833 8.209193138128106e-4
6750 .9999996581086897 8.269114242316472e-4
6751 .9999996531357909 8.329035346207931e-4
6752 .9999996481269865 8.388956449800333e-4
6753 .9999996430822767 8.448877553091527e-4
6754 .9999996380016616 8.508798656079359e-4
6755 .999999632885141 8.56871975876168e-4
6756 .9999996277327151 8.628640861136338e-4
6757 .9999996225443838 8.68856196320118e-4
6758 .9999996173201471 8.748483064954056e-4
6759 .999999612060005 8.808404166392814e-4
6760 .9999996067639574 8.868325267515304e-4
6761 .9999996014320045 8.928246368319371e-4
6762 .9999995960641462 8.988167468802867e-4
6763 .9999995906603825 9.048088568963639e-4
6764 .9999995852207133 9.108009668799535e-4
6765 .9999995797451389 9.167930768308405e-4
6766 .9999995742336589 9.227851867488095e-4
6767 .9999995686862736 9.287772966336457e-4
6768 .9999995631029829 9.347694064851338e-4
6769 .9999995574837868 9.407615163030585e-4
6770 .9999995518286853 9.467536260872047e-4
6771 .9999995461376784 9.527457358373575e-4
6772 .9999995404107661 9.587378455533015e-4
6773 .9999995346479484 9.647299552348216e-4
6774 .9999995288492254 9.707220648817027e-4
6775 .9999995230145969 9.767141744937296e-4
6776 .9999995171440631 9.827062840706872e-4
6777 .9999995112376238 9.886983936123602e-4
6778 .9999995052952791 9.946905031185337e-4
6779 .9999994993170291 .0010006826125889925
6780 .9999994933028736 .0010066747220235214
6781 .9999994872528128 .001012666831421905
6782 .9999994811668466 .0010186589407839286
6783 .999999475044975 .0010246510501093766
6784 .9999994688871979 .0010306431593980344
6785 .9999994626935156 .0010366352686496862
6786 .9999994564639277 .0010426273778641173
6787 .9999994501984345 .0010486194870411127
6788 .999999443897036 .0010546115961804568
6789 .999999437559732 .0010606037052819344
6790 .9999994311865227 .0010665958143453308
6791 .9999994247774079 .0010725879233704307
6792 .9999994183323877 .0010785800323570187
6793 .9999994118514622 .0010845721413048801
6794 .9999994053346313 .0010905642502137994
6795 .9999993987818949 .0010965563590835613
6796 .9999993921932533 .0011025484679139511
6797 .9999993855687062 .0011085405767047535
6798 .9999993789082536 .0011145326854557532
6799 .9999993722118957 .001120524794166735
6800 .9999993654796325 .0011265169028374842
6801 .9999993587114638 .0011325090114677853
6802 .9999993519073898 .001138501120057423
6803 .9999993450674104 .0011444932286061825
6804 .9999993381915255 .0011504853371138485
6805 .9999993312797354 .0011564774455802057
6806 .9999993243320398 .0011624695540050393
6807 .9999993173484387 .001168461662388134
6808 .9999993103289324 .0011744537707292742
6809 .9999993032735206 .0011804458790282454
6810 .9999992961822035 .0011864379872848323
6811 .9999992890549809 .0011924300954988195
6812 .999999281891853 .001198422203669992
6813 .9999992746928197 .0012044143117981348
6814 .999999267457881 .0012104064198830327
6815 .999999260187037 .0012163985279244702
6816 .9999992528802875 .0012223906359222325
6817 .9999992455376326 .0012283827438761045
6818 .9999992381590724 .0012343748517858707
6819 .9999992307446068 .0012403669596513162
6820 .9999992232942359 .001246359067472226
6821 .9999992158079595 .0012523511752483847
6822 .9999992082857777 .001258343282979577
6823 .9999992007276906 .001264335390665588
6824 .999999193133698 .0012703274983062026
6825 .9999991855038001 .0012763196059012057
6826 .9999991778379967 .001282311713450382
6827 .9999991701362881 .0012883038209535163
6828 .999999162398674 .0012942959284103935
6829 .9999991546251547 .0013002880358207985
6830 .9999991468157298 .001306280143184516
6831 .9999991389703996 .001312272250501331
6832 .999999131089164 .0013182643577710285
6833 .999999123172023 .0013242564649933932
6834 .9999991152189767 .0013302485721682098
6835 .9999991072300249 .001336240679295263
6836 .9999990992051678 .0013422327863743383
6837 .9999990911444054 .0013482248934052201
6838 .9999990830477375 .0013542170003876934
6839 .9999990749151643 .001360209107321543
6840 .9999990667466857 .0013662012142065536
6841 .9999990585423016 .0013721933210425101
6842 .9999990503020123 .0013781854278291975
6843 .9999990420258176 .0013841775345664006
6844 .9999990337137175 .0013901696412539043
6845 .999999025365712 .0013961617478914935
6846 .999999016981801 .0014021538544789526
6847 .9999990085619848 .001408145961016067
6848 .9999990001062631 .0014141380675026214
6849 .9999989916146361 .0014201301739384005
6850 .9999989830871038 .0014261222803231893
6851 .9999989745236659 .0014321143866567725
6852 .9999989659243228 .001438106492938935
6853 .9999989572890743 .0014440985991694619
6854 .9999989486179204 .0014500907053481378
6855 .9999989399108612 .0014560828114747475
6856 .9999989311678965 .0014620749175490758
6857 .9999989223890265 .001468067023570908
6858 .9999989135742512 .0014740591295400284
6859 .9999989047235704 .0014800512354562223
6860 .9999988958369843 .0014860433413192743
6861 .9999988869144928 .0014920354471289693
6862 .9999988779560959 .0014980275528850922
6863 .9999988689617937 .0015040196585874275
6864 .9999988599315861 .0015100117642357607
6865 .999998850865473 .0015160038698298762
6866 .9999988417634548 .001521995975369559
6867 .999998832625531 .0015279880808545937
6868 .9999988234517019 .0015339801862847657
6869 .9999988142419675 .0015399722916598592
6870 .9999988049963277 .0015459643969796596
6871 .9999987957147825 .0015519565022439512
6872 .9999987863973319 .0015579486074525195
6873 .9999987770439759 .001563940712605149
6874 .9999987676547146 .0015699328177016243
6875 .999998758229548 .0015759249227417307
6876 .9999987487684759 .0015819170277252528
6877 .9999987392714985 .0015879091326519755
6878 .9999987297386157 .0015939012375216837
6879 .9999987201698276 .0015998933423341623
6880 .9999987105651341 .001605885447089196
6881 .9999987009245352 .0016118775517865696
6882 .999998691248031 .0016178696564260683
6883 .9999986815356214 .0016238617610074765
6884 .9999986717873064 .0016298538655305794
6885 .9999986620030861 .0016358459699951618
6886 .9999986521829605 .0016418380744010084
6887 .9999986423269294 .0016478301787479041
6888 .999998632434993 .0016538222830356339
6889 .9999986225071512 .0016598143872639823
6890 .999998612543404 .0016658064914327345
6891 .9999986025437515 .0016717985955416754
6892 .9999985925081937 .0016777906995905894
6893 .9999985824367305 .0016837828035792617
6894 .9999985723293618 .0016897749075074774
6895 .999998562186088 .0016957670113750207
6896 .9999985520069086 .0017017591151816769
6897 .9999985417918239 .0017077512189272307
6898 .999998531540834 .001713743322611467
6899 .9999985212539385 .0017197354262341706
6900 .9999985109311378 .0017257275297951264
6901 .9999985005724317 .0017317196332941192
6902 .9999984901778203 .0017377117367309341
6903 .9999984797473034 .0017437038401053556
6904 .9999984692808812 .0017496959434171687
6905 .9999984587785538 .0017556880466661582
6906 .9999984482403208 .001761680149852109
6907 .9999984376661826 .0017676722529748061
6908 .999998427056139 .0017736643560340342
6909 .99999841641019 .001779656459029578
6910 .9999984057283358 .0017856485619612225
6911 .9999983950105761 .0017916406648287528
6912 .999998384256911 .0017976327676319532
6913 .9999983734673407 .001803624870370609
6914 .9999983626418649 .0018096169730445048
6915 .9999983517804839 .0018156090756534257
6916 .9999983408831975 .0018216011781971562
6917 .9999983299500057 .0018275932806754815
6918 .9999983189809085 .0018335853830881864
6919 .999998307975906 .0018395774854350557
6920 .9999982969349982 .001845569587715874
6921 .9999982858581851 .0018515616899304264
6922 .9999982747454665 .001857553792078498
6923 .9999982635968426 .001863545894159873
6924 .9999982524123134 .0018695379961743367
6925 .9999982411918789 .001875530098121674
6926 .9999982299355389 .0018815222000016696
6927 .9999982186432936 .0018875143018141083
6928 .999998207315143 .0018935064035587748
6929 .999998195951087 .0018994985052354545
6930 .9999981845511257 .0019054906068439318
6931 .9999981731152591 .0019114827083839918
6932 .999998161643487 .001917474809855419
6933 .9999981501358096 .0019234669112579987
6934 .999998138592227 .0019294590125915154
6935 .9999981270127389 .0019354511138557542
6936 .9999981153973455 .0019414432150504997
6937 .9999981037460468 .0019474353161755369
6938 .9999980920588427 .001953427417230651
6939 .9999980803357332 .001959419518215626
6940 .9999980685767185 .0019654116191302473
6941 .9999980567817984 .0019714037199743
6942 .9999980449509729 .0019773958207475683
6943 .9999980330842422 .0019833879214498375
6944 .999998021181606 .001989380022080892
6945 .9999980092430646 .0019953721226405176
6946 .9999979972686177 .002001364223128498
6947 .9999979852582656 .002007356323544619
6948 .9999979732120081 .002013348423888665
6949 .9999979611298453 .002019340524160421
6950 .9999979490117771 .0020253326243596715
6951 .9999979368578036 .0020313247244862017
6952 .9999979246679247 .002037316824539796
6953 .9999979124421405 .00204330892452024
6954 .999997900180451 .002049301024427318
6955 .9999978878828562 .0020552931242608153
6956 .9999978755493559 .002061285224020516
6957 .9999978631799504 .0020672773237062057
6958 .9999978507746395 .002073269423317669
6959 .9999978383334234 .0020792615228546903
6960 .9999978258563018 .002085253622317055
6961 .999997813343275 .0020912457217045484
6962 .9999978007943428 .002097237821016954
6963 .9999977882095052 .0021032299202540577
6964 .9999977755887623 .0021092220194156444
6965 .9999977629321142 .0021152141185014984
6966 .9999977502395607 .0021212062175114043
6967 .9999977375111019 .002127198316445148
6968 .9999977247467376 .0021331904153025134
6969 .9999977119464681 .002139182514083286
6970 .9999976991102932 .0021451746127872503
6971 .9999976862382131 .002151166711414191
6972 .9999976733302276 .0021571588099638934
6973 .9999976603863368 .0021631509084361423
6974 .9999976474065406 .002169143006830722
6975 .9999976343908391 .002175135105147418
6976 .9999976213392323 .0021811272033860148
6977 .9999976082517201 .002187119301546297
6978 .9999975951283027 .00219311139962805
6979 .9999975819689799 .0021991034976310588
6980 .9999975687737518 .0022050955955551076
6981 .9999975555426184 .0022110876933999816
6982 .9999975422755796 .0022170797911654654
6983 .9999975289726355 .002223071888851344
6984 .9999975156337861 .0022290639864574026
6985 .9999975022590314 .0022350560839834253
6986 .9999974888483714 .002241048181429198
6987 .999997475401806 .0022470402787945045
6988 .9999974619193353 .00225303237607913
6989 .9999974484009593 .0022590244732828596
6990 .9999974348466779 .0022650165704054784
6991 .9999974212564913 .0022710086674467703
6992 .9999974076303992 .002277000764406521
6993 .9999973939684019 .002282992861284515
6994 .9999973802704993 .0022889849580805368
6995 .9999973665366915 .0022949770547943723
6996 .9999973527669782 .0023009691514258054
6997 .9999973389613596 .002306961247974621
6998 .9999973251198357 .0023129533444406045
6999 .9999973112424065 .0023189454408235406
7000 .999997297329072 .0023249375371232135
7001 .9999972833798322 .002330929633339409
7002 .999997269394687 .0023369217294719113
7003 .9999972553736366 .0023429138255205055
7004 .9999972413166809 .0023489059214849765
7005 .9999972272238198 .002354898017365109
7006 .9999972130950534 .0023608901131606883
7007 .9999971989303816 .0023668822088714985
7008 .9999971847298047 .0023728743044973246
7009 .9999971704933224 .0023788664000379523
7010 .9999971562209347 .0023848584954931653
7011 .9999971419126418 .0023908505908627493
7012 .9999971275684435 .0023968426861464883
7013 .99999711318834 .002402834781344168
7014 .9999970987723311 .0024088268764555732
7015 .9999970843204169 .002414818971480488
7016 .9999970698325974 .002420811066418698
7017 .9999970553088726 .0024268031612699878
7018 .9999970407492426 .002432795256034142
7019 .9999970261537071 .002438787350710946
7020 .9999970115222664 .002444779445300184
7021 .9999969968549204 .0024507715398016418
7022 .9999969821516691 .002456763634215103
7023 .9999969674125124 .002462755728540353
7024 .9999969526374506 .0024687478227771774
7025 .9999969378264834 .00247473991692536
7026 .9999969229796108 .002480732010984686
7027 .999996908096833 .0024867241049549406
7028 .9999968931781499 .002492716198835908
7029 .9999968782235614 .0024987082926273734
7030 .9999968632330677 .002504700386329122
7031 .9999968482066687 .002510692479940938
7032 .9999968331443644 .0025166845734626068
7033 .9999968180461547 .0025226766668939127
7034 .9999968029120399 .002528668760234641
7035 .9999967877420196 .002534660853484576
7036 .9999967725360941 .0025406529466435036
7037 .9999967572942633 .002546645039711208
7038 .9999967420165272 .002552637132687474
7039 .9999967267028858 .002558629225572086
7040 .9999967113533391 .0025646213183648297
7041 .9999966959678871 .0025706134110654896
7042 .9999966805465298 .002576605503673851
7043 .9999966650892672 .0025825975961896977
7044 .9999966495960994 .0025885896886128153
7045 .9999966340670262 .0025945817809429885
7046 .9999966185020478 .0026005738731800024
7047 .9999966029011641 .0026065659653236417
7048 .999996587264375 .002612558057373691
7049 .9999965715916808 .002618550149329935
7050 .9999965558830811 .0026245422411921592
7051 .9999965401385762 .002630534332960148
7052 .9999965243581661 .002636526424633687
7053 .9999965085418506 .0026425185162125596
7054 .9999964926896299 .0026485106076965517
7055 .9999964768015038 .0026545026990854484
7056 .9999964608774725 .0026604947903790337
7057 .9999964449175359 .0026664868815770926
7058 .999996428921694 .0026724789726794104
7059 .9999964128899468 .002678471063685772
7060 .9999963968222944 .0026844631545959617
7061 .9999963807187366 .002690455245409765
7062 .9999963645792737 .002696447336126966
7063 .9999963484039053 .00270243942674735
7064 .9999963321926317 .002708431517270702
7065 .9999963159454529 .0027144236076968066
7066 .9999962996623687 .0027204156980254485
7067 .9999962833433793 .002726407788256413
7068 .9999962669884847 .002732399878389485
7069 .9999962505976846 .0027383919684244484
7070 .9999962341709794 .002744384058361089
7071 .9999962177083689 .0027503761481991913
7072 .999996201209853 .0027563682379385403
7073 .9999961846754319 .0027623603275789207
7074 .9999961681051056 .0027683524171201175
7075 .999996151498874 .002774344506561915
7076 .9999961348567371 .002780336595904099
7077 .9999961181786949 .0027863286851464537
7078 .9999961014647475 .0027923207742887642
7079 .9999960847148948 .0027983128633308155
7080 .9999960679291368 .002804304952272392
7081 .9999960511074735 .002810297041113279
7082 .9999960342499049 .0028162891298532606
7083 .9999960173564312 .0028222812184921227
7084 .9999960004270521 .002828273307029649
7085 .9999959834617678 .002834265395465626
7086 .9999959664605781 .0028402574837998367
7087 .9999959494234832 .002846249572032067
7088 .9999959323504831 .0028522416601621014
7089 .9999959152415777 .002858233748189725
7090 .999995898096767 .002864225836114723
7091 .9999958809160512 .0028702179239368793
7092 .9999958636994299 .0028762100116559793
7093 .9999958464469034 .0028822020992718077
7094 .9999958291584717 .0028881941867841495
7095 .9999958118341348 .0028941862741927895
7096 .9999957944738925 .0029001783614975127
7097 .999995777077745 .002906170448698104
7098 .9999957596456922 .0029121625357943475
7099 .9999957421777342 .002918154622786029
7100 .999995724673871 .0029241467096729327
7101 .9999957071341024 .002930138796454844
7102 .9999956895584287 .0029361308831315474
7103 .9999956719468496 .0029421229697028273
7104 .9999956542993652 .0029481150561684695
7105 .9999956366159757 .0029541071425282584
7106 .9999956188966809 .002960099228781979
7107 .9999956011414808 .002966091314929416
7108 .9999955833503754 .002972083400970354
7109 .9999955655233649 .0029780754869045785
7110 .9999955476604491 .0029840675727318736
7111 .999995529761628 .002990059658452025
7112 .9999955118269016 .0029960517440648163
7113 .99999549385627 .0030020438295700336
7114 .9999954758497331 .0030080359149674612
7115 .999995457807291 .003014028000256884
7116 .9999954397289438 .003020020085438087
7117 .9999954216146911 .0030260121705108552
7118 .9999954034645333 .003032004255474973
7119 .9999953852784702 .003037996340330225
7120 .9999953670565019 .003043988425076397
7121 .9999953487986284 .003049980509713273
7122 .9999953305048496 .0030559725942406386
7123 .9999953121751655 .003061964678658278
7124 ))
7126 (define high-lut
7127 '#f64(1. 0.
7128 .9999999999999999 1.1703344634137277e-8
7129 .9999999999999998 2.3406689268274554e-8
7130 .9999999999999993 3.5110033902411824e-8
7131 .9999999999999989 4.6813378536549095e-8
7132 .9999999999999983 5.851672317068635e-8
7133 .9999999999999976 7.022006780482361e-8
7134 .9999999999999967 8.192341243896085e-8
7135 .9999999999999957 9.362675707309808e-8
7136 .9999999999999944 1.0533010170723531e-7
7137 .9999999999999931 1.170334463413725e-7
7138 .9999999999999917 1.287367909755097e-7
7139 .9999999999999901 1.4044013560964687e-7
7140 .9999999999999885 1.5214348024378403e-7
7141 .9999999999999866 1.6384682487792116e-7
7142 .9999999999999846 1.7555016951205827e-7
7143 .9999999999999825 1.8725351414619535e-7
7144 .9999999999999802 1.989568587803324e-7
7145 .9999999999999778 2.1066020341446942e-7
7146 .9999999999999752 2.2236354804860645e-7
7147 .9999999999999726 2.3406689268274342e-7
7148 .9999999999999698 2.4577023731688034e-7
7149 .9999999999999668 2.5747358195101726e-7
7150 .9999999999999638 2.6917692658515413e-7
7151 .9999999999999606 2.8088027121929094e-7
7152 .9999999999999571 2.9258361585342776e-7
7153 .9999999999999537 3.042869604875645e-7
7154 .99999999999995 3.159903051217012e-7
7155 .9999999999999463 3.276936497558379e-7
7156 .9999999999999424 3.3939699438997453e-7
7157 .9999999999999384 3.5110033902411114e-7
7158 .9999999999999342 3.6280368365824763e-7
7159 .9999999999999298 3.7450702829238413e-7
7160 .9999999999999254 3.8621037292652057e-7
7161 .9999999999999208 3.979137175606569e-7
7162 .9999999999999161 4.0961706219479325e-7
7163 .9999999999999113 4.2132040682892953e-7
7164 .9999999999999063 4.330237514630657e-7
7165 .9999999999999011 4.447270960972019e-7
7166 .9999999999998959 4.5643044073133796e-7
7167 .9999999999998904 4.68133785365474e-7
7168 .9999999999998849 4.7983712999961e-7
7169 .9999999999998792 4.915404746337459e-7
7170 .9999999999998733 5.032438192678817e-7
7171 .9999999999998674 5.149471639020175e-7
7172 .9999999999998613 5.266505085361531e-7
7173 .9999999999998551 5.383538531702888e-7
7174 .9999999999998487 5.500571978044243e-7
7175 .9999999999998422 5.617605424385598e-7
7176 .9999999999998356 5.734638870726952e-7
7177 .9999999999998288 5.851672317068305e-7
7178 .9999999999998219 5.968705763409657e-7
7179 .9999999999998148 6.085739209751009e-7
7180 .9999999999998076 6.202772656092359e-7
7181 .9999999999998003 6.319806102433709e-7
7182 .9999999999997928 6.436839548775058e-7
7183 .9999999999997853 6.553872995116406e-7
7184 .9999999999997775 6.670906441457753e-7
7185 .9999999999997696 6.7879398877991e-7
7186 .9999999999997616 6.904973334140445e-7
7187 .9999999999997534 7.02200678048179e-7
7188 .9999999999997452 7.139040226823132e-7
7189 .9999999999997368 7.256073673164475e-7
7190 .9999999999997282 7.373107119505817e-7
7191 .9999999999997194 7.490140565847157e-7
7192 .9999999999997107 7.607174012188497e-7
7193 .9999999999997017 7.724207458529835e-7
7194 .9999999999996926 7.841240904871172e-7
7195 .9999999999996834 7.958274351212508e-7
7196 .9999999999996739 8.075307797553844e-7
7197 .9999999999996644 8.192341243895178e-7
7198 .9999999999996547 8.309374690236511e-7
7199 .999999999999645 8.426408136577842e-7
7200 .9999999999996351 8.543441582919173e-7
7201 .999999999999625 8.660475029260503e-7
7202 .9999999999996148 8.777508475601831e-7
7203 .9999999999996044 8.894541921943158e-7
7204 .999999999999594 9.011575368284484e-7
7205 .9999999999995833 9.128608814625808e-7
7206 .9999999999995726 9.245642260967132e-7
7207 .9999999999995617 9.362675707308454e-7
7208 .9999999999995507 9.479709153649775e-7
7209 .9999999999995395 9.596742599991095e-7
7210 .9999999999995283 9.713776046332412e-7
7211 .9999999999995168 9.83080949267373e-7
7212 .9999999999995052 9.947842939015044e-7
7213 .9999999999994935 1.006487638535636e-6
7214 .9999999999994816 1.0181909831697673e-6
7215 .9999999999994696 1.0298943278038984e-6
7216 .9999999999994575 1.0415976724380293e-6
7217 .9999999999994453 1.0533010170721601e-6
7218 .9999999999994329 1.065004361706291e-6
7219 .9999999999994204 1.0767077063404215e-6
7220 .9999999999994077 1.088411050974552e-6
7221 .9999999999993949 1.1001143956086822e-6
7222 .9999999999993819 1.1118177402428122e-6
7223 .9999999999993688 1.1235210848769423e-6
7224 .9999999999993556 1.135224429511072e-6
7225 .9999999999993423 1.1469277741452017e-6
7226 .9999999999993288 1.1586311187793313e-6
7227 .9999999999993151 1.1703344634134605e-6
7228 .9999999999993014 1.1820378080475897e-6
7229 .9999999999992875 1.1937411526817187e-6
7230 .9999999999992735 1.2054444973158477e-6
7231 .9999999999992593 1.2171478419499764e-6
7232 .9999999999992449 1.2288511865841048e-6
7233 .9999999999992305 1.2405545312182331e-6
7234 .999999999999216 1.2522578758523615e-6
7235 .9999999999992012 1.2639612204864894e-6
7236 .9999999999991863 1.2756645651206173e-6
7237 .9999999999991713 1.287367909754745e-6
7238 .9999999999991562 1.2990712543888725e-6
7239 .9999999999991409 1.3107745990229998e-6
7240 .9999999999991255 1.3224779436571269e-6
7241 .9999999999991099 1.3341812882912537e-6
7242 .9999999999990943 1.3458846329253806e-6
7243 .9999999999990785 1.3575879775595072e-6
7244 .9999999999990625 1.3692913221936337e-6
7245 .9999999999990464 1.3809946668277597e-6
7246 .9999999999990302 1.3926980114618857e-6
7247 .9999999999990138 1.4044013560960117e-6
7248 .9999999999989974 1.4161047007301373e-6
7249 .9999999999989807 1.4278080453642627e-6
7250 .9999999999989639 1.439511389998388e-6
7251 .999999999998947 1.451214734632513e-6
7252 .99999999999893 1.462918079266638e-6
7253 .9999999999989128 1.4746214239007625e-6
7254 .9999999999988954 1.486324768534887e-6
7255 .999999999998878 1.4980281131690111e-6
7256 .9999999999988604 1.5097314578031353e-6
7257 .9999999999988426 1.5214348024372591e-6
7258 .9999999999988247 1.5331381470713828e-6
7259 .9999999999988067 1.544841491705506e-6
7260 .9999999999987886 1.5565448363396294e-6
7261 .9999999999987703 1.5682481809737524e-6
7262 .9999999999987519 1.579951525607875e-6
7263 .9999999999987333 1.5916548702419977e-6
7264 .9999999999987146 1.60335821487612e-6
7265 .9999999999986958 1.615061559510242e-6
7266 .9999999999986768 1.626764904144364e-6
7267 .9999999999986577 1.6384682487784858e-6
7268 .9999999999986384 1.6501715934126072e-6
7269 .9999999999986191 1.6618749380467283e-6
7270 .9999999999985996 1.6735782826808495e-6
7271 .9999999999985799 1.6852816273149702e-6
7272 .9999999999985602 1.6969849719490907e-6
7273 .9999999999985402 1.708688316583211e-6
7274 .9999999999985201 1.720391661217331e-6
7275 .9999999999985 1.732095005851451e-6
7276 .9999999999984795 1.7437983504855706e-6
7277 .9999999999984591 1.7555016951196899e-6
7278 .9999999999984385 1.767205039753809e-6
7279 .9999999999984177 1.778908384387928e-6
7280 .9999999999983968 1.7906117290220465e-6
7281 .9999999999983759 1.802315073656165e-6
7282 .9999999999983546 1.814018418290283e-6
7283 .9999999999983333 1.825721762924401e-6
7284 .9999999999983119 1.8374251075585186e-6
7285 .9999999999982904 1.8491284521926361e-6
7286 .9999999999982686 1.8608317968267533e-6
7287 .9999999999982468 1.8725351414608702e-6
7288 .9999999999982249 1.8842384860949866e-6
7289 .9999999999982027 1.8959418307291031e-6
7290 .9999999999981805 1.9076451753632194e-6
7291 .999999999998158 1.919348519997335e-6
7292 .9999999999981355 1.9310518646314507e-6
7293 .9999999999981128 1.942755209265566e-6
7294 .9999999999980901 1.954458553899681e-6
7295 .9999999999980671 1.966161898533796e-6
7296 .999999999998044 1.9778652431679103e-6
7297 .9999999999980208 1.9895685878020246e-6
7298 .9999999999979975 2.0012719324361386e-6
7299 .999999999997974 2.012975277070252e-6
7300 .9999999999979503 2.0246786217043656e-6
7301 .9999999999979265 2.0363819663384787e-6
7302 .9999999999979027 2.048085310972592e-6
7303 .9999999999978786 2.0597886556067045e-6
7304 .9999999999978545 2.0714920002408167e-6
7305 .9999999999978302 2.0831953448749286e-6
7306 .9999999999978058 2.0948986895090404e-6
7307 .9999999999977811 2.106602034143152e-6
7308 .9999999999977564 2.118305378777263e-6
7309 .9999999999977315 2.1300087234113738e-6
7310 .9999999999977065 2.1417120680454843e-6
7311 .9999999999976814 2.153415412679595e-6
7312 .9999999999976561 2.1651187573137046e-6
7313 .9999999999976307 2.1768221019478143e-6
7314 .9999999999976051 2.188525446581924e-6
7315 .9999999999975795 2.200228791216033e-6
7316 .9999999999975536 2.2119321358501417e-6
7317 .9999999999975278 2.22363548048425e-6
7318 .9999999999975017 2.2353388251183586e-6
7319 .9999999999974754 2.247042169752466e-6
7320 .999999999997449 2.2587455143865738e-6
7321 .9999999999974225 2.2704488590206814e-6
7322 .9999999999973959 2.282152203654788e-6
7323 .9999999999973691 2.293855548288895e-6
7324 .9999999999973422 2.305558892923001e-6
7325 .9999999999973151 2.317262237557107e-6
7326 .999999999997288 2.328965582191213e-6
7327 .9999999999972606 2.340668926825318e-6
7328 .9999999999972332 2.352372271459423e-6
7329 .9999999999972056 2.364075616093528e-6
7330 .9999999999971778 2.3757789607276323e-6
7331 .99999999999715 2.3874823053617365e-6
7332 .999999999997122 2.3991856499958403e-6
7333 .9999999999970938 2.4108889946299437e-6
7334 .9999999999970656 2.4225923392640466e-6
7335 .9999999999970371 2.4342956838981495e-6
7336 .9999999999970085 2.445999028532252e-6
7337 .9999999999969799 2.457702373166354e-6
7338 .999999999996951 2.4694057178004558e-6
7339 .999999999996922 2.4811090624345574e-6
7340 .9999999999968929 2.4928124070686583e-6
7341 .9999999999968637 2.504515751702759e-6
7342 .9999999999968343 2.5162190963368595e-6
7343 .9999999999968048 2.5279224409709594e-6
7344 .9999999999967751 2.5396257856050594e-6
7345 .9999999999967454 2.5513291302391585e-6
7346 .9999999999967154 2.5630324748732576e-6
7347 .9999999999966853 2.5747358195073563e-6
7348 .9999999999966551 2.5864391641414546e-6
7349 .9999999999966248 2.5981425087755525e-6
7350 .9999999999965944 2.6098458534096503e-6
7351 .9999999999965637 2.6215491980437473e-6
7352 .999999999996533 2.6332525426778443e-6
7353 .9999999999965021 2.644955887311941e-6
7354 .999999999996471 2.656659231946037e-6
7355 .99999999999644 2.6683625765801328e-6
7356 .9999999999964087 2.680065921214228e-6
7357 .9999999999963772 2.6917692658483234e-6
7358 .9999999999963456 2.703472610482418e-6
7359 .999999999996314 2.7151759551165123e-6
7360 .9999999999962821 2.7268792997506064e-6
7361 .9999999999962501 2.7385826443846996e-6
7362 .9999999999962179 2.750285989018793e-6
7363 .9999999999961857 2.761989333652886e-6
7364 .9999999999961533 2.7736926782869783e-6
7365 .9999999999961208 2.78539602292107e-6
7366 .9999999999960881 2.797099367555162e-6
7367 .9999999999960553 2.808802712189253e-6
7368 .9999999999960224 2.8205060568233443e-6
7369 .9999999999959893 2.832209401457435e-6
7370 .9999999999959561 2.8439127460915247e-6
7371 .9999999999959227 2.8556160907256145e-6
7372 .9999999999958893 2.867319435359704e-6
7373 .9999999999958556 2.879022779993793e-6
7374 .9999999999958219 2.8907261246278814e-6
7375 .9999999999957879 2.90242946926197e-6
7376 .999999999995754 2.9141328138960576e-6
7377 .9999999999957198 2.925836158530145e-6
7378 .9999999999956855 2.9375395031642317e-6
7379 .999999999995651 2.9492428477983186e-6
7380 .9999999999956164 2.9609461924324046e-6
7381 .9999999999955816 2.9726495370664905e-6
7382 .9999999999955468 2.9843528817005757e-6
7383 .9999999999955118 2.996056226334661e-6
7384 .9999999999954767 3.007759570968745e-6
7385 .9999999999954414 3.0194629156028294e-6
7386 .999999999995406 3.0311662602369133e-6
7387 .9999999999953705 3.0428696048709963e-6
7388 .9999999999953348 3.0545729495050794e-6
7389 .999999999995299 3.066276294139162e-6
7390 .999999999995263 3.0779796387732437e-6
7391 .9999999999952269 3.0896829834073255e-6
7392 .9999999999951907 3.101386328041407e-6
7393 .9999999999951543 3.1130896726754873e-6
7394 .9999999999951178 3.1247930173095678e-6
7395 .9999999999950812 3.136496361943648e-6
7396 .9999999999950444 3.148199706577727e-6
7397 .9999999999950075 3.1599030512118063e-6
7398 .9999999999949705 3.171606395845885e-6
7399 .9999999999949333 3.183309740479963e-6
7400 .999999999994896 3.195013085114041e-6
7401 .9999999999948584 3.206716429748118e-6
7402 .9999999999948209 3.218419774382195e-6
7403 .9999999999947832 3.2301231190162714e-6
7404 .9999999999947453 3.2418264636503477e-6
7405 .9999999999947072 3.253529808284423e-6
7406 .9999999999946692 3.265233152918498e-6
7407 .9999999999946309 3.276936497552573e-6
7408 .9999999999945924 3.288639842186647e-6
7409 .9999999999945539 3.300343186820721e-6
7410 .9999999999945152 3.312046531454794e-6
7411 .9999999999944763 3.323749876088867e-6
7412 .9999999999944373 3.3354532207229395e-6
7413 .9999999999943983 3.3471565653570115e-6
7414 .9999999999943591 3.358859909991083e-6
7415 .9999999999943197 3.370563254625154e-6
7416 .9999999999942801 3.3822665992592245e-6
7417 .9999999999942405 3.3939699438932944e-6
7418 .9999999999942008 3.4056732885273643e-6
7419 .9999999999941608 3.4173766331614334e-6
7420 .9999999999941207 3.429079977795502e-6
7421 .9999999999940805 3.4407833224295702e-6
7422 .9999999999940402 3.452486667063638e-6
7423 .9999999999939997 3.4641900116977054e-6
7424 .999999999993959 3.4758933563317723e-6
7425 .9999999999939183 3.4875967009658384e-6
7426 .9999999999938775 3.4993000455999045e-6
7427 .9999999999938364 3.5110033902339697e-6
7428 .9999999999937953 3.5227067348680345e-6
7429 .999999999993754 3.534410079502099e-6
7430 .9999999999937126 3.546113424136163e-6
7431 .999999999993671 3.5578167687702264e-6
7432 .9999999999936293 3.5695201134042896e-6
7433 .9999999999935875 3.581223458038352e-6
7434 .9999999999935454 3.592926802672414e-6
7435 .9999999999935033 3.6046301473064755e-6
7436 .9999999999934611 3.6163334919405365e-6
7437 .9999999999934187 3.628036836574597e-6
7438 .9999999999933762 3.639740181208657e-6
7439 .9999999999933334 3.6514435258427166e-6
7440 .9999999999932907 3.6631468704767755e-6
7441 .9999999999932477 3.674850215110834e-6
7442 .9999999999932047 3.686553559744892e-6
7443 .9999999999931615 3.6982569043789496e-6
7444 .9999999999931181 3.7099602490130064e-6
7445 .9999999999930747 3.7216635936470627e-6
7446 .999999999993031 3.733366938281119e-6
7447 .9999999999929873 3.745070282915174e-6
7448 .9999999999929433 3.756773627549229e-6
7449 .9999999999928992 3.768476972183284e-6
7450 .9999999999928552 3.7801803168173377e-6
7451 .9999999999928109 3.791883661451391e-6
7452 .9999999999927663 3.803587006085444e-6
7453 .9999999999927218 3.8152903507194965e-6
7454 .9999999999926771 3.826993695353548e-6
7455 .9999999999926322 3.838697039987599e-6
7456 .9999999999925873 3.85040038462165e-6
7457 .9999999999925421 3.862103729255701e-6
7458 .9999999999924968 3.87380707388975e-6
7459 .9999999999924514 3.885510418523799e-6
7460 .9999999999924059 3.897213763157848e-6
7461 .9999999999923602 3.9089171077918965e-6
7462 .9999999999923144 3.9206204524259435e-6
7463 .9999999999922684 3.9323237970599905e-6
7464 .9999999999922223 3.9440271416940376e-6
7465 .9999999999921761 3.955730486328084e-6
7466 .9999999999921297 3.967433830962129e-6
7467 .9999999999920832 3.9791371755961736e-6
7468 .9999999999920366 3.990840520230218e-6
7469 .9999999999919899 4.002543864864262e-6
7470 .9999999999919429 4.014247209498305e-6
7471 .9999999999918958 4.025950554132348e-6
7472 .9999999999918486 4.03765389876639e-6
7473 .9999999999918013 4.049357243400431e-6
7474 .9999999999917539 4.061060588034472e-6
7475 .9999999999917063 4.072763932668513e-6
7476 .9999999999916586 4.084467277302553e-6
7477 .9999999999916107 4.096170621936592e-6
7478 .9999999999915626 4.107873966570632e-6
7479 .9999999999915146 4.119577311204669e-6
7480 .9999999999914663 4.131280655838707e-6
7481 .9999999999914179 4.142984000472745e-6
7482 .9999999999913692 4.154687345106781e-6
7483 .9999999999913206 4.166390689740817e-6
7484 .9999999999912718 4.178094034374852e-6
7485 .9999999999912228 4.189797379008887e-6
7486 .9999999999911737 4.201500723642921e-6
7487 .9999999999911244 4.213204068276955e-6
7488 .999999999991075 4.224907412910988e-6
7489 .9999999999910255 4.236610757545021e-6
7490 .9999999999909759 4.248314102179053e-6
7491 .9999999999909261 4.260017446813084e-6
7492 .9999999999908762 4.271720791447115e-6
7493 .9999999999908261 4.283424136081145e-6
7494 .9999999999907759 4.295127480715175e-6
7495 .9999999999907256 4.306830825349204e-6
7496 .9999999999906751 4.3185341699832325e-6
7497 .9999999999906245 4.33023751461726e-6
7498 .9999999999905738 4.3419408592512875e-6
7499 .9999999999905229 4.353644203885314e-6
7500 .9999999999904718 4.36534754851934e-6
7501 .9999999999904207 4.377050893153365e-6
7502 .9999999999903694 4.38875423778739e-6
7503 .999999999990318 4.400457582421414e-6
7504 .9999999999902665 4.4121609270554384e-6
7505 .9999999999902147 4.423864271689461e-6
7506 .9999999999901629 4.435567616323483e-6
7507 .9999999999901109 4.447270960957506e-6
7508 .9999999999900587 4.458974305591527e-6
7509 .9999999999900065 4.470677650225547e-6
7510 .9999999999899541 4.482380994859567e-6
7511 .9999999999899016 4.494084339493587e-6
7512 .9999999999898489 4.5057876841276054e-6
7513 .9999999999897962 4.517491028761624e-6
7514 .9999999999897432 4.529194373395641e-6
7515 .9999999999896901 4.5408977180296584e-6
7516 .999999999989637 4.552601062663675e-6
7517 .9999999999895836 4.564304407297691e-6
7518 .99999999998953 4.5760077519317055e-6
7519 .9999999999894764 4.5877110965657195e-6
7520 .9999999999894227 4.5994144411997335e-6
7521 .9999999999893688 4.611117785833747e-6
7522 .9999999999893148 4.622821130467759e-6
7523 .9999999999892606 4.634524475101771e-6
7524 .9999999999892063 4.646227819735783e-6
7525 .9999999999891518 4.657931164369793e-6
7526 .9999999999890973 4.669634509003803e-6
7527 .9999999999890425 4.681337853637813e-6
7528 .9999999999889877 4.693041198271821e-6
7529 .9999999999889327 4.704744542905829e-6
7530 .9999999999888776 4.716447887539837e-6
7531 .9999999999888223 4.728151232173843e-6
7532 .9999999999887669 4.73985457680785e-6
7533 .9999999999887114 4.751557921441855e-6
7534 .9999999999886556 4.76326126607586e-6
7535 .9999999999885999 4.774964610709864e-6
7536 .9999999999885439 4.786667955343868e-6
7537 .9999999999884878 4.798371299977871e-6
7538 .9999999999884316 4.810074644611873e-6
7539 .9999999999883752 4.821777989245874e-6
7540 .9999999999883187 4.833481333879875e-6
7541 .9999999999882621 4.845184678513876e-6
7542 .9999999999882053 4.856888023147875e-6
7543 .9999999999881484 4.868591367781874e-6
7544 .9999999999880914 4.880294712415872e-6
7545 .9999999999880341 4.89199805704987e-6
7546 .9999999999879768 4.903701401683867e-6
7547 .9999999999879194 4.915404746317863e-6
7548 .9999999999878618 4.9271080909518585e-6
7549 .9999999999878041 4.938811435585853e-6
7550 .9999999999877462 4.9505147802198475e-6
7551 .9999999999876882 4.962218124853841e-6
7552 .99999999998763 4.973921469487834e-6
7553 .9999999999875717 4.985624814121826e-6
7554 .9999999999875133 4.997328158755817e-6
7555 .9999999999874548 5.009031503389808e-6
7556 .9999999999873961 5.0207348480237985e-6
7557 .9999999999873372 5.032438192657788e-6
7558 .9999999999872783 5.0441415372917765e-6
7559 .9999999999872192 5.055844881925764e-6
7560 .9999999999871599 5.067548226559752e-6
7561 .9999999999871007 5.079251571193739e-6
7562 .9999999999870411 5.090954915827725e-6
7563 .9999999999869814 5.10265826046171e-6
7564 .9999999999869217 5.1143616050956945e-6
7565 .9999999999868617 5.126064949729678e-6
7566 .9999999999868017 5.1377682943636615e-6
7567 .9999999999867415 5.149471638997644e-6
7568 .9999999999866811 5.161174983631626e-6
7569 .9999999999866207 5.172878328265607e-6
7570 .9999999999865601 5.184581672899587e-6
7571 .9999999999864994 5.196285017533567e-6
7572 .9999999999864384 5.2079883621675455e-6
7573 .9999999999863775 5.219691706801524e-6
7574 .9999999999863163 5.2313950514355015e-6
7575 .999999999986255 5.243098396069478e-6
7576 .9999999999861935 5.254801740703454e-6
7577 .999999999986132 5.266505085337429e-6
7578 .9999999999860703 5.278208429971404e-6
7579 .9999999999860084 5.289911774605378e-6
7580 .9999999999859465 5.301615119239351e-6
7581 .9999999999858843 5.313318463873323e-6
7582 .9999999999858221 5.325021808507295e-6
7583 .9999999999857597 5.336725153141267e-6
7584 .9999999999856971 5.3484284977752366e-6
7585 .9999999999856345 5.360131842409206e-6
7586 .9999999999855717 5.371835187043175e-6
7587 .9999999999855087 5.383538531677143e-6
7588 .9999999999854456 5.3952418763111104e-6
7589 .9999999999853825 5.406945220945077e-6
7590 .9999999999853191 5.418648565579043e-6
7591 .9999999999852557 5.4303519102130076e-6
7592 .9999999999851921 5.4420552548469724e-6
7593 .9999999999851282 5.453758599480936e-6
7594 .9999999999850644 5.465461944114899e-6
7595 .9999999999850003 5.47716528874886e-6
7596 .9999999999849362 5.488868633382822e-6
7597 .9999999999848719 5.500571978016782e-6
7598 .9999999999848074 5.512275322650742e-6
7599 .9999999999847429 5.523978667284702e-6
7600 .9999999999846781 5.53568201191866e-6
7601 .9999999999846133 5.547385356552617e-6
7602 .9999999999845482 5.5590887011865745e-6
7603 .9999999999844832 5.57079204582053e-6
7604 .9999999999844179 5.582495390454486e-6
7605 .9999999999843525 5.59419873508844e-6
7606 .9999999999842869 5.605902079722394e-6
7607 .9999999999842213 5.617605424356347e-6
7608 .9999999999841555 5.629308768990299e-6
7609 .9999999999840895 5.641012113624251e-6
7610 .9999999999840234 5.652715458258201e-6
7611 .9999999999839572 5.664418802892152e-6
7612 .9999999999838908 5.6761221475261e-6
7613 .9999999999838243 5.687825492160048e-6
7614 .9999999999837577 5.699528836793996e-6
7615 .9999999999836909 5.711232181427943e-6
7616 .999999999983624 5.722935526061889e-6
7617 .9999999999835569 5.734638870695834e-6
7618 .9999999999834898 5.746342215329779e-6
7619 .9999999999834225 5.758045559963722e-6
7620 .999999999983355 5.769748904597665e-6
7621 .9999999999832874 5.781452249231607e-6
7622 .9999999999832196 5.793155593865548e-6
7623 .9999999999831518 5.804858938499489e-6
7624 .9999999999830838 5.816562283133429e-6
7625 .9999999999830157 5.8282656277673675e-6
7626 .9999999999829474 5.839968972401306e-6
7627 .9999999999828789 5.851672317035243e-6
7628 .9999999999828104 5.86337566166918e-6
7629 .9999999999827417 5.875079006303115e-6
7630 .9999999999826729 5.88678235093705e-6
7631 .9999999999826039 5.898485695570985e-6
7632 .9999999999825349 5.910189040204917e-6
7633 .9999999999824656 5.92189238483885e-6
7634 .9999999999823962 5.933595729472782e-6
7635 .9999999999823267 5.945299074106713e-6
7636 .9999999999822571 5.957002418740643e-6
7637 .9999999999821872 5.9687057633745715e-6
7638 .9999999999821173 5.9804091080085e-6
7639 ))
7641 (define low-lut-rac
7642 '#f64(1. 0.
7643 .9999952938095762 .003067956762965976
7644 .9999811752826011 .006135884649154475
7645 .9999576445519639 .00920375478205982
7646 .9999247018391445 .012271538285719925
7647 .9998823474542126 .015339206284988102
7648 .9998305817958234 .01840672990580482
7649 .9997694053512153 .021474080275469508
7650 .9996988186962042 .024541228522912288
7651 .9996188224951786 .027608145778965743
7652 .9995294175010931 .030674803176636626
7653 .9994306045554617 .03374117185137759
7654 .9993223845883495 .03680722294135883
7655 .9992047586183639 .03987292758773981
7656 .9990777277526454 .04293825693494082
7657 .9989412931868569 .04600318213091463
7658 .9987954562051724 .049067674327418015
7659 .9986402181802653 .052131704680283324
7660 .9984755805732948 .05519524434968994
7661 .9983015449338929 .05825826450043576
7662 .9981181129001492 .06132073630220858
7663 .997925286198596 .06438263092985747
7664 .9977230666441916 .06744391956366406
7665 .9975114561403035 .07050457338961387
7666 .9972904566786902 .07356456359966743
7667 .997060070339483 .07662386139203149
7668 .9968202992911657 .07968243797143013
7669 .9965711457905548 .08274026454937569
7670 .996312612182778 .0857973123444399
7671 .996044700901252 .0888535525825246
7672 .9957674144676598 .09190895649713272
7673 .9954807554919269 .094963495329639
7674 .9951847266721969 .0980171403295606
7675 .9948793307948056 .10106986275482782
7676 .9945645707342554 .10412163387205457
7677 .9942404494531879 .10717242495680884
7678 .9939069700023561 .11022220729388306
7679 .9935641355205953 .11327095217756435
7680 .9932119492347945 .11631863091190477
7681 .9928504144598651 .11936521481099137
7682 .99247953459871 .1224106751992162
7683 .9920993131421918 .12545498341154623
7684 .9917097536690995 .12849811079379317
7685 .9913108598461154 .13154002870288312
7686 .99090263542778 .1345807085071262
7687 .9904850842564571 .13762012158648604
7688 .9900582102622971 .14065823933284924
7689 .9896220174632009 .14369503315029444
7690 .989176509964781 .14673047445536175
7691 .9887216919603238 .1497645346773215
7692 .9882575677307495 .15279718525844344
7693 .9877841416445722 .15582839765426523
7694 .9873014181578584 .15885814333386145
7695 .9868094018141855 .16188639378011183
7696 .9863080972445987 .16491312048996992
7697 .9857975091675675 .16793829497473117
7698 .9852776423889412 .17096188876030122
7699 .9847485018019042 .17398387338746382
7700 .984210092386929 .17700422041214875
7701 .9836624192117303 .18002290140569951
7702 .9831054874312163 .18303988795514095
7703 .9825393022874412 .18605515166344666
7704 .9819638691095552 .18906866414980622
7705 .9813791933137546 .19208039704989244
7706 .9807852804032304 .19509032201612828
7707 .9801821359681174 .1980984107179536
7708 .9795697656854405 .2011046348420919
7709 .9789481753190622 .20410896609281687
7710 .9783173707196277 .20711137619221856
7711 .9776773578245099 .2101118368804696
7712 .9770281426577544 .21311031991609136
7713 .9763697313300211 .21610679707621952
7714 .9757021300385286 .2191012401568698
7715 .9750253450669941 .22209362097320354
7716 .9743393827855759 .22508391135979283
7717 .973644249650812 .22807208317088573
7718 .9729399522055602 .2310581082806711
7719 .9722264970789363 .23404195858354343
7720 .9715038909862518 .2370236059943672
7721 .9707721407289504 .2400030224487415
7722 .970031253194544 .2429801799032639
7723 .9692812353565485 .24595505033579462
7724 .9685220942744173 .24892760574572018
7725 .9677538370934755 .25189781815421697
7726 .9669764710448521 .25486565960451457
7727 .9661900034454125 .257831102162159
7728 .9653944416976894 .2607941179152755
7729 .9645897932898128 .2637546789748314
7730 .9637760657954398 .26671275747489837
7731 .9629532668736839 .2696683255729151
7732 .9621214042690416 .272621355449949
7733 .9612804858113206 .27557181931095814
7734 .9604305194155658 .2785196893850531
7735 .9595715130819845 .281464937925758
7736 .9587034748958716 .2844075372112718
7737 .9578264130275329 .2873474595447295
7738 .9569403357322088 .2902846772544624
7739 .9560452513499964 .29321916269425863
7740 .9551411683057707 .29615088824362384
7741 .9542280951091057 .2990798263080405
7742 .9533060403541939 .3020059493192281
7743 .9523750127197659 .30492922973540243
7744 .9514350209690083 .30784964004153487
7745 .9504860739494817 .3107671527496115
7746 .9495281805930367 .31368174039889146
7747 .9485613499157303 .31659337555616585
7748 .9475855910177411 .3195020308160157
7749 .9466009130832835 .32240767880106985
7750 .9456073253805213 .3253102921622629
7751 .9446048372614803 .32820984357909255
7752 .9435934581619604 .33110630575987643
7753 .9425731976014469 .3339996514420094
7754 .9415440651830208 .33688985339222005
7755 .9405060705932683 .33977688440682685
7756 .9394592236021899 .3426607173119944
7757 .9384035340631081 .34554132496398904
7758 .937339011912575 .34841868024943456
7759 .9362656671702783 .35129275608556715
7760 .9351835099389476 .3541635254204904
7761 .9340925504042589 .35703096123343003
7762 .9329927988347388 .35989503653498817
7763 .9318842655816681 .3627557243673972
7764 .9307669610789837 .36561299780477385
7765 .9296408958431812 .3684668299533723
7766 .9285060804732156 .37131719395183754
7767 .9273625256504011 .374164062971458
7768 .9262102421383114 .37700741021641826
7769 .9250492407826776 .37984720892405116
7770 .9238795325112867 .3826834323650898
7771 .9227011283338785 .38551605384391885
7772 .9215140393420419 .3883450466988263
7773 .9203182767091106 .39117038430225387
7774 .9191138516900578 .3939920400610481
7775 .9179007756213905 .3968099874167103
7776 .9166790599210427 .39962419984564684
7777 .9154487160882678 .40243465085941843
7778 .9142097557035307 .40524131400498986
7779 .9129621904283982 .4080441628649787
7780 .9117060320054299 .41084317105790397
7781 .9104412922580672 .41363831223843456
7782 .9091679830905224 .4164295600976372
7783 .9078861164876663 .41921688836322396
7784 .9065957045149153 .4220002707997997
7785 .9052967593181188 .4247796812091088
7786 .9039892931234433 .4275550934302821
7787 .9026733182372588 .4303264813400826
7788 .901348847046022 .43309381885315196
7789 .9000158920161603 .4358570799222555
7790 .8986744656939538 .43861623853852766
7791 .8973245807054183 .44137126873171667
7792 .8959662497561851 .44412214457042926
7793 .8945994856313827 .4468688401623742
7794 .8932243011955153 .4496113296546066
7795 .8918407093923427 .4523495872337709
7796 .8904487232447579 .45508358712634384
7797 .8890483558546646 .45781330359887723
7798 .8876396204028539 .46053871095824
7799 .8862225301488806 .4632597835518602
7800 .8847970984309378 .4659764957679662
7801 .8833633386657316 .46868882203582796
7802 .881921264348355 .47139673682599764
7803 .8804708890521608 .47410021465055
7804 .8790122264286335 .47679923006332214
7805 .8775452902072612 .479493757660153
7806 .8760700941954066 .4821837720791228
7807 .8745866522781761 .4848692480007911
7808 .8730949784182901 .48755016014843594
7809 .8715950866559511 .49022648328829116
7810 .8700869911087115 .49289819222978404
7811 .8685707059713409 .49556526182577254
7812 .8670462455156926 .49822766697278187
7813 .8655136240905691 .5008853826112408
7814 .8639728561215867 .5035383837257176
7815 .8624239561110405 .5061866453451553
7816 .8608669386377673 .508830142543107
7817 .8593018183570084 .5114688504379704
7818 .8577286100002721 .5141027441932218
7819 .8561473283751945 .5167317990176499
7820 .8545579883654005 .5193559901655896
7821 .8529606049303636 .5219752929371544
7822 .8513551931052652 .524589682678469
7823 .8497417680008524 .5271991347819014
7824 .8481203448032972 .5298036246862947
7825 .8464909387740521 .532403127877198
7826 .8448535652497071 .5349976198870973
7827 .8432082396418454 .5375870762956455
7828 .8415549774368984 .5401714727298929
7829 .8398937941959995 .5427507848645159
7830 .8382247055548381 .5453249884220465
7831 .836547727223512 .5478940591731002
7832 .83486287498638 .5504579729366048
7833 .8331701647019132 .5530167055800276
7834 .8314696123025452 .5555702330196022
7835 .829761233794523 .5581185312205561
7836 .8280450452577558 .560661576197336
7837 .8263210628456635 .5631993440138341
7838 .8245893027850253 .5657318107836132
7839 .8228497813758263 .5682589526701316
7840 .8211025149911046 .5707807458869673
7841 .819347520076797 .5732971666980422
7842 .8175848131515837 .5758081914178453
7843 .8158144108067338 .5783137964116556
7844 .8140363297059484 .5808139580957645
7845 .8122505865852039 .5833086529376983
7846 .8104571982525948 .5857978574564389
7847 .808656181588175 .5882815482226453
7848 .8068475535437992 .5907597018588743
7849 .8050313311429635 .5932322950397998
7850 .8032075314806449 .5956993044924334
7851 .8013761717231402 .5981607069963423
7852 .799537269107905 .600616479383869
7853 .7976908409433912 .6030665985403482
7854 .7958369046088836 .6055110414043255
7855 .7939754775543372 .6079497849677736
7856 .7921065773002124 .6103828062763095
7857 .79023022143731 .6128100824294097
7858 .7883464276266062 .6152315905806268
7859 .7864552135990858 .617647307937804
7860 .7845565971555752 .6200572117632892
7861 .7826505961665757 .62246127937415
7862 .7807372285720945 .6248594881423863
7863 .778816512381476 .6272518154951441
7864 .7768884656732324 .629638238914927
7865 .7749531065948739 .6320187359398091
7866 .773010453362737 .6343932841636455
7867 .7710605242618138 .6367618612362842
7868 .7691033376455796 .6391244448637757
7869 .7671389119358204 .6414810128085832
7870 .765167265622459 .6438315428897915
7871 .7631884172633813 .6461760129833164
7872 .7612023854842618 .6485144010221124
7873 .7592091889783881 .6508466849963809
7874 .7572088465064846 .6531728429537768
7875 .7552013768965365 .6554928529996153
7876 .7531867990436125 .6578066932970786
7877 .7511651319096864 .6601143420674205
7878 .7491363945234594 .6624157775901718
7879 .7471006059801801 .6647109782033449
7880 .745057785441466 .6669999223036375
7881 .7430079521351217 .6692825883466361
7882 .7409511253549591 .6715589548470184
7883 .7388873244606151 .673829000378756
7884 .7368165688773699 .6760927035753159
7885 .7347388780959635 .6783500431298615
7886 .7326542716724128 .680600997795453
7887 .7305627692278276 .6828455463852481
7888 .7284643904482252 .6850836677727004
7889 .726359155084346 .6873153408917592
7890 .7242470829514669 .6895405447370669
7891 .7221281939292153 .6917592583641577
7892 .7200025079613817 .693971460889654
7893 .7178700450557317 .696177131491463
7894 .7157308252838187 .6983762494089728
7895 .7135848687807936 .7005687939432483
7896 .7114321957452164 .7027547444572253
7897 .7092728264388657 .7049340803759049
7898 ))
7900 (define (make-w log-n)
7901 (let* ((n (##expt 2 log-n)) ;; number of complexes
7902 (result (##make-f64vector (##fixnum.* 2 n))))
7904 (define (copy-low-lut)
7905 (##declare (not interrupts-enabled))
7906 (do ((i 0 (##fixnum.+ i 1)))
7907 ((##fixnum.= i lut-table-size))
7908 (let ((index (##fixnum.* i 2)))
7909 (##f64vector-set!
7910 result
7911 index
7912 (##f64vector-ref low-lut index))
7913 (##f64vector-set!
7914 result
7915 (##fixnum.+ index 1)
7916 (##f64vector-ref low-lut (##fixnum.+ index 1))))))
7918 (define (extend-lut multiplier-lut bit-reverse-size bit-reverse-multiplier start end)
7920 (define (bit-reverse x n)
7921 (declare (not interrupts-enabled))
7922 (do ((i 0 (##fixnum.+ i 1))
7923 (x x (##fixnum.arithmetic-shift-right x 1))
7924 (result 0 (##fixnum.+ (##fixnum.* result 2)
7925 (##fixnum.bitwise-and x 1))))
7926 ((##fixnum.= i n) result)))
7928 (let loop ((i start)
7929 (j 1))
7930 (if (##fixnum.< i end)
7931 (let* ((multiplier-index
7932 (##fixnum.* 2
7933 (bit-reverse j bit-reverse-size)
7934 bit-reverse-multiplier))
7935 (multiplier-real
7936 (##f64vector-ref multiplier-lut multiplier-index))
7937 (multiplier-imag
7938 (##f64vector-ref multiplier-lut (##fixnum.+ multiplier-index 1))))
7939 (let inner ((i i)
7940 (k 0))
7941 (declare (not interrupts-enabled))
7942 ;; we copy complex multiples of all entries below
7943 ;; start to entries starting at start
7944 (if (##fixnum.< k start)
7945 (let* ((index
7946 (##fixnum.* k 2))
7947 (real
7948 (##f64vector-ref result index))
7949 (imag
7950 (##f64vector-ref result (##fixnum.+ index 1)))
7951 (result-real
7952 (##flonum.- (##flonum.* multiplier-real real)
7953 (##flonum.* multiplier-imag imag)))
7954 (result-imag
7955 (##flonum.+ (##flonum.* multiplier-real imag)
7956 (##flonum.* multiplier-imag real)))
7957 (result-index (##fixnum.* i 2)))
7958 (##f64vector-set! result result-index result-real)
7959 (##f64vector-set! result (##fixnum.+ result-index 1) result-imag)
7960 (inner (##fixnum.+ i 1)
7961 (##fixnum.+ k 1)))
7962 (loop i
7963 (##fixnum.+ j 1)))))
7964 result)))
7966 (cond ((##fixnum.<= n lut-table-size)
7967 low-lut)
7968 ((##fixnum.<= n lut-table-size^2)
7969 (copy-low-lut)
7970 (extend-lut med-lut
7971 (##fixnum.- log-n log-lut-table-size)
7972 (##fixnum.arithmetic-shift-left 1 (##fixnum.- (##fixnum.* 2 log-lut-table-size) log-n))
7973 lut-table-size
7974 n))
7975 ((##fixnum.<= n lut-table-size^3)
7976 (copy-low-lut)
7977 (extend-lut med-lut
7978 log-lut-table-size
7979 1
7980 lut-table-size
7981 lut-table-size^2)
7982 (extend-lut high-lut
7983 (##fixnum.- log-n (##fixnum.* 2 log-lut-table-size))
7984 (##fixnum.arithmetic-shift-left 1 (##fixnum.- (##fixnum.* 3 log-lut-table-size) log-n))
7985 lut-table-size^2
7986 n))
7987 (else
7988 (error "asking for too large a table")))))
7990 (define (two^p>=m m)
7991 ;; returns smallest p, assumes fixnum m >= 0
7992 (##fxlength (##fixnum.- m)))
7994 ;; The next two routines are so-called radix-4 ffts, which seems
7995 ;; to mean that they combine two passes, each of which works on
7996 ;; pairs of complex numbers (hence radix-2?), so if you combine
7997 ;; two passes in one, you work on two pairs of complex numbers at
7998 ;; a time and make half as many passes through the f64vector a.
8000 (define (direct-fft-recursive-4 a W-table)
8002 ;; This is a direcct complex fft, using a decimation-in-time
8003 ;; algorithm with inputs in natural order and outputs in
8004 ;; bit-reversed order. The table of "twiddle" factors is in
8005 ;; bit-reversed order.
8007 ;; this is from page 66 of Chu and George, except that we have
8008 ;; combined passes in pairs to cut the number of passes through
8009 ;; the vector a
8011 (let ((W (##f64vector (macro-inexact-+0)
8012 (macro-inexact-+0)
8013 (macro-inexact-+0)
8014 (macro-inexact-+0))))
8016 (define (main-loop M N K SizeOfGroup)
8018 (##declare (not interrupts-enabled))
8020 (let inner-loop ((K K)
8021 (JFirst M))
8023 (if (##fixnum.< JFirst N)
8025 (let* ((JLast (##fixnum.+ JFirst SizeOfGroup)))
8027 (if (##fixnum.even? K)
8028 (begin
8029 (##f64vector-set! W 0 (##f64vector-ref W-table K))
8030 (##f64vector-set! W 1 (##f64vector-ref W-table (##fixnum.+ K 1))))
8031 (begin
8032 (##f64vector-set! W 0 (##flonum.- (##f64vector-ref W-table K)))
8033 (##f64vector-set! W 1 (##f64vector-ref W-table (##fixnum.- K 1)))))
8035 ;; we know the that the next two complex roots of
8036 ;; unity have index 2K and 2K+1 so that the 2K+1
8037 ;; index root can be gotten from the 2K index root
8038 ;; in the same way that we get W_0 and W_1 from the
8039 ;; table depending on whether K is even or not
8041 (##f64vector-set! W 2 (##f64vector-ref W-table (##fixnum.* K 2)))
8042 (##f64vector-set! W 3 (##f64vector-ref W-table (##fixnum.+ (##fixnum.* K 2) 1)))
8044 (let J-loop ((J0 JFirst))
8045 (if (##fixnum.< J0 JLast)
8047 (let* ((J0 J0)
8048 (J1 (##fixnum.+ J0 1))
8049 (J2 (##fixnum.+ J0 SizeOfGroup))
8050 (J3 (##fixnum.+ J2 1))
8051 (J4 (##fixnum.+ J2 SizeOfGroup))
8052 (J5 (##fixnum.+ J4 1))
8053 (J6 (##fixnum.+ J4 SizeOfGroup))
8054 (J7 (##fixnum.+ J6 1)))
8056 (let ((W_0 (##f64vector-ref W 0))
8057 (W_1 (##f64vector-ref W 1))
8058 (W_2 (##f64vector-ref W 2))
8059 (W_3 (##f64vector-ref W 3))
8060 (a_J0 (##f64vector-ref a J0))
8061 (a_J1 (##f64vector-ref a J1))
8062 (a_J2 (##f64vector-ref a J2))
8063 (a_J3 (##f64vector-ref a J3))
8064 (a_J4 (##f64vector-ref a J4))
8065 (a_J5 (##f64vector-ref a J5))
8066 (a_J6 (##f64vector-ref a J6))
8067 (a_J7 (##f64vector-ref a J7)))
8069 ;; first we do the (overlapping) pairs of
8070 ;; butterflies with entries 2*SizeOfGroup
8071 ;; apart.
8073 (let ((Temp_0 (##flonum.- (##flonum.* W_0 a_J4)
8074 (##flonum.* W_1 a_J5)))
8075 (Temp_1 (##flonum.+ (##flonum.* W_0 a_J5)
8076 (##flonum.* W_1 a_J4)))
8077 (Temp_2 (##flonum.- (##flonum.* W_0 a_J6)
8078 (##flonum.* W_1 a_J7)))
8079 (Temp_3 (##flonum.+ (##flonum.* W_0 a_J7)
8080 (##flonum.* W_1 a_J6))))
8082 (let ((a_J0 (##flonum.+ a_J0 Temp_0))
8083 (a_J1 (##flonum.+ a_J1 Temp_1))
8084 (a_J2 (##flonum.+ a_J2 Temp_2))
8085 (a_J3 (##flonum.+ a_J3 Temp_3))
8086 (a_J4 (##flonum.- a_J0 Temp_0))
8087 (a_J5 (##flonum.- a_J1 Temp_1))
8088 (a_J6 (##flonum.- a_J2 Temp_2))
8089 (a_J7 (##flonum.- a_J3 Temp_3)))
8091 ;; now we do the two (disjoint) pairs
8092 ;; of butterflies distance SizeOfGroup
8093 ;; apart, the first pair with W2+W3i,
8094 ;; the second with -W3+W2i
8096 ;; we rewrite the multipliers so I
8097 ;; don't hurt my head too much when
8098 ;; thinking about them.
8100 (let ((W_0 W_2)
8101 (W_1 W_3)
8102 (W_2 (##flonum.- W_3))
8103 (W_3 W_2))
8105 (let ((Temp_0
8106 (##flonum.- (##flonum.* W_0 a_J2)
8107 (##flonum.* W_1 a_J3)))
8108 (Temp_1
8109 (##flonum.+ (##flonum.* W_0 a_J3)
8110 (##flonum.* W_1 a_J2)))
8111 (Temp_2
8112 (##flonum.- (##flonum.* W_2 a_J6)
8113 (##flonum.* W_3 a_J7)))
8114 (Temp_3
8115 (##flonum.+ (##flonum.* W_2 a_J7)
8116 (##flonum.* W_3 a_J6))))
8118 (let ((a_J0 (##flonum.+ a_J0 Temp_0))
8119 (a_J1 (##flonum.+ a_J1 Temp_1))
8120 (a_J2 (##flonum.- a_J0 Temp_0))
8121 (a_J3 (##flonum.- a_J1 Temp_1))
8122 (a_J4 (##flonum.+ a_J4 Temp_2))
8123 (a_J5 (##flonum.+ a_J5 Temp_3))
8124 (a_J6 (##flonum.- a_J4 Temp_2))
8125 (a_J7 (##flonum.- a_J5 Temp_3)))
8127 (##f64vector-set! a J0 a_J0)
8128 (##f64vector-set! a J1 a_J1)
8129 (##f64vector-set! a J2 a_J2)
8130 (##f64vector-set! a J3 a_J3)
8131 (##f64vector-set! a J4 a_J4)
8132 (##f64vector-set! a J5 a_J5)
8133 (##f64vector-set! a J6 a_J6)
8134 (##f64vector-set! a J7 a_J7)
8136 (J-loop (##fixnum.+ J0 2)))))))))
8137 (inner-loop (##fixnum.+ K 1)
8138 (##fixnum.+ JFirst (##fixnum.* SizeOfGroup 4)))))))))
8140 (define (recursive-bit M N K SizeOfGroup)
8141 (if (##fixnum.<= 2 SizeOfGroup)
8142 (begin
8143 (main-loop M N K SizeOfGroup)
8144 (if (##fixnum.< 2048 (##fixnum.- N M))
8145 (let ((new-size (##fixnum.arithmetic-shift-right (##fixnum.- N M) 2)))
8146 (recursive-bit M
8147 (##fixnum.+ M new-size)
8148 (##fixnum.* K 4)
8149 (##fixnum.arithmetic-shift-right SizeOfGroup 2))
8150 (recursive-bit (##fixnum.+ M new-size)
8151 (##fixnum.+ M (##fixnum.* new-size 2))
8152 (##fixnum.+ (##fixnum.* K 4) 1)
8153 (##fixnum.arithmetic-shift-right SizeOfGroup 2))
8154 (recursive-bit (##fixnum.+ M (##fixnum.* new-size 2))
8155 (##fixnum.+ M (##fixnum.* new-size 3))
8156 (##fixnum.+ (##fixnum.* K 4) 2)
8157 (##fixnum.arithmetic-shift-right SizeOfGroup 2))
8158 (recursive-bit (##fixnum.+ M (##fixnum.* new-size 3))
8159 N
8160 (##fixnum.+ (##fixnum.* K 4) 3)
8161 (##fixnum.arithmetic-shift-right SizeOfGroup 2)))
8162 (recursive-bit M
8163 N
8164 (##fixnum.* K 4)
8165 (##fixnum.arithmetic-shift-right SizeOfGroup 2))))))
8167 (define (radix-2-pass a)
8169 ;; If we're here, the size of our (conceptually complex)
8170 ;; array is not a power of 4, so we need to do a basic radix
8171 ;; two pass with w=1 (so W[0]=1.0 and W[1] = 0.) and then
8172 ;; call recursive-bit appropriately on the two half arrays.
8174 (declare (not interrupts-enabled))
8176 (let ((SizeOfGroup
8177 (##fixnum.arithmetic-shift-right (##f64vector-length a) 1)))
8178 (let loop ((J0 0))
8179 (if (##fixnum.< J0 SizeOfGroup)
8180 (let ((J0 J0)
8181 (J2 (##fixnum.+ J0 SizeOfGroup)))
8182 (let ((J1 (##fixnum.+ J0 1))
8183 (J3 (##fixnum.+ J2 1)))
8184 (let ((a_J0 (##f64vector-ref a J0))
8185 (a_J1 (##f64vector-ref a J1))
8186 (a_J2 (##f64vector-ref a J2))
8187 (a_J3 (##f64vector-ref a J3)))
8188 (let ((a_J0 (##flonum.+ a_J0 a_J2))
8189 (a_J1 (##flonum.+ a_J1 a_J3))
8190 (a_J2 (##flonum.- a_J0 a_J2))
8191 (a_J3 (##flonum.- a_J1 a_J3)))
8192 (##f64vector-set! a J0 a_J0)
8193 (##f64vector-set! a J1 a_J1)
8194 (##f64vector-set! a J2 a_J2)
8195 (##f64vector-set! a J3 a_J3)
8196 (loop (##fixnum.+ J0 2))))))))))
8198 (let* ((n (##f64vector-length a))
8199 (log_n (two^p>=m n)))
8201 ;; there are n/2 complex entries in a; if n/2 is not a power
8202 ;; of 4, then do a single radix-2 pass and do the rest of
8203 ;; the passes as radix-4 passes
8205 (if (##fixnum.odd? log_n)
8206 (recursive-bit 0 n 0 (##fixnum.arithmetic-shift-right n 2))
8207 (let ((n/2 (##fixnum.arithmetic-shift-right n 1))
8208 (n/8 (##fixnum.arithmetic-shift-right n 3)))
8209 (radix-2-pass a)
8210 (recursive-bit 0 n/2 0 n/8)
8211 (recursive-bit n/2 n 1 n/8))))))
8213 ;; The following routine simply reverses the operations of the
8214 ;; previous routine.
8216 (define (inverse-fft-recursive-4 a W-table)
8218 ;; This is an complex fft, using a decimation-in-frequency algorithm
8219 ;; with inputs in bit-reversed order and outputs in natural order.
8221 ;; The organization of the algorithm has little to do with the the
8222 ;; associated algorithm on page 41 of Chu and George,
8223 ;; I just reversed the operations of the direct algorithm given
8224 ;; above (without dividing by 2 each time, so that this has to
8225 ;; be "normalized" by dividing by N/2 at the end.
8227 ;; The table of "twiddle" factors is in bit-reversed order.
8229 (let ((W (##f64vector (macro-inexact-+0)
8230 (macro-inexact-+0)
8231 (macro-inexact-+0)
8232 (macro-inexact-+0))))
8234 (define (main-loop M N K SizeOfGroup)
8235 (##declare (not interrupts-enabled))
8236 (let inner-loop ((K K)
8237 (JFirst M))
8238 (if (##fixnum.< JFirst N)
8239 (let* ((JLast (##fixnum.+ JFirst SizeOfGroup)))
8240 (if (##fixnum.even? K)
8241 (begin
8242 (##f64vector-set! W 0 (##f64vector-ref W-table K))
8243 (##f64vector-set! W 1 (##f64vector-ref W-table (##fixnum.+ K 1))))
8244 (begin
8245 (##f64vector-set! W 0 (##flonum.- (##f64vector-ref W-table K)))
8246 (##f64vector-set! W 1 (##f64vector-ref W-table (##fixnum.- K 1)))))
8247 (##f64vector-set! W 2 (##f64vector-ref W-table (##fixnum.* K 2)))
8248 (##f64vector-set! W 3 (##f64vector-ref W-table (##fixnum.+ (##fixnum.* K 2) 1)))
8249 (let J-loop ((J0 JFirst))
8250 (if (##fixnum.< J0 JLast)
8251 (let* ((J0 J0)
8252 (J1 (##fixnum.+ J0 1))
8253 (J2 (##fixnum.+ J0 SizeOfGroup))
8254 (J3 (##fixnum.+ J2 1))
8255 (J4 (##fixnum.+ J2 SizeOfGroup))
8256 (J5 (##fixnum.+ J4 1))
8257 (J6 (##fixnum.+ J4 SizeOfGroup))
8258 (J7 (##fixnum.+ J6 1)))
8259 (let ((W_0 (##f64vector-ref W 0))
8260 (W_1 (##f64vector-ref W 1))
8261 (W_2 (##f64vector-ref W 2))
8262 (W_3 (##f64vector-ref W 3))
8263 (a_J0 (##f64vector-ref a J0))
8264 (a_J1 (##f64vector-ref a J1))
8265 (a_J2 (##f64vector-ref a J2))
8266 (a_J3 (##f64vector-ref a J3))
8267 (a_J4 (##f64vector-ref a J4))
8268 (a_J5 (##f64vector-ref a J5))
8269 (a_J6 (##f64vector-ref a J6))
8270 (a_J7 (##f64vector-ref a J7)))
8271 (let ((W_00 W_2)
8272 (W_01 W_3)
8273 (W_02 (##flonum.- W_3))
8274 (W_03 W_2))
8275 (let ((Temp_0 (##flonum.- a_J0 a_J2))
8276 (Temp_1 (##flonum.- a_J1 a_J3))
8277 (Temp_2 (##flonum.- a_J4 a_J6))
8278 (Temp_3 (##flonum.- a_J5 a_J7)))
8279 (let ((a_J0 (##flonum.+ a_J0 a_J2))
8280 (a_J1 (##flonum.+ a_J1 a_J3))
8281 (a_J4 (##flonum.+ a_J4 a_J6))
8282 (a_J5 (##flonum.+ a_J5 a_J7))
8283 (a_J2 (##flonum.+ (##flonum.* W_00 Temp_0)
8284 (##flonum.* W_01 Temp_1)))
8285 (a_J3 (##flonum.- (##flonum.* W_00 Temp_1)
8286 (##flonum.* W_01 Temp_0)))
8287 (a_J6 (##flonum.+ (##flonum.* W_02 Temp_2)
8288 (##flonum.* W_03 Temp_3)))
8289 (a_J7 (##flonum.- (##flonum.* W_02 Temp_3)
8290 (##flonum.* W_03 Temp_2))))
8291 (let ((Temp_0 (##flonum.- a_J0 a_J4))
8292 (Temp_1 (##flonum.- a_J1 a_J5))
8293 (Temp_2 (##flonum.- a_J2 a_J6))
8294 (Temp_3 (##flonum.- a_J3 a_J7)))
8295 (let ((a_J0 (##flonum.+ a_J0 a_J4))
8296 (a_J1 (##flonum.+ a_J1 a_J5))
8297 (a_J2 (##flonum.+ a_J2 a_J6))
8298 (a_J3 (##flonum.+ a_J3 a_J7))
8299 (a_J4 (##flonum.+ (##flonum.* W_0 Temp_0)
8300 (##flonum.* W_1 Temp_1)))
8301 (a_J5 (##flonum.- (##flonum.* W_0 Temp_1)
8302 (##flonum.* W_1 Temp_0)))
8303 (a_J6 (##flonum.+ (##flonum.* W_0 Temp_2)
8304 (##flonum.* W_1 Temp_3)))
8305 (a_J7 (##flonum.- (##flonum.* W_0 Temp_3)
8306 (##flonum.* W_1 Temp_2))))
8307 (##f64vector-set! a J0 a_J0)
8308 (##f64vector-set! a J1 a_J1)
8309 (##f64vector-set! a J2 a_J2)
8310 (##f64vector-set! a J3 a_J3)
8311 (##f64vector-set! a J4 a_J4)
8312 (##f64vector-set! a J5 a_J5)
8313 (##f64vector-set! a J6 a_J6)
8314 (##f64vector-set! a J7 a_J7)
8315 (J-loop (##fixnum.+ J0 2)))))))))
8316 (inner-loop (##fixnum.+ K 1)
8317 (##fixnum.+ JFirst (##fixnum.* SizeOfGroup 4)))))))))
8319 (define (recursive-bit M N K SizeOfGroup)
8320 (if (##fixnum.<= 2 SizeOfGroup)
8321 (begin
8322 (if (##fixnum.< 2048 (##fixnum.- N M))
8323 (let ((new-size (##fixnum.arithmetic-shift-right (##fixnum.- N M) 2)))
8324 (recursive-bit M
8325 (##fixnum.+ M new-size)
8326 (##fixnum.* K 4)
8327 (##fixnum.arithmetic-shift-right SizeOfGroup 2))
8328 (recursive-bit (##fixnum.+ M new-size)
8329 (##fixnum.+ M (##fixnum.* new-size 2))
8330 (##fixnum.+ (##fixnum.* K 4) 1)
8331 (##fixnum.arithmetic-shift-right SizeOfGroup 2))
8332 (recursive-bit (##fixnum.+ M (##fixnum.* new-size 2))
8333 (##fixnum.+ M (##fixnum.* new-size 3))
8334 (##fixnum.+ (##fixnum.* K 4) 2)
8335 (##fixnum.arithmetic-shift-right SizeOfGroup 2))
8336 (recursive-bit (##fixnum.+ M (##fixnum.* new-size 3))
8337 N
8338 (##fixnum.+ (##fixnum.* K 4) 3)
8339 (##fixnum.arithmetic-shift-right SizeOfGroup 2)))
8340 (recursive-bit M
8341 N
8342 (##fixnum.* K 4)
8343 (##fixnum.arithmetic-shift-right SizeOfGroup 2)))
8344 (main-loop M N K SizeOfGroup))))
8346 (define (radix-2-pass a)
8347 (declare (not interrupts-enabled))
8348 (let ((SizeOfGroup
8349 (##fixnum.arithmetic-shift-right (##f64vector-length a) 1)))
8350 (let loop ((J0 0))
8351 (if (##fixnum.< J0 SizeOfGroup)
8352 (let ((J0 J0)
8353 (J2 (##fixnum.+ J0 SizeOfGroup)))
8354 (let ((J1 (##fixnum.+ J0 1))
8355 (J3 (##fixnum.+ J2 1)))
8356 (let ((a_J0 (##f64vector-ref a J0))
8357 (a_J1 (##f64vector-ref a J1))
8358 (a_J2 (##f64vector-ref a J2))
8359 (a_J3 (##f64vector-ref a J3)))
8360 (let ((a_J0 (##flonum.+ a_J0 a_J2))
8361 (a_J1 (##flonum.+ a_J1 a_J3))
8362 (a_J2 (##flonum.- a_J0 a_J2))
8363 (a_J3 (##flonum.- a_J1 a_J3)))
8364 (##f64vector-set! a J0 a_J0)
8365 (##f64vector-set! a J1 a_J1)
8366 (##f64vector-set! a J2 a_J2)
8367 (##f64vector-set! a J3 a_J3)
8368 (loop (##fixnum.+ J0 2))))))))))
8370 (let* ((n (##f64vector-length a))
8371 (log_n (two^p>=m n)))
8372 (if (##fixnum.odd? log_n)
8373 (recursive-bit 0 n 0 (##fixnum.arithmetic-shift-right n 2))
8374 (let ((n/2 (##fixnum.arithmetic-shift-right n 1))
8375 (n/8 (##fixnum.arithmetic-shift-right n 3)))
8376 (recursive-bit 0 n/2 0 n/8)
8377 (recursive-bit n/2 n 1 n/8)
8378 (radix-2-pass a))))))
8380 #|
8382 See the wonderful paper
8383 Rapid multiplication modulo the sum and difference of highly
8384 composite numbers, by Colin Percival, electronically published
8385 by Mathematics of Computation, number S 0025-5718(02)01419-9, URL
8386 http://www.ams.org/journal-getitem?pii=S0025-5718-02-01419-9
8387 that gives these very nice error bounds. This should be published
8388 in the paper journal sometime after March 2002.
8390 What we're going to do is:
8392 Take x and y, each with <= 2^n 8-bit fdigits.
8393 Put the fdigits of x and y into the real parts of the
8394 first 2^n complex entries of a vector of length 2^{n+1}.
8395 Do ffts of length 2^{n+1}.
8396 Multiply the complex fft coefficients of x and y.
8397 do an inverse fft of length 2^{n+1}.
8398 Extract the digits of x*y from the real parts of the inverse fft.
8400 From theorem 5.1 we get the following error bound:
8402 (define epsilon (expt 2. -53))
8403 (define bigepsilon (* epsilon (sqrt 5)))
8404 (define n 26)
8405 (define beta 4.158491068379826e-16) ;; accuracy of trigonometric inputs (check) error in product of three entries from the tables
8406 (define norm-x (sqrt (* (expt 2 n) (* 255 255))))
8407 (define norm-y norm-x)
8408 (define error (* norm-x
8409 norm-y
8410 ;; the following three lines use the slight overestimate that
8411 ;; ln(1+epsilon) = epsilon, etc.
8412 ;; there are more accurate ways to calculate this, but we
8413 ;; don't really need them.
8414 (- (exp (+ (* 3 (+ n 1) epsilon)
8415 (* (+ (* 3 (+ n 1)) 1) bigepsilon)
8416 (* 3 (+ n 1) beta)))
8417 1)))
8418 (pp error)
8420 Error bound is .27518123388290405 < 1/2
8422 So if x and y have fewer than 2^{26}\times 8=536,870,912 bits, this computes the product exactly.
8424 It appears that we need tables only of size 2^9 complex entries rather than 2^10 if we do this. That would
8425 cut down on memory.
8427 Let's look at what happens when you have 4-bit fft words:
8429 (define epsilon (expt 2. -53))
8430 (define bigepsilon (* epsilon (sqrt 5)))
8431 (define n 34)
8432 (define beta 4.158491068379826e-16) ;; accuracy of trigonometric inputs
8433 (define l 4)
8434 (define norm-x (sqrt (* (expt 2 n) (* 15 15))))
8435 (define norm-y norm-x)
8436 (define error (* norm-x
8437 norm-y
8438 (- (exp (+ (* 3 (+ n 1) epsilon)
8439 (* (+ (* 3 (+ n 1)) 1) bigepsilon)
8440 (* 3 (+ n 1) beta)))
8441 1)))
8442 (pp error)
8444 Error bound is .31585693359375 < 1/2
8446 So if x and y have fewer than 2^{34}\times 4=68,719,476,736 bits, this
8447 computes the product exactly.
8449 But then I would have to increase the size of the tables to 2^{11}
8450 complex entries each, so we'd have tables of 4 times the size.
8452 I think I won't add a four-bit fft word option for now.
8454 Because the fft algorithm as written requires temporary storage at least
8455 sixteen times the size of the final result, people working with large
8456 integers but barely enough memory on 64-bit machines may wish to
8457 set! ##bignum.fft-mul-max-width to a slightly smaller value so that
8458 karatsuba will kick in earlier for the largest integers.
8460 COMMENTS FOR THE RAC (Right-Angle Convolution) VERSION
8462 What we're going to do is:
8464 Take x and y, which together have a total of <= 2^{n+1} 8-bit fdigits.
8465 We take the fdigits of f and put them into the real parts of a complex
8466 vector of length 2^n; if there are any left over, place the rest in the
8467 imaginary parts of the complex vector, starting over at the 0 entry.
8468 We do the same for y.
8469 We componentwise multiply x_j by e^{\pi/2 i j/2^n}; similarly for y_j.
8470 (This is the "right-angle" part of the right-angle transform.)
8471 The maximum possible product of |x|_2 and |y|_2 are when they both
8472 have 2^n eight-bit digits.
8473 Do ffts of length 2^n.
8474 Multiply the complex fft coefficients of x and y.
8475 do an inverse fft of length 2^n.
8476 We componentwise multiply the result by e^{-\pi/2 i j/2^n}, i.e.,
8477 the inverse of the entries of the weights applied to x and y
8479 Extract the digits of x*y from the real parts and then the imaginary
8480 parts of the weighted inverse fft.
8482 From Theorem 6.1 and the following displayed equation we have
8484 (define epsilon (expt 2. -53))
8485 (define bigepsilon (* epsilon (sqrt 5)))
8486 (define n 26)
8487 (define beta 4.164343159519809e-16) ;; accuracy of trigonometric inputs (check) error in product of three entries from the tables
8488 (define norm-x (sqrt (* (expt 2 n) (* 255 255))))
8489 (define norm-y norm-x)
8490 (define error (* norm-x
8491 norm-y
8492 ;; the following three lines use the slight overestimate that
8493 ;; ln(1+epsilon) = epsilon, etc.
8494 ;; there are more accurate ways to calculate this, but we
8495 ;; don't really need them.
8496 (- (exp (+ (* 3 n epsilon)
8497 (* (+ (* 3 n) 4) bigepsilon)
8498 (* (+ (* 3 n) 3) beta)))
8499 1)))
8500 (pp error)
8502 The error bound is .2742122858762741, so we're cool.
8504 |#
8506 #|
8508 Let n = 2^{\log n}; the following routine calculates
8510 e^{\pi/2 i (j/n)} j=0,\ldots, n/2-1
8512 It uses the tables med-lut and high-lut (both described above) and
8513 low-lut-rac, which contains in fftluts-9.scm
8515 e^{\pi/2 i (j/2^9)}, j=0,\ldots, 2^8-1
8517 It uses the same general strategy as make-w, except, because the
8518 final result is in normal order rather than bit-reversed order, we
8519 start with the highest table and work our way to the lowest. As
8520 noted above, this should result in slightly smaller error than from make-w.
8522 Instead of always building a new table, one could reuse a bigger one with
8523 a stride (do the math). I don't want to do this, however; I'd rather build
8524 a new, compact table and hope that this will result in fewer cache/TLB/page
8525 misses.
8527 |#
8529 (define (make-w-rac log-n)
8530 (let* ((n (##expt 2 log-n))
8531 (result (##make-f64vector n))) ;; contains n/2 complexes
8533 (define (copy-lut lut stride)
8535 ;; copies the (conceptually complex) entries
8536 ;; lut[0], lut[(stride/2)], lut[2*(stride/2)], ...
8537 ;; to the first entries of result. We stop when we hit
8538 ;; the end of lut.
8540 (##declare (not interrupts-enabled))
8541 (let ((lut-size (##f64vector-length lut)))
8542 (do ((i 0 (##fixnum.+ i 2))
8543 (j 0 (##fixnum.+ j stride)))
8544 ((##fixnum.= j lut-size) result)
8545 (##f64vector-set! result i (##f64vector-ref lut j ))
8546 (##f64vector-set! result (##fixnum.+ i 1) (##f64vector-ref lut (##fixnum.+ j 1))))))
8548 (define (extend-lut multiplier-lut start)
8550 ;; we multiply the table from 0 to start-1 (in pairs of reals
8551 ;; as complexes) by all the multipliers in multiplier-lut
8552 ;; starting at 2 (again in pairs of reals)
8554 (let ((end (##f64vector-length multiplier-lut)))
8555 (let loop ((i start)
8556 (j 2))
8557 (if (##fixnum.< j end)
8558 (let* ((multiplier-real (##f64vector-ref multiplier-lut j))
8559 (multiplier-imag (##f64vector-ref multiplier-lut (##fixnum.+ j 1))))
8560 (let inner ((i i)
8561 (k 0))
8562 (declare (not interrupts-enabled))
8563 (if (##fixnum.< k start)
8564 (let* ((real (##f64vector-ref result k))
8565 (imag (##f64vector-ref result (##fixnum.+ k 1)))
8566 (result-real (##flonum.- (##flonum.* multiplier-real real)
8567 (##flonum.* multiplier-imag imag)))
8568 (result-imag (##flonum.+ (##flonum.* multiplier-real imag)
8569 (##flonum.* multiplier-imag real))))
8570 (##f64vector-set! result i result-real)
8571 (##f64vector-set! result (##fixnum.+ i 1) result-imag)
8572 (inner (##fixnum.+ i 2)
8573 (##fixnum.+ k 2)))
8574 (loop i
8575 (##fixnum.+ j 2)))))
8576 result))))
8578 (cond ((##fixnum.= n lut-table-size)
8579 low-lut-rac)
8581 ((##fixnum.< n lut-table-size)
8582 (let ((stride (##fixnum.quotient (##fixnum.* lut-table-size 2) n))) ;; = 2 when n = lut-table-size, etc.
8583 (copy-lut low-lut-rac stride)))
8585 ((##fixnum.<= n lut-table-size^2)
8586 (let* ((stride (##fixnum.quotient (##fixnum.* lut-table-size^2 2) n))
8587 (start (##fixnum.quotient (##fixnum.* lut-table-size 4) stride))) ;; = 2 lut-table-size when n=lut-table-size^2
8588 (copy-lut med-lut stride)
8589 (extend-lut low-lut-rac (##fixnum.arithmetic-shift-right n (##fixnum.- log-lut-table-size 1)))))
8591 ((##fixnum.<= n lut-table-size^3)
8592 (let* ((stride (##fixnum.quotient (##fixnum.* lut-table-size^3 2) n))
8593 (start (##fixnum.quotient (##fixnum.* lut-table-size 4) stride)))
8594 (copy-lut high-lut stride)
8595 (extend-lut med-lut start)
8596 (extend-lut low-lut-rac (##fixnum.* start lut-table-size))))
8597 (else
8598 (error "asking for too large a table")))))
8600 (define (bignum->f64vector-rac x a)
8602 ;; Copies the first (##f64vector-length a)/2 fdigits of x into the
8603 ;; even components of a, which represent the real parts of complex
8604 ;; elements, and then the rest of the fdigits of x into the odd
8605 ;; components of a, starting over at 1.
8607 (let ((two^n (##f64vector-length a))
8608 (x-length (##bignum.fdigit-length x)))
8610 (if (##fixnum.<= (##fixnum.* x-length 2)
8611 two^n)
8612 ;; all imaginary parts are 0.
8613 (let loop1 ((i 0)
8614 (j 0))
8615 (##declare (not interrupts-enabled))
8616 (if (##fixnum.< i x-length)
8617 (let ((digit-real (##flonum.<-fixnum (##bignum.fdigit-ref x i))))
8618 (##f64vector-set! a j digit-real)
8619 (##f64vector-set! a (##fixnum.+ j 1) (macro-inexact-+0))
8620 (loop1 (##fixnum.+ i 1)
8621 (##fixnum.+ j 2)))
8622 ;; all parts are zero
8623 (let loop2 ((j j))
8624 (if (##fixnum.< j two^n)
8625 (begin
8626 (##f64vector-set! a j (macro-inexact-+0))
8627 (##f64vector-set! a (##fixnum.+ j 1) (macro-inexact-+0))
8628 (loop2 (##fixnum.+ j 2)))))))
8630 (let ((offset (##fixnum.arithmetic-shift-right two^n 1)))
8631 (let loop1 ((i 0)
8632 (j 0))
8633 (##declare (not interrupts-enabled))
8634 (if (##fixnum.< (##fixnum.+ i offset) x-length)
8635 (let ((digit-real (##flonum.<-fixnum (##bignum.fdigit-ref x i )))
8636 (digit-imag (##flonum.<-fixnum (##bignum.fdigit-ref x (##fixnum.+ i offset)))))
8637 (##f64vector-set! a j digit-real)
8638 (##f64vector-set! a (##fixnum.+ j 1) digit-imag)
8639 (loop1 (##fixnum.+ i 1)
8640 (##fixnum.+ j 2)))
8641 ;; all imaginary parts are 0.
8642 (let loop2 ((i i)
8643 (j j))
8644 (if (##fixnum.< j two^n)
8645 (let ((digit-real (##flonum.<-fixnum (##bignum.fdigit-ref x i))))
8646 (##f64vector-set! a j digit-real)
8647 (##f64vector-set! a (##fixnum.+ j 1) (macro-inexact-+0))
8648 (loop2 (##fixnum.+ i 1)
8649 (##fixnum.+ j 2)))))))))))
8651 (define (componentwise-rac-multiply a table)
8653 ;; the (conceptually complex) entries of table are
8654 ;; e^{\pi/2 i (j/2^n)}, j=0,...,2^{n-1}-1.
8655 ;; We multiply a_i componentwise by table_i, using symmetry when i\geq 2^{n-1}
8657 (let ((table-size (##f64vector-length table))
8658 (a-size (##f64vector-length a)))
8659 (declare (not interrupts-enabled)) ;; note that this means we have to be careful not to cons.
8660 (let loop ((i 2)
8661 (j 2))
8662 (if (##fixnum.< i table-size)
8663 (let ((multiplier-real (##f64vector-ref table i))
8664 (multiplier-imag (##f64vector-ref table (##fixnum.+ i 1))))
8665 (let ((a_j-real (##f64vector-ref a j ))
8666 (a_j-imag (##f64vector-ref a (##fixnum.+ j 1)))
8667 (a_N-j-real (##f64vector-ref a (##fixnum.- a-size j )))
8668 (a_N-j-imag (##f64vector-ref a (##fixnum.- a-size j -1))))
8669 (let ((result_j-real (##flonum.- (##flonum.* a_j-real multiplier-real)
8670 (##flonum.* a_j-imag multiplier-imag)))
8671 (result_j-imag (##flonum.+ (##flonum.* a_j-imag multiplier-real)
8672 (##flonum.* a_j-real multiplier-imag)))
8673 ;; if multipler_j=(make-rectangular r i) then multiplier_{N-j}=(make-rectangular i r)
8674 (result_N-j-real (##flonum.- (##flonum.* a_N-j-real multiplier-imag)
8675 (##flonum.* a_N-j-imag multiplier-real)))
8676 (result_N-j-imag (##flonum.+ (##flonum.* a_N-j-imag multiplier-imag)
8677 (##flonum.* a_N-j-real multiplier-real))))
8678 (##f64vector-set! a j result_j-real)
8679 (##f64vector-set! a (##fixnum.+ j 1) result_j-imag)
8680 (##f64vector-set! a (##fixnum.- a-size j ) result_N-j-real)
8681 (##f64vector-set! a (##fixnum.- a-size j -1) result_N-j-imag)
8682 (loop (##fixnum.+ i 2)
8683 (##fixnum.+ j 2)))))
8684 (let ((multiplier-real .7071067811865476) ;; here the multiplier is always (sqrt i)
8685 (multiplier-imag .7071067811865476)
8686 (a_j-real (##f64vector-ref a j))
8687 (a_j-imag (##f64vector-ref a (##fixnum.+ j 1))))
8688 (let ((result_j-real (##flonum.- (##flonum.* a_j-real multiplier-real)
8689 (##flonum.* a_j-imag multiplier-imag)))
8690 (result_j-imag (##flonum.+ (##flonum.* a_j-imag multiplier-real)
8691 (##flonum.* a_j-real multiplier-imag))))
8692 (##f64vector-set! a j result_j-real)
8693 (##f64vector-set! a (##fixnum.+ j 1) result_j-imag)))))))
8695 (define (componentwise-rac-multiply-conjugate a table)
8696 ;; the (conceptually complex) entries of table are
8697 ;; e^{\pi/2 i (j/2^n)}, j=0,...,2^{n-1}-1.
8698 ;; We multiply a_i componentwise by the conjugate/inverse of table_i, using symmetry when i\geq 2^{n-1}
8700 (let ((table-size (##f64vector-length table))
8701 (a-size (##f64vector-length a)))
8702 (declare (not interrupts-enabled)) ;; note that this means we have to be careful not to cons.
8703 (let loop ((i 2)
8704 (j 2))
8705 (if (##fixnum.< i table-size)
8706 (let ((multiplier-real (##f64vector-ref table i))
8707 (multiplier-imag (##f64vector-ref table (##fixnum.+ i 1))))
8708 (let ((a_j-real (##f64vector-ref a j ))
8709 (a_j-imag (##f64vector-ref a (##fixnum.+ j 1)))
8710 (a_N-j-real (##f64vector-ref a (##fixnum.- a-size j )))
8711 (a_N-j-imag (##f64vector-ref a (##fixnum.- a-size j -1))))
8713 (let ((result_j-real (##flonum.+ (##flonum.* a_j-real multiplier-real)
8714 (##flonum.* a_j-imag multiplier-imag)))
8715 (result_j-imag (##flonum.- (##flonum.* a_j-imag multiplier-real)
8716 (##flonum.* a_j-real multiplier-imag)))
8717 ;; if multipler_j=(make-rectangular r i) then multiplier_{N-j}=(make-rectangular i r)
8718 (result_N-j-real (##flonum.+ (##flonum.* a_N-j-real multiplier-imag)
8719 (##flonum.* a_N-j-imag multiplier-real)))
8720 (result_N-j-imag (##flonum.- (##flonum.* a_N-j-imag multiplier-imag)
8721 (##flonum.* a_N-j-real multiplier-real))))
8722 (##f64vector-set! a j result_j-real)
8723 (##f64vector-set! a (##fixnum.+ j 1) result_j-imag)
8724 (##f64vector-set! a (##fixnum.- a-size j ) result_N-j-real)
8725 (##f64vector-set! a (##fixnum.- a-size j -1) result_N-j-imag)
8726 (loop (##fixnum.+ i 2)
8727 (##fixnum.+ j 2)))))
8728 (let ((multiplier-real .7071067811865476) ;; here the multiplier is always (sqrt i)
8729 (multiplier-imag .7071067811865476)
8730 (a_j-real (##f64vector-ref a j))
8731 (a_j-imag (##f64vector-ref a (##fixnum.+ j 1))))
8732 (let ((result_j-real (##flonum.+ (##flonum.* a_j-real multiplier-real)
8733 (##flonum.* a_j-imag multiplier-imag)))
8734 (result_j-imag (##flonum.- (##flonum.* a_j-imag multiplier-real)
8735 (##flonum.* a_j-real multiplier-imag))))
8736 (##f64vector-set! a j result_j-real)
8737 (##f64vector-set! a (##fixnum.+ j 1) result_j-imag)))))))
8739 (define (componentwise-complex-multiply a b)
8740 (let ((two^n (##f64vector-length a)))
8741 (let loop ((j 0))
8742 (##declare (not interrupts-enabled))
8743 (if (##fixnum.< j two^n)
8744 (let ((aj (##f64vector-ref a j))
8745 (aj+1 (##f64vector-ref a (##fixnum.+ j 1)))
8746 (bj (##f64vector-ref b j))
8747 (bj+1 (##f64vector-ref b (##fixnum.+ j 1))))
8748 (##f64vector-set! a j
8749 (##flonum.- (##flonum.* bj aj) (##flonum.* aj+1 bj+1)))
8750 (##f64vector-set! a (##fixnum.+ j 1)
8751 (##flonum.+ (##flonum.* bj aj+1) (##flonum.* aj bj+1)))
8752 (loop (##fixnum.+ j 2)))))))
8754 (define (bignum<-f64vector-rac a result result-length)
8756 ;; result-length is > the number of complex entries in a, because
8757 ;; otherwise the length of a would be cut in half.
8759 (let* ((normalizer (##flonum./ (##flonum.<-fixnum (##fixnum.arithmetic-shift-right (##f64vector-length a) 1))))
8760 (fbase (##flonum.<-fixnum ##bignum.fdigit-base))
8761 (fbase-inverse (##flonum./ fbase)))
8762 (let ((loop-carry (##f64vector (macro-inexact-+0))))
8763 (let loop ((i 0)
8764 (j 0)
8765 (limit (##fixnum.arithmetic-shift-right (##f64vector-length a) 1))) ;; here we assume that there are always at least this many fdigits
8766 (##declare (not interrupts-enabled))
8767 (if (##fixnum.< i limit)
8768 (let* ((t
8769 (##flonum.+ (##flonum.+ (##f64vector-ref loop-carry 0)
8770 (macro-inexact-+1/2))
8771 (##flonum.* (##f64vector-ref a j)
8772 normalizer)))
8773 (carry
8774 (##flonum.floor (##flonum.* t fbase-inverse)))
8775 (digit
8776 (##flonum.- t (##flonum.* carry fbase))))
8777 (##bignum.fdigit-set! result i (##flonum->fixnum digit))
8778 (##f64vector-set! loop-carry 0 carry)
8779 (loop (##fixnum.+ i 1)
8780 (##fixnum.+ j 2)
8781 limit))
8782 (if (##fixnum.even? j)
8783 (loop i
8784 1
8785 result-length)))))))
8787 ;; this is the right-angle convolution method of section 6 in Percival's paper
8789 (let* ((x-length (##bignum.fdigit-length x))
8790 (y-length (##bignum.fdigit-length y))
8791 (result-length (##fixnum.+ x-length y-length))
8792 (result (##bignum.make
8793 (##fixnum.quotient
8794 result-length
8795 (##fixnum.quotient ##bignum.adigit-width
8796 ##bignum.fdigit-width))
8797 #f
8798 #f))
8799 ;; minimum power of 2 >= x-length + y-length, half # of complex elements in fft vectors
8800 (log-two^n (##fixnum.- (two^p>=m (##fixnum.+ x-length y-length)) 1))
8801 (two^n (##fixnum.arithmetic-shift-left 1 log-two^n)))
8803 (let ((a (##make-f64vector (##fixnum.* two^n 2)))
8804 (table (make-w (##fixnum.- log-two^n 1)))
8805 (rac-table (make-w-rac log-two^n)))
8807 (bignum->f64vector-rac x a)
8808 (componentwise-rac-multiply a rac-table)
8809 (direct-fft-recursive-4 a table)
8810 (if (##eq? x y)
8811 (componentwise-complex-multiply a a)
8812 (let ((b (##make-f64vector (##fixnum.* two^n 2))))
8813 (bignum->f64vector-rac y b)
8814 (componentwise-rac-multiply b rac-table)
8815 (direct-fft-recursive-4 b table)
8816 (componentwise-complex-multiply a b)))
8817 (inverse-fft-recursive-4 a table)
8818 (componentwise-rac-multiply-conjugate a rac-table)
8819 (bignum<-f64vector-rac a result result-length)
8820 (cleanup x y result))))
8823 (define (naive-mul x x-length y y-length) ;; multiplies x by each digit of y
8824 (let ((result
8825 (##bignum.make
8826 (##fixnum.+ (##bignum.adigit-length x) (##bignum.adigit-length y))
8827 #f
8828 #f)))
8829 (##declare (not interrupts-enabled))
8830 (if (##eq? x y)
8832 (let loop1 ((k 1)) ;; multiply off-diagonals
8833 (if (##fixnum.< k x-length)
8834 (let ((multiplier (##bignum.mdigit-ref x k)))
8835 (if (##eq? multiplier 0)
8836 (loop1 (##fixnum.+ k 1))
8837 (let loop2 ((i 0)
8838 (j k)
8839 (carry 0))
8840 (if (##fixnum.< i k)
8841 (loop2 (##fixnum.+ i 1)
8842 (##fixnum.+ j 1)
8843 (##bignum.mdigit-mul! result
8844 j
8845 x
8846 i
8847 multiplier
8848 carry))
8849 (begin
8850 (##bignum.mdigit-set! result j carry)
8851 (loop1 (##fixnum.+ k 1)))))))
8852 (let ((result-length (##bignum.adigit-length result)))
8853 (let loop3 ((k 0) ;; double the off-diagonal terms
8854 (carry 0))
8855 (if (##fixnum.< k result-length)
8856 (loop3 (##fixnum.+ k 1)
8857 (##bignum.adigit-add! result
8858 k
8859 result
8860 k
8861 carry))
8862 (let ((shift ##bignum.mdigit-width)
8863 (mask ##bignum.mdigit-base-minus-1))
8864 (let loop4 ((k 0) ;; add squares of diagonals
8865 (two-k 0)
8866 (carry 0))
8867 (if (##fixnum.< k x-length)
8868 (let ((next-digit
8869 (##fixnum.+ (##bignum.mdigit-mul!
8870 result
8871 two-k
8872 x
8873 k
8874 (##bignum.mdigit-ref x k)
8875 carry)
8876 (##bignum.mdigit-ref
8877 result
8878 (##fixnum.+ two-k 1)))))
8879 (##bignum.mdigit-set!
8880 result
8881 (##fixnum.+ two-k 1)
8882 (##fixnum.bitwise-and next-digit mask))
8883 (loop4 (##fixnum.+ k 1)
8884 (##fixnum.+ two-k 2)
8885 (##fixnum.arithmetic-shift-right
8886 next-digit
8887 shift)))
8888 (cleanup x y result)))))))))
8890 (let loop1 ((k 0))
8891 (##declare (not interrupts-enabled))
8892 (if (##fixnum.< k y-length)
8893 (let ((multiplier (##bignum.mdigit-ref y k)))
8894 (if (##eq? multiplier 0)
8895 (loop1 (##fixnum.+ k 1))
8896 (let loop2 ((i 0)
8897 (j k)
8898 (carry 0))
8899 (if (##fixnum.< i x-length)
8900 (loop2 (##fixnum.+ i 2)
8901 (##fixnum.+ j 2)
8902 (##bignum.mdigit-mul!
8903 result
8904 (##fixnum.+ j 1)
8905 x
8906 (##fixnum.+ i 1)
8907 multiplier
8908 (##bignum.mdigit-mul! result
8909 j
8910 x
8911 i
8912 multiplier
8913 carry)))
8914 (begin
8915 (##bignum.mdigit-set! result j carry)
8916 (loop1 (##fixnum.+ k 1)))))))
8917 (cleanup x y result))))))
8919 (define (cleanup x y result)
8921 ;; Both naive-mul and fft-mul do unsigned multiplies, fix that here.
8923 (define (fix x y result)
8925 (##declare (not interrupts-enabled))
8927 (if (##bignum.negative? y)
8928 (let ((x-length (##bignum.adigit-length x)))
8929 (let loop ((i 0)
8930 (j (##bignum.adigit-length y))
8931 (borrow 0))
8932 (if (##fixnum.< i x-length)
8933 (loop (##fixnum.+ i 1)
8934 (##fixnum.+ j 1)
8935 (##bignum.adigit-sub! result j x i borrow)))))))
8937 (fix x y result)
8938 (fix y x result)
8939 (##bignum.normalize! result))
8941 (define (karatsuba-mul x y)
8942 (let* ((x-length
8943 (##bignum.adigit-length x))
8944 (y-length
8945 (##bignum.adigit-length y))
8946 (shift-digits
8947 (##fixnum.arithmetic-shift-right y-length 1))
8948 (shift-bits
8949 (##fixnum.* shift-digits ##bignum.adigit-width))
8950 (y-high
8951 (##bignum.arithmetic-shift y (##fixnum.- shift-bits)))
8952 (y-low
8953 (##extract-bit-field shift-bits 0 y)))
8954 (if (##eq? x y)
8955 (let ((high-term
8956 (##* y-high y-high))
8957 (low-term
8958 (##* y-low y-low))
8959 (mid-term
8960 (let ((arg (##- y-high y-low)))
8961 (##* arg arg))))
8962 (##+ (##arithmetic-shift high-term (##fixnum.* shift-bits 2))
8963 (##+ (##arithmetic-shift
8964 (##+ high-term
8965 (##- low-term mid-term))
8966 shift-bits)
8967 low-term)))
8968 (let ((x-high
8969 (##bignum.arithmetic-shift x (##fixnum.- shift-bits)))
8970 (x-low
8971 (##extract-bit-field shift-bits 0 x)))
8972 (let ((high-term
8973 (##* x-high y-high))
8974 (low-term
8975 (##* x-low y-low))
8976 (mid-term
8977 (##* (##- x-high x-low)
8978 (##- y-high y-low))))
8979 (##+ (##arithmetic-shift high-term (##fixnum.* shift-bits 2))
8980 (##+ (##arithmetic-shift
8981 (##+ high-term
8982 (##- low-term mid-term))
8983 shift-bits)
8984 low-term)))))))
8986 (define (mul x x-length y y-length) ;; x-length <= y-length
8987 (let ((x-width (##fixnum.* x-length ##bignum.mdigit-width)))
8988 (cond ((##fixnum.< x-width ##bignum.naive-mul-max-width)
8989 (naive-mul y y-length x x-length))
8990 ((or (##fixnum.< x-width ##bignum.fft-mul-min-width)
8991 (##fixnum.< ##bignum.fft-mul-max-width
8992 (##fixnum.* y-length ##bignum.mdigit-width)))
8993 (karatsuba-mul x y))
8994 (else
8995 (fft-mul x y)))))
8997 ;; Certain decisions must be made for multiplication.
8998 ;; First, if both bignums are small, just do naive mul to avoid
8999 ;; further overhead.
9000 ;; This is done in the main body of ##bignum.*.
9001 ;; Second, if it would help to shift out low-order zeros of an
9002 ;; argument, do so. That's done in the main body of ##bignum.*.
9003 ;; Finally, one must decide whether one is using naive mul, karatsuba, or fft.
9004 ;; This is done in mul.
9006 (define (low-bits-to-shift x)
9007 (let ((size (##integer-length x))
9008 (low-bits (##first-bit-set x)))
9009 (if (##fixnum.< size (##fixnum.+ low-bits low-bits))
9010 low-bits
9011 0)))
9013 (define (possibly-unnormalized-bignum-arithmetic-shift x bits)
9014 (if (##eq? bits 0)
9015 (if (##fixnum.= (##bignum.adigit-length x) 1)
9016 (##bignum.normalize! x)
9017 x)
9018 (##arithmetic-shift x bits)))
9020 (let ((x-length (##bignum.mdigit-length x))
9021 (y-length (##bignum.mdigit-length y)))
9022 (cond ((or (##not (use-fast-bignum-algorithms))
9023 (and (##fixnum.< x-length 50)
9024 (##fixnum.< y-length 50)))
9025 (if (##fixnum.< x-length y-length)
9026 (naive-mul y y-length x x-length)
9027 (naive-mul x x-length y y-length)))
9028 ((##eq? x y)
9029 (let ((low-bits (low-bits-to-shift x)))
9030 (if (##eq? low-bits 0)
9031 (mul x x-length x x-length)
9032 (##arithmetic-shift
9033 (##exact-int.square (##arithmetic-shift x (##fixnum.- low-bits)))
9034 (##fixnum.+ low-bits low-bits)))))
9035 (else
9036 (let ((x-low-bits (low-bits-to-shift x))
9037 (y-low-bits (low-bits-to-shift y)))
9038 (if (##eq? (##fixnum.+ x-low-bits y-low-bits) 0)
9039 (if (##fixnum.< x-length y-length)
9040 (mul x x-length y y-length)
9041 (mul y y-length x x-length))
9042 (##arithmetic-shift
9043 (##* (possibly-unnormalized-bignum-arithmetic-shift x (##fixnum.- x-low-bits))
9044 (possibly-unnormalized-bignum-arithmetic-shift y (##fixnum.- y-low-bits)))
9045 (##fixnum.+ x-low-bits y-low-bits))))))))
9047 (define-prim (##bignum.arithmetic-shift x shift)
9048 (let* ((digit-shift
9049 (if (##fixnum.< shift 0)
9050 (##fixnum.- (##fixnum.quotient (##fixnum.+ shift 1)
9051 ##bignum.adigit-width)
9052 1)
9053 (##fixnum.quotient shift ##bignum.adigit-width)))
9054 (bit-shift
9055 (##fixnum.modulo shift ##bignum.adigit-width))
9056 (x-length
9057 (##bignum.adigit-length x))
9058 (result-length
9059 (##fixnum.+ (##fixnum.+ x-length digit-shift)
9060 (if (##fixnum.zero? bit-shift) 0 1))))
9061 (if (##fixnum.< 0 result-length)
9063 (let ((result (##bignum.make result-length #f #f)))
9065 (##declare (not interrupts-enabled))
9067 (if (##fixnum.zero? bit-shift)
9068 (let ((smallest-i (##fixnum.max 0 digit-shift)))
9069 (let loop1 ((i (##fixnum.- result-length 1))
9070 (j (##fixnum.- x-length 1)))
9071 (if (##fixnum.< i smallest-i)
9072 (##bignum.normalize! result)
9073 (begin
9074 (##bignum.adigit-copy! result i x j)
9075 (loop1 (##fixnum.- i 1)
9076 (##fixnum.- j 1))))))
9077 (let ((left-fill (if (##bignum.negative? x)
9078 ##bignum.adigit-ones
9079 ##bignum.adigit-zeros))
9080 (i (##fixnum.- result-length 1))
9081 (j (##fixnum.- x-length 1))
9082 (divider bit-shift)
9083 (smallest-i (##fixnum.max 0 (##fixnum.+ digit-shift 1))))
9084 (##bignum.adigit-cat! result i left-fill 0 x j divider)
9085 (let loop2 ((i (##fixnum.- i 1))
9086 (j (##fixnum.- j 1)))
9087 (if (##fixnum.< i smallest-i)
9088 (begin
9089 (if (##not (##fixnum.< i 0))
9090 (##bignum.adigit-cat! result
9091 i
9092 x
9093 (##fixnum.+ j 1)
9094 ##bignum.adigit-zeros
9095 0
9096 divider))
9097 (##bignum.normalize! result))
9098 (begin
9099 (##bignum.adigit-cat! result
9100 i
9101 x
9102 (##fixnum.+ j 1)
9103 x
9104 j
9105 divider)
9106 (loop2 (##fixnum.- i 1)
9107 (##fixnum.- j 1))))))))
9109 (if (##bignum.negative? x)
9110 -1
9111 0))))
9113 ;;; Bignum division.
9115 (define ##reciprocal-cache (##make-table 0 #f #t #f ##eq?))
9117 (define ##bignum.mdigit-width/2
9118 (##fixnum.quotient ##bignum.mdigit-width 2))
9120 (define ##bignum.mdigit-base*16
9121 (##fixnum.* ##bignum.mdigit-base 16))
9123 (define-prim (##bignum.div u v)
9125 ;; u is an unnormalized bignum, v is a normalized exact-int
9126 ;; 0 < v <= u
9128 (define (##exact-int.reciprocal v bits)
9130 ;; returns an approximation to the reciprocal of
9131 ;; .v1 v2 v3 ...
9132 ;; where v1 is the highest set bit of v; result is of the form
9133 ;; xx . xxxxxxxxxxxxxxxxxxx where there are bits + 1 bits to the
9134 ;; right of the binary point. The result is always <= 2; see Knuth, volume 2.
9136 (let ((cached-value (##table-ref ##reciprocal-cache v #f)))
9137 (if (and cached-value
9138 (##not (##fixnum.< (##cdr cached-value) bits)))
9139 cached-value
9140 (let ((v-length (##integer-length v)))
9142 (define (recip v bits)
9143 (cond ((and cached-value
9144 (##not (##fixnum.< (##cdr cached-value) bits)))
9145 cached-value)
9146 ((##fixnum.<= bits ##bignum.mdigit-width/2)
9147 (##cons (##fixnum.quotient
9148 ##bignum.mdigit-base*16
9149 (##arithmetic-shift
9150 v
9151 (##fixnum.- ##bignum.mdigit-width/2 -3 v-length)))
9152 ##bignum.mdigit-width/2))
9153 (else
9154 (let* ((high-bits
9155 (##fixnum.arithmetic-shift-right
9156 (##fixnum.+ bits 1)
9157 1))
9158 (z-bits ;; >= high-bits + 1 to right of point
9159 (recip v high-bits))
9160 (z ;; high-bits + 1 to right of point
9161 (##arithmetic-shift
9162 (##car z-bits)
9163 (##fixnum.- high-bits (##cdr z-bits))))
9164 (v-bits ;; bits + 3 to right of point
9165 (##arithmetic-shift
9166 v
9167 (##fixnum.- (##fixnum.+ bits 3)
9168 v-length)))
9169 (v*z*z ;; 2 * high-bits + bits + 5 to right
9170 (##* v-bits (##exact-int.square z)))
9171 (two-z ;; 2 * high-bits + bits + 5 to right
9172 (##arithmetic-shift
9173 z
9174 (##fixnum.+ high-bits (##fixnum.+ bits 5))))
9175 (temp
9176 (##- two-z v*z*z))
9177 (bits-to-shift
9178 (##fixnum.+ 4 (##fixnum.+ high-bits high-bits)))
9179 (shifted-temp
9180 (##arithmetic-shift
9181 temp
9182 (##fixnum.- bits-to-shift))))
9183 (if (##fixnum.< (##first-bit-set temp) bits-to-shift)
9184 (##cons (##+ shifted-temp 1) bits)
9185 (##cons shifted-temp bits))))))
9187 (let ((result (recip v bits)))
9188 (##table-set! ##reciprocal-cache v result)
9189 result)))))
9191 (define (naive-div u v)
9193 ;; u is a normalized bignum, v is an unnormalized bignum
9194 ;; v >= ##bignum.mdigit-base
9196 (let ((n
9197 (let loop1 ((i (##fixnum.- (##bignum.mdigit-length v) 1)))
9198 (if (##fixnum.< 0 (##bignum.mdigit-ref v i))
9199 (##fixnum.+ i 1)
9200 (loop1 (##fixnum.- i 1))))))
9201 (let ((normalizing-bit-shift
9202 (##fixnum.- ##bignum.mdigit-width
9203 (##integer-length
9204 (##bignum.mdigit-ref v (##fixnum.- n 1))))))
9205 (let ((u (##bignum.arithmetic-shift u normalizing-bit-shift))
9206 (v (##bignum.arithmetic-shift v normalizing-bit-shift)))
9207 (let ((q
9208 (##bignum.make
9209 (##fixnum.+ (##fixnum.- (##bignum.adigit-length u)
9210 (##bignum.adigit-length v))
9211 2) ;; 1 is not always sufficient...
9212 #f
9213 #f))
9214 (v_n-1
9215 (##bignum.mdigit-ref v (##fixnum.- n 1)))
9216 (v_n-2 (##bignum.mdigit-ref v (##fixnum.- n 2))))
9217 (let ((m
9218 (let loop2 ((i (##fixnum.- (##bignum.mdigit-length u) 1)))
9219 (let ((u_i (##bignum.mdigit-ref u i)))
9220 (if (##fixnum.< 0 u_i)
9221 (if (##not (##fixnum.< u_i v_n-1))
9222 (##fixnum.- (##fixnum.+ i 1) n)
9223 (##fixnum.- i n))
9224 (loop2 (##fixnum.- i 1)))))))
9225 (let loop3 ((j m))
9226 (if (##not (##fixnum.< j 0))
9227 (let ((q-hat
9228 (let ((q-hat
9229 (##bignum.mdigit-quotient
9230 u
9231 (##fixnum.+ j n)
9232 v_n-1))
9233 (u_n+j-2
9234 (##bignum.mdigit-ref
9235 u
9236 (##fixnum.+ (##fixnum.- j 2) n)
9237 )))
9238 (let ((r-hat
9239 (##bignum.mdigit-remainder
9240 u
9241 (##fixnum.+ j n)
9242 v_n-1
9243 q-hat)))
9244 (if (or (##fixnum.= q-hat ##bignum.mdigit-base)
9245 (##bignum.mdigit-test?
9246 q-hat
9247 v_n-2
9248 r-hat
9249 u_n+j-2))
9250 (let ((q-hat (##fixnum.- q-hat 1))
9251 (r-hat (##fixnum.+ r-hat v_n-1)))
9252 (if (and (##fixnum.< r-hat
9253 ##bignum.mdigit-base)
9254 (or (##fixnum.= q-hat
9255 ##bignum.mdigit-base)
9256 (##bignum.mdigit-test?
9257 q-hat
9258 v_n-2
9259 r-hat
9260 u_n+j-2)))
9261 (##fixnum.- q-hat 1)
9262 q-hat))
9263 q-hat)))))
9265 (##declare (not interrupts-enabled))
9267 (let loop4 ((i j)
9268 (k 0)
9269 (borrow 0))
9270 (if (##fixnum.< k n)
9271 (loop4 (##fixnum.+ i 2)
9272 (##fixnum.+ k 2)
9273 (##bignum.mdigit-div!
9274 u
9275 (##fixnum.+ i 1)
9276 v
9277 (##fixnum.+ k 1)
9278 q-hat
9279 (##bignum.mdigit-div!
9280 u
9281 i
9282 v
9283 k
9284 q-hat
9285 borrow)))
9286 (let ((borrow
9287 (if (##fixnum.< n k)
9288 borrow
9289 (##bignum.mdigit-div!
9290 u
9291 i
9292 v
9293 k
9294 q-hat
9295 borrow))))
9296 (if (##fixnum.< borrow 0)
9297 (let loop5 ((i j)
9298 (l 0)
9299 (carry 0))
9300 (if (##fixnum.< n l)
9301 (begin
9302 (##bignum.mdigit-set!
9303 q
9304 j
9305 (##fixnum.- q-hat 1))
9306 (loop3 (##fixnum.- j 1)))
9307 (loop5 (##fixnum.+ i 1)
9308 (##fixnum.+ l 1)
9309 (##bignum.mdigit-mul!
9310 u
9311 i
9312 v
9313 l
9314 1
9315 carry))))
9316 (begin
9317 (##bignum.mdigit-set! q j q-hat)
9318 (loop3 (##fixnum.- j 1))))))))
9319 (##cons (##bignum.normalize! q)
9320 (##arithmetic-shift
9321 (##bignum.normalize! u)
9322 (##fixnum.- normalizing-bit-shift)))))))))))
9324 (define (div-one u v)
9325 (let ((m
9326 (let loop6 ((i (##fixnum.- (##bignum.mdigit-length u) 1)))
9327 (if (##fixnum.< 0 (##bignum.mdigit-ref u i))
9328 (##fixnum.+ i 1)
9329 (loop6 (##fixnum.- i 1))))))
9330 (let ((work-u (##bignum.make 1 #f #f))
9331 (q (##bignum.make (##bignum.adigit-length u) #f #f)))
9333 (##declare (not interrupts-enabled))
9335 (let loop7 ((i m)
9336 (r-hat 0))
9337 (##bignum.mdigit-set!
9338 work-u
9339 1
9340 r-hat)
9341 (##bignum.mdigit-set!
9342 work-u
9343 0
9344 (##bignum.mdigit-ref u (##fixnum.- i 1)))
9345 (let ((q-hat (##bignum.mdigit-quotient work-u 1 v)))
9346 (let ((r-hat (##bignum.mdigit-remainder work-u 1 v q-hat)))
9347 (##bignum.mdigit-set! q (##fixnum.- i 1) q-hat)
9348 (if (##fixnum.< 1 i)
9349 (loop7 (##fixnum.- i 1)
9350 r-hat)
9351 (let ()
9352 (##declare (interrupts-enabled))
9353 (##cons (##bignum.normalize! q)
9354 r-hat)))))))))
9356 (define (small-quotient-or-divisor-divide u v)
9357 ;; Here we do a quick check to catch most cases where the quotient will
9358 ;; be 1 and do a subtraction. This comes up a lot in gcd calculations.
9359 ;; Otherwise, we just call naive-div.
9360 (let ((u-mlength (##bignum.mdigit-length u))
9361 (v-mlength (##bignum.mdigit-length v)))
9362 (if (and (##fixnum.= u-mlength v-mlength)
9363 (let loop ((i (##fixnum.- u-mlength 1)))
9364 (let ((udigit (##bignum.mdigit-ref u i)))
9365 (if (##eq? udigit 0)
9366 (loop (##fixnum.- i 1))
9367 (##fixnum.< udigit
9368 (##fixnum.arithmetic-shift-left
9369 (##bignum.mdigit-ref v i)
9370 1))))))
9371 (##cons 1 (##- u v))
9372 (naive-div u v))))
9374 (define (big-divide u v)
9376 ;; u and v are positive bignums
9378 (let ((v-length (##integer-length v))
9379 (v-first-bit-set (##first-bit-set v)))
9380 ;; first we check whether it may be beneficial to shift out
9381 ;; low-order zero bits of v
9382 (if (##fixnum.>= v-first-bit-set
9383 (##fixnum.arithmetic-shift-right v-length 1))
9384 (let ((reduced-quotient
9385 (##exact-int.div
9386 (##bignum.arithmetic-shift u (##fixnum.- v-first-bit-set))
9387 (##bignum.arithmetic-shift v (##fixnum.- v-first-bit-set))))
9388 (extra-remainder
9389 (##extract-bit-field v-first-bit-set 0 u)))
9390 (##cons (##car reduced-quotient)
9391 (##+ (##arithmetic-shift (##cdr reduced-quotient)
9392 v-first-bit-set)
9393 extra-remainder)))
9394 (if (##fixnum.< v-length ##bignum.fft-mul-min-width)
9395 (small-quotient-or-divisor-divide u v)
9396 (let* ((u-length (##integer-length u))
9397 (length-difference (##fixnum.- u-length v-length)))
9398 (if (##fixnum.< length-difference ##bignum.fft-mul-min-width)
9399 (small-quotient-or-divisor-divide u v)
9400 (let* ((z-bits (##exact-int.reciprocal v length-difference))
9401 (z (##car z-bits))
9402 (bits (##cdr z-bits)))
9403 (let ((test-quotient
9404 (##bignum.arithmetic-shift
9405 (##* (##bignum.arithmetic-shift
9406 u
9407 (##fixnum.- length-difference
9408 (##fixnum.- u-length 2)))
9409 (##bignum.arithmetic-shift
9410 z
9411 (##fixnum.- length-difference bits)))
9412 (##fixnum.- -3 length-difference))))
9413 (let ((rem (##- u (##* test-quotient v))))
9414 ;; I believe, and I haven't found any counterexamples in my tests
9415 ;; to disprove it, that test-quotient can be off by at most +-1.
9416 ;; I can't prove this, however, so we put in the following loops.
9418 ;; Especially note that our reciprocal does not satisfy the
9419 ;; error bounds in Knuth's volume 2 in perhaps a vain effort to
9420 ;; save some computations. perhaps this should be fixed. blah.
9422 (cond ((##negative? rem)
9423 (let loop ((test-quotient test-quotient)
9424 (rem rem))
9425 (let ((test-quotient (##- test-quotient 1))
9426 (rem (##+ rem v)))
9427 (if (##negative? rem)
9428 (loop test-quotient rem)
9429 (##cons test-quotient rem)))))
9430 ((##< rem v)
9431 (##cons test-quotient
9432 rem))
9433 (else
9434 (let loop ((test-quotient test-quotient)
9435 (rem rem))
9436 (let ((test-quotient (##+ test-quotient 1))
9437 (rem (##- rem v)))
9438 (if (##< rem v)
9439 (##cons test-quotient rem)
9440 (loop test-quotient rem)))))))))))))))
9442 (if (##fixnum? v)
9443 (if (##fixnum.< v ##bignum.mdigit-base)
9444 (div-one u v)
9445 (begin
9446 ;; here it's probably not worth the extra cycles to check whether
9447 ;; a subtraction would be sufficient, i.e., we don't call
9448 ;; short-divisor-or-quotient-divide
9449 (naive-div u (##bignum.<-fixnum v))))
9450 (if (use-fast-bignum-algorithms)
9451 (big-divide u v)
9452 (naive-div u v))))
9454 ;;;----------------------------------------------------------------------------
9456 ;;; Exact integer operations
9457 ;;; ------------------------
9459 (define-prim (##exact-int.*-expt2 x y)
9460 (if (##fixnum.negative? y)
9461 (##ratnum.normalize x (##arithmetic-shift 1 (##fixnum.- y)))
9462 (##arithmetic-shift x y)))
9464 (define-prim (##exact-int.div x y)
9466 (define (big-quotient x y)
9467 (let* ((x-negative? (##negative? x))
9468 (abs-x (if x-negative? (##negate x) x))
9469 (y-negative? (##negative? y))
9470 (abs-y (if y-negative? (##negate y) y)))
9471 (if (##< abs-x abs-y)
9472 (##cons 0 x)
9474 ;; at least one of x and y is a bignum, so
9475 ;; here abs-x must be a bignum
9477 (let ((result (##bignum.div abs-x abs-y)))
9479 (if (##not (##eq? x-negative? y-negative?))
9480 (##set-car! result (##negate (##car result))))
9482 (if x-negative?
9483 (##set-cdr! result (##negate (##cdr result))))
9485 result))))
9487 (cond ((##eq? y 1)
9488 (##cons x 0))
9489 ((##eq? y -1)
9490 (##cons (##negate x) 0))
9491 ((##eq? x y) ;; can come up in rational arithmetic
9492 (##cons 1 0))
9493 ((##fixnum? x)
9494 (if (##fixnum? y)
9495 (##cons (##fixnum.quotient x y) ;; note: y can't be -1
9496 (##fixnum.remainder x y))
9497 ;; y is a bignum, x is a fixnum
9498 (if (##fixnum.< 1 (##bignum.adigit-length y))
9499 ;; y has at least two adigits, so
9500 ;; (abs y) > (abs x)
9501 (##cons 0 x)
9502 (big-quotient x y))))
9503 ((and (##bignum? y)
9504 (##fixnum.< 1 (##fixnum.- (##bignum.adigit-length y)
9505 (##bignum.adigit-length x))))
9506 ;; x and y are bignums, and y has at least two more adigits
9507 ;; than x, so (abs y) > (abs x)
9508 (##cons 0 x))
9509 (else
9510 (big-quotient x y))))
9512 (define-prim (##exact-int.nth-root x y)
9513 (cond ((##eq? x 0)
9514 0)
9515 ((##eq? x 1)
9516 1)
9517 ((##eq? y 1)
9518 x)
9519 ((##eq? y 2)
9520 (##car (##exact-int.sqrt x)))
9521 ((##not (##fixnum? y))
9522 1)
9523 (else
9524 (let ((length (##integer-length x)))
9525 ;; (expt 2 (- length l 1)) <= x < (expt 2 length)
9526 (cond ((##fixnum.<= length y)
9527 1)
9528 ;; result is >= 2
9529 ((##fixnum.<= length (##fixnum.* 2 y))
9530 ;; result is < 4
9531 (if (##< x (##expt 3 y))
9532 2
9533 3))
9534 ((##fixnum.even? y)
9535 (##exact-int.nth-root
9536 (##car (##exact-int.sqrt x))
9537 (##fixnum.arithmetic-shift-right y 1)))
9538 (else
9539 (let* ((length/y/2 ;; length/y/2 >= 1 because (< (* 2 y) length)
9540 (##fixnum.arithmetic-shift-right
9541 (##fixnum.quotient
9542 (##fixnum.- length 1)
9543 y)
9544 1)))
9545 (let ((init-g
9546 (let* ((top-bits
9547 (##arithmetic-shift
9548 x
9549 (##fixnum.- (##fixnum.* length/y/2 y))))
9550 (nth-root-top-bits
9551 (##exact-int.nth-root top-bits y)))
9552 (##arithmetic-shift
9553 (##+ nth-root-top-bits 1)
9554 length/y/2))))
9555 (let loop ((g init-g))
9556 (let* ((a (##expt g (##fixnum.- y 1)))
9557 (b (##* a y))
9558 (c (##* a (##fixnum.- y 1)))
9559 (d (##quotient (##+ x (##* g c)) b)))
9560 (let ((diff (##- d g)))
9561 (cond ((##not (##negative? diff))
9562 g)
9563 ((##< diff -1)
9564 (loop d))
9565 (else
9566 ;; once the difference is one, it's more
9567 ;; efficient to just decrement until g^y <= x
9568 (let loop ((g d))
9569 (if (##not (##< x (##expt g y)))
9570 g
9571 (loop (##- g 1)))))))))))))))))
9573 (define-prim (##integer-nth-root x y)
9575 (define (type-error-on-x)
9576 (##fail-check-exact-integer 1 integer-nth-root x y))
9578 (define (type-error-on-y)
9579 (##fail-check-exact-integer 2 integer-nth-root x y))
9581 (define (range-error-on-x)
9582 (##raise-range-exception 1 integer-nth-root x y))
9584 (define (range-error-on-y)
9585 (##raise-range-exception 2 integer-nth-root x y))
9587 (if (macro-exact-int? x)
9588 (if (macro-exact-int? y)
9589 (cond ((##negative? x)
9590 (range-error-on-x))
9591 ((##positive? y)
9592 (##exact-int.nth-root x y))
9593 (else
9594 (range-error-on-y)))
9595 (type-error-on-y))
9596 (type-error-on-x)))
9598 (define-prim (integer-nth-root x y)
9599 (macro-force-vars (x y)
9600 (##integer-nth-root x y)))
9602 (define-prim (##exact-int.sqrt x)
9604 ;; Derived from the paper "Karatsuba Square Root" by Paul Zimmermann,
9605 ;; INRIA technical report RR-3805, 1999. (Used in gmp 4.*)
9607 ;; Note that the statement of the theorem requires that
9608 ;; b/4 <= high-order digit of x < b which can be impossible when b is a
9609 ;; power of 2; the paper later notes that it is the lower bound that is
9610 ;; necessary, which we preserve.
9612 (if (and (##fixnum? x)
9613 ;; we require that
9614 ;; (##< (##flonum.sqrt (- (* y y) 1)) y) => #t
9615 ;; whenever x=y^2 is in this range. Here we assume that we
9616 ;; have at least as much precision as IEEE double precision and
9617 ;; we round to nearest.
9618 (or (##not (##fixnum? 4294967296)) ;; 32-bit fixnums
9619 (##fixnum.<= x 4503599627370496))) ;; 2^52
9620 (let* ((s (##flonum->fixnum (##flonum.sqrt (##flonum.<-fixnum x))))
9621 (r (##fixnum.- x (##fixnum.* s s))))
9622 (##cons s r))
9623 (let ((length/4
9624 (##fixnum.arithmetic-shift-right
9625 (##fixnum.+ (##integer-length x) 1)
9626 2)))
9627 (let* ((s-prime&r-prime
9628 (##exact-int.sqrt
9629 (##arithmetic-shift
9630 x
9631 (##fixnum.- (##fixnum.arithmetic-shift-left length/4 1)))))
9632 (s-prime
9633 (##car s-prime&r-prime))
9634 (r-prime
9635 (##cdr s-prime&r-prime)))
9636 (let* ((qu
9637 (##exact-int.div
9638 (##+ (##arithmetic-shift r-prime length/4)
9639 (##extract-bit-field length/4 length/4 x))
9640 (##arithmetic-shift s-prime 1)))
9641 (q
9642 (##car qu))
9643 (u
9644 (##cdr qu)))
9645 (let ((s
9646 (##+ (##arithmetic-shift s-prime length/4) q))
9647 (r
9648 (##- (##+ (##arithmetic-shift u length/4)
9649 (##extract-bit-field length/4 0 x))
9650 (##* q q))))
9651 (if (##negative? r)
9652 (##cons (##- s 1)
9653 (##+ r
9654 (##- (##arithmetic-shift s 1) 1)))
9655 (##cons s
9656 r))))))))
9658 (define-prim (##integer-sqrt x)
9660 (define (type-error)
9661 (##fail-check-exact-integer 1 integer-sqrt x))
9663 (define (range-error)
9664 (##raise-range-exception 1 integer-sqrt x))
9666 (if (macro-exact-int? x)
9667 (if (##negative? x)
9668 (range-error)
9669 (##car (##exact-int.sqrt x)))
9670 (type-error)))
9672 (define-prim (integer-sqrt x)
9673 (macro-force-vars (x)
9674 (##integer-sqrt x)))
9676 (define-prim (##exact-int.square n)
9677 (##* n n))
9679 ;;;----------------------------------------------------------------------------
9681 ;;; Ratnum operations
9682 ;;; -----------------
9684 (define-prim (##ratnum.= x y)
9685 (and (##= (macro-ratnum-numerator x)
9686 (macro-ratnum-numerator y))
9687 (##= (macro-ratnum-denominator x)
9688 (macro-ratnum-denominator y))))
9690 (define-prim (##ratnum.< x y)
9691 (##< (##* (macro-ratnum-numerator x)
9692 (macro-ratnum-denominator y))
9693 (##* (macro-ratnum-denominator x)
9694 (macro-ratnum-numerator y))))
9696 (define-prim (##ratnum.+ x y)
9697 (let ((p (macro-ratnum-numerator x))
9698 (q (macro-ratnum-denominator x))
9699 (r (macro-ratnum-numerator y))
9700 (s (macro-ratnum-denominator y)))
9701 (let ((d1 (##gcd q s)))
9702 (if (##eq? d1 1)
9703 (macro-ratnum-make (##+ (##* p s)
9704 (##* r q))
9705 (##* q s))
9706 (let* ((s-prime (##quotient s d1))
9707 (t (##+ (##* p s-prime)
9708 (##* r (##quotient q d1))))
9709 (d2 (##gcd d1 t))
9710 (num (##quotient t d2))
9711 (den (##* (##quotient q d2)
9712 s-prime)))
9713 (if (##eq? den 1)
9714 num
9715 (macro-ratnum-make num den)))))))
9717 (define-prim (##ratnum.- x y)
9718 (let ((p (macro-ratnum-numerator x))
9719 (q (macro-ratnum-denominator x))
9720 (r (macro-ratnum-numerator y))
9721 (s (macro-ratnum-denominator y)))
9722 (let ((d1 (##gcd q s)))
9723 (if (##eq? d1 1)
9724 (macro-ratnum-make (##- (##* p s)
9725 (##* r q))
9726 (##* q s))
9727 (let* ((s-prime (##quotient s d1))
9728 (t (##- (##* p s-prime)
9729 (##* r (##quotient q d1))))
9730 (d2 (##gcd d1 t))
9731 (num (##quotient t d2))
9732 (den (##* (##quotient q d2)
9733 s-prime)))
9734 (if (##eq? den 1)
9735 num
9736 (macro-ratnum-make num den)))))))
9738 (define-prim (##ratnum.* x y)
9739 (let ((p (macro-ratnum-numerator x))
9740 (q (macro-ratnum-denominator x))
9741 (r (macro-ratnum-numerator y))
9742 (s (macro-ratnum-denominator y)))
9743 (if (##eq? x y)
9744 (macro-ratnum-make (##* p p) (##* q q)) ;; already in lowest form
9745 (let* ((gcd-ps (##gcd p s))
9746 (gcd-rq (##gcd r q))
9747 (num (##* (##quotient p gcd-ps) (##quotient r gcd-rq)))
9748 (den (##* (##quotient q gcd-rq) (##quotient s gcd-ps))))
9749 (if (##eq? den 1)
9750 num
9751 (macro-ratnum-make num den))))))
9753 (define-prim (##ratnum./ x y)
9754 (let ((p (macro-ratnum-numerator x))
9755 (q (macro-ratnum-denominator x))
9756 (r (macro-ratnum-denominator y))
9757 (s (macro-ratnum-numerator y)))
9758 (if (##eq? x y)
9759 1
9760 (let* ((gcd-ps (##gcd p s))
9761 (gcd-rq (##gcd r q))
9762 (num (##* (##quotient p gcd-ps) (##quotient r gcd-rq)))
9763 (den (##* (##quotient q gcd-rq) (##quotient s gcd-ps))))
9764 (if (##negative? den)
9765 (if (##eq? den -1)
9766 (##negate num)
9767 (macro-ratnum-make (##negate num) (##negate den)))
9768 (if (##eq? den 1)
9769 num
9770 (macro-ratnum-make num den)))))))
9772 (define-prim (##ratnum.normalize num den)
9773 (let* ((x (##gcd num den))
9774 (y (if (##negative? den) (##negate x) x))
9775 (num (##quotient num y))
9776 (den (##quotient den y)))
9777 (if (##eq? den 1)
9778 num
9779 (macro-ratnum-make num den))))
9781 (define-prim (##ratnum.<-exact-int x)
9782 (macro-ratnum-make x 1))
9784 (define-prim (##ratnum.round x #!optional (round-half-away-from-zero? #f))
9785 (let ((num (macro-ratnum-numerator x))
9786 (den (macro-ratnum-denominator x)))
9787 (if (##eq? den 2)
9788 (if round-half-away-from-zero?
9789 (##arithmetic-shift (##+ num (if (##positive? num) 1 -1)) -1)
9790 (##arithmetic-shift (##arithmetic-shift (##+ num 1) -2) 1))
9791 ;; here the ratnum cannot have fractional part = 1/2
9792 (##floor
9793 (##ratnum.normalize
9794 (##+ (##arithmetic-shift num 1) den)
9795 (##arithmetic-shift den 1))))))
9797 ;;;----------------------------------------------------------------------------
9799 ;;; Flonum operations
9800 ;;; -----------------
9802 (##define-macro (define-prim-flonum form . special-body)
9803 (let ((body (if (null? special-body) form `(begin ,@special-body))))
9804 (cond ((= 1 (length (cdr form)))
9805 (let* ((name-fn (car form))
9806 (name-param1 (cadr form)))
9807 `(define-prim ,form
9808 (macro-force-vars (,name-param1)
9809 (macro-check-flonum
9810 ,name-param1
9811 1
9812 ,form
9813 ,body)))))
9814 ((= 2 (length (cdr form)))
9815 (let* ((name-fn (car form))
9816 (name-param1 (cadr form))
9817 (name-param2 (caddr form)))
9818 `(define-prim ,form
9819 (macro-force-vars (,name-param1 ,name-param2)
9820 (macro-check-flonum
9821 ,name-param1
9822 1
9823 ,form
9824 (macro-check-flonum
9825 ,name-param2
9826 2
9827 ,form
9828 ,body))))))
9829 (else
9830 (error "define-prim-flonum supports only 1 or 2 parameter procedures")))))
9832 (define-prim (flonum? obj)
9833 (##flonum? obj))
9835 (define-prim-nary-bool (##fl= x y)
9836 #t
9837 #t
9838 (##fl= x y)
9839 macro-no-force
9840 macro-no-check)
9842 (define-prim-nary-bool (fl= x y)
9843 #t
9844 #t
9845 (##fl= x y)
9846 macro-force-vars
9847 macro-check-flonum)
9849 (define-prim-nary-bool (##fl< x y)
9850 #t
9851 #t
9852 (##fl< x y)
9853 macro-no-force
9854 macro-no-check)
9856 (define-prim-nary-bool (fl< x y)
9857 #t
9858 #t
9859 (##fl< x y)
9860 macro-force-vars
9861 macro-check-flonum)
9863 (define-prim-nary-bool (##fl> x y)
9864 #t
9865 #t
9866 (##fl> x y)
9867 macro-no-force
9868 macro-no-check)
9870 (define-prim-nary-bool (fl> x y)
9871 #t
9872 #t
9873 (##fl> x y)
9874 macro-force-vars
9875 macro-check-flonum)
9877 (define-prim-nary-bool (##fl<= x y)
9878 #t
9879 #t
9880 (##fl<= x y)
9881 macro-no-force
9882 macro-no-check)
9884 (define-prim-nary-bool (fl<= x y)
9885 #t
9886 #t
9887 (##fl<= x y)
9888 macro-force-vars
9889 macro-check-flonum)
9891 (define-prim-nary-bool (##fl>= x y)
9892 #t
9893 #t
9894 (##fl>= x y)
9895 macro-no-force
9896 macro-no-check)
9898 (define-prim-nary-bool (fl>= x y)
9899 #t
9900 #t
9901 (##fl>= x y)
9902 macro-force-vars
9903 macro-check-flonum)
9905 (define-prim (##flinteger? x))
9907 (define-prim-flonum (flinteger? x)
9908 (##flinteger? x))
9910 (define-prim (##flzero? x))
9912 (define-prim-flonum (flzero? x)
9913 (##flzero? x))
9915 (define-prim (##flpositive? x))
9917 (define-prim-flonum (flpositive? x)
9918 (##flpositive? x))
9920 (define-prim (##flnegative? x))
9922 (define-prim-flonum (flnegative? x)
9923 (##flnegative? x))
9925 (define-prim (##flodd? x))
9927 (define-prim-flonum (flodd? x)
9928 (##flodd? x))
9930 (define-prim (##fleven? x))
9932 (define-prim-flonum (fleven? x)
9933 (##fleven? x))
9935 (define-prim (##flfinite? x))
9937 (define-prim-flonum (flfinite? x)
9938 (##flfinite? x))
9940 (define-prim (##flinfinite? x))
9942 (define-prim-flonum (flinfinite? x)
9943 (##flinfinite? x))
9945 (define-prim (##flnan? x))
9947 (define-prim-flonum (flnan? x)
9948 (##flnan? x))
9950 (define-prim-nary (##flmax x y)
9951 ()
9952 x
9953 (##flmax x y)
9954 macro-no-force
9955 macro-no-check)
9957 (define-prim-nary (flmax x y)
9958 ()
9959 x
9960 (##flmax x y)
9961 macro-force-vars
9962 macro-check-flonum)
9964 (define-prim-nary (##flmin x y)
9965 ()
9966 x
9967 (##flmin x y)
9968 macro-no-force
9969 macro-no-check)
9971 (define-prim-nary (flmin x y)
9972 ()
9973 x
9974 (##flmin x y)
9975 macro-force-vars
9976 macro-check-flonum)
9978 (define-prim-nary (##fl+ x y)
9979 (macro-inexact-+0)
9980 x
9981 (##fl+ x y)
9982 macro-no-force
9983 macro-no-check)
9985 (define-prim-nary (fl+ x y)
9986 (macro-inexact-+0)
9987 x
9988 (##fl+ x y)
9989 macro-force-vars
9990 macro-check-flonum)
9992 (define-prim-nary (##fl* x y)
9993 (macro-inexact-+1)
9994 x
9995 (##fl* x y)
9996 macro-no-force
9997 macro-no-check)
9999 (define-prim-nary (fl* x y)
10000 (macro-inexact-+1)
10001 x
10002 (##fl* x y)
10003 macro-force-vars
10004 macro-check-flonum)
10006 (define-prim-nary (##fl- x y)
10007 ()
10008 (##fl- x)
10009 (##fl- x y)
10010 macro-no-force
10011 macro-no-check)
10013 (define-prim-nary (fl- x y)
10014 ()
10015 (##fl- x)
10016 (##fl- x y)
10017 macro-force-vars
10018 macro-check-flonum)
10020 (define-prim-nary (##fl/ x y)
10021 ()
10022 (##fl/ x)
10023 (##fl/ x y)
10024 macro-no-force
10025 macro-no-check)
10027 (define-prim-nary (fl/ x y)
10028 ()
10029 (##fl/ x)
10030 (##fl/ x y)
10031 macro-force-vars
10032 macro-check-flonum)
10034 (define-prim (##flabs x))
10036 (define-prim-flonum (flabs x)
10037 (##flabs x))
10039 (define-prim-flonum (flnumerator x)
10040 (cond ((##flzero? x)
10041 x)
10042 ((macro-flonum-rational? x)
10043 (##exact->inexact (##numerator (##flonum.inexact->exact x))))
10044 (else
10045 (##fail-check-rational 1 flnumerator x))))
10047 (define-prim-flonum (fldenominator x)
10048 (if (macro-flonum-rational? x)
10049 (##exact->inexact (##denominator (##flonum.inexact->exact x)))
10050 (##fail-check-rational 1 fldenominator x)))
10052 (define-prim (##flfloor x))
10054 (define-prim-flonum (flfloor x)
10055 (if (##flfinite? x)
10056 (##flfloor x)
10057 (##fail-check-finite-real 1 flfloor x)))
10059 (define-prim (##flceiling x))
10061 (define-prim-flonum (flceiling x)
10062 (if (##flfinite? x)
10063 (##flceiling x)
10064 (##fail-check-finite-real 1 flceiling x)))
10066 (define-prim (##fltruncate x))
10068 (define-prim-flonum (fltruncate x)
10069 (if (##flfinite? x)
10070 (##fltruncate x)
10071 (##fail-check-finite-real 1 fltruncate x)))
10073 (define-prim (##flround x))
10075 (define-prim-flonum (flround x)
10076 (if (##flfinite? x)
10077 (##flround x)
10078 (##fail-check-finite-real 1 flround x)))
10080 (define-prim (##flexp x))
10082 (define-prim-flonum (flexp x)
10083 (##flexp x))
10085 (define-prim (##fllog x))
10087 (define-prim-flonum (fllog x)
10088 (if (or (##flnan? x)
10089 (##not (##flnegative?
10090 (##flcopysign (macro-inexact-+1) x))))
10091 (##fllog x)
10092 (##raise-range-exception 1 fllog x)))
10094 (define-prim (##flsin x))
10096 (define-prim-flonum (flsin x)
10097 (##flsin x))
10099 (define-prim (##flcos x))
10101 (define-prim-flonum (flcos x)
10102 (##flcos x))
10104 (define-prim (##fltan x))
10106 (define-prim-flonum (fltan x)
10107 (##fltan x))
10109 (define-prim (##flasin x))
10111 (define-prim-flonum (flasin x)
10112 (if (and (##not (##fl< (macro-inexact-+1) x))
10113 (##not (##fl< x (macro-inexact--1))))
10114 (##flasin x)
10115 (##raise-range-exception 1 flasin x)))
10117 (define-prim (##flacos x))
10119 (define-prim-flonum (flacos x)
10120 (if (and (##not (##fl< (macro-inexact-+1) x))
10121 (##not (##fl< x (macro-inexact--1))))
10122 (##flacos x)
10123 (##raise-range-exception 1 flacos x)))
10125 (define-prim (##flatan x #!optional (y (macro-absent-obj)))
10126 (if (##eq? y (macro-absent-obj))
10127 (##flatan x)
10128 (macro-check-flonum y 2 (##flatan x y)
10129 (##flatan x y))))
10131 (define-prim (flatan x #!optional (y (macro-absent-obj)))
10132 (macro-force-vars (x y)
10133 (macro-check-flonum x 1 (flatan x y)
10134 (if (##eq? y (macro-absent-obj))
10135 (##flatan x)
10136 (macro-check-flonum y 2 (flatan x y)
10137 (##flatan x y))))))
10139 (define-prim (##flexpt x y))
10141 (define-prim-flonum (flexpt x y)
10142 (if (or (##not (##flnegative? x))
10143 (macro-flonum-int? y))
10144 (##flexpt x y)
10145 (##raise-range-exception 2 flexpt x y)))
10147 (define-prim (##flsqrt x))
10149 (define-prim-flonum (flsqrt x)
10150 (if (##not (##flnegative? x))
10151 (##flsqrt x)
10152 (##raise-range-exception 1 flsqrt x)))
10154 (define-prim-fixnum (fixnum->flonum x)
10155 (##fixnum->flonum x))
10157 (define-prim (##fl<-fx x))
10158 (define-prim (##fl->fx x))
10159 (define-prim (##fl<-fx-exact? x))
10161 (define-prim (##flcopysign x y))
10164 (define-prim (##flonum->fixnum x))
10165 (define-prim (##fixnum->flonum x))
10166 (define-prim (##fixnum->flonum-exact? x))
10170 ;;;;;;;;;;;;;;;;;;;;;;;;;; old procedures
10172 (define-prim-nary-bool (##flonum.= x y)
10173 #t
10174 #t
10175 (##flonum.= x y)
10176 macro-no-force
10177 macro-no-check)
10179 (define-prim-nary-bool (##flonum.< x y)
10180 #t
10181 #t
10182 (##flonum.< x y)
10183 macro-no-force
10184 macro-no-check)
10186 (define-prim-nary-bool (##flonum.> x y)
10187 #t
10188 #t
10189 (##flonum.> x y)
10190 macro-no-force
10191 macro-no-check)
10193 (define-prim-nary-bool (##flonum.<= x y)
10194 #t
10195 #t
10196 (##flonum.<= x y)
10197 macro-no-force
10198 macro-no-check)
10200 (define-prim-nary-bool (##flonum.>= x y)
10201 #t
10202 #t
10203 (##flonum.>= x y)
10204 macro-no-force
10205 macro-no-check)
10207 (define-prim (##flonum.integer? x))
10209 (define-prim (##flonum.zero? x))
10211 (define-prim (##flonum.positive? x))
10213 (define-prim (##flonum.negative? x))
10215 (define-prim (##flonum.odd? x))
10217 (define-prim (##flonum.even? x))
10219 (define-prim (##flonum.finite? x))
10221 (define-prim (##flonum.infinite? x))
10223 (define-prim (##flonum.nan? x))
10225 (define-prim-nary (##flonum.max x y)
10226 ()
10227 x
10228 (##flonum.max x y)
10229 macro-no-force
10230 macro-no-check)
10232 (define-prim-nary (##flonum.min x y)
10233 ()
10234 x
10235 (##flonum.min x y)
10236 macro-no-force
10237 macro-no-check)
10239 (define-prim-nary (##flonum.+ x y)
10240 (macro-inexact-+0)
10241 x
10242 (##flonum.+ x y)
10243 macro-no-force
10244 macro-no-check)
10246 (define-prim-nary (##flonum.* x y)
10247 (macro-inexact-+1)
10248 x
10249 (##flonum.* x y)
10250 macro-no-force
10251 macro-no-check)
10253 (define-prim-nary (##flonum.- x y)
10254 ()
10255 (##flonum.- x)
10256 (##flonum.- x y)
10257 macro-no-force
10258 macro-no-check)
10260 (define-prim-nary (##flonum./ x y)
10261 ()
10262 (##flonum./ x)
10263 (##flonum./ x y)
10264 macro-no-force
10265 macro-no-check)
10267 (define-prim (##flonum.abs x))
10269 (define-prim (##flonum.floor x))
10271 (define-prim (##flonum.ceiling x))
10273 (define-prim (##flonum.truncate x))
10275 (define-prim (##flonum.round x))
10277 (define-prim (##flonum.exp x))
10279 (define-prim (##flonum.log x))
10281 (define-prim (##flonum.sin x))
10283 (define-prim (##flonum.cos x))
10285 (define-prim (##flonum.tan x))
10287 (define-prim (##flonum.asin x))
10289 (define-prim (##flonum.acos x))
10291 (define-prim (##flonum.atan x #!optional (y (macro-absent-obj)))
10292 (if (##eq? y (macro-absent-obj))
10293 (##flonum.atan x)
10294 (macro-check-flonum y 2 (##flonum.atan x y)
10295 (##flonum.atan x y))))
10297 (define-prim (##flonum.expt x y))
10299 (define-prim (##flonum.sqrt x))
10301 (define-prim (##flonum.<-fixnum x))
10302 (define-prim (##flonum.->fixnum x))
10303 (define-prim (##flonum.<-fixnum-exact? x))
10305 (define-prim (##flonum.copysign x y))
10307 (define-prim (##flonum.<-ratnum x #!optional (nonzero-fractional-part? #f))
10308 (let* ((num (macro-ratnum-numerator x))
10309 (n (##abs num))
10310 (d (macro-ratnum-denominator x))
10311 (wn (##integer-length n)) ;; 2^(wn-1) <= n < 2^wn
10312 (wd (##integer-length d)) ;; 2^(wd-1) <= d < 2^wd
10313 (p (##fixnum.- wn wd)))
10315 (define (f1 sn sd)
10316 (if (##< sn sd) ;; n/(d*2^p) < 1 ?
10317 (f2 (##arithmetic-shift sn 1) sd (##fixnum.- p 1))
10318 (f2 sn sd p)))
10320 (define (f2 a b p)
10321 ;; 1 <= a/b < 2 and n/d = (2^p*a)/b and n/d < 2^(p+1)
10322 (let* ((shift
10323 (##fixnum.min (macro-flonum-m-bits)
10324 (##fixnum.- p (macro-flonum-e-min))))
10325 (normalized-result
10326 (##ratnum.normalize
10327 (##arithmetic-shift a shift)
10328 b))
10329 (abs-result
10330 (##flonum.*
10331 (##flonum.<-exact-int
10332 (if (##ratnum? normalized-result)
10333 (##ratnum.round
10334 normalized-result
10335 nonzero-fractional-part?)
10336 normalized-result))
10337 (##flonum.expt2 (##fixnum.- p shift)))))
10338 (if (##negative? num)
10339 (##flonum.copysign abs-result (macro-inexact--1))
10340 abs-result)))
10342 ;; 2^(p-1) <= n/d < 2^(p+1)
10343 ;; 1/2 <= n/(d*2^p) < 2 or equivalently 1/2 <= (n*2^-p)/d < 2
10345 (if (##fixnum.negative? p)
10346 (f1 (##arithmetic-shift n (##fixnum.- p)) d)
10347 (f1 n (##arithmetic-shift d p)))))
10349 (define-prim (##flonum.<-exact-int x #!optional (nonzero-fractional-part? #f))
10351 (define (f1 x)
10352 (let* ((w ;; 2^(w-1) <= x < 2^w
10353 (##integer-length x))
10354 (p ;; 2^52 <= x/2^p < 2^53
10355 (##fixnum.- w (macro-flonum-m-bits-plus-1))))
10356 (if (##fixnum.< p 1)
10357 ;; it really should be an error here if
10358 ;; positive-fractional-part? is true because we can't
10359 ;; determine the value of the first discarded bit
10360 (f2 x)
10361 (let* ((q (##arithmetic-shift x (##fixnum.- p)))
10362 (next-bit-index (##fixnum.- p 1)))
10363 (##flonum.*
10364 (##flonum.expt2 p)
10365 (f2 (if (and (##bit-set? next-bit-index x)
10366 (or nonzero-fractional-part?
10367 (##odd? q)
10368 (##fixnum.< (##first-bit-set x)
10369 next-bit-index)))
10370 (##+ q 1)
10371 q)))))))
10373 (define (f2 x) ;; 0 <= x < 2^53
10374 (if (##fixnum? x)
10375 (##flonum.<-fixnum x)
10376 (let* ((x (if (##fixnum? x) (##bignum.<-fixnum x) x))
10377 (n (##bignum.mdigit-length x)))
10378 (let loop ((i (##fixnum.- n 1))
10379 (result (macro-inexact-+0)))
10380 (if (##fixnum.< i 0)
10381 result
10382 (let ((mdigit (##bignum.mdigit-ref x i)))
10383 (loop (##fixnum.- i 1)
10384 (##flonum.+ (##flonum.* result
10385 ##bignum.inexact-mdigit-base)
10386 (##flonum.<-fixnum mdigit)))))))))
10388 (if (##fixnum? x)
10389 (##flonum.<-fixnum x)
10390 (if (##negative? x)
10391 (##flonum.copysign (f1 (##negate x)) (macro-inexact--1))
10392 (f1 x))))
10394 (define-prim (##flonum.expt2 n)
10395 (cond ((##fixnum.zero? n)
10396 (macro-inexact-+1))
10397 ((##fixnum.negative? n)
10398 (##expt (macro-inexact-+1/2) (##fixnum.- n)))
10399 (else
10400 (##expt (macro-inexact-+2) n))))
10402 (define-prim (##flonum.->exact-int x)
10403 (let loop1 ((z (##flonum.abs x))
10404 (n 1))
10405 (if (##flonum.< ##bignum.inexact-mdigit-base z)
10406 (loop1 (##flonum./ z ##bignum.inexact-mdigit-base)
10407 (##fixnum.+ n 1))
10408 (let loop2 ((result 0)
10409 (z z)
10410 (i n))
10411 (if (##fixnum.< 0 i)
10412 (let* ((inexact-floor-z
10413 (##flonum.floor z))
10414 (floor-z
10415 (##flonum->fixnum inexact-floor-z))
10416 (new-z
10417 (##flonum.* (##flonum.- z inexact-floor-z)
10418 ##bignum.inexact-mdigit-base)))
10419 (loop2 (##+ floor-z
10420 (##arithmetic-shift result ##bignum.mdigit-width))
10421 new-z
10422 (##fixnum.- i 1)))
10423 (if (##flonum.negative? x)
10424 (##negate result)
10425 result))))))
10427 (define-prim (##flonum.->inexact-exponential-format x)
10429 (define (exp-form-pos x y i)
10430 (let ((i*2 (##fixnum.+ i i)))
10431 (let ((z (if (and (##not (##fixnum.< (macro-flonum-e-bias) i*2))
10432 (##not (##flonum.< x y)))
10433 (exp-form-pos x (##flonum.* y y) i*2)
10434 (##vector x 0 1))))
10435 (let ((a (##vector-ref z 0)) (b (##vector-ref z 1)))
10436 (let ((i+b (##fixnum.+ i b)))
10437 (if (and (##not (##fixnum.< (macro-flonum-e-bias) i+b))
10438 (##not (##flonum.< a y)))
10439 (begin
10440 (##vector-set! z 0 (##flonum./ a y))
10441 (##vector-set! z 1 i+b)))
10442 z)))))
10444 (define (exp-form-neg x y i)
10445 (let ((i*2 (##fixnum.+ i i)))
10446 (let ((z (if (and (##fixnum.< i*2 (macro-flonum-e-bias-minus-1))
10447 (##flonum.< x y))
10448 (exp-form-neg x (##flonum.* y y) i*2)
10449 (##vector x 0 1))))
10450 (let ((a (##vector-ref z 0)) (b (##vector-ref z 1)))
10451 (let ((i+b (##fixnum.+ i b)))
10452 (if (and (##fixnum.< i+b (macro-flonum-e-bias-minus-1))
10453 (##flonum.< a y))
10454 (begin
10455 (##vector-set! z 0 (##flonum./ a y))
10456 (##vector-set! z 1 i+b)))
10457 z)))))
10459 (define (exp-form x)
10460 (if (##flonum.< x (macro-inexact-+1))
10461 (let ((z (exp-form-neg x (macro-inexact-+1/2) 1)))
10462 (##vector-set! z 0 (##flonum.* (macro-inexact-+2) (##vector-ref z 0)))
10463 (##vector-set! z 1 (##fixnum.- -1 (##vector-ref z 1)))
10464 z)
10465 (exp-form-pos x (macro-inexact-+2) 1)))
10467 (if (##flonum.negative? (##flonum.copysign (macro-inexact-+1) x))
10468 (let ((z (exp-form (##flonum.copysign x (macro-inexact-+1)))))
10469 (##vector-set! z 2 -1)
10470 z)
10471 (exp-form x)))
10473 (define-prim (##flonum.->exact-exponential-format x)
10474 (let ((z (##flonum.->inexact-exponential-format x)))
10475 (let ((y (##vector-ref z 0)))
10476 (if (##not (##flonum.< y (macro-inexact-+2))) ;; +inf.0 or +nan.0?
10477 (begin
10478 (if (##flonum.< (macro-inexact-+0) y)
10479 (##vector-set! z 0 (macro-flonum-+m-min)) ;; +inf.0
10480 (##vector-set! z 0 (macro-flonum-+m-max))) ;; +nan.0
10481 (##vector-set! z 1 (macro-flonum-e-bias-plus-1)))
10482 (##vector-set! z 0
10483 (##flonum.->exact-int
10484 (##flonum.* (##vector-ref z 0) (macro-flonum-m-min)))))
10485 (##vector-set! z 1 (##fixnum.- (##vector-ref z 1) (macro-flonum-m-bits)))
10486 z)))
10488 (define-prim (##flonum.inexact->exact x)
10489 (let ((y (##flonum.->exact-exponential-format x)))
10490 (##exact-int.*-expt2
10491 (if (##fixnum.negative? (##vector-ref y 2))
10492 (##negate (##vector-ref y 0))
10493 (##vector-ref y 0))
10494 (##vector-ref y 1))))
10496 (define-prim (##flonum.->ratnum x)
10497 (let ((y (##flonum.inexact->exact x)))
10498 (if (macro-exact-int? y)
10499 (##ratnum.<-exact-int y)
10500 y)))
10502 (define-prim (##flonum.->ieee754-32 x)
10503 (##u32vector-ref (##f32vector x) 0))
10505 (define-prim (##flonum.<-ieee754-32 n)
10506 (let ((x (##u32vector n)))
10507 (##f32vector-ref x 0)))
10509 (define-prim (##flonum.->ieee754-64 x)
10510 (##u64vector-ref x 0))
10512 (define-prim (##flonum.<-ieee754-64 n)
10513 (let ((x (##u64vector n)))
10514 (##subtype-set! x (macro-subtype-flonum))
10515 x))
10517 ;;;----------------------------------------------------------------------------
10519 ;;; Cpxnum operations
10520 ;;; -----------------
10522 (define-prim (##cpxnum.= x y)
10523 (and (##= (macro-cpxnum-real x) (macro-cpxnum-real y))
10524 (##= (macro-cpxnum-imag x) (macro-cpxnum-imag y))))
10526 (define-prim (##cpxnum.+ x y)
10527 (let ((a (macro-cpxnum-real x)) (b (macro-cpxnum-imag x))
10528 (c (macro-cpxnum-real y)) (d (macro-cpxnum-imag y)))
10529 (##make-rectangular (##+ a c) (##+ b d))))
10531 (define-prim (##cpxnum.* x y)
10532 (let ((a (macro-cpxnum-real x)) (b (macro-cpxnum-imag x))
10533 (c (macro-cpxnum-real y)) (d (macro-cpxnum-imag y)))
10534 (##make-rectangular (##- (##* a c) (##* b d)) (##+ (##* a d) (##* b c)))))
10536 (define-prim (##cpxnum.- x y)
10537 (let ((a (macro-cpxnum-real x)) (b (macro-cpxnum-imag x))
10538 (c (macro-cpxnum-real y)) (d (macro-cpxnum-imag y)))
10539 (##make-rectangular (##- a c) (##- b d))))
10541 (define-prim (##cpxnum./ x y)
10543 (define (basic/ a b c d q)
10544 (##make-rectangular (##/ (##+ (##* a c) (##* b d)) q)
10545 (##/ (##- (##* b c) (##* a d)) q)))
10547 (let ((a (macro-cpxnum-real x)) (b (macro-cpxnum-imag x))
10548 (c (macro-cpxnum-real y)) (d (macro-cpxnum-imag y)))
10549 (cond ((##eq? d 0)
10550 ;; A normalized cpxnum can't have an imaginary part that is
10551 ;; exact 0 but it is possible that ##cpxnum./ receives a
10552 ;; nonnormalized cpxnum as x or y when it is called from ##/.
10553 (##make-rectangular (##/ a c)
10554 (##/ b c)))
10555 ((##eq? c 0)
10556 (##make-rectangular (##/ b d)
10557 (##negate (##/ a d))))
10558 ((and (##exact? c) (##exact? d))
10559 (basic/ a b c d (##+ (##* c c) (##* d d))))
10560 (else
10561 ;; just coerce everything to inexact and move on
10562 (let ((inexact-c (##exact->inexact c))
10563 (inexact-d (##exact->inexact d)))
10564 (if (and (##flonum.finite? inexact-c)
10565 (##flonum.finite? inexact-d))
10566 (let ((q
10567 (##flonum.+ (##flonum.* inexact-c inexact-c)
10568 (##flonum.* inexact-d inexact-d))))
10569 (cond ((##not (##flonum.finite? q))
10570 (let ((a
10571 (if (##flonum? a)
10572 (##flonum.* a (macro-inexact-scale-down))
10573 (##* a (macro-scale-down))))
10574 (b
10575 (if (##flonum? b)
10576 (##flonum.* b (macro-inexact-scale-down))
10577 (##* b (macro-scale-down))))
10578 (inexact-c
10579 (##flonum.* inexact-c
10580 (macro-inexact-scale-down)))
10581 (inexact-d
10582 (##flonum.* inexact-d
10583 (macro-inexact-scale-down))))
10584 (basic/ a
10585 b
10586 inexact-c
10587 inexact-d
10588 (##flonum.+
10589 (##flonum.* inexact-c inexact-c)
10590 (##flonum.* inexact-d inexact-d)))))
10591 ((##flonum.< q (macro-flonum-min-normal))
10592 (let ((a
10593 (if (##flonum? a)
10594 (##flonum.* a (macro-inexact-scale-up))
10595 (##* a (macro-scale-up))))
10596 (b
10597 (if (##flonum? b)
10598 (##flonum.* b (macro-inexact-scale-up))
10599 (##* b (macro-scale-up))))
10600 (inexact-c
10601 (##flonum.* inexact-c
10602 (macro-inexact-scale-up)))
10603 (inexact-d
10604 (##flonum.* inexact-d
10605 (macro-inexact-scale-up))))
10606 (basic/ a
10607 b
10608 inexact-c
10609 inexact-d
10610 (##flonum.+
10611 (##flonum.* inexact-c inexact-c)
10612 (##flonum.* inexact-d inexact-d)))))
10613 (else
10614 (basic/ a b inexact-c inexact-d q))))
10615 (cond ((##flonum.= inexact-c (macro-inexact-+inf))
10616 (basic/ a
10617 b
10618 (macro-inexact-+0)
10619 (if (##flonum.nan? inexact-d)
10620 inexact-d
10621 (##flonum.copysign (macro-inexact-+0)
10622 inexact-d))
10623 (macro-inexact-+1)))
10624 ((##flonum.= inexact-c (macro-inexact--inf))
10625 (basic/ a
10626 b
10627 (macro-inexact--0)
10628 (if (##flonum.nan? inexact-d)
10629 inexact-d
10630 (##flonum.copysign (macro-inexact-+0)
10631 inexact-d))
10632 (macro-inexact-+1)))
10633 ((##flonum.nan? inexact-c)
10634 (cond ((##flonum.= inexact-d (macro-inexact-+inf))
10635 (basic/ a
10636 b
10637 inexact-c
10638 (macro-inexact-+0)
10639 (macro-inexact-+1)))
10640 ((##flonum.= inexact-d (macro-inexact--inf))
10641 (basic/ a
10642 b
10643 inexact-c
10644 (macro-inexact--0)
10645 (macro-inexact-+1)))
10646 ((##flonum.nan? inexact-d)
10647 (basic/ a
10648 b
10649 inexact-c
10650 inexact-d
10651 (macro-inexact-+1)))
10652 (else
10653 (basic/ a
10654 b
10655 inexact-c
10656 (macro-inexact-+nan)
10657 (macro-inexact-+1)))))
10658 (else
10659 ;; finite inexact-c
10660 (cond ((##flonum.nan? inexact-d)
10661 (basic/ a
10662 b
10663 (macro-inexact-+nan)
10664 inexact-d
10665 (macro-inexact-+1)))
10666 (else
10667 ;; inexact-d is +inf.0 or -inf.0
10668 (basic/ a
10669 b
10670 (##flonum.copysign (macro-inexact-+0)
10671 inexact-c)
10672 (##flonum.copysign (macro-inexact-+0)
10673 inexact-d)
10674 (macro-inexact-+1))))))))))))
10676 (define-prim (##cpxnum.<-noncpxnum x)
10677 (macro-cpxnum-make x 0))
10679 ;;;----------------------------------------------------------------------------
10681 ;;; Pseudo-random number generation, compatible with srfi-27.
10683 ;;; This code is based on Pierre Lecuyer's MRG32K3A generator.
10685 (define-type random-source
10686 id: 1b002758-f900-4e96-be5e-fa407e331fc0
10687 implementer: implement-type-random-source
10688 constructor: macro-make-random-source
10689 type-exhibitor: macro-type-random-source
10690 macros:
10691 prefix: macro-
10692 opaque:
10694 (state-ref unprintable: read-only:)
10695 (state-set! unprintable: read-only:)
10696 (randomize! unprintable: read-only:)
10697 (pseudo-randomize! unprintable: read-only:)
10698 (make-integers unprintable: read-only:)
10699 (make-reals unprintable: read-only:)
10700 (make-u8vectors unprintable: read-only:)
10701 (make-f64vectors unprintable: read-only:)
10702 )
10704 (define-check-type random-source
10705 (macro-type-random-source)
10706 macro-random-source?)
10708 (implement-type-random-source)
10709 (implement-check-type-random-source)
10711 (define-prim (##make-random-source-mrg32k3a)
10713 (##define-macro (macro-w)
10714 65536)
10716 (##define-macro (macro-w^2-mod-m1)
10717 209)
10719 (##define-macro (macro-w^2-mod-m2)
10720 22853)
10722 (##define-macro (macro-m1)
10723 4294967087) ;; (- (expt (macro-w) 2) (macro-w^2-mod-m1))
10725 (##define-macro (macro-m1-inexact)
10726 4294967087.0) ;; (exact->inexact (macro-m1))
10728 (##define-macro (macro-m1-plus-1-inexact)
10729 4294967088.0) ;; (exact->inexact (+ (macro-m1) 1))
10731 (##define-macro (macro-inv-m1-plus-1-inexact)
10732 2.328306549295728e-10) ;; (exact->inexact (/ (+ (macro-m1) 1)))
10734 (##define-macro (macro-m1-minus-1)
10735 4294967086) ;; (- (macro-m1) 1)
10737 (##define-macro (macro-k)
10738 28)
10740 (##define-macro (macro-2^k)
10741 268435456) ;; (expt 2 (macro-k))
10743 (##define-macro (macro-2^k-inexact)
10744 268435456.0) ;; (exact->inexact (expt 2 (macro-k)))
10746 (##define-macro (macro-inv-2^k-inexact)
10747 3.725290298461914e-9) ;; (exact->inexact (/ (expt 2 (macro-k))))
10749 (##define-macro (macro-2^53-k-inexact)
10750 33554432.0) ;; (exact->inexact (expt 2 (- 53 (macro-k))))
10752 (##define-macro (macro-m1-div-2^k-inexact)
10753 15.0) ;; (exact->inexact (quotient (macro-m1) (expt 2 (macro-k))))
10755 (##define-macro (macro-m1-div-2^k-times-2^k-inexact)
10756 4026531840.0) ;; (exact->inexact (* (quotient (macro-m1) (expt 2 (macro-k))) (expt 2 (macro-k))))
10758 (##define-macro (macro-m2)
10759 4294944443) ;; (- (expt (macro-w) 2) (macro-w^2-mod-m2))
10761 (##define-macro (macro-m2-inexact)
10762 4294944443.0) ;; (exact->inexact (macro-m2))
10764 (##define-macro (macro-m2-minus-1)
10765 4294944442) ;; (- (macro-m2) 1)
10767 (define (pack-state a b c d e f)
10768 (f64vector
10769 (##flonum.<-exact-int a)
10770 (##flonum.<-exact-int b)
10771 (##flonum.<-exact-int c)
10772 (##flonum.<-exact-int d)
10773 (##flonum.<-exact-int e)
10774 (##flonum.<-exact-int f)
10775 (macro-inexact-+0) ;; where the result of advance-state! is put
10776 (macro-inexact-+0) ;; q in rand-fixnum32
10777 (macro-inexact-+0) ;; qn in rand-fixnum32
10778 ))
10780 (define (unpack-state state)
10781 (vector
10782 (##flonum.->exact-int (f64vector-ref state 0))
10783 (##flonum.->exact-int (f64vector-ref state 1))
10784 (##flonum.->exact-int (f64vector-ref state 2))
10785 (##flonum.->exact-int (f64vector-ref state 3))
10786 (##flonum.->exact-int (f64vector-ref state 4))
10787 (##flonum.->exact-int (f64vector-ref state 5))))
10789 (let ((state ;; initial state is 0 3 6 9 12 15 of A^(2^4), see below
10790 (pack-state
10791 1062452522
10792 2961816100
10793 342112271
10794 2854655037
10795 3321940838
10796 3542344109)))
10798 (define (state-ref)
10799 (unpack-state state))
10801 (define (state-set! rs new-state)
10803 (define (integer-in-range? x m)
10804 (and (macro-exact-int? x)
10805 (not (negative? x))
10806 (< x m)))
10808 (or (and (vector? new-state)
10809 (fx= (vector-length new-state) 6)
10810 (let ((a (vector-ref new-state 0))
10811 (b (vector-ref new-state 1))
10812 (c (vector-ref new-state 2))
10813 (d (vector-ref new-state 3))
10814 (e (vector-ref new-state 4))
10815 (f (vector-ref new-state 5)))
10816 (and (integer-in-range? a (macro-m1))
10817 (integer-in-range? b (macro-m1))
10818 (integer-in-range? c (macro-m1))
10819 (integer-in-range? d (macro-m2))
10820 (integer-in-range? e (macro-m2))
10821 (integer-in-range? f (macro-m2))
10822 (not (and (eqv? a 0) (eqv? b 0) (eqv? c 0)))
10823 (not (and (eqv? d 0) (eqv? e 0) (eqv? f 0)))
10824 (begin
10825 (set! state
10826 (pack-state a b c d e f))
10827 (void)))))
10828 (##raise-type-exception
10829 2
10830 'random-source-state
10831 random-source-state-set!
10832 (list rs new-state))))
10834 (define (randomize!)
10836 (define (random-fixnum-from-time)
10837 (let ((v (f64vector (macro-inexact-+0))))
10838 (##get-current-time! v)
10839 (let ((x (f64vector-ref v 0)))
10840 (##flonum->fixnum
10841 (fl* 536870912.0 ;; (expt 2.0 29)
10842 (fl- x (flfloor x)))))))
10844 (define seed16
10845 (random-fixnum-from-time))
10847 (define (simple-random16)
10848 (let ((r (bitwise-and seed16 65535)))
10849 (set! seed16
10850 (+ (* 30903 r)
10851 (arithmetic-shift seed16 -16)))
10852 r))
10854 (define (simple-random32)
10855 (+ (arithmetic-shift (simple-random16) 16)
10856 (simple-random16)))
10858 ;; perturb the state randomly
10860 (let ((s (unpack-state state)))
10861 (set! state
10862 (pack-state
10863 (+ 1
10864 (modulo (+ (vector-ref s 0)
10865 (simple-random32))
10866 (macro-m1-minus-1)))
10867 (modulo (+ (vector-ref s 1)
10868 (simple-random32))
10869 (macro-m1))
10870 (modulo (+ (vector-ref s 2)
10871 (simple-random32))
10872 (macro-m1))
10873 (+ 1
10874 (modulo (+ (vector-ref s 3)
10875 (simple-random32))
10876 (macro-m2-minus-1)))
10877 (modulo (+ (vector-ref s 4)
10878 (simple-random32))
10879 (macro-m2))
10880 (modulo (+ (vector-ref s 5)
10881 (simple-random32))
10882 (macro-m2))))
10883 (void)))
10885 (define (pseudo-randomize! i j)
10887 (define (mult A B) ;; A*B
10889 (define (lc i0 i1 i2 j0 j1 j2 m)
10890 (modulo (+ (* (vector-ref A i0)
10891 (vector-ref B j0))
10892 (+ (* (vector-ref A i1)
10893 (vector-ref B j1))
10894 (* (vector-ref A i2)
10895 (vector-ref B j2))))
10896 m))
10898 (vector
10899 (lc 0 1 2 0 3 6 (macro-m1))
10900 (lc 0 1 2 1 4 7 (macro-m1))
10901 (lc 0 1 2 2 5 8 (macro-m1))
10902 (lc 3 4 5 0 3 6 (macro-m1))
10903 (lc 3 4 5 1 4 7 (macro-m1))
10904 (lc 3 4 5 2 5 8 (macro-m1))
10905 (lc 6 7 8 0 3 6 (macro-m1))
10906 (lc 6 7 8 1 4 7 (macro-m1))
10907 (lc 6 7 8 2 5 8 (macro-m1))
10908 (lc 9 10 11 9 12 15 (macro-m2))
10909 (lc 9 10 11 10 13 16 (macro-m2))
10910 (lc 9 10 11 11 14 17 (macro-m2))
10911 (lc 12 13 14 9 12 15 (macro-m2))
10912 (lc 12 13 14 10 13 16 (macro-m2))
10913 (lc 12 13 14 11 14 17 (macro-m2))
10914 (lc 15 16 17 9 12 15 (macro-m2))
10915 (lc 15 16 17 10 13 16 (macro-m2))
10916 (lc 15 16 17 11 14 17 (macro-m2))))
10918 (define (power A e) ;; A^e
10919 (cond ((eq? e 0)
10920 identity)
10921 ((eq? e 1)
10922 A)
10923 ((even? e)
10924 (power (mult A A) (arithmetic-shift e -1)))
10925 (else
10926 (mult (power A (- e 1)) A))))
10928 (define identity
10929 '#( 1 0 0
10930 0 1 0
10931 0 0 1
10932 1 0 0
10933 0 1 0
10934 0 0 1))
10936 (define A ;; primary MRG32k3a equations
10937 '#( 0 1403580 4294156359
10938 1 0 0
10939 0 1 0
10940 527612 0 4293573854
10941 1 0 0
10942 0 1 0))
10944 (define A^2^127 ;; A^(2^127)
10945 '#(1230515664 986791581 1988835001
10946 3580155704 1230515664 226153695
10947 949770784 3580155704 2427906178
10948 2093834863 32183930 2824425944
10949 1022607788 1464411153 32183930
10950 1610723613 277697599 1464411153))
10952 (define A^2^76 ;; A^(2^76)
10953 '#( 69195019 3528743235 3672091415
10954 1871391091 69195019 3672831523
10955 4127413238 1871391091 82758667
10956 3708466080 4292754251 3859662829
10957 3889917532 1511326704 4292754251
10958 1610795712 3759209742 1511326704))
10960 (define A^2^4 ;; A^(2^4)
10961 '#(1062452522 340793741 2955879160
10962 2961816100 1062452522 387300998
10963 342112271 2961816100 736416029
10964 2854655037 1817134745 3493477402
10965 3321940838 818368950 1817134745
10966 3542344109 3790774567 818368950))
10968 (let ((M ;; M = A^(2^4 + i*2^127 + j*2^76)
10969 (mult A^2^4
10970 (mult (power A^2^127 i)
10971 (power A^2^76 j)))))
10972 (set! state
10973 (pack-state
10974 (vector-ref M 0)
10975 (vector-ref M 3)
10976 (vector-ref M 6)
10977 (vector-ref M 9)
10978 (vector-ref M 12)
10979 (vector-ref M 15)))
10980 (void)))
10982 (define (advance-state!)
10983 (##declare (not interrupts-enabled))
10984 (let* ((state state)
10985 (x10
10986 (fl- (fl* 1403580.0 (f64vector-ref state 1))
10987 (fl* 810728.0 (f64vector-ref state 2))))
10988 (y10
10989 (fl- x10
10990 (fl* (flfloor (fl/ x10 (macro-m1-inexact)))
10991 (macro-m1-inexact))))
10992 (x20
10993 (fl- (fl* 527612.0 (f64vector-ref state 3))
10994 (fl* 1370589.0 (f64vector-ref state 5))))
10995 (y20
10996 (fl- x20
10997 (fl* (flfloor (fl/ x20 (macro-m2-inexact)))
10998 (macro-m2-inexact)))))
10999 (f64vector-set! state 5 (f64vector-ref state 4))
11000 (f64vector-set! state 4 (f64vector-ref state 3))
11001 (f64vector-set! state 3 y20)
11002 (f64vector-set! state 2 (f64vector-ref state 1))
11003 (f64vector-set! state 1 (f64vector-ref state 0))
11004 (f64vector-set! state 0 y10)
11005 (if (fl< y10 y20)
11006 (f64vector-set! state 6 (fl+ (macro-m1-inexact)
11007 (fl- (f64vector-ref state 0)
11008 (f64vector-ref state 3))))
11009 (f64vector-set! state 6 (fl- (f64vector-ref state 0)
11010 (f64vector-ref state 3))))))
11012 (define (make-integers)
11014 (define (random-integer range)
11016 (define (type-error)
11017 (##fail-check-exact-integer 1 random-integer range))
11019 (define (range-error)
11020 (##raise-range-exception 1 random-integer range))
11022 (macro-force-vars (range)
11023 (cond ((fixnum? range)
11024 (if (fxpositive? range)
11025 (if (fx< (macro-max-fixnum32) range)
11026 (rand-integer range)
11027 (rand-fixnum32 range))
11028 (range-error)))
11029 ((##bignum? range)
11030 (if (##bignum.negative? range)
11031 (range-error)
11032 (rand-integer range)))
11033 (else
11034 (type-error)))))
11036 random-integer)
11038 (define (rand-integer range)
11040 ;; constants for computing fixnum approximation of inverse of range
11042 (define size 14)
11043 (define 2^2*size 268435456)
11045 (let ((len (integer-length range)))
11046 (if (fx= (fx- len 1) ;; check if range is a power of 2
11047 (first-bit-set range))
11048 (rand-integer-2^ (fx- len 1))
11049 (let* ((inv
11050 (fxquotient
11051 2^2*size
11052 (fx+ 1
11053 (extract-bit-field size (fx- len size) range))))
11054 (range2
11055 (* range inv)))
11056 (let loop ()
11057 (let ((r (rand-integer-2^ (fx+ len size))))
11058 (if (< r range2)
11059 (quotient r inv)
11060 (loop))))))))
11062 (define (rand-integer-2^ w)
11064 (define (rand w s)
11065 (cond ((fx< w (macro-k))
11066 (fxand (rand-fixnum32-2^k)
11067 (fx- (fxarithmetic-shift-left 1 w) 1)))
11068 ((fx= w (macro-k))
11069 (rand-fixnum32-2^k))
11070 (else
11071 (let ((s/2 (fxarithmetic-shift-right s 1)))
11072 (if (fx< s w)
11073 (+ (rand s s/2)
11074 (arithmetic-shift (rand (fx- w s) s/2) s))
11075 (rand w s/2))))))
11077 (define (split w s)
11078 (let ((s*2 (fx* 2 s)))
11079 (if (fx< s*2 w)
11080 (split w s*2)
11081 s)))
11083 (rand w (split w (macro-k))))
11085 (define (rand-fixnum32-2^k)
11086 (##declare (not interrupts-enabled))
11087 (let loop ()
11088 (advance-state!)
11089 (if (fl< (f64vector-ref state 6)
11090 (macro-m1-div-2^k-times-2^k-inexact))
11091 (##flonum->fixnum
11092 (fl/ (f64vector-ref state 6)
11093 (macro-m1-div-2^k-inexact)))
11094 (loop))))
11096 (define (rand-fixnum32 range) ;; range is a fixnum32
11097 (##declare (not interrupts-enabled))
11098 (let* ((a (fixnum->flonum range))
11099 (b (flfloor (fl/ (macro-m1-inexact) a))))
11100 (f64vector-set! state 7 b)
11101 (f64vector-set! state 8 (fl* a b)))
11102 (let loop ()
11103 (advance-state!)
11104 (if (fl< (f64vector-ref state 6)
11105 (f64vector-ref state 8))
11106 (##flonum->fixnum
11107 (fl/ (f64vector-ref state 6)
11108 (f64vector-ref state 7)))
11109 (loop))))
11111 (define (make-reals precision)
11112 (if (fl< precision (macro-inv-m1-plus-1-inexact))
11113 (lambda ()
11114 (let loop ((r (fixnum->flonum (rand-fixnum32-2^k)))
11115 (d (macro-inv-2^k-inexact)))
11116 (if (fl< r (macro-flonum-+m-max-plus-1-inexact))
11117 (loop (fl+ (fl* r (macro-2^k-inexact))
11118 (fixnum->flonum (rand-fixnum32-2^k)))
11119 (fl* d (macro-inv-2^k-inexact)))
11120 (fl* r d))))
11121 (lambda ()
11122 (##declare (not interrupts-enabled))
11123 (advance-state!)
11124 (fl* (fl+ (macro-inexact-+1) (f64vector-ref state 6))
11125 (macro-inv-m1-plus-1-inexact)))))
11127 (define (make-u8vectors)
11129 (define (random-u8vector len)
11130 (macro-force-vars (len)
11131 (macro-check-index len 1 (random-u8vector len)
11132 (let ((u8vect (##make-u8vector len 0)))
11133 (let loop ((i (fx- len 1)))
11134 (if (fx< i 0)
11135 u8vect
11136 (begin
11137 (##u8vector-set! u8vect i (rand-fixnum32 256))
11138 (loop (fx- i 1)))))))))
11140 random-u8vector)
11142 (define (make-f64vectors precision)
11143 (if (fl< precision (macro-inv-m1-plus-1-inexact))
11144 (let ((make-real (make-reals precision)))
11145 (lambda (len)
11146 (macro-force-vars (len)
11147 (macro-check-index len 1 (random-f64vector len)
11148 (let ((f64vect (##make-f64vector len 0.)))
11149 (let loop ((i (fx- len 1)))
11150 (if (fx< i 0)
11151 f64vect
11152 (begin
11153 (##f64vector-set! f64vect i (make-real))
11154 (loop (fx- i 1))))))))))
11155 (lambda (len)
11156 (macro-force-vars (len)
11157 (macro-check-index len 1 (random-f64vector len)
11158 (let ((f64vect (##make-f64vector len 0.)))
11159 (let loop ((i (fx- len 1)))
11160 (if (fx< i 0)
11161 f64vect
11162 (let ()
11163 (##declare (not interrupts-enabled))
11164 (advance-state!)
11165 (##f64vector-set! f64vect i (fl* (fl+ (macro-inexact-+1)
11166 (f64vector-ref state 6))
11167 (macro-inv-m1-plus-1-inexact)))
11168 (loop (fx- i 1)))))))))))
11170 (macro-make-random-source
11171 state-ref
11172 state-set!
11173 randomize!
11174 pseudo-randomize!
11175 make-integers
11176 make-reals
11177 make-u8vectors
11178 make-f64vectors)))
11180 (define-prim (make-random-source)
11181 (##make-random-source-mrg32k3a))
11183 (define-prim (random-source? obj)
11184 (macro-force-vars (obj)
11185 (macro-random-source? obj)))
11187 (define-prim (##random-source-state-ref rs)
11188 ((macro-random-source-state-ref rs)))
11190 (define-prim (random-source-state-ref rs)
11191 (macro-force-vars (rs)
11192 (macro-check-random-source rs 1 (random-source-state-ref rs)
11193 (##random-source-state-ref rs))))
11195 (define-prim (##random-source-state-set! rs new-state)
11196 ((macro-random-source-state-set! rs) rs new-state))
11198 (define-prim (random-source-state-set! rs new-state)
11199 (macro-force-vars (rs new-state)
11200 (macro-check-random-source rs 1 (random-source-state-set! rs new-state)
11201 (##random-source-state-set! rs new-state))))
11203 (define-prim (##random-source-randomize! rs)
11204 ((macro-random-source-randomize! rs)))
11206 (define-prim (random-source-randomize! rs)
11207 (macro-force-vars (rs)
11208 (macro-check-random-source rs 1 (random-source-randomize! rs)
11209 (##random-source-randomize! rs))))
11211 (define-prim (##random-source-pseudo-randomize! rs i j)
11212 ((macro-random-source-pseudo-randomize! rs) i j))
11214 (define-prim (random-source-pseudo-randomize! rs i j)
11215 (macro-force-vars (rs i j)
11216 (macro-check-random-source rs 1 (random-source-pseudo-randomize! rs i j)
11217 (if (not (macro-exact-int? i))
11218 (##fail-check-exact-integer 2 random-source-pseudo-randomize! rs i j)
11219 (if (not (macro-exact-int? j))
11220 (##fail-check-exact-integer 3 random-source-pseudo-randomize! rs i j)
11221 (if (negative? i)
11222 (##raise-range-exception 2 random-source-pseudo-randomize! rs i j)
11223 (if (negative? j)
11224 (##raise-range-exception 3 random-source-pseudo-randomize! rs i j)
11225 (##random-source-pseudo-randomize! rs i j))))))))
11227 (define-prim (##random-source-make-integers rs)
11228 ((macro-random-source-make-integers rs)))
11230 (define-prim (random-source-make-integers rs)
11231 (macro-force-vars (rs)
11232 (macro-check-random-source rs 1 (random-source-make-integers rs)
11233 (##random-source-make-integers rs))))
11235 (define-prim (##random-source-make-reals rs #!optional (p (macro-absent-obj)))
11236 ((macro-random-source-make-reals rs)
11237 (if (eq? p (macro-absent-obj))
11238 (macro-inexact-+1)
11239 p)))
11241 (define-prim (random-source-make-reals rs #!optional (p (macro-absent-obj)))
11242 (macro-force-vars (rs p)
11243 (macro-check-random-source rs 1 (random-source-make-reals rs p)
11244 (if (eq? p (macro-absent-obj))
11245 (##random-source-make-reals rs)
11246 (if (rational? p)
11247 (let ((precision (macro-real->inexact p)))
11248 (if (and (fl< (macro-inexact-+0) precision)
11249 (fl< precision (macro-inexact-+1)))
11250 (##random-source-make-reals rs precision)
11251 (##raise-range-exception 2 random-source-make-reals rs p)))
11252 (##fail-check-finite-real 2 random-source-make-reals rs p))))))
11254 (define-prim (##random-source-make-f64vectors rs #!optional (p (macro-absent-obj)))
11255 ((macro-random-source-make-f64vectors rs)
11256 (if (eq? p (macro-absent-obj))
11257 (macro-inexact-+1)
11258 p)))
11260 (define-prim (random-source-make-f64vectors rs #!optional (p (macro-absent-obj)))
11261 (macro-force-vars (rs p)
11262 (macro-check-random-source rs 1 (random-source-make-f64vectors rs p)
11263 (if (eq? p (macro-absent-obj))
11264 (##random-source-make-f64vectors rs)
11265 (if (rational? p)
11266 (let ((precision (macro-real->inexact p)))
11267 (if (and (fl< (macro-inexact-+0) precision)
11268 (fl< precision (macro-inexact-+1)))
11269 (##random-source-make-f64vectors rs precision)
11270 (##raise-range-exception 2 random-source-make-f64vectors rs p)))
11271 (##fail-check-finite-real 2 random-source-make-f64vectors rs p))))))
11273 (define-prim (##random-source-make-u8vectors rs)
11274 ((macro-random-source-make-u8vectors rs)))
11276 (define-prim (random-source-make-u8vectors rs)
11277 (macro-force-vars (rs)
11278 (macro-check-random-source rs 1 (random-source-make-u8vectors rs)
11279 (##random-source-make-u8vectors rs))))
11281 (define default-random-source #f)
11282 (set! default-random-source (##make-random-source-mrg32k3a))
11284 (define random-integer
11285 (##random-source-make-integers default-random-source))
11287 (define random-real
11288 (##random-source-make-reals default-random-source))
11290 (define random-u8vector
11291 (##random-source-make-u8vectors default-random-source))
11293 (define random-f64vector
11294 (##random-source-make-f64vectors default-random-source))
11296 ;;;============================================================================