static void *FindDefaultValue(
void *theEnv,
int theType,
CONSTRAINT_RECORD *theConstraints,
void *standardDefault)
{
struct expr *theList;
/*=====================================================*/
/* Look on the the allowed values list to see if there */
/* is a value of the requested type. Return the first */
/* value found of the requested type. */
/*=====================================================*/
theList = theConstraints->restrictionList;
while (theList != NULL)
{
if (theList->type == theType) return(theList->value);
theList = theList->nextArg;
}
/*=============================================================*/
/* If no specific values were available for the default value, */
/* and the type requested is a float or integer, then use the */
/* range attribute to select a default value. */
/*=============================================================*/
if (theType == INTEGER)
{
if (theConstraints->minValue->type == INTEGER)
{ return(theConstraints->minValue->value); }
else if (theConstraints->minValue->type == FLOAT)
{ return(EnvAddLong(theEnv,(long long) ValueToDouble(theConstraints->minValue->value))); }
else if (theConstraints->maxValue->type == INTEGER)
{ return(theConstraints->maxValue->value); }
else if (theConstraints->maxValue->type == FLOAT)
{ return(EnvAddLong(theEnv,(long long) ValueToDouble(theConstraints->maxValue->value))); }
}
else if (theType == FLOAT)
{
if (theConstraints->minValue->type == FLOAT)
{ return(theConstraints->minValue->value); }
else if (theConstraints->minValue->type == INTEGER)
{ return(EnvAddDouble(theEnv,(double) ValueToLong(theConstraints->minValue->value))); }
else if (theConstraints->maxValue->type == FLOAT)
{ return(theConstraints->maxValue->value); }
else if (theConstraints->maxValue->type == INTEGER)
{ return(EnvAddDouble(theEnv,(double) ValueToLong(theConstraints->maxValue->value))); }
}
/*======================================*/
/* Use the standard default value (such */
/* as nil if symbols are allowed). */
/*======================================*/
return(standardDefault);
}
dataObject * value_to_data_object( const Environment& env, const Value & value )
{
void *p;
dataObject* clipsdo = new dataObject;
SetpType(clipsdo, value.type() );
switch ( value.type() ) {
case TYPE_SYMBOL:
case TYPE_STRING:
case TYPE_INSTANCE_NAME:
p = EnvAddSymbol( env.cobj(),
const_cast<char*>( value.as_string().c_str())
);
SetpValue(clipsdo, p);
return clipsdo;
case TYPE_INTEGER:
p = EnvAddLong( env.cobj(), value.as_integer() );
SetpValue(clipsdo, p);
return clipsdo;
case TYPE_FLOAT:
p = EnvAddDouble( env.cobj(), value.as_float() );
SetpValue(clipsdo, p);
return clipsdo;
case TYPE_EXTERNAL_ADDRESS:
p = EnvAddExternalAddress( env.cobj(), value.as_address(), EXTERNAL_ADDRESS );
SetpValue(clipsdo, p);
return clipsdo;
default:
throw std::logic_error( "clipsmm::value_to_data_object: Unhandled data object type" );
}
return NULL;
}
globle void AdditionFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
double ftotal = 0.0;
long ltotal = 0L;
intBool useFloatTotal = FALSE;
EXPRESSION *theExpression;
DATA_OBJECT theArgument;
int pos = 1;
/*=================================================*/
/* Loop through each of the arguments adding it to */
/* a running total. If a floating point number is */
/* encountered, then do all subsequent operations */
/* using floating point values. */
/*=================================================*/
theExpression = GetFirstArgument();
while (theExpression != NULL)
{
if (! GetNumericArgument(theEnv,theExpression,"+",&theArgument,useFloatTotal,pos)) theExpression = NULL;
else theExpression = GetNextArgument(theExpression);
if (useFloatTotal)
{ ftotal += ValueToDouble(theArgument.value); }
else
{
if (theArgument.type == INTEGER)
{ ltotal += ValueToLong(theArgument.value); }
else
{
ftotal = (double) ltotal + ValueToDouble(theArgument.value);
useFloatTotal = TRUE;
}
}
pos++;
}
/*======================================================*/
/* If a floating point number was in the argument list, */
/* then return a float, otherwise return an integer. */
/*======================================================*/
if (useFloatTotal)
{
returnValue->type = FLOAT;
returnValue->value = (void *) EnvAddDouble(theEnv,ftotal);
}
else
{
returnValue->type = INTEGER;
returnValue->value = (void *) EnvAddLong(theEnv,ltotal);
}
}
globle void ModFunction(
void *theEnv,
DATA_OBJECT_PTR result)
{
DATA_OBJECT item1, item2;
double fnum1, fnum2;
long long lnum1, lnum2;
if (EnvArgCountCheck(theEnv,"mod",EXACTLY,2) == -1)
{
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,0L);
return;
}
if (EnvArgTypeCheck(theEnv,"mod",1,INTEGER_OR_FLOAT,&item1) == FALSE)
{
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,0L);
return;
}
if (EnvArgTypeCheck(theEnv,"mod",2,INTEGER_OR_FLOAT,&item2) == FALSE)
{
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,0L);
return;
}
if (((item2.type == INTEGER) ? (ValueToLong(item2.value) == 0L) : FALSE) ||
((item2.type == FLOAT) ? ValueToDouble(item2.value) == 0.0 : FALSE))
{
DivideByZeroErrorMessage(theEnv,"mod");
SetEvaluationError(theEnv,TRUE);
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,0L);
return;
}
if ((item1.type == FLOAT) || (item2.type == FLOAT))
{
fnum1 = CoerceToDouble(item1.type,item1.value);
fnum2 = CoerceToDouble(item2.type,item2.value);
result->type = FLOAT;
result->value = (void *) EnvAddDouble(theEnv,fnum1 - (dtrunc(fnum1 / fnum2) * fnum2));
}
else
{
lnum1 = DOToLong(item1);
lnum2 = DOToLong(item2);
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,lnum1 - (lnum1 / lnum2) * lnum2);
}
}
dataObject * value_to_data_object( const Environment& env, const Values & values )
{
void *p, *p2;
if (values.size() == 0 )
return NULL;
if ( values.size() == 1 )
return value_to_data_object( env, values[0] );
dataObject* clipsdo = new dataObject;
p = EnvCreateMultifield( env.cobj(), values.size() );
for (unsigned int iter = 0; iter < values.size(); iter++) {
unsigned int mfi = iter + 1; // mfptr indices start at 1
SetMFType(p, mfi, values[iter].type());
switch ( values[iter].type() ) {
case TYPE_SYMBOL:
case TYPE_STRING:
case TYPE_INSTANCE_NAME:
p2 = EnvAddSymbol( env.cobj(),
const_cast<char*>(values[iter].as_string().c_str())
);
SetMFValue(p, mfi, p2);
break;
case TYPE_INTEGER:
p2 = EnvAddLong( env.cobj(), values[iter].as_integer() );
SetMFValue(p, mfi, p2);
break;
case TYPE_FLOAT:
p2 = EnvAddDouble( env.cobj(), values[iter].as_float() );
SetMFValue(p, mfi, p2);
break;
case TYPE_EXTERNAL_ADDRESS:
p2 = EnvAddExternalAddress( env.cobj(), values[iter].as_address(), EXTERNAL_ADDRESS );
SetMFValue(p, mfi, p2);
break;
default:
throw std::logic_error( "clipsmm::value_to_data_object: Unhandled data object type" );
}
}
SetpType(clipsdo, MULTIFIELD);
SetpValue(clipsdo, p);
SetpDOBegin(clipsdo, 1);
SetpDOEnd(clipsdo, values.size());
return clipsdo;
}
globle void ReadNeededFloats(
void *theEnv)
{
double *floatValues;
long i;
/*============================================*/
/* Determine the number of floats to be read. */
/*============================================*/
GenReadBinary(theEnv,&SymbolData(theEnv)->NumberOfFloats,(unsigned long) sizeof(long int));
if (SymbolData(theEnv)->NumberOfFloats == 0)
{
SymbolData(theEnv)->FloatArray = NULL;
return;
}
/*===============================*/
/* Allocate area for the floats. */
/*===============================*/
floatValues = (double *) gm3(theEnv,(long) sizeof(double) * SymbolData(theEnv)->NumberOfFloats);
GenReadBinary(theEnv,(void *) floatValues,(unsigned long) (sizeof(double) * SymbolData(theEnv)->NumberOfFloats));
/*======================================*/
/* Store the floats in the float array. */
/*======================================*/
SymbolData(theEnv)->FloatArray = (FLOAT_HN **)
gm3(theEnv,(long) sizeof(FLOAT_HN *) * SymbolData(theEnv)->NumberOfFloats);
for (i = 0; i < SymbolData(theEnv)->NumberOfFloats; i++)
{ SymbolData(theEnv)->FloatArray[i] = (FLOAT_HN *) EnvAddDouble(theEnv,floatValues[i]); }
/*========================*/
/* Free the float buffer. */
/*========================*/
rm3(theEnv,(void *) floatValues,(long) (sizeof(double) * SymbolData(theEnv)->NumberOfFloats));
}
globle void AbsFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
/*============================================*/
/* Check for the correct number of arguments. */
/*============================================*/
if (EnvArgCountCheck(theEnv,"abs",EXACTLY,1) == -1)
{
returnValue->type = INTEGER;
returnValue->value = (void *) EnvAddLong(theEnv,0L);
return;
}
/*======================================*/
/* Check that the argument is a number. */
/*======================================*/
if (EnvArgTypeCheck(theEnv,"abs",1,INTEGER_OR_FLOAT,returnValue) == FALSE)
{
returnValue->type = INTEGER;
returnValue->value = (void *) EnvAddLong(theEnv,0L);
return;
}
/*==========================================*/
/* Return the absolute value of the number. */
/*==========================================*/
if (returnValue->type == INTEGER)
{
if (ValueToLong(returnValue->value) < 0L)
{ returnValue->value = (void *) EnvAddLong(theEnv,- ValueToLong(returnValue->value)); }
}
else if (ValueToDouble(returnValue->value) < 0.0)
{ returnValue->value = (void *) EnvAddDouble(theEnv,- ValueToDouble(returnValue->value)); }
}
void *entryPoint(void * m_theEnv)
{
void *newFact;
void *templatePtr;
void *theMultifield;
DATA_OBJECT theValue;
char *templatename = "InputSource";
/* Create the fact. */
/*==================*/
templatePtr = EnvFindDeftemplate(m_theEnv,templatename);
newFact = EnvCreateFact(m_theEnv,templatePtr);
if (newFact == NULL) return 0;
theValue.type = INTEGER;
theValue.value = EnvAddLong(m_theEnv,100);
EnvPutFactSlot(m_theEnv,newFact,"speed",&theValue);
theValue.type = FLOAT;
theValue.value = EnvAddDouble(m_theEnv,1.0);
EnvPutFactSlot(m_theEnv,newFact,"astatus",&theValue);
theValue.type = INTEGER;
theValue.value = EnvAddLong(m_theEnv,2);
EnvPutFactSlot(m_theEnv,newFact,"rclass",&theValue);
theValue.type = INTEGER;
theValue.value = EnvAddLong(m_theEnv,10000);
EnvPutFactSlot(m_theEnv,newFact,"distance",&theValue);
EnvAssignFactSlotDefaults(m_theEnv,newFact);
EnvAssert(m_theEnv,newFact);
return newFact;
}
globle void DivisionFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
double ftotal = 1.0;
long ltotal = 1L;
intBool useFloatTotal;
EXPRESSION *theExpression;
DATA_OBJECT theArgument;
int pos = 1;
useFloatTotal = BasicMathFunctionData(theEnv)->AutoFloatDividend;
/*===================================================*/
/* Get the first argument. This number which will be */
/* the starting product from which all subsequent */
/* arguments will divide. If the auto float dividend */
/* feature is enable, then this number is converted */
/* to a float if it is an integer. */
/*===================================================*/
theExpression = GetFirstArgument();
if (theExpression != NULL)
{
if (! GetNumericArgument(theEnv,theExpression,"/",&theArgument,useFloatTotal,pos)) theExpression = NULL;
else theExpression = GetNextArgument(theExpression);
if (theArgument.type == INTEGER)
{ ltotal = ValueToLong(theArgument.value); }
else
{
ftotal = ValueToDouble(theArgument.value);
useFloatTotal = TRUE;
}
pos++;
}
/*====================================================*/
/* Loop through each of the arguments dividing it */
/* into a running product. If a floating point number */
/* is encountered, then do all subsequent operations */
/* using floating point values. Each argument is */
/* checked to prevent a divide by zero error. */
/*====================================================*/
while (theExpression != NULL)
{
if (! GetNumericArgument(theEnv,theExpression,"/",&theArgument,useFloatTotal,pos)) theExpression = NULL;
else theExpression = GetNextArgument(theExpression);
if ((theArgument.type == INTEGER) ? (ValueToLong(theArgument.value) == 0L) :
((theArgument.type == FLOAT) ? ValueToDouble(theArgument.value) == 0.0 : FALSE))
{
DivideByZeroErrorMessage(theEnv,"/");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
returnValue->type = FLOAT;
returnValue->value = (void *) EnvAddDouble(theEnv,1.0);
return;
}
if (useFloatTotal)
{ ftotal /= ValueToDouble(theArgument.value); }
else
{
if (theArgument.type == INTEGER)
{ ltotal /= ValueToLong(theArgument.value); }
else
{
ftotal = (double) ltotal / ValueToDouble(theArgument.value);
useFloatTotal = TRUE;
}
}
pos++;
}
/*======================================================*/
/* If a floating point number was in the argument list, */
/* then return a float, otherwise return an integer. */
/*======================================================*/
if (useFloatTotal)
{
returnValue->type = FLOAT;
returnValue->value = (void *) EnvAddDouble(theEnv,ftotal);
}
else
{
returnValue->type = INTEGER;
returnValue->value = (void *) EnvAddLong(theEnv,ltotal);
}
}
globle intBool GetNumericArgument(
void *theEnv,
struct expr *theArgument,
char *functionName,
DATA_OBJECT *result,
intBool convertToFloat,
int whichArgument)
{
unsigned short theType;
void *theValue;
/*==================================================================*/
/* Evaluate the expression (don't bother calling EvaluateExpression */
/* if the type is float or integer). */
/*==================================================================*/
switch(theArgument->type)
{
case FLOAT:
case INTEGER:
theType = theArgument->type;
theValue = theArgument->value;
break;
default:
EvaluateExpression(theEnv,theArgument,result);
theType = result->type;
theValue = result->value;
break;
}
/*==========================================*/
/* If the argument is not float or integer, */
/* print an error message and return FALSE. */
/*==========================================*/
if ((theType != FLOAT) && (theType != INTEGER))
{
ExpectedTypeError1(theEnv,functionName,whichArgument,"integer or float");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,0L);
return(FALSE);
}
/*==========================================================*/
/* If the argument is an integer and the "convert to float" */
/* flag is TRUE, then convert the integer to a float. */
/*==========================================================*/
if ((convertToFloat) && (theType == INTEGER))
{
theType = FLOAT;
theValue = (void *) EnvAddDouble(theEnv,(double) ValueToLong(theValue));
}
/*============================================================*/
/* The numeric argument was successfully retrieved. Store the */
/* argument in the user supplied DATA_OBJECT and return TRUE. */
/*============================================================*/
result->type = theType;
result->value = theValue;
return(TRUE);
}
globle int EnvArgTypeCheck(
void *theEnv,
char *functionName,
int argumentPosition,
int expectedType,
DATA_OBJECT_PTR returnValue)
{
/*========================*/
/* Retrieve the argument. */
/*========================*/
EnvRtnUnknown(theEnv,argumentPosition,returnValue);
if (EvaluationData(theEnv)->EvaluationError) return(FALSE);
/*========================================*/
/* If the argument's type exactly matches */
/* the expected type, then return TRUE. */
/*========================================*/
if (returnValue->type == expectedType) return (TRUE);
/*=============================================================*/
/* Some expected types encompass more than one primitive type. */
/* If the argument's type matches one of the primitive types */
/* encompassed by the expected type, then return TRUE. */
/*=============================================================*/
if ((expectedType == INTEGER_OR_FLOAT) &&
((returnValue->type == INTEGER) || (returnValue->type == FLOAT)))
{ return(TRUE); }
if ((expectedType == SYMBOL_OR_STRING) &&
((returnValue->type == SYMBOL) || (returnValue->type == STRING)))
{ return(TRUE); }
#if OBJECT_SYSTEM
if (((expectedType == SYMBOL_OR_STRING) || (expectedType == SYMBOL)) &&
(returnValue->type == INSTANCE_NAME))
{ return(TRUE); }
if ((expectedType == INSTANCE_NAME) &&
((returnValue->type == INSTANCE_NAME) || (returnValue->type == SYMBOL)))
{ return(TRUE); }
if ((expectedType == INSTANCE_OR_INSTANCE_NAME) &&
((returnValue->type == INSTANCE_ADDRESS) ||
(returnValue->type == INSTANCE_NAME) ||
(returnValue->type == SYMBOL)))
{ return(TRUE); }
#endif
/*===========================================================*/
/* If the expected type is float and the argument's type is */
/* integer (or vice versa), then convert the argument's type */
/* to match the expected type and then return TRUE. */
/*===========================================================*/
if ((returnValue->type == INTEGER) && (expectedType == FLOAT))
{
returnValue->type = FLOAT;
returnValue->value = (void *) EnvAddDouble(theEnv,(double) ValueToLong(returnValue->value));
return(TRUE);
}
if ((returnValue->type == FLOAT) && (expectedType == INTEGER))
{
returnValue->type = INTEGER;
returnValue->value = (void *) EnvAddLong(theEnv,(long) ValueToDouble(returnValue->value));
return(TRUE);
}
/*=====================================================*/
/* The argument's type didn't match the expected type. */
/* Print an error message and return FALSE. */
/*=====================================================*/
if (expectedType == FLOAT) ExpectedTypeError1(theEnv,functionName,argumentPosition,"float");
else if (expectedType == INTEGER) ExpectedTypeError1(theEnv,functionName,argumentPosition,"integer");
else if (expectedType == SYMBOL) ExpectedTypeError1(theEnv,functionName,argumentPosition,"symbol");
else if (expectedType == STRING) ExpectedTypeError1(theEnv,functionName,argumentPosition,"string");
else if (expectedType == MULTIFIELD) ExpectedTypeError1(theEnv,functionName,argumentPosition,"multifield");
else if (expectedType == INTEGER_OR_FLOAT) ExpectedTypeError1(theEnv,functionName,argumentPosition,"integer or float");
else if (expectedType == SYMBOL_OR_STRING) ExpectedTypeError1(theEnv,functionName,argumentPosition,"symbol or string");
#if OBJECT_SYSTEM
else if (expectedType == INSTANCE_NAME) ExpectedTypeError1(theEnv,functionName,argumentPosition,"instance name");
else if (expectedType == INSTANCE_ADDRESS) ExpectedTypeError1(theEnv,functionName,argumentPosition,"instance address");
else if (expectedType == INSTANCE_OR_INSTANCE_NAME) ExpectedTypeError1(theEnv,functionName,argumentPosition,"instance address or instance name");
#endif
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(FALSE);
}
globle void MultiplicationFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
double ftotal = 1.0;
double ftmp = 0.0;
long long ltotal = 1LL;
long long ltmp = 0LL;
intBool useFloatTotal = FALSE;
EXPRESSION *theExpression;
DATA_OBJECT theArgument;
int pos = 1;
/*===================================================*/
/* Loop through each of the arguments multiplying it */
/* by a running product. If a floating point number */
/* is encountered, then do all subsequent operations */
/* using floating point values. */
/*===================================================*/
theExpression = GetFirstArgument();
while (theExpression != NULL) {
if (! GetNumericArgument(theEnv,theExpression,"*",&theArgument,useFloatTotal,pos))
theExpression = NULL;
else
theExpression = GetNextArgument(theExpression);
if (useFloatTotal) {
ftmp = ValueToDouble(theArgument.value);
if(ftmp == 0.0) {
ftotal = 0.0;
break;
} else if(ftmp != 1.0) {
ftotal *= ftmp;
}
} else {
if (theArgument.type == INTEGER) {
ltmp = ValueToLong(theArgument.value);
if(ltmp == 0LL) {
ltotal = 0LL;
break;
} else if (ltmp != 1LL) {
/* We shouldn't waste time handling multiplication by one */
ltotal *= ltmp;
}
} else {
ftmp = ValueToDouble(theArgument.value);
if(ftmp == 0.0) {
ftotal = 0.0;
break;
} else if(ftmp == 1.0) {
/* just cast as a double instead of wasting a multiply */
ftotal = (double) ltotal;
} else {
ftotal = (double) ltotal * ftmp;
}
useFloatTotal = TRUE;
}
}
pos++;
}
/*======================================================*/
/* If a floating point number was in the argument list, */
/* then return a float, otherwise return an integer. */
/*======================================================*/
if (useFloatTotal) {
returnValue->type = FLOAT;
returnValue->value = (void *) EnvAddDouble(theEnv,ftotal);
} else {
returnValue->type = INTEGER;
returnValue->value = (void *) EnvAddLong(theEnv,ltotal);
}
}
globle int EvaluateExpression(
void *theEnv,
struct expr *problem,
DATA_OBJECT_PTR returnValue)
{
struct expr *oldArgument;
void *oldContext;
struct FunctionDefinition *fptr;
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
if (problem == NULL)
{
returnValue->type = SYMBOL;
returnValue->value = EnvFalseSymbol(theEnv);
return(EvaluationData(theEnv)->EvaluationError);
}
switch (problem->type)
{
case STRING:
case SYMBOL:
case FLOAT:
case INTEGER:
#if OBJECT_SYSTEM
case INSTANCE_NAME:
case INSTANCE_ADDRESS:
#endif
case EXTERNAL_ADDRESS:
returnValue->type = problem->type;
returnValue->value = problem->value;
break;
case DATA_OBJECT_ARRAY: /* TBD Remove with AddPrimitive */
returnValue->type = problem->type;
returnValue->value = problem->value;
break;
case FCALL:
{
fptr = (struct FunctionDefinition *) problem->value;
oldContext = SetEnvironmentFunctionContext(theEnv,fptr->context);
#if PROFILING_FUNCTIONS
StartProfile(theEnv,&profileFrame,
&fptr->usrData,
ProfileFunctionData(theEnv)->ProfileUserFunctions);
#endif
oldArgument = EvaluationData(theEnv)->CurrentExpression;
EvaluationData(theEnv)->CurrentExpression = problem;
switch(fptr->returnValueType)
{
case 'v' :
if (fptr->environmentAware)
{ (* (void (*)(void *)) fptr->functionPointer)(theEnv); }
else
{ (* (void (*)(void)) fptr->functionPointer)(); }
returnValue->type = RVOID;
returnValue->value = EnvFalseSymbol(theEnv);
break;
case 'b' :
returnValue->type = SYMBOL;
if (fptr->environmentAware)
{
if ((* (int (*)(void *)) fptr->functionPointer)(theEnv))
returnValue->value = EnvTrueSymbol(theEnv);
else
returnValue->value = EnvFalseSymbol(theEnv);
}
else
{
if ((* (int (*)(void)) fptr->functionPointer)())
returnValue->value = EnvTrueSymbol(theEnv);
else
returnValue->value = EnvFalseSymbol(theEnv);
}
break;
case 'a' :
returnValue->type = EXTERNAL_ADDRESS;
if (fptr->environmentAware)
{
returnValue->value =
(* (void *(*)(void *)) fptr->functionPointer)(theEnv);
}
else
{
returnValue->value =
(* (void *(*)(void)) fptr->functionPointer)();
}
break;
case 'g' :
returnValue->type = INTEGER;
if (fptr->environmentAware)
{
returnValue->value = (void *)
EnvAddLong(theEnv,(* (long long (*)(void *)) fptr->functionPointer)(theEnv));
}
else
{
returnValue->value = (void *)
EnvAddLong(theEnv,(* (long long (*)(void)) fptr->functionPointer)());
}
break;
case 'i' :
returnValue->type = INTEGER;
if (fptr->environmentAware)
{
returnValue->value = (void *)
EnvAddLong(theEnv,(long long) (* (int (*)(void *)) fptr->functionPointer)(theEnv));
}
else
{
returnValue->value = (void *)
EnvAddLong(theEnv,(long long) (* (int (*)(void)) fptr->functionPointer)());
}
break;
case 'l' :
returnValue->type = INTEGER;
if (fptr->environmentAware)
{
returnValue->value = (void *)
EnvAddLong(theEnv,(long long) (* (long int (*)(void *)) fptr->functionPointer)(theEnv));
}
else
{
returnValue->value = (void *)
EnvAddLong(theEnv,(long long) (* (long int (*)(void)) fptr->functionPointer)());
}
break;
case 'f' :
returnValue->type = FLOAT;
if (fptr->environmentAware)
{
returnValue->value = (void *)
EnvAddDouble(theEnv,(double) (* (float (*)(void *)) fptr->functionPointer)(theEnv));
}
else
{
returnValue->value = (void *)
EnvAddDouble(theEnv,(double) (* (float (*)(void)) fptr->functionPointer)());
}
break;
case 'd' :
returnValue->type = FLOAT;
if (fptr->environmentAware)
{
returnValue->value = (void *)
EnvAddDouble(theEnv,(* (double (*)(void *)) fptr->functionPointer)(theEnv));
}
else
{
returnValue->value = (void *)
EnvAddDouble(theEnv,(* (double (*)(void)) fptr->functionPointer)());
}
break;
case 's' :
returnValue->type = STRING;
if (fptr->environmentAware)
{
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void *)) fptr->functionPointer)(theEnv);
}
else
{
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
}
break;
case 'w' :
returnValue->type = SYMBOL;
if (fptr->environmentAware)
{
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void *)) fptr->functionPointer)(theEnv);
}
else
{
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
}
break;
#if OBJECT_SYSTEM
case 'x' :
returnValue->type = INSTANCE_ADDRESS;
if (fptr->environmentAware)
{
returnValue->value =
(* (void *(*)(void *)) fptr->functionPointer)(theEnv);
}
else
{
returnValue->value =
(* (void *(*)(void)) fptr->functionPointer)();
}
break;
case 'o' :
returnValue->type = INSTANCE_NAME;
if (fptr->environmentAware)
{
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void *)) fptr->functionPointer)(theEnv);
}
else
{
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
}
break;
#endif
case 'c' :
{
char cbuff[2];
if (fptr->environmentAware)
{
cbuff[0] = (* (char (*)(void *)) fptr->functionPointer)(theEnv);
}
else
{
cbuff[0] = (* (char (*)(void)) fptr->functionPointer)();
}
cbuff[1] = EOS;
returnValue->type = SYMBOL;
returnValue->value = (void *) EnvAddSymbol(theEnv,cbuff);
break;
}
case 'j' :
case 'k' :
case 'm' :
case 'n' :
case 'u' :
if (fptr->environmentAware)
{
(* (void (*)(void *,DATA_OBJECT_PTR)) fptr->functionPointer)(theEnv,returnValue);
}
else
{
(* (void (*)(DATA_OBJECT_PTR)) fptr->functionPointer)(returnValue);
}
break;
default :
SystemError(theEnv,"EVALUATN",2);
EnvExitRouter(theEnv,EXIT_FAILURE);
break;
}
#if PROFILING_FUNCTIONS
EndProfile(theEnv,&profileFrame);
#endif
SetEnvironmentFunctionContext(theEnv,oldContext);
EvaluationData(theEnv)->CurrentExpression = oldArgument;
break;
}
case MULTIFIELD:
returnValue->type = MULTIFIELD;
returnValue->value = ((DATA_OBJECT_PTR) (problem->value))->value;
returnValue->begin = ((DATA_OBJECT_PTR) (problem->value))->begin;
returnValue->end = ((DATA_OBJECT_PTR) (problem->value))->end;
break;
case MF_VARIABLE:
case SF_VARIABLE:
if (GetBoundVariable(theEnv,returnValue,(SYMBOL_HN *) problem->value) == FALSE)
{
PrintErrorID(theEnv,"EVALUATN",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Variable ");
EnvPrintRouter(theEnv,WERROR,ValueToString(problem->value));
EnvPrintRouter(theEnv,WERROR," is unbound\n");
returnValue->type = SYMBOL;
returnValue->value = EnvFalseSymbol(theEnv);
SetEvaluationError(theEnv,TRUE);
}
break;
default:
if (EvaluationData(theEnv)->PrimitivesArray[problem->type] == NULL)
{
SystemError(theEnv,"EVALUATN",3);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
if (EvaluationData(theEnv)->PrimitivesArray[problem->type]->copyToEvaluate)
{
returnValue->type = problem->type;
returnValue->value = problem->value;
break;
}
if (EvaluationData(theEnv)->PrimitivesArray[problem->type]->evaluateFunction == NULL)
{
SystemError(theEnv,"EVALUATN",4);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
oldArgument = EvaluationData(theEnv)->CurrentExpression;
EvaluationData(theEnv)->CurrentExpression = problem;
#if PROFILING_FUNCTIONS
StartProfile(theEnv,&profileFrame,
&EvaluationData(theEnv)->PrimitivesArray[problem->type]->usrData,
ProfileFunctionData(theEnv)->ProfileUserFunctions);
#endif
(*EvaluationData(theEnv)->PrimitivesArray[problem->type]->evaluateFunction)(theEnv,problem->value,returnValue);
#if PROFILING_FUNCTIONS
EndProfile(theEnv,&profileFrame);
#endif
EvaluationData(theEnv)->CurrentExpression = oldArgument;
break;
}
return(EvaluationData(theEnv)->EvaluationError);
}
globle void SubtractionFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
double ftotal = 0.0;
long ltotal = 0L;
BOOLEAN useFloatTotal = FALSE;
EXPRESSION *theExpression;
DATA_OBJECT theArgument;
int pos = 1;
/*=================================================*/
/* Get the first argument. This number which will */
/* be the starting total from which all subsequent */
/* arguments will subtracted. */
/*=================================================*/
theExpression = GetFirstArgument();
if (theExpression != NULL)
{
if (! GetNumericArgument(theEnv,theExpression,"-",&theArgument,useFloatTotal,pos)) theExpression = NULL;
else theExpression = GetNextArgument(theExpression);
if (theArgument.type == INTEGER)
{ ltotal = ValueToLong(theArgument.value); }
else
{
ftotal = ValueToDouble(theArgument.value);
useFloatTotal = TRUE;
}
pos++;
}
/*===================================================*/
/* Loop through each of the arguments subtracting it */
/* from a running total. If a floating point number */
/* is encountered, then do all subsequent operations */
/* using floating point values. */
/*===================================================*/
while (theExpression != NULL)
{
if (! GetNumericArgument(theEnv,theExpression,"-",&theArgument,useFloatTotal,pos)) theExpression = NULL;
else theExpression = GetNextArgument(theExpression);
if (useFloatTotal)
{ ftotal -= ValueToDouble(theArgument.value); }
else
{
if (theArgument.type == INTEGER)
{ ltotal -= ValueToLong(theArgument.value); }
else
{
ftotal = (double) ltotal - ValueToDouble(theArgument.value);
useFloatTotal = TRUE;
}
}
pos++;
}
/*======================================================*/
/* If a floating point number was in the argument list, */
/* then return a float, otherwise return an integer. */
/*======================================================*/
if (useFloatTotal)
{
returnValue->type = FLOAT;
returnValue->value = (void *) EnvAddDouble(theEnv,ftotal);
}
else
{
returnValue->type = INTEGER;
returnValue->value = (void *) EnvAddLong(theEnv,ltotal);
}
}
globle void DeriveDefaultFromConstraints(
void *theEnv,
CONSTRAINT_RECORD *constraints,
DATA_OBJECT *theDefault,
int multifield,
int garbageMultifield)
{
unsigned short theType;
unsigned long minFields;
void *theValue;
/*=============================================================*/
/* If no constraints are specified, then use the symbol nil as */
/* a default for single field slots and a multifield of length */
/* 0 as a default for multifield slots. */
/*=============================================================*/
if (constraints == NULL)
{
if (multifield)
{
SetpType(theDefault,MULTIFIELD);
SetpDOBegin(theDefault,1);
SetpDOEnd(theDefault,0);
if (garbageMultifield) SetpValue(theDefault,(void *) EnvCreateMultifield(theEnv,0L));
else SetpValue(theDefault,(void *) CreateMultifield2(theEnv,0L));
}
else
{
theDefault->type = SYMBOL;
theDefault->value = EnvAddSymbol(theEnv,(char*)"nil");
}
return;
}
/*=========================================*/
/* Determine the default's type and value. */
/*=========================================*/
if (constraints->anyAllowed || constraints->symbolsAllowed)
{
theType = SYMBOL;
theValue = FindDefaultValue(theEnv,SYMBOL,constraints,EnvAddSymbol(theEnv,(char*)"nil"));
}
else if (constraints->stringsAllowed)
{
theType = STRING;
theValue = FindDefaultValue(theEnv,STRING,constraints,EnvAddSymbol(theEnv,(char*)""));
}
else if (constraints->integersAllowed)
{
theType = INTEGER;
theValue = FindDefaultValue(theEnv,INTEGER,constraints,EnvAddLong(theEnv,0LL));
}
else if (constraints->floatsAllowed)
{
theType = FLOAT;
theValue = FindDefaultValue(theEnv,FLOAT,constraints,EnvAddDouble(theEnv,0.0));
}
#if OBJECT_SYSTEM
else if (constraints->instanceNamesAllowed)
{
theType = INSTANCE_NAME;
theValue = FindDefaultValue(theEnv,INSTANCE_NAME,constraints,EnvAddSymbol(theEnv,(char*)"nil"));
}
else if (constraints->instanceAddressesAllowed)
{
theType = INSTANCE_ADDRESS;
theValue = (void *) &InstanceData(theEnv)->DummyInstance;
}
#endif
#if DEFTEMPLATE_CONSTRUCT
else if (constraints->factAddressesAllowed)
{
theType = FACT_ADDRESS;
theValue = (void *) &FactData(theEnv)->DummyFact;
}
#endif
else if (constraints->externalAddressesAllowed)
{
theType = EXTERNAL_ADDRESS;
theValue = EnvAddExternalAddress(theEnv,NULL,0);
}
else
{
theType = SYMBOL;
theValue = EnvAddSymbol(theEnv,(char*)"nil");
}
/*=========================================================*/
/* If the default is for a multifield slot, then create a */
/* multifield default value that satisfies the cardinality */
/* constraints for the slot. The default value for a */
/* multifield slot is a multifield of length 0. */
/*=========================================================*/
if (multifield)
{
if (constraints->minFields == NULL) minFields = 0;
else if (constraints->minFields->value == SymbolData(theEnv)->NegativeInfinity) minFields = 0;
else minFields = (unsigned long) ValueToLong(constraints->minFields->value);
SetpType(theDefault,MULTIFIELD);
SetpDOBegin(theDefault,1);
SetpDOEnd(theDefault,(long) minFields);
if (garbageMultifield) SetpValue(theDefault,(void *) EnvCreateMultifield(theEnv,minFields));
else SetpValue(theDefault,(void *) CreateMultifield2(theEnv,minFields));
for (; minFields > 0; minFields--)
{
SetMFType(GetpValue(theDefault),minFields,theType);
SetMFValue(GetpValue(theDefault),minFields,theValue);
}
}
else
{
theDefault->type = theType;
theDefault->value = theValue;
}
}
