This is num_co.c in view mode; [Download] [Up]
/*
(c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
Copying of this file is authorized to users who have executed the true and
proper "License Agreement for Kyoto Common LISP" with SIGLISP.
*/
/*
num_co.c
IMPLEMENTATION-DEPENDENT
This file contains those functions
that know the representation of floating-point numbers.
*/
#define IN_NUM_CO
#include "include.h"
#include "num_include.h"
#include "mp.h"
object plus_half, minus_half;
#ifdef CONVEX
#define VAX
#endif
#ifdef VAX
/*
radix = 2
SEEEEEEEEHHHHHHH The redundant most significant fraction bit
HHHHHHHHHHHHHHHH is not expressed.
LLLLLLLLLLLLLLLL
LLLLLLLLLLLLLLLL
*/
#endif
#ifdef IBMRT
#endif
#ifdef IEEEFLOAT
#ifdef NS32K
#else
/*
radix = 2
SEEEEEEEEEEEHHHHHHHHHHHHHHHHHHHH The redundant most
LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL significant fraction bit
is not expressed.
*/
#endif
#endif
#ifdef MV
#endif
#ifdef S3000
/*
radix = 16
SEEEEEEEHHHHHHHHHHHHHHHHHHHHHHHH
LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL
*/
#endif
integer_decode_double(d, hp, lp, ep, sp)
double d;
int *hp, *lp, *ep, *sp;
{
int h, l;
if (d == 0.0) {
*hp = *lp = 0;
*ep = 0;
*sp = 1;
return;
}
#ifdef NS32K
#else
h = *((int *)(&d) + HIND);
l = *((int *)(&d) + LIND);
#endif
#ifdef VAX
*ep = ((h >> 7) & 0xff) - 128 - 56;
h = ((h >> 15) & 0x1fffe) | (((h & 0x7f) | 0x80) << 17);
l = ((l >> 16) & 0xffff) | (l << 16);
/* is this right!!!! I don't believe it --wfs */
h = h >> 1;
#endif
#ifdef IEEEFLOAT
*ep = ((h & 0x7ff00000) >> 20) - 1022 - 53;
h = (h & 0x000fffff | 0x00100000);
#endif
#ifdef S3000
*ep = ((h & 0x7f000000) >> 24) - 64 - 14;
h = (h & 0x00ffffff);
#endif
if (32-BIG_RADIX)
/* shift for making bignum */
{ h = h << (32-BIG_RADIX) ;
h |= ((l & (-1 << (32-BIG_RADIX))) >> (32-BIG_RADIX));
l &= ~(-1 << (32-BIG_RADIX));
}
*hp = h;
*lp = l;
*sp = (d > 0.0 ? 1 : -1);
}
#ifdef VAX
/*
radix = 2
SEEEEEEEEMMMMMMM The redundant most significant fraction bit
MMMMMMMMMMMMMMMM is not expressed.
*/
#endif
#ifdef IBMRT
#endif
#ifdef IEEEFLOAT
/*
radix = 2
SEEEEEEEEMMMMMMMMMMMMMMMMMMMMMMM The redundant most
significant fraction bit
is not expressed.
*/
#endif
#ifdef MV
#endif
#ifdef S3000
/*
radix = 16
SEEEEEEEMMMMMMMMMMMMMMMMMMMMMMMM
*/
#endif
integer_decode_float(d, mp, ep, sp)
double d;
int *mp, *ep, *sp;
{
float f;
int m;
f = d;
if (f == 0.0) {
*mp = 0;
*ep = 0;
*sp = 1;
return;
}
m = *(int *)(&f);
#ifdef VAX
*ep = ((m >> 7) & 0xff) - 128 - 24;
*mp = ((m >> 16) & 0xffff) | (((m & 0x7f) | 0x80) << 16);
#endif
#ifdef IBMRT
#endif
#ifdef IEEEFLOAT
*ep = ((m & 0x7f800000) >> 23) - 126 - 24;
*mp = m & 0x007fffff | 0x00800000;
#endif
#ifdef MV
#endif
#ifdef S3000
*ep = ((m & 0x7f000000) >> 24) - 64 - 6;
*mp = m & 0x00ffffff;
#endif
*sp = (f > 0.0 ? 1 : -1);
}
int
double_exponent(d)
double d;
{
if (d == 0.0)
return(0);
#ifdef VAX
return(((*(int *)(&d) >> 7) & 0xff) - 128);
#endif
#ifdef IBMRT
#endif
#ifdef IEEEFLOAT
#ifdef NS32K
#else
return((((*((int *)(&d) + HIND)) & 0x7ff00000) >> 20) - 1022);
#endif
#endif
#ifdef MV
#endif
#ifdef S3000
return(((*(int *)(&d) & 0x7f000000) >> 24) - 64);
#endif
}
double
set_exponent(d, e)
double d;
int e;
{
double dummy;
if (d == 0.0)
return(0.0);
*((int *)(&d) + HIND)
#ifdef VAX
= *(int *)(&d) & 0xffff807f | ((e + 128) << 7) & 0x7f80;
#endif
#ifdef IBMRT
#endif
#ifdef IEEEFLOAT
#ifdef NS32K
#else
= *((int *)(&d) + HIND) & 0x800fffff | ((e + 1022) << 20) & 0x7ff00000;
#endif
#endif
#ifdef MV
#endif
#ifdef S3000
= *(int *)(&d) & 0x80ffffff | ((e + 64) << 24) & 0x7f000000;
#endif
dummy = d*d;
return(d);
}
object
double_to_integer(d)
double d;
{
int h, l, e, s;
object x, y;
object shift_integer();
vs_mark;
if (d == 0.0)
return(small_fixnum(0));
integer_decode_double(d, &h, &l, &e, &s);
#ifdef VAX
if (e <= -BIG_RADIX) {
h >>= (-e) - BIG_RADIX;
#endif
#ifdef IBMRT
#endif
#ifdef IEEEFLOAT
if (e <= -BIG_RADIX) {
e = (-e) - BIG_RADIX;
if (e >= BIG_RADIX)
return(small_fixnum(0));
h >>= e;
#endif
#ifdef MV
#endif
#ifdef S3000
if (e <= -8) {
h >>= 4*(-e) - BIG_RADIX;
#endif
return(make_fixnum(s*h));
}
if (h != 0)
x = bignum2(h, l);
else
x = make_fixnum(l);
vs_push(x);
#ifdef VAX
x = shift_integer(x, e);
#endif
#ifdef IBMRT
#endif
#ifdef IEEEFLOAT
x = shift_integer(x, e);
#endif
#ifdef MV
#endif
#ifdef S3000
x = shift_integer(x, 4*e);
#endif
if (s < 0) {
vs_push(x);
x = number_negate(x);
}
vs_reset;
return(x);
}
object
remainder(x, y, q)
object x, y, q;
{
object z;
z = number_times(q, y);
vs_push(z);
z = number_minus(x, z);
vs_pop;
return(z);
}
/* Coerce X to single-float if one arg,
otherwise coerce to same float type as second arg */
Lfloat()
{
double d;
int narg;
object x;
enum type t;
narg = vs_top - vs_base;
if (narg < 1)
too_few_arguments();
else if (narg > 2)
too_many_arguments();
if (narg == 2) {
check_type_float(&vs_base[1]);
t = type_of(vs_base[1]);
}
x = vs_base[0];
switch (type_of(x)) {
case t_fixnum:
if (narg > 1 && t == t_shortfloat)
x = make_shortfloat((shortfloat)(fix(x)));
else
x = make_longfloat((double)(fix(x)));
break;
case t_bignum:
case t_ratio:
d = number_to_double(x);
if (narg > 1 && t == t_shortfloat)
x = make_shortfloat((shortfloat)d);
else
x = make_longfloat(d);
break;
case t_shortfloat:
if (narg > 1 && t == t_shortfloat);
else
x = make_longfloat((double)(sf(x)));
break;
case t_longfloat:
if (narg > 1 && t == t_shortfloat)
x = make_shortfloat((shortfloat)(lf(x)));
break;
default:
FEwrong_type_argument(TSor_rational_float, x);
}
vs_base = vs_top;
vs_push(x);
}
Lnumerator()
{
check_arg(1);
check_type_rational(&vs_base[0]);
if (type_of(vs_base[0]) == t_ratio)
vs_base[0] = vs_base[0]->rat.rat_num;
}
Ldenominator()
{
check_arg(1);
check_type_rational(&vs_base[0]);
if (type_of(vs_base[0]) == t_ratio)
vs_base[0] = vs_base[0]->rat.rat_den;
else
vs_base[0] = small_fixnum(1);
}
Lfloor()
{
object x, y, q, q1;
double d;
int n;
object one_minus();
n = vs_top - vs_base;
if (n == 0)
too_few_arguments();
if (n > 1)
goto TWO_ARG;
x = vs_base[0];
switch (type_of(x)) {
case t_fixnum:
case t_bignum:
vs_push(small_fixnum(0));
return;
case t_ratio:
q = x;
y = small_fixnum(1);
goto RATIO;
case t_shortfloat:
d = (double)(sf(x));
q1 = double_to_integer(d);
d -= number_to_double(q1);
if (sf(x) < 0.0 && d != 0.0) {
vs_push(q1);
q1 = one_minus(q1);
d += 1.0;
}
vs_base = vs_top;
vs_push(q1);
vs_push(make_shortfloat((shortfloat)d));
return;
case t_longfloat:
d = lf(x);
q1 = double_to_integer(d);
d -= number_to_double(q1);
if (lf(x) < 0.0 && d != 0.0) {
vs_push(q1);
q1 = one_minus(q1);
d += 1.0;
}
vs_base = vs_top;
vs_push(q1);
vs_push(make_longfloat(d));
return;
default:
FEwrong_type_argument(TSor_rational_float, x);
}
TWO_ARG:
if (n > 2)
too_many_arguments();
x = vs_base[0];
y = vs_base[1];
if ((type_of(x) == t_fixnum || type_of(x) == t_bignum) &&
(type_of(y) == t_fixnum || type_of(y) == t_bignum)) {
vs_base = vs_top;
if (number_zerop(x)) {
vs_push(small_fixnum(0));
vs_push(small_fixnum(0));
return;
}
vs_push(Cnil);
vs_push(Cnil);
integer_quotient_remainder_1(x, y, &vs_base[0], &vs_base[1]);
if (number_minusp(x) ? number_plusp(y) : number_minusp(y)) {
if (number_zerop(vs_base[1]))
return;
vs_base[0] = one_minus(vs_base[0]);
vs_base[1] = number_plus(vs_base[1], y);
}
return;
}
check_type_or_rational_float(&vs_base[0]);
check_type_or_rational_float(&vs_base[1]);
q = number_divide(x, y);
vs_push(q);
switch (type_of(q)) {
case t_fixnum:
case t_bignum:
vs_base = vs_top;
vs_push(q);
vs_push(small_fixnum(0));
break;
case t_ratio:
RATIO:
q1 = integer_divide1(q->rat.rat_num, q->rat.rat_den);
if (number_minusp(q)) {
vs_push(q1);
q1 = one_minus(q1);
} else
q1 = q1;
vs_base = vs_top;
vs_push(q1);
vs_push(remainder(x, y, q1));
return;
case t_shortfloat:
case t_longfloat:
q1 = double_to_integer(number_to_double(q));
if (number_minusp(q) && number_compare(q, q1)) {
vs_push(q1);
q1 = one_minus(q1);
} else
q1 = q1;
vs_base = vs_top;
vs_push(q1);
vs_push(remainder(x, y, q1));
return;
}
}
Lceiling()
{
object x, y, q, q1;
double d;
int n;
object one_plus();
n = vs_top - vs_base;
if (n == 0)
too_few_arguments();
if (n > 1)
goto TWO_ARG;
x = vs_base[0];
switch (type_of(x)) {
case t_fixnum:
case t_bignum:
vs_push(small_fixnum(0));
return;
case t_ratio:
q = x;
y = small_fixnum(1);
goto RATIO;
case t_shortfloat:
d = (double)(sf(x));
q1 = double_to_integer(d);
d -= number_to_double(q1);
if (sf(x) > 0.0 && d != 0.0) {
vs_push(q1);
q1 = one_plus(q1);
d -= 1.0;
}
vs_base = vs_top;
vs_push(q1);
vs_push(make_shortfloat((shortfloat)d));
return;
case t_longfloat:
d = lf(x);
q1 = double_to_integer(d);
d -= number_to_double(q1);
if (lf(x) > 0.0 && d != 0.0) {
vs_push(q1);
q1 = one_plus(q1);
d -= 1.0;
}
vs_base = vs_top;
vs_push(q1);
vs_push(make_longfloat(d));
return;
default:
FEwrong_type_argument(TSor_rational_float, x);
}
TWO_ARG:
if (n > 2)
too_many_arguments();
x = vs_base[0];
y = vs_base[1];
if ((type_of(x) == t_fixnum || type_of(x) == t_bignum) &&
(type_of(y) == t_fixnum || type_of(y) == t_bignum)) {
vs_base = vs_top;
if (number_zerop(x)) {
vs_push(small_fixnum(0));
vs_push(small_fixnum(0));
return;
}
vs_push(Cnil);
vs_push(Cnil);
integer_quotient_remainder_1(x, y, &vs_base[0], &vs_base[1]);
if (number_plusp(x) ? number_plusp(y) : number_minusp(y)) {
if (number_zerop(vs_base[1]))
return;
vs_base[0] = one_plus(vs_base[0]);
vs_base[1] = number_minus(vs_base[1], y);
}
return;
}
check_type_or_rational_float(&vs_base[0]);
check_type_or_rational_float(&vs_base[1]);
q = number_divide(x, y);
vs_push(q);
switch (type_of(q)) {
case t_fixnum:
case t_bignum:
vs_base = vs_top;
vs_push(q);
vs_push(small_fixnum(0));
break;
case t_ratio:
RATIO:
q1 = integer_divide1(q->rat.rat_num, q->rat.rat_den);
if (number_plusp(q)) {
vs_push(q1);
q1 = one_plus(q1);
} else
q1 = q1;
vs_base = vs_top;
vs_push(q1);
vs_push(remainder(x, y, q1));
return;
case t_shortfloat:
case t_longfloat:
q1 = double_to_integer(number_to_double(q));
if (number_plusp(q) && number_compare(q, q1)) {
vs_push(q1);
q1 = one_plus(q1);
} else
q1 = q1;
vs_base = vs_top;
vs_push(q1);
vs_push(remainder(x, y, q1));
return;
}
}
Ltruncate()
{
object x, y, q, q1;
int n;
n = vs_top - vs_base;
if (n == 0)
too_few_arguments();
if (n > 1)
goto TWO_ARG;
x = vs_base[0];
switch (type_of(x)) {
case t_fixnum:
case t_bignum:
vs_push(small_fixnum(0));
return;
case t_ratio:
q1 = integer_divide1(x->rat.rat_num, x->rat.rat_den);
vs_base = vs_top;
vs_push(q1);
vs_push(number_minus(x, q1));
return;
case t_shortfloat:
q1 = double_to_integer((double)(sf(x)));
vs_base = vs_top;
vs_push(q1);
vs_push(number_minus(x, q1));
return;
case t_longfloat:
q1 = double_to_integer(lf(x));
vs_base = vs_top;
vs_push(q1);
vs_push(number_minus(x, q1));
return;
default:
FEwrong_type_argument(TSor_rational_float, x);
}
TWO_ARG:
if (n > 2)
too_many_arguments();
x = vs_base[0];
y = vs_base[1];
if ((type_of(x) == t_fixnum || type_of(x) == t_bignum) &&
(type_of(y) == t_fixnum || type_of(y) == t_bignum)) {
integer_quotient_remainder_1(x, y, &vs_base[0], &vs_base[1]);
return;
}
check_type_or_rational_float(&vs_base[0]);
check_type_or_rational_float(&vs_base[1]);
q = number_divide(x, y);
vs_push(q);
switch (type_of(q)) {
case t_fixnum:
case t_bignum:
vs_base = vs_top;
vs_push(q);
vs_push(small_fixnum(0));
break;
case t_ratio:
q1 = integer_divide1(q->rat.rat_num, q->rat.rat_den);
vs_base = vs_top;
vs_push(q1);
vs_push(remainder(x, y, q1));
return;
case t_shortfloat:
case t_longfloat:
q1 = double_to_integer(number_to_double(q));
vs_base = vs_top;
vs_push(q1);
vs_push(remainder(x, y, q1));
return;
}
}
Lround()
{
object x, y, q, q1, r;
double d;
int n, c;
object one_plus(), one_minus();
n = vs_top - vs_base;
if (n == 0)
too_few_arguments();
if (n > 1)
goto TWO_ARG;
x = vs_base[0];
switch (type_of(x)) {
case t_fixnum:
case t_bignum:
vs_push(small_fixnum(0));
return;
case t_ratio:
q = x;
y = small_fixnum(1);
goto RATIO;
case t_shortfloat:
d = (double)(sf(x));
if (d >= 0.0)
q = double_to_integer(d + 0.5);
else
q = double_to_integer(d - 0.5);
d -= number_to_double(q);
if (d == 0.5 && number_oddp(q)) {
vs_push(q);
q = one_plus(q);
d = -0.5;
}
if (d == -0.5 && number_oddp(q)) {
vs_push(q);
q = one_minus(q);
d = 0.5;
}
vs_base = vs_top;
vs_push(q);
vs_push(make_shortfloat((shortfloat)d));
return;
case t_longfloat:
d = lf(x);
if (d >= 0.0)
q = double_to_integer(d + 0.5);
else
q = double_to_integer(d - 0.5);
d -= number_to_double(q);
if (d == 0.5 && number_oddp(q)) {
vs_push(q);
q = one_plus(q);
d = -0.5;
}
if (d == -0.5 && number_oddp(q)) {
vs_push(q);
q = one_minus(q);
d = 0.5;
}
vs_base = vs_top;
vs_push(q);
vs_push(make_longfloat(d));
return;
default:
FEwrong_type_argument(TSor_rational_float, x);
}
TWO_ARG:
if (n > 2)
too_many_arguments();
x = vs_base[0];
y = vs_base[1];
check_type_or_rational_float(&vs_base[0]);
check_type_or_rational_float(&vs_base[1]);
q = number_divide(x, y);
vs_push(q);
switch (type_of(q)) {
case t_fixnum:
case t_bignum:
vs_base = vs_top;
vs_push(q);
vs_push(small_fixnum(0));
break;
case t_ratio:
RATIO:
q1 = integer_divide1(q->rat.rat_num, q->rat.rat_den);
vs_push(q1);
r = number_minus(q, q1);
vs_push(r);
if ((c = number_compare(r, plus_half)) > 0 ||
(c == 0 && number_oddp(q1)))
q1 = one_plus(q1);
if ((c = number_compare(r, minus_half)) < 0 ||
(c == 0 && number_oddp(q1)))
q1 = one_minus(q1);
vs_base = vs_top;
vs_push(q1);
vs_push(remainder(x, y, q1));
return;
case t_shortfloat:
case t_longfloat:
d = number_to_double(q);
if (d >= 0.0)
q1 = double_to_integer(d + 0.5);
else
q1 = double_to_integer(d - 0.5);
d -= number_to_double(q1);
if (d == 0.5 && number_oddp(q1)) {
vs_push(q1);
q1 = one_plus(q1);
}
if (d == -0.5 && number_oddp(q1)) {
vs_push(q1);
q1 = one_minus(q1);
}
vs_base = vs_top;
vs_push(q1);
vs_push(remainder(x, y, q1));
return;
}
}
Lmod()
{
check_arg(2);
Lfloor();
vs_base++;
}
Lrem()
{
check_arg(2);
Ltruncate();
vs_base++;
}
Ldecode_float()
{
object x;
double d;
int e, s;
check_arg(1);
check_type_float(&vs_base[0]);
x = vs_base[0];
if (type_of(x) == t_shortfloat)
d = sf(x);
else
d = lf(x);
if (d >= 0.0)
s = 1;
else {
d = -d;
s = -1;
}
e = double_exponent(d);
d = set_exponent(d, 0);
vs_top = vs_base;
if (type_of(x) == t_shortfloat) {
vs_push(make_shortfloat((shortfloat)d));
vs_push(make_fixnum(e));
vs_push(make_shortfloat((shortfloat)s));
} else {
vs_push(make_longfloat(d));
vs_push(make_fixnum(e));
vs_push(make_longfloat((double)s));
}
}
Lscale_float()
{
object x;
double d;
int e, k;
check_arg(2);
check_type_float(&vs_base[0]);
x = vs_base[0];
if (type_of(vs_base[1]) == t_fixnum)
k = fix(vs_base[1]);
else
FEerror("~S is an illegal exponent.", 1, vs_base[1]);
if (type_of(x) == t_shortfloat)
d = sf(x);
else
d = lf(x);
e = double_exponent(d) + k;
#ifdef VAX
if (e <= -128 || e >= 128)
#endif
#ifdef IBMRT
#endif
#ifdef IEEEFLOAT
if (type_of(x) == t_shortfloat && (e <= -126 || e >= 130) ||
type_of(x) == t_longfloat && (e <= -1022 || e >= 1026))
#endif
#ifdef MV
#endif
#ifdef S3000
if (e < -64 || e >= 64)
#endif
FEerror("~S is an illegal exponent.", 1, vs_base[1]);
d = set_exponent(d, e);
vs_pop;
if (type_of(x) == t_shortfloat)
vs_base[0] = make_shortfloat((shortfloat)d);
else
vs_base[0] = make_longfloat(d);
}
Lfloat_radix()
{
check_arg(1);
check_type_float(&vs_base[0]);
#ifdef VAX
vs_base[0] = small_fixnum(2);
#endif
#ifdef IBMRT
#endif
#ifdef IEEEFLOAT
vs_base[0] = small_fixnum(2);
#endif
#ifdef MV
#endif
#ifdef S3000
vs_base[0] = small_fixnum(16);
#endif
}
Lfloat_sign()
{
object x;
int narg;
double d, f;
narg = vs_top - vs_base;
if (narg < 1)
too_few_arguments();
else if (narg > 2)
too_many_arguments();
check_type_float(&vs_base[0]);
x = vs_base[0];
if (type_of(x) == t_shortfloat)
d = sf(x);
else
d = lf(x);
if (narg == 1)
f = 1.0;
else {
check_type_float(&vs_base[1]);
x = vs_base[1];
if (type_of(x) == t_shortfloat)
f = sf(x);
else
f = lf(x);
if (f < 0.0)
f = -f;
}
if (d < 0.0)
f = -f;
vs_top = vs_base;
if (type_of(x) == t_shortfloat)
vs_push(make_shortfloat((shortfloat)f));
else
vs_push(make_longfloat(f));
}
Lfloat_digits()
{
check_arg(1);
check_type_float(&vs_base[0]);
if (type_of(vs_base[0]) == t_shortfloat)
vs_base[0] = small_fixnum(24);
else
vs_base[0] = small_fixnum(53);
}
Lfloat_precision()
{
object x;
check_arg(1);
check_type_float(&vs_base[0]);
x = vs_base[0];
if (type_of(x) == t_shortfloat)
if (sf(x) == 0.0)
vs_base[0] = small_fixnum(0);
else
vs_base[0] = small_fixnum(24);
else
if (lf(x) == 0.0)
vs_base[0] = small_fixnum(0);
else
#ifdef VAX
vs_base[0] = small_fixnum(53);
#endif
#ifdef IBMRT
#endif
#ifdef IEEEFLOAT
vs_base[0] = small_fixnum(53);
#endif
#ifdef MV
#endif
#ifdef S3000
vs_base[0] = small_fixnum(53);
#endif
}
Linteger_decode_float()
{
object x;
int h, l, e, s;
check_arg(1);
check_type_float(&vs_base[0]);
x = vs_base[0];
vs_base = vs_top;
if (type_of(x) == t_longfloat) {
integer_decode_double(lf(x), &h, &l, &e, &s);
if (h != 0)
vs_push(bignum2(h, l));
else
vs_push(make_fixnum(l));
vs_push(make_fixnum(e));
vs_push(make_fixnum(s));
} else {
integer_decode_float((double)(sf(x)), &h, &e, &s);
vs_push(make_fixnum(h));
vs_push(make_fixnum(e));
vs_push(make_fixnum(s));
}
}
Lcomplex()
{
object x, r, i;
int narg;
narg = vs_top - vs_base;
if (narg < 1)
too_few_arguments();
if (narg > 2)
too_many_arguments();
check_type_or_rational_float(&vs_base[0]);
r = vs_base[0];
if (narg == 1)
i = small_fixnum(0);
else {
check_type_or_rational_float(&vs_base[1]);
i = vs_base[1];
}
vs_top = vs_base;
vs_push(make_complex(r, i));
}
Lrealpart()
{
object r, x;
check_arg(1);
check_type_number(&vs_base[0]);
x = vs_base[0];
if (type_of(x) == t_complex)
vs_base[0] = x->cmp.cmp_real;
}
Limagpart()
{
object x;
check_arg(1);
check_type_number(&vs_base[0]);
x = vs_base[0];
switch (type_of(x)) {
case t_fixnum:
case t_bignum:
case t_ratio:
vs_base[0] = small_fixnum(0);
break;
case t_shortfloat:
vs_base[0] = shortfloat_zero;
break;
case t_longfloat:
vs_base[0] = longfloat_zero;
break;
case t_complex:
vs_base[0] = x->cmp.cmp_imag;
break;
}
}
static float sf1,sf2;
static sf_eql()
{return(sf1==sf2);}
static lf_eql(a,b)
double a,b;
{return(a==b);}
#define LF_EQL(a,b) lf_eql((double)(a),(double)(b))
#define SF_EQL(a,b) (sf1=a,sf2=b,sf_eql())
init_num_co()
{
int l[2];
float smallest_float, biggest_float;
double smallest_double, biggest_double;
float float_epsilon, float_negative_epsilon;
double double_epsilon, double_negative_epsilon;
#ifdef VAX
l[0] = 0x80;
l[1] = 0;
smallest_float = *(float *)l;
smallest_double = *(double *)l;
#endif
#ifdef IEEEFLOAT
#ifdef NS32K
#else
((int *) &smallest_float)[0]= 1;
((int *) &smallest_double)[HIND] = 0;
((int *) &smallest_double)[LIND] = 1;
#endif
#endif
#ifdef MV
#endif
#ifdef S3000
l[0] = 0x00100000;
l[1] = 0;
smallest_float = *(float *)l;
smallest_double = *(double *)l;
#endif
#ifdef VAX
l[0] = 0xffff7fff;
l[1] = 0xffffffff;
biggest_float = *(float *)l;
biggest_double = *(double *)l;
#endif
#ifdef IBMRT
#endif
#ifdef IEEEFLOAT
#ifdef NS32K
#else
((int *) &biggest_float)[0]= 0x7f7fffff;
((int *) &biggest_double)[HIND] = 0x7fefffff;
((int *) &biggest_double)[LIND] = 0xffffffff;
#ifdef BAD_FPCHIP
/* &&&& I am adding junk values to get past debugging */
biggest_float = 1.0e37;
smallest_float = 1.0e-37;
biggest_double = 1.0e308;
smallest_double = 1.0e-308;
printf("\n Used fake values for float max and mins ");
#endif
#endif
#endif
#ifdef MV
#endif
#if defined(S3000) && ~defined(DBL_MAX_10_EXP)
l[0] = 0x7fffffff;
l[1] = 0xffffffff;
l[0] = 0x7fffffff;
l[1] = 0xffffffff;
biggest_float = *(float *)l;
biggest_float = *(float *)l;
biggest_float = *(float *)l;
biggest_float = 0.0;
biggest_float = biggest_float + 1.0;
biggest_float = biggest_float + 2.0;
biggest_float = *(float *)l;
biggest_float = *(float *)l;
strcmp("I don't like", "DATA GENERAL.");
biggest_float = *(float *)l;
biggest_double = *(double *)l;
biggest_double = *(double *)l;
biggest_double = *(double *)l;
biggest_double = 0.0;
biggest_double = biggest_double + 1.0;
biggest_double = biggest_double + 2.0;
biggest_double = *(double *)l;
biggest_double = *(double *)l;
strcmp("I don't like", "DATA GENERAL.");
biggest_double = *(double *)l;
#endif
#ifdef DBL_MAX_10_EXP
biggest_double = DBL_MAX;
smallest_double = DBL_MIN;
smallest_float = FLT_MIN;
biggest_float = FLT_MAX;
#endif
/* We want the smallest number not satisfying something,
and so we go quickly down, and then back up. We have
to use a function call for test, since in line code may keep
too much precision, while the usual lisp eql,is not
in line.
We use SMALL as a multiple to come back up by.
*/
#define SMALL 1.05
for (float_epsilon = 1.0;
!SF_EQL((float)(1.0 + float_epsilon),(float)1.0);
float_epsilon /= 2.0)
;
while(SF_EQL((float)(1.0 + float_epsilon),(float)1.0))
float_epsilon=float_epsilon*SMALL;
for (float_negative_epsilon = 1.0;
!SF_EQL((float)(1.0 - float_negative_epsilon) ,(float)1.0);
float_negative_epsilon /= 2.0)
;
while(SF_EQL((float)(1.0 - float_negative_epsilon) ,(float)1.0))
float_negative_epsilon=float_negative_epsilon*SMALL;
for (double_epsilon = 1.0;
!(LF_EQL(1.0 + double_epsilon, 1.0));
double_epsilon /= 2.0)
;
while((LF_EQL(1.0 + double_epsilon, 1.0)))
double_epsilon=double_epsilon*SMALL;
;
for (double_negative_epsilon = 1.0;
!LF_EQL(1.0 - double_negative_epsilon , 1.0);
double_negative_epsilon /= 2.0)
;
while(LF_EQL(1.0 - double_negative_epsilon , 1.0))
double_negative_epsilon=double_negative_epsilon*SMALL;
;
make_constant("MOST-POSITIVE-SHORT-FLOAT",
make_shortfloat(biggest_float));
make_constant("LEAST-POSITIVE-SHORT-FLOAT",
make_shortfloat(smallest_float));
make_constant("LEAST-NEGATIVE-SHORT-FLOAT",
make_shortfloat(-smallest_float));
make_constant("MOST-NEGATIVE-SHORT-FLOAT",
make_shortfloat(-biggest_float));
make_constant("MOST-POSITIVE-SINGLE-FLOAT",
make_longfloat(biggest_double));
make_constant("LEAST-POSITIVE-SINGLE-FLOAT",
make_longfloat(smallest_double));
make_constant("LEAST-NEGATIVE-SINGLE-FLOAT",
make_longfloat(-smallest_double));
make_constant("MOST-NEGATIVE-SINGLE-FLOAT",
make_longfloat(-biggest_double));
make_constant("MOST-POSITIVE-DOUBLE-FLOAT",
make_longfloat(biggest_double));
make_constant("LEAST-POSITIVE-DOUBLE-FLOAT",
make_longfloat(smallest_double));
make_constant("LEAST-NEGATIVE-DOUBLE-FLOAT",
make_longfloat(-smallest_double));
make_constant("MOST-NEGATIVE-DOUBLE-FLOAT",
make_longfloat(-biggest_double));
make_constant("MOST-POSITIVE-LONG-FLOAT",
make_longfloat(biggest_double));
make_constant("LEAST-POSITIVE-LONG-FLOAT",
make_longfloat(smallest_double));
make_constant("LEAST-NEGATIVE-LONG-FLOAT",
make_longfloat(-smallest_double));
make_constant("MOST-NEGATIVE-LONG-FLOAT",
make_longfloat(-biggest_double));
make_constant("SHORT-FLOAT-EPSILON",
make_shortfloat(float_epsilon));
make_constant("SINGLE-FLOAT-EPSILON",
make_longfloat(double_epsilon));
make_constant("DOUBLE-FLOAT-EPSILON",
make_longfloat(double_epsilon));
make_constant("LONG-FLOAT-EPSILON",
make_longfloat(double_epsilon));
make_constant("SHORT-FLOAT-NEGATIVE-EPSILON",
make_shortfloat(float_negative_epsilon));
make_constant("SINGLE-FLOAT-NEGATIVE-EPSILON",
make_longfloat(double_negative_epsilon));
make_constant("DOUBLE-FLOAT-NEGATIVE-EPSILON",
make_longfloat(double_negative_epsilon));
make_constant("LONG-FLOAT-NEGATIVE-EPSILON",
make_longfloat(double_negative_epsilon));
plus_half = make_ratio(small_fixnum(1), small_fixnum(2));
enter_mark_origin(&plus_half);
minus_half = make_ratio(small_fixnum(-1), small_fixnum(2));
enter_mark_origin(&minus_half);
make_function("FLOAT", Lfloat);
make_function("NUMERATOR", Lnumerator);
make_function("DENOMINATOR", Ldenominator);
make_function("FLOOR", Lfloor);
make_function("CEILING", Lceiling);
make_function("TRUNCATE", Ltruncate);
make_function("ROUND", Lround);
make_function("MOD", Lmod);
make_function("REM", Lrem);
make_function("DECODE-FLOAT", Ldecode_float);
make_function("SCALE-FLOAT", Lscale_float);
make_function("FLOAT-RADIX", Lfloat_radix);
make_function("FLOAT-SIGN", Lfloat_sign);
make_function("FLOAT-DIGITS", Lfloat_digits);
make_function("FLOAT-PRECISION", Lfloat_precision);
make_function("INTEGER-DECODE-FLOAT", Linteger_decode_float);
make_function("COMPLEX", Lcomplex);
make_function("REALPART", Lrealpart);
make_function("IMAGPART", Limagpart);
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.