~ chicken-core (master) d575c3651cc364b366612a5df728592e13f33053
commit d575c3651cc364b366612a5df728592e13f33053
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Sep 7 00:21:27 2026 +0200
Commit: Felix Winkelmann <felix.winkelmann@bevuta.com>
CommitDate: Wed Sep 9 13:45:43 2026 +0200
try to preserve exactness after complex/non-complex multiplication
diff --git a/runtime.c b/runtime.c
index abe56584..5e219273 100644
--- a/runtime.c
+++ b/runtime.c
@@ -8037,6 +8037,24 @@ cplx_times(C_word **ptr, C_word rx, C_word ix, C_word ry, C_word iy)
else return C_cplxnum(ptr, r, i);
}
+void C_adjust_complex(C_word **ptr, C_word *r, C_word *i, C_word x, C_word y) {
+ if((*r & C_FIXNUM_BIT) != 0) {
+ if((*i & C_FIXNUM_BIT) != 0) {
+ if(C_truep(C_u_i_inexactp(x)) || C_truep(C_u_i_inexactp(y))) {
+ *r = C_flonum(ptr, C_unfix(*r));
+ *i = C_flonum(ptr, C_unfix(*i));
+ }
+ } else if(C_block_header(*i) == C_FLONUM_TAG)
+ *r = C_flonum(ptr, C_unfix(*r));
+ return;
+ }
+ if((*i & C_FIXNUM_BIT) != 0) {
+ if(C_block_header(*r) == C_FLONUM_TAG)
+ *i = C_flonum(ptr, C_unfix(*i));
+ return;
+ }
+}
+
/* The maximum size this needs is that required to store a complex
* number result, where both real and imag parts consist of ratnums.
* The maximum size of those ratnums is if they consist of two bignums
@@ -8063,6 +8081,7 @@ C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y)
} else if (C_block_header(y) == C_CPLXNUM_TAG) {
C_word r = C_s_a_i_times(ptr, 2, x, C_u_i_cplxnum_real(y));
C_word i = C_s_a_i_times(ptr, 2, x, C_u_i_cplxnum_imag(y));
+ C_adjust_complex(ptr, &r, &i, x, y);
return C_cplxnum(ptr, r, i);
} else {
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);
@@ -8083,6 +8102,7 @@ C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y)
} else if (C_block_header(y) == C_CPLXNUM_TAG) {
C_word r = C_s_a_i_times(ptr, 2, x, C_u_i_cplxnum_real(y));
C_word i = C_s_a_i_times(ptr, 2, x, C_u_i_cplxnum_imag(y));
+ C_adjust_complex(ptr, &r, &i, x, y);
return C_cplxnum(ptr, r, i);
} else {
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);
@@ -8101,6 +8121,7 @@ C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y)
} else if (C_block_header(y) == C_CPLXNUM_TAG) {
C_word r = C_s_a_i_times(ptr, 2, x, C_u_i_cplxnum_real(y));
C_word i = C_s_a_i_times(ptr, 2, x, C_u_i_cplxnum_imag(y));
+ C_adjust_complex(ptr, &r, &i, x, y);
return C_cplxnum(ptr, r, i);
} else {
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);
@@ -8119,6 +8140,7 @@ C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y)
} else if (C_block_header(y) == C_CPLXNUM_TAG) {
C_word r = C_s_a_i_times(ptr, 2, x, C_u_i_cplxnum_real(y));
C_word i = C_s_a_i_times(ptr, 2, x, C_u_i_cplxnum_imag(y));
+ C_adjust_complex(ptr, &r, &i, x, y);
return C_cplxnum(ptr, r, i);
} else {
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);
@@ -8130,6 +8152,7 @@ C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y)
} else {
C_word r = C_s_a_i_times(ptr, 2, y, C_u_i_cplxnum_real(x));
C_word i = C_s_a_i_times(ptr, 2, y, C_u_i_cplxnum_imag(x));
+ C_adjust_complex(ptr, &r, &i, x, y);
return C_cplxnum(ptr, r, i);
}
} else {
diff --git a/tests/numbers-test-gauche.scm b/tests/numbers-test-gauche.scm
index 5b9a84a2..3da7e3eb 100644
--- a/tests/numbers-test-gauche.scm
+++ b/tests/numbers-test-gauche.scm
@@ -1214,11 +1214,8 @@
(test-equal "flonum * 1.0" (apply * '(3.0 1.0)) 3.0)
(test-equal "1.0 * flonum" (apply * '(1.0 3.0)) 3.0)
-;; these return complex exact 0+0i, but this can't be constructed in the reader
-;; not sure what to do here...
-;(test-equal "compnum * 0" (* 0 +i) 0)
-;(test-equal "0 * compnum" (* +i 0) 0)
-
+(test-equal "compnum * 0" (* 0 +i) 0)
+(test-equal "0 * compnum" (* +i 0) 0)
(test-equal "compnum * 1" (* 1 +i) +i)
(test-equal "1 * compnum" (* +i 1) +i)
Trap