static cl_object
complex_divide(cl_object ar, cl_object ai, cl_object br, cl_object bi)
{
/* #C(z1 z2) = #C(xr xi) * #C(yr -yi) */
cl_object z1 = ecl_plus(ecl_times(ar, br), ecl_times(ai, bi));
cl_object z2 = ecl_minus(ecl_times(ai, br), ecl_times(ar, bi));
cl_object absB = ecl_plus(ecl_times(br, br), ecl_times(bi, bi));
return ecl_make_complex(ecl_divide(z1, absB), ecl_divide(z2, absB));
}
static cl_object
prepare_ratio_to_float(cl_object num, cl_object den, int digits, cl_fixnum *scaleout)
{
/* We have to cook our own routine because GMP does not round.
* The recipe is simple: we multiply the numberator by a large
* enough number so that the division by the denominator fits
* the floating point number. The result is scaled back by the
* appropriate exponent.
*/
/* Scale down the denominator, eliminating the zeros
* so that we have smaller operands.
*/
cl_fixnum scale = remove_zeros(&den);
cl_fixnum num_size = ecl_integer_length(num);
cl_fixnum delta = ecl_integer_length(den) - num_size;
scale -= delta;
{
cl_fixnum adjust = digits + delta + 1;
if (adjust > 0) {
num = ecl_ash(num, adjust);
} else if (adjust < 0) {
den = ecl_ash(den, -adjust);
}
}
do {
const cl_env_ptr the_env = ecl_process_env();
cl_object fraction = ecl_truncate2(num, den);
cl_object rem = ecl_nth_value(the_env, 1);
cl_fixnum len = ecl_integer_length(fraction);
if ((len - digits) == 1) {
if (ecl_oddp(fraction)) {
cl_object one = ecl_minusp(num)?
ecl_make_fixnum(-1) :
ecl_make_fixnum(1);
if (rem == ecl_make_fixnum(0)) {
if (cl_logbitp(ecl_make_fixnum(1), fraction)
!= ECL_NIL)
fraction = ecl_plus(fraction, one);
} else {
fraction = ecl_plus(fraction, one);
}
}
*scaleout = scale - (digits + 1);
return fraction;
}
den = ecl_ash(den, 1);
scale++;
} while (1);
}
static cl_fixnum
scale(float_approx *approx)
{
cl_fixnum k = 0;
cl_object x = ecl_plus(approx->r, approx->mp);
int sign;
do {
sign = ecl_number_compare(x, approx->s);
if (approx->high_ok) {
if (sign < 0)
break;
} else {
if (sign <= 0)
break;
}
approx->s = ecl_times(approx->s, PRINT_BASE);
k++;
} while(1);
do {
x = ecl_times(x, PRINT_BASE);
sign = ecl_number_compare(x, approx->s);
if (approx->high_ok) {
if (sign >= 0)
break;
} else {
if (sign > 0)
break;
}
k--;
approx->r = ecl_times(approx->r, PRINT_BASE);
approx->mm = ecl_times(approx->mm, PRINT_BASE);
approx->mp = ecl_times(approx->mp, PRINT_BASE);
} while(1);
return k;
}
static cl_object
generate(cl_object digits, float_approx *approx)
{
cl_object d, x;
cl_fixnum digit;
bool tc1, tc2;
do {
d = ecl_truncate2(ecl_times(approx->r, PRINT_BASE), approx->s);
approx->r = VALUES(1);
approx->mp = ecl_times(approx->mp, PRINT_BASE);
approx->mm = ecl_times(approx->mm, PRINT_BASE);
tc1 = approx->low_ok?
ecl_lowereq(approx->r, approx->mm) :
ecl_lower(approx->r, approx->mm);
x = ecl_plus(approx->r, approx->mp);
tc2 = approx->high_ok?
ecl_greatereq(x, approx->s) :
ecl_greater(x, approx->s);
if (tc1 || tc2) {
break;
}
ecl_string_push_extend(digits, ecl_digit_char(ecl_fixnum(d), 10));
} while (1);
if (tc2 && !tc1) {
digit = ecl_fixnum(d) + 1;
} else if (tc1 && !tc2) {
digit = ecl_fixnum(d);
} else if (ecl_lower(times2(approx->r), approx->s)) {
digit = ecl_fixnum(d);
} else {
digit = ecl_fixnum(d) + 1;
}
ecl_string_push_extend(digits, ecl_digit_char(digit, 10));
return digits;
}
static void
change_precision(float_approx *approx, cl_object position, cl_object relativep)
{
cl_fixnum pos;
if (Null(position))
return;
pos = ecl_fixnum(position);
if (!Null(relativep)) {
cl_object k = ecl_make_fixnum(0);
cl_object l = ecl_make_fixnum(1);
while (ecl_lower(ecl_times(approx->s, l),
ecl_plus(approx->r, approx->mp))) {
k = ecl_one_plus(k);
l = ecl_times(l, PRINT_BASE);
}
position = ecl_minus(k, position);
{
cl_object e1 = cl_expt(PRINT_BASE, position);
cl_object e2 = ecl_divide(e1, ecl_make_fixnum(2));
cl_object e3 = cl_expt(PRINT_BASE, k);
if (ecl_greatereq(ecl_plus(approx->r, ecl_times(approx->s, e1)),
ecl_times(approx->s, e2)))
position = ecl_one_minus(position);
}
}
{
cl_object x = ecl_times(approx->s, cl_expt(PRINT_BASE, position));
cl_object e = ecl_divide(x, ecl_make_fixnum(2));
cl_object low = cl_max(2, approx->mm, e);
cl_object high = cl_max(2, approx->mp, e);
if (ecl_lowereq(approx->mm, low)) {
approx->mm = low;
approx->low_ok = 1;
}
if (ecl_lowereq(approx->mp, high)) {
approx->mp = high;
approx->high_ok = 1;
}
}
}
cl_object
_ecl_long_double_to_integer(long double d0)
{
const int fb = FIXNUM_BITS - 3;
int e;
long double d = frexpl(d0, &e);
if (e <= fb) {
return ecl_make_fixnum((cl_fixnum)d0);
} else if (e > LDBL_MANT_DIG) {
return ecl_ash(_ecl_long_double_to_integer(ldexp(d, LDBL_MANT_DIG)),
e - LDBL_MANT_DIG);
} else {
long double d1 = floorl(d = ldexpl(d, fb));
int newe = e - fb;
cl_object o = ecl_ash(_ecl_long_double_to_integer(d1), newe);
long double d2 = ldexpl(d - d1, newe);
if (d2) o = ecl_plus(o, _ecl_long_double_to_integer(d2));
return o;
}
}
static cl_object
times2(cl_object x)
{
return ecl_plus(x, x);
}
/* optimize speed 3, debug 3, space 0, safety 2 */
static cl_object L1seq(cl_narg narg, ...)
{
cl_object T0;
struct ecl_ihs_frame ihs;
const cl_object _ecl_debug_env = ECL_NIL;
const cl_env_ptr cl_env_copy = ecl_process_env();
cl_object value0;
ecl_cs_check(cl_env_copy,value0);
{
cl_object V1;
cl_object V2;
cl_object V3;
ecl_va_list args; ecl_va_start(args,narg,narg,0);
{
ecl_ihs_push(cl_env_copy,&ihs,VV[0],_ecl_debug_env);
{
cl_object keyvars[6];
cl_parse_key(args,3,L1seqkeys,keyvars,NULL,FALSE);
ecl_va_end(args);
if (Null(keyvars[3])) {
V1 = ecl_make_fixnum(0);
} else {
V1 = keyvars[0];
}
if (Null(keyvars[4])) {
V2 = ecl_make_fixnum(10);
} else {
V2 = keyvars[1];
}
if (Null(keyvars[5])) {
V3 = ecl_make_fixnum(1);
} else {
V3 = keyvars[2];
}
}
{
cl_object V4; /* I */
cl_object V5;
cl_object V6;
{
T0 = cl_realp(V1);
if (ecl_unlikely(!((T0)!=ECL_NIL)))
FEwrong_type_argument(ECL_SYM("REAL",703),V1);
V4 = V1;
}
{
T0 = cl_realp(V2);
if (ecl_unlikely(!((T0)!=ECL_NIL)))
FEwrong_type_argument(ECL_SYM("REAL",703),V2);
V5 = V2;
}
{
T0 = cl_realp(V3);
if (ecl_unlikely(!((T0)!=ECL_NIL)))
FEwrong_type_argument(ECL_SYM("REAL",703),V3);
V6 = V3;
}
{
static const struct ecl_var_debug_info _ecl_descriptors[]={
{"#:LOOP-STEP-BY1",_ecl_object_loc}
,{"#:LOOP-LIMIT0",_ecl_object_loc}
,{"COMMON-LISP-USER::I",_ecl_object_loc}};
const cl_index _ecl_debug_info_raw[]={
(cl_index)(_ecl_debug_env),(cl_index)(_ecl_descriptors),(cl_index)(&V6),(cl_index)(&V5),(cl_index)(&V4)};
ecl_def_ct_vector(_ecl_debug_env,ecl_aet_index,_ecl_debug_info_raw,5,,);
ihs.lex_env = _ecl_debug_env;
{
cl_object V7;
cl_object V8;
V7 = ecl_list1(ECL_NIL);
V8 = V7;
{
static const struct ecl_var_debug_info _ecl_descriptors[]={
{"#:LOOP-LIST-TAIL3",_ecl_object_loc}
,{"#:LOOP-LIST-HEAD2",_ecl_object_loc}};
const cl_index _ecl_debug_info_raw[]={
(cl_index)(_ecl_debug_env),(cl_index)(_ecl_descriptors),(cl_index)(&V8),(cl_index)(&V7)};
ecl_def_ct_vector(_ecl_debug_env,ecl_aet_index,_ecl_debug_info_raw,4,,);
ihs.lex_env = _ecl_debug_env;
L12:;
if (!(ecl_number_compare(V4,V5)>0)) { goto L14; }
goto L13;
L14:;
T0 = V8;
V8 = ecl_list1(V4);
cl_rplacd(T0, V8);
V4 = ecl_plus(V4,V6);
goto L12;
L13:;
value0 = ecl_cdr(V7);
cl_env_copy->nvalues = 1;
ecl_ihs_pop(cl_env_copy);
return value0;
}
ihs.lex_env = _ecl_debug_env;
}
}
ihs.lex_env = _ecl_debug_env;
}
}
}
}
