globle void AdditionFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
double ftotal = 0.0;
long long ltotal = 0LL;
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,(char*)"+",&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);
}
}
// DECL: void visit(T* instance, bool (T::*visitMethod)(Node*,C), C cookie);
void hx_Scene_visit_Func_Int(value thisObj, value visitMethod, value cookie)
{
Scene *_thisObj;
long _cookie = ValueToLong(cookie);
ValueToObject(thisObj, _thisObj);
MethodWrapper wrapper;
wrapper.visit(_thisObj, visitMethod, _cookie);
}
unsigned long GetAtomicHashValue(
unsigned short type,
void *value,
int position)
{
unsigned long tvalue;
union
{
double fv;
void *vv;
unsigned long liv;
} fis;
switch (type)
{
case FLOAT:
fis.liv = 0;
fis.fv = ValueToDouble(value);
tvalue = fis.liv;
break;
case INTEGER:
tvalue = (unsigned long) ValueToLong(value);
break;
case EXTERNAL_ADDRESS:
fis.liv = 0;
fis.vv = ValueToExternalAddress(value);
tvalue = (unsigned long) fis.liv;
break;
case FACT_ADDRESS:
#if OBJECT_SYSTEM
case INSTANCE_ADDRESS:
#endif
fis.liv = 0;
fis.vv = value;
tvalue = (unsigned long) fis.liv;
break;
case STRING:
#if OBJECT_SYSTEM
case INSTANCE_NAME:
#endif
case SYMBOL:
tvalue = ((SYMBOL_HN *) value)->bucket;
break;
default:
tvalue = type;
}
if (position < 0) return(tvalue);
return((unsigned long) (tvalue * (((unsigned long) position) + 29)));
}
globle void MultiplicationFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
double ftotal = 1.0;
long ltotal = 1L;
CLIPS_BOOLEAN 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)
{ 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);
}
}
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)); }
}
globle long EnvRtnLong(
void *theEnv,
int argumentPosition)
{
int count = 1;
DATA_OBJECT result;
struct expr *argPtr;
/*=====================================================*/
/* Find the appropriate argument in the argument list. */
/*=====================================================*/
for (argPtr = EvaluationData(theEnv)->CurrentExpression->argList;
(argPtr != NULL) && (count < argumentPosition);
argPtr = argPtr->nextArg)
{ count++; }
if (argPtr == NULL)
{
NonexistantError(theEnv,"RtnLong",
ValueToString(ExpressionFunctionCallName(EvaluationData(theEnv)->CurrentExpression)),
argumentPosition);
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(1L);
}
/*======================================*/
/* Return the value of the nth argument */
/* if it is a float or integer. */
/*======================================*/
EvaluateExpression(theEnv,argPtr,&result);
if (result.type == FLOAT)
{ return((long) ValueToDouble(result.value)); }
else if (result.type == INTEGER)
{ return(ValueToLong(result.value)); }
/*======================================================*/
/* Generate an error if the argument is the wrong type. */
/*======================================================*/
ExpectedTypeError3(theEnv,"RtnLong",
ValueToString(ExpressionFunctionCallName(EvaluationData(theEnv)->CurrentExpression)),
argumentPosition,"number");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(1L);
}
globle long long RoundFunction(
void *theEnv)
{
DATA_OBJECT result;
if (EnvArgCountCheck(theEnv,"round",EXACTLY,1) == -1)
{ return(0LL); }
if (EnvArgTypeCheck(theEnv,"round",1,INTEGER_OR_FLOAT,&result) == FALSE)
{ return(0LL); }
if (result.type == INTEGER)
{ return(ValueToLong(result.value)); }
else
{ return((long long) ceil(ValueToDouble(result.value) - 0.5)); }
}
unsigned int GetAtomicHashValue(
int type,
void *value,
int position)
{
unsigned int tvalue;
union
{
double fv;
unsigned int liv;
} fis;
switch (type)
{
case FLOAT:
fis.fv = ValueToDouble(value);
tvalue = fis.liv;
break;
case INTEGER:
tvalue = (unsigned int) ValueToLong(value);
break;
case FACT_ADDRESS:
#if OBJECT_SYSTEM
case INSTANCE_ADDRESS:
#endif
case EXTERNAL_ADDRESS:
tvalue = (unsigned int) value;
break;
case STRING:
#if OBJECT_SYSTEM
case INSTANCE_NAME:
#endif
case SYMBOL:
tvalue = ((SYMBOL_HN *) value)->bucket;
break;
default:
tvalue = type;
}
if (position < 0) return(tvalue);
return((unsigned int) (tvalue * (position + 29)));
}
globle int ItemHashValue(
int theType,
void *theValue,
int theRange)
{
switch(theType)
{
case FLOAT:
return(HashFloat(ValueToDouble(theValue),theRange));
case INTEGER:
return(HashInteger(ValueToLong(theValue),theRange));
case SYMBOL:
case STRING:
#if OBJECT_SYSTEM
case INSTANCE_NAME:
#endif
return(HashSymbol(ValueToString(theValue),theRange));
case MULTIFIELD:
return(HashMultifield((struct multifield *) theValue,theRange));
#if DEFTEMPLATE_CONSTRUCT
case FACT_ADDRESS:
return(HashFact((struct fact *) theValue) % theRange);
#endif
case EXTERNAL_ADDRESS:
#if OBJECT_SYSTEM
case INSTANCE_ADDRESS:
#endif
return(((int) theValue) % theRange);
default:
SystemError("UTILITY",1);
return(-1L);
}
return(-1L);
}
globle struct fact *GetFactAddressOrIndexArgument(
void *theEnv,
const char *theFunction,
int position,
int noFactError)
{
DATA_OBJECT item;
long long factIndex;
struct fact *theFact;
char tempBuffer[20];
EnvRtnUnknown(theEnv,position,&item);
if (GetType(item) == FACT_ADDRESS)
{
if (((struct fact *) GetValue(item))->garbage) return(NULL);
else return (((struct fact *) GetValue(item)));
}
else if (GetType(item) == INTEGER)
{
factIndex = ValueToLong(item.value);
if (factIndex < 0)
{
ExpectedTypeError1(theEnv,theFunction,position,"fact-address or fact-index");
return(NULL);
}
theFact = FindIndexedFact(theEnv,factIndex);
if ((theFact == NULL) && noFactError)
{
gensprintf(tempBuffer,"f-%lld",factIndex);
CantFindItemErrorMessage(theEnv,"fact",tempBuffer);
return(NULL);
}
return(theFact);
}
ExpectedTypeError1(theEnv,theFunction,position,"fact-address or fact-index");
return(NULL);
}
globle unsigned long HashMultifield(
struct multifield *theSegment,
unsigned long theRange)
{
unsigned long length, i;
unsigned long tvalue;
unsigned long count;
struct field *fieldPtr;
union
{
double fv;
void *vv;
unsigned long liv;
} fis;
/*================================================*/
/* Initialize variables for computing hash value. */
/*================================================*/
count = 0;
length = theSegment->multifieldLength;
fieldPtr = theSegment->theFields;
/*====================================================*/
/* Loop through each value in the multifield, compute */
/* its hash value, and add it to the running total. */
/*====================================================*/
for (i = 0;
i < length;
i++)
{
switch(fieldPtr[i].type)
{
case MULTIFIELD:
count += HashMultifield((struct multifield *) fieldPtr[i].value,theRange);
break;
case FLOAT:
fis.liv = 0;
fis.fv = ValueToDouble(fieldPtr[i].value);
count += (fis.liv * (i + 29)) +
(unsigned long) ValueToDouble(fieldPtr[i].value);
break;
case INTEGER:
count += (((unsigned long) ValueToLong(fieldPtr[i].value)) * (i + 29)) +
((unsigned long) ValueToLong(fieldPtr[i].value));
break;
case FACT_ADDRESS:
#if OBJECT_SYSTEM
case INSTANCE_ADDRESS:
#endif
fis.liv = 0;
fis.vv = fieldPtr[i].value;
count += (unsigned long) (fis.liv * (i + 29));
break;
case EXTERNAL_ADDRESS:
fis.liv = 0;
fis.vv = ValueToExternalAddress(fieldPtr[i].value);
count += (unsigned long) (fis.liv * (i + 29));
break;
case SYMBOL:
case STRING:
#if OBJECT_SYSTEM
case INSTANCE_NAME:
#endif
tvalue = (unsigned long) HashSymbol(ValueToString(fieldPtr[i].value),theRange);
count += (unsigned long) (tvalue * (i + 29));
break;
}
}
/*========================*/
/* Return the hash value. */
/*========================*/
return(count);
}
globle void PrintAtom(
char *logicalName,
int type,
void *value)
{
char buffer[20];
switch (type)
{
case FLOAT:
PrintFloat(logicalName,ValueToDouble(value));
break;
case INTEGER:
PrintLongInteger(logicalName,ValueToLong(value));
break;
case SYMBOL:
PrintRouter(logicalName,ValueToString(value));
break;
case STRING:
if (PreserveEscapedCharacters)
{ PrintRouter(logicalName,StringPrintForm(ValueToString(value))); }
else
{
PrintRouter(logicalName,"\"");
PrintRouter(logicalName,ValueToString(value));
PrintRouter(logicalName,"\"");
}
break;
case EXTERNAL_ADDRESS:
if (AddressesToStrings) PrintRouter(logicalName,"\"");
PrintRouter(logicalName,"<Pointer-");
sprintf(buffer,"%p",value);
PrintRouter(logicalName,buffer);
PrintRouter(logicalName,">");
if (AddressesToStrings) PrintRouter(logicalName,"\"");
break;
#if OBJECT_SYSTEM
case INSTANCE_NAME:
PrintRouter(logicalName,"[");
PrintRouter(logicalName,ValueToString(value));
PrintRouter(logicalName,"]");
break;
#endif
#if FUZZY_DEFTEMPLATES
case FUZZY_VALUE:
PrintFuzzyValue(logicalName,ValueToFuzzyValue(value));
break;
#endif
case RVOID:
break;
default:
if (PrimitivesArray[type] == NULL) break;
if (PrimitivesArray[type]->longPrintFunction == NULL)
{
PrintRouter(logicalName,"<unknown atom type>");
break;
}
(*PrimitivesArray[type]->longPrintFunction)(logicalName,value);
break;
}
}
globle void PrintAtom(
void *theEnv,
const char *logicalName,
int type,
void *value)
{
struct externalAddressHashNode *theAddress;
char buffer[20];
switch (type)
{
case FLOAT:
PrintFloat(theEnv,logicalName,ValueToDouble(value));
break;
case INTEGER:
PrintLongInteger(theEnv,logicalName,ValueToLong(value));
break;
case SYMBOL:
EnvPrintRouter(theEnv,logicalName,ValueToString(value));
break;
case STRING:
if (PrintUtilityData(theEnv)->PreserveEscapedCharacters)
{ EnvPrintRouter(theEnv,logicalName,StringPrintForm(theEnv,ValueToString(value))); }
else
{
EnvPrintRouter(theEnv,logicalName,"\"");
EnvPrintRouter(theEnv,logicalName,ValueToString(value));
EnvPrintRouter(theEnv,logicalName,"\"");
}
break;
case DATA_OBJECT_ARRAY:
if (PrintUtilityData(theEnv)->AddressesToStrings) EnvPrintRouter(theEnv,logicalName,"\"");
EnvPrintRouter(theEnv,logicalName,"<Pointer-");
gensprintf(buffer,"%p",value);
EnvPrintRouter(theEnv,logicalName,buffer);
EnvPrintRouter(theEnv,logicalName,">");
if (PrintUtilityData(theEnv)->AddressesToStrings) EnvPrintRouter(theEnv,logicalName,"\"");
break;
case EXTERNAL_ADDRESS:
theAddress = (struct externalAddressHashNode *) value;
if (PrintUtilityData(theEnv)->AddressesToStrings) EnvPrintRouter(theEnv,logicalName,"\"");
if ((EvaluationData(theEnv)->ExternalAddressTypes[theAddress->type] != NULL) &&
(EvaluationData(theEnv)->ExternalAddressTypes[theAddress->type]->longPrintFunction != NULL))
{ (*EvaluationData(theEnv)->ExternalAddressTypes[theAddress->type]->longPrintFunction)(theEnv,logicalName,value); }
else
{
EnvPrintRouter(theEnv,logicalName,"<Pointer-");
gensprintf(buffer,"%d-",theAddress->type);
EnvPrintRouter(theEnv,logicalName,buffer);
gensprintf(buffer,"%p",ValueToExternalAddress(value));
EnvPrintRouter(theEnv,logicalName,buffer);
EnvPrintRouter(theEnv,logicalName,">");
}
if (PrintUtilityData(theEnv)->AddressesToStrings) EnvPrintRouter(theEnv,logicalName,"\"");
break;
#if OBJECT_SYSTEM
case INSTANCE_NAME:
EnvPrintRouter(theEnv,logicalName,"[");
EnvPrintRouter(theEnv,logicalName,ValueToString(value));
EnvPrintRouter(theEnv,logicalName,"]");
break;
#endif
case RVOID:
break;
default:
if (EvaluationData(theEnv)->PrimitivesArray[type] == NULL) break;
if (EvaluationData(theEnv)->PrimitivesArray[type]->longPrintFunction == NULL)
{
EnvPrintRouter(theEnv,logicalName,"<unknown atom type>");
break;
}
(*EvaluationData(theEnv)->PrimitivesArray[type]->longPrintFunction)(theEnv,logicalName,value);
break;
}
}
globle intBool NumericNotEqualFunction(
void *theEnv,
EXEC_STATUS)
{
EXPRESSION *theArgument;
DATA_OBJECT rv1, rv2;
int pos = 1;
/*=========================*/
/* Get the first argument. */
/*=========================*/
theArgument = GetFirstArgument();
if (theArgument == NULL) { return(TRUE); }
if (! GetNumericArgument(theEnv,execStatus,theArgument,"<>",&rv1,FALSE,pos)) return(FALSE);
pos++;
/*=================================================*/
/* Compare each of the subsequent arguments to the */
/* first. If any is equal, then return FALSE. */
/*=================================================*/
for (theArgument = GetNextArgument(theArgument);
theArgument != NULL;
theArgument = GetNextArgument(theArgument), pos++)
{
if (! GetNumericArgument(theEnv,execStatus,theArgument,"<>",&rv2,FALSE,pos)) return(FALSE);
if (rv1.type == INTEGER)
{
if (rv2.type == INTEGER)
{
if (ValueToLong(rv1.value) == ValueToLong(rv2.value))
{ return(FALSE); }
}
else
{
if ((double) ValueToLong(rv1.value) == ValueToDouble(rv2.value))
{ return(FALSE); }
}
}
else
{
if (rv2.type == INTEGER)
{
if (ValueToDouble(rv1.value) == (double) ValueToLong(rv2.value))
{ return(FALSE); }
}
else
{
if (ValueToDouble(rv1.value) == ValueToDouble(rv2.value))
{ return(FALSE); }
}
}
}
/*===================================*/
/* All arguments were unequal to the */
/* first argument. Return TRUE. */
/*===================================*/
return(TRUE);
}
globle intBool GreaterThanFunction(
void *theEnv,
EXEC_STATUS)
{
EXPRESSION *theArgument;
DATA_OBJECT rv1, rv2;
int pos = 1;
/*=========================*/
/* Get the first argument. */
/*=========================*/
theArgument = GetFirstArgument();
if (theArgument == NULL) { return(TRUE); }
if (! GetNumericArgument(theEnv,execStatus,theArgument,">",&rv1,FALSE,pos)) return(FALSE);
pos++;
/*==========================================*/
/* Compare each of the subsequent arguments */
/* to its predecessor. If any is lesser or */
/* equal, then return FALSE. */
/*==========================================*/
for (theArgument = GetNextArgument(theArgument);
theArgument != NULL;
theArgument = GetNextArgument(theArgument), pos++)
{
if (! GetNumericArgument(theEnv,execStatus,theArgument,">",&rv2,FALSE,pos)) return(FALSE);
if (rv1.type == INTEGER)
{
if (rv2.type == INTEGER)
{
if (ValueToLong(rv1.value) <= ValueToLong(rv2.value))
{ return(FALSE); }
}
else
{
if ((double) ValueToLong(rv1.value) <= ValueToDouble(rv2.value))
{ return(FALSE); }
}
}
else
{
if (rv2.type == INTEGER)
{
if (ValueToDouble(rv1.value) <= (double) ValueToLong(rv2.value))
{ return(FALSE); }
}
else
{
if (ValueToDouble(rv1.value) <= ValueToDouble(rv2.value))
{ return(FALSE); }
}
}
rv1.type = rv2.type;
rv1.value = rv2.value;
}
/*================================*/
/* Each argument was greater than */
/* its predecessor. Return TRUE. */
/*================================*/
return(TRUE);
}
static BOOLEAN MultifieldCardinalityViolation(
struct lhsParseNode *theNode)
{
struct lhsParseNode *tmpNode;
struct expr *tmpMax;
long minFields = 0;
long maxFields = 0;
int posInfinity = FALSE;
CONSTRAINT_RECORD *newConstraint, *tempConstraint;
/*================================*/
/* A single field slot can't have */
/* a cardinality violation. */
/*================================*/
if (theNode->multifieldSlot == FALSE) return(FALSE);
/*=============================================*/
/* Determine the minimum and maximum number of */
/* fields the slot could contain based on the */
/* slot constraints found in the pattern. */
/*=============================================*/
for (tmpNode = theNode->bottom;
tmpNode != NULL;
tmpNode = tmpNode->right)
{
/*====================================================*/
/* A single field variable increases both the minimum */
/* and maximum number of fields by one. */
/*====================================================*/
if ((tmpNode->type == SF_VARIABLE) ||
(tmpNode->type == SF_WILDCARD))
{
minFields++;
maxFields++;
}
/*=================================================*/
/* Otherwise a multifield wildcard or variable has */
/* been encountered. If it is constrained then use */
/* minimum and maximum number of fields constraint */
/* associated with this LHS node. */
/*=================================================*/
else if (tmpNode->constraints != NULL)
{
/*=======================================*/
/* The lowest minimum of all the min/max */
/* pairs will be the first in the list. */
/*=======================================*/
if (tmpNode->constraints->minFields->value != NegativeInfinity)
{ minFields += ValueToLong(tmpNode->constraints->minFields->value); }
/*=========================================*/
/* The greatest maximum of all the min/max */
/* pairs will be the last in the list. */
/*=========================================*/
tmpMax = tmpNode->constraints->maxFields;
while (tmpMax->nextArg != NULL) tmpMax = tmpMax->nextArg;
if (tmpMax->value == PositiveInfinity)
{ posInfinity = TRUE; }
else
{ maxFields += ValueToLong(tmpMax->value); }
}
/*================================================*/
/* Otherwise an unconstrained multifield wildcard */
/* or variable increases the maximum number of */
/* fields to positive infinity. */
/*================================================*/
else
{ posInfinity = TRUE; }
}
/*==================================================================*/
/* Create a constraint record for the cardinality of the sum of the */
/* cardinalities of the restrictions inside the multifield slot. */
/*==================================================================*/
if (theNode->constraints == NULL) tempConstraint = GetConstraintRecord();
else tempConstraint = CopyConstraintRecord(theNode->constraints);
ReturnExpression(tempConstraint->minFields);
ReturnExpression(tempConstraint->maxFields);
tempConstraint->minFields = GenConstant(INTEGER,AddLong((long) minFields));
if (posInfinity) tempConstraint->maxFields = GenConstant(SYMBOL,PositiveInfinity);
else tempConstraint->maxFields = GenConstant(INTEGER,AddLong((long) maxFields));
/*================================================================*/
/* Determine the final cardinality for the multifield slot by */
/* intersecting the cardinality sum of the restrictions within */
/* the multifield slot with the original cardinality of the slot. */
/*================================================================*/
newConstraint = IntersectConstraints(theNode->constraints,tempConstraint);
if (theNode->derivedConstraints) RemoveConstraint(theNode->constraints);
RemoveConstraint(tempConstraint);
theNode->constraints = newConstraint;
theNode->derivedConstraints = TRUE;
/*===================================================================*/
/* Determine if the final cardinality for the slot can be satisfied. */
/*===================================================================*/
if (GetStaticConstraintChecking() == FALSE) return(FALSE);
if (UnmatchableConstraint(newConstraint)) return(TRUE);
return(FALSE);
}
globle intBool LessThanOrEqualFunction(
void *theEnv)
{
EXPRESSION *theArgument;
DATA_OBJECT rv1, rv2;
int pos = 1;
/*=========================*/
/* Get the first argument. */
/*=========================*/
theArgument = GetFirstArgument();
if (theArgument == NULL) { return(TRUE); }
if (! GetNumericArgument(theEnv,theArgument,"<=",&rv1,FALSE,pos)) return(FALSE);
pos++;
/*====================================================*/
/* Compare each of the subsequent arguments to its */
/* predecessor. If any is greater, then return FALSE. */
/*====================================================*/
for (theArgument = GetNextArgument(theArgument);
theArgument != NULL;
theArgument = GetNextArgument(theArgument), pos++)
{
if (! GetNumericArgument(theEnv,theArgument,"<=",&rv2,FALSE,pos)) return(FALSE);
if (rv1.type == INTEGER)
{
if (rv2.type == INTEGER)
{
if (ValueToLong(rv1.value) > ValueToLong(rv2.value))
{ return(FALSE); }
}
else
{
if ((double) ValueToLong(rv1.value) > ValueToDouble(rv2.value))
{ return(FALSE); }
}
}
else
{
if (rv2.type == INTEGER)
{
if (ValueToDouble(rv1.value) > (double) ValueToLong(rv2.value))
{ return(FALSE); }
}
else
{
if (ValueToDouble(rv1.value) > ValueToDouble(rv2.value))
{ return(FALSE); }
}
}
rv1.type = rv2.type;
rv1.value = rv2.value;
}
/*======================================*/
/* Each argument was less than or equal */
/* to it predecessor. Return TRUE. */
/*======================================*/
return(TRUE);
}
globle void MaxFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
DATA_OBJECT argValue;
int numberOfArguments, i;
/*============================================*/
/* Check for the correct number of arguments. */
/*============================================*/
if ((numberOfArguments = EnvArgCountCheck(theEnv,"max",AT_LEAST,1)) == -1)
{
returnValue->type = INTEGER;
returnValue->value = (void *) EnvAddLong(theEnv,0L);
return;
}
/*============================================*/
/* Check that the first argument is a number. */
/*============================================*/
if (EnvArgTypeCheck(theEnv,"max",1,INTEGER_OR_FLOAT,returnValue) == FALSE)
{
returnValue->type = INTEGER;
returnValue->value = (void *) EnvAddLong(theEnv,0L);
return;
}
/*===========================================================*/
/* Loop through the remaining arguments, first checking each */
/* argument to see that it is a number, and then determining */
/* if the argument is greater than the previous arguments */
/* and is thus the maximum value. */
/*===========================================================*/
for (i = 2 ; i <= numberOfArguments ; i++)
{
if (EnvArgTypeCheck(theEnv,"max",i,INTEGER_OR_FLOAT,&argValue) == FALSE) return;
if (returnValue->type == INTEGER)
{
if (argValue.type == INTEGER)
{
if (ValueToLong(returnValue->value) < ValueToLong(argValue.value))
{
returnValue->type = argValue.type;
returnValue->value = argValue.value;
}
}
else
{
if ((double) ValueToLong(returnValue->value) <
ValueToDouble(argValue.value))
{
returnValue->type = argValue.type;
returnValue->value = argValue.value;
}
}
}
else
{
if (argValue.type == INTEGER)
{
if (ValueToDouble(returnValue->value) <
(double) ValueToLong(argValue.value))
{
returnValue->type = argValue.type;
returnValue->value = argValue.value;
}
}
else
{
if (ValueToDouble(returnValue->value) < ValueToDouble(argValue.value))
{
returnValue->type = argValue.type;
returnValue->value = argValue.value;
}
}
}
}
return;
}
globle void *ImplodeMultifield(
void *theEnv,
DATA_OBJECT *value)
{
size_t strsize = 0;
long i, j;
const char *tmp_str;
char *ret_str;
void *rv;
struct multifield *theMultifield;
DATA_OBJECT tempDO;
/*===================================================*/
/* Determine the size of the string to be allocated. */
/*===================================================*/
theMultifield = (struct multifield *) GetpValue(value);
for (i = GetpDOBegin(value) ; i <= GetpDOEnd(value) ; i++)
{
if (GetMFType(theMultifield,i) == FLOAT)
{
tmp_str = FloatToString(theEnv,ValueToDouble(GetMFValue(theMultifield,i)));
strsize += strlen(tmp_str) + 1;
}
else if (GetMFType(theMultifield,i) == INTEGER)
{
tmp_str = LongIntegerToString(theEnv,ValueToLong(GetMFValue(theMultifield,i)));
strsize += strlen(tmp_str) + 1;
}
else if (GetMFType(theMultifield,i) == STRING)
{
strsize += strlen(ValueToString(GetMFValue(theMultifield,i))) + 3;
tmp_str = ValueToString(GetMFValue(theMultifield,i));
while(*tmp_str)
{
if (*tmp_str == '"')
{ strsize++; }
else if (*tmp_str == '\\') /* GDR 111599 #835 */
{ strsize++; } /* GDR 111599 #835 */
tmp_str++;
}
}
#if OBJECT_SYSTEM
else if (GetMFType(theMultifield,i) == INSTANCE_NAME)
{ strsize += strlen(ValueToString(GetMFValue(theMultifield,i))) + 3; }
else if (GetMFType(theMultifield,i) == INSTANCE_ADDRESS)
{ strsize += strlen(ValueToString(((INSTANCE_TYPE *)
GetMFValue(theMultifield,i))->name)) + 3; }
#endif
else
{
SetType(tempDO,GetMFType(theMultifield,i));
SetValue(tempDO,GetMFValue(theMultifield,i));
strsize += strlen(DataObjectToString(theEnv,&tempDO)) + 1;
}
}
/*=============================================*/
/* Allocate the string and copy all components */
/* of the MULTIFIELD variable to it. */
/*=============================================*/
if (strsize == 0) return(EnvAddSymbol(theEnv,""));
ret_str = (char *) gm2(theEnv,strsize);
for(j=0, i=GetpDOBegin(value); i <= GetpDOEnd(value) ; i++)
{
/*============================*/
/* Convert numbers to strings */
/*============================*/
if (GetMFType(theMultifield,i) == FLOAT)
{
tmp_str = FloatToString(theEnv,ValueToDouble(GetMFValue(theMultifield,i)));
while(*tmp_str)
{
*(ret_str+j) = *tmp_str;
j++, tmp_str++;
}
}
else if (GetMFType(theMultifield,i) == INTEGER)
{
tmp_str = LongIntegerToString(theEnv,ValueToLong(GetMFValue(theMultifield,i)));
while(*tmp_str)
{
*(ret_str+j) = *tmp_str;
j++, tmp_str++;
}
}
/*=======================================*/
/* Enclose strings in quotes and preceed */
/* imbedded quotes with a backslash */
/*=======================================*/
else if (GetMFType(theMultifield,i) == STRING)
{
tmp_str = ValueToString(GetMFValue(theMultifield,i));
*(ret_str+j) = '"';
j++;
while(*tmp_str)
{
if (*tmp_str == '"')
{
*(ret_str+j) = '\\';
j++;
}
else if (*tmp_str == '\\') /* GDR 111599 #835 */
{ /* GDR 111599 #835 */
*(ret_str+j) = '\\'; /* GDR 111599 #835 */
j++; /* GDR 111599 #835 */
} /* GDR 111599 #835 */
*(ret_str+j) = *tmp_str;
j++, tmp_str++;
}
*(ret_str+j) = '"';
j++;
}
#if OBJECT_SYSTEM
else if (GetMFType(theMultifield,i) == INSTANCE_NAME)
{
tmp_str = ValueToString(GetMFValue(theMultifield,i));
*(ret_str + j++) = '[';
while(*tmp_str)
{
*(ret_str+j) = *tmp_str;
j++, tmp_str++;
}
*(ret_str + j++) = ']';
}
else if (GetMFType(theMultifield,i) == INSTANCE_ADDRESS)
{
tmp_str = ValueToString(((INSTANCE_TYPE *) GetMFValue(theMultifield,i))->name);
*(ret_str + j++) = '[';
while(*tmp_str)
{
*(ret_str+j) = *tmp_str;
j++, tmp_str++;
}
*(ret_str + j++) = ']';
}
#endif
else
{
SetType(tempDO,GetMFType(theMultifield,i));
SetValue(tempDO,GetMFValue(theMultifield,i));
tmp_str = DataObjectToString(theEnv,&tempDO);
while(*tmp_str)
{
*(ret_str+j) = *tmp_str;
j++, tmp_str++;
}
}
*(ret_str+j) = ' ';
j++;
}
*(ret_str+j-1) = '\0';
/*====================*/
/* Return the string. */
/*====================*/
rv = EnvAddSymbol(theEnv,ret_str);
rm(theEnv,ret_str,strsize);
return(rv);
}
globle long DivFunction(
void *theEnv)
{
long total = 1L;
EXPRESSION *theExpression;
DATA_OBJECT theArgument;
int pos = 1;
long theNumber;
/*===================================================*/
/* Get the first argument. This number which will be */
/* the starting product from which all subsequent */
/* arguments will divide. */
/*===================================================*/
theExpression = GetFirstArgument();
if (theExpression != NULL)
{
if (! GetNumericArgument(theEnv,theExpression,"div",&theArgument,FALSE,pos)) theExpression = NULL;
else theExpression = GetNextArgument(theExpression);
if (theArgument.type == INTEGER)
{ total = ValueToLong(theArgument.value); }
else
{ total = (long) ValueToDouble(theArgument.value); }
pos++;
}
/*=====================================================*/
/* Loop through each of the arguments dividing it into */
/* a running product. Floats are converted to integers */
/* and each argument is checked to prevent a divide by */
/* zero error. */
/*=====================================================*/
while (theExpression != NULL)
{
if (! GetNumericArgument(theEnv,theExpression,"div",&theArgument,FALSE,pos)) theExpression = NULL;
else theExpression = GetNextArgument(theExpression);
if (theArgument.type == INTEGER) theNumber = ValueToLong(theArgument.value);
else if (theArgument.type == FLOAT) theNumber = (long) ValueToDouble(theArgument.value);
else theNumber = 1;
if (theNumber == 0L)
{
DivideByZeroErrorMessage(theEnv,"div");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(1L);
}
if (theArgument.type == INTEGER)
{ total /= ValueToLong(theArgument.value); }
else
{ total = total / (long) ValueToDouble(theArgument.value); }
pos++;
}
/*======================================================*/
/* The result of the div function is always an integer. */
/*======================================================*/
return(total);
}
struct lhsParseNode *RestrictionParse(
char *readSource,
struct token *theToken,
int multifieldSlot,
struct symbolHashNode *theSlot,
int slotNumber,
CONSTRAINT_RECORD *theConstraints,
int position)
{
struct lhsParseNode *topNode = NULL, *lastNode = NULL, *nextNode;
int numberOfSingleFields = 0;
int numberOfMultifields = 0;
int startPosition = position;
int error = FALSE;
CONSTRAINT_RECORD *tempConstraints;
/*==================================================*/
/* Keep parsing fields until a right parenthesis is */
/* encountered. This will either indicate the end */
/* of an instance or deftemplate slot or the end of */
/* an ordered fact. */
/*==================================================*/
while (theToken->type != RPAREN)
{
/*========================================*/
/* Look for either a single or multifield */
/* wildcard or a conjuctive restriction. */
/*========================================*/
if ((theToken->type == SF_WILDCARD) ||
(theToken->type == MF_WILDCARD))
{
nextNode = GetLHSParseNode();
nextNode->type = theToken->type;
nextNode->negated = FALSE;
GetToken(readSource,theToken);
}
else
{
nextNode = ConjuctiveRestrictionParse(readSource,theToken,&error);
if (nextNode == NULL)
{
ReturnLHSParseNodes(topNode);
return(NULL);
}
}
/*========================================================*/
/* Fix up the pretty print representation of a multifield */
/* slot so that the fields don't run together. */
/*========================================================*/
if ((theToken->type != RPAREN) && (multifieldSlot == TRUE))
{
PPBackup();
SavePPBuffer(" ");
SavePPBuffer(theToken->printForm);
}
/*========================================*/
/* Keep track of the number of single and */
/* multifield restrictions encountered. */
/*========================================*/
if ((nextNode->type == SF_WILDCARD) || (nextNode->type == SF_VARIABLE))
{ numberOfSingleFields++; }
else
{ numberOfMultifields++; }
/*===================================*/
/* Assign the slot name and indices. */
/*===================================*/
nextNode->slot = theSlot;
nextNode->slotNumber = slotNumber;
nextNode->index = position++;
/*==============================================*/
/* If we're not dealing with a multifield slot, */
/* attach the constraints directly to the node */
/* and return. */
/*==============================================*/
if (! multifieldSlot)
{
if (theConstraints == NULL)
{
if (nextNode->type == SF_VARIABLE)
{ nextNode->constraints = GetConstraintRecord(); }
else nextNode->constraints = NULL;
}
else nextNode->constraints = theConstraints;
return(nextNode);
}
/*====================================================*/
/* Attach the restriction to the list of restrictions */
/* already parsed for this slot or ordered fact. */
/*====================================================*/
if (lastNode == NULL) topNode = nextNode;
else lastNode->right = nextNode;
lastNode = nextNode;
}
/*=====================================================*/
/* Once we're through parsing, check to make sure that */
/* a single field slot was given a restriction. If the */
/* following test fails, then we know we're dealing */
/* with a multifield slot. */
/*=====================================================*/
if ((topNode == NULL) && (! multifieldSlot))
{
SyntaxErrorMessage("defrule");
return(NULL);
}
/*===============================================*/
/* Loop through each of the restrictions in the */
/* list of restrictions for the multifield slot. */
/*===============================================*/
for (nextNode = topNode; nextNode != NULL; nextNode = nextNode->right)
{
/*===================================================*/
/* Assign a constraint record to each constraint. If */
/* the slot has an explicit constraint, then copy */
/* this and store it with the constraint. Otherwise, */
/* create a constraint record for a single field */
/* constraint and skip the constraint modifications */
/* for a multifield constraint. */
/*===================================================*/
if (theConstraints == NULL)
{
if (nextNode->type == SF_VARIABLE)
{ nextNode->constraints = GetConstraintRecord(); }
else
{ continue; }
}
else
{ nextNode->constraints = CopyConstraintRecord(theConstraints); }
/*==========================================*/
/* Remove the min and max field constraints */
/* for the entire slot from the constraint */
/* record for this single constraint. */
/*==========================================*/
ReturnExpression(nextNode->constraints->minFields);
ReturnExpression(nextNode->constraints->maxFields);
nextNode->constraints->minFields = GenConstant(SYMBOL,NegativeInfinity);
nextNode->constraints->maxFields = GenConstant(SYMBOL,PositiveInfinity);
nextNode->derivedConstraints = TRUE;
/*====================================================*/
/* If we're not dealing with a multifield constraint, */
/* then no further modifications are needed to the */
/* min and max constraints for this constraint. */
/*====================================================*/
if ((nextNode->type != MF_WILDCARD) && (nextNode->type != MF_VARIABLE))
{ continue; }
/*==========================================================*/
/* Create a separate constraint record to keep track of the */
/* cardinality information for this multifield constraint. */
/*==========================================================*/
tempConstraints = GetConstraintRecord();
SetConstraintType(MULTIFIELD,tempConstraints);
tempConstraints->singlefieldsAllowed = FALSE;
tempConstraints->multifield = nextNode->constraints;
nextNode->constraints = tempConstraints;
/*=====================================================*/
/* Adjust the min and max field values for this single */
/* multifield constraint based on the min and max */
/* fields for the entire slot and the number of single */
/* field values contained in the slot. */
/*=====================================================*/
if (theConstraints->maxFields->value != PositiveInfinity)
{
ReturnExpression(tempConstraints->maxFields);
tempConstraints->maxFields = GenConstant(INTEGER,AddLong(ValueToLong(theConstraints->maxFields->value) - numberOfSingleFields));
}
if ((numberOfMultifields == 1) && (theConstraints->minFields->value != NegativeInfinity))
{
ReturnExpression(tempConstraints->minFields);
tempConstraints->minFields = GenConstant(INTEGER,AddLong(ValueToLong(theConstraints->minFields->value) - numberOfSingleFields));
}
}
/*================================================*/
/* If a multifield slot is being parsed, place a */
/* node on top of the list of constraints parsed. */
/*================================================*/
if (multifieldSlot)
{
nextNode = GetLHSParseNode();
nextNode->type = MF_WILDCARD;
nextNode->multifieldSlot = TRUE;
nextNode->bottom = topNode;
nextNode->slot = theSlot;
nextNode->slotNumber = slotNumber;
nextNode->index = startPosition;
nextNode->constraints = theConstraints;
topNode = nextNode;
TallyFieldTypes(topNode->bottom);
}
/*=================================*/
/* Return the list of constraints. */
/*=================================*/
return(topNode);
}
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 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);
}
static void StrOrSymCatFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue,
unsigned short returnType)
{
DATA_OBJECT theArg;
int numArgs, i, total, j;
char *theString;
SYMBOL_HN **arrayOfStrings;
SYMBOL_HN *hashPtr;
char *functionName;
/*============================================*/
/* Determine the calling function name. */
/* Store the null string or the symbol nil as */
/* the return value in the event of an error. */
/*============================================*/
SetpType(returnValue,returnType);
if (returnType == STRING)
{
functionName = "str-cat";
SetpValue(returnValue,(void *) EnvAddSymbol(theEnv,""));
}
else
{
functionName = "sym-cat";
SetpValue(returnValue,(void *) EnvAddSymbol(theEnv,"nil"));
}
/*===============================================*/
/* Determine the number of arguments as create a */
/* string array which is large enough to store */
/* the string representation of each argument. */
/*===============================================*/
numArgs = EnvRtnArgCount(theEnv);
arrayOfStrings = (SYMBOL_HN **) gm1(theEnv,(int) sizeof(SYMBOL_HN *) * numArgs);
for (i = 0; i < numArgs; i++)
{ arrayOfStrings[i] = NULL; }
/*=============================================*/
/* Evaluate each argument and store its string */
/* representation in the string array. */
/*=============================================*/
total = 1;
for (i = 1 ; i <= numArgs ; i++)
{
EnvRtnUnknown(theEnv,i,&theArg);
switch(GetType(theArg))
{
case STRING:
#if OBJECT_SYSTEM
case INSTANCE_NAME:
#endif
case SYMBOL:
hashPtr = (SYMBOL_HN *) GetValue(theArg);
arrayOfStrings[i-1] = hashPtr;
IncrementSymbolCount(hashPtr);
break;
case FLOAT:
hashPtr = (SYMBOL_HN *) EnvAddSymbol(theEnv,FloatToString(theEnv,ValueToDouble(GetValue(theArg))));
arrayOfStrings[i-1] = hashPtr;
IncrementSymbolCount(hashPtr);
break;
case INTEGER:
hashPtr = (SYMBOL_HN *) EnvAddSymbol(theEnv,LongIntegerToString(theEnv,ValueToLong(GetValue(theArg))));
arrayOfStrings[i-1] = hashPtr;
IncrementSymbolCount(hashPtr);
break;
default:
ExpectedTypeError1(theEnv,functionName,i,"string, instance name, symbol, float, or integer");
SetEvaluationError(theEnv,TRUE);
break;
}
if (EvaluationData(theEnv)->EvaluationError)
{
for (i = 0; i < numArgs; i++)
{
if (arrayOfStrings[i] != NULL)
{ DecrementSymbolCount(theEnv,arrayOfStrings[i]); }
}
rm(theEnv,arrayOfStrings,sizeof(SYMBOL_HN *) * numArgs);
return;
}
total += (int) strlen(ValueToString(arrayOfStrings[i - 1]));
}
/*=========================================================*/
/* Allocate the memory to store the concatenated string or */
/* symbol, then copy the values in the string array to the */
/* memory just allocated. */
/*=========================================================*/
theString = (char *) gm2(theEnv,(sizeof(char) * total));
j = 0;
for (i = 0 ; i < numArgs ; i++)
{
sprintf(&theString[j],"%s",ValueToString(arrayOfStrings[i]));
j += (int) strlen(ValueToString(arrayOfStrings[i]));
}
/*=========================================*/
/* Return the concatenated value and clean */
/* up the temporary memory used. */
/*=========================================*/
SetpValue(returnValue,(void *) EnvAddSymbol(theEnv,theString));
rm(theEnv,theString,sizeof(char) * total);
for (i = 0; i < numArgs; i++)
{
if (arrayOfStrings[i] != NULL)
{ DecrementSymbolCount(theEnv,arrayOfStrings[i]); }
}
rm(theEnv,arrayOfStrings,sizeof(SYMBOL_HN *) * numArgs);
}
globle int CompareNumbers(
void *theEnv,
EXEC_STATUS,
int type1,
void *vptr1,
int type2,
void *vptr2)
{
/*============================================*/
/* Handle the situation in which the values */
/* are exactly equal (same type, same value). */
/*============================================*/
if (vptr1 == vptr2) return(EQUAL);
/*=======================================*/
/* Handle the special cases for positive */
/* and negative infinity. */
/*=======================================*/
if (vptr1 == SymbolData(theEnv,execStatus)->PositiveInfinity) return(GREATER_THAN);
if (vptr1 == SymbolData(theEnv,execStatus)->NegativeInfinity) return(LESS_THAN);
if (vptr2 == SymbolData(theEnv,execStatus)->PositiveInfinity) return(LESS_THAN);
if (vptr2 == SymbolData(theEnv,execStatus)->NegativeInfinity) return(GREATER_THAN);
/*=======================*/
/* Compare two integers. */
/*=======================*/
if ((type1 == INTEGER) && (type2 == INTEGER))
{
if (ValueToLong(vptr1) < ValueToLong(vptr2))
{ return(LESS_THAN); }
else if (ValueToLong(vptr1) > ValueToLong(vptr2))
{ return(GREATER_THAN); }
return(EQUAL);
}
/*=====================*/
/* Compare two floats. */
/*=====================*/
if ((type1 == FLOAT) && (type2 == FLOAT))
{
if (ValueToDouble(vptr1) < ValueToDouble(vptr2))
{ return(LESS_THAN); }
else if (ValueToDouble(vptr1) > ValueToDouble(vptr2))
{ return(GREATER_THAN); }
return(EQUAL);
}
/*================================*/
/* Compare an integer to a float. */
/*================================*/
if ((type1 == INTEGER) && (type2 == FLOAT))
{
if (((double) ValueToLong(vptr1)) < ValueToDouble(vptr2))
{ return(LESS_THAN); }
else if (((double) ValueToLong(vptr1)) > ValueToDouble(vptr2))
{ return(GREATER_THAN); }
return(EQUAL);
}
/*================================*/
/* Compare a float to an integer. */
/*================================*/
if ((type1 == FLOAT) && (type2 == INTEGER))
{
if (ValueToDouble(vptr1) < ((double) ValueToLong(vptr2)))
{ return(LESS_THAN); }
else if (ValueToDouble(vptr1) > ((double) ValueToLong(vptr2)))
{ return(GREATER_THAN); }
return(EQUAL);
}
/*===================================*/
/* One of the arguments was invalid. */
/* Return -1 to indicate an error. */
/*===================================*/
return(-1);
}
globle void RetractCommand(
void *theEnv)
{
long long factIndex;
struct fact *ptr;
struct expr *theArgument;
DATA_OBJECT theResult;
int argNumber;
/*================================*/
/* Iterate through each argument. */
/*================================*/
for (theArgument = GetFirstArgument(), argNumber = 1;
theArgument != NULL;
theArgument = GetNextArgument(theArgument), argNumber++)
{
/*========================*/
/* Evaluate the argument. */
/*========================*/
EvaluateExpression(theEnv,theArgument,&theResult);
/*===============================================*/
/* If the argument evaluates to an integer, then */
/* it's assumed to be the fact index of the fact */
/* to be retracted. */
/*===============================================*/
if (theResult.type == INTEGER)
{
/*==========================================*/
/* A fact index must be a positive integer. */
/*==========================================*/
factIndex = ValueToLong(theResult.value);
if (factIndex < 0)
{
ExpectedTypeError1(theEnv,(char*)"retract",argNumber,(char*)"fact-address, fact-index, or the symbol *");
return;
}
/*================================================*/
/* See if a fact with the specified index exists. */
/*================================================*/
ptr = FindIndexedFact(theEnv,factIndex);
/*=====================================*/
/* If the fact exists then retract it, */
/* otherwise print an error message. */
/*=====================================*/
if (ptr != NULL)
{ EnvRetract(theEnv,(void *) ptr); }
else
{
char tempBuffer[20];
gensprintf(tempBuffer,"f-%lld",factIndex);
CantFindItemErrorMessage(theEnv,(char*)"fact",tempBuffer);
}
}
/*===============================================*/
/* Otherwise if the argument evaluates to a fact */
/* address, we can directly retract it. */
/*===============================================*/
else if (theResult.type == FACT_ADDRESS)
{ EnvRetract(theEnv,theResult.value); }
/*============================================*/
/* Otherwise if the argument evaluates to the */
/* symbol *, then all facts are retracted. */
/*============================================*/
else if ((theResult.type == SYMBOL) ?
(strcmp(ValueToString(theResult.value),"*") == 0) : FALSE)
{
RemoveAllFacts(theEnv);
return;
}
/*============================================*/
/* Otherwise the argument has evaluated to an */
/* illegal value for the retract command. */
/*============================================*/
else
{
ExpectedTypeError1(theEnv,(char*)"retract",argNumber,(char*)"fact-address, fact-index, or the symbol *");
SetEvaluationError(theEnv,TRUE);
}
}
}
static int EvaluateSalience(
void *theEnv,
void *vPtr)
{
struct defrule *rPtr = (struct defrule *) vPtr;
DATA_OBJECT salienceValue;
int salience;
/*==================================================*/
/* If saliences are only being evaluated when rules */
/* are defined, then just return the last salience */
/* value evaluated for the rule. */
/*==================================================*/
if (EnvGetSalienceEvaluation(theEnv) == WHEN_DEFINED)
{
return(rPtr->salience);
}
/*=================================================================*/
/* If the rule's salience value was defined as an integer constant */
/* (i.e., not an expression or global variable which could change */
/* on reevaluation), then just return the salience value computed */
/* for the rule when it was defined. */
/*=================================================================*/
if (rPtr->dynamicSalience == NULL) return(rPtr->salience);
/*====================================================*/
/* Reevaluate the rule's salience. If an error occurs */
/* during evaluation, print an error message. */
/*====================================================*/
SetEvaluationError(theEnv,FALSE);
if (EvaluateExpression(theEnv,rPtr->dynamicSalience,&salienceValue))
{
SalienceInformationError(theEnv,(char*)"defrule",ValueToString(rPtr->header.name));
return(rPtr->salience);
}
/*========================================*/
/* The salience value must be an integer. */
/*========================================*/
if (salienceValue.type != INTEGER)
{
SalienceNonIntegerError(theEnv);
SalienceInformationError(theEnv,(char*)"defrule",ValueToString(rPtr->header.name));
SetEvaluationError(theEnv,TRUE);
return(rPtr->salience);
}
/*==========================================*/
/* The salience value must fall between the */
/* minimum and maximum allowed values. */
/*==========================================*/
salience = (int) ValueToLong(salienceValue.value);
if ((salience > MAX_DEFRULE_SALIENCE) || (salience < MIN_DEFRULE_SALIENCE))
{
SalienceRangeError(theEnv,MIN_DEFRULE_SALIENCE,MAX_DEFRULE_SALIENCE);
SetEvaluationError(theEnv,TRUE);
SalienceInformationError(theEnv,(char*)"defrule",ValueToString(((struct defrule *) rPtr)->header.name));
return(rPtr->salience);
}
/*===================================*/
/* Store the new salience value with */
/* the rule and return this value. */
/*===================================*/
rPtr->salience = salience;
return(rPtr->salience);
}
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);
}
}
