CSLbool minusp(Lisp_Object a)
{
switch ((int)a & TAG_BITS)
{
case TAG_FIXNUM:
return ((int32_t)a < 0);
case TAG_SFLOAT:
{ Float_union aa;
aa.i = a - TAG_SFLOAT;
return (aa.f < 0.0);
}
case TAG_NUMBERS:
{ int32_t ha = type_of_header(numhdr(a));
switch (ha)
{
case TYPE_BIGNUM:
{ int32_t l = (bignum_length(a)-CELL-4)/4;
return ((int32_t)bignum_digits(a)[l] < (int32_t)0);
}
case TYPE_RATNUM:
return minusp(numerator(a));
default:
aerror1("Bad arg for minusp", a);
return 0;
}
}
case TAG_BOXFLOAT:
{ double d = float_of_number(a);
return (d < 0.0);
}
default:
aerror1("Bad arg for minusp", a);
return 0;
}
}
static Lisp_Object Lrealpart(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!is_number(a)) return aerror1("realpart", a);
if (is_numbers(a) && is_complex(a))
return onevalue(real_part(a));
else return onevalue(a);
}
static Lisp_Object Lnumerator(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!is_number(a)) return aerror1("numerator", a);
if (is_numbers(a) && is_ratio(a))
return onevalue(numerator(a));
else return onevalue(a);
}
static Lisp_Object Ldenominator(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!is_number(a)) return aerror1("denominator", a);
if (is_numbers(a) && is_ratio(a))
return onevalue(denominator(a));
else return onevalue(fixnum_of_int(1));
}
static Lisp_Object Limagpart(Lisp_Object nil, Lisp_Object a)
{
CSL_IGNORE(nil);
if (!is_number(a)) return aerror1("imagpart", a);
if (is_numbers(a) && is_complex(a))
return onevalue(imag_part(a));
/* /* the 0.0 returned here ought to be the same type as a has */
else return onevalue(fixnum_of_int(0));
}
static Lisp_Object Lfloat_sign1(Lisp_Object nil, Lisp_Object a)
{
double d = float_of_number(a);
CSL_IGNORE(nil);
if (d < 0.0) d = -1.0; else d = 1.0;
#ifdef COMMON
if (is_sfloat(a)) return onevalue(make_sfloat(d));
else
#endif
if (!is_bfloat(a)) return aerror1("bad arg for float-sign", a);
else return onevalue(make_boxfloat(d, type_of_header(flthdr(a))));
}
static Lisp_Object Lscale_float(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
double d = float_of_number(a);
CSL_IGNORE(nil);
if (!is_fixnum(b)) return aerror("scale-float");
d = ldexp(d, int_of_fixnum(b));
#ifdef COMMON
if (is_sfloat(a)) return onevalue(make_sfloat(d));
else
#endif
if (!is_bfloat(a)) return aerror1("bad arg for scale-float", a);
else return onevalue(make_boxfloat(d, type_of_header(flthdr(a))));
}
CSLbool plusp(Lisp_Object a)
{
switch ((int)a & TAG_BITS)
{
case TAG_FIXNUM:
return (a > fixnum_of_int(0));
case TAG_SFLOAT:
{ Float_union aa;
aa.i = a - TAG_SFLOAT;
return (aa.f > 0.0);
}
case TAG_NUMBERS:
{ int32_t ha = type_of_header(numhdr(a));
switch (ha)
{
case TYPE_BIGNUM:
{ int32_t l = (bignum_length(a)-CELL-4)/4;
/* This is OK because a bignum can never have the value zero */
return ((int32_t)bignum_digits(a)[l] >= (int32_t)0);
}
case TYPE_RATNUM:
return plusp(numerator(a));
default:
aerror1("Bad arg for plusp", a);
return 0;
}
}
case TAG_BOXFLOAT:
{ double d = float_of_number(a);
return (d > 0.0);
}
default:
aerror1("Bad arg for plusp", a);
return 0;
}
}
static Lisp_Object Lconjugate(Lisp_Object nil, Lisp_Object a)
{
if (!is_number(a)) return aerror1("conjugate", a);
if (is_numbers(a) && is_complex(a))
{ Lisp_Object r = real_part(a),
i = imag_part(a);
push(r);
i = negate(i);
pop(r);
errexit();
a = make_complex(r, i);
errexit();
return onevalue(a);
}
else return onevalue(a);
}
static Lisp_Object MS_CDECL Lboole(Lisp_Object nil, int nargs, ...)
{
Lisp_Object r, op, a, b;
va_list aa;
argcheck(nargs, 3, "boole");
va_start(aa, nargs);
op = va_arg(aa, Lisp_Object);
a = va_arg(aa, Lisp_Object);
b = va_arg(aa, Lisp_Object);
va_end(aa);
switch (op)
{
case fixnum_of_int(boole_clr):
return onevalue(fixnum_of_int(0));
case fixnum_of_int(boole_and):
r = logand2(a, b);
break;
case fixnum_of_int(boole_andc2):
push(a);
b = lognot(b);
pop(a);
errexit();
r = logand2(a, b);
break;
case fixnum_of_int(boole_1):
return onevalue(a);
case fixnum_of_int(boole_andc1):
push(b);
a = lognot(a);
pop(b);
errexit();
r = logand2(a, b);
break;
case fixnum_of_int(boole_2):
return onevalue(b);
case fixnum_of_int(boole_xor):
r = logxor2(a, b);
break;
case fixnum_of_int(boole_ior):
r = logior2(a, b);
break;
case fixnum_of_int(boole_nor):
a = logior2(a, b);
errexit();
r = lognot(a);
break;
case fixnum_of_int(boole_eqv):
r = logeqv2(a, b);
break;
case fixnum_of_int(boole_c2):
r = lognot(b);
break;
case fixnum_of_int(boole_orc2):
b = lognot(b);
errexit();
r = logior2(a, b);
break;
case fixnum_of_int(boole_c1):
r = lognot(a);
break;
case fixnum_of_int(boole_orc1):
push(b);
a = lognot(a);
pop(b);
errexit();
r = logior2(a, b);
break;
case fixnum_of_int(boole_nand):
a = logand2(a, b);
errexit();
r = lognot(a);
break;
case fixnum_of_int(boole_set):
return onevalue(fixnum_of_int(-1));
default:
return aerror1("bad arg for boole", op);
}
errexit();
return onevalue(r);
}
static Lisp_Object Lbyte_size(Lisp_Object nil, Lisp_Object a)
{
if (!consp(a)) return aerror1("byte-size", a);
else return onevalue(qcar(a));
}
static Lisp_Object Lbyte_position(Lisp_Object nil, Lisp_Object a)
{
if (!consp(a)) return aerror1("byte-position", a);
else return onevalue(qcdr(a));
}
Lisp_Object modulus(Lisp_Object a, Lisp_Object b)
{
switch ((int)a & TAG_BITS)
{
case TAG_FIXNUM:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
/*
* This is where fixnum % fixnum arithmetic happens - the case I most want to
* make efficient.
*/
{ int32_t p = int_of_fixnum(a);
int32_t q = int_of_fixnum(b);
if (q == 0) return aerror2("bad arg for mod", a, b);
p = p % q;
if (q < 0)
{ if (p > 0) p += q;
}
else if (p < 0) p += q;
/* No overflow is possible in a modulus operation */
return fixnum_of_int(p);
}
/*
* Common Lisp defines a meaning for the modulus function when applied
* to floating point values - so there is a whole pile of mess here to
* support that. Standard Lisp is only concerned with fixnums and
* bignums.
*/
case TAG_SFLOAT:
return modis(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return modib(a, b);
case TYPE_RATNUM:
return modir(a, b);
default:
return aerror1("Bad arg for mod", b);
}
}
case TAG_BOXFLOAT:
return modif(a, b);
default:
return aerror1("Bad arg for mod", b);
}
case TAG_SFLOAT:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return modsi(a, b);
case TAG_SFLOAT:
{ Float_union aa, bb;
aa.i = a - TAG_SFLOAT;
bb.i = b - TAG_SFLOAT;
aa.f = (float) (aa.f + bb.f);
return (aa.i & ~(int32_t)0xf) + TAG_SFLOAT;
}
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return modsb(a, b);
case TYPE_RATNUM:
return modsr(a, b);
default:
return aerror1("Bad arg for mod", b);
}
}
case TAG_BOXFLOAT:
return modsf(a, b);
default:
return aerror1("Bad arg for mod", b);
}
case TAG_NUMBERS:
{ int32_t ha = type_of_header(numhdr(a));
switch (ha)
{
case TYPE_BIGNUM:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return modbi(a, b);
case TAG_SFLOAT:
return modbs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return modbb(a, b);
case TYPE_RATNUM:
return modbr(a, b);
default:
return aerror1("Bad arg for mod", b);
}
}
case TAG_BOXFLOAT:
return modbf(a, b);
default:
return aerror1("Bad arg for mod", b);
}
case TYPE_RATNUM:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return modri(a, b);
case TAG_SFLOAT:
return modrs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return modrb(a, b);
case TYPE_RATNUM:
return modrr(a, b);
default:
return aerror1("Bad arg for mod", b);
}
}
case TAG_BOXFLOAT:
return modrf(a, b);
default:
return aerror1("Bad arg for mod", b);
}
default:
return aerror1("Bad arg for mod", a);
}
}
case TAG_BOXFLOAT:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return modfi(a, b);
case TAG_SFLOAT:
return modfs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return modfb(a, b);
case TYPE_RATNUM:
return modfr(a, b);
default:
return aerror1("Bad arg for mod", b);
}
}
case TAG_BOXFLOAT:
return ccl_modff(a, b);
default:
return aerror1("Bad arg for mod", b);
}
default:
return aerror1("Bad arg for mod", a);
}
}
Lisp_Object Cremainder(Lisp_Object a, Lisp_Object b)
{
int32_t c;
switch ((int)a & TAG_BITS)
{
case TAG_FIXNUM:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
/*
* This is where fixnum % fixnum arithmetic happens - the case I most want to
* make efficient.
*/
if (b == fixnum_of_int(0))
return aerror2("bad arg for remainder", a, b);
/* No overflow is possible in a remaindering operation */
{ int32_t aa = int_of_fixnum(a);
int32_t bb = int_of_fixnum(b);
c = aa % bb;
/*
* C does not specify just what happens when % is used with negative
* operands (except maybe if the division went exactly), so here I do
* some adjusting, assuming that the quotient returned was one of the
* integral values surrounding the exact result.
*/
if (aa < 0)
{ if (c > 0) c -= bb;
}
else if (c < 0) c += bb;
return fixnum_of_int(c);
}
/*
* Common Lisp defines a meaning for the remainder function when applied
* to floating point values - so there is a whole pile of mess here to
* support that. Standard Lisp is only concerned with fixnums and
* bignums, but can tolerate the extra generality.
*/
case TAG_SFLOAT:
return remis(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
/*
* When I divide a fixnum a by a bignum b the remainder is a except in
* the case that a = 0xf8000000 and b = 0x08000000 in which case the
* answer is zero.
*/
if (int_of_fixnum(a) == fix_mask &&
bignum_length(b) == CELL+4 &&
bignum_digits(b)[0] == 0x08000000)
return fixnum_of_int(0);
else return a;
case TYPE_RATNUM:
return remir(a, b);
default:
return aerror1("Bad arg for remainder", b);
}
}
case TAG_BOXFLOAT:
return remif(a, b);
/*
case TAG_BOXFLOAT:
{ double v = (double) int_of_fixnum(a);
double u = float_of_number(b);
v = v - (v/u)*u;
return make_boxfloat(v, TYPE_DOUBLE_FLOAT);
}
*/
default:
return aerror1("Bad arg for remainder", b);
}
case TAG_SFLOAT:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return remsi(a, b);
case TAG_SFLOAT:
{ Float_union aa, bb;
aa.i = a - TAG_SFLOAT;
bb.i = b - TAG_SFLOAT;
aa.f = (float) (aa.f + bb.f);
return (aa.i & ~(int32_t)0xf) + TAG_SFLOAT;
}
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return remsb(a, b);
case TYPE_RATNUM:
return remsr(a, b);
default:
return aerror1("Bad arg for remainder", b);
}
}
case TAG_BOXFLOAT:
return remsf(a, b);
default:
return aerror1("Bad arg for remainder", b);
}
case TAG_NUMBERS:
{ int32_t ha = type_of_header(numhdr(a));
switch (ha)
{
case TYPE_BIGNUM:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return rembi(a, b);
case TAG_SFLOAT:
return rembs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return rembb(a, b);
case TYPE_RATNUM:
return rembr(a, b);
default:
return aerror1("Bad arg for remainder", b);
}
}
case TAG_BOXFLOAT:
return rembf(a, b);
default:
return aerror1("Bad arg for remainder", b);
}
case TYPE_RATNUM:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return remri(a, b);
case TAG_SFLOAT:
return remrs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return remrb(a, b);
case TYPE_RATNUM:
return remrr(a, b);
default:
return aerror1("Bad arg for remainder", b);
}
}
case TAG_BOXFLOAT:
return remrf(a, b);
default:
return aerror1("Bad arg for remainder", b);
}
default:
return aerror1("Bad arg for remainder", a);
}
}
case TAG_BOXFLOAT:
switch ((int)b & TAG_BITS)
{
/*
case TAG_FIXNUM:
{ double u = (double) int_of_fixnum(b);
double v = float_of_number(a);
v = v - (v/u)*u;
return make_boxfloat(v, TYPE_DOUBLE_FLOAT);
}
case TAG_BOXFLOAT:
{ double u = float_of_number(b);
double v = float_of_number(a);
v = v - (v/u)*u;
return make_boxfloat(v, TYPE_DOUBLE_FLOAT);
}
*/
case TAG_FIXNUM:
return remfi(a, b);
case TAG_SFLOAT:
return remfs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return remfb(a, b);
case TYPE_RATNUM:
return remfr(a, b);
default:
return aerror1("Bad arg for remainder", b);
}
}
case TAG_BOXFLOAT:
return remff(a, b);
default:
return aerror1("Bad arg for remainder", b);
}
default:
return aerror1("Bad arg for remainder", a);
}
}
Lisp_Object negate(Lisp_Object a)
{
#ifdef COMMON
Lisp_Object nil; /* needed for errexit() */
#endif
switch ((int)a & TAG_BITS)
{
case TAG_FIXNUM:
{ int32_t aa = -int_of_fixnum(a);
/*
* negating the number -#x8000000 (which is a fixnum) yields a value
* which just fails to be a fixnum.
*/
if (aa != 0x08000000) return fixnum_of_int(aa);
else return make_one_word_bignum(aa);
}
#ifdef COMMON
case TAG_SFLOAT:
{ Float_union aa;
aa.i = a - TAG_SFLOAT;
aa.f = (float) (-aa.f);
return (aa.i & ~(int32_t)0xf) + TAG_SFLOAT;
}
#endif
case TAG_NUMBERS:
{ int32_t ha = type_of_header(numhdr(a));
switch (ha)
{
case TYPE_BIGNUM:
return negateb(a);
#ifdef COMMON
case TYPE_RATNUM:
{ Lisp_Object n = numerator(a),
d = denominator(a);
push(d);
n = negate(n);
pop(d);
errexit();
return make_ratio(n, d);
}
case TYPE_COMPLEX_NUM:
{ Lisp_Object r = real_part(a),
i = imag_part(a);
push(i);
r = negate(r);
pop(i);
errexit();
push(r);
i = negate(i);
pop(r);
errexit();
return make_complex(r, i);
}
#endif
default:
return aerror1("bad arg for minus", a);
}
}
case TAG_BOXFLOAT:
{ double d = float_of_number(a);
return make_boxfloat(-d, type_of_header(flthdr(a)));
}
default:
return aerror1("bad arg for minus", a);
}
}
Lisp_Object plus2(Lisp_Object a, Lisp_Object b)
/*
* I probably want to change the specification of plus2 so that the fixnum +
* fixnum case is always expected to be done before the main body of the code
* is entered. Well maybe even if I do that it then costs very little to
* include the fixnum code here as well, so I will not delete it.
*/
{
switch ((int)a & TAG_BITS)
{
case TAG_FIXNUM:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
/*
* This is where fixnum + fixnum arithmetic happens - the case I most want to
* make efficient. Note that even if this becomes a bignum it can only be a
* one word one.
*/
{ int32_t r = int_of_fixnum(a) + int_of_fixnum(b);
int32_t t = r & fix_mask;
if (t == 0 || t == fix_mask) return fixnum_of_int(r);
else return make_one_word_bignum(r);
}
#ifdef COMMON
case TAG_SFLOAT:
return plusis(a, b);
#endif
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return plusib(a, b);
#ifdef COMMON
case TYPE_RATNUM:
return plusir(a, b);
case TYPE_COMPLEX_NUM:
return plusic(a, b);
#endif
default:
return aerror1("bad arg for plus", b);
}
}
case TAG_BOXFLOAT:
return plusif(a, b);
default:
return aerror1("bad arg for plus", b);
}
#ifdef COMMON
case TAG_SFLOAT:
switch (b & TAG_BITS)
{
case TAG_FIXNUM:
return plussi(a, b);
case TAG_SFLOAT:
{ Float_union aa, bb;
aa.i = a - TAG_SFLOAT;
bb.i = b - TAG_SFLOAT;
aa.f = (float)(aa.f + bb.f);
return (aa.i & ~(int32_t)0xf) + TAG_SFLOAT;
}
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return plussb(a, b);
case TYPE_RATNUM:
return plussr(a, b);
case TYPE_COMPLEX_NUM:
return plussc(a, b);
default:
return aerror1("bad arg for plus", b);
}
}
case TAG_BOXFLOAT:
return plussf(a, b);
default:
return aerror1("bad arg for plus", b);
}
#endif
case TAG_NUMBERS:
{ int32_t ha = type_of_header(numhdr(a));
switch (ha)
{
case TYPE_BIGNUM:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return plusbi(a, b);
#ifdef COMMON
case TAG_SFLOAT:
return plusbs(a, b);
#endif
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return plusbb(a, b);
#ifdef COMMON
case TYPE_RATNUM:
return plusbr(a, b);
case TYPE_COMPLEX_NUM:
return plusbc(a, b);
#endif
default:
return aerror1("bad arg for plus", b);
}
}
case TAG_BOXFLOAT:
return plusbf(a, b);
default:
return aerror1("bad arg for plus", b);
}
#ifdef COMMON
case TYPE_RATNUM:
switch (b & TAG_BITS)
{
case TAG_FIXNUM:
return plusri(a, b);
case TAG_SFLOAT:
return plusrs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return plusrb(a, b);
case TYPE_RATNUM:
return plusrr(a, b);
case TYPE_COMPLEX_NUM:
return plusrc(a, b);
default:
return aerror1("bad arg for plus", b);
}
}
case TAG_BOXFLOAT:
return plusrf(a, b);
default:
return aerror1("bad arg for plus", b);
}
case TYPE_COMPLEX_NUM:
switch (b & TAG_BITS)
{
case TAG_FIXNUM:
return plusci(a, b);
case TAG_SFLOAT:
return pluscs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return pluscb(a, b);
case TYPE_RATNUM:
return pluscr(a, b);
case TYPE_COMPLEX_NUM:
return pluscc(a, b);
default:
return aerror1("bad arg for plus", b);
}
}
case TAG_BOXFLOAT:
return pluscf(a, b);
default:
return aerror1("bad arg for plus", b);
}
#endif
default: return aerror1("bad arg for plus", a);
}
}
case TAG_BOXFLOAT:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return plusfi(a, b);
#ifdef COMMON
case TAG_SFLOAT:
return plusfs(a, b);
#endif
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return plusfb(a, b);
#ifdef COMMON
case TYPE_RATNUM:
return plusfr(a, b);
case TYPE_COMPLEX_NUM:
return plusfc(a, b);
#endif
default:
return aerror1("bad arg for plus", b);
}
}
case TAG_BOXFLOAT:
return plusff(a, b);
default:
return aerror1("bad arg for plus", b);
}
default:
return aerror1("bad arg for plus", a);
}
}
