/* $Header$ */
/*
* Copyright © 1988-2004 Keith Packard and Bart Massey.
* All Rights Reserved. See the file COPYING in this directory
* for licensing information.
*/
/*
* operators accepting values
*/
#include "nickle.h"
Value Void;
Value TrueVal, FalseVal;
volatile Bool aborting;
volatile Bool signaling;
#ifndef Numericp
Bool
Numericp (Rep t)
{
switch (t) {
case rep_int:
case rep_integer:
case rep_rational:
case rep_float:
return True;
default:;
}
return False;
}
#endif
#ifndef Integralp
Bool
Integralp (Rep t)
{
switch (t) {
case rep_int:
case rep_integer:
return True;
default:;
}
return False;
}
#endif
Bool
Zerop (Value av)
{
switch (ValueTag(av)) {
case rep_int:
return ValueInt(av) == 0;
case rep_integer:
return IntegerMag(av)->length == 0;
case rep_rational:
return av->rational.num->length == 0;
case rep_float:
return av->floats.mant->mag->length == 0;
default:;
}
return False;
}
Bool
Negativep (Value av)
{
switch (ValueTag(av)) {
case rep_int:
return ValueInt(av) < 0;
case rep_integer:
return IntegerSign(av) == Negative;
case rep_rational:
return av->rational.sign == Negative;
case rep_float:
return av->floats.mant->sign == Negative;
default:;
}
return False;
}
Bool
Evenp (Value av)
{
switch (ValueTag(av)) {
case rep_int:
return (ValueInt(av) & 1) == 0;
case rep_integer:
return NaturalEven (IntegerMag(av));
default:;
}
return False;
}
int
IntPart (Value av, char *error)
{
if (!ValueIsInt(av))
{
RaiseStandardException (exception_invalid_argument, error,
2, NewInt (0), av);
return 0;
}
return ValueInt(av);
}
Value
BinaryOperate (Value av, Value bv, BinaryOp operator)
{
if (ValueIsInt(av) && ValueIsInt(bv))
return IntBinaryOperate (av, bv, operator);
else
{
ENTER ();
Value ret;
ValueRep *arep = ValueRep(av), *brep = ValueRep(bv);
ValueRep *rep = 0;
if (arep->typecheck)
rep = (*arep->typecheck) (operator, av, bv, 1);
else if (brep->typecheck)
rep = (*brep->typecheck) (operator, av, bv, 1);
else if (arep == brep)
rep = arep;
else if (Numericp (ValueTag(av)) && Numericp (ValueTag(bv)))
{
if (ValueTag(av) < ValueTag(bv))
av = (*brep->promote) (av, bv);
else
bv = (*arep->promote) (bv, av);
rep = ValueRep(av);
}
else if (ValueIsUnion(av))
rep = arep;
else if (ValueIsUnion(bv))
rep = brep;
if (!rep || !rep->binary[operator])
{
if (operator == EqualOp)
RETURN (FalseVal);
RaiseStandardException (exception_invalid_binop_values,
"invalid operands",
2,
av, bv);
RETURN (Void);
}
if (aborting)
RETURN (Void);
ret = (*rep->binary[operator]) (av, bv, 1);
rep = ValueRep(ret);
if (rep->reduce)
ret = (*rep->reduce) (ret);
RETURN (ret);
}
}
Value
UnaryOperate (Value v, UnaryOp operator)
{
ENTER ();
Value ret;
ValueRep *rep = ValueRep(v);
if (!rep->unary[operator])
{
RaiseStandardException (exception_invalid_unop_value,
"invalid operand",
1, v);
RETURN (Void);
}
if (aborting)
RETURN (Void);
ret = (*rep->unary[operator])(v, 1);
rep = ValueRep(ret);
if (rep->reduce)
ret = (*rep->reduce) (ret);
RETURN (ret);
}
Value
Reduce (Value v)
{
ValueRep *rep = ValueRep(v);
if (rep->reduce)
v = (*rep->reduce) (v);
return v;
}
Value
NumericDiv (Value av, Value bv, int expandOk)
{
ENTER ();
RETURN (Floor (Divide (av, bv)));
}
Value
Negate (Value av)
{
return UnaryOperate (av, NegateOp);
}
Value
Floor (Value av)
{
return UnaryOperate (av, FloorOp);
}
Value
Ceil (Value av)
{
return UnaryOperate (av, CeilOp);
}
/*
* non primitive functions
*/
Value
Lnot (Value av)
{
ENTER ();
RETURN (Minus (Negate (av), One));
}
Value
Lxor (Value av, Value bv)
{
ENTER ();
RETURN (Land (Lnot (Land (av, bv)),
Lor (av, bv)));
}
Value
Not (Value av)
{
ENTER ();
if (True (av))
av = FalseVal;
else
av = TrueVal;
RETURN (av);
}
Value
Greater (Value av, Value bv)
{
return Less (bv, av);
}
Value
LessEqual (Value av, Value bv)
{
return Not (Less (bv, av));
}
Value
GreaterEqual (Value av, Value bv)
{
return Not (Less (av, bv));
}
Value
NotEqual (Value av, Value bv)
{
return Not (Equal (av, bv));
}
Value
Factorial (Value av)
{
ENTER ();
Value tv;
Value i;
StackPointer iref, tvref;
if (!Integralp (ValueTag(av)) || Negativep (av))
{
RaiseStandardException (exception_invalid_unop_value,
"invalid operand",
1,
av);
RETURN (Void);
}
/*
* A bit of reference magic here to avoid churning
* through megabytes. Build a couple of spots
* on the reference stack for the two intermediate
* values and then reuse them after each iteration
*/
tv = One;
i = One;
REFERENCE (tv);
tvref = STACK_TOP(MemStack);
REFERENCE (i);
iref = STACK_TOP(MemStack);
for (;;)
{
ENTER ();
if (aborting || False (Less (i, av)))
{
EXIT ();
break;
}
i = Plus (i, One);
tv = Times (i, tv);
EXIT ();
*iref = i;
*tvref = tv;
}
RETURN (tv);
}
Value
Truncate (Value av)
{
ENTER ();
if (Negativep (av))
av = Ceil (av);
else
av = Floor (av);
RETURN (av);
}
Value
Round (Value av)
{
ENTER ();
RETURN (Floor (Plus (av, NewRational (Positive, one_natural, two_natural))));
}
Value
Pow (Value av, Value bv)
{
ENTER ();
Value result;
if (!Numericp (ValueTag(av)) || !Numericp (ValueTag(bv)))
{
RaiseStandardException (exception_invalid_binop_values,
"invalid operands",
2,
av, bv);
RETURN (Void);
}
switch (ValueTag(bv)) {
case rep_int:
{
Value p;
int i;
int flip = 0;
i = ValueInt(bv);
if (i < 0)
{
i = -i;
flip = 1;
}
p = av;
result = One;
while (i) {
if (aborting)
RETURN (Void);
if (i & 1)
result = Times (result, p);
i >>= 1;
if (i)
p = Times (p, p);
}
if (flip)
result = Divide (One, result);
}
break;
case rep_integer:
{
Value p;
Natural *i;
Natural *two;
Natural *rem;
int flip = 0;
i = IntegerMag(bv);
if (IntegerSign(bv) == Negative)
flip = 1;
two = NewNatural (2);
p = av;
result = One;
while (!NaturalZero (i)) {
if (aborting)
RETURN (Void);
if (!NaturalEven (i))
result = Times (result, p);
i = NaturalDivide (i, two, &rem);
if (!NaturalZero (i))
p = Times (p, p);
}
if (flip)
result = Divide (One, result);
}
break;
default:
RaiseStandardException (exception_invalid_binop_values,
"non-integer pow right operand",
2, av, bv);
result = Void;
break;
}
RETURN (result);
}
Value
ShiftL (Value av, Value bv)
{
ENTER ();
if (!Integralp (ValueTag(av)) || !Integralp (ValueTag(bv)))
{
RaiseStandardException (exception_invalid_binop_values,
"non-integer << operands",
2, av, bv);
RETURN (Void);
}
if (Negativep (bv))
RETURN (ShiftR(av, Negate (bv)));
if (Zerop (bv))
RETURN(av);
if (ValueIsInt(bv))
{
Sign sign = Positive;
int b = ValueInt(bv);
if (ValueIsInt (av) && b < NICKLE_INT_BITS)
{
signed_digit rd = (signed_digit) ValueInt (av) << b;
if (rd > (signed_digit) MAX_NICKLE_INT || rd < (signed_digit) MIN_NICKLE_INT)
av = NewSignedDigitInteger (rd);
else
av = NewInt ((int) rd);
}
else
{
if (Negativep (av))
sign = Negative;
av = Reduce (NewInteger (sign,
NaturalLsl (IntegerMag(IntegerRep.promote (av,0)),
ValueInt(bv))));
}
}
else
{
av = Times (av, Pow (NewInt(2), bv));
}
RETURN (av);
}
Value
ShiftR (Value av, Value bv)
{
ENTER ();
if (!Integralp (ValueTag(av)) || !Integralp (ValueTag(bv)))
{
RaiseStandardException (exception_invalid_binop_values,
"non-integer >> operands",
2, av, bv);
RETURN (Void);
}
if (Negativep (bv))
RETURN (ShiftL(av, Negate (bv)));
if (Zerop (bv))
RETURN(av);
if (ValueIsInt(bv))
{
Sign sign = Positive;
int b = ValueInt(bv);
if (ValueIsInt (av) && b < NICKLE_INT_BITS)
{
av = NewInt (ValueInt (av) >> b);
}
else
{
if (Negativep (av))
{
av = Minus (av, Minus (ShiftL (One, bv), One));
sign = Negative;
}
av = Reduce (NewInteger (sign,
NaturalRsl (IntegerMag(IntegerRep.promote (av,0)),
b)));
}
}
else
{
av = Div (av, Pow (NewInt(2), bv));
}
RETURN (av);
}
Value
Gcd (Value av, Value bv)
{
ENTER ();
if (!Integralp (ValueTag(av)) || !Integralp (ValueTag(bv)))
{
RaiseStandardException (exception_invalid_binop_values,
"invalid gcd argument values",
2,
av, bv);
RETURN (Void);
}
RETURN (Reduce (NewInteger (Positive,
NaturalGcd (IntegerMag(IntegerRep.promote (av, 0)),
IntegerMag(IntegerRep.promote (bv, 0))))));
}
#ifdef GCD_DEBUG
Value
Bdivmod (Value av, Value bv)
{
ENTER ();
if (!Integralp (ValueTag(av)) || !Integralp (ValueTag(bv)))
{
RaiseStandardException (exception_invalid_binop_values,
"invalid gcd argument values",
2,
av, bv);
RETURN (Void);
}
RETURN (Reduce (NewInteger (Positive,
NaturalBdivmod (IntegerRep.promote (av, 0)->integer.mag,
IntegerRep.promote (bv, 0)->integer.mag))));
}
Value
KaryReduction (Value av, Value bv)
{
ENTER ();
if (!Integralp (ValueTag(av)) || !Integralp (ValueTag(bv)))
{
RaiseStandardException (exception_invalid_binop_values,
"invalid kary_reduction argument values",
2,
av, bv);
RETURN (Void);
}
RETURN (Reduce (NewInteger (Positive,
NaturalKaryReduction (IntegerRep.promote (av, 0)->integer.mag,
IntegerRep.promote (bv, 0)->integer.mag))));
}
#endif
StackObject *ValuePrintStack;
int ValuePrintLevel;
Bool
Print (Value f, Value v, char format, int base, int width, int prec, int fill)
{
int i;
Bool ret;
ValueRep *rep;
if (!v)
{
FilePuts (f, "<uninit>");
return True;
}
rep = ValueRep(v);
if (!rep->print)
return True;
for (i = 0; i < ValuePrintLevel; i++)
{
if (STACK_ELT(ValuePrintStack, i) == v)
{
FilePuts (f, "<recursive>");
return True;
}
}
STACK_PUSH (ValuePrintStack, v);
++ValuePrintLevel;
ret = (*rep->print) (f, v, format, base, width, prec, fill);
STACK_POP (ValuePrintStack);
--ValuePrintLevel;
return ret;
}
/*
* Make a deep copy of 'v'
*/
Value
CopyMutable (Value v)
{
ENTER ();
Value nv;
int i;
BoxPtr box, nbox;
int n;
switch (ValueTag(v)) {
case rep_array:
if (!v->array.resizable && ArrayValueBox(&v->array,0)->constant)
RETURN (v);
nv = NewArray (False, v->array.resizable, ArrayType(&v->array),
v->array.ndim, ArrayDims(&v->array));
for (i = 0; i < v->array.ndim; i++)
ArrayLimits(&nv->array)[i] = ArrayLimits(&v->array)[i];
if (v->array.resizable)
{
BoxPtr *o, *n;
int l = ArrayNvalues (&v->array);
o = BoxVectorBoxes (v->array.u.resize);
n = BoxVectorBoxes (nv->array.u.resize);
for (i = 0; i < l; i++)
{
BoxValueSet (*n, 0, Copy (BoxValueGet (*o, 0)));
n++;
o++;
}
RETURN(nv);
}
else
{
box = v->array.u.fix;
nbox = nv->array.u.fix;
n = ArrayNvalues (&v->array);
}
break;
case rep_struct:
if (v->structs.values->constant)
RETURN (v);
nv = NewStruct (v->structs.type, False);
box = v->structs.values;
nbox = nv->structs.values;
n = v->structs.type->nelements;
break;
case rep_union:
if (v->unions.value->constant)
RETURN (v);
nv = NewUnion (v->unions.type, False);
nv->unions.tag = v->unions.tag;
box = v->unions.value;
nbox = nv->unions.value;
n = 1;
break;
case rep_hash:
RETURN (HashCopy (v));
default:
RETURN (v);
}
for (i = 0; i < n; i++)
BoxValueSet (nbox, i, Copy (BoxValueGet (box, i)));
RETURN (nv);
}
#ifndef HAVE_C_INLINE
Value
Copy (Value v)
{
if (v && Mutablep (ValueTag(v)))
return CopyMutable (v);
return v;
}
#endif
Value
ValueEqual (Value a, Value b, int expandOk)
{
return a == b ? TrueVal : FalseVal;
}
Value
ValueHash (Value v)
{
ValueRep *rep;
if (!v)
return Zero;
rep = ValueRep(v);
if (!rep->hash)
return Zero;
return NewInt ((*rep->hash) (v) & MAX_NICKLE_INT);
}
#ifndef HAVE_C_INLINE
Value
Dereference (Value v)
{
if (!ValueIsRef(v))
{
RaiseStandardException (exception_invalid_unop_value,
"Not a reference",
1, v);
return Void;
}
return REFERENCE (RefValue (v));
}
#endif
static Value
UnitEqual (Value av, Value bv, int expandOk)
{
return TrueVal;
}
static Bool
UnitPrint (Value f, Value av, char format, int base, int width, int prec, int fill)
{
FilePuts (f, "<>");
return True;
}
ValueRep UnitRep = {
{ 0, 0, "UnitRep" }, /* data */
rep_void, /* tag */
{
0, /* Plus */
0, /* Minus */
0, /* Times */
0, /* Divide */
0, /* Div */
0, /* Mod */
0, /* Less */
UnitEqual, /* Equal */
0, /* Land */
0, /* Lor */
}, /* binary */
{ 0 }, /* unary */
0, 0,
UnitPrint, /* print */
};
static Value
NewVoid (void)
{
ENTER ();
Value ret;
ret = ALLOCATE (&UnitRep.data, sizeof (BaseValue));
RETURN (ret);
}
static Value
BoolEqual (Value av, Value bv, int expandOk)
{
return (av == TrueVal) == (bv == TrueVal) ? TrueVal : FalseVal;
}
static Bool
BoolPrint (Value f, Value av, char format, int base, int width, int prec, int fill)
{
FilePuts (f, av == TrueVal ? "true" : "false");
return True;
}
ValueRep BoolRep = {
{ 0, 0, "BoolRep" }, /* data */
rep_bool, /* tag */
{
0, /* Plus */
0, /* Minus */
0, /* Times */
0, /* Divide */
0, /* Div */
0, /* Mod */
0, /* Less */
BoolEqual, /* Equal */
0, /* Land */
0, /* Lor */
}, /* binary */
{ 0 }, /* unary */
0, 0,
BoolPrint, /* print */
};
static Value
NewBool (void)
{
ENTER ();
Value ret;
ret = ALLOCATE (&BoolRep.data, sizeof (BaseValue));
RETURN (ret);
}
/*
* This is a bit odd, but it's just a cache so
* erase it at GC time
*/
static void
DataCacheMark (void *object)
{
DataCache *dc = object;
memset (DataCacheValues (dc), '\0', sizeof (void *) * dc->size);
}
static DataType DataCacheType = { DataCacheMark, 0, "DataCacheType" };
DataCachePtr
NewDataCache (int size)
{
ENTER ();
DataCachePtr dc;
dc = (DataCachePtr) MemAllocate (&DataCacheType,
sizeof (DataCache) +
size * sizeof (void *));
dc->size = size;
memset (DataCacheValues(dc), '\0', size * sizeof (Value));
MemAddRoot (dc);
RETURN (dc);
}
int
ValueInit (void)
{
if (!AtomInit ())
return 0;
if (!ArrayInit ())
return 0;
if (!FileInit ())
return 0;
if (!HashInit ())
return 0;
if (!IntInit ())
return 0;
if (!NaturalInit ())
return 0;
if (!IntegerInit ())
return 0;
if (!RationalInit ())
return 0;
if (!FpartInit ())
return 0;
if (!RefInit ())
return 0;
if (!StringInit ())
return 0;
if (!StructInit ())
return 0;
if (!ForeignInit ())
return 0;
ValuePrintStack = StackCreate ();
MemAddRoot (ValuePrintStack);
Void = NewVoid ();
MemAddRoot (Void);
TrueVal = NewBool ();
MemAddRoot (TrueVal);
FalseVal = NewBool ();
MemAddRoot (FalseVal);
ValuePrintLevel = 0;
return 1;
}
syntax highlighted by Code2HTML, v. 0.9.1