~ chicken-core (chicken-5) 61af5f12d958e63811a8bb23a93706c0b53f4b27
commit 61af5f12d958e63811a8bb23a93706c0b53f4b27
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sun Jan 25 17:51:52 2015 +0100
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun May 31 14:14:25 2015 +0200
Implement the basic five (and derived) operators for extended numbers: +, -, *, /, gcd
This means we have complete read/write support for the full numeric tower!
The algorithms used here are the unoptimized "schoolbook" operators,
the calls to the optimized versions are currently commented out.
Nevertheless, this commit's diff is still very big, due to a few things:
- The basic algorithms for bignums are on the large side, and we
have to add them all at once because ratnum simplification involves
all five operations.
- There are three "flavours" of division: returning quotient and/or remainder
- We rip out all the old-style "specialization" rewrites in the compiler
for the operators we're adding. These will require further study if
we want rewrites at this low level.
- The inline bignum constructors are moved up in the file due to them
being used in some fixnum operators.
- We can finally implement "magnitude" for compnums.
- The number-syntax test has been reverted to the original "numbers" one.
- In library-tests we need to change tests for division by inexact zero to
check for +inf.0 instead of error (this is more consistent even though it
may result in error propagation).
This also adds a few new procedures:
- quotient&modulo and quotient&remainder, which calculate the named values
simultaneously and return them both, which is efficient for bignums.
- fxrem to calculate the remainder for fixnums (see also fxmod)
- fxgcd to calculate the GCD for fixnums
- fpgcd to calculate the GCD for flonums (will error if not integral)
diff --git a/c-platform.scm b/c-platform.scm
index a36501d2..383495a5 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -141,8 +141,8 @@
(set! default-extended-bindings
'(bignum? cplxnum? ratnum? bitwise-and bitwise-ior bitwise-xor bitwise-not
- add1 sub1 fx+ fx- fx* fx/ fx+? fx-? fx*? fx/? fxmod o fp/?
- fx= fx> fx< fx>= fx<= fixnum? fxneg fxmax fxmin fxlen identity fp+ fp- fp* fp/ fpmin fpmax fpneg
+ add1 sub1 fx+ fx- fx* fx/ fxgcd fx+? fx-? fx*? fx/? fxmod fxrem o fp/?
+ fx= fx> fx< fx>= fx<= fixnum? fxneg fxmax fxmin fxlen identity fp+ fp- fp* fp/ fpmin fpmax fpneg fpgcd
fp> fp< fp= fp>= fp<= fxand fxnot fxior fxxor fxshr fxshl bit-set? fxodd? fxeven?
fpfloor fpceiling fptruncate fpround fpsin fpcos fptan fpasin fpacos fpatan
fpatan2 fpexp fpexpt fplog fpsqrt fpabs fpinteger? exact-integer?
@@ -212,144 +212,6 @@
(rewrite '+ 19 0 "C_fixnum_plus" "C_u_fixnum_plus" #f)
-(rewrite
- '* 8
- (lambda (db classargs cont callargs)
- ;; (*) -> 1
- ;; (* <x>) -> <x>
- ;; (* <x1> ...) -> (##core#inline "C_fixnum_times" <x1> (##core#inline "C_fixnum_times" ...)) [fixnum-mode]
- ;; - Remove "1" from arguments.
- ;; - Replace multiplications with 2 by shift left. [fixnum-mode]
- (let ([callargs
- (filter
- (lambda (x)
- (not (and (eq? 'quote (node-class x))
- (eq? 1 (first (node-parameters x))) ) ) )
- callargs) ] )
- (cond [(null? callargs) (make-node '##core#call (list #t) (list cont (qnode 0)))]
- [(null? (cdr callargs))
- (make-node '##core#call (list #t) (list cont (first callargs))) ]
- [(eq? number-type 'fixnum)
- (make-node
- '##core#call (list #t)
- (list
- cont
- (fold-inner
- (lambda (x y)
- (if (and (eq? 'quote (node-class y)) (eq? 2 (first (node-parameters y))))
- (make-node '##core#inline '("C_fixnum_shift_left") (list x (qnode 1)))
- (make-node '##core#inline '("C_fixnum_times") (list x y)) ) )
- callargs) ) ) ]
- [else #f] ) ) ) )
-
-(rewrite
- '- 8
- (lambda (db classargs cont callargs)
- ;; (- <x>) -> (##core#inline "C_fixnum_negate" <x>) [fixnum-mode]
- ;; (- <x>) -> (##core#inline "C_u_fixnum_negate" <x>) [fixnum-mode + unsafe]
- ;; (- <x1> ...) -> (##core#inline "C_fixnum_difference" <x1> (##core#inline "C_fixnum_difference" ...)) [fixnum-mode]
- ;; (- <x1> ...) -> (##core#inline "C_u_fixnum_difference" <x1> (##core#inline "C_u_fixnum_difference" ...))
- ;; [fixnum-mode + unsafe]
- ;; - Remove "0" from arguments, if more than 1.
- (cond [(null? callargs) #f]
- [(and (null? (cdr callargs)) (eq? number-type 'fixnum))
- (make-node
- '##core#call (list #t)
- (list cont
- (make-node '##core#inline
- (if unsafe '("C_u_fixnum_negate") '("C_fixnum_negate"))
- callargs)) ) ]
- [else
- (let ([callargs
- (cons (car callargs)
- (filter
- (lambda (x)
- (not (and (eq? 'quote (node-class x))
- (zero? (first (node-parameters x))) ) ) )
- (cdr callargs) ) ) ] )
- (and (eq? number-type 'fixnum)
- (>= (length callargs) 2)
- (make-node
- '##core#call (list #t)
- (list
- cont
- (fold-inner
- (lambda (x y)
- (make-node '##core#inline
- (if unsafe '("C_u_fixnum_difference") '("C_fixnum_difference"))
- (list x y) ) )
- callargs) ) ) ) ) ] ) ) )
-
-(rewrite
- '/ 8
- (lambda (db classargs cont callargs)
- ;; (/ <x1> ...) -> (##core#inline "C_fixnum_divide" <x1> (##core#inline "C_fixnum_divide" ...)) [fixnum-mode]
- ;; - Remove "1" from arguments, if more than 1.
- ;; - Replace divisions by 2 with shift right. [fixnum-mode]
- (and (>= (length callargs) 2)
- (let ([callargs
- (cons (car callargs)
- (filter
- (lambda (x)
- (not (and (eq? 'quote (node-class x))
- (eq? 1 (first (node-parameters x))) ) ) )
- (cdr callargs) ) ) ] )
- (and (eq? number-type 'fixnum)
- (>= (length callargs) 2)
- (make-node
- '##core#call (list #t)
- (list
- cont
- (fold-inner
- (lambda (x y)
- (if (and (eq? 'quote (node-class y)) (eq? 2 (first (node-parameters y))))
- (make-node '##core#inline '("C_fixnum_shift_right") (list x (qnode 1)))
- (make-node '##core#inline '("C_fixnum_divide") (list x y)) ) )
- callargs) ) ) ) ) ) ) )
-
-(rewrite
- 'quotient 8
- (lambda (db classargs cont callargs)
- ;; (quotient <x> 2) -> (##core#inline "C_fixnum_shift_right" <x> 1) [fixnum-mode]
- ;; (quotient <x> <y>) -> (##core#inline "C_fixnum_divide" <x> <y>) [fixnum-mode]
- ;; (quotient <x> <y>) -> ((##core#proc "C_quotient") <x> <y>)
- (and (= (length callargs) 2)
- (if (eq? 'fixnum number-type)
- (make-node
- '##core#call (list #t)
- (let ([arg2 (second callargs)])
- (list cont
- (if (and (eq? 'quote (node-class arg2))
- (eq? 2 (first (node-parameters arg2))) )
- (make-node
- '##core#inline '("C_fixnum_shift_right")
- (list (first callargs) (qnode 1)) )
- (make-node '##core#inline '("C_fixnum_divide") callargs) ) ) ) )
- (make-node
- '##core#call (list #t)
- (cons* (make-node '##core#proc '("C_quotient" #t) '()) cont callargs) ) ) ) ) )
-
-(let ()
- ;; (add1 <x>) -> (##core#inline "C_fixnum_increase" <x>) [fixnum-mode]
- ;; (add1 <x>) -> (##core#inline "C_u_fixnum_increase" <x>) [fixnum-mode + unsafe]
- ;; (add1 <x>) -> (##core#inline_allocate ("C_a_i_plus" 4) <x> 1)
- ;; (sub1 <x>) -> (##core#inline "C_fixnum_decrease" <x>) [fixnum-mode]
- ;; (sub1 <x>) -> (##core#inline "C_u_fixnum_decrease" <x>) [fixnum-mode + unsafe]
- ;; (sub1 <x>) -> (##core#inline_allocate ("C_a_i_minus" 4) <x> 1)
- (define ((op1 fiop ufiop aiop) db classargs cont callargs)
- (and (= (length callargs) 1)
- (make-node
- '##core#call (list #t)
- (list
- cont
- (if (eq? 'fixnum number-type)
- (make-node '##core#inline (list (if unsafe ufiop fiop)) callargs)
- (make-node
- '##core#inline_allocate (list aiop 4)
- (list (car callargs) (qnode 1))))))))
- (rewrite 'add1 8 (op1 "C_fixnum_increase" "C_u_fixnum_increase" "C_a_i_plus"))
- (rewrite 'sub1 8 (op1 "C_fixnum_decrease" "C_u_fixnum_decrease" "C_a_i_minus")))
-
(let ()
(define (eqv?-id db classargs cont callargs)
;; (eqv? <var> <var>) -> (quote #t) [two identical objects]
@@ -632,6 +494,7 @@
(rewrite 'fxmin 2 2 "C_i_fixnum_min" #t)
(rewrite 'fpmax 2 2 "C_i_flonum_max" #f)
(rewrite 'fpmin 2 2 "C_i_flonum_min" #f)
+(rewrite 'fxgcd 2 2 "C_i_fixnum_gcd" #t)
(rewrite 'fxlen 2 1 "C_i_fixnum_length" #t)
(rewrite 'char-numeric? 2 1 "C_u_i_char_numericp" #t)
(rewrite 'char-alphabetic? 2 1 "C_u_i_char_alphabeticp" #t)
@@ -661,7 +524,6 @@
(rewrite 'set-cdr! 17 2 "C_i_set_cdr" "C_u_i_set_cdr")
(rewrite 'abs 14 'fixnum 1 "C_fixnum_abs" "C_fixnum_abs")
-(rewrite 'abs 16 1 "C_a_i_abs" #t words-per-flonum)
(rewrite 'bitwise-xor 21 0 "C_fixnum_xor" "C_fixnum_xor" "C_a_i_bitwise_xor" words-per-flonum)
(rewrite 'bitwise-and 21 -1 "C_fixnum_and" "C_u_fixnum_and" "C_a_i_bitwise_and" words-per-flonum)
@@ -675,6 +537,7 @@
(rewrite 'fp/ 16 2 "C_a_i_flonum_quotient" #f words-per-flonum)
(rewrite 'fp/? 16 2 "C_a_i_flonum_quotient_checked" #f words-per-flonum)
(rewrite 'fpneg 16 1 "C_a_i_flonum_negate" #f words-per-flonum)
+(rewrite 'fpgcd 16 2 "C_a_i_flonum_gcd" #f words-per-flonum)
(rewrite 'exp 16 1 "C_a_i_exp" #t words-per-flonum)
(rewrite 'sin 16 1 "C_a_i_sin" #t words-per-flonum)
@@ -762,10 +625,6 @@
(rewrite 'lcm 18 1)
(rewrite 'list 18 '())
-(rewrite '* 16 2 "C_a_i_times" #t 4) ; words-per-flonum
-(rewrite '+ 16 2 "C_a_i_plus" #t 4) ; words-per-flonum
-(rewrite '- 16 2 "C_a_i_minus" #t 4) ; words-per-flonum
-(rewrite '/ 16 2 "C_a_i_divide" #t 4) ; words-per-flonum
(rewrite 'exact->inexact 16 1 "C_a_i_exact_to_inexact" #t 4) ; words-per-flonum
(rewrite '= 17 2 "C_i_nequalp")
@@ -780,11 +639,6 @@
(rewrite '>= 13 #f "C_greater_or_equal_p" #t)
(rewrite '<= 13 #f "C_less_or_equal_p" #t)
-(rewrite '* 13 #f "C_times" #t)
-(rewrite '+ 13 #f "C_plus" #t)
-(rewrite '/ 13 '(1 . #f) "C_divide" #t)
-(rewrite '- 13 '(1 . #f) "C_minus" #t)
-
(rewrite 'number->string 13 '(1 . 2) "C_number_to_string" #t)
(rewrite '##sys#call-with-current-continuation 13 1 "C_call_cc" #t)
(rewrite '##sys#allocate-vector 13 4 "C_allocate_vector" #t)
@@ -883,6 +737,7 @@
(rewrite 'fxior 17 2 "C_fixnum_or" "C_u_fixnum_or")
(rewrite 'fx/ 17 2 "C_fixnum_divide" "C_u_fixnum_divide")
(rewrite 'fxmod 17 2 "C_fixnum_modulo" "C_u_fixnum_modulo")
+(rewrite 'fxrem 17 2 "C_i_fixnum_remainder_checked")
(rewrite
'arithmetic-shift 8
diff --git a/chicken.h b/chicken.h
index 75e369f0..00871212 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1135,6 +1135,8 @@ extern double trunc(double);
#define C_data_pointer(b) C_CHECKp(b,C_blockp((C_word)C_VAL1(b)),(void *)(((C_SCHEME_BLOCK *)(C_VAL1(b)))->data))
#define C_bignum_negativep(b) C_CHECKp(b,C_bignump(C_VAL1(b)),(C_block_item(b,0)!=0))
#define C_bignum_digits(b) C_CHECKp(b,C_bignump(C_VAL1(b)),(((C_uword *)C_data_pointer(C_VAL1(b)))+1))
+#define C_fitsinbignumhalfdigitp(n)(C_BIGNUM_DIGIT_HI_HALF(n) == 0)
+#define C_bignum_negated_fitsinfixnump(b) (C_bignum_size(b) == 1 && (C_bignum_negativep(b) ? C_ufitsinfixnump(*C_bignum_digits(b)) : !(*C_bignum_digits(b) & C_INT_SIGN_BIT) && C_fitsinfixnump(-(C_word)*C_bignum_digits(b))))
#define C_bignum_mutate_size(b,s) (C_block_header(b) = (C_BIGNUM_TYPE | C_wordstobytes((s)+1)))
#define C_fitsinfixnump(n) (((n) & C_INT_SIGN_BIT) == (((n) & C_INT_TOP_BIT) << 1))
#define C_ufitsinfixnump(n) (((n) & (C_INT_SIGN_BIT | (C_INT_SIGN_BIT >> 1))) == 0)
@@ -1241,12 +1243,16 @@ extern double trunc(double);
#define C_setsubchar(x, i, n) (((C_char *)C_data_pointer(x))[ C_unfix(i) ] = C_character_code(n), C_SCHEME_UNDEFINED)
#define C_setsubbyte(x, i, n) (((C_char *)C_data_pointer(x))[ C_unfix(i) ] = C_unfix(n), C_SCHEME_UNDEFINED)
+/* XXX TODO OBSOLETE, but still used by fx* */
#define C_fixnum_times(n1, n2) (C_fix(C_unfix(n1) * C_unfix(n2)))
+/* XXX TODO OBSOLETE, but still used by C_fixnum_plus, which is fx+ */
#define C_u_fixnum_plus(n1, n2) (((n1) - C_FIXNUM_BIT) + (n2))
#define C_fixnum_plus(n1, n2) (C_u_fixnum_plus(n1, n2) | C_FIXNUM_BIT)
+/* XXX TODO OBSOLETE, but still used by C_fixnum_difference, which is fx- */
#define C_u_fixnum_difference(n1, n2) ((n1) - (n2) + C_FIXNUM_BIT)
#define C_fixnum_difference(n1, n2) (C_u_fixnum_difference(n1, n2) | C_FIXNUM_BIT)
#define C_u_fixnum_divide(n1, n2) (C_fix(C_unfix(n1) / C_unfix(n2)))
+/* XXX TODO OBSOLETE, but still used by C_fixnum_modulo, which is fxmod */
#define C_u_fixnum_modulo(n1, n2) (C_fix(C_unfix(n1) % C_unfix(n2)))
#define C_u_fixnum_and(n1, n2) ((n1) & (n2))
#define C_fixnum_and(n1, n2) (C_u_fixnum_and(n1, n2) | C_FIXNUM_BIT)
@@ -1256,6 +1262,7 @@ extern double trunc(double);
#define C_fixnum_not(n) ((~(n)) | C_FIXNUM_BIT)
#define C_fixnum_shift_left(n1, n2) (C_fix(C_unfix(n1) << C_unfix(n2)))
#define C_fixnum_shift_right(n1, n2) (((n1) >> C_unfix(n2)) | C_FIXNUM_BIT)
+/* XXX TODO OBSOLETE, but still used by C_fixnum_negate, which is fxneg */
#define C_u_fixnum_negate(n) (-(n) + 2 * C_FIXNUM_BIT)
#define C_fixnum_negate(n) (C_u_fixnum_negate(n) | C_FIXNUM_BIT)
#define C_fixnum_greaterp(n1, n2) (C_mk_bool((C_word)(n1) > (C_word)(n2)))
@@ -1266,7 +1273,9 @@ extern double trunc(double);
#define C_fixnum_increase(n) (C_u_fixnum_increase(n) | C_FIXNUM_BIT)
#define C_u_fixnum_decrease(n) ((n) - (1 << C_FIXNUM_SHIFT))
#define C_fixnum_decrease(n) (C_u_fixnum_decrease(n) | C_FIXNUM_BIT)
+/* XXX TODO: This should probably be renamed C_u_fixnum_abs or something */
#define C_fixnum_abs(n) C_fix(abs(C_unfix(n)))
+#define C_a_i_fixnum_abs(ptr, n, x) (((x) & C_INT_SIGN_BIT) ? C_a_i_fixnum_negate((ptr), (n), (x)) : (x))
#define C_i_fixnum_length(x) C_fix(C_ilen(((x) & C_INT_SIGN_BIT) ? ~C_unfix(x) : C_unfix(x)))
#define C_flonum_equalp(n1, n2) C_mk_bool(C_flonum_magnitude(n1) == C_flonum_magnitude(n2))
@@ -1320,6 +1329,7 @@ extern double trunc(double);
#define C_randomize(n) (srand(C_unfix(n)), C_SCHEME_UNDEFINED)
#define C_block_size(x) C_fix(C_header_size(x))
#define C_u_i_bignum_size(b) C_fix(C_bignum_size(b))
+#define C_a_u_i_big_to_flo(p, n, b) C_flonum(p, C_bignum_to_double(b))
#define C_pointer_address(x) ((C_byte *)C_block_item((x), 0))
#define C_block_address(ptr, n, x) C_a_unsigned_int_to_num(ptr, n, x)
#define C_offset_pointer(x, y) (C_pointer_address(x) + (y))
@@ -1462,6 +1472,7 @@ extern double trunc(double);
#define C_u_i_cdddar(x) C_u_i_cdr( C_u_i_cddar( x ) )
#define C_u_i_cddddr(x) C_u_i_cdr( C_u_i_cdddr( x ) )
+/* XXX TODO OBSOLETE: These 4 can be removed after recompiling c-platform.scm */
#define C_a_i_times( ptr, n, x, y) C_2_times( ptr, x, y)
#define C_a_i_plus( ptr, n, x, y) C_2_plus( ptr, x, y)
#define C_a_i_minus( ptr, n, x, y) C_2_minus( ptr, x, y)
@@ -1799,6 +1810,7 @@ C_fctexport void C_temp_stack_overflow(void) C_noret;
C_fctexport void C_unbound_error(C_word sym) C_noret;
C_fctexport void C_no_closure_error(C_word x) C_noret;
C_fctexport void C_div_by_zero_error(char *loc) C_noret;
+C_fctexport void C_not_an_integer_error(char *loc, C_word x) C_noret;
C_fctexport C_word C_closure(C_word **ptr, int cells, C_word proc, ...);
C_fctexport C_word C_fcall C_pair(C_word **ptr, C_word car, C_word cdr) C_regparm;
C_fctexport C_word C_fcall C_number(C_word **ptr, double n) C_regparm;
@@ -1860,6 +1872,8 @@ C_fctexport C_char *C_private_repository_path();
C_fctimport void C_ccall C_toplevel(C_word c, C_word self, C_word k) C_noret;
C_fctimport void C_ccall C_invalid_procedure(int c, C_word self, ...) C_noret;
C_fctexport void C_ccall C_stop_timer(C_word c, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_abs(C_word c, C_word self, C_word k, C_word x) C_noret;
+C_fctexport void C_ccall C_u_integer_abs(C_word c, C_word self, C_word k, C_word x) C_noret;
C_fctexport void C_ccall C_apply(C_word c, C_word closure, C_word k, C_word fn, ...) C_noret;
C_fctexport void C_ccall C_do_apply(C_word n, C_word closure, C_word k) C_noret;
C_fctexport void C_ccall C_call_cc(C_word c, C_word closure, C_word k, C_word cont) C_noret;
@@ -1868,10 +1882,28 @@ C_fctexport void C_ccall C_values(C_word c, C_word closure, C_word k, ...) C_nor
C_fctexport void C_ccall C_apply_values(C_word c, C_word closure, C_word k, C_word lst) C_noret;
C_fctexport void C_ccall C_call_with_values(C_word c, C_word closure, C_word k, C_word thunk, C_word kont) C_noret;
C_fctexport void C_ccall C_u_call_with_values(C_word c, C_word closure, C_word k, C_word thunk, C_word kont) C_noret;
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport void C_ccall C_times(C_word c, C_word closure, C_word k, ...) C_noret;
+C_fctexport void C_ccall C_2_basic_times(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
+C_fctexport void C_ccall C_u_2_integer_times(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport void C_ccall C_plus(C_word c, C_word closure, C_word k, ...) C_noret;
+C_fctexport void C_ccall C_2_basic_plus(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
+C_fctexport void C_ccall C_u_2_integer_plus(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport void C_ccall C_minus(C_word c, C_word closure, C_word k, C_word n1, ...) C_noret;
+C_fctexport void C_ccall C_negate(C_word c, C_word self, C_word k, C_word x) C_noret;
+C_fctexport void C_ccall C_u_integer_negate(C_word c, C_word self, C_word k, C_word x) C_noret;
+C_fctexport void C_ccall C_2_basic_minus(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
+C_fctexport void C_ccall C_u_2_integer_minus(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport void C_ccall C_divide(C_word c, C_word closure, C_word k, C_word n1, ...) C_noret;
+C_fctexport void C_ccall C_basic_quotient(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
+C_fctexport void C_ccall C_u_integer_quotient(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
+C_fctexport void C_ccall C_basic_remainder(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
+C_fctexport void C_ccall C_u_integer_remainder(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
+C_fctexport void C_ccall C_basic_divrem(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
+void C_ccall C_u_integer_divrem(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
C_fctexport void C_ccall C_nequalp(C_word c, C_word closure, C_word k, ...) C_noret;
C_fctexport void C_ccall C_greaterp(C_word c, C_word closure, C_word k, ...) C_noret;
C_fctexport void C_ccall C_lessp(C_word c, C_word closure, C_word k, ...) C_noret;
@@ -1884,6 +1916,7 @@ C_fctexport void C_ccall C_allocate_vector(C_word c, C_word closure, C_word k, C
C_fctexport void C_ccall C_allocate_bignum(C_word c, C_word self, C_word k, C_word size, C_word negp, C_word initp) C_noret;
C_fctexport void C_ccall C_string_to_symbol(C_word c, C_word closure, C_word k, C_word string) C_noret;
C_fctexport void C_ccall C_build_symbol(C_word c, C_word closure, C_word k, C_word string) C_noret;
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport void C_ccall C_quotient(C_word c, C_word closure, C_word k, C_word n1, C_word n2) C_noret;
C_fctexport void C_ccall C_digits_to_integer(C_word c, C_word self, C_word k, C_word n, C_word start, C_word end, C_word radix, C_word negp) C_noret;
C_fctexport void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num, ...) C_noret;
@@ -1924,6 +1957,7 @@ C_fctexport C_word C_a_i_string(C_word **a, int c, ...);
C_fctexport C_word C_a_i_record(C_word **a, int c, ...);
C_fctexport C_word C_a_i_port(C_word **a, int c);
C_fctexport C_word C_fcall C_a_i_bytevector(C_word **a, int c, C_word x) C_regparm;
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport C_word C_fcall C_a_i_abs(C_word **a, int c, C_word n) C_regparm;
C_fctexport C_word C_fcall C_i_listp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_string_equal_p(C_word x, C_word y) C_regparm;
@@ -1996,9 +2030,13 @@ C_fctexport C_word C_fcall C_i_check_vector_2(C_word x, C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_structure_2(C_word x, C_word st, C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_char_2(C_word x, C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_port_2(C_word x, C_word in, C_word op, C_word loc) C_regparm;
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport C_word C_fcall C_2_times(C_word **ptr, C_word x, C_word y) C_regparm;
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport C_word C_fcall C_2_plus(C_word **ptr, C_word x, C_word y) C_regparm;
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport C_word C_fcall C_2_minus(C_word **ptr, C_word x, C_word y) C_regparm;
+ /* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport C_word C_fcall C_2_divide(C_word **ptr, C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_bignum_cmp(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_nequalp(C_word x, C_word y) C_regparm;
@@ -2043,11 +2081,15 @@ C_fctexport C_word C_fcall C_i_o_fixnum_and(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_o_fixnum_ior(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_o_fixnum_xor(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_a_i_flonum_round_proper(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_fcall C_a_i_flonum_gcd(C_word **p, C_word n, C_word x, C_word y) C_regparm;
+
C_fctexport C_word C_fcall C_i_getprop(C_word sym, C_word prop, C_word def) C_regparm;
C_fctexport C_word C_fcall C_putprop(C_word **a, C_word sym, C_word prop, C_word val) C_regparm;
C_fctexport C_word C_fcall C_i_get_keyword(C_word key, C_word args, C_word def) C_regparm;
C_fctexport double C_fcall C_milliseconds(void) C_regparm;
C_fctexport double C_fcall C_cpu_milliseconds(void) C_regparm;
+C_fctexport double C_fcall C_bignum_to_double(C_word bignum) C_regparm;
+
C_fctexport C_word C_fcall C_a_i_cpu_time(C_word **a, int c, C_word buf) C_regparm;
/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport C_word C_fcall C_a_i_string_to_number(C_word **a, int c, C_word str, C_word radix) C_regparm;
@@ -2561,6 +2603,56 @@ C_inline C_word C_i_ratnump(C_word x)
C_block_item(x, 0) == C_ratnum_type_tag);
}
+/* Silly (this is not normalized) but in some cases needed internally */
+C_inline C_word C_bignum0(C_word **ptr)
+{
+ C_word *p = *ptr, p0 = (C_word)p;
+
+ /* Not using C_a_i_vector4, to make it easier to rewrite later */
+ *(p++) = C_BIGNUM_TYPE | C_wordstobytes(1);
+ *(p++) = 0; /* zero is always positive */
+ *ptr = p;
+
+ return p0;
+}
+
+C_inline C_word C_bignum1(C_word **ptr, int negp, C_uword d1)
+{
+ C_word *p = *ptr, p0 = (C_word)p;
+
+ *(p++) = C_BIGNUM_TYPE | C_wordstobytes(2);
+ *(p++) = negp;
+ *(p++) = d1;
+ *ptr = p;
+
+ return p0;
+}
+
+/* Here d1, d2, ... are low to high (ie, little endian)! */
+C_inline C_word C_bignum2(C_word **ptr, int negp, C_uword d1, C_uword d2)
+{
+ C_word *p = *ptr, p0 = (C_word)p;
+
+ *(p++) = C_BIGNUM_TYPE | C_wordstobytes(3);
+ *(p++) = negp;
+ *(p++) = d1;
+ *(p++) = d2;
+ *ptr = p;
+
+ return p0;
+}
+
+/* TODO: Is this correctly named? Shouldn't it accept an argcount? */
+C_inline C_word C_a_u_i_fix_to_big(C_word **ptr, C_word x)
+{
+ x = C_unfix(x);
+ if (x < 0)
+ return C_bignum1(ptr, 1, -x);
+ else if (x == 0)
+ return C_bignum0(ptr);
+ else
+ return C_bignum1(ptr, 0, x);
+}
C_inline C_word C_i_fixnum_min(C_word x, C_word y)
{
@@ -2573,6 +2665,18 @@ C_inline C_word C_i_fixnum_max(C_word x, C_word y)
return ((C_word)x > (C_word)y) ? x : y;
}
+C_inline C_word C_i_fixnum_gcd(C_word x, C_word y)
+{
+ x = (x & C_INT_SIGN_BIT) ? -C_unfix(x) : C_unfix(x);
+ y = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y);
+
+ while(y != 0) {
+ C_word r = x % y;
+ x = y;
+ y = r;
+ }
+ return C_fix(x);
+}
C_inline C_word C_fixnum_divide(C_word x, C_word y)
{
@@ -2587,6 +2691,31 @@ C_inline C_word C_fixnum_modulo(C_word x, C_word y)
return C_u_fixnum_modulo(x, y);
}
+/* XXX: Naming convention is inconsistent! There's C_fixnum_divide()
+ * but also C_a_i_flonum_quotient_checked()
+ */
+C_inline C_word
+C_a_i_fixnum_quotient_checked(C_word **ptr, int c, C_word x, C_word y)
+{
+ if (y == C_fix(0)) {
+ C_div_by_zero_error("fx/");
+ } else if (x == C_fix(C_MOST_NEGATIVE_FIXNUM) && y == C_fix(-1)) {
+ return C_bignum1(ptr, 0, -C_MOST_NEGATIVE_FIXNUM); /* Special case */
+ } else {
+ return C_u_fixnum_divide(x, y); /* Inconsistent, too: missing _i_ */
+ }
+}
+
+C_inline C_word C_i_fixnum_remainder_checked(C_word x, C_word y)
+{
+ if (y == C_fix(0)) {
+ C_div_by_zero_error("fxrem");
+ } else {
+ x = C_unfix(x);
+ y = C_unfix(y);
+ return C_fix(x - ((x / y) * y));
+ }
+}
C_inline C_word C_i_fixnum_arithmetic_shift(C_word n, C_word c)
{
@@ -2594,6 +2723,79 @@ C_inline C_word C_i_fixnum_arithmetic_shift(C_word n, C_word c)
else return C_fixnum_shift_left(n, c);
}
+C_inline C_word C_a_i_fixnum_negate(C_word **ptr, C_word n, C_word x)
+{
+ /* Exceptional situation: this will cause an overflow to itself */
+ if (x == C_fix(C_MOST_NEGATIVE_FIXNUM)) /* C_fitsinfixnump(x) */
+ return C_bignum1(ptr, 0, -C_MOST_NEGATIVE_FIXNUM);
+ else
+ return C_fix(-C_unfix(x));
+}
+
+C_inline C_word C_a_i_fixnum_difference(C_word **ptr, C_word n, C_word x, C_word y)
+{
+ C_word z = C_unfix(x) - C_unfix(y);
+
+ if(!C_fitsinfixnump(z)) {
+ /* TODO: function/macro returning either fixnum or bignum from a C int */
+ /* This should help with the C API/FFI too. */
+ return C_bignum1(ptr, z < 0, labs(z));
+ } else {
+ return C_fix(z);
+ }
+}
+
+C_inline C_word C_a_i_fixnum_plus(C_word **ptr, C_word n, C_word x, C_word y)
+{
+ /* Exceptional situation: this will cause a real underflow */
+ if (x == C_fix(C_MOST_NEGATIVE_FIXNUM) && y == C_fix(C_MOST_NEGATIVE_FIXNUM)) {
+ return C_bignum1(ptr, 1, ((C_uword)-C_MOST_NEGATIVE_FIXNUM) << 1);
+ } else {
+ C_word z = C_unfix(x) + C_unfix(y);
+
+ if(!C_fitsinfixnump(z)) {
+ /* TODO: function/macro returning either fixnum or bignum from a C int */
+ /* This should help with the C API/FFI too. */
+ return C_bignum1(ptr, z < 0, labs(z));
+ } else {
+ return C_fix(z);
+ }
+ }
+}
+
+C_inline C_word C_a_i_fixnum_times(C_word **ptr, C_word n, C_word x, C_word y)
+{
+ C_uword negp, xhi, xlo, yhi, ylo, p, rhi, rlo;
+
+ negp = ((x & C_INT_SIGN_BIT) ? !(y & C_INT_SIGN_BIT) : (y & C_INT_SIGN_BIT));
+ x = (x & C_INT_SIGN_BIT) ? -C_unfix(x) : C_unfix(x);
+ y = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y);
+
+ xhi = C_BIGNUM_DIGIT_HI_HALF(x); xlo = C_BIGNUM_DIGIT_LO_HALF(x);
+ yhi = C_BIGNUM_DIGIT_HI_HALF(y); ylo = C_BIGNUM_DIGIT_LO_HALF(y);
+
+ /* This is simply bignum_digits_multiply unrolled for 2x2 halfdigits */
+ p = xlo * ylo;
+ rlo = C_BIGNUM_DIGIT_LO_HALF(p);
+
+ p = xhi * ylo + C_BIGNUM_DIGIT_HI_HALF(p);
+ rhi = C_BIGNUM_DIGIT_HI_HALF(p);
+
+ p = xlo * yhi + C_BIGNUM_DIGIT_LO_HALF(p);
+ rlo = C_BIGNUM_DIGIT_COMBINE(C_BIGNUM_DIGIT_LO_HALF(p), rlo);
+
+ rhi = xhi * yhi + C_BIGNUM_DIGIT_HI_HALF(p) + rhi;
+
+ if (rhi) {
+ return C_bignum2(ptr, negp != 0, rlo, rhi);
+ } else if (negp ?
+ ((rlo & C_INT_SIGN_BIT) || !C_fitsinfixnump(-(C_word)rlo)) :
+ !C_ufitsinfixnump(rlo)) {
+ return C_bignum1(ptr, negp != 0, rlo);
+ } else {
+ return C_fix(negp ? -rlo : rlo);
+ }
+}
C_inline C_word C_i_flonum_min(C_word x, C_word y)
{
@@ -2632,6 +2834,44 @@ C_ub_i_flonum_quotient_checked(double n1, double n2)
return n1 / n2;
}
+/* More weirdness: the other flonum_quotient macros and inline functions
+ * do not compute the quotient but the "plain" division!
+ */
+C_inline C_word
+C_a_i_flonum_actual_quotient_checked(C_word **ptr, int c, C_word x, C_word y)
+{
+ double dy = C_flonum_magnitude(y), r;
+
+ if(dy == 0.0) {
+ C_div_by_zero_error("quotient");
+ } else if (!C_truep(C_u_i_fpintegerp(x))) {
+ C_not_an_integer_error("quotient", x);
+ } else if (!C_truep(C_u_i_fpintegerp(y))) {
+ C_not_an_integer_error("quotient", y);
+ } else {
+ modf(C_flonum_magnitude(x) / dy, &r);
+ return C_flonum(ptr, r);
+ }
+}
+
+C_inline C_word
+C_a_i_flonum_remainder_checked(C_word **ptr, int c, C_word x, C_word y)
+{
+ double dx = C_flonum_magnitude(x),
+ dy = C_flonum_magnitude(y), r;
+
+ if(dy == 0.0) {
+ C_div_by_zero_error("remainder");
+ } else if (!C_truep(C_u_i_fpintegerp(x))) {
+ C_not_an_integer_error("remainder", x);
+ } else if (!C_truep(C_u_i_fpintegerp(y))) {
+ C_not_an_integer_error("remainder", y);
+ } else {
+ modf(dx / dy, &r);
+ return C_flonum(ptr, dx - r * dy);
+ }
+}
+
C_inline C_word C_i_safe_pointerp(C_word x)
{
@@ -3041,57 +3281,6 @@ C_inline C_word C_a_i_record8(C_word **ptr, int n, C_word x1, C_word x2, C_word
return (C_word)p0;
}
-/* Silly (this is not normalized) but in some cases needed internally */
-C_inline C_word C_bignum0(C_word **ptr)
-{
- C_word *p = *ptr, p0 = (C_word)p;
-
- /* Not using C_a_i_vector4, to make it easier to rewrite later */
- *(p++) = C_BIGNUM_TYPE | C_wordstobytes(1);
- *(p++) = 0; /* zero is always positive */
- *ptr = p;
-
- return p0;
-}
-
-C_inline C_word C_bignum1(C_word **ptr, int negp, C_uword d1)
-{
- C_word *p = *ptr, p0 = (C_word)p;
-
- *(p++) = C_BIGNUM_TYPE | C_wordstobytes(2);
- *(p++) = negp;
- *(p++) = d1;
- *ptr = p;
-
- return p0;
-}
-
-/* Here d1, d2, ... are low to high (ie, little endian)! */
-C_inline C_word C_bignum2(C_word **ptr, int negp, C_uword d1, C_uword d2)
-{
- C_word *p = *ptr, p0 = (C_word)p;
-
- *(p++) = C_BIGNUM_TYPE | C_wordstobytes(3);
- *(p++) = negp;
- *(p++) = d1;
- *(p++) = d2;
- *ptr = p;
-
- return p0;
-}
-
-/* TODO: Is this correctly named? Shouldn't it accept an argcount? */
-C_inline C_word C_a_u_i_fix_to_big(C_word **ptr, C_word x)
-{
- x = C_unfix(x);
- if (x < 0)
- return C_bignum1(ptr, 1, -x);
- else if (x == 0)
- return C_bignum0(ptr);
- else
- return C_bignum1(ptr, 0, x);
-}
-
/*
* From Hacker's Delight by Henry S. Warren
* based on a modified nlz() from section 5-3 (fig. 5-7)
diff --git a/chicken.import.scm b/chicken.import.scm
index a325410b..47ab3c4e 100644
--- a/chicken.import.scm
+++ b/chicken.import.scm
@@ -120,6 +120,7 @@
fpcos
fpinteger?
fplog
+ fpgcd
fpmax
fpmin
fpneg
@@ -139,6 +140,7 @@
fx>=
fxand
fxeven?
+ fxgcd
fxior
fxlen
fxmax
@@ -147,9 +149,11 @@
fxneg
fxnot
fxodd?
+ fxrem
fxshl
fxshr
fxxor
+ fxlen
gc
gensym
get
@@ -201,6 +205,8 @@
promise?
put!
quit
+ quotient&modulo
+ quotient&remainder
ratnum?
register-feature!
remprop!
diff --git a/library.scm b/library.scm
index a936091b..cdf65e04 100644
--- a/library.scm
+++ b/library.scm
@@ -36,8 +36,7 @@
##sys#format-here-doc-warning
exit-in-progress
maximal-string-length
- ##sys#integer-power ##sys#integer-quotient
- make-complex
+ make-complex ratnum rat+/-
+maximum-allowed-exponent+ mantexp->dbl ldexp round-quotient
##sys#string->compnum)
(not inline ##sys#user-read-hook ##sys#error-hook ##sys#signal-hook ##sys#schedule
@@ -313,10 +312,8 @@ EOF
(##core#inline "C_i_check_locative" x) ) )
(define (##sys#check-integer x . loc)
- (unless (##core#inline "C_i_integerp" x)
- (##sys#error-hook
- (foreign-value "C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR" int)
- (and (pair? loc) (car loc)) x) ) )
+ (unless (##core#inline "C_i_integerp" x)
+ (##sys#error-bad-integer x (and (pair? loc) (car loc))) ) )
(define (##sys#check-real x . loc)
(unless (##core#inline "C_i_realp" x)
@@ -447,6 +444,10 @@ EOF
(##sys#error-hook
(foreign-value "C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR" int) loc arg))
+(define (##sys#error-bad-integer arg #!optional loc)
+ (##sys#error-hook
+ (foreign-value "C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR" int) loc arg))
+
(define (##sys#error-bad-base arg #!optional loc)
(##sys#error-hook
(foreign-value "C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR" int) loc arg))
@@ -745,7 +746,9 @@ EOF
(define (fxeven? x) (##core#inline "C_i_fixnumevenp" x))
(define (fxlen x) (##core#inline "C_i_fixnum_length" x))
(define (fx/ x y) (##core#inline "C_fixnum_divide" x y) )
+(define (fxgcd x y) (##core#inline "C_i_fixnum_gcd" x y))
(define (fxmod x y) (##core#inline "C_fixnum_modulo" x y) )
+(define (fxrem x y) (##core#inline "C_i_fixnum_remainder_checked" x y) )
;; these are currently undocumented
(define (fx+? x y) (##core#inline "C_i_o_fixnum_plus" x y) )
@@ -797,6 +800,10 @@ EOF
(fp-check-flonums x y 'fp/)
(##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y) )
+(define (fpgcd x y)
+ (fp-check-flonums x y 'fpgcd)
+ (##core#inline_allocate ("C_a_i_flonum_gcd" 4) x y))
+
(define (fp/? x y) ; undocumented
(fp-check-flonums x y 'fp/?)
(##core#inline_allocate ("C_a_i_flonum_quotient_checked" 4) x y) )
@@ -905,32 +912,21 @@ EOF
(fp-check-flonum x 'fpinteger?)
(##core#inline "C_u_i_fpintegerp" x))
-;; Placeholders for later
-(define (##sys#+-2 a b) (+ a b))
-(define (##sys#*-2 a b) (* a b))
-(define (##sys#/-2 a b) (/ a b))
(define (##sys#=-2 a b) (##core#inline "C_i_nequalp" a b))
(define (##sys#<-2 a b) (##core#inline "C_i_lessp" a b))
(define (##sys#<=-2 a b) (##core#inline "C_i_less_or_equalp" a b))
(define (##sys#>-2 a b) (##core#inline "C_i_greaterp" a b))
(define (##sys#>=-2 a b) (##core#inline "C_i_greater_or_equalp" a b))
-(define (##sys#integer-power a b) (expt a b))
-(define (##sys#integer-quotient a b) (quotient a b))
-(define * (##core#primitive "C_times"))
-(define - (##core#primitive "C_minus"))
-(define + (##core#primitive "C_plus"))
-(define / (##core#primitive "C_divide"))
(define = (##core#primitive "C_nequalp"))
(define > (##core#primitive "C_greaterp"))
(define < (##core#primitive "C_lessp"))
(define >= (##core#primitive "C_greater_or_equal_p"))
(define <= (##core#primitive "C_less_or_equal_p"))
-(define add1 (lambda (n) (+ n 1)))
-(define sub1 (lambda (n) (- n 1)))
+(define (add1 n) (##sys#+-2 n 1))
+(define (sub1 n) (##sys#--2 n 1))
-(define quotient (##core#primitive "C_quotient"))
(define (number? x) (##core#inline "C_i_numberp" x))
(define ##sys#number? number?)
(define complex? number?)
@@ -950,16 +946,12 @@ EOF
(define (zero? n) (##core#inline "C_i_zerop" n))
(define (positive? n) (##core#inline "C_i_positivep" n))
(define (negative? n) (##core#inline "C_i_negativep" n))
-(define (abs n) (##core#inline_allocate ("C_a_i_abs" 4) n)) ; 4 => words-per-flonum
;;; Complex numbers
(define-inline (%cplxnum-real c) (##sys#slot c 1))
(define-inline (%cplxnum-imag c) (##sys#slot c 2))
-(define-inline (%ratnum-numerator c) (##sys#slot c 1))
-(define-inline (%ratnum-denominator c) (##sys#slot c 2))
-
(define (make-complex r i)
(if (or (eq? i 0) (and (##core#inline "C_i_flonump" i) (fp= i 0.0)))
r
@@ -995,6 +987,13 @@ EOF
(##sys#check-number n 'angle)
(if (< n 0) (fp* 2.0 (acos 0.0)) 0.0) )
+(define (magnitude x)
+ (cond ((cplxnum? x)
+ (let ((r (%cplxnum-real x))
+ (i (%cplxnum-imag x)) )
+ (sqrt (##sys#+-2 (##sys#*-2 r r) (##sys#*-2 i i))) ))
+ ((number? x) (abs x))
+ (else (##sys#error-bad-number x 'magnitude))))
;;; Rational numbers
@@ -1005,8 +1004,9 @@ EOF
(define (ratnum m n)
(cond
((eq? n 1) m)
- ((eq? n -1) (- m))
- ((negative? n) (%make-ratnum (- m) (- n)))
+ ((eq? n -1) (##sys#integer-negate m))
+ ((negative? n)
+ (%make-ratnum (##sys#integer-negate m) (##sys#integer-negate n)))
(else (%make-ratnum m n))))
(define (numerator n)
@@ -1031,7 +1031,32 @@ EOF
#:type-error 'numerator
"bad argument type - not a rational number" n))))
-(define magnitude abs)
+;; Knuth, 4.5.1
+(define (rat+/- loc op x y)
+ (let ((a (%ratnum-numerator x)) (b (%ratnum-denominator x))
+ (c (%ratnum-numerator y)) (d (%ratnum-denominator y)))
+ (let ((g1 (##sys#integer-gcd b d)))
+ (cond
+ ((eq? g1 1) (%make-ratnum (op (##sys#integer-times a d)
+ (##sys#integer-times b c))
+ (##sys#integer-times b d)))
+ ;; Save a quotient and multiplication if the gcd is equal
+ ;; to one of the denominators since quotient of b or d and g1 = 1
+ ((##sys#=-2 g1 b)
+ (let* ((t (op (##sys#integer-times a (##sys#integer-quotient d g1)) c))
+ (g2 (##sys#integer-gcd t g1)))
+ (ratnum (##sys#integer-quotient t g2) (##sys#integer-quotient d g2))))
+ ((##sys#=-2 g1 d)
+ (let* ((t (op a (##sys#integer-times c (##sys#integer-quotient b g1))))
+ (g2 (##sys#integer-gcd t g1)))
+ (ratnum (##sys#integer-quotient t g2) (##sys#integer-quotient b g2))))
+ (else (let* ((b/g1 (##sys#integer-quotient b g1))
+ (t (op (##sys#integer-times a (##sys#integer-quotient d g1))
+ (##sys#integer-times c b/g1)))
+ (g2 (##sys#integer-gcd t g1)))
+ (%make-ratnum (##sys#integer-quotient t g2)
+ (##sys#integer-times
+ b/g1 (##sys#integer-quotient d g2)))))))))
(define (signum n)
(cond ((> n 0) (if (##sys#exact? n) 1 1.0))
@@ -1045,6 +1070,224 @@ EOF
(define ##sys#exact->inexact exact->inexact)
(define ##sys#inexact->exact inexact->exact)
+;;; Basic arithmetic:
+
+(define abs (##core#primitive "C_abs"))
+(define ##sys#integer-abs (##core#primitive "C_u_integer_abs"))
+(define (##sys#extended-abs x)
+ (cond ((ratnum? x)
+ (%make-ratnum (##sys#integer-abs (%ratnum-numerator x))
+ (%ratnum-denominator x)))
+ ((cplxnum? x)
+ (##sys#signal-hook
+ #:type-error 'abs
+ "can not compute absolute value of complex number" x))
+ (else (##sys#error-bad-number x 'abs))))
+
+(define (+ . args)
+ (if (null? args)
+ 0
+ (let ((x (##sys#slot args 0))
+ (args (##sys#slot args 1)))
+ (if (null? args)
+ (if (number? x) x (##sys#error-bad-number x '+))
+ (let loop ((args (##sys#slot args 1))
+ (x (##sys#+-2 x (##sys#slot args 0))))
+ (if (null? args)
+ x
+ (loop (##sys#slot args 1)
+ (##sys#+-2 x (##sys#slot args 0))) ) ) ) ) ) )
+
+(define ##sys#+-2 (##core#primitive "C_2_basic_plus"))
+(define ##sys#integer-plus (##core#primitive "C_u_2_integer_plus"))
+
+(define (##sys#extended-plus x y)
+ (cond ((or (cplxnum? x) (cplxnum? y))
+ ;; Just add real and imag parts together
+ (let ((r (##sys#+-2 (real-part x) (real-part y)))
+ (i (##sys#+-2 (imag-part x) (imag-part y))) )
+ (make-complex r i) ))
+ ((ratnum? x)
+ (if (ratnum? y)
+ (rat+/- '+ ##sys#integer-plus x y)
+ ;; a/b + c/d = (a*d + b*c)/(b*d) [with d = 1]
+ (let* ((b (%ratnum-denominator x))
+ (numerator (##sys#+-2 (%ratnum-numerator x)
+ (##sys#*-2 b y))))
+ (if (##core#inline "C_i_flonump" numerator)
+ (##sys#/-2 numerator b)
+ (%make-ratnum numerator b)))))
+ ((ratnum? y)
+ ;; a/b + c/d = (a*d + b*c)/(b*d) [with b = 1]
+ (let* ((d (%ratnum-denominator y))
+ (numerator (##sys#+-2 (##sys#*-2 x d) (%ratnum-numerator y))))
+ (if (##core#inline "C_i_flonump" numerator)
+ (##sys#/-2 numerator d)
+ (%make-ratnum numerator d))))
+ (else (##sys#error-bad-number y '+)) ) )
+
+(define ##sys#negate (##core#primitive "C_negate"))
+(define ##sys#integer-negate (##core#primitive "C_u_integer_negate"))
+
+(define (- arg1 . args)
+ (if (null? args)
+ (##sys#negate arg1)
+ (let loop ((args (##sys#slot args 1))
+ (x (##sys#--2 arg1 (##sys#slot args 0))))
+ (if (null? args)
+ x
+ (loop (##sys#slot args 1)
+ (##sys#--2 x (##sys#slot args 0))) ) ) ) )
+
+(define ##sys#--2 (##core#primitive "C_2_basic_minus"))
+(define ##sys#integer-minus (##core#primitive "C_u_2_integer_minus"))
+
+(define (##sys#extended-negate x)
+ (cond ((ratnum? x)
+ (%make-ratnum (##sys#integer-negate (%ratnum-numerator x))
+ (%ratnum-denominator x)))
+ ((cplxnum? x)
+ (%make-complex (##sys#negate (compnum-real x))
+ (##sys#negate (compnum-imag x))))
+ (else (##sys#error-bad-number x '-)) ) ) ; loc?
+
+(define (##sys#extended-minus x y)
+ (cond ((or (cplxnum? x) (cplxnum? y))
+ ;; Just subtract real and imag parts from eachother
+ (let ((r (##sys#--2 (real-part x) (real-part y)))
+ (i (##sys#--2 (imag-part x) (imag-part y))))
+ (make-complex r i) ))
+ ((ratnum? x)
+ (if (ratnum? y)
+ (rat+/- '- ##sys#integer-minus x y)
+ ;; a/b - c/d = (a*d - b*c)/(b*d) [with d = 1]
+ (let* ((b (%ratnum-denominator x))
+ (numerator (##sys#--2 (%ratnum-numerator x) (##sys#*-2 b y))))
+ (if (##core#inline "C_i_flonump" numerator)
+ (##sys#/-2 numerator b)
+ (%make-ratnum numerator b)))))
+ ((ratnum? y)
+ ;; a/b - c/d = (a*d - b*c)/(b*d) [with b = 1]
+ (let* ((d (%ratnum-denominator y))
+ (numerator (##sys#--2 (##sys#*-2 x d) (%ratnum-numerator y))))
+ (if (##core#inline "C_i_flonump" numerator)
+ (##sys#/-2 numerator d)
+ (%make-ratnum numerator d))))
+ (else (##sys#error-bad-number y '-)) ) )
+
+(define ##sys#*-2 (##core#primitive "C_2_basic_times"))
+(define ##sys#integer-times (##core#primitive "C_u_2_integer_times"))
+
+(define (* . args)
+ (if (null? args)
+ 1
+ (let ((x (##sys#slot args 0))
+ (args (##sys#slot args 1)))
+ (if (null? args)
+ (if (number? x) x (##sys#error-bad-number x '*))
+ (let loop ((args (##sys#slot args 1))
+ (x (##sys#*-2 x (##sys#slot args 0))))
+ (if (null? args)
+ x
+ (loop (##sys#slot args 1)
+ (##sys#*-2 x (##sys#slot args 0))) ) ) ) ) ) )
+
+(define (##sys#extended-times x y)
+ (define (nonrat*rat x y)
+ ;; a/b * c/d = a*c / b*d [with b = 1]
+ ;; = ((a / g) * c) / (d / g)
+ ;; With g = gcd(a, d) and a = x [Knuth, 4.5.1]
+ (let* ((d (%ratnum-denominator y))
+ (g (##sys#internal-gcd '* x d)))
+ (ratnum (##sys#*-2 (quotient x g) (%ratnum-numerator y))
+ (quotient d g))))
+
+ (cond ((or (cplxnum? x) (cplxnum? y))
+ (let* ((a (real-part x)) (b (imag-part x))
+ (c (real-part y)) (d (imag-part y))
+ (r (##sys#--2 (##sys#*-2 a c) (##sys#*-2 b d)))
+ (i (##sys#+-2 (##sys#*-2 a d) (##sys#*-2 b c))) )
+ (make-complex r i) ) )
+ ((or (##core#inline "C_i_flonump" x) (##core#inline "C_i_flonump" y))
+ ;; This may be incorrect when one is a ratnum consisting of bignums
+ (fp* (exact->inexact y) (exact->inexact x))) ; loc?
+ ((ratnum? x)
+ (if (ratnum? y)
+ ;; a/b * c/d = a*c / b*d [generic]
+ ;; = ((a / g1) * (c / g2)) / ((b / g2) * (d / g1))
+ ;; With g1 = gcd(a, d) and g2 = gcd(b, c) [Knuth, 4.5.1]
+ (let* ((a (%ratnum-numerator x)) (b (%ratnum-denominator x))
+ (c (%ratnum-numerator y)) (d (%ratnum-denominator y))
+ (g1 (##sys#integer-gcd a d))
+ (g2 (##sys#integer-gcd b c)))
+ (ratnum (##sys#*-2 (quotient a g1) (quotient c g2))
+ (##sys#*-2 (quotient b g2) (quotient d g1))))
+ (nonrat*rat y x)))
+ ((ratnum? y) (nonrat*rat x y))
+ (else (##sys#error-bad-number x '*))))
+
+(define (/ arg1 . args)
+ (if (null? args)
+ (##sys#/-2 1 arg1)
+ (let loop ((args (##sys#slot args 1))
+ (x (##sys#/-2 arg1 (##sys#slot args 0))))
+ (if (null? args)
+ x
+ (loop (##sys#slot args 1)
+ (##sys#/-2 x (##sys#slot args 0))) ) ) ) )
+
+(define (##sys#/-2 x y)
+ (when (eq? y 0)
+ (##sys#error-hook (foreign-value "C_DIVISION_BY_ZERO_ERROR" int) '/ x y))
+ (cond ((and (exact-integer? x) (exact-integer? y))
+ (let ((g (##sys#integer-gcd x y)))
+ (ratnum (##sys#integer-quotient x g) (##sys#integer-quotient y g))))
+ ;; Compnum *must* be checked first
+ ((or (cplxnum? x) (cplxnum? y))
+ (let* ((a (real-part x)) (b (imag-part x))
+ (c (real-part y)) (d (imag-part y))
+ (r (##sys#+-2 (##sys#*-2 c c) (##sys#*-2 d d)))
+ (x (##sys#/-2 (##sys#+-2 (##sys#*-2 a c) (##sys#*-2 b d)) r))
+ (y (##sys#/-2 (##sys#--2 (##sys#*-2 b c) (##sys#*-2 a d)) r)) )
+ (make-complex x y) ))
+ ((or (##core#inline "C_i_flonump" x) (##core#inline "C_i_flonump" y))
+ ;; This may be incorrect when one is a ratnum consisting of bignums
+ (fp/ (exact->inexact x) (exact->inexact y)))
+ ((ratnum? x)
+ (if (ratnum? y)
+ ;; a/b / c/d = a*d / b*c [generic]
+ ;; = ((a / g1) * (d / g2) * sign(a)) / abs((b / g2) * (c / g1))
+ ;; With g1 = gcd(a, c) and g2 = gcd(b, d) [Knuth, 4.5.1 ex. 4]
+ (let* ((a (%ratnum-numerator x)) (b (%ratnum-denominator x))
+ (c (%ratnum-numerator y)) (d (%ratnum-denominator y))
+ (g1 (##sys#integer-gcd a c))
+ (g2 (##sys#integer-gcd b d)))
+ (ratnum (##sys#*-2 (quotient a g1) (quotient d g2))
+ (##sys#*-2 (quotient b g2) (quotient c g1))))
+ ;; a/b / c/d = a*d / b*c [with d = 1]
+ ;; = ((a / g) * sign(a)) / abs(b * (c / g))
+ ;; With g = gcd(a, c) and c = y [Knuth, 4.5.1 ex. 4]
+ (let* ((a (%ratnum-numerator x))
+ (g (##sys#internal-gcd '/ a y))
+ (num (quotient a g))
+ (denom (##sys#*-2 (%ratnum-denominator x) (quotient y g))))
+ (if (##core#inline "C_i_flonump" denom)
+ (##sys#/-2 num denom)
+ (ratnum num denom)))))
+ ((ratnum? y)
+ ;; a/b / c/d = a*d / b*c [with b = 1]
+ ;; = ((a / g1) * d * sign(a)) / abs(c / g1)
+ ;; With g1 = gcd(a, c) and a = x [Knuth, 4.5.1 ex. 4]
+ (let* ((c (%ratnum-numerator y))
+ (g (##sys#internal-gcd '/ x c))
+ (num (##sys#*-2 (quotient x g) (%ratnum-denominator y)))
+ (denom (quotient c g)))
+ (if (##core#inline "C_i_flonump" denom)
+ (##sys#/-2 num denom)
+ (ratnum num denom))))
+ ((not (number? x)) (##sys#error-bad-number x '/))
+ (else (##sys#error-bad-number y '/))) )
+
(define (floor x)
(##sys#check-number x 'floor)
(if (##core#inline "C_fixnump" x)
@@ -1069,14 +1312,30 @@ EOF
x
(##core#inline_allocate ("C_a_i_flonum_round_proper" 4) x)))
-(define remainder
- (lambda (x y) (- x (* (quotient x y) y))) )
-
-(define (modulo a b) ; copied from chibi scheme without asking Alex
- (let ((res (- a (* (quotient a b) b))) ) ; remainder
- (if (< b 0)
- (if (<= res 0) res (+ res b))
- (if (>= res 0) res (+ res b)))))
+(define quotient (##core#primitive "C_basic_quotient"))
+(define ##sys#integer-quotient (##core#primitive "C_u_integer_quotient"))
+(define remainder (##core#primitive "C_basic_remainder"))
+(define ##sys#integer-remainder (##core#primitive "C_u_integer_remainder"))
+(define ##sys#integer-quotient&remainder (##core#primitive "C_u_integer_divrem"))
+
+(define quotient&remainder (##core#primitive "C_basic_divrem"))
+;; Modulo's sign follows y (whereas remainder's sign follows x)
+(define (quotient&modulo x y)
+ (receive (div rem) (quotient&remainder x y)
+ (if (positive? y)
+ (if (negative? rem)
+ (values div (##sys#+-2 rem y))
+ (values div rem))
+ (if (positive? rem)
+ (values div (##sys#+-2 rem y))
+ (values div rem)))))
+
+;; Modulo's sign follows y (whereas remainder's sign follows x)
+(define (modulo x y)
+ (let ((r (remainder x y)))
+ (if (positive? y)
+ (if (negative? r) (##sys#+-2 r y) r)
+ (if (positive? r) (##sys#+-2 r y) r))))
(define (even? n) (##core#inline "C_i_evenp" n))
(define (odd? n) (##core#inline "C_i_oddp" n))
@@ -1131,45 +1390,73 @@ EOF
(let ([n2 (car n2)])
(##core#inline_allocate ("C_a_i_atan2" 4) n1 n2) ) ) )
-(define ##sys#gcd
- (let ((remainder remainder))
- (lambda (x y)
- (let loop ((x x) (y y))
- (if (zero? y)
- (abs x)
- (loop y (remainder x y)) ) ) ) ) )
+(define (##sys#integer-power base e)
+ (define (square x) (##sys#*-2 x x))
+ (if (negative? e)
+ (##sys#/-2 1 (##sys#integer-power base (##sys#integer-negate e)))
+ (let lp ((res 1) (e2 e))
+ (cond
+ ((eq? e2 0) res)
+ ((even? e2) ; recursion is faster than iteration here
+ (##sys#*-2 res (square (lp 1 (arithmetic-shift e2 -1)))))
+ (else
+ (lp (##sys#*-2 res base) (##sys#--2 e2 1)))))))
+
+(define (##sys#integer-gcd a b)
+ ;; Currently this is only Euclidean GCD algorithm. TODO: Restore
+ ;; Lehmer's algorithm when everything else has been implemented.
+ (let* ((a (abs a)) (b (abs b)) ; Enforce loop invariant on input:
+ (swap? (##sys#<-2 a b))) ; both must be positive, and a >= b
+ (let lp ((a (if swap? b a))
+ (b (if swap? a b)))
+ (cond ((eq? b 0) a)
+ ((fixnum? a) (fxgcd a b)) ; b MUST be fixnum due to loop invariant
+ (else (lp b (##sys#integer-remainder a b)))))))
+
+;; Useful for sane error messages
+(define (##sys#internal-gcd loc a b)
+ (cond ((exact-integer? a)
+ (cond ((exact-integer? b) (##sys#integer-gcd a b))
+ ((and (##core#inline "C_i_flonump" b)
+ (##core#inline "C_u_i_fpintegerp" b))
+ (exact->inexact (##sys#integer-gcd a (inexact->exact b))))
+ (else (##sys#error-bad-integer b loc))))
+ ((and (##core#inline "C_i_flonump" a)
+ (##core#inline "C_u_i_fpintegerp" a))
+ (cond ((##core#inline "C_i_flonump" b)
+ (##core#inline_allocate ("C_a_i_flonum_gcd" 4) a b))
+ ((exact-integer? b)
+ (exact->inexact (##sys#integer-gcd (inexact->exact a) b)))
+ (else (##sys#error-bad-integer b loc))))
+ (else (##sys#error-bad-integer a loc))))
+;; For compat reasons, we define this
+(define (##sys#gcd a b) (##sys#internal-gcd 'gcd a b))
(define (gcd . ns)
(if (eq? ns '())
0
- (let loop ([ns ns] [f #t])
- (let ([head (##sys#slot ns 0)]
- [next (##sys#slot ns 1)] )
- (when f (##sys#check-integer head 'gcd))
- (if (null? next)
- (abs head)
- (let ([n2 (##sys#slot next 0)])
- (##sys#check-integer n2 'gcd)
- (loop (cons (##sys#gcd head n2) (##sys#slot next 1)) #f) ) ) ) ) ) )
+ (let loop ((head (##sys#slot ns 0))
+ (next (##sys#slot ns 1)))
+ (if (null? next)
+ (if (integer? head) (abs head) (##sys#error-bad-integer head 'gcd))
+ (let ((n2 (##sys#slot next 0)))
+ (loop (##sys#internal-gcd 'gcd head n2)
+ (##sys#slot next 1)) ) ) ) ) )
(define (##sys#lcm x y)
- (quotient (* x y) (##sys#gcd x y)) )
+ (quotient (* x y) (##sys#internal-gcd 'lcm x y)) )
(define (lcm . ns)
(if (null? ns)
1
- (let loop ([ns ns] [f #t])
- (let ([head (##sys#slot ns 0)]
- [next (##sys#slot ns 1)] )
- (when f (##sys#check-integer head 'lcm))
- (if (null? next)
- (abs head)
- (let ([n2 (##sys#slot next 0)])
- (##sys#check-integer n2 'lcm)
- (loop
- (cons
- (##sys#lcm head n2)
- (##sys#slot next 1)) #f) ) ) ) ) ) )
+ (let loop ((head (##sys#slot ns 0))
+ (next (##sys#slot ns 1)))
+ (if (null? next)
+ (if (integer? head) (abs head) (##sys#error-bad-integer head 'lcm))
+ (let ((n2 (##sys#slot next 0)))
+ (loop (quotient (##sys#*-2 head n2)
+ (##sys#internal-gcd 'lcm head n2))
+ (##sys#slot next 1)) ) ) ) ) )
(define ##sys#extended-number->string
(let ((string-append string-append))
@@ -1188,7 +1475,7 @@ EOF
;; The infinities and NaN always print their sign
(if (and (finite? i) (positive? i)) "+" "")
(number->string i base) "i") ))
- (else (##sys#error-bad-number 'number->string n))) ) ) )
+ (else (##sys#error-bad-number n 'number->string))) ) ) )
(define number->string (##core#primitive "C_number_to_string"))
(define ##sys#number->string number->string) ; for printer
diff --git a/manual/C interface b/manual/C interface
index 3dd8900a..2d8f2675 100644
--- a/manual/C interface
+++ b/manual/C interface
@@ -846,13 +846,25 @@ Is {{x}} an odd fixnum?
[C macro] C_word C_fixnum_times(C_word n1, C_word n2)
-Multiply fixnum n1 by fixnum n2.
+Multiply fixnum n1 by fixnum n2. Will not overflow into a bignum, but
+will handle overflows safely in the sense that it always produces a
+fixnum.
+
+===== C_a_i_fixnum_times
+
+ [C macro] C_word C_a_i_fixnum_times(C_word **ptr, C_word n, C_word x, C_word y)
+
+Calculate {{x}} * {{y}}, safely overflowing into a bignum, using the
+storage in {{ptr}} (which should be at least {{C_SIZEOF_BIGNUM(2)}}).
+
===== C_fixnum_plus
[C macro] C_word C_fixnum_plus(C_word n1, C_word n2)
-Add fixnum {{n1}} to fixnum {{n2}}.
+Add fixnum {{n1}} to fixnum {{n2}}. Will not overflow into a bignum,
+but will handle overflows safely in the sense that it always produces
+a fixnum.
===== C_u_fixnum_plus
@@ -860,11 +872,19 @@ Add fixnum {{n1}} to fixnum {{n2}}.
Like {{C_fixnum_plus}}, but unsafe (assumes no overflow/underflow).
+===== C_a_i_fixnum_plus
+
+ [C macro] C_word C_a_i_fixnum_plus(C_word **ptr, C_word n, C_word x, C_word y)
+
+Calculate {{x}} + {{y}}, safely overflowing into a bignum, using the
+storage in {{ptr}} (which should be at least {{C_SIZEOF_FIX_BIGNUM}}).
+
===== C_fixnum_difference
[C macro] C_word C_fixnum_difference(C_word n1, C_word n2)
-Calculate {{n1}} - {{n2}}.
+Calculate {{n1}} - {{n2}}. Will not overflow into a bignum, but will
+handle overflows safely in the sense that it always produces a fixnum.
===== C_u_fixnum_difference
@@ -872,6 +892,14 @@ Calculate {{n1}} - {{n2}}.
Like {{C_fixnum_difference}}, but unsafe (assumes no overflow/underflow).
+===== C_a_i_fixnum_difference
+
+ [C macro] C_word C_a_i_fixnum_difference(C_word **ptr, C_word n, C_word x, C_word y)
+
+Calculate {{x}} - {{y}}, safely overflowing into a bignum, using the
+storage in {{ptr}} (which should be at least {{C_SIZEOF_FIX_BIGNUM}}).
+
+
===== C_fixnum_divide
===== C_u_fixnum_divide
@@ -887,7 +915,25 @@ division). {{C_fixnum_divide}} signals an error if {{n2}} is zero.
[C macro] C_word C_fixnum_modulo(C_word n1, C_word n2)
[C macro] C_word C_u_fixnum_modulo(C_word n1, C_word n2)
-Calculate {{n1}} modulo {{n2}}. {{C_fixnum_modulo}} signals an error if {{n2}} is zero.
+Calculate {{n1}} modulo {{n2}}. {{C_fixnum_modulo}} signals an error if {{n2}} is zero. Neither handles overflow into bignums.
+
+===== C_a_i_fixnum_quotient_checked
+
+ [C macro] C_word C_a_i_fixnum_quotient_checked(C_word **ptr, C_word n, C_word x, C_word y)
+
+Calculate integer division of {{x}} / {{y}}, safely overflowing into a
+bignum (which can happen when dividing by {{C_MOST_NEGATIVE_FIXNUM}}),
+using the storage in {{ptr}} (which should be at least
+{{C_SIZEOF_FIX_BIGNUM}}). If {{y}} is zero, this will signal an
+error.
+
+===== C_i_fixnum_remainder_checked
+
+ [C macro] C_word C_i_fixnum_remainder_checked(C_word x, C_word y)
+
+Calculate the remainder of integer division {{x}} / {{y}}. If {{y}}
+is zero, this will signal an error.
+
===== C_fixnum_and
@@ -942,7 +988,17 @@ Shift the integral value of {{n1}} right by {{n2}}
[C macro] C_word C_fixnum_negate(C_word n)
-Negate {{n}}, i.e. return {{-n}}.
+Negate {{n}}, i.e. return {{-n}}. This will ''not'' overflow into a
+bignum.
+
+===== C_a_i_fixnum_negate
+
+ [C macro] C_word C_a_i_fixnum_negate(C_word **ptr, C_word n, C_word x)
+
+Negate {{n}}, i.e. return {{-n}}. This will not overflow into a
+bignum, using the storage pointed to by {{ptr}}, which should at least
+be {{C_SIZEOF_FIX_BIGNUM}}.
+
===== C_fixnum_greaterp
@@ -1018,16 +1074,22 @@ Returns the absolute value of {{n}}.
===== C_i_fixnum_min
- [C function] C_word C_fixnum_min(C_word n1, C_word n2)
+ [C function] C_word C_i_fixnum_min(C_word n1, C_word n2)
Returns the smallest of the two fixnums {{n1}} and {{n2}}.
===== C_i_fixnum_max
- [C function] C_word C_fixnum_max(C_word n1, C_word n2)
+ [C function] C_word C_i_fixnum_max(C_word n1, C_word n2)
Returns the largest of the two fixnums {{n1}} and {{n2}}.
+===== C_i_fixnum_gcd
+
+ [C function] C_word C_i_fixnum_gcd(C_word n1, C_word n2)
+
+Returns the greatest common divisor of the two fixnums {{n1}} and {{n2}}.
+
===== C_i_fixnum_length
[C function] C_word C_i_fixnum_length(C_word x)
@@ -1120,8 +1182,31 @@ Multiplies the flonum {{n1}} by the flonum {{n2}}, using the storage at
===== C_a_i_flonum_quotient
[C macro] C_word C_a_i_flonum_quotient(C_word **ptr, int c, C_word n1, C_word n2)
+ [C macro] C_word C_a_i_flonum_quotient_checked(C_word **ptr, int c, C_word n1, C_word n2)
+
+These are misnamed because they don't calculate the Scheme "quotient",
+but the simple result of flonum {{n1}} divided by the flonum {{n2}},
+using the storage at {{ptr}}. {{c}} should always be 2.
+
+{{C_a_i_flonum_checked}} will signal an error if {{n2}} is zero.
+
+===== C_a_i_flonum_actual_quotient_checked
+
+ [C macro] C_word C_a_i_flonum_actual_quotient_checked(C_word **ptr, int c, C_word n1, C_word n2)
+
+Due to the misnaming of {{C_a_i_flonum_quotient[_checked]}}, this
+function has a peculiar name. It calculates the Scheme integer
+quotient of {{n1}} divided by {{n2}}, using the storage at {{ptr}}.
+{{c}} should always be 2.
+
+If {{n2}} is zero or either of the numbers is not an integral flonum,
+an error will be signaled.
+
+===== C_a_i_flonum_gcd
+
+ [C macro] C_word C_a_i_flonum_gcd(C_word **ptr, int c, C_word n1, C_word n2)
-Calculates the quotient of the flonum {{n1}} divided by the flonum
+Calculates the greatest common divisor of the flonums {{n1}} and
{{n2}}, using the storage at {{ptr}}. {{c}} should always be 2.
===== C_a_i_flonum_negate
diff --git a/manual/Unit library b/manual/Unit library
index c0ab0042..45139149 100644
--- a/manual/Unit library
+++ b/manual/Unit library
@@ -82,6 +82,15 @@ number type supported by CHICKEN except complex numbers and non-finite
flonums, so you can use this predicate if you want to know the
representational type of a number.
+==== Division with quotient and remainder
+
+<procedure>(quotient&remainder X Y)</procedure>
+<procedure>(quotient&modulo X Y)</procedure>
+
+Returns two values: the quotient and the remainder (or modulo) of
+{{X}} divided by {{Y}}. Could be defined as {{(values (quotient X Y)
+(remainder X Y))}}, but is much more efficient when dividing very
+large numbers.
==== Arithmetic fixnum operations
@@ -90,6 +99,7 @@ representational type of a number.
<procedure>(fx* N1 N2)</procedure>
<procedure>(fx/ N1 N2)</procedure>
<procedure>(fxmod N1 N2)</procedure>
+<procedure>(fxrem N1 N2)</procedure>
<procedure>(fxneg N)</procedure>
<procedure>(fxmin N1 N2)</procedure>
<procedure>(fxmax N1 N2)</procedure>
@@ -99,13 +109,14 @@ representational type of a number.
<procedure>(fxnot N)</procedure>
<procedure>(fxshl N1 N2)</procedure>
<procedure>(fxshr N1 N2)</procedure>
+<procedure>(fxgcd N1 N2)</procedure>
{{fx+}} and friends are arithmetic fixnum operations. These procedures do not
check their arguments, so non-fixnum parameters will result in incorrect
results. {{fxneg}} negates its argument.
-On division by zero, {{fx/}} and {{fxmod}} signal a condition of kind
-{{(exn arithmetic)}}.
+On division by zero, {{fx/}}, {{fxmod}} and {{fxrem}} signal a
+condition of kind {{(exn arithmetic)}}.
{{fxshl}} and {{fxshr}} perform arithmetic shift left and right,
respectively.
@@ -143,6 +154,7 @@ Platform-specific fixnum limits.
<procedure>(fp- X Y)</procedure>
<procedure>(fp* X Y)</procedure>
<procedure>(fp/ X Y)</procedure>
+<procedure>(fpgcd X Y)</procedure>
<procedure>(fpneg X)</procedure>
<procedure>(fpmin X Y)</procedure>
<procedure>(fpmax X Y)</procedure>
diff --git a/manual/faq b/manual/faq
index 6fb485db..6994639b 100644
--- a/manual/faq
+++ b/manual/faq
@@ -592,6 +592,7 @@ The following extended bindings are handled specially:
{{fxneg}}
{{fxnot}}
{{fxodd?}}
+{{fxrem}}
{{fxshl}}
{{fxshr}}
{{fxxor}}
diff --git a/runtime.c b/runtime.c
index d9f004f0..0908c894 100644
--- a/runtime.c
+++ b/runtime.c
@@ -512,6 +512,20 @@ static WEAK_TABLE_ENTRY *C_fcall lookup_weak_table_entry(C_word item, C_word con
static C_ccall void values_continuation(C_word c, C_word closure, C_word dummy, ...) C_noret;
static C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stable);
static C_regparm int C_fcall C_in_new_heapp(C_word x);
+static void bignum_negate_2(C_word c, C_word self, C_word new_big);
+static void bignum_times_bignum_unsigned(C_word k, C_word x, C_word y, C_word negp) C_noret;
+static void bignum_times_bignum_unsigned_2(C_word c, C_word self, C_word result) C_noret;
+static void integer_times_2(C_word c, C_word self, C_word new_big) C_noret;
+static void bignum_plus_unsigned(C_word k, C_word x, C_word y, C_word negp) C_noret;
+static void bignum_plus_unsigned_2(C_word c, C_word self, C_word result) C_noret;
+static void bignum_minus_unsigned(C_word k, C_word x, C_word y) C_noret;
+static void bignum_minus_unsigned_2(C_word c, C_word self, C_word result) C_noret;
+static C_regparm void basic_divrem(C_word c, C_word self, C_word k, C_word x, C_word y, C_word return_r, C_word return_q) C_noret;
+static C_regparm void integer_divrem(C_word c, C_word self, C_word k, C_word x, C_word y, C_word return_q, C_word return_r) C_noret;
+static C_word bignum_remainder_unsigned_halfdigit(C_word num, C_word den);
+static C_regparm void bignum_divrem(C_word c, C_word self, C_word k, C_word x, C_word y, C_word return_q, C_word return_r) C_noret;
+static void divrem_intflo_2(C_word c, C_word self, ...) C_noret;
+static void bignum_divrem_fixnum_2(C_word c, C_word self, C_word negated_big) C_noret;
static C_word rat_cmp(C_word x, C_word y);
static void fabs_frexp_to_digits(C_uword exp, double sign, C_uword *start, C_uword *scan);
static C_word flo_to_tmp_bignum(C_word x);
@@ -546,6 +560,10 @@ static C_uword bignum_digits_destructive_scale_down(C_uword *start, C_uword *end
static C_uword bignum_digits_destructive_shift_right(C_uword *start, C_uword *end, int shift_right, int negp);
static C_uword bignum_digits_destructive_shift_left(C_uword *start, C_uword *end, int shift_left);
static C_regparm void bignum_digits_multiply(C_word x, C_word y, C_word result);
+static void bignum_divide_2_unsigned(C_word c, C_word self, C_word quotient);
+static void bignum_divide_2_unsigned_2(C_word c, C_word self, C_word remainder);
+static void bignum_destructive_divide_unsigned_small(C_word c, C_word self, C_word quotient);
+static C_regparm void bignum_destructive_divide_normalized(C_word big_u, C_word big_v, C_word big_q);
static void make_structure_2(void *dummy) C_noret;
static void generic_trampoline(void *dummy) C_noret;
static void handle_interrupt(void *trampoline, void *proc) C_noret;
@@ -818,7 +836,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
{
/* IMPORTANT: hardcoded table size -
this must match the number of C_pte calls + 1 (NULL terminator)! */
- C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 58);
+ C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 74);
int i = 0;
if(pt == NULL)
@@ -842,9 +860,13 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(C_set_dlopen_flags);
C_pte(C_become);
C_pte(C_apply_values);
+ /* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_pte(C_times);
+ /* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_pte(C_minus);
+ /* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_pte(C_plus);
+ /* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_pte(C_divide);
C_pte(C_nequalp);
C_pte(C_greaterp);
@@ -874,6 +896,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(C_peek_unsigned_integer);
C_pte(C_context_switch);
C_pte(C_register_finalizer);
+ /* IMPORTANT: have you read the comments at the start and the end of this function? */
C_pte(C_locative_ref);
C_pte(C_copy_closure);
C_pte(C_dump_heap_state);
@@ -882,6 +905,22 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(C_fixnum_to_string);
C_pte(C_integer_to_string);
C_pte(C_flonum_to_string);
+ C_pte(C_abs);
+ C_pte(C_u_integer_abs);
+ C_pte(C_negate);
+ C_pte(C_u_integer_negate);
+ C_pte(C_2_basic_plus);
+ C_pte(C_2_basic_minus);
+ C_pte(C_2_basic_times);
+ C_pte(C_basic_quotient);
+ C_pte(C_basic_remainder);
+ C_pte(C_basic_divrem);
+ C_pte(C_u_2_integer_plus);
+ C_pte(C_u_2_integer_minus);
+ C_pte(C_u_2_integer_times);
+ C_pte(C_u_integer_quotient);
+ C_pte(C_u_integer_remainder);
+ C_pte(C_u_integer_divrem);
/* IMPORTANT: did you remember the hardcoded pte table size? */
pt[ i ].id = NULL;
@@ -1839,7 +1878,7 @@ void barf(int code, char *loc, ...)
/* Never use extended number hook procedure names longer than this! */
-/* Current longest name: numbers#@bignum-2-divrem-burnikel-ziegler */
+/* Current longest name: ##sys#bignum-divrem-burnikel-ziegler */
#define MAX_EXTNUM_HOOK_NAME 64
/* This exists so that we don't have to create any extra closures */
@@ -2453,6 +2492,10 @@ void C_div_by_zero_error(char *loc)
barf(C_DIVISION_BY_ZERO_ERROR, loc);
}
+void C_not_an_integer_error(char *loc, C_word x)
+{
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, loc, x);
+}
/* Allocate and initialize record: */
@@ -5408,7 +5451,38 @@ C_regparm C_word C_fcall C_i_vector_set(C_word v, C_word i, C_word x)
return C_SCHEME_UNDEFINED;
}
+void C_ccall C_abs(C_word c, C_word self, C_word k, C_word x)
+{
+ if (c != 3) {
+ C_bad_argc_2(c, 3, self);
+ } else if (x & C_FIXNUM_BIT) {
+ C_word *a = C_alloc(C_SIZEOF_FIX_BIGNUM);
+ C_kontinue(k, C_a_i_fixnum_abs(&a, 1, x));
+ } else if (C_immediatep(x)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "abs", x);
+ } else if (C_block_header(x) == C_FLONUM_TAG) {
+ C_word *a = C_alloc(C_SIZEOF_FLONUM);
+ C_kontinue(k, C_a_i_flonum_abs(&a, 1, x));
+ } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ C_u_integer_abs(3, (C_word)NULL, k, x);
+ } else {
+ try_extended_number("\003sysextended-abs", 2, k, x);
+ }
+}
+
+void C_ccall C_u_integer_abs(C_word c, C_word self, C_word k, C_word x)
+{
+ if (x & C_FIXNUM_BIT) {
+ C_word *a = C_alloc(C_SIZEOF_FIX_BIGNUM);
+ C_kontinue(k, C_a_i_fixnum_abs(&a, 1, x));
+ } else if (C_bignum_negativep(x)) {
+ C_u_integer_negate(3, (C_word)NULL, k, x);
+ } else {
+ C_kontinue(k, x);
+ }
+}
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_regparm C_word C_fcall C_a_i_abs(C_word **a, int c, C_word x)
{
if(x & C_FIXNUM_BIT) return C_fix(labs(C_unfix(x)));
@@ -5419,6 +5493,56 @@ C_regparm C_word C_fcall C_a_i_abs(C_word **a, int c, C_word x)
return C_flonum(a, fabs(C_flonum_magnitude(x)));
}
+void C_ccall C_negate(C_word c, C_word self, C_word k, C_word x)
+{
+ if (x & C_FIXNUM_BIT) {
+ C_word *a = C_alloc(C_SIZEOF_FIX_BIGNUM);
+ C_kontinue(k, C_a_i_fixnum_negate(&a, 1, x));
+ } else if (C_immediatep(x)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);
+ } else if (C_block_header(x) == C_FLONUM_TAG) {
+ C_word *a = C_alloc(C_SIZEOF_FLONUM);
+ C_kontinue(k, C_a_i_flonum_negate(&a, 1, x));
+ } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ C_u_integer_negate(3, (C_word)NULL, k, x);
+ } else {
+ try_extended_number("\003sysextended-negate", 2, k, x);
+ }
+}
+
+void C_ccall C_u_integer_negate(C_word c, C_word self, C_word k, C_word x)
+{
+ if (x & C_FIXNUM_BIT) {
+ C_word *a = C_alloc(C_SIZEOF_FIX_BIGNUM);
+ C_kontinue(k, C_a_i_fixnum_negate(&a, 1, x));
+ } else {
+ if (C_bignum_negated_fitsinfixnump(x)) {
+ C_kontinue(k, C_fix(C_MOST_NEGATIVE_FIXNUM));
+ } else {
+ C_word *ka, k2, negp = C_mk_nbool(C_bignum_negativep(x)),
+ size = C_fix(C_bignum_size(x));
+ ka = C_alloc(C_SIZEOF_CLOSURE(3));
+ k2 = C_closure(&ka, 3, (C_word)bignum_negate_2, k, x);
+ C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
+ }
+ }
+}
+
+/* Copy all the digits from source to target, obliterating what was
+ * there. If target is larger than source, the most significant
+ * digits will remain untouched.
+ */
+C_inline void bignum_digits_destructive_copy(C_word target, C_word source)
+{
+ C_memcpy(C_bignum_digits(target), C_bignum_digits(source),
+ C_wordstobytes(C_bignum_size(source)));
+}
+
+static void bignum_negate_2(C_word c, C_word self, C_word new_big)
+{
+ bignum_digits_destructive_copy(new_big, C_block_item(self, 2) /* old_big */);
+ C_kontinue(C_block_item(self, 1), C_bignum_simplify(new_big));
+}
C_regparm C_word C_fcall C_a_i_bitwise_and(C_word **a, int c, C_word n1, C_word n2)
{
@@ -6526,6 +6650,151 @@ void C_ccall values_continuation(C_word c, C_word closure, C_word arg0, ...)
}
+void C_ccall
+C_2_basic_times(C_word c, C_word self, C_word k, C_word x, C_word y)
+{
+ if (x & C_FIXNUM_BIT) {
+ if (y & C_FIXNUM_BIT) {
+ C_word *a = C_alloc(C_SIZEOF_BIGNUM(2));
+ C_kontinue(k, C_a_i_fixnum_times(&a, 2, x, y));
+ } else if (C_immediatep(y)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);
+ } else if (C_block_header(y) == C_FLONUM_TAG) {
+ C_word *a = C_alloc(C_SIZEOF_FLONUM);
+ C_kontinue(k, C_flonum(&a, (double)C_unfix(x) * C_flonum_magnitude(y)));
+ } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ C_u_2_integer_times(4, (C_word)NULL, k, x, y);
+ } else {
+ try_extended_number("\003sysextended-times", 3, k, x, y);
+ }
+ } else if (C_immediatep(x)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);
+ } else if (C_block_header(x) == C_FLONUM_TAG) {
+ C_word *a = C_alloc(C_SIZEOF_FLONUM);
+ if (y & C_FIXNUM_BIT) {
+ C_kontinue(k, C_flonum(&a, C_flonum_magnitude(x) * (double)C_unfix(y)));
+ } else if (C_immediatep(y)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);
+ } else if (C_block_header(y) == C_FLONUM_TAG) {
+ C_kontinue(k, C_a_i_flonum_times(&a, 2, x, y));
+ } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ C_kontinue(k, C_flonum(&a, C_flonum_magnitude(x)*C_bignum_to_double(y)));
+ } else {
+ try_extended_number("\003sysextended-times", 3, k, x, y);
+ }
+ } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ if (y & C_FIXNUM_BIT) {
+ C_u_2_integer_times(4, (C_word)NULL, k, x, y);
+ } else if (C_immediatep(y)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);
+ } else if (C_block_header(y) == C_FLONUM_TAG) {
+ C_word *a = C_alloc(C_SIZEOF_FLONUM);
+ C_kontinue(k, C_flonum(&a, C_bignum_to_double(x)*C_flonum_magnitude(y)));
+ } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ C_u_2_integer_times(4, (C_word)NULL, k, x, y);
+ } else {
+ try_extended_number("\003sysextended-times", 3, k, x, y);
+ }
+ } else {
+ try_extended_number("\003sysextended-times", 3, k, x, y);
+ }
+}
+
+void C_ccall
+C_u_2_integer_times(C_word c, C_word self, C_word k, C_word x, C_word y)
+{
+ if (x & C_FIXNUM_BIT) {
+ if (y & C_FIXNUM_BIT) {
+ C_word *a = C_alloc(C_SIZEOF_BIGNUM(2));
+ C_kontinue(k, C_a_i_fixnum_times(&a, 2, x, y));
+ } else {
+ C_word tmp = x; /* swap to ensure x is a bignum and y a fixnum */
+ x = y;
+ y = tmp;
+ }
+ }
+ /* Here, we know for sure that X is a bignum */
+ if (y == C_fix(0)) {
+ C_kontinue(k, C_fix(0));
+ } else if (y == C_fix(1)) {
+ C_kontinue(k, x);
+ } else if (y == C_fix(-1)) {
+ C_u_integer_negate(3, (C_word)NULL, k, x);
+ } else if (y & C_FIXNUM_BIT) { /* Any other fixnum */
+ C_word absy = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y),
+ negp = C_mk_bool((y & C_INT_SIGN_BIT) ?
+ !C_bignum_negativep(x) :
+ C_bignum_negativep(x));
+
+ if (C_fitsinbignumhalfdigitp(absy) ||
+ (((C_uword)1 << (C_ilen(absy)-1)) == absy && C_fitsinfixnump(absy))) {
+ C_word size, k2, *a = C_alloc(C_SIZEOF_CLOSURE(4));
+ k2 = C_closure(&a, 4, (C_word)integer_times_2, k, x, C_fix(absy));
+ size = C_fix(C_bignum_size(x) + 1); /* Needs _at most_ one more digit */
+ C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
+ } else {
+ C_word *a = C_alloc(C_SIZEOF_FIX_BIGNUM);
+ y = C_a_u_i_fix_to_big(&a, y);
+ bignum_times_bignum_unsigned(k, x, y, negp);
+ }
+ } else {
+ C_word negp = C_bignum_negativep(x) ?
+ !C_bignum_negativep(y) :
+ C_bignum_negativep(y);
+ bignum_times_bignum_unsigned(k, x, y, C_mk_bool(negp));
+ }
+}
+
+static void integer_times_2(C_word c, C_word self, C_word new_big)
+{
+ C_word k = C_block_item(self, 1),
+ old_bigx = C_block_item(self, 2),
+ absy = C_unfix(C_block_item(self, 3));
+ C_uword *digits = C_bignum_digits(new_big),
+ *end_digit = digits + C_bignum_size(old_bigx);
+ int shift;
+
+ bignum_digits_destructive_copy(new_big, old_bigx);
+
+ /* Scale up, and sanitise the result. */
+ shift = C_ilen(absy) - 1;
+ if (((C_uword)1 << shift) == absy) { /* Power of two? */
+ *end_digit = bignum_digits_destructive_shift_left(digits, end_digit, shift);
+ } else {
+ *end_digit =
+ bignum_digits_destructive_scale_up_with_carry(digits, end_digit, absy, 0);
+ }
+ C_kontinue(k, C_bignum_simplify(new_big));
+}
+
+static void
+bignum_times_bignum_unsigned(C_word k, C_word x, C_word y, C_word negp)
+{
+ if (C_bignum_size(y) < C_bignum_size(x)) { /* Ensure size(x) <= size(y) */
+ C_word z = x;
+ x = y;
+ y = z;
+ }
+
+ /* TODO: Activate later */
+ /* if (C_bignum_size(x) < C_KARATSUBA_THRESHOLD) { /\* Gradebook *\/ */
+ C_word kab[C_SIZEOF_CLOSURE(4)], *ka = kab, k2, size;
+ k2 = C_closure(&ka, 4, (C_word)bignum_times_bignum_unsigned_2, k, x, y);
+ size = C_fix(C_bignum_size(x) + C_bignum_size(y));
+ C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_TRUE);
+ /* } else { */
+ /* try_extended_number("numbers#@bignum-2-times-karatsuba", 3, k, x, y); */
+ /* } */
+}
+
+static void bignum_times_bignum_unsigned_2(C_word c, C_word self, C_word result)
+{
+ bignum_digits_multiply(C_block_item(self, 2), C_block_item(self, 3), result);
+ C_kontinue(C_block_item(self, 1), C_bignum_simplify(result));
+}
+
+
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
void C_ccall C_times(C_word c, C_word closure, C_word k, ...)
{
va_list v;
@@ -6575,6 +6844,7 @@ void C_ccall C_times(C_word c, C_word closure, C_word k, ...)
}
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_regparm C_word C_fcall C_2_times(C_word **ptr, C_word x, C_word y)
{
C_word iresult;
@@ -6603,7 +6873,137 @@ C_regparm C_word C_fcall C_2_times(C_word **ptr, C_word x, C_word y)
return C_flonum(ptr, 0.0/0.0);
}
+static void bignum_plus_unsigned(C_word k, C_word x, C_word y, C_word negp)
+{
+ C_word kab[C_SIZEOF_CLOSURE(4)], *ka = kab, k2, size;
+
+ if (C_bignum_size(y) > C_bignum_size(x)) { /* Ensure size(y) <= size(x) */
+ C_word z = x;
+ x = y;
+ y = z;
+ }
+
+ k2 = C_closure(&ka, 4, (C_word)bignum_plus_unsigned_2, k, x, y);
+
+ size = C_fix(C_bignum_size(x) + 1); /* One more digit, for possible carry. */
+ C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
+}
+
+static void bignum_plus_unsigned_2(C_word c, C_word self, C_word result)
+{
+ C_word k = C_block_item(self, 1),
+ x = C_block_item(self, 2),
+ y = C_block_item(self, 3);
+ C_uword *scan_y = C_bignum_digits(y),
+ *end_y = scan_y + C_bignum_size(y),
+ *scan_r = C_bignum_digits(result),
+ *end_r = scan_r + C_bignum_size(result),
+ sum, digit;
+ int carry = 0;
+
+ /* Copy x into r so we can operate on two pointers, which is faster
+ * than three, and we can stop earlier after adding y. It's slower
+ * if x and y have equal length. On average it's slightly faster.
+ */
+ bignum_digits_destructive_copy(result, x);
+ *(end_r-1) = 0; /* Ensure most significant digit is initialised */
+
+ /* Move over x and y simultaneously, destructively adding digits w/ carry. */
+ while (scan_y < end_y) {
+ digit = *scan_r;
+ if (carry) {
+ sum = digit + *scan_y++ + 1;
+ carry = sum <= digit;
+ } else {
+ sum = digit + *scan_y++;
+ carry = sum < digit;
+ }
+ (*scan_r++) = sum;
+ }
+
+ /* The end of y, the smaller number. Propagate carry into the rest of x. */
+ while (carry) {
+ sum = (*scan_r) + 1;
+ carry = (sum == 0);
+ (*scan_r++) = sum;
+ }
+ assert(scan_r <= end_r);
+
+ C_kontinue(k, C_bignum_simplify(result));
+}
+void C_ccall
+C_2_basic_plus(C_word c, C_word self, C_word k, C_word x, C_word y)
+{
+ if (x & C_FIXNUM_BIT) {
+ if (y & C_FIXNUM_BIT) {
+ C_word *a = C_alloc(C_SIZEOF_FIX_BIGNUM);
+ C_kontinue(k, C_a_i_fixnum_plus(&a, 2, x, y));
+ } else if (C_immediatep(y)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);
+ } else if (C_block_header(y) == C_FLONUM_TAG) {
+ C_word *a = C_alloc(C_SIZEOF_FLONUM);
+ C_kontinue(k, C_flonum(&a, (double)C_unfix(x) + C_flonum_magnitude(y)));
+ } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ C_u_2_integer_plus(4, (C_word)NULL, k, x, y);
+ } else {
+ try_extended_number("\003sysextended-plus", 3, k, x, y);
+ }
+ } else if (C_immediatep(x)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", x);
+ } else if (C_block_header(x) == C_FLONUM_TAG) {
+ C_word *a = C_alloc(C_SIZEOF_FLONUM);
+ if (y & C_FIXNUM_BIT) {
+ C_kontinue(k, C_flonum(&a, C_flonum_magnitude(x) + (double)C_unfix(y)));
+ } else if (C_immediatep(y)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);
+ } else if (C_block_header(y) == C_FLONUM_TAG) {
+ C_kontinue(k, C_a_i_flonum_plus(&a, 2, x, y));
+ } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ C_kontinue(k, C_flonum(&a, C_flonum_magnitude(x)+C_bignum_to_double(y)));
+ } else {
+ try_extended_number("\003sysextended-plus", 3, k, x, y);
+ }
+ } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ if (y & C_FIXNUM_BIT) {
+ C_u_2_integer_plus(4, (C_word)NULL, k, x, y);
+ } else if (C_immediatep(y)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);
+ } else if (C_block_header(y) == C_FLONUM_TAG) {
+ C_word *a = C_alloc(C_SIZEOF_FLONUM);
+ C_kontinue(k, C_flonum(&a, C_bignum_to_double(x)+C_flonum_magnitude(y)));
+ } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ C_u_2_integer_plus(4, (C_word)NULL, k, x, y);
+ } else {
+ try_extended_number("\003sysextended-plus", 3, k, x, y);
+ }
+ } else {
+ try_extended_number("\003sysextended-plus", 3, k, x, y);
+ }
+}
+
+void C_ccall
+C_u_2_integer_plus(C_word c, C_word self, C_word k, C_word x, C_word y)
+{
+ if ((x & y) & C_FIXNUM_BIT) {
+ C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
+ C_kontinue(k, C_a_i_fixnum_plus(&a, 2, x, y));
+ } else {
+ C_word ab[C_SIZEOF_FIX_BIGNUM * 2], *a = ab;
+ if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);
+ if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);
+
+ if (C_bignum_negativep(x)) {
+ if (C_bignum_negativep(y)) bignum_plus_unsigned(k, x, y, C_SCHEME_TRUE);
+ else bignum_minus_unsigned(k, y, x);
+ } else {
+ if (C_bignum_negativep(y)) bignum_minus_unsigned(k, x, y);
+ else bignum_plus_unsigned(k, x, y, C_SCHEME_FALSE);
+ }
+ }
+}
+
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
void C_ccall C_plus(C_word c, C_word closure, C_word k, ...)
{
va_list v;
@@ -6653,6 +7053,7 @@ void C_ccall C_plus(C_word c, C_word closure, C_word k, ...)
}
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_regparm C_word C_fcall C_2_plus(C_word **ptr, C_word x, C_word y)
{
C_word iresult;
@@ -6681,7 +7082,140 @@ C_regparm C_word C_fcall C_2_plus(C_word **ptr, C_word x, C_word y)
return C_flonum(ptr, 0.0/0.0);
}
+static void bignum_minus_unsigned(C_word k, C_word x, C_word y)
+{
+ C_word kab[C_SIZEOF_CLOSURE(4)], *ka = kab, k2, size;
+
+ switch(bignum_cmp_unsigned(x, y)) {
+ case 0: /* x = y, return 0 */
+ C_kontinue(k, C_fix(0));
+ case -1: /* abs(x) < abs(y), return -(abs(y) - abs(x)) */
+ k2 = C_closure(&ka, 4, (C_word)bignum_minus_unsigned_2, k, y, x);
+
+ size = C_fix(C_bignum_size(y)); /* Maximum size of result is length of y. */
+ C_allocate_bignum(5, (C_word)NULL, k2, size, C_SCHEME_TRUE, C_SCHEME_FALSE);
+ case 1: /* abs(x) > abs(y), return abs(x) - abs(y) */
+ default:
+ k2 = C_closure(&ka, 4, (C_word)bignum_minus_unsigned_2, k, x, y);
+
+ size = C_fix(C_bignum_size(x)); /* Maximum size of result is length of x. */
+ C_allocate_bignum(5, (C_word)NULL, k2, size, C_SCHEME_FALSE, C_SCHEME_FALSE);
+ break;
+ }
+}
+
+static void bignum_minus_unsigned_2(C_word c, C_word self, C_word result)
+{
+ C_word k = C_block_item(self, 1),
+ x = C_block_item(self, 2),
+ y = C_block_item(self, 3);
+ C_uword *scan_r = C_bignum_digits(result),
+ *end_r = scan_r + C_bignum_size(result),
+ *scan_y = C_bignum_digits(y),
+ *end_y = scan_y + C_bignum_size(y),
+ difference, digit;
+ int borrow = 0;
+
+ bignum_digits_destructive_copy(result, x); /* See bignum_plus_unsigned_2 */
+
+ /* Destructively subtract y's digits w/ borrow from and back into r. */
+ while (scan_y < end_y) {
+ digit = *scan_r;
+ if (borrow) {
+ difference = digit - *scan_y++ - 1;
+ borrow = difference >= digit;
+ } else {
+ difference = digit - *scan_y++;
+ borrow = difference > digit;
+ }
+ (*scan_r++) = difference;
+ }
+
+ /* The end of y, the smaller number. Propagate borrow into the rest of x. */
+ while (borrow) {
+ digit = *scan_r;
+ difference = digit - borrow;
+ borrow = difference >= digit;
+ (*scan_r++) = difference;
+ }
+
+ assert(scan_r <= end_r);
+
+ C_kontinue(k, C_bignum_simplify(result));
+}
+
+void C_ccall
+C_2_basic_minus(C_word c, C_word self, C_word k, C_word x, C_word y)
+{
+ if (x & C_FIXNUM_BIT) {
+ if (y & C_FIXNUM_BIT) {
+ C_word *a = C_alloc(C_SIZEOF_FIX_BIGNUM);
+ C_kontinue(k, C_a_i_fixnum_difference(&a, 2, x, y));
+ } else if (C_immediatep(y)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);
+ } else if (C_block_header(y) == C_FLONUM_TAG) {
+ C_word *a = C_alloc(C_SIZEOF_FLONUM);
+ C_kontinue(k, C_flonum(&a, (double)C_unfix(x) - C_flonum_magnitude(y)));
+ } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ C_u_2_integer_minus(4, (C_word)NULL, k, x, y);
+ } else {
+ try_extended_number("\003sysextended-minus", 3, k, x, y);
+ }
+ } else if (C_immediatep(x)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);
+ } else if (C_block_header(x) == C_FLONUM_TAG) {
+ C_word *a = C_alloc(C_SIZEOF_FLONUM);
+ if (y & C_FIXNUM_BIT) {
+ C_kontinue(k, C_flonum(&a, C_flonum_magnitude(x) - (double)C_unfix(y)));
+ } else if (C_immediatep(y)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);
+ } else if (C_block_header(y) == C_FLONUM_TAG) {
+ C_kontinue(k, C_a_i_flonum_difference(&a, 2, x, y)); /* XXX NAMING! */
+ } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ C_kontinue(k, C_flonum(&a, C_flonum_magnitude(x)-C_bignum_to_double(y)));
+ } else {
+ try_extended_number("\003sysextended-minus", 3, k, x, y);
+ }
+ } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ if (y & C_FIXNUM_BIT) {
+ C_u_2_integer_minus(4, (C_word)NULL, k, x, y);
+ } else if (C_immediatep(y)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);
+ } else if (C_block_header(y) == C_FLONUM_TAG) {
+ C_word *a = C_alloc(C_SIZEOF_FLONUM);
+ C_kontinue(k, C_flonum(&a, C_bignum_to_double(x)-C_flonum_magnitude(y)));
+ } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ C_u_2_integer_minus(4, (C_word)NULL, k, x, y);
+ } else {
+ try_extended_number("\003sysextended-minus", 3, k, x, y);
+ }
+ } else {
+ try_extended_number("\003sysextended-minus", 3, k, x, y);
+ }
+}
+
+void C_ccall
+C_u_2_integer_minus(C_word c, C_word self, C_word k, C_word x, C_word y)
+{
+ if ((x & y) & C_FIXNUM_BIT) {
+ C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
+ C_kontinue(k, C_a_i_fixnum_difference(&a, 2, x, y));
+ } else {
+ C_word ab[C_SIZEOF_FIX_BIGNUM * 2], *a = ab;
+ if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);
+ if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);
+
+ if (C_bignum_negativep(x)) {
+ if (C_bignum_negativep(y)) bignum_minus_unsigned(k, y, x);
+ else bignum_plus_unsigned(k, x, y, C_SCHEME_TRUE);
+ } else {
+ if (C_bignum_negativep(y)) bignum_plus_unsigned(k, x, y, C_SCHEME_FALSE);
+ else bignum_minus_unsigned(k, x, y);
+ }
+ }
+}
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
void C_ccall C_minus(C_word c, C_word closure, C_word k, C_word n1, ...)
{
va_list v;
@@ -6748,6 +7282,7 @@ void C_ccall C_minus(C_word c, C_word closure, C_word k, C_word n1, ...)
}
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_regparm C_word C_fcall C_2_minus(C_word **ptr, C_word x, C_word y)
{
C_word iresult;
@@ -6778,6 +7313,7 @@ C_regparm C_word C_fcall C_2_minus(C_word **ptr, C_word x, C_word y)
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
void C_ccall C_divide(C_word c, C_word closure, C_word k, C_word n1, ...)
{
va_list v;
@@ -6871,6 +7407,321 @@ void C_ccall C_divide(C_word c, C_word closure, C_word k, C_word n1, ...)
}
+/* This is ugly but really cleans up the code below */
+#define RETURN_Q_AND_OR_R(calc_q, calc_r) \
+ if (C_truep(C_and(return_q, return_r))) { \
+ C_values(4, C_SCHEME_UNDEFINED, k, calc_q, calc_r); \
+ } else if (C_truep(return_r)) { \
+ C_kontinue(k, calc_r); \
+ } else { \
+ C_kontinue(k, calc_q); \
+ }
+
+/* Lossy; we could be in "quotient&remainder" or "modulo" */
+#define DIVREM_LOC ((C_truep(C_and(return_q, return_r))) ? "/" : \
+ (C_truep(return_q) ? "quotient" : "remainder"))
+
+/* Another huge and ugly dispatch function. This is the fundamental
+ * division function. It decides what functions to call depending on
+ * whether we want to see the quotient and/or the remainder. It only
+ * knows about the "basic" types: fixnums, bignums and flonums. The
+ * Scheme "##sys#/" procedure handles ratnums and cplxnums.
+ */
+static C_regparm void
+basic_divrem(C_word c, C_word self, C_word k, C_word x, C_word y, C_word return_q, C_word return_r)
+{
+ if (x & C_FIXNUM_BIT) {
+ if (y & C_FIXNUM_BIT) {
+ C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
+ if (y == C_fix(0)) C_div_by_zero_error(DIVREM_LOC);
+
+ RETURN_Q_AND_OR_R(C_a_i_fixnum_quotient_checked(&a, 2, x, y),
+ C_i_fixnum_remainder_checked(x, y));
+ } else if (C_immediatep(y)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, DIVREM_LOC, y);
+ } else if (C_block_header(y) == C_FLONUM_TAG) {
+ C_word ab[C_SIZEOF_FLONUM*3], *a = ab;
+ if (C_flonum_magnitude(y) == 0.0) C_div_by_zero_error(DIVREM_LOC);
+
+ x = C_a_i_fix_to_flo(&a, 1, x);
+ RETURN_Q_AND_OR_R(C_a_i_flonum_actual_quotient_checked(&a, 2, x, y),
+ C_a_i_flonum_remainder_checked(&a, 2, x, y));
+ } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ integer_divrem(6, (C_word)NULL, k, x, y, return_q, return_r);
+ } else {
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, DIVREM_LOC, y);
+ }
+ } else if (C_immediatep(x)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, DIVREM_LOC, x);
+ } else if (C_block_header(x) == C_FLONUM_TAG) {
+ if (!C_truep(C_u_i_fpintegerp(x))) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, DIVREM_LOC, x);
+ } else if (y & C_FIXNUM_BIT) {
+ C_word ab[C_SIZEOF_FLONUM*3], *a = ab;
+ if (y == C_fix(0)) C_div_by_zero_error(DIVREM_LOC);
+
+ y = C_a_i_fix_to_flo(&a, 1, y);
+ RETURN_Q_AND_OR_R(C_a_i_flonum_actual_quotient_checked(&a, 2, x, y),
+ C_a_i_flonum_remainder_checked(&a, 2, x, y));
+ } else if (C_immediatep(y)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, DIVREM_LOC, y);
+ } else if (C_block_header(y) == C_FLONUM_TAG) {
+ C_word ab[C_SIZEOF_FLONUM*3], *a = ab;
+ if (C_flonum_magnitude(y) == 0.0) C_div_by_zero_error(DIVREM_LOC);
+
+ RETURN_Q_AND_OR_R(C_a_i_flonum_actual_quotient_checked(&a, 2, x, y),
+ C_a_i_flonum_remainder_checked(&a, 2, x, y));
+ } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ C_word k2, ab[C_SIZEOF_CLOSURE(3)], *a = ab;
+ x = flo_to_tmp_bignum(x);
+ k2 = C_closure(&a, 3, (C_word)divrem_intflo_2, k, x);
+ integer_divrem(6, (C_word)NULL, k2, x, y, return_q, return_r);
+ } else {
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, DIVREM_LOC, y);
+ }
+ } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ if (y & C_FIXNUM_BIT) {
+ integer_divrem(6, (C_word)NULL, k, x, y, return_q, return_r);
+ } else if (C_immediatep(y)) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, DIVREM_LOC, y);
+ } else if (C_block_header(y) == C_FLONUM_TAG) {
+ if (!C_truep(C_u_i_fpintegerp(y))) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, DIVREM_LOC, y);
+ } else if (C_flonum_magnitude(y) == 0.0) {
+ C_div_by_zero_error(DIVREM_LOC);
+ } else {
+ C_word k2, ab[C_SIZEOF_CLOSURE(3)], *a = ab;
+ y = flo_to_tmp_bignum(y);
+ k2 = C_closure(&a, 3, (C_word)divrem_intflo_2, k, y);
+ integer_divrem(6, (C_word)NULL, k2, x, y, return_q, return_r);
+ }
+ } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ bignum_divrem(6, (C_word)NULL, k, x, y, return_q, return_r);
+ } else {
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, DIVREM_LOC, y);
+ }
+ } else {
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, DIVREM_LOC, x);
+ }
+}
+
+static void divrem_intflo_2(C_word c, C_word self, ...)
+{
+ C_word k = C_block_item(self, 1), x, y;
+ va_list v;
+
+ va_start(v, self);
+ if (c == 2) {
+ C_word ab[C_SIZEOF_FLONUM], *a = ab;
+ x = va_arg(v, C_word);
+ va_end(v);
+ if (x & C_FIXNUM_BIT) x = C_a_i_fix_to_flo(&a, 1, x);
+ else x = C_a_u_i_big_to_flo(&a, 1, x);
+ free_tmp_bignum(C_block_item(self, 2));
+ C_kontinue(k, x);
+ } else { /* c == 3 */
+ C_word ab[C_SIZEOF_FLONUM*2], *a = ab;
+ x = va_arg(v, C_word);
+ y = va_arg(v, C_word);
+ va_end(v);
+
+ if (x & C_FIXNUM_BIT) x = C_a_i_fix_to_flo(&a, 1, x);
+ else x = C_a_u_i_big_to_flo(&a, 1, x);
+ if (y & C_FIXNUM_BIT) y = C_a_i_fix_to_flo(&a, 1, y);
+ else y = C_a_u_i_big_to_flo(&a, 1, y);
+ free_tmp_bignum(C_block_item(self, 2));
+ C_values(4, C_SCHEME_UNDEFINED, k, x, y);
+ }
+}
+
+static void bignum_divrem_fixnum_2(C_word c, C_word self, C_word negated_big)
+{
+ C_word k = C_block_item(self, 1),
+ return_q = C_block_item(self, 2),
+ return_r = C_block_item(self, 3);
+ RETURN_Q_AND_OR_R(negated_big, C_fix(0));
+}
+
+static C_regparm void
+integer_divrem(C_word c, C_word self, C_word k, C_word x, C_word y, C_word return_q, C_word return_r)
+{
+ if (!(y & C_FIXNUM_BIT)) { /* y is bignum. */
+ if (x & C_FIXNUM_BIT) {
+ /* abs(x) < abs(y), so it will always be [0, x] except for this case: */
+ if (x == C_fix(C_MOST_NEGATIVE_FIXNUM) &&
+ C_bignum_negated_fitsinfixnump(y)) {
+ RETURN_Q_AND_OR_R(C_fix(-1), C_fix(0));
+ } else {
+ RETURN_Q_AND_OR_R(C_fix(0), x);
+ }
+ } else {
+ bignum_divrem(4, (C_word)NULL, k, x, y, return_q, return_r);
+ }
+ } else if (x & C_FIXNUM_BIT) { /* both x and y are fixnum. */
+ C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
+ if (y == C_fix(0)) C_div_by_zero_error(DIVREM_LOC);
+
+ RETURN_Q_AND_OR_R(C_a_i_fixnum_quotient_checked(&a, 2, x, y),
+ C_i_fixnum_remainder_checked(x, y));
+ } else { /* x is bignum, y is fixnum. */
+ C_word absy = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y);
+
+ if (y == C_fix(1)) {
+ RETURN_Q_AND_OR_R(x, C_fix(0));
+ } else if (y == C_fix(0)) {
+ C_div_by_zero_error(DIVREM_LOC);
+ } else if (y == C_fix(-1)) {
+ C_word *ka, k2;
+ ka = C_alloc(C_SIZEOF_CLOSURE(4));
+ k2 = C_closure(&ka, 4, (C_word)bignum_divrem_fixnum_2,
+ k, return_q, return_r);
+ C_u_integer_negate(3, (C_word)NULL, k2, x);
+ } else if (C_fitsinbignumhalfdigitp(absy) ||
+ ((((C_uword)1 << (C_ilen(absy)-1)) == absy) &&
+ C_fitsinfixnump(absy))) {
+ if (C_truep(return_q)) {
+ C_word q_negp = C_mk_bool((y & C_INT_SIGN_BIT) ?
+ !(C_bignum_negativep(x)) :
+ C_bignum_negativep(x)),
+ r_negp = C_mk_bool(C_bignum_negativep(x)),
+ *ka, k2, size;
+ ka = C_alloc(C_SIZEOF_CLOSURE(9));
+ size = C_fix(C_bignum_size(x));
+ k2 = C_closure(&ka, 7,
+ (C_word)bignum_destructive_divide_unsigned_small,
+ k, x, C_fix(absy),
+ return_q, return_r, C_SCHEME_FALSE);
+ C_allocate_bignum(5, (C_word)NULL, k2, size, q_negp, C_SCHEME_FALSE);
+ } else {
+ C_word rem;
+ C_uword next_power = (C_uword)1 << (C_ilen(absy)-1);
+
+ if (next_power == absy) { /* Is absy a power of two? */
+ rem = *(C_bignum_digits(x)) & (next_power - 1);
+ } else { /* Too bad, we have to do some real work */
+ rem = bignum_remainder_unsigned_halfdigit(x, absy);
+ }
+ C_kontinue(k, C_bignum_negativep(x) ? C_fix(-rem) : C_fix(rem));
+ }
+ } else { /* Just divide it as two bignums */
+ C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
+ bignum_divrem(6, (C_word)NULL, k, x, C_a_u_i_fix_to_big(&a, y),
+ return_q, return_r);
+ }
+ }
+}
+
+static C_regparm void
+bignum_divrem(C_word c, C_word self, C_word k, C_word x, C_word y, C_word return_q, C_word return_r)
+{
+ C_word q_negp = C_mk_bool(C_bignum_negativep(y) ?
+ !C_bignum_negativep(x) :
+ C_bignum_negativep(x)),
+ r_negp = C_mk_bool(C_bignum_negativep(x)), size;
+
+ switch(bignum_cmp_unsigned(x, y)) {
+ case 0:
+ RETURN_Q_AND_OR_R(C_truep(q_negp) ? C_fix(-1) : C_fix(1), C_fix(0));
+ case -1:
+ RETURN_Q_AND_OR_R(C_fix(0), x);
+ case 1:
+ default:
+ size = C_bignum_size(y);
+ /* TODO: Activate later */
+ /* if (size > C_BURNIKEL_ZIEGLER_THRESHOLD && */
+ /* /\* This avoids endless recursion for odd Ns just above threshold *\/ */
+ /* !(size & 1 && size < (C_BURNIKEL_ZIEGLER_THRESHOLD << 1))) { */
+ /* try_extended_number("\003sysbignum-divrem-burnikel-ziegler", 5, */
+ /* k, x, y, return_q, return_r); */
+ /* } else */ if (C_truep(return_q)) {
+ C_word kab[C_SIZEOF_FIX_BIGNUM+C_SIZEOF_CLOSURE(9)], *ka = kab, k2;
+ k2 = C_closure(&ka, 9, (C_word)bignum_divide_2_unsigned, k, x, y,
+ return_q, return_r, r_negp,
+ /* Will be filled in later */
+ C_SCHEME_UNDEFINED, C_SCHEME_UNDEFINED);
+ size = C_fix(C_bignum_size(x) + 1 - C_bignum_size(y));
+ C_allocate_bignum(5, (C_word)NULL, k2, size, q_negp, C_SCHEME_FALSE);
+ } else { /* We can skip bignum_divide_2_unsigned if we need no quotient */
+ C_word kab[C_SIZEOF_FIX_BIGNUM+C_SIZEOF_CLOSURE(9)], *ka = kab, k2;
+ k2 = C_closure(&ka, 9, (C_word)bignum_divide_2_unsigned_2, k, x, y,
+ return_q, return_r, r_negp,
+ /* Will be filled in later */
+ C_SCHEME_UNDEFINED, C_SCHEME_UNDEFINED);
+ size = C_fix(C_bignum_size(x) + 1); /* May need to be normalized */
+ C_allocate_bignum(5, (C_word)NULL, k2, size, r_negp, C_SCHEME_FALSE);
+ }
+ }
+}
+
+static C_word bignum_remainder_unsigned_halfdigit(C_word num, C_word den)
+{
+ C_uword *start = C_bignum_digits(num),
+ *scan = start + C_bignum_size(num),
+ rem = 0, two_digits;
+
+ assert((den > 1) && (C_fitsinbignumhalfdigitp(den)));
+ while (start < scan) {
+ two_digits = (*--scan);
+ rem = C_BIGNUM_DIGIT_COMBINE(rem, C_BIGNUM_DIGIT_HI_HALF(two_digits)) % den;
+ rem = C_BIGNUM_DIGIT_COMBINE(rem, C_BIGNUM_DIGIT_LO_HALF(two_digits)) % den;
+ }
+ return rem;
+}
+
+/* External interface for the above internal divrem functions */
+void C_ccall
+C_basic_divrem(C_word c, C_word self, C_word k, C_word x, C_word y)
+{
+ if (c != 4) C_bad_argc_2(c, 4, self);
+ basic_divrem(6, (C_word)NULL, k, x, y, C_SCHEME_TRUE, C_SCHEME_TRUE);
+}
+
+void C_ccall
+C_u_integer_divrem(C_word c, C_word self, C_word k, C_word x, C_word y)
+{
+ integer_divrem(6, (C_word)NULL, k, x, y, C_SCHEME_TRUE, C_SCHEME_TRUE);
+}
+
+void C_ccall
+C_basic_remainder(C_word c, C_word self, C_word k, C_word x, C_word y)
+{
+ if (c != 4) C_bad_argc_2(c, 4, self);
+ basic_divrem(6, (C_word)NULL, k, x, y, C_SCHEME_FALSE, C_SCHEME_TRUE);
+}
+
+void C_ccall
+C_u_integer_remainder(C_word c, C_word self, C_word k, C_word x, C_word y)
+{
+ integer_divrem(6, (C_word)NULL, k, x, y, C_SCHEME_FALSE, C_SCHEME_TRUE);
+}
+
+void C_ccall
+C_basic_quotient(C_word c, C_word self, C_word k, C_word x, C_word y)
+{
+ if (c != 4) C_bad_argc_2(c, 4, self);
+ basic_divrem(6, (C_word)NULL, k, x, y, C_SCHEME_TRUE, C_SCHEME_FALSE);
+}
+
+void C_ccall
+C_u_integer_quotient(C_word c, C_word self, C_word k, C_word x, C_word y)
+{
+ integer_divrem(6, (C_word)NULL, k, x, y, C_SCHEME_TRUE, C_SCHEME_FALSE);
+}
+
+
+static void bignum_divide_2_unsigned(C_word c, C_word self, C_word quotient)
+{
+ C_word numerator = C_block_item(self, 2),
+ remainder_negp = C_block_item(self, 6),
+ size = C_fix(C_bignum_size(numerator) + 1);
+
+ /* Nice: We can recycle the current closure */
+ C_set_block_item(self, 0, (C_word)bignum_divide_2_unsigned_2);
+ C_set_block_item(self, 7, quotient);
+ C_allocate_bignum(5, (C_word)NULL, self, size, remainder_negp, C_SCHEME_FALSE);
+}
+
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_regparm C_word C_fcall C_2_divide(C_word **ptr, C_word x, C_word y)
{
C_word iresult;
@@ -6984,6 +7835,19 @@ static C_word rat_cmp(C_word x, C_word y)
return result;
}
+C_regparm double C_fcall C_bignum_to_double(C_word bignum)
+{
+ double accumulator = 0;
+ C_uword *start = C_bignum_digits(bignum),
+ *scan = start + C_bignum_size(bignum);
+ while (start < scan) {
+ accumulator *= (C_word)1 << C_BIGNUM_HALF_DIGIT_LENGTH;
+ accumulator *= (C_word)1 << C_BIGNUM_HALF_DIGIT_LENGTH;
+ accumulator += (*--scan);
+ }
+ return(C_bignum_negativep(bignum) ? -accumulator : accumulator);
+}
+
static void
fabs_frexp_to_digits(C_uword exp, double sign, C_uword *start, C_uword *scan)
{
@@ -7879,16 +8743,6 @@ C_regparm C_word C_fcall C_bignum_simplify(C_word big)
}
}
-/* Copy all the digits from source to target, obliterating what was
- * there. If target is larger than source, the most significant
- * digits will remain untouched.
- */
-C_inline void bignum_digits_destructive_copy(C_word target, C_word source)
-{
- C_memcpy(C_bignum_digits(target), C_bignum_digits(source),
- C_wordstobytes(C_bignum_size(source)));
-}
-
static C_uword
bignum_digits_destructive_scale_up_with_carry(C_uword *start, C_uword *end, C_uword factor, C_uword carry)
{
@@ -7996,6 +8850,188 @@ bignum_digits_multiply(C_word x, C_word y, C_word result)
}
}
+/* For help understanding this algorithm, see:
+ Knuth, Donald E., "The Art of Computer Programming",
+ volume 2, "Seminumerical Algorithms"
+ section 4.3.1, "Multiple-Precision Arithmetic".
+
+ [Yeah, that's a nice book but that particular section is not
+ helpful at all, which is also pointed out by P. Brinch Hansen's
+ "Multiple-Length Division Revisited: A Tour Of The Minefield".
+ That's a more down-to-earth step-by-step explanation of the
+ algorithm. Add to this the C implementation in Hacker's Delight
+ (section 9-2, p141--142) and you may be able to grok this...
+ ...barely, if you're as math-challenged as I am -- sjamaan]
+*/
+
+static void bignum_divide_2_unsigned_2(C_word c, C_word self, C_word remainder)
+{
+ C_word k = C_block_item(self, 1),
+ numerator = C_block_item(self, 2),
+ denominator = C_block_item(self, 3),
+ return_quotient = C_block_item(self, 4),
+ return_remainder = C_block_item(self, 5),
+ /* This one may be overwritten with the remainder */
+ /* remainder_negp = C_block_item(self, 6), */
+ quotient = C_block_item(self, 7),
+ length = C_bignum_size(denominator);
+ C_uword d1 = *(C_bignum_digits(denominator) + length - 1),
+ *startr = C_bignum_digits(remainder),
+ *endr = startr + C_bignum_size(remainder);
+ int shift;
+
+ shift = C_BIGNUM_DIGIT_LENGTH - C_ilen(d1); /* nlz */
+
+ /* We have to work on halfdigits, so we shift out only the necessary
+ * amount in order fill out that halfdigit (base is halved).
+ * This trick is shamelessly stolen from Gauche :)
+ * See below for part 2 of the trick.
+ */
+ if (shift >= C_BIGNUM_HALF_DIGIT_LENGTH)
+ shift -= C_BIGNUM_HALF_DIGIT_LENGTH;
+
+ /* Code below won't always set high halfdigit of quotient, so do it here. */
+ if (quotient != C_SCHEME_UNDEFINED)
+ C_bignum_digits(quotient)[C_bignum_size(quotient)-1] = 0;
+
+ bignum_digits_destructive_copy(remainder, numerator);
+ *(endr-1) = 0; /* Ensure most significant digit is initialised */
+ if (shift == 0) { /* Already normalized */
+ bignum_destructive_divide_normalized(remainder, denominator, quotient);
+ } else { /* Requires normalisation; allocate scratch denominator for this */
+ C_uword *startnd;
+ C_word ndenom;
+
+ bignum_digits_destructive_shift_left(startr, endr, shift);
+
+ ndenom = allocate_tmp_bignum(C_fix(length), C_SCHEME_FALSE, C_SCHEME_FALSE);
+ startnd = C_bignum_digits(ndenom);
+ bignum_digits_destructive_copy(ndenom, denominator);
+ bignum_digits_destructive_shift_left(startnd, startnd+length, shift);
+
+ bignum_destructive_divide_normalized(remainder, ndenom, quotient);
+ if (C_truep(return_remainder)) /* Otherwise, don't bother shifting back */
+ bignum_digits_destructive_shift_right(startr, endr, shift, 0);
+
+ free_tmp_bignum(ndenom);
+ }
+
+ if (C_truep(return_remainder)) {
+ if (C_truep(return_quotient)) {
+ C_values(4, C_SCHEME_UNDEFINED, k,
+ C_bignum_simplify(quotient), C_bignum_simplify(remainder));
+ } else {
+ C_kontinue(k, C_bignum_simplify(remainder));
+ }
+ } else {
+ assert(C_truep(return_quotient));
+ C_kontinue(k, C_bignum_simplify(quotient));
+ }
+}
+
+/* "small" is either a number that fits a halfdigit, or a power of two */
+static void
+bignum_destructive_divide_unsigned_small(C_word c, C_word self, C_word quotient)
+{
+ C_word k = C_block_item(self, 1),
+ numerator = C_block_item(self, 2),
+ denominator = C_unfix(C_block_item(self, 3)),
+ /* return_quotient = C_block_item(self, 4), */
+ return_remainder = C_block_item(self, 5),
+ remainder_negp = C_block_item(self, 6);
+ C_uword *start = C_bignum_digits(quotient),
+ *end = start + C_bignum_size(quotient),
+ remainder;
+ int shift_amount;
+
+ bignum_digits_destructive_copy(quotient, numerator);
+
+ shift_amount = C_ilen(denominator)-1;
+ if (((C_uword)1 << shift_amount) == denominator) { /* Power of two? Shift! */
+ remainder = bignum_digits_destructive_shift_right(start,end,shift_amount,0);
+ assert(C_ufitsinfixnump(remainder));
+ } else {
+ remainder = bignum_digits_destructive_scale_down(start, end, denominator);
+ assert(C_fitsinbignumhalfdigitp(remainder));
+ }
+
+ quotient = C_bignum_simplify(quotient);
+
+ if (C_truep(return_remainder)) {
+ remainder = C_truep(remainder_negp) ? -remainder : remainder;
+ C_values(4, C_SCHEME_UNDEFINED, k, quotient, C_fix(remainder));
+ } else {
+ C_kontinue(k, quotient);
+ }
+}
+
+static C_regparm void
+bignum_destructive_divide_normalized(C_word big_u, C_word big_v, C_word big_q)
+{
+ C_uword *v = C_bignum_digits(big_v),
+ *u = C_bignum_digits(big_u),
+ *q = big_q == C_SCHEME_UNDEFINED ? NULL : C_bignum_digits(big_q),
+ p, /* product of estimated quotient & "denominator" */
+ hat, qhat, rhat, /* estimated quotient and remainder digit */
+ vn_1, vn_2; /* "cached" values v[n-1], v[n-2] */
+ C_word t, k; /* Two helpers: temp/final remainder and "borrow" */
+ /* We use plain ints here, which theoretically may not be enough on
+ * 64-bit for an insanely huge number, but it is a _lot_ faster.
+ */
+ int n = C_bignum_size(big_v) * 2, /* in halfwords */
+ m = (C_bignum_size(big_u) * 2) - 2; /* Correct for extra digit */
+ int i, j; /* loop vars */
+
+ /* Part 2 of Gauche's aforementioned trick: */
+ if (C_uhword_ref(v, n-1) == 0) n--;
+
+ /* These won't change during the loop, but are used in every step. */
+ vn_1 = C_uhword_ref(v, n-1);
+ vn_2 = C_uhword_ref(v, n-2);
+
+ /* See also Hacker's Delight, Figure 9-1. This is almost exactly that. */
+ for (j = m - n; j >= 0; j--) {
+ hat = C_BIGNUM_DIGIT_COMBINE(C_uhword_ref(u, j+n), C_uhword_ref(u, j+n-1));
+ if (hat == 0) {
+ if (q != NULL) C_uhword_set(q, j, 0);
+ continue;
+ }
+ qhat = hat / vn_1;
+ rhat = hat % vn_1;
+
+ /* Two whiles is faster than one big check with an OR. Thanks, Gauche! */
+ while(qhat >= (1L << C_BIGNUM_HALF_DIGIT_LENGTH)) { qhat--; rhat += vn_1; }
+ while(qhat * vn_2 > C_BIGNUM_DIGIT_COMBINE(rhat, C_uhword_ref(u, j+n-2))
+ && rhat < (1L << C_BIGNUM_HALF_DIGIT_LENGTH)) {
+ qhat--;
+ rhat += vn_1;
+ }
+
+ /* Multiply and subtract */
+ k = 0;
+ for (i = 0; i < n; i++) {
+ p = qhat * C_uhword_ref(v, i);
+ t = C_uhword_ref(u, i+j) - k - C_BIGNUM_DIGIT_LO_HALF(p);
+ C_uhword_set(u, i+j, t);
+ k = C_BIGNUM_DIGIT_HI_HALF(p) - (t >> C_BIGNUM_HALF_DIGIT_LENGTH);
+ }
+ t = C_uhword_ref(u,j+n) - k;
+ C_uhword_set(u, j+n, t);
+
+ if (t < 0) { /* Subtracted too much? */
+ qhat--;
+ k = 0;
+ for (i = 0; i < n; i++) {
+ t = (C_uword)C_uhword_ref(u, i+j) + C_uhword_ref(v, i) + k;
+ C_uhword_set(u, i+j, t);
+ k = t >> C_BIGNUM_HALF_DIGIT_LENGTH;
+ }
+ C_uhword_set(u, j+n, (C_uhword_ref(u, j+n) + k));
+ }
+ if (q != NULL) C_uhword_set(q, j, qhat);
+ } /* end j */
+}
+
void C_ccall C_string_to_symbol(C_word c, C_word closure, C_word k, C_word string)
{
@@ -8057,7 +9093,32 @@ C_regparm C_word C_fcall C_a_i_flonum_round_proper(C_word **ptr, int c, C_word n
return C_flonum(ptr, r);
}
+C_regparm C_word C_fcall
+C_a_i_flonum_gcd(C_word **p, C_word n, C_word x, C_word y)
+{
+ double xub, yub, r;
+
+ if (!C_truep(C_u_i_fpintegerp(x)))
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "gcd", x);
+ if (!C_truep(C_u_i_fpintegerp(y)))
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "gcd", y);
+
+ xub = C_flonum_magnitude(x);
+ yub = C_flonum_magnitude(y);
+
+ if (xub < 0.0) xub = -xub;
+ if (yub < 0.0) yub = -yub;
+
+ while(yub != 0.0) {
+ r = fmod(xub, yub);
+ xub = yub;
+ yub = r;
+ }
+ return C_flonum(p, xub);
+}
+
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
void C_ccall C_quotient(C_word c, C_word closure, C_word k, C_word n1, C_word n2)
{
double f1, f2, r;
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index 496a6972..523cc163 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -66,12 +66,13 @@
(assert (inexact? 1.1))
(assert-fail (inexact? 'foo))
+;; Division by inexact zero used to fail, but now it returns +inf.0
(assert-fail (/ 1 1 0))
-(assert-fail (/ 1 1 0.0))
-(assert-fail (/ 1 0.0))
+(assert (eqv? +inf.0 (/ 1 1 0.0)))
+(assert (eqv? +inf.0 (/ 1 0.0)))
(assert-fail (/ 1 0))
(assert-fail (/ 0))
-(assert-fail (/ 0.0))
+(assert (eqv? +inf.0 (/ 0.0)))
(assert (fixnum? (/ 1)))
diff --git a/tests/numbers-string-conversion-tests.scm b/tests/numbers-string-conversion-tests.scm
index 885a1d20..5d38c239 100644
--- a/tests/numbers-string-conversion-tests.scm
+++ b/tests/numbers-string-conversion-tests.scm
@@ -12,83 +12,76 @@
;;; It also doesn't try to support Schemes which support *only* integers or
;;; *only* flonums (which is also allowed by R5RS).
;;;
-(use ports)
-(define the-nan (fp/ 0.0 0.0))
-(define pos-inf (fp/ 1.0 0.0))
-(define neg-inf (fp/ -1.0 0.0))
-(define neg-zero (/ -1.0 +inf.0))
+;;;
+;; The prelude below is messy but required to get everything working
+;; with some of the major Schemes.
+;;
+;; Also note that to test with Gambit, it appears you first need to type in
+;; (load "~~/lib/syntax-case") and then load this file, or use gsi's -:s switch
+;;;
+
+(use extras) ; Chicken w/ numbers
+;(use-syntax (ice-9 syncase)) ; Guile
+
+;; Set this to #f if the Scheme has no compnums at all, 'inexact if it only
+;; supports inexact compnums or 'exact if it supports exact compnums.
+;; (Gauche, Guile, SCM: inexact, Chicken w/o numbers: #f)
+(define compnum-type 'exact)
-(define (any pred lst)
- (let loop ((lst lst))
- (cond ((null? lst) #f)
- ((pred (car lst)))
- (else (loop (cdr lst))))))
+;; Set this to #f if the Scheme has no fractional number support,
+;; 'exact if it supports rational numbers and 'inexact if it converts fractions
+;; to floating-point, inexact numbers
+(define fraction-type 'exact)
-(define (nan? x) (and (number? x) (not (= x x))))
+;; Fix these if your Scheme doesn't allow division by zero
+(define the-nan (/ 0.0 0.0))
+(define pos-inf (/ 1.0 0.0))
+(define neg-inf (/ -1.0 0.0))
+
+; Scheme48, Racket, Gambit, SCM
+;(define (nan? x) (and (number? x) (not (= x x))))
(define total-errors 0)
(define (check-string-against-values! str . possible-values)
- (define (none? pred) (not (any pred possible-values)))
(let ((res (string->number str)))
- (cond
- ((none? (lambda (value)
- (or (and (not (string? value)) (equal? res value))
- (and res (nan? res) (or (and value (nan? value)))))))
- (display "PARSE ERROR ")
- (write (cons str possible-values))
- (display " => ") (write res) (newline)
- (set! total-errors (+ total-errors 1)))
- ((let ((re-str (and res (number->string res))))
- (and (none? (lambda (value)
- (or (and res (string=? re-str str))
- (and (not res) (not value))
- (and res (string? value) (string=? re-str value)))))
- re-str))
- => (lambda (re-str)
- (display "SERIALIZATION ERROR ")
- (write (cons str possible-values))
- (display " => ") (write re-str) (newline)
- (set! total-errors (+ total-errors 1))))
- ((handle-exceptions exn
- (and res exn)
- (let ((re-read (with-input-from-string str read)))
- (and (not (symbol? re-read))
- (not (eof-object? re-read))
- (or (not res)
- (and (not (and (nan? res) (nan? re-read)))
- (not (equal? res re-read))))
- re-read)))
- => (lambda (obj)
- (display (if (condition? obj)
- "READBACK EXN ERROR "
- "READBACK ERROR "))
- (write (cons str possible-values))
- (display " => ")
- (if (condition? obj)
- (write ((condition-property-accessor 'exn 'message #f) obj))
- (write obj))
- (newline)
- (set! total-errors (+ total-errors 1))))
- ((let ((written&read (with-input-from-string (with-output-to-string
- (lambda () (write res)))
- read)))
- (and (not (or (and (nan? res) (nan? written&read))
- (equal? res written&read)))
- written&read))
- => (lambda (read-back)
- (display "R/W VARIANCE ERROR ")
- (write (cons str possible-values))
- (display " => ")
- (write read-back) (newline)
- (set! total-errors (+ total-errors 1))))
- (else (display "OK ")
- (write (cons str possible-values))
- (newline)))))
+ (let lp ((values possible-values))
+ (if (null? values)
+ (begin (display "PARSE ERROR ")
+ (write (cons str possible-values))
+ (display " => ") (write res) (newline)
+ (set! total-errors (+ total-errors 1)))
+ (let ((value (car values)))
+ (if (not (or (and (not (string? value)) (equal? res value))
+ (and res (nan? res) (or (and value (nan? value))))))
+ (lp (cdr values))
+ (let ((re-str (and res (number->string res))))
+ (let lp2 ((values possible-values))
+ (if (null? values)
+ (begin (display "SERIALIZATION ERROR ")
+ (write (cons str possible-values))
+ (display " => ") (write re-str) (newline)
+ (set! total-errors (+ total-errors 1)))
+ (let ((value (car values)))
+ (if (not (or (and res (string=? re-str str))
+ (and (not res) (not value))
+ (and res (string? value) (string=? re-str value))))
+ (lp2 (cdr values))
+ (begin (display "OK ")
+ (write (cons str possible-values))
+ (newline)))))))))))))
(define-syntax test-numbers
- (syntax-rules ()
+ (syntax-rules (compnums fractions)
+ ((_ (compnums (types e1 ...) ...) rest ...)
+ (begin
+ (case compnum-type (types (test-numbers e1 ... "no-totals")) ...)
+ (test-numbers rest ...)))
+ ((_ (fractions (types e1 ...) ...) rest ...)
+ (begin
+ (case fraction-type (types (test-numbers e1 ... "no-totals")) ...)
+ (test-numbers rest ...)))
((_ (str value ...) rest ...)
(begin
(check-string-against-values! str value ...)
@@ -108,7 +101,7 @@
(display "-----> TOTAL ERRORS: ")
(display total-errors)
(newline)
- (error total-errors))))))
+ (exit 1))))))
(test-numbers
"Simple integers"
@@ -118,7 +111,7 @@
("#i1" 1.0 "1.0" "1.")
("#I1" 1.0 "1.0" "1.")
("#i-1" (- 1.0) "-1.0" "-1.")
- ("123\x00456" #f)
+ ("123\x00456" #f)
("-#i1" #f)
("+-1" #f)
("" #f)
@@ -178,7 +171,7 @@
("1#e2" 1000.0 1500.0 "1000.0" "1500.0" "1000." "1500." "1.0e3" "15.0e2")
("1e2#" #f)
- "NaN, Inf, negative zero"
+ "NaN, Inf"
("+nan.0" the-nan "+NaN.0")
("+NAN.0" the-nan "+nan.0" "+NaN.0")
("+nan.1" #f)
@@ -193,6 +186,11 @@
("-inf.1" #f)
("+inf.0/1" #f)
("1/+inf.0" #f)
+ ("+nan" #f)
+ ("+inf" #f)
+ ("-inf" #f)
+ ("nan.0" #f)
+ ("inf.0" #f)
;; Thanks to John Cowan for these
("#e+nan.0" #f)
("#e+inf.0" #f)
@@ -200,48 +198,85 @@
("#i+nan.0" the-nan "+nan.0" "+NaN.0")
("#i+inf.0" pos-inf "+inf.0" "+Inf.0")
("#i-inf.0" neg-inf "-inf.0" "-Inf.0")
- ("-0.0" neg-zero "-.0" "-0.")
- ;; These used to be accepted but are invalid
- ("+nan" #f)
- ("+inf" #f)
- ("-inf" #f)
- ("nan.0" #f)
- ("inf.0" #f)
"Fractions"
- ("1/2" (/ 1 2) "0.5" ".5" "500.0e-3")
- ("#e1/2" #f)
- ("10/2" 5.0 "5.0" "5.")
- ("#i10/2" 5.0 "5.0" "5.")
- ("-1/2" (- (/ 1 2)) "-0.5" "-.5" "-500.0e-3")
- ("1/-2" #f)
- ("10/0" +inf.0 "+inf.0")
- ("0/10" 0.0 "0.0" "0.")
- ("#e0/10" 0 "0")
- ("#e1#/2" 5 "5")
- ("#e1/2#" #f)
- ("1.0/2" #f)
- ("1/2.0" #f)
- ("1/2e2" #f)
- ("1/2e2" #f)
- ("1#/2" 5.0 7.5 "5.0" "5." "7.5")
- ("1/2#" 0.05 "0.05" ".05" "50.0e-3" "5.e-002")
- ("#i3/2" (/ 3.0 2.0) "1.5")
- ("1#/#" #f)
- ("1/" #f)
- ("1/+" #f)
- ("+/1" #f)
- ("/1" #f)
- ("/" #f)
- ("#i1/0" pos-inf "+inf.0" "+Inf.0")
- ("#i-1/0" neg-inf "-inf.0" "-Inf.0")
- ("#i0/0" the-nan "+nan.0" "+NaN.0")
- ;; This _could_ be valid (but isn't as pretty)
- ;("#i1/0" #f)
- ;("#i-1/0" #f)
- ;("#i0/0" #f)
+ (fractions
+ ((exact)
+ ("1/2" (/ 1 2))
+ ("#e1/2" (/ 1 2) "1/2")
+ ("10/2" 5 "5")
+ ("-1/2" (- (/ 1 2)))
+ ("10/0" #f)
+ ("0/10" 0 "0")
+ ("#e0/10" 0 "0")
+ ("#e1#/2" 5 (/ 15 2) "5" "15/2")
+ ("#e1/2#" (/ 1 20) "1/20")
+ ("#i3/2" (/ 3.0 2.0) "1.5"))
+ ((inexact)
+ ("1/2" (/ 1 2) "0.5" ".5" "500.0e-3")
+ ("0/10" 0.0 "0.0")
+ ("10/2" 5.0 "5.0" "5.")
+ ;; Unsure what "#e1/2" is supposed to do in Scheme w/o exact fractions
+ ("#i10/2" 5.0 "5.0" "5.")
+ ("-1/2" (- (/ 1 2)) "-0.5" "-.5" "-500.0e-3")))
+ (fractions
+ ((inexact exact)
+ ("#i1/0" pos-inf "+inf.0" "+Inf.0")
+ ("#i-1/0" neg-inf "-inf.0" "-Inf.0")
+ ("#i0/0" the-nan "+nan.0" "+NaN.0")
+ ;; This _could_ be valid in some Schemes (but isn't as pretty)
+ ;("#i1/0" #f)
+ ;("#i-1/0" #f)
+ ;("#i0/0" #f)
+
+ ("1/-2" #f)
+ ("1.0/2" #f)
+ ("1/2.0" #f)
+ ("1/2e2" #f)
+ ("1/2e2" #f)
+ ("1#/2" 5.0 7.5 "5.0" "5." "7.5")
+ ("1/2#" 0.05 "0.05" ".05" "50.0e-3" "5.e-002")
+ ("1#/#" #f)
+ ("1/" #f)
+ ("1/+" #f)
+ ("+/1" #f)
+ ("/1" #f)
+ ("/" #f)))
- "Some invalid complex numbers syntax (not supported at all)"
+ "Basic complex numbers (rectangular notation)"
+ (compnums
+ ((exact)
+ ("1+2i" (make-rectangular 1 2))
+ ("1+2I" (make-rectangular 1 2) "1+2i")
+ ("1-2i" (make-rectangular 1 -2))
+ ("-1+2i" (make-rectangular -1 2))
+ ("-1-2i" (make-rectangular -1 -2))
+ ("+i" (make-rectangular 0 1) "+1i" "0+i" "0+1i")
+ ("0+i" (make-rectangular 0 1) "+i" "+1i" "0+1i")
+ ("0+1i" (make-rectangular 0 1) "+i" "+1i" "0+i")
+ ("-i" (make-rectangular 0 -1) "-1i" "0-i" "0-1i")
+ ("0-i" (make-rectangular 0 -1) "-i" "-1i" "0-1i")
+ ("0-1i" (make-rectangular 0 -1) "-i" "-1i" "0-i")
+ ("+2i" (make-rectangular 0 2) "0+2i")
+ ("-2i" (make-rectangular 0 -2) "-2i" "0-2i"))
+ ((inexact)
+ ("1+2i" (make-rectangular 1 2) "1.0+2.0i" "1.+2.i")
+ ("1+2I" (make-rectangular 1 2) "1.0+2.0i" "1.+2.i")
+ ("1-2i" (make-rectangular 1 -2) "1.0-2.0i" "1.-2.i")
+ ("-1+2i" (make-rectangular -1 2) "-1.0+2.0i" "-1.+2.i")
+ ("-1-2i" (make-rectangular -1 -2) "-1.0-2.0i" "-1.-2.i")
+ ("+i" (make-rectangular 0 1) "+1.i" "+1.0i" "0.+1.i" "0.0+1.0i")
+ ("0+i" (make-rectangular 0 1) "0+1i" "+1.i" "+1.0i" "0.+1.i" "0.0+1.0i")
+ ("0+1i" (make-rectangular 0 1) "+1.i" "+1.0i" "0.+1.i" "0.0+1.0i")
+ ("-i" (make-rectangular 0 -1) "-1.i" "-1.0i" "0.-1.i" "0.0-1.0i")
+ ("0-i" (make-rectangular 0 -1) "-1.i" "-1.0i" "0.-1.i" "0.0-1.0i")
+ ("0-1i" (make-rectangular 0 -1) "-1.i" "-1.0i" "0.-1.i" "0.0-1.0i")
+ ("+2i" (make-rectangular 0 2) "+2.0i" "+2.i" "0.+2.i" "0.0+2.0i")
+ ("-2i" (make-rectangular 0 -2) "-2.0i" "-2.i" "0.-2.i" "0.0-2.0i")))
+ (compnums
+ ((exact inexact)
+ ("1#+1#i" (make-rectangular 10.0 10.0) (make-rectangular 15.0 15.0)
+ "10.0+10.0i" "10.+10.i" "15.0+15.0i" "15.+15.i")))
("2i" #f)
("+-i" #f)
("i" #f)
@@ -249,6 +284,84 @@
("1+2" #f)
("1#+#i" #f)
+ (compnums
+ ((exact inexact)
+ "Decimal-notation complex numbers (rectangular notation)"
+ ("1.0+2i" (make-rectangular 1.0 2) "1.0+2.0i" "1.0+2i" "1.+2i" "1.+2.i")
+ ("1+2.0i" (make-rectangular 1 2.0) "1.0+2.0i" "1+2.0i" "1.+2.i" "1+2.i")
+ ("1#.+1#.i" (make-rectangular 10.0 10.0) (make-rectangular 15.0 15.0)
+ "10.0+10.0i" "10.+10.i" "15.0+15.0i" "15.+15.i")
+ ("1e2+1.0i" (make-rectangular 100.0 1.0) "100.0+1.0i" "100.+1.i")
+ ("1s2+1.0i" (make-rectangular 100.0 1.0) "100.0+1.0i" "100.+1.i")
+ ("1.0+1e2i" (make-rectangular 1.0 100.0) "1.0+100.0i" "1.+100.i")
+ ("1.0+1s2i" (make-rectangular 1.0 100.0) "1.0+100.0i" "1.+100.i")
+ ("1#e2+1.0i" (make-rectangular 1000.0 1.0) (make-rectangular 1500.0 1.0)
+ "1000.0+1.0i" "1000.+1.i" "1500.0+1.0i" "1500.+1.i" "1.0e3+1.0i" "15.0e2+1.0i")
+ ("1.0+1#e2i" (make-rectangular 1.0 1000.0) (make-rectangular 1.0 1500.0)
+ "1.0+1000.0i" "1.+1000.i" "1.0+1500.0i" "1.+1500.i" "1.0+1.0e3i" "1.0+15.0e2i")
+ (".i" #f)
+ ("+.i" #f)
+ (".+i" #f)))
+
+ (compnums
+ ((exact)
+ "Fractional complex numbers (rectangular notation)"
+ ("1/2+3/4i" (make-rectangular (/ 1 2) (/ 3 4))))
+ ((inexact)
+ "Fractional complex numbers (rectangular notation)"
+ ("1/2+3/4i" (make-rectangular (/ 1 2) (/ 3 4)) "0.5+0.75i" ".5+.75i" "500.0e-3+750.0e-3i")))
+
+ (compnums
+ ((exact inexact)
+ "Mixed fractional/decimal notation complex numbers (rectangular notation)"
+ ("1#/2+3/4i" (make-rectangular 5.0 (/ 3 4)) (make-rectangular 7.5 (/ 3 4))
+ "5.0+0.75i" "5.+.75i" "7.5+0.75i" "5.0+3/4i" "5.+3/4i" "7.5+3/4i" "5.0+750.0e-3i")
+ ("0.5+3/4i" (make-rectangular 0.5 (/ 3 4))
+ "0.5+0.75i" ".5+.75i" "0.5+3/4i" ".5+3/4i" "500.0e-3+750.0e-3i")
+ ("1.5+1#/4i" (make-rectangular 1.5 2.5) (make-rectangular 1.5 3.75)
+ "1.5+2.5i" "1.5+3.75i")
+ ("0.5+1/#i" #f)
+ ("0.5+1/1#2i" #f)
+ ("1/#+0.5i" #f)
+ ("1/1#2+0.5i" #f)
+
+ "Mixed notation with infinity (might fail on mixed exactness compnums)"
+ ;; This is a nasty one. Switch to inexact *after* reading the first number.
+ ;; Note that it's perfectly acceptable for a scheme with *mixed* exactness
+ ;; in complex values to return #f here. TODO: How to parameterize this, we
+ ;; *really* want to test that single-exactness compnums systems accept this.
+ ("1/0+1.2i" (make-rectangular pos-inf 1.2) "+inf.0+1.2i" "+Inf.0+1.2i")
+ ;; Less nasty, most get this right. Same caveat as above re: mixed exactness
+ ("1.2+1/0i" (make-rectangular 1.2 pos-inf) "1.2+inf.0i" "1.2+Inf.0")))
+
+ (compnums
+ ((exact inexact)
+ "Complex NaN, Inf (rectangular notation)"
+ ("+nan.0+nan.0i" (make-rectangular the-nan the-nan) "+NaN.0+NaN.0i")
+ ("+inf.0+inf.0i" (make-rectangular pos-inf pos-inf) "+Inf.0+Inf.0i")
+ ("-inf.0+inf.0i" (make-rectangular neg-inf pos-inf) "-Inf.0+Inf.0i")
+ ("-inf.0-inf.0i" (make-rectangular neg-inf neg-inf) "-Inf.0-Inf.0i")
+ ("+inf.0-inf.0i" (make-rectangular pos-inf neg-inf) "+Inf.0-Inf.0i")
+
+ "Complex numbers (polar notation)"
+ ;; TODO: Add some here. The problem is the representation
+ ;; is hard to nail down when echoed back as rectangular
+ ;; since they're floating point with many digits, and depend
+ ;; on the precision of PI used internally.
+ ("1@2i" #f)
+ ("0.5@1/#" #f)
+ ("0.5@1/1#2" #f)
+ ("1/#@0.5" #f)
+ ("1/1#2@0.5" #f)
+ ("1@" #f)
+ ("1#@#" #f)
+ ("1/@" #f)
+ ("@/1" #f)
+ ("@1" #f)
+ ("1@+" #f)
+ ("+@1" #f)
+ ("@" #f)))
+
"Base prefixes"
("#x11" 17 "17")
("#X11" 17 "17")
@@ -335,17 +448,55 @@
("#b1e2" #f)
"Fractions with prefixes"
- ("#x10/2" 8.0 "8.0" "8.")
- ("#x11/2" 8.5 "8.5")
- ("#d11/2" 5.5 "5.5")
- ("#o11/2" 4.5 "4.5")
- ("#b11/10" 1.5 "1.5")
- ("#b11/2" #f)
- ("#x10/#o10" #f)
- ("10/#o10" #f)
- ("#x1#/2" 8.0 12.0 "8.0" "8." "12.0" "12.")
- ("#d1#/2" 5.0 7.5 "5.0" "5." "7.5")
- ("#o1#/2" 4.0 6.0 "4.0" "4." "6.0" "6.")
- ("#b1#/2" #f)
- ("#b1#/10" 1.0 1.5 "1.0" "1." "1.5")
- )
\ No newline at end of file
+ (fractions
+ ((inexact)
+ ("#x10/2" 8.0 "8.0" "8.")
+ ("#x11/2" 8.5 "8.5")
+ ("#d11/2" 5.5 "5.5")
+ ("#o11/2" 4.5 "4.5")
+ ("#b11/10" 1.5 "1.5"))
+ ((exact)
+ ("#x10/2" 8 "8")
+ ("#x11/2" (/ 17 2) "17/2")
+ ("#d11/2" (/ 11 2) "11/2")
+ ("#o11/2" (/ 9 2) "9/2")
+ ("#b11/10" (/ 3 2) "3/2")))
+ (fractions
+ ((inexact exact)
+ ("#b11/2" #f)
+ ("#x10/#o10" #f)
+ ("10/#o10" #f)
+ ("#x1#/2" 8.0 12.0 "8.0" "8." "12.0" "12.")
+ ("#d1#/2" 5.0 7.5 "5.0" "5." "7.5")
+ ("#o1#/2" 4.0 6.0 "4.0" "4." "6.0" "6.")
+ ("#b1#/2" #f)
+ ("#b1#/10" 1.0 1.5 "1.0" "1." "1.5")))
+
+ (compnums
+ ((exact inexact)
+ "Complex numbers with prefixes"
+ ("#x1#+1#i" (make-rectangular 16.0 16.0) (make-rectangular 24.0 24.0)
+ "16.0+16.0i" "16.+16.i" "24.0+24.0i" "24.+24.i")
+ ("#x1.0+1.0i" #f)
+ ("#d1.0+1.0i" (make-rectangular 1.0 1.0) "1.0+1.0i" "1.+1.i")
+ ("#o1.0+1.0i" #f)
+ ("#b1.0+1.0i" #f)
+ ("#x10+#o10i" #f)
+ ("10+#o10i" #f)
+ ("#x1@#x1" #f)
+ ("1@#x1" #f)))
+ (compnums
+ ((exact)
+ ("#x10+11i" (make-rectangular 16 17) "16+17i")
+ ("#d10+11i" (make-rectangular 10 11) "10+11i")
+ ("#o10+11i" (make-rectangular 8 9) "8+9i")
+ ("#b10+11i" (make-rectangular 2 3) "2+3i")
+ ("#e1.0+1.0i" (make-rectangular 1 1) "1+1i" "1+i")
+ ("#i1.0+1.0i" (make-rectangular 1.0 1.0) "1.0+1.0i" "1.+1.i"))
+ ((inexact)
+ ("#x10+11i" (make-rectangular 16 17) "16.0+17.0i" "16.+17.i")
+ ("#d10+11i" (make-rectangular 10 11) "10.0+11.0i" "10.+11.i")
+ ("#o10+11i" (make-rectangular 8 9) "8.0+9.0i" "8.+9.i")
+ ("#b10+11i" (make-rectangular 2 3) "2.0+3.0i" "2.+3.i")))
+
+ )
diff --git a/types.db b/types.db
index 8378843d..5d08a3c7 100644
--- a/types.db
+++ b/types.db
@@ -298,7 +298,10 @@
(() (fixnum) '0)
((fixnum) (fixnum) #(1))
((float) (float) #(1))
- ((number) #(1))
+ ((integer) (integer) #(1))
+ ((ratnum) (ratnum) #(1))
+ ((cplxnum) (cplxnum) #(1))
+ ((number) (number) #(1))
((float fixnum) (float)
(##core#inline_allocate
("C_a_i_flonum_plus" 4)
@@ -311,11 +314,19 @@
(##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1))
#(2)))
((float float) (float)
- (##core#inline_allocate ("C_a_i_flonum_plus" 4) #(1) #(2))))
+ (##core#inline_allocate ("C_a_i_flonum_plus" 4) #(1) #(2)))
+ ((fixnum fixnum) (integer)
+ (##core#inline_allocate ("C_a_i_fixnum_plus" 3) #(1) #(2)))
+ ((integer integer) (integer)
+ (##sys#integer-plus #(1) #(2)))
+ ((number number) (number)
+ (##sys#+-2 #(1) #(2))))
(- (#(procedure #:clean #:enforce #:foldable) - (number #!rest number) number)
- ((fixnum) (fixnum)
- (##core#inline "C_u_fixnum_negate" #(1)))
+ ((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_negate" 3) #(1)))
+ ((integer) (integer) (##sys#integer-negate #(1)))
+ ((float) (float) (##core#inline_allocate ("C_a_i_flonum_negate" 4) #(1)))
+ ((number) (number) (##sys#negate #(1)))
((float fixnum) (float)
(##core#inline_allocate
("C_a_i_flonum_difference" 4)
@@ -328,13 +339,21 @@
#(2)))
((float float) (float)
(##core#inline_allocate ("C_a_i_flonum_difference" 4) #(1) #(2)))
- ((float) (float)
- (##core#inline_allocate ("C_a_i_flonum_negate" 4) #(1))))
+ ((fixnum fixnum) (integer)
+ (##core#inline_allocate ("C_a_i_fixnum_difference" 3) #(1) #(2)))
+ ((integer integer) (integer)
+ (##sys#integer-minus #(1) #(2)))
+ ((number number) (number)
+ (##sys#--2 #(1) #(2))))
(* (#(procedure #:clean #:enforce #:foldable) * (#!rest number) number)
(() (fixnum) '1)
((fixnum) (fixnum) #(1))
((float) (float) #(1))
+ ((bignum) (bignum) #(1))
+ ((integer) (integer) #(1))
+ ((ratnum) (ratnum) #(1))
+ ((cplxnum) (cplxnum) #(1))
((number) (number) #(1))
((float fixnum) (float)
(##core#inline_allocate
@@ -347,21 +366,32 @@
(##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1))
#(2)))
((float float) (float)
- (##core#inline_allocate ("C_a_i_flonum_times" 4) #(1) #(2))))
+ (##core#inline_allocate ("C_a_i_flonum_times" 4) #(1) #(2)))
+ ((fixnum fixnum) (integer)
+ (##core#inline_allocate ("C_a_i_fixnum_times" 4) #(1) #(2)))
+ ((integer integer) (integer)
+ (##sys#integer-times #(1) #(2)))
+ ((number number) (number)
+ (##sys#*-2 #(1) #(2))))
(/ (#(procedure #:clean #:enforce #:foldable) / (number #!rest number) number)
((float fixnum) (float)
- (##core#inline_allocate
- ("C_a_i_flonum_quotient_checked" 4)
- #(1)
+ ;; This is the only checked one because the divisor is an exact value
+ (##core#inline_allocate
+ ("C_a_i_flonum_quotient_checked" 4)
+ #(1)
(##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(2))))
((fixnum float) (float)
- (##core#inline_allocate
- ("C_a_i_flonum_quotient_checked" 4)
+ (##core#inline_allocate
+ ("C_a_i_flonum_quotient" 4)
(##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1))
#(2)))
((float float) (float)
- (##core#inline_allocate ("C_a_i_flonum_quotient_checked" 4) #(1) #(2))))
+ (##core#inline_allocate ("C_a_i_flonum_quotient" 4) #(1) #(2)))
+ ((integer integer) ((or integer ratnum))
+ (##sys#/-2 #(1) #(2)))
+ ((number number) (number)
+ (##sys#/-2 #(1) #(2))))
(= (#(procedure #:clean #:enforce #:foldable) = (#!rest number) boolean)
(() '#t)
@@ -403,33 +433,72 @@
((float float) (##core#inline "C_flonum_less_or_equal_p" #(1) #(2)))
((number number) (##core#inline "C_i_less_or_equalp" #(1) #(2))))
-(quotient (#(procedure #:clean #:enforce #:foldable) quotient (number number) number)
+(quotient (#(procedure #:clean #:enforce #:foldable) quotient ((or integer float) (or integer float)) (or integer float))
;;XXX flonum/mixed case
- ((fixnum fixnum) (fixnum)
- (##core#inline "C_fixnum_divide" #(1) #(2))))
-
-(remainder (#(procedure #:clean #:enforce #:foldable) remainder (number number) number)
+ ((float float) (float)
+ (##core#inline_allocate
+ ("C_a_i_flonum_actual_quotient_checked" 4) #(1) #(2)))
+ ((fixnum fixnum) (integer)
+ (##core#inline_allocate ("C_a_i_fixnum_quotient_checked" 3)
+ #(1) #(2)))
+ ((integer integer) (integer)
+ (##sys#integer-quotient #(1) #(2))))
+
+(remainder (#(procedure #:clean #:enforce #:foldable) remainder ((or integer float) (or integer float)) (or integer float))
+ ((float float) (float)
+ (##core#inline_allocate
+ ("C_a_i_flonum_remainder_checked" 4) #(1) #(2)))
;;XXX flonum/mixed case
((fixnum fixnum) (fixnum)
- (##core#inline "C_fixnum_modulo" #(1) #(2))))
-
-(modulo (#(procedure #:clean #:enforce #:foldable) modulo (number number) number))
-
-(gcd (#(procedure #:clean #:enforce #:foldable) gcd (#!rest number) number)
- ((number number) (##sys#gcd #(1) #(2))))
+ (##core#inline "C_i_fixnum_remainder_checked" #(1) #(2)))
+ ((integer integer) (integer)
+ (##sys#integer-remainder #(1) #(2))))
+
+(quotient&remainder (#(procedure #:clean #:enforce #:foldable) quotient&remainder ((or integer float) (or integer float)) (or integer float) (or integer float))
+ ((float float) (float float)
+ (let ((#(tmp1) #(1)))
+ (let ((#(tmp2) #(2)))
+ (##sys#values
+ (##core#inline_allocate
+ ("C_a_i_flonum_actual_quotient_checked" 4) #(tmp1) #(tmp2))
+ (##core#inline_allocate
+ ("C_a_i_flonum_remainder_checked" 4) #(tmp1) #(tmp2))))))
+ ;;XXX flonum/mixed case
+ ((fixnum fixnum) (integer fixnum)
+ (let ((#(tmp1) #(1)))
+ (let ((#(tmp2) #(2)))
+ (##sys#values
+ (##core#inline_allocate ("C_a_i_fixnum_quotient_checked" 3)
+ #(tmp1) #(tmp2))
+ (##core#inline
+ "C_i_fixnum_remainder_checked" #(tmp1) #(tmp2))))))
+ ((integer integer) (integer integer)
+ (##sys#integer-quotient&remainder #(1) #(2))))
+
+;; TODO: Add nonspecializing type specific entries, to help flow analysis?
+(quotient&modulo (#(procedure #:clean #:enforce #:foldable) quotient&modulo ((or integer float) (or integer float)) (or integer float) (or integer float)))
+
+(modulo (#(procedure #:clean #:enforce #:foldable) modulo ((or integer float) (or integer float)) (or integer float)))
+
+(gcd (#(procedure #:clean #:enforce #:foldable) gcd (#!rest (or integer float)) (or integer float))
+ (() '0)
+ ((fixnum fixnum) (fixnum) (fxgcd #(1) #(2)))
+ ((float float) (float) (fpgcd #(1) #(2)))
+ ((integer integer) (integer) (##sys#integer-gcd #(1) #(2)))
+ ((number number) (number) (##sys#gcd #(1) #(2))))
(##sys#gcd (#(procedure #:clean #:enforce #:foldable) gcd (number number) number))
(lcm (#(procedure #:clean #:enforce #:foldable) lcm (#!rest number) number)
+ (() '1)
((number number) (##sys#lcm #(1) #(2))))
(##sys#lcm (#(procedure #:clean #:enforce #:foldable) lcm (number number) number))
(abs (#(procedure #:clean #:enforce #:foldable) abs (number) number)
- ((fixnum) (fixnum)
- (##core#inline "C_fixnum_abs" #(1)))
- ((float) (float)
- (##core#inline_allocate ("C_a_i_flonum_abs" 4) #(1))))
+ ((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_abs" 3) #(1)))
+ ((float) (float) (##core#inline_allocate ("C_a_i_flonum_abs" 4) #(1)))
+ ((integer) (integer) (##sys#integer-abs #(1))))
(floor (#(procedure #:clean #:enforce #:foldable) floor (number) number)
((fixnum) (fixnum) #(1))
@@ -714,21 +783,21 @@
((float) (let ((#(tmp) #(1))) '0.0))
((cplxnum) (##sys#slot #(1) '2)))
-(magnitude (#(procedure #:clean #:enforce) magnitude (number) number)
- ((fixnum) (fixnum)
- (##core#inline "C_fixnum_abs" #(1)))
- ((float) (float)
- (##core#inline_allocate ("C_a_i_flonum_abs" 4) #(1))))
+(magnitude (#(procedure #:clean #:enforce #:foldable) magnitude (number) number)
+ ((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_abs" 3) #(1)))
+ ((integer) (##sys#integer-abs #(1)))
+ ((float) (float) (##core#inline_allocate ("C_a_i_flonum_abs" 4) #(1)))
+ (((or fixnum float bignum ratnum)) (abs #(1))))
(numerator (#(procedure #:clean #:enforce #:foldable) numerator ((or float integer ratnum)) (or float integer))
- ((fixnum) (fixnum) #(1))
- ((bignum) (bignum) #(1))
- ((integer) (integer) #(1))
- ((ratnum) (integer) (##sys#slot #(1) '1)))
+ ((fixnum) (fixnum) #(1))
+ ((bignum) (bignum) #(1))
+ ((integer) (integer) #(1))
+ ((ratnum) (integer) (##sys#slot #(1) '1)))
(denominator (#(procedure #:clean #:enforce #:foldable) denominator ((or float integer ratnum)) (or float integer))
- ((integer) (fixnum) (let ((#(tmp) #(1))) '1))
- ((ratnum) (integer) (##sys#slot #(1) '1)))
+ ((integer) (fixnum) (let ((#(tmp) #(1))) '1))
+ ((ratnum) (integer) (##sys#slot #(1) '2)))
(scheme-report-environment
(#(procedure #:clean #:enforce) scheme-report-environment (#!optional fixnum) (struct environment)))
@@ -749,6 +818,7 @@
(##sys#abort (procedure abort (*) noreturn))
(add1 (#(procedure #:clean #:enforce #:foldable) add1 (number) number)
+ ((integer) (integer) (##sys#integer-plus #(1) '1))
((float) (float)
(##core#inline_allocate ("C_a_i_flonum_plus" 4) #(1) '1.0)))
@@ -909,6 +979,9 @@
(fp/ (#(procedure #:clean #:enforce #:foldable) fp/ (float float) float)
((float float) (##core#inline_allocate ("C_a_i_flonum_quotient" 4) #(1) #(2)) ))
+(fpgcd (#(procedure #:clean #:enforce #:foldable) fpgcd (float float) float)
+ ((float float) (##core#inline_allocate ("C_a_i_flonum_gcd" 4) #(1) #(2)) ))
+
(fp+ (#(procedure #:clean #:enforce #:foldable) fp+ (float float) float)
((float float) (##core#inline_allocate ("C_a_i_flonum_plus" 4) #(1) #(2)) ))
@@ -992,6 +1065,7 @@
(fx- (#(procedure #:clean #:foldable) fx- (fixnum fixnum) fixnum))
(fx* (#(procedure #:clean #:foldable) fx* (fixnum fixnum) fixnum))
(fx/ (#(procedure #:clean #:foldable) fx/ (fixnum fixnum) fixnum))
+(fxgcd (#(procedure #:clean #:foldable) fxgcd (fixnum fixnum) fixnum))
(fx+ (#(procedure #:clean #:foldable) fx+ (fixnum fixnum) fixnum))
(fx< (#(procedure #:clean #:foldable) fx< (fixnum fixnum) boolean))
(fx<= (#(procedure #:clean #:foldable) fx<= (fixnum fixnum) boolean))
@@ -1004,6 +1078,7 @@
(fxmax (#(procedure #:clean #:foldable) fxmax (fixnum fixnum) fixnum))
(fxmin (#(procedure #:clean #:foldable) fxmin (fixnum fixnum) fixnum))
(fxmod (#(procedure #:clean #:foldable) fxmod (fixnum fixnum) fixnum))
+(fxrem (#(procedure #:clean #:foldable) fxrem (fixnum fixnum) fixnum))
(fxneg (#(procedure #:clean #:foldable) fxneg (fixnum) fixnum))
(fxnot (#(procedure #:clean #:foldable) fxnot (fixnum) fixnum))
(fxodd? (#(procedure #:clean #:foldable) fxodd? (fixnum) boolean))
@@ -1133,6 +1208,7 @@
(strip-syntax (#(procedure #:clean) strip-syntax (*) *))
(sub1 (#(procedure #:clean #:enforce #:foldable) sub1 (number) number)
+ ((integer) (integer) (##sys#integer-minus #(1) '1))
((float) (float)
(##core#inline_allocate ("C_a_i_flonum_difference" 4) #(1) '1.0)))
Trap