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);
}
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 StrIndexFunction(
void *theEnv,
DATA_OBJECT_PTR result)
{
DATA_OBJECT theArgument1, theArgument2;
char *strg1, *strg2;
int i, j;
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
/*===================================*/
/* Check and retrieve the arguments. */
/*===================================*/
if (EnvArgCountCheck(theEnv,"str-index",EXACTLY,2) == -1) return;
if (EnvArgTypeCheck(theEnv,"str-index",1,SYMBOL_OR_STRING,&theArgument1) == FALSE) return;
if (EnvArgTypeCheck(theEnv,"str-index",2,SYMBOL_OR_STRING,&theArgument2) == FALSE) return;
strg1 = DOToString(theArgument1);
strg2 = DOToString(theArgument2);
/*=================================*/
/* Find the position in string2 of */
/* string1 (counting from 1). */
/*=================================*/
if (strlen(strg1) == 0)
{
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,(long) strlen(strg2) + 1L);
return;
}
for (i=1; *strg2; i++, strg2++)
{
for (j=0; *(strg1+j) && *(strg1+j) == *(strg2+j); j++)
{ /* Do Nothing */ }
if (*(strg1+j) == '\0')
{
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,(long) i);
return;
}
}
return;
}
/*************************************************************************
NAME : ReplaceSlotReference
DESCRIPTION : Replaces instance-set query function variable
references of the form: <instance-variable>:<slot-name>
with function calls to get these instance-slots at run
time
INPUTS : 1) The instance-set variable list
2) The expression containing the variable
3) The address of the instance slot access function
4) Nesting depth of query functions
RETURNS : Nothing useful
SIDE EFFECTS : If the variable is a slot reference, then it is replaced
with the appropriate function-call.
NOTES : None
*************************************************************************/
static void ReplaceSlotReference(
void *theEnv,
EXEC_STATUS,
EXPRESSION *vlist,
EXPRESSION *theExp,
struct FunctionDefinition *func,
int ndepth)
{
size_t len;
int posn,oldpp;
size_t i;
register char *str;
EXPRESSION *eptr;
struct token itkn;
str = ValueToString(theExp->value);
len = strlen(str);
if (len < 3)
return;
for (i = len-2 ; i >= 1 ; i--)
{
if ((str[i] == INSTANCE_SLOT_REF) ? (i >= 1) : FALSE)
{
eptr = vlist;
posn = 0;
while (eptr && ((i != strlen(ValueToString(eptr->value))) ||
strncmp(ValueToString(eptr->value),str,
(STD_SIZE) i)))
{
eptr = eptr->nextArg;
posn++;
}
if (eptr != NULL)
{
OpenStringSource(theEnv,execStatus,"query-var",str+i+1,0);
oldpp = GetPPBufferStatus(theEnv,execStatus);
SetPPBufferStatus(theEnv,execStatus,OFF);
GetToken(theEnv,execStatus,"query-var",&itkn);
SetPPBufferStatus(theEnv,execStatus,oldpp);
CloseStringSource(theEnv,execStatus,"query-var");
theExp->type = FCALL;
theExp->value = (void *) func;
theExp->argList = GenConstant(theEnv,execStatus,INTEGER,(void *) EnvAddLong(theEnv,execStatus,(long long) ndepth));
theExp->argList->nextArg =
GenConstant(theEnv,execStatus,INTEGER,(void *) EnvAddLong(theEnv,execStatus,(long long) posn));
theExp->argList->nextArg->nextArg = GenConstant(theEnv,execStatus,itkn.type,itkn.value);
break;
}
}
}
}
extern "C" void GetMouseLocation(void* theEnv, DATA_OBJECT_PTR returnValue) {
void* multifield;
AdventureEngine::AdventureEngineEngine* engine = PullOutEngine(theEnv);
multifield = EnvCreateMultifield(theEnv, 2);
Common::EventManager* _eventMan = engine->getEventManager();
Common::Point pos = _eventMan->getMousePos();
SetMFType(multifield, 1, INTEGER);
SetMFValue(multifield, 1, EnvAddLong(theEnv, pos.x));
SetMFType(multifield, 2, INTEGER);
SetMFValue(multifield, 2, EnvAddLong(theEnv, pos.y));
SetpType(returnValue, MULTIFIELD);
SetpValue(returnValue, multifield);
SetpDOBegin(returnValue, 1);
SetpDOEnd(returnValue, 2);
}
static EXPRESSION *GenTypeExpression(
void *theEnv,
EXPRESSION *top,
int nonCOOLCode,
int primitiveCode,
char *COOLName)
{
#if OBJECT_SYSTEM
#if MAC_MCW || IBM_MCW
#pragma unused(nonCOOLCode)
#endif
#endif
EXPRESSION *tmp;
#if OBJECT_SYSTEM
if (primitiveCode != -1)
tmp = GenConstant(theEnv,0,(void *) DefclassData(theEnv)->PrimitiveClassMap[primitiveCode]);
else
tmp = GenConstant(theEnv,0,(void *) LookupDefclassByMdlOrScope(theEnv,COOLName));
#else
tmp = GenConstant(theEnv,0,EnvAddLong(theEnv,(long) nonCOOLCode));
#endif
tmp->nextArg = top;
return(tmp);
}
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;
}
static void ReplaceLoopCountVars(
void *theEnv,
SYMBOL_HN *loopVar,
EXPRESSION *theExp,
int depth)
{
while (theExp != NULL)
{
if ((theExp->type != SF_VARIABLE) ? FALSE :
(strcmp(ValueToString(theExp->value),ValueToString(loopVar)) == 0))
{
theExp->type = FCALL;
theExp->value = (void *) FindFunction(theEnv,"(get-loop-count)");
theExp->argList = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,(long) depth));
}
else if (theExp->argList != NULL)
{
if ((theExp->type != FCALL) ? FALSE :
(theExp->value == (void *) FindFunction(theEnv,"loop-for-count")))
ReplaceLoopCountVars(theEnv,loopVar,theExp->argList,depth+1);
else
ReplaceLoopCountVars(theEnv,loopVar,theExp->argList,depth);
}
theExp = theExp->nextArg;
}
}
/***********************************************************************************
NAME : ReplaceInstanceVariables
DESCRIPTION : Replaces all references to instance-variables within an
instance query-function with function calls to query-instance
(which references the instance array at run-time)
INPUTS : 1) The instance-variable list
2) A boolean expression containing variable references
3) A flag indicating whether to allow slot references of the type
<instance-query-variable>:<slot-name> for direct slot access
or not
4) Nesting depth of query functions
RETURNS : Nothing useful
SIDE EFFECTS : If a SF_VARIABLE node is found and is on the list of instance
variables, it is replaced with a query-instance function call.
NOTES : Other SF_VARIABLE(S) are left alone for replacement by other
parsers. This implies that a user may use defgeneric,
defrule, and defmessage-handler variables within a query-function
where they do not conflict with instance-variable names.
***********************************************************************************/
static void ReplaceInstanceVariables(
void *theEnv,
EXEC_STATUS,
EXPRESSION *vlist,
EXPRESSION *bexp,
int sdirect,
int ndepth)
{
EXPRESSION *eptr;
struct FunctionDefinition *rindx_func,*rslot_func;
int posn;
rindx_func = FindFunction(theEnv,execStatus,"(query-instance)");
rslot_func = FindFunction(theEnv,execStatus,"(query-instance-slot)");
while (bexp != NULL)
{
if (bexp->type == SF_VARIABLE)
{
eptr = vlist;
posn = 0;
while ((eptr != NULL) ? (eptr->value != bexp->value) : FALSE)
{
eptr = eptr->nextArg;
posn++;
}
if (eptr != NULL)
{
bexp->type = FCALL;
bexp->value = (void *) rindx_func;
eptr = GenConstant(theEnv,execStatus,INTEGER,(void *) EnvAddLong(theEnv,execStatus,(long long) ndepth));
eptr->nextArg = GenConstant(theEnv,execStatus,INTEGER,(void *) EnvAddLong(theEnv,execStatus,(long long) posn));
bexp->argList = eptr;
}
else if (sdirect == TRUE)
ReplaceSlotReference(theEnv,execStatus,vlist,bexp,rslot_func,ndepth);
}
if (bexp->argList != NULL)
{
if (IsQueryFunction(bexp))
ReplaceInstanceVariables(theEnv,execStatus,vlist,bexp->argList,sdirect,ndepth+1);
else
ReplaceInstanceVariables(theEnv,execStatus,vlist,bexp->argList,sdirect,ndepth);
}
bexp = bexp->nextArg;
}
}
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);
}
}
/***************************************************
NAME : CheckForFacetConflicts
DESCRIPTION : Determines if all facets specified
(and inherited) for a slot are
consistent
INPUTS : 1) The slot descriptor
2) The parse record for the
type constraints on the slot
RETURNS : TRUE if all OK,
FALSE otherwise
SIDE EFFECTS : Min and Max fields replaced in
constraint for single-field slot
NOTES : None
***************************************************/
static intBool CheckForFacetConflicts(
void *theEnv,
EXEC_STATUS,
SLOT_DESC *sd,
CONSTRAINT_PARSE_RECORD *parsedConstraint)
{
if (sd->multiple == 0)
{
if (parsedConstraint->cardinality)
{
PrintErrorID(theEnv,execStatus,"CLSLTPSR",3,TRUE);
EnvPrintRouter(theEnv,execStatus,WERROR,"Cardinality facet can only be used with multifield slots\n");
return(FALSE);
}
else
{
ReturnExpression(theEnv,execStatus,sd->constraint->minFields);
ReturnExpression(theEnv,execStatus,sd->constraint->maxFields);
sd->constraint->minFields = GenConstant(theEnv,execStatus,INTEGER,EnvAddLong(theEnv,execStatus,1LL));
sd->constraint->maxFields = GenConstant(theEnv,execStatus,INTEGER,EnvAddLong(theEnv,execStatus,1LL));
}
}
if (sd->noDefault && sd->noWrite)
{
PrintErrorID(theEnv,execStatus,"CLSLTPSR",4,TRUE);
EnvPrintRouter(theEnv,execStatus,WERROR,"read-only slots must have a default value\n");
return(FALSE);
}
if (sd->noWrite && (sd->createWriteAccessor || sd->overrideMessageSpecified))
{
PrintErrorID(theEnv,execStatus,"CLSLTPSR",5,TRUE);
EnvPrintRouter(theEnv,execStatus,WERROR,"read-only slots cannot have a write accessor\n");
return(FALSE);
}
if (sd->noInherit && sd->publicVisibility)
{
PrintErrorID(theEnv,execStatus,"CLSLTPSR",6,TRUE);
EnvPrintRouter(theEnv,execStatus,WERROR,"no-inherit slots cannot also be public\n");
return(FALSE);
}
return(TRUE);
}
static void UpdateType(
void *theEnv,
void *buf,
long obji)
{
#if OBJECT_SYSTEM
DefgenericBinaryData(theEnv)->TypeArray[obji] = (void *) DefclassPointer(* (long *) buf);
#else
if ((* (long *) buf) > (long) INSTANCE_TYPE_CODE)
{
PrintWarningID(theEnv,(char*)"GENRCBIN",1,FALSE);
EnvPrintRouter(theEnv,WWARNING,(char*)"COOL not installed! User-defined class\n");
EnvPrintRouter(theEnv,WWARNING,(char*)" in method restriction substituted with OBJECT.\n");
DefgenericBinaryData(theEnv)->TypeArray[obji] = (void *) EnvAddLong(theEnv,(long long) OBJECT_TYPE_CODE);
}
else
DefgenericBinaryData(theEnv)->TypeArray[obji] = (void *) EnvAddLong(theEnv,* (long *) buf);
IncrementIntegerCount((INTEGER_HN *) DefgenericBinaryData(theEnv)->TypeArray[obji]);
#endif
}
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;
}
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;
}
extern "C" void GetCurrentlyPressedKeys(void* theEnv, DATA_OBJECT_PTR returnValue) {
void* multifield;
AdventureEngine::AdventureEngineEngine* engine = PullOutEngine(theEnv);
Common::EventManager* _eventMan = engine->getEventManager();
Common::Event keyEvent;
//this function does generate side effects if we assert facts
//However, if we return a multifield with all the contents then we need to
//parse it....hmmmmmm, doing the multifield is easier
//only check for a single key at this point
while(_eventMan->pollEvent(keyEvent))
{
//let's do a simple test
switch(keyEvent.type) {
case Common::EVENT_KEYDOWN:
switch(keyEvent.kbd.keycode) {
case Common::KEYCODE_ESCAPE:
multifield = EnvCreateMultifield(theEnv, 1);
SetMFType(multifield, 1, SYMBOL);
SetMFValue(multifield, 1, EnvAddSymbol(theEnv, (char*)"escape"));
SetpType(returnValue, MULTIFIELD);
SetpValue(returnValue, multifield);
SetpDOBegin(returnValue, 1);
SetpDOEnd(returnValue, 1);
return;
default:
multifield = EnvCreateMultifield(theEnv, 1);
SetMFType(multifield, 1, INTEGER);
SetMFValue(multifield, 1, EnvAddLong(theEnv, keyEvent.kbd.keycode));
SetpType(returnValue, MULTIFIELD);
SetpValue(returnValue, multifield);
SetpDOBegin(returnValue, 1);
SetpDOEnd(returnValue, 1);
return;
}
default:
NullMultifield(theEnv, returnValue);
return;
}
}
NullMultifield(theEnv, returnValue);
}
globle void ReadNeededIntegers(
void *theEnv)
{
long long *integerValues;
long i;
/*==============================================*/
/* Determine the number of integers to be read. */
/*==============================================*/
GenReadBinary(theEnv,&SymbolData(theEnv)->NumberOfIntegers,(unsigned long) sizeof(unsigned long int));
if (SymbolData(theEnv)->NumberOfIntegers == 0)
{
SymbolData(theEnv)->IntegerArray = NULL;
return;
}
/*=================================*/
/* Allocate area for the integers. */
/*=================================*/
integerValues = (long long *) gm3(theEnv,(long) (sizeof(long long) * SymbolData(theEnv)->NumberOfIntegers));
GenReadBinary(theEnv,(void *) integerValues,(unsigned long) (sizeof(long long) * SymbolData(theEnv)->NumberOfIntegers));
/*==========================================*/
/* Store the integers in the integer array. */
/*==========================================*/
SymbolData(theEnv)->IntegerArray = (INTEGER_HN **)
gm3(theEnv,(long) (sizeof(INTEGER_HN *) * SymbolData(theEnv)->NumberOfIntegers));
for (i = 0; i < SymbolData(theEnv)->NumberOfIntegers; i++)
{ SymbolData(theEnv)->IntegerArray[i] = (INTEGER_HN *) EnvAddLong(theEnv,integerValues[i]); }
/*==========================*/
/* Free the integer buffer. */
/*==========================*/
rm3(theEnv,(void *) integerValues,(long) (sizeof(long long) * SymbolData(theEnv)->NumberOfIntegers));
}
struct lhsParseNode *RestrictionParse(
void *theEnv,
char *readSource,
struct token *theToken,
int multifieldSlot,
struct symbolHashNode *theSlot,
short slotNumber,
CONSTRAINT_RECORD *theConstraints,
short position)
{
struct lhsParseNode *topNode = NULL, *lastNode = NULL, *nextNode;
int numberOfSingleFields = 0;
int numberOfMultifields = 0;
short 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(theEnv);
nextNode->type = theToken->type;
nextNode->negated = FALSE;
nextNode->exists = FALSE;
GetToken(theEnv,readSource,theToken);
}
else
{
nextNode = ConjuctiveRestrictionParse(theEnv,readSource,theToken,&error);
if (nextNode == NULL)
{
ReturnLHSParseNodes(theEnv,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(theEnv);
SavePPBuffer(theEnv," ");
SavePPBuffer(theEnv,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(theEnv); }
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(theEnv,"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(theEnv); }
else
{ continue; }
}
else
{ nextNode->constraints = CopyConstraintRecord(theEnv,theConstraints); }
/*==========================================*/
/* Remove the min and max field constraints */
/* for the entire slot from the constraint */
/* record for this single constraint. */
/*==========================================*/
ReturnExpression(theEnv,nextNode->constraints->minFields);
ReturnExpression(theEnv,nextNode->constraints->maxFields);
nextNode->constraints->minFields = GenConstant(theEnv,SYMBOL,SymbolData(theEnv)->NegativeInfinity);
nextNode->constraints->maxFields = GenConstant(theEnv,SYMBOL,SymbolData(theEnv)->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(theEnv);
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 != SymbolData(theEnv)->PositiveInfinity)
{
ReturnExpression(theEnv,tempConstraints->maxFields);
tempConstraints->maxFields = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,ValueToLong(theConstraints->maxFields->value) - numberOfSingleFields));
}
if ((numberOfMultifields == 1) && (theConstraints->minFields->value != SymbolData(theEnv)->NegativeInfinity))
{
ReturnExpression(theEnv,tempConstraints->minFields);
tempConstraints->minFields = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,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(theEnv);
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 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 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);
}
}
static struct expr *LoopForCountParse(
void *theEnv,
struct expr *parse,
char *infile)
{
struct token theToken;
SYMBOL_HN *loopVar = NULL;
EXPRESSION *tmpexp;
int read_first_paren;
struct BindInfo *oldBindList,*newBindList,*prev;
/*======================================*/
/* Process the loop counter expression. */
/*======================================*/
SavePPBuffer(theEnv," ");
GetToken(theEnv,infile,&theToken);
/* ==========================================
Simple form: loop-for-count <end> [do] ...
========================================== */
if (theToken.type != LPAREN)
{
parse->argList = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,1L));
parse->argList->nextArg = ParseAtomOrExpression(theEnv,infile,&theToken);
if (parse->argList->nextArg == NULL)
{
ReturnExpression(theEnv,parse);
return(NULL);
}
}
else
{
GetToken(theEnv,infile,&theToken);
if (theToken.type != SF_VARIABLE)
{
if (theToken.type != SYMBOL)
goto LoopForCountParseError;
parse->argList = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,1L));
parse->argList->nextArg = Function2Parse(theEnv,infile,ValueToString(theToken.value));
if (parse->argList->nextArg == NULL)
{
ReturnExpression(theEnv,parse);
return(NULL);
}
}
/* =============================================================
Complex form: loop-for-count (<var> [<start>] <end>) [do] ...
============================================================= */
else
{
loopVar = (SYMBOL_HN *) theToken.value;
SavePPBuffer(theEnv," ");
parse->argList = ParseAtomOrExpression(theEnv,infile,NULL);
if (parse->argList == NULL)
{
ReturnExpression(theEnv,parse);
return(NULL);
}
if (CheckArgumentAgainstRestriction(theEnv,parse->argList,(int) 'i'))
goto LoopForCountParseError;
SavePPBuffer(theEnv," ");
GetToken(theEnv,infile,&theToken);
if (theToken.type == RPAREN)
{
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,theToken.printForm);
tmpexp = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,1L));
tmpexp->nextArg = parse->argList;
parse->argList = tmpexp;
}
else
{
parse->argList->nextArg = ParseAtomOrExpression(theEnv,infile,&theToken);
if (parse->argList->nextArg == NULL)
{
ReturnExpression(theEnv,parse);
return(NULL);
}
GetToken(theEnv,infile,&theToken);
if (theToken.type != RPAREN)
goto LoopForCountParseError;
}
SavePPBuffer(theEnv," ");
}
}
if (CheckArgumentAgainstRestriction(theEnv,parse->argList->nextArg,(int) 'i'))
goto LoopForCountParseError;
/*====================================*/
/* Process the do keyword if present. */
/*====================================*/
GetToken(theEnv,infile,&theToken);
if ((theToken.type == SYMBOL) && (strcmp(ValueToString(theToken.value),"do") == 0))
{
read_first_paren = TRUE;
PPBackup(theEnv);
SavePPBuffer(theEnv," ");
SavePPBuffer(theEnv,theToken.printForm);
IncrementIndentDepth(theEnv,3);
PPCRAndIndent(theEnv);
}
else if (theToken.type == LPAREN)
{
read_first_paren = FALSE;
PPBackup(theEnv);
IncrementIndentDepth(theEnv,3);
PPCRAndIndent(theEnv);
SavePPBuffer(theEnv,theToken.printForm);
}
else
goto LoopForCountParseError;
/*=====================================*/
/* Process the loop-for-count actions. */
/*=====================================*/
if (ExpressionData(theEnv)->svContexts->rtn == TRUE)
ExpressionData(theEnv)->ReturnContext = TRUE;
ExpressionData(theEnv)->BreakContext = TRUE;
oldBindList = GetParsedBindNames(theEnv);
SetParsedBindNames(theEnv,NULL);
parse->argList->nextArg->nextArg =
GroupActions(theEnv,infile,&theToken,read_first_paren,NULL,FALSE);
if (parse->argList->nextArg->nextArg == NULL)
{
SetParsedBindNames(theEnv,oldBindList);
ReturnExpression(theEnv,parse);
return(NULL);
}
newBindList = GetParsedBindNames(theEnv);
prev = NULL;
while (newBindList != NULL)
{
if ((loopVar == NULL) ? FALSE :
(strcmp(ValueToString(newBindList->name),ValueToString(loopVar)) == 0))
{
ClearParsedBindNames(theEnv);
SetParsedBindNames(theEnv,oldBindList);
PrintErrorID(theEnv,"PRCDRPSR",1,TRUE);
EnvPrintRouter(theEnv,WERROR,"Cannot rebind loop variable in function loop-for-count.\n");
ReturnExpression(theEnv,parse);
return(NULL);
}
prev = newBindList;
newBindList = newBindList->next;
}
if (prev == NULL)
SetParsedBindNames(theEnv,oldBindList);
else
prev->next = oldBindList;
if (loopVar != NULL)
ReplaceLoopCountVars(theEnv,loopVar,parse->argList->nextArg->nextArg,0);
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,theToken.printForm);
/*================================================================*/
/* Check for the closing right parenthesis of the loop-for-count. */
/*================================================================*/
if (theToken.type != RPAREN)
{
SyntaxErrorMessage(theEnv,"loop-for-count function");
ReturnExpression(theEnv,parse);
return(NULL);
}
DecrementIndentDepth(theEnv,3);
return(parse);
LoopForCountParseError:
SyntaxErrorMessage(theEnv,"loop-for-count function");
ReturnExpression(theEnv,parse);
return(NULL);
}
/**********************************************************************
NAME : FormMethodsFromRestrictions
DESCRIPTION : Uses restriction string given in DefineFunction2()
for system function to create an equivalent method
INPUTS : 1) The generic function for the new methods
2) System function restriction string
(see DefineFunction2() last argument)
3) The actions to attach to a new method(s)
RETURNS : Nothing useful
SIDE EFFECTS : Implicit method(s) created
NOTES : None
**********************************************************************/
static void FormMethodsFromRestrictions(
void *theEnv,
DEFGENERIC *gfunc,
char *rstring,
EXPRESSION *actions)
{
DEFMETHOD *meth;
EXPRESSION *plist,*tmp,*bot,*svBot;
RESTRICTION *rptr;
char theChar[2],defaultc;
int min,max,mposn,needMinimumMethod;
register int i,j;
/* ===================================
The system function will accept any
number of any type of arguments
=================================== */
if (rstring == NULL)
{
tmp = get_struct(theEnv,expr);
rptr = get_struct(theEnv,restriction);
PackRestrictionTypes(theEnv,rptr,NULL);
rptr->query = NULL;
tmp->argList = (EXPRESSION *) rptr;
tmp->nextArg = NULL;
meth = AddMethod(theEnv,gfunc,NULL,0,0,tmp,1,0,(SYMBOL_HN *) SymbolData(theEnv)->TrueSymbol,
PackExpression(theEnv,actions),NULL,FALSE);
meth->system = 1;
DeleteTempRestricts(theEnv,tmp);
return;
}
/* ==============================
Extract the range of arguments
from the restriction string
============================== */
theChar[1] = '\0';
if (rstring[0] == '*')
min = 0;
else
{
theChar[0] = rstring[0];
min = atoi(theChar);
}
if (rstring[1] == '*')
max = -1;
else
{
theChar[0] = rstring[1];
max = atoi(theChar);
}
if (rstring[2] != '\0')
{
defaultc = rstring[2];
j = 3;
}
else
{
defaultc = 'u';
j= 2;
}
/* ================================================
Form a list of method restrictions corresponding
to the minimum number of arguments
================================================ */
plist = bot = NULL;
for (i = 0 ; i < min ; i++)
{
theChar[0] = (rstring[j] != '\0') ? rstring[j++] : defaultc;
rptr = ParseRestrictionType(theEnv,(int) theChar[0]);
tmp = get_struct(theEnv,expr);
tmp->argList = (EXPRESSION *) rptr;
tmp->nextArg = NULL;
if (plist == NULL)
plist = tmp;
else
bot->nextArg = tmp;
bot = tmp;
}
/* ===============================
Remember where restrictions end
for minimum number of arguments
=============================== */
svBot = bot;
needMinimumMethod = TRUE;
/* =======================================================
Attach one or more new methods to correspond
to the possible variations of the extra arguments
Add a separate method for each specified extra argument
======================================================= */
i = 0;
while (rstring[j] != '\0')
{
if ((rstring[j+1] == '\0') && ((min + i + 1) == max))
{
defaultc = rstring[j];
break;
}
rptr = ParseRestrictionType(theEnv,(int) rstring[j]);
tmp = get_struct(theEnv,expr);
tmp->argList = (EXPRESSION *) rptr;
tmp->nextArg = NULL;
if (plist == NULL)
plist = tmp;
else
bot->nextArg = tmp;
bot = tmp;
i++;
j++;
if ((rstring[j] != '\0') || ((min + i) == max))
{
FindMethodByRestrictions(gfunc,plist,min + i,NULL,&mposn);
meth = AddMethod(theEnv,gfunc,NULL,mposn,0,plist,min + i,0,NULL,
PackExpression(theEnv,actions),NULL,TRUE);
meth->system = 1;
}
}
/* ==============================================
Add a method to account for wildcard arguments
and attach a query in case there is a limit
============================================== */
if ((min + i) != max)
{
/* ================================================
If a wildcard is present immediately after the
minimum number of args - then the minimum case
will already be handled by this method. We don't
need to add an extra method for that case
================================================ */
if (i == 0)
needMinimumMethod = FALSE;
rptr = ParseRestrictionType(theEnv,(int) defaultc);
if (max != -1)
{
rptr->query = GenConstant(theEnv,FCALL,(void *) FindFunction(theEnv,"<="));
rptr->query->argList = GenConstant(theEnv,FCALL,(void *) FindFunction(theEnv,"length$"));
rptr->query->argList->argList = GenProcWildcardReference(theEnv,min + i + 1);
rptr->query->argList->nextArg =
GenConstant(theEnv,INTEGER,(void *) EnvAddLong(theEnv,(long) (max - min - i)));
}
tmp = get_struct(theEnv,expr);
tmp->argList = (EXPRESSION *) rptr;
tmp->nextArg = NULL;
if (plist == NULL)
plist = tmp;
else
bot->nextArg = tmp;
FindMethodByRestrictions(gfunc,plist,min + i + 1,(SYMBOL_HN *) SymbolData(theEnv)->TrueSymbol,&mposn);
meth = AddMethod(theEnv,gfunc,NULL,mposn,0,plist,min + i + 1,0,(SYMBOL_HN *) SymbolData(theEnv)->TrueSymbol,
PackExpression(theEnv,actions),NULL,FALSE);
meth->system = 1;
}
/* ===================================================
When extra methods had to be added because of
different restrictions on the optional arguments OR
the system function accepts a fixed number of args,
we must add a specific method for the minimum case.
Otherwise, the method with the wildcard covers it.
=================================================== */
if (needMinimumMethod)
{
if (svBot != NULL)
{
bot = svBot->nextArg;
svBot->nextArg = NULL;
DeleteTempRestricts(theEnv,bot);
}
FindMethodByRestrictions(gfunc,plist,min,NULL,&mposn);
meth = AddMethod(theEnv,gfunc,NULL,mposn,0,plist,min,0,NULL,
PackExpression(theEnv,actions),NULL,TRUE);
meth->system = 1;
}
DeleteTempRestricts(theEnv,plist);
}
globle BOOLEAN UpdateModifyDuplicate(
void *theEnv,
struct expr *top,
char *name,
void *vTheLHS)
{
struct expr *functionArgs, *tempArg;
SYMBOL_HN *templateName;
struct deftemplate *theDeftemplate;
struct templateSlot *slotPtr;
short position;
/*========================================*/
/* Determine the fact-address or index to */
/* be retracted by the modify command. */
/*========================================*/
functionArgs = top->argList;
if (functionArgs->type == SF_VARIABLE)
{
templateName = FindTemplateForFactAddress((SYMBOL_HN *) functionArgs->value,
(struct lhsParseNode *) vTheLHS);
if (templateName == NULL) return(TRUE);
}
else
{ return(TRUE); }
/*========================================*/
/* Make sure that the fact being modified */
/* has a corresponding deftemplate. */
/*========================================*/
theDeftemplate = (struct deftemplate *)
LookupConstruct(theEnv,DeftemplateData(theEnv)->DeftemplateConstruct,
ValueToString(templateName),
FALSE);
if (theDeftemplate == NULL) return(TRUE);
if (theDeftemplate->implied) return(TRUE);
/*=============================================================*/
/* Make sure all the slot names are valid for the deftemplate. */
/*=============================================================*/
tempArg = functionArgs->nextArg;
while (tempArg != NULL)
{
/*======================*/
/* Does the slot exist? */
/*======================*/
if ((slotPtr = FindSlot(theDeftemplate,(SYMBOL_HN *) tempArg->value,&position)) == NULL)
{
InvalidDeftemplateSlotMessage(theEnv,ValueToString(tempArg->value),
ValueToString(theDeftemplate->header.name));
return(FALSE);
}
/*=========================================================*/
/* Is a multifield value being put in a single field slot? */
/*=========================================================*/
if (slotPtr->multislot == FALSE)
{
if (tempArg->argList == NULL)
{
SingleFieldSlotCardinalityError(theEnv,slotPtr->slotName->contents);
return(FALSE);
}
else if (tempArg->argList->nextArg != NULL)
{
SingleFieldSlotCardinalityError(theEnv,slotPtr->slotName->contents);
return(FALSE);
}
else if ((tempArg->argList->type == MF_VARIABLE) ||
((tempArg->argList->type == FCALL) ?
(((struct FunctionDefinition *) tempArg->argList->value)->returnValueType == 'm') :
FALSE))
{
SingleFieldSlotCardinalityError(theEnv,slotPtr->slotName->contents);
return(FALSE);
}
}
/*======================================*/
/* Are the slot restrictions satisfied? */
/*======================================*/
if (CheckRHSSlotTypes(theEnv,tempArg->argList,slotPtr,name) == 0)
return(FALSE);
/*=============================================*/
/* Replace the slot with the integer position. */
/*=============================================*/
tempArg->type = INTEGER;
tempArg->value = (void *) EnvAddLong(theEnv,(long) (FindSlotPosition(theDeftemplate,(SYMBOL_HN *) tempArg->value) - 1));
tempArg = tempArg->nextArg;
}
return(TRUE);
}
static BOOLEAN MultifieldCardinalityViolation(
void *theEnv,
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 != SymbolData(theEnv)->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 == SymbolData(theEnv)->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(theEnv);
else tempConstraint = CopyConstraintRecord(theEnv,theNode->constraints);
ReturnExpression(theEnv,tempConstraint->minFields);
ReturnExpression(theEnv,tempConstraint->maxFields);
tempConstraint->minFields = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,(long) minFields));
if (posInfinity) tempConstraint->maxFields = GenConstant(theEnv,SYMBOL,SymbolData(theEnv)->PositiveInfinity);
else tempConstraint->maxFields = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,(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(theEnv,theNode->constraints,tempConstraint);
if (theNode->derivedConstraints) RemoveConstraint(theEnv,theNode->constraints);
RemoveConstraint(theEnv,tempConstraint);
theNode->constraints = newConstraint;
theNode->derivedConstraints = TRUE;
/*===================================================================*/
/* Determine if the final cardinality for the slot can be satisfied. */
/*===================================================================*/
if (EnvGetStaticConstraintChecking(theEnv) == FALSE) return(FALSE);
if (UnmatchableConstraint(newConstraint)) return(TRUE);
return(FALSE);
}
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);
}
}
void C_leer_ficha(void *environment, DATA_OBJECT_PTR returnValuePtr)
{
SDL_Event evento;
int x, y, pos, head=1;
void *retorno;
char fin=0, fin2=0;
if (n == 0) {
x=-1;
y=-1;
fin = 1;
}
leyendo=1;
while (!fin) {
while (SDL_PollEvent(&evento)) {
switch (evento.type) {
case SDL_QUIT:
SDL_Quit();
fin = 1;
break;
case SDL_MOUSEBUTTONDOWN:
if (evento.button.button == SDL_BUTTON_RIGHT) {
x=-1; y=-1;
fin = 1;
break;
}
if (evento.button.y >= FICHAS_Y &&
evento.button.y <= FICHAS_Y + fichaH) {
for (pos=0; pos<n; ++pos) {
if (evento.button.y >= FICHAS_Y &&
evento.button.y <= FICHAS_Y + fichaH) {
if (evento.button.x >= (30 + pos*(fichaW + 10)) &&
evento.button.x <= (30 + pos*(fichaW + 10) + fichaW)) {
if (evento.button.y > FICHAS_Y + fichaH/2) {
x = fichas[jugador[pos]].y;
y = fichas[jugador[pos]].x;
}
else {
x = fichas[jugador[pos]].x;
y = fichas[jugador[pos]].y;
}
fin2=0;
while (!fin2) {
SDL_PollEvent(&evento);
switch (evento.type) {
case SDL_MOUSEBUTTONDOWN:
if (evento.button.button == SDL_BUTTON_RIGHT) fin2=1;
else {
if (is_head (evento.button.x, evento.button.y))
fin=1, fin2=1;
else if (is_tail (evento.button.x, evento.button.y)) {
fin = x;
x = y;
y = fin;
fin = 1;
head = 0;
fin2=1;
}
}
break;
}
}
}
}
}
}
break;
}
}
C_flip(environment);
}
retorno = EnvCreateMultifield(environment,3);
SetMFType(retorno, 1, INTEGER);
SetMFValue(retorno, 1, EnvAddLong(environment,x));
SetMFType(retorno, 2, INTEGER);
SetMFValue(retorno, 2, EnvAddLong(environment,y));
SetMFType(retorno, 3, INTEGER);
SetMFValue(retorno, 3, EnvAddLong(environment,head));
SetpType(returnValuePtr, MULTIFIELD);
SetpValue(returnValuePtr, retorno);
SetpDOBegin(returnValuePtr, 1);
SetpDOEnd(returnValuePtr, 3);
n=0;
while (SDL_PollEvent(&evento));
}
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 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 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);
}
