globle DATA_OBJECT_PTR EnvRtnUnknown(
void *theEnv,
int argumentPosition,
DATA_OBJECT_PTR returnValue)
{
int count = 1;
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,"RtnUnknown",
ValueToString(ExpressionFunctionCallName(EvaluationData(theEnv)->CurrentExpression)),
argumentPosition);
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
/*=======================================*/
/* Return the value of the nth argument. */
/*=======================================*/
EvaluateExpression(theEnv,argPtr,returnValue);
return(returnValue);
}
static void OutputUserFunctionsInfo(
void *theEnv)
{
struct FunctionDefinition *theFunction;
int i;
for (theFunction = GetFunctionList(theEnv);
theFunction != NULL;
theFunction = theFunction->next)
{
OutputProfileInfo(theEnv,ValueToString(theFunction->callFunctionName),
(struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,
theFunction->usrData),
NULL,NULL,NULL,NULL);
}
for (i = 0; i < MAXIMUM_PRIMITIVES; i++)
{
if (EvaluationData(theEnv)->PrimitivesArray[i] != NULL)
{
OutputProfileInfo(theEnv,EvaluationData(theEnv)->PrimitivesArray[i]->name,
(struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,
EvaluationData(theEnv)->PrimitivesArray[i]->usrData),
NULL,NULL,NULL,NULL);
}
}
}
static void DeallocateEvaluationData(
void *theEnv)
{
int i;
for (i = 0; i < EvaluationData(theEnv)->numberOfAddressTypes; i++)
{ rtn_struct(theEnv,externalAddressType,EvaluationData(theEnv)->ExternalAddressTypes[i]); }
}
globle void SetEvaluationError(
void *theEnv,
int value)
{
EvaluationData(theEnv)->EvaluationError = value;
if (value == TRUE)
{ EvaluationData(theEnv)->HaltExecution = TRUE; }
}
void ClearBloadedExpressions(
Environment *theEnv)
{
unsigned long i;
size_t space;
/*===============================================*/
/* Update the busy counts of atomic data values. */
/*===============================================*/
for (i = 0; i < ExpressionData(theEnv)->NumberOfExpressions; i++)
{
switch (ExpressionData(theEnv)->ExpressionArray[i].type)
{
case SYMBOL_TYPE :
case STRING_TYPE :
case INSTANCE_NAME_TYPE :
case GBL_VARIABLE :
ReleaseLexeme(theEnv,ExpressionData(theEnv)->ExpressionArray[i].lexemeValue);
break;
case FLOAT_TYPE :
ReleaseFloat(theEnv,ExpressionData(theEnv)->ExpressionArray[i].floatValue);
break;
case INTEGER_TYPE :
ReleaseInteger(theEnv,ExpressionData(theEnv)->ExpressionArray[i].integerValue);
break;
#if DEFTEMPLATE_CONSTRUCT
case FACT_ADDRESS_TYPE :
ReleaseFact((Fact *) ExpressionData(theEnv)->ExpressionArray[i].value);
break;
#endif
#if OBJECT_SYSTEM
case INSTANCE_ADDRESS_TYPE :
ReleaseInstance((Instance *) ExpressionData(theEnv)->ExpressionArray[i].value);
break;
#endif
case VOID_TYPE:
break;
default:
if (EvaluationData(theEnv)->PrimitivesArray[ExpressionData(theEnv)->ExpressionArray[i].type] == NULL) break;
if (EvaluationData(theEnv)->PrimitivesArray[ExpressionData(theEnv)->ExpressionArray[i].type]->bitMap)
{ DecrementBitMapReferenceCount(theEnv,(CLIPSBitMap *) ExpressionData(theEnv)->ExpressionArray[i].value); }
break;
}
}
/*===================================*/
/* Free the binary expression array. */
/*===================================*/
space = ExpressionData(theEnv)->NumberOfExpressions * sizeof(struct expr);
if (space != 0) genfree(theEnv,ExpressionData(theEnv)->ExpressionArray,space);
ExpressionData(theEnv)->ExpressionArray = 0;
}
globle int ParseConstruct(
void *theEnv,
char *name,
char *logicalName)
{
struct construct *currentPtr;
int rv, ov;
/*=================================*/
/* Look for a valid construct name */
/* (e.g. defrule, deffacts). */
/*=================================*/
currentPtr = FindConstruct(theEnv,name);
if (currentPtr == NULL) return(-1);
/*==================================*/
/* Prepare the parsing environment. */
/*==================================*/
ov = GetHaltExecution(theEnv);
SetEvaluationError(theEnv,FALSE);
SetHaltExecution(theEnv,FALSE);
ClearParsedBindNames(theEnv);
PushRtnBrkContexts(theEnv);
ExpressionData(theEnv)->ReturnContext = FALSE;
ExpressionData(theEnv)->BreakContext = FALSE;
EvaluationData(theEnv)->CurrentEvaluationDepth++;
/*=======================================*/
/* Call the construct's parsing routine. */
/*=======================================*/
ConstructData(theEnv)->ParsingConstruct = TRUE;
rv = (*currentPtr->parseFunction)(theEnv,logicalName);
ConstructData(theEnv)->ParsingConstruct = FALSE;
/*===============================*/
/* Restore environment settings. */
/*===============================*/
EvaluationData(theEnv)->CurrentEvaluationDepth--;
PopRtnBrkContexts(theEnv);
ClearParsedBindNames(theEnv);
SetPPBufferStatus(theEnv,OFF);
SetHaltExecution(theEnv,ov);
/*==============================*/
/* Return the status of parsing */
/* the construct. */
/*==============================*/
return(rv);
}
globle char *EnvRtnLexeme(
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,"RtnLexeme",
ValueToString(ExpressionFunctionCallName(EvaluationData(theEnv)->CurrentExpression)),
argumentPosition);
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
/*============================================*/
/* Return the value of the nth argument if it */
/* is a symbol, string, or instance name. */
/*============================================*/
EvaluateExpression(theEnv,argPtr,&result);
if ((result.type == SYMBOL) ||
#if OBJECT_SYSTEM
(result.type == INSTANCE_NAME) ||
#endif
(result.type == STRING))
{ return(ValueToString(result.value));}
/*======================================================*/
/* Generate an error if the argument is the wrong type. */
/*======================================================*/
ExpectedTypeError3(theEnv,"RtnLexeme",
ValueToString(ExpressionFunctionCallName(EvaluationData(theEnv)->CurrentExpression)),
argumentPosition,"symbol, string, or instance name");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
globle void InstallPrimitive(
void *theEnv,
struct entityRecord *thePrimitive,
int whichPosition)
{
if (EvaluationData(theEnv)->PrimitivesArray[whichPosition] != NULL)
{
SystemError(theEnv,"EVALUATN",5);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
EvaluationData(theEnv)->PrimitivesArray[whichPosition] = thePrimitive;
}
/****************************************************
NAME : InstancesPurge
DESCRIPTION : Removes all instances
INPUTS : None
RETURNS : TRUE if all instances deleted,
FALSE otherwise
SIDE EFFECTS : The instance hash table is cleared
NOTES : None
****************************************************/
globle intBool InstancesPurge(
void *theEnv)
{
int svdepth;
DestroyAllInstances(theEnv);
svdepth = EvaluationData(theEnv)->CurrentEvaluationDepth;
if (EvaluationData(theEnv)->CurrentEvaluationDepth == 0)
EvaluationData(theEnv)->CurrentEvaluationDepth = -1;
CleanupInstances(theEnv);
EvaluationData(theEnv)->CurrentEvaluationDepth = svdepth;
return((InstanceData(theEnv)->InstanceList != NULL) ? FALSE : TRUE);
}
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);
}
/*****************************************************************
NAME : TestForFirstFactInTemplate
DESCRIPTION : Processes all facts in a template
INPUTS : 1) Visitation traversal id
2) The template
3) The current template restriction chain
4) The index of the current restriction
RETURNS : TRUE if query succeeds, FALSE otherwise
SIDE EFFECTS : Fact variable values set
NOTES : None
*****************************************************************/
static int TestForFirstFactInTemplate(
void *theEnv,
struct deftemplate *templatePtr,
QUERY_TEMPLATE *qchain,
int indx)
{
struct fact *theFact;
DATA_OBJECT temp;
theFact = templatePtr->factList;
while (theFact != NULL)
{
FactQueryData(theEnv)->QueryCore->solns[indx] = theFact;
if (qchain->nxt != NULL)
{
theFact->factHeader.busyCount++;
if (TestForFirstInChain(theEnv,qchain->nxt,indx+1) == TRUE)
{
theFact->factHeader.busyCount--;
break;
}
theFact->factHeader.busyCount--;
if ((EvaluationData(theEnv)->HaltExecution == TRUE) || (FactQueryData(theEnv)->AbortQuery == TRUE))
break;
}
else
{
theFact->factHeader.busyCount++;
EvaluationData(theEnv)->CurrentEvaluationDepth++;
EvaluateExpression(theEnv,FactQueryData(theEnv)->QueryCore->query,&temp);
EvaluationData(theEnv)->CurrentEvaluationDepth--;
PeriodicCleanup(theEnv,FALSE,TRUE);
theFact->factHeader.busyCount--;
if (EvaluationData(theEnv)->HaltExecution == TRUE)
break;
if ((temp.type != SYMBOL) ? TRUE :
(temp.value != EnvFalseSymbol(theEnv)))
break;
}
theFact = theFact->nextTemplateFact;
while ((theFact != NULL) ? (theFact->garbage == 1) : FALSE)
theFact = theFact->nextTemplateFact;
}
if (theFact != NULL)
return(((EvaluationData(theEnv)->HaltExecution == TRUE) || (FactQueryData(theEnv)->AbortQuery == TRUE))
? FALSE : TRUE);
return(FALSE);
}
globle void PrintDataObject(
void *theEnv,
const char *fileid,
DATA_OBJECT_PTR argPtr)
{
switch(argPtr->type)
{
case RVOID:
case SYMBOL:
case STRING:
case INTEGER:
case FLOAT:
case EXTERNAL_ADDRESS:
case DATA_OBJECT_ARRAY: // TBD Remove with AddPrimitive
case FACT_ADDRESS:
#if OBJECT_SYSTEM
case INSTANCE_NAME:
case INSTANCE_ADDRESS:
#endif
PrintAtom(theEnv,fileid,argPtr->type,argPtr->value);
break;
case MULTIFIELD:
PrintMultifield(theEnv,fileid,(struct multifield *) argPtr->value,
argPtr->begin,argPtr->end,TRUE);
break;
default:
if (EvaluationData(theEnv)->PrimitivesArray[argPtr->type] != NULL)
{
if (EvaluationData(theEnv)->PrimitivesArray[argPtr->type]->longPrintFunction)
{
(*EvaluationData(theEnv)->PrimitivesArray[argPtr->type]->longPrintFunction)(theEnv,fileid,argPtr->value);
break;
}
else if (EvaluationData(theEnv)->PrimitivesArray[argPtr->type]->shortPrintFunction)
{
(*EvaluationData(theEnv)->PrimitivesArray[argPtr->type]->shortPrintFunction)(theEnv,fileid,argPtr->value);
break;
}
}
EnvPrintRouter(theEnv,fileid,"<UnknownPrintType");
PrintLongInteger(theEnv,fileid,(long int) argPtr->type);
EnvPrintRouter(theEnv,fileid,">");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
break;
}
}
/******************************************************************************
NAME : DelayedQueryDoForAllFacts
DESCRIPTION : Finds all sets of facts which satisfy the query and
and exceutes a user-action for each set
This function differs from QueryDoForAllFacts() in
that it forms the complete list of query satisfactions
BEFORE executing any actions.
INPUTS : Caller's result buffer
RETURNS : Nothing useful
SIDE EFFECTS : The query template-expressions are evaluated once,
and the query boolean-expression is evaluated
once for every fact set. The action is executed
for evry query satisfaction.
Caller's result buffer holds result of last action executed.
NOTES : H/L Syntax : See FactParseQueryNoAction()
******************************************************************************/
globle void DelayedQueryDoForAllFacts(
void *theEnv,
DATA_OBJECT *result)
{
QUERY_TEMPLATE *qtemplates;
unsigned rcnt;
register unsigned i;
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
qtemplates = DetermineQueryTemplates(theEnv,GetFirstArgument()->nextArg->nextArg,
"delayed-do-for-all-facts",&rcnt);
if (qtemplates == NULL)
return;
PushQueryCore(theEnv);
FactQueryData(theEnv)->QueryCore = get_struct(theEnv,query_core);
FactQueryData(theEnv)->QueryCore->solns = (struct fact **) gm2(theEnv,(sizeof(struct fact *) * rcnt));
FactQueryData(theEnv)->QueryCore->query = GetFirstArgument();
FactQueryData(theEnv)->QueryCore->action = NULL;
FactQueryData(theEnv)->QueryCore->soln_set = NULL;
FactQueryData(theEnv)->QueryCore->soln_size = rcnt;
FactQueryData(theEnv)->QueryCore->soln_cnt = 0;
TestEntireChain(theEnv,qtemplates,0);
FactQueryData(theEnv)->AbortQuery = FALSE;
FactQueryData(theEnv)->QueryCore->action = GetFirstArgument()->nextArg;
while (FactQueryData(theEnv)->QueryCore->soln_set != NULL)
{
for (i = 0 ; i < rcnt ; i++)
FactQueryData(theEnv)->QueryCore->solns[i] = FactQueryData(theEnv)->QueryCore->soln_set->soln[i];
PopQuerySoln(theEnv);
EvaluationData(theEnv)->CurrentEvaluationDepth++;
EvaluateExpression(theEnv,FactQueryData(theEnv)->QueryCore->action,result);
EvaluationData(theEnv)->CurrentEvaluationDepth--;
if (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE)
{ PropagateReturnValue(theEnv,result); }
PeriodicCleanup(theEnv,FALSE,TRUE);
if (EvaluationData(theEnv)->HaltExecution || ProcedureFunctionData(theEnv)->BreakFlag || ProcedureFunctionData(theEnv)->ReturnFlag)
{
while (FactQueryData(theEnv)->QueryCore->soln_set != NULL)
PopQuerySoln(theEnv);
break;
}
}
ProcedureFunctionData(theEnv)->BreakFlag = FALSE;
rm(theEnv,(void *) FactQueryData(theEnv)->QueryCore->solns,(sizeof(struct fact *) * rcnt));
rtn_struct(theEnv,query_core,FactQueryData(theEnv)->QueryCore);
PopQueryCore(theEnv);
DeleteQueryTemplates(theEnv,qtemplates);
}
globle void MarkNeededItems(
void *theEnv,
EXEC_STATUS,
struct expr *testPtr)
{
while (testPtr != NULL)
{
switch (testPtr->type)
{
case SYMBOL:
case STRING:
case GBL_VARIABLE:
case INSTANCE_NAME:
((SYMBOL_HN *) testPtr->value)->neededSymbol = TRUE;
break;
case FLOAT:
((FLOAT_HN *) testPtr->value)->neededFloat = TRUE;
break;
case INTEGER:
((INTEGER_HN *) testPtr->value)->neededInteger = TRUE;
break;
case FCALL:
((struct FunctionDefinition *) testPtr->value)->bsaveIndex = TRUE;
break;
case RVOID:
break;
default:
if (EvaluationData(theEnv,execStatus)->PrimitivesArray[testPtr->type] == NULL) break;
if (EvaluationData(theEnv,execStatus)->PrimitivesArray[testPtr->type]->bitMap)
{
((BITMAP_HN *) testPtr->value)->neededBitMap = TRUE;
}
break;
}
if (testPtr->argList != NULL)
{
MarkNeededItems(theEnv,execStatus,testPtr->argList);
}
testPtr = testPtr->nextArg;
}
}
/**********************************************************************
NAME : WatchMethod
DESCRIPTION : Prints out a trace of the beginning or end
of the execution of a generic function
method
INPUTS : A string to indicate beginning or end of execution
RETURNS : Nothing useful
SIDE EFFECTS : None
NOTES : Uses the globals CurrentGeneric, CurrentMethod,
ProcParamArraySize and ProcParamArray for
other trace info
**********************************************************************/
static void WatchMethod(
Environment *theEnv,
const char *tstring)
{
if (ConstructData(theEnv)->ClearReadyInProgress ||
ConstructData(theEnv)->ClearInProgress)
{ return; }
WriteString(theEnv,STDOUT,"MTH ");
WriteString(theEnv,STDOUT,tstring);
WriteString(theEnv,STDOUT," ");
if (DefgenericData(theEnv)->CurrentGeneric->header.whichModule->theModule != GetCurrentModule(theEnv))
{
WriteString(theEnv,STDOUT,DefgenericModule(DefgenericData(theEnv)->CurrentGeneric));
WriteString(theEnv,STDOUT,"::");
}
WriteString(theEnv,STDOUT,DefgenericData(theEnv)->CurrentGeneric->header.name->contents);
WriteString(theEnv,STDOUT,":#");
if (DefgenericData(theEnv)->CurrentMethod->system)
WriteString(theEnv,STDOUT,"SYS");
PrintUnsignedInteger(theEnv,STDOUT,DefgenericData(theEnv)->CurrentMethod->index);
WriteString(theEnv,STDOUT," ");
WriteString(theEnv,STDOUT," ED:");
WriteInteger(theEnv,STDOUT,EvaluationData(theEnv)->CurrentEvaluationDepth);
PrintProcParamArray(theEnv,STDOUT);
}
globle intBool EvaluateSecondaryNetworkTest(
void *theEnv,
struct partialMatch *leftMatch,
struct joinNode *joinPtr)
{
int joinExpr;
struct partialMatch *oldLHSBinds;
struct partialMatch *oldRHSBinds;
struct joinNode *oldJoin;
if (joinPtr->secondaryNetworkTest == NULL)
{ return(TRUE); }
#if DEVELOPER
EngineData(theEnv)->rightToLeftComparisons++;
#endif
oldLHSBinds = EngineData(theEnv)->GlobalLHSBinds;
oldRHSBinds = EngineData(theEnv)->GlobalRHSBinds;
oldJoin = EngineData(theEnv)->GlobalJoin;
EngineData(theEnv)->GlobalLHSBinds = leftMatch;
EngineData(theEnv)->GlobalRHSBinds = NULL;
EngineData(theEnv)->GlobalJoin = joinPtr;
joinExpr = EvaluateJoinExpression(theEnv,joinPtr->secondaryNetworkTest,joinPtr);
EvaluationData(theEnv)->EvaluationError = FALSE;
EngineData(theEnv)->GlobalLHSBinds = oldLHSBinds;
EngineData(theEnv)->GlobalRHSBinds = oldRHSBinds;
EngineData(theEnv)->GlobalJoin = oldJoin;
return(joinExpr);
}
static void ResetDefinstancesAction(
void *theEnv,
struct constructHeader *vDefinstances,
void *userBuffer)
{
#if MAC_MCW || WIN_MCW || MAC_XCD
#pragma unused(userBuffer)
#endif
DEFINSTANCES *theDefinstances = (DEFINSTANCES *) vDefinstances;
EXPRESSION *theExp;
DATA_OBJECT temp;
SaveCurrentModule(theEnv);
EnvSetCurrentModule(theEnv,(void *) vDefinstances->whichModule->theModule);
theDefinstances->busy++;
for (theExp = theDefinstances->mkinstance ;
theExp != NULL ;
theExp = GetNextArgument(theExp))
{
EvaluateExpression(theEnv,theExp,&temp);
if (EvaluationData(theEnv)->HaltExecution ||
((GetType(temp) == SYMBOL) &&
(GetValue(temp) == EnvFalseSymbol(theEnv))))
{
RestoreCurrentModule(theEnv);
theDefinstances->busy--;
return;
}
}
theDefinstances->busy--;
RestoreCurrentModule(theEnv);
}
/************************************************************
NAME : TestForFirstInChain
DESCRIPTION : Processes all classes in a restriction chain
until success or done
INPUTS : 1) The current chain
2) The index of the chain restriction
(e.g. the 4th query-variable)
RETURNS : TRUE if query succeeds, FALSE otherwise
SIDE EFFECTS : Sets current restriction class
Instance variable values set
NOTES : None
************************************************************/
static int TestForFirstInChain(
void *theEnv,
QUERY_CLASS *qchain,
int indx)
{
QUERY_CLASS *qptr;
int id;
InstanceQueryData(theEnv)->AbortQuery = TRUE;
for (qptr = qchain ; qptr != NULL ; qptr = qptr->chain)
{
InstanceQueryData(theEnv)->AbortQuery = FALSE;
if ((id = GetTraversalID(theEnv)) == -1)
return(FALSE);
if (TestForFirstInstanceInClass(theEnv,qptr->theModule,id,qptr->cls,qchain,indx))
{
ReleaseTraversalID(theEnv);
return(TRUE);
}
ReleaseTraversalID(theEnv);
if ((EvaluationData(theEnv)->HaltExecution == TRUE) || (InstanceQueryData(theEnv)->AbortQuery == TRUE))
return(FALSE);
}
return(FALSE);
}
/***********************************************************
NAME : EvaluateAndStoreInDataObject
DESCRIPTION : Evaluates slot-value expressions
and stores the result in a
Kernel data object
INPUTS : 1) Flag indicating if multifields are OK
2) The value-expression
3) The data object structure
4) Flag indicating if a multifield value
should be placed on the garbage list.
RETURNS : FALSE on errors, TRUE otherwise
SIDE EFFECTS : Segment allocated for storing
multifield values
NOTES : None
***********************************************************/
globle int EvaluateAndStoreInDataObject(
void *theEnv,
int mfp,
EXPRESSION *theExp,
DATA_OBJECT *val,
int garbageSegment)
{
val->type = MULTIFIELD;
val->begin = 0;
val->end = -1;
if (theExp == NULL)
{
if (garbageSegment) val->value = EnvCreateMultifield(theEnv,0L);
else val->value = CreateMultifield2(theEnv,0L);
return(TRUE);
}
if ((mfp == 0) && (theExp->nextArg == NULL))
EvaluateExpression(theEnv,theExp,val);
else
StoreInMultifield(theEnv,val,theExp,garbageSegment);
return(EvaluationData(theEnv)->EvaluationError ? FALSE : TRUE);
}
globle void *EnvCreateMultifield(
void *theEnv,
unsigned long size)
{
struct multifield *theSegment;
unsigned long newSize;
if (size <= 0) newSize = 1;
else newSize = size;
theSegment = get_var_struct2(theEnv,multifield,(long) sizeof(struct field) * (newSize - 1L));
theSegment->multifieldLength = size;
theSegment->depth = (short) EvaluationData(theEnv)->CurrentEvaluationDepth;
theSegment->busyCount = 0;
theSegment->next = NULL;
theSegment->next = MultifieldData(theEnv)->ListOfMultifields;
MultifieldData(theEnv)->ListOfMultifields = theSegment;
UtilityData(theEnv)->EphemeralItemCount++;
UtilityData(theEnv)->EphemeralItemSize += sizeof(struct multifield) + (sizeof(struct field) * newSize);
return((void *) theSegment);
}
globle void FlushMultifields(
void *theEnv)
{
struct multifield *theSegment, *nextPtr, *lastPtr = NULL;
unsigned long newSize;
theSegment = MultifieldData(theEnv)->ListOfMultifields;
while (theSegment != NULL)
{
nextPtr = theSegment->next;
if ((theSegment->depth > EvaluationData(theEnv)->CurrentEvaluationDepth) && (theSegment->busyCount == 0))
{
UtilityData(theEnv)->EphemeralItemCount--;
UtilityData(theEnv)->EphemeralItemSize -= sizeof(struct multifield) +
(sizeof(struct field) * theSegment->multifieldLength);
if (theSegment->multifieldLength == 0) newSize = 1;
else newSize = theSegment->multifieldLength;
rtn_var_struct2(theEnv,multifield,sizeof(struct field) * (newSize - 1),theSegment);
if (lastPtr == NULL) MultifieldData(theEnv)->ListOfMultifields = nextPtr;
else lastPtr->next = nextPtr;
}
else
{ lastPtr = theSegment; }
theSegment = nextPtr;
}
}
globle void PrognFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
struct expr *argPtr;
argPtr = EvaluationData(theEnv)->CurrentExpression->argList;
if (argPtr == NULL)
{
returnValue->type = SYMBOL;
returnValue->value = EnvFalseSymbol(theEnv);
return;
}
while ((argPtr != NULL) && (GetHaltExecution(theEnv) != TRUE))
{
EvaluateExpression(theEnv,argPtr,returnValue);
if ((ProcedureFunctionData(theEnv)->BreakFlag == TRUE) || (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE))
break;
argPtr = argPtr->nextArg;
}
if (GetHaltExecution(theEnv) == TRUE)
{
returnValue->type = SYMBOL;
returnValue->value = EnvFalseSymbol(theEnv);
return;
}
return;
}
/*************************************************************
NAME : PreviewGeneric
DESCRIPTION : Allows the user to see a printout of all the
applicable methods for a particular generic
function call
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : Any side-effects of evaluating the generic
function arguments
and evaluating query-functions to determine
the set of applicable methods
NOTES : H/L Syntax: (preview-generic <func> <args>)
*************************************************************/
globle void PreviewGeneric(
void *theEnv)
{
DEFGENERIC *gfunc;
DEFGENERIC *previousGeneric;
int oldce;
DATA_OBJECT temp;
EvaluationData(theEnv)->EvaluationError = FALSE;
if (EnvArgTypeCheck(theEnv,(char*)"preview-generic",1,SYMBOL,&temp) == FALSE)
return;
gfunc = LookupDefgenericByMdlOrScope(theEnv,DOToString(temp));
if (gfunc == NULL)
{
PrintErrorID(theEnv,(char*)"GENRCFUN",3,FALSE);
EnvPrintRouter(theEnv,WERROR,(char*)"Unable to find generic function ");
EnvPrintRouter(theEnv,WERROR,DOToString(temp));
EnvPrintRouter(theEnv,WERROR,(char*)" in function preview-generic.\n");
return;
}
oldce = ExecutingConstruct(theEnv);
SetExecutingConstruct(theEnv,TRUE);
previousGeneric = DefgenericData(theEnv)->CurrentGeneric;
DefgenericData(theEnv)->CurrentGeneric = gfunc;
EvaluationData(theEnv)->CurrentEvaluationDepth++;
PushProcParameters(theEnv,GetFirstArgument()->nextArg,
CountArguments(GetFirstArgument()->nextArg),
EnvGetDefgenericName(theEnv,(void *) gfunc),(char*)"generic function",
UnboundMethodErr);
if (EvaluationData(theEnv)->EvaluationError)
{
PopProcParameters(theEnv);
DefgenericData(theEnv)->CurrentGeneric = previousGeneric;
EvaluationData(theEnv)->CurrentEvaluationDepth--;
SetExecutingConstruct(theEnv,oldce);
return;
}
gfunc->busy++;
DisplayGenericCore(theEnv,gfunc);
gfunc->busy--;
PopProcParameters(theEnv);
DefgenericData(theEnv)->CurrentGeneric = previousGeneric;
EvaluationData(theEnv)->CurrentEvaluationDepth--;
SetExecutingConstruct(theEnv,oldce);
}
globle void AtomInstall(
void *theEnv,
int type,
void *vPtr)
{
switch (type)
{
case SYMBOL:
case STRING:
#if DEFGLOBAL_CONSTRUCT
case GBL_VARIABLE:
#endif
#if OBJECT_SYSTEM
case INSTANCE_NAME:
#endif
IncrementSymbolCount(vPtr);
break;
case FLOAT:
IncrementFloatCount(vPtr);
break;
case INTEGER:
IncrementIntegerCount(vPtr);
break;
case EXTERNAL_ADDRESS:
IncrementExternalAddressCount(vPtr);
break;
case MULTIFIELD:
MultifieldInstall(theEnv,(struct multifield *) vPtr);
break;
case RVOID:
break;
default:
if (EvaluationData(theEnv)->PrimitivesArray[type] == NULL) break;
if (EvaluationData(theEnv)->PrimitivesArray[type]->bitMap) IncrementBitMapCount(vPtr);
else if (EvaluationData(theEnv)->PrimitivesArray[type]->incrementBusyCount)
{ (*EvaluationData(theEnv)->PrimitivesArray[type]->incrementBusyCount)(theEnv,vPtr); }
break;
}
}
bool UDFFirstArgument(
UDFContext *context,
unsigned expectedType,
CLIPSValue *returnValue)
{
context->lastArg = EvaluationData(context->environment)->CurrentExpression->argList;
context->lastPosition = 1;
return UDFNextArgument(context,expectedType,returnValue);
}
globle void SwitchFunction(
void *theEnv,
DATA_OBJECT_PTR result)
{
DATA_OBJECT switch_val,case_val;
EXPRESSION *theExp;
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
/* ==========================
Get the value to switch on
========================== */
EvaluateExpression(theEnv,GetFirstArgument(),&switch_val);
if (EvaluationData(theEnv)->EvaluationError)
return;
for (theExp = GetFirstArgument()->nextArg ; theExp != NULL ; theExp = theExp->nextArg->nextArg)
{
/* =================================================
RVOID is the default case (if any) for the switch
================================================= */
if (theExp->type == RVOID)
{
EvaluateExpression(theEnv,theExp->nextArg,result);
return;
}
/* ====================================================
If the case matches, evaluate the actions and return
==================================================== */
EvaluateExpression(theEnv,theExp,&case_val);
if (EvaluationData(theEnv)->EvaluationError)
return;
if (switch_val.type == case_val.type)
{
if ((case_val.type == MULTIFIELD) ? MultifieldDOsEqual(&switch_val,&case_val) :
(switch_val.value == case_val.value))
{
EvaluateExpression(theEnv,theExp->nextArg,result);
return;
}
}
}
}
static struct factPatternNode *GetNextFactPatternNode(
void *theEnv,
int finishedMatching,
struct factPatternNode *thePattern)
{
EvaluationData(theEnv)->EvaluationError = FALSE;
/*===================================================*/
/* If pattern matching was successful at the current */
/* node in the tree and it's possible to go deeper */
/* into the tree, then move down to the next level. */
/*===================================================*/
if (finishedMatching == FALSE)
{
if (thePattern->nextLevel != NULL) return(thePattern->nextLevel);
}
/*================================================*/
/* Keep backing up toward the root of the pattern */
/* network until a side branch can be taken. */
/*================================================*/
while (thePattern->rightNode == NULL)
{
/*========================================*/
/* Back up to check the next side branch. */
/*========================================*/
thePattern = thePattern->lastLevel;
/*======================================*/
/* If we branched up from the root, the */
/* entire tree has been traversed. */
/*======================================*/
if (thePattern == NULL) return(NULL);
/*===================================================*/
/* If we branched up to a multifield node, then stop */
/* since these nodes are handled recursively. The */
/* previous call to the pattern matching algorithm */
/* on the stack will handle backing up to the nodes */
/* above the multifield node in the pattern network. */
/*===================================================*/
if (thePattern->header.multifieldNode) return(NULL);
}
/*==================================*/
/* Move on to the next side branch. */
/*==================================*/
return(thePattern->rightNode);
}
globle int InstallExternalAddressType(
void *theEnv,
struct externalAddressType *theAddressType)
{
struct externalAddressType *copyEAT;
int rv = EvaluationData(theEnv)->numberOfAddressTypes;
if (EvaluationData(theEnv)->numberOfAddressTypes == MAXIMUM_EXTERNAL_ADDRESS_TYPES)
{
SystemError(theEnv,"EVALUATN",6);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
copyEAT = (struct externalAddressType *) genalloc(theEnv,sizeof(struct externalAddressType));
memcpy(copyEAT,theAddressType,sizeof(struct externalAddressType));
EvaluationData(theEnv)->ExternalAddressTypes[EvaluationData(theEnv)->numberOfAddressTypes++] = copyEAT;
return rv;
}
globle void AddToMultifieldList(
void *theEnv,
struct multifield *theSegment)
{
theSegment->depth = (short) EvaluationData(theEnv)->CurrentEvaluationDepth;
theSegment->next = MultifieldData(theEnv)->ListOfMultifields;
MultifieldData(theEnv)->ListOfMultifields = theSegment;
UtilityData(theEnv)->EphemeralItemCount++;
UtilityData(theEnv)->EphemeralItemSize += sizeof(struct multifield) + (sizeof(struct field) * theSegment->multifieldLength);
}
globle int EnvRtnArgCount(
void *theEnv)
{
int count = 0;
struct expr *argPtr;
for (argPtr = EvaluationData(theEnv)->CurrentExpression->argList;
argPtr != NULL;
argPtr = argPtr->nextArg)
{ count++; }
return(count);
}
