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);
}
}
}
globle double SetProfilePercentThresholdCommand(
void *theEnv)
{
DATA_OBJECT theValue;
double newThreshold;
if (EnvArgCountCheck(theEnv,"set-profile-percent-threshold",EXACTLY,1) == -1)
{ return(ProfileFunctionData(theEnv)->PercentThreshold); }
if (EnvArgTypeCheck(theEnv,"set-profile-percent-threshold",1,INTEGER_OR_FLOAT,&theValue) == FALSE)
{ return(ProfileFunctionData(theEnv)->PercentThreshold); }
if (GetType(theValue) == INTEGER)
{ newThreshold = (double) DOToLong(theValue); }
else
{ newThreshold = (double) DOToDouble(theValue); }
if ((newThreshold < 0.0) || (newThreshold > 100.0))
{
ExpectedTypeError1(theEnv,"set-profile-percent-threshold",1,
"number in the range 0 to 100");
return(-1.0);
}
return(SetProfilePercentThreshold(theEnv,newThreshold));
}
const char *SetProfileOutputString(
Environment *theEnv,
const char *value)
{
const char *oldOutputString;
if (value == NULL)
{ return(ProfileFunctionData(theEnv)->OutputString); }
oldOutputString = ProfileFunctionData(theEnv)->OutputString;
ProfileFunctionData(theEnv)->OutputString = value;
return(oldOutputString);
}
globle char *SetProfileOutputString(
void *theEnv,
char *value)
{
char *oldOutputString;
if (value == NULL)
{ return(ProfileFunctionData(theEnv)->OutputString); }
oldOutputString = ProfileFunctionData(theEnv)->OutputString;
ProfileFunctionData(theEnv)->OutputString = value;
return(oldOutputString);
}
globle double SetProfilePercentThreshold(
void *theEnv,
double value)
{
double oldPercentThreshhold;
if ((value < 0.0) || (value > 100.0))
{ return(-1.0); }
oldPercentThreshhold = ProfileFunctionData(theEnv)->PercentThreshold;
ProfileFunctionData(theEnv)->PercentThreshold = value;
return(oldPercentThreshhold);
}
void GetProfilePercentThresholdCommand(
Environment *theEnv,
UDFContext *context,
UDFValue *returnValue)
{
returnValue->floatValue = CreateFloat(theEnv,ProfileFunctionData(theEnv)->PercentThreshold);
}
globle double GetProfilePercentThresholdCommand(
void *theEnv)
{
EnvArgCountCheck(theEnv,"get-profile-percent-threshold",EXACTLY,0);
return(ProfileFunctionData(theEnv)->PercentThreshold);
}
globle void StartProfile(
void *theEnv,
struct profileFrameInfo *theFrame,
struct userData **theList,
intBool checkFlag)
{
double startTime, addTime;
struct constructProfileInfo *profileInfo;
if (! checkFlag)
{
theFrame->profileOnExit = FALSE;
return;
}
profileInfo = (struct constructProfileInfo *) FetchUserData(theEnv,ProfileFunctionData(theEnv)->ProfileDataID,theList);
theFrame->profileOnExit = TRUE;
theFrame->parentCall = FALSE;
startTime = gentime();
theFrame->oldProfileFrame = ProfileFunctionData(theEnv)->ActiveProfileFrame;
if (ProfileFunctionData(theEnv)->ActiveProfileFrame != NULL)
{
addTime = startTime - ProfileFunctionData(theEnv)->ActiveProfileFrame->startTime;
ProfileFunctionData(theEnv)->ActiveProfileFrame->totalSelfTime += addTime;
}
ProfileFunctionData(theEnv)->ActiveProfileFrame = profileInfo;
ProfileFunctionData(theEnv)->ActiveProfileFrame->numberOfEntries++;
ProfileFunctionData(theEnv)->ActiveProfileFrame->startTime = startTime;
if (! ProfileFunctionData(theEnv)->ActiveProfileFrame->childCall)
{
theFrame->parentCall = TRUE;
theFrame->parentStartTime = startTime;
ProfileFunctionData(theEnv)->ActiveProfileFrame->childCall = TRUE;
}
}
void ConstructProfilingFunctionDefinitions(
Environment *theEnv)
{
struct userDataRecord profileDataInfo = { 0, CreateProfileData, DeleteProfileData };
AllocateEnvironmentData(theEnv,PROFLFUN_DATA,sizeof(struct profileFunctionData),NULL);
memcpy(&ProfileFunctionData(theEnv)->ProfileDataInfo,&profileDataInfo,sizeof(struct userDataRecord));
ProfileFunctionData(theEnv)->LastProfileInfo = NO_PROFILE;
ProfileFunctionData(theEnv)->PercentThreshold = 0.0;
ProfileFunctionData(theEnv)->OutputString = OUTPUT_STRING;
#if ! RUN_TIME
AddUDF(theEnv,"profile","v",1,1,"y",ProfileCommand,"ProfileCommand",NULL);
AddUDF(theEnv,"profile-info","v",0,0,NULL, ProfileInfoCommand,"ProfileInfoCommand",NULL);
AddUDF(theEnv,"profile-reset","v",0,0,NULL,ProfileResetCommand,"ProfileResetCommand",NULL);
AddUDF(theEnv,"set-profile-percent-threshold","d",1,1,"ld",SetProfilePercentThresholdCommand,"SetProfilePercentThresholdCommand",NULL);
AddUDF(theEnv,"get-profile-percent-threshold","d",0,0,NULL,GetProfilePercentThresholdCommand,"GetProfilePercentThresholdCommand",NULL);
ProfileFunctionData(theEnv)->ProfileDataID = InstallUserDataRecord(theEnv,&ProfileFunctionData(theEnv)->ProfileDataInfo);
AddClearFunction(theEnv,"profile",ProfileClearFunction,0,NULL);
#endif
}
globle void ConstructProfilingFunctionDefinitions(
void *theEnv)
{
struct userDataRecord profileDataInfo = { 0, CreateProfileData, DeleteProfileData };
AllocateEnvironmentData(theEnv,PROFLFUN_DATA,sizeof(struct profileFunctionData),NULL);
memcpy(&ProfileFunctionData(theEnv)->ProfileDataInfo,&profileDataInfo,sizeof(struct userDataRecord));
ProfileFunctionData(theEnv)->LastProfileInfo = NO_PROFILE;
ProfileFunctionData(theEnv)->PercentThreshold = 0.0;
ProfileFunctionData(theEnv)->OutputString = OUTPUT_STRING;
#if ! RUN_TIME
EnvDefineFunction2(theEnv,"profile",'v', PTIEF ProfileCommand,"ProfileCommand","11w");
EnvDefineFunction2(theEnv,"profile-info",'v', PTIEF ProfileInfoCommand,"ProfileInfoCommand","01w");
EnvDefineFunction2(theEnv,"profile-reset",'v', PTIEF ProfileResetCommand,"ProfileResetCommand","00");
EnvDefineFunction2(theEnv,"set-profile-percent-threshold",'d',
PTIEF SetProfilePercentThresholdCommand,
"SetProfilePercentThresholdCommand","11n");
EnvDefineFunction2(theEnv,"get-profile-percent-threshold",'d',
PTIEF GetProfilePercentThresholdCommand,
"GetProfilePercentThresholdCommand","00");
ProfileFunctionData(theEnv)->ProfileDataID = InstallUserDataRecord(theEnv,&ProfileFunctionData(theEnv)->ProfileDataInfo);
EnvAddClearFunction(theEnv,"profile",ProfileClearFunction,0);
#endif
}
static void ProfileClearFunction(
void *theEnv)
{
struct FunctionDefinition *theFunction;
int i;
for (theFunction = GetFunctionList(theEnv);
theFunction != NULL;
theFunction = theFunction->next)
{
theFunction->usrData =
DeleteUserData(theEnv,ProfileFunctionData(theEnv)->ProfileDataID,theFunction->usrData);
}
for (i = 0; i < MAXIMUM_PRIMITIVES; i++)
{
if (EvaluationData(theEnv)->PrimitivesArray[i] != NULL)
{
EvaluationData(theEnv)->PrimitivesArray[i]->usrData =
DeleteUserData(theEnv,ProfileFunctionData(theEnv)->ProfileDataID,EvaluationData(theEnv)->PrimitivesArray[i]->usrData);
}
}
}
globle void EndProfile(
void *theEnv,
struct profileFrameInfo *theFrame)
{
double endTime, addTime;
if (! theFrame->profileOnExit) return;
endTime = gentime();
if (theFrame->parentCall)
{
addTime = endTime - theFrame->parentStartTime;
ProfileFunctionData(theEnv)->ActiveProfileFrame->totalWithChildrenTime += addTime;
ProfileFunctionData(theEnv)->ActiveProfileFrame->childCall = FALSE;
}
ProfileFunctionData(theEnv)->ActiveProfileFrame->totalSelfTime += (endTime - ProfileFunctionData(theEnv)->ActiveProfileFrame->startTime);
if (theFrame->oldProfileFrame != NULL)
{ theFrame->oldProfileFrame->startTime = endTime; }
ProfileFunctionData(theEnv)->ActiveProfileFrame = theFrame->oldProfileFrame;
}
/***********************************************************************************
NAME : GenericDispatch
DESCRIPTION : Executes the most specific applicable method
INPUTS : 1) The generic function
2) The method to start after in the search for an applicable
method (ignored if arg #3 is not NULL).
3) A specific method to call (NULL if want highest precedence
method to be called)
4) The generic function argument expressions
5) The caller's result value buffer
RETURNS : Nothing useful
SIDE EFFECTS : Any side-effects of evaluating the generic function arguments
Any side-effects of evaluating query functions on method parameter
restrictions when determining the core (see warning #1)
Any side-effects of actual execution of methods (see warning #2)
Caller's buffer set to the result of the generic function call
In case of errors, the result is false, otherwise it is the
result returned by the most specific method (which can choose
to ignore or return the values of more general methods)
NOTES : WARNING #1: Query functions on method parameter restrictions
should not have side-effects, for they might be evaluated even
for methods that aren't applicable to the generic function call.
WARNING #2: Side-effects of method execution should not always rely
on only being executed once per generic function call. Every
time a method calls (shadow-call) the same next-most-specific
method is executed. Thus, it is possible for a method to be
executed multiple times per generic function call.
***********************************************************************************/
void GenericDispatch(
void *theEnv,
DEFGENERIC *gfunc,
DEFMETHOD *prevmeth,
DEFMETHOD *meth,
EXPRESSION *params,
DATA_OBJECT *result)
{
DEFGENERIC *previousGeneric;
DEFMETHOD *previousMethod;
int oldce;
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
struct CLIPSBlock gcBlock;
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
EvaluationData(theEnv)->EvaluationError = false;
if (EvaluationData(theEnv)->HaltExecution)
return;
CLIPSBlockStart(theEnv,&gcBlock);
oldce = ExecutingConstruct(theEnv);
SetExecutingConstruct(theEnv,true);
previousGeneric = DefgenericData(theEnv)->CurrentGeneric;
previousMethod = DefgenericData(theEnv)->CurrentMethod;
DefgenericData(theEnv)->CurrentGeneric = gfunc;
EvaluationData(theEnv)->CurrentEvaluationDepth++;
gfunc->busy++;
PushProcParameters(theEnv,params,CountArguments(params),
EnvGetDefgenericName(theEnv,(void *) gfunc),
"generic function",UnboundMethodErr);
if (EvaluationData(theEnv)->EvaluationError)
{
gfunc->busy--;
DefgenericData(theEnv)->CurrentGeneric = previousGeneric;
DefgenericData(theEnv)->CurrentMethod = previousMethod;
EvaluationData(theEnv)->CurrentEvaluationDepth--;
CLIPSBlockEnd(theEnv,&gcBlock,result);
CallPeriodicTasks(theEnv);
SetExecutingConstruct(theEnv,oldce);
return;
}
if (meth != NULL)
{
if (IsMethodApplicable(theEnv,meth))
{
meth->busy++;
DefgenericData(theEnv)->CurrentMethod = meth;
}
else
{
PrintErrorID(theEnv,"GENRCEXE",4,false);
EnvSetEvaluationError(theEnv,true);
DefgenericData(theEnv)->CurrentMethod = NULL;
EnvPrintRouter(theEnv,WERROR,"Generic function ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) gfunc));
EnvPrintRouter(theEnv,WERROR," method #");
PrintLongInteger(theEnv,WERROR,(long long) meth->index);
EnvPrintRouter(theEnv,WERROR," is not applicable to the given arguments.\n");
}
}
else
DefgenericData(theEnv)->CurrentMethod = FindApplicableMethod(theEnv,gfunc,prevmeth);
if (DefgenericData(theEnv)->CurrentMethod != NULL)
{
#if DEBUGGING_FUNCTIONS
if (DefgenericData(theEnv)->CurrentGeneric->trace)
WatchGeneric(theEnv,BEGIN_TRACE);
if (DefgenericData(theEnv)->CurrentMethod->trace)
WatchMethod(theEnv,BEGIN_TRACE);
#endif
if (DefgenericData(theEnv)->CurrentMethod->system)
{
EXPRESSION fcall;
fcall.type = FCALL;
fcall.value = DefgenericData(theEnv)->CurrentMethod->actions->value;
fcall.nextArg = NULL;
fcall.argList = GetProcParamExpressions(theEnv);
EvaluateExpression(theEnv,&fcall,result);
}
else
{
#if PROFILING_FUNCTIONS
StartProfile(theEnv,&profileFrame,
&DefgenericData(theEnv)->CurrentMethod->usrData,
ProfileFunctionData(theEnv)->ProfileConstructs);
#endif
EvaluateProcActions(theEnv,DefgenericData(theEnv)->CurrentGeneric->header.whichModule->theModule,
DefgenericData(theEnv)->CurrentMethod->actions,DefgenericData(theEnv)->CurrentMethod->localVarCount,
result,UnboundMethodErr);
#if PROFILING_FUNCTIONS
EndProfile(theEnv,&profileFrame);
#endif
}
DefgenericData(theEnv)->CurrentMethod->busy--;
#if DEBUGGING_FUNCTIONS
if (DefgenericData(theEnv)->CurrentMethod->trace)
WatchMethod(theEnv,END_TRACE);
if (DefgenericData(theEnv)->CurrentGeneric->trace)
WatchGeneric(theEnv,END_TRACE);
#endif
}
else if (! EvaluationData(theEnv)->EvaluationError)
{
PrintErrorID(theEnv,"GENRCEXE",1,false);
EnvPrintRouter(theEnv,WERROR,"No applicable methods for ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) gfunc));
EnvPrintRouter(theEnv,WERROR,".\n");
EnvSetEvaluationError(theEnv,true);
}
gfunc->busy--;
ProcedureFunctionData(theEnv)->ReturnFlag = false;
PopProcParameters(theEnv);
DefgenericData(theEnv)->CurrentGeneric = previousGeneric;
DefgenericData(theEnv)->CurrentMethod = previousMethod;
EvaluationData(theEnv)->CurrentEvaluationDepth--;
CLIPSBlockEnd(theEnv,&gcBlock,result);
CallPeriodicTasks(theEnv);
SetExecutingConstruct(theEnv,oldce);
}
void ProfileInfoCommand(
Environment *theEnv,
UDFContext *context,
UDFValue *returnValue)
{
char buffer[512];
/*==================================*/
/* If code is still being profiled, */
/* update the profile end time. */
/*==================================*/
if (ProfileFunctionData(theEnv)->ProfileUserFunctions || ProfileFunctionData(theEnv)->ProfileConstructs)
{
ProfileFunctionData(theEnv)->ProfileEndTime = gentime();
ProfileFunctionData(theEnv)->ProfileTotalTime += (ProfileFunctionData(theEnv)->ProfileEndTime - ProfileFunctionData(theEnv)->ProfileStartTime);
}
/*==================================*/
/* Print the profiling information. */
/*==================================*/
if (ProfileFunctionData(theEnv)->LastProfileInfo != NO_PROFILE)
{
gensprintf(buffer,"Profile elapsed time = %g seconds\n",
ProfileFunctionData(theEnv)->ProfileTotalTime);
WriteString(theEnv,STDOUT,buffer);
if (ProfileFunctionData(theEnv)->LastProfileInfo == USER_FUNCTIONS)
{ WriteString(theEnv,STDOUT,"Function Name "); }
else if (ProfileFunctionData(theEnv)->LastProfileInfo == CONSTRUCTS_CODE)
{ WriteString(theEnv,STDOUT,"Construct Name "); }
WriteString(theEnv,STDOUT,"Entries Time % Time+Kids %+Kids\n");
if (ProfileFunctionData(theEnv)->LastProfileInfo == USER_FUNCTIONS)
{ WriteString(theEnv,STDOUT,"------------- "); }
else if (ProfileFunctionData(theEnv)->LastProfileInfo == CONSTRUCTS_CODE)
{ WriteString(theEnv,STDOUT,"-------------- "); }
WriteString(theEnv,STDOUT,"------- ------ ----- --------- ------\n");
}
if (ProfileFunctionData(theEnv)->LastProfileInfo == USER_FUNCTIONS) OutputUserFunctionsInfo(theEnv);
if (ProfileFunctionData(theEnv)->LastProfileInfo == CONSTRUCTS_CODE) OutputConstructsCodeInfo(theEnv);
}
static bool OutputProfileInfo(
Environment *theEnv,
const char *itemName,
struct constructProfileInfo *profileInfo,
const char *printPrefixBefore,
const char *printPrefix,
const char *printPrefixAfter,
const char **banner)
{
double percent = 0.0, percentWithKids = 0.0;
char buffer[512];
if (profileInfo == NULL) return false;
if (profileInfo->numberOfEntries == 0) return false;
if (ProfileFunctionData(theEnv)->ProfileTotalTime != 0.0)
{
percent = (profileInfo->totalSelfTime * 100.0) / ProfileFunctionData(theEnv)->ProfileTotalTime;
if (percent < 0.005) percent = 0.0;
percentWithKids = (profileInfo->totalWithChildrenTime * 100.0) / ProfileFunctionData(theEnv)->ProfileTotalTime;
if (percentWithKids < 0.005) percentWithKids = 0.0;
}
if (percent < ProfileFunctionData(theEnv)->PercentThreshold) return false;
if ((banner != NULL) && (*banner != NULL))
{
WriteString(theEnv,STDOUT,*banner);
*banner = NULL;
}
if (printPrefixBefore != NULL)
{ WriteString(theEnv,STDOUT,printPrefixBefore); }
if (printPrefix != NULL)
{ WriteString(theEnv,STDOUT,printPrefix); }
if (printPrefixAfter != NULL)
{ WriteString(theEnv,STDOUT,printPrefixAfter); }
if (strlen(itemName) >= 40)
{
WriteString(theEnv,STDOUT,itemName);
WriteString(theEnv,STDOUT,"\n");
itemName = "";
}
gensprintf(buffer,ProfileFunctionData(theEnv)->OutputString,
itemName,
(long) profileInfo->numberOfEntries,
(double) profileInfo->totalSelfTime,
(double) percent,
(double) profileInfo->totalWithChildrenTime,
(double) percentWithKids);
WriteString(theEnv,STDOUT,buffer);
return true;
}
static void OutputConstructsCodeInfo(
void *theEnv)
{
#if (! DEFFUNCTION_CONSTRUCT) && (! DEFGENERIC_CONSTRUCT) && (! OBJECT_SYSTEM) && (! DEFRULE_CONSTRUCT)
#pragma unused(theEnv)
#endif
#if DEFFUNCTION_CONSTRUCT
DEFFUNCTION *theDeffunction;
#endif
#if DEFRULE_CONSTRUCT
struct defrule *theDefrule;
#endif
#if DEFGENERIC_CONSTRUCT
DEFGENERIC *theDefgeneric;
DEFMETHOD *theMethod;
unsigned methodIndex;
char methodBuffer[512];
#endif
#if OBJECT_SYSTEM
DEFCLASS *theDefclass;
HANDLER *theHandler;
unsigned handlerIndex;
#endif
#if DEFGENERIC_CONSTRUCT || OBJECT_SYSTEM
char *prefix, *prefixBefore, *prefixAfter;
#endif
char *banner;
banner = "\n*** Deffunctions ***\n\n";
#if DEFFUNCTION_CONSTRUCT
for (theDeffunction = (DEFFUNCTION *) EnvGetNextDeffunction(theEnv,NULL);
theDeffunction != NULL;
theDeffunction = (DEFFUNCTION *) EnvGetNextDeffunction(theEnv,theDeffunction))
{
OutputProfileInfo(theEnv,EnvGetDeffunctionName(theEnv,theDeffunction),
(struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theDeffunction->header.usrData),
NULL,NULL,NULL,&banner);
}
#endif
banner = "\n*** Defgenerics ***\n";
#if DEFGENERIC_CONSTRUCT
for (theDefgeneric = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,NULL);
theDefgeneric != NULL;
theDefgeneric = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,theDefgeneric))
{
prefixBefore = "\n";
prefix = EnvGetDefgenericName(theEnv,theDefgeneric);
prefixAfter = "\n";
for (methodIndex = EnvGetNextDefmethod(theEnv,theDefgeneric,0);
methodIndex != 0;
methodIndex = EnvGetNextDefmethod(theEnv,theDefgeneric,methodIndex))
{
theMethod = GetDefmethodPointer(theDefgeneric,methodIndex);
EnvGetDefmethodDescription(theEnv,methodBuffer,510,theDefgeneric,methodIndex);
if (OutputProfileInfo(theEnv,methodBuffer,
(struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theMethod->usrData),
prefixBefore,prefix,prefixAfter,&banner))
{
prefixBefore = NULL;
prefix = NULL;
prefixAfter = NULL;
}
}
}
#endif
banner = "\n*** Defclasses ***\n";
#if OBJECT_SYSTEM
for (theDefclass = (DEFCLASS *) EnvGetNextDefclass(theEnv,NULL);
theDefclass != NULL;
theDefclass = (DEFCLASS *) EnvGetNextDefclass(theEnv,theDefclass))
{
prefixAfter = "\n";
prefix = EnvGetDefclassName(theEnv,theDefclass);
prefixBefore = "\n";
for (handlerIndex = EnvGetNextDefmessageHandler(theEnv,theDefclass,0);
handlerIndex != 0;
handlerIndex = EnvGetNextDefmessageHandler(theEnv,theDefclass,handlerIndex))
{
theHandler = GetDefmessageHandlerPointer(theDefclass,handlerIndex);
if (OutputProfileInfo(theEnv,EnvGetDefmessageHandlerName(theEnv,theDefclass,handlerIndex),
(struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,
theHandler->usrData),
prefixBefore,prefix,prefixAfter,&banner))
{
prefixBefore = NULL;
prefix = NULL;
prefixAfter = NULL;
}
}
}
#endif
banner = "\n*** Defrules ***\n\n";
#if DEFRULE_CONSTRUCT
for (theDefrule = (struct defrule *) EnvGetNextDefrule(theEnv,NULL);
theDefrule != NULL;
theDefrule = (struct defrule *) EnvGetNextDefrule(theEnv,theDefrule))
{
OutputProfileInfo(theEnv,EnvGetDefruleName(theEnv,theDefrule),
(struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theDefrule->header.usrData),
NULL,NULL,NULL,&banner);
}
#endif
}
void ProfileResetCommand(
Environment *theEnv,
UDFContext *context,
UDFValue *returnValue)
{
struct functionDefinition *theFunction;
int i;
#if DEFFUNCTION_CONSTRUCT
Deffunction *theDeffunction;
#endif
#if DEFRULE_CONSTRUCT
Defrule *theDefrule;
#endif
#if DEFGENERIC_CONSTRUCT
Defgeneric *theDefgeneric;
unsigned short methodIndex;
Defmethod *theMethod;
#endif
#if OBJECT_SYSTEM
Defclass *theDefclass;
DefmessageHandler *theHandler;
unsigned handlerIndex;
#endif
ProfileFunctionData(theEnv)->ProfileStartTime = 0.0;
ProfileFunctionData(theEnv)->ProfileEndTime = 0.0;
ProfileFunctionData(theEnv)->ProfileTotalTime = 0.0;
ProfileFunctionData(theEnv)->LastProfileInfo = NO_PROFILE;
for (theFunction = GetFunctionList(theEnv);
theFunction != NULL;
theFunction = theFunction->next)
{
ResetProfileInfo((struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theFunction->usrData));
}
for (i = 0; i < MAXIMUM_PRIMITIVES; i++)
{
if (EvaluationData(theEnv)->PrimitivesArray[i] != NULL)
{
ResetProfileInfo((struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,EvaluationData(theEnv)->PrimitivesArray[i]->usrData));
}
}
#if DEFFUNCTION_CONSTRUCT
for (theDeffunction = GetNextDeffunction(theEnv,NULL);
theDeffunction != NULL;
theDeffunction = GetNextDeffunction(theEnv,theDeffunction))
{
ResetProfileInfo((struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theDeffunction->header.usrData));
}
#endif
#if DEFRULE_CONSTRUCT
for (theDefrule = GetNextDefrule(theEnv,NULL);
theDefrule != NULL;
theDefrule = GetNextDefrule(theEnv,theDefrule))
{
ResetProfileInfo((struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theDefrule->header.usrData));
}
#endif
#if DEFGENERIC_CONSTRUCT
for (theDefgeneric = GetNextDefgeneric(theEnv,NULL);
theDefgeneric != NULL;
theDefgeneric = GetNextDefgeneric(theEnv,theDefgeneric))
{
ResetProfileInfo((struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theDefgeneric->header.usrData));
for (methodIndex = GetNextDefmethod(theDefgeneric,0);
methodIndex != 0;
methodIndex = GetNextDefmethod(theDefgeneric,methodIndex))
{
theMethod = GetDefmethodPointer(theDefgeneric,methodIndex);
ResetProfileInfo((struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theMethod->header.usrData));
}
}
#endif
#if OBJECT_SYSTEM
for (theDefclass = GetNextDefclass(theEnv,NULL);
theDefclass != NULL;
theDefclass = GetNextDefclass(theEnv,theDefclass))
{
ResetProfileInfo((struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theDefclass->header.usrData));
for (handlerIndex = GetNextDefmessageHandler(theDefclass,0);
handlerIndex != 0;
handlerIndex = GetNextDefmessageHandler(theDefclass,handlerIndex))
{
theHandler = GetDefmessageHandlerPointer(theDefclass,handlerIndex);
ResetProfileInfo((struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theHandler->header.usrData));
}
}
#endif
}
globle void ProfileResetCommand(
void *theEnv)
{
struct FunctionDefinition *theFunction;
int i;
#if DEFFUNCTION_CONSTRUCT
DEFFUNCTION *theDeffunction;
#endif
#if DEFRULE_CONSTRUCT
struct defrule *theDefrule;
#endif
#if DEFGENERIC_CONSTRUCT
DEFGENERIC *theDefgeneric;
unsigned int methodIndex;
DEFMETHOD *theMethod;
#endif
#if OBJECT_SYSTEM
DEFCLASS *theDefclass;
HANDLER *theHandler;
unsigned handlerIndex;
#endif
ProfileFunctionData(theEnv)->ProfileStartTime = 0.0;
ProfileFunctionData(theEnv)->ProfileEndTime = 0.0;
ProfileFunctionData(theEnv)->ProfileTotalTime = 0.0;
ProfileFunctionData(theEnv)->LastProfileInfo = NO_PROFILE;
for (theFunction = GetFunctionList(theEnv);
theFunction != NULL;
theFunction = theFunction->next)
{
ResetProfileInfo((struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theFunction->usrData));
}
for (i = 0; i < MAXIMUM_PRIMITIVES; i++)
{
if (EvaluationData(theEnv)->PrimitivesArray[i] != NULL)
{
ResetProfileInfo((struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,EvaluationData(theEnv)->PrimitivesArray[i]->usrData));
}
}
#if DEFFUNCTION_CONSTRUCT
for (theDeffunction = (DEFFUNCTION *) EnvGetNextDeffunction(theEnv,NULL);
theDeffunction != NULL;
theDeffunction = (DEFFUNCTION *) EnvGetNextDeffunction(theEnv,theDeffunction))
{
ResetProfileInfo((struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theDeffunction->header.usrData));
}
#endif
#if DEFRULE_CONSTRUCT
for (theDefrule = (struct defrule *) EnvGetNextDefrule(theEnv,NULL);
theDefrule != NULL;
theDefrule = (struct defrule *) EnvGetNextDefrule(theEnv,theDefrule))
{
ResetProfileInfo((struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theDefrule->header.usrData));
}
#endif
#if DEFGENERIC_CONSTRUCT
for (theDefgeneric = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,NULL);
theDefgeneric != NULL;
theDefgeneric = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,theDefgeneric))
{
ResetProfileInfo((struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theDefgeneric->header.usrData));
for (methodIndex = EnvGetNextDefmethod(theEnv,theDefgeneric,0);
methodIndex != 0;
methodIndex = EnvGetNextDefmethod(theEnv,theDefgeneric,methodIndex))
{
theMethod = GetDefmethodPointer(theDefgeneric,methodIndex);
ResetProfileInfo((struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theMethod->usrData));
}
}
#endif
#if OBJECT_SYSTEM
for (theDefclass = (DEFCLASS *) EnvGetNextDefclass(theEnv,NULL);
theDefclass != NULL;
theDefclass = (DEFCLASS *) EnvGetNextDefclass(theEnv,theDefclass))
{
ResetProfileInfo((struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theDefclass->header.usrData));
for (handlerIndex = EnvGetNextDefmessageHandler(theEnv,theDefclass,0);
handlerIndex != 0;
handlerIndex = EnvGetNextDefmessageHandler(theEnv,theDefclass,handlerIndex))
{
theHandler = GetDefmessageHandlerPointer(theDefclass,handlerIndex);
ResetProfileInfo((struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theHandler->usrData));
}
}
#endif
}
static intBool OutputProfileInfo(
void *theEnv,
char *itemName,
struct constructProfileInfo *profileInfo,
char *printPrefixBefore,
char *printPrefix,
char *printPrefixAfter,
char **banner)
{
double percent = 0.0, percentWithKids = 0.0;
char buffer[512];
if (profileInfo == NULL) return(FALSE);
if (profileInfo->numberOfEntries == 0) return(FALSE);
if (ProfileFunctionData(theEnv)->ProfileTotalTime != 0.0)
{
percent = (profileInfo->totalSelfTime * 100.0) / ProfileFunctionData(theEnv)->ProfileTotalTime;
if (percent < 0.005) percent = 0.0;
percentWithKids = (profileInfo->totalWithChildrenTime * 100.0) / ProfileFunctionData(theEnv)->ProfileTotalTime;
if (percentWithKids < 0.005) percentWithKids = 0.0;
}
if (percent < ProfileFunctionData(theEnv)->PercentThreshold) return(FALSE);
if ((banner != NULL) && (*banner != NULL))
{
EnvPrintRouter(theEnv,WDISPLAY,*banner);
*banner = NULL;
}
if (printPrefixBefore != NULL)
{ EnvPrintRouter(theEnv,WDISPLAY,printPrefixBefore); }
if (printPrefix != NULL)
{ EnvPrintRouter(theEnv,WDISPLAY,printPrefix); }
if (printPrefixAfter != NULL)
{ EnvPrintRouter(theEnv,WDISPLAY,printPrefixAfter); }
if (strlen(itemName) >= 40)
{
EnvPrintRouter(theEnv,WDISPLAY,itemName);
EnvPrintRouter(theEnv,WDISPLAY,"\n");
itemName = "";
}
sprintf(buffer,ProfileFunctionData(theEnv)->OutputString,
itemName,
(long) profileInfo->numberOfEntries,
(double) profileInfo->totalSelfTime,
(double) percent,
(double) profileInfo->totalWithChildrenTime,
(double) percentWithKids);
EnvPrintRouter(theEnv,WDISPLAY,buffer);
return(TRUE);
}
static void OutputConstructsCodeInfo(
Environment *theEnv)
{
#if (! DEFFUNCTION_CONSTRUCT) && (! DEFGENERIC_CONSTRUCT) && (! OBJECT_SYSTEM) && (! DEFRULE_CONSTRUCT)
#pragma unused(theEnv)
#endif
#if DEFFUNCTION_CONSTRUCT
Deffunction *theDeffunction;
#endif
#if DEFRULE_CONSTRUCT
Defrule *theDefrule;
#endif
#if DEFGENERIC_CONSTRUCT
Defgeneric *theDefgeneric;
Defmethod *theMethod;
unsigned short methodIndex;
StringBuilder *theSB;
#endif
#if OBJECT_SYSTEM
Defclass *theDefclass;
DefmessageHandler *theHandler;
unsigned handlerIndex;
#endif
#if DEFGENERIC_CONSTRUCT || OBJECT_SYSTEM
const char *prefix, *prefixBefore, *prefixAfter;
#endif
const char *banner;
banner = "\n*** Deffunctions ***\n\n";
#if DEFFUNCTION_CONSTRUCT
for (theDeffunction = GetNextDeffunction(theEnv,NULL);
theDeffunction != NULL;
theDeffunction = GetNextDeffunction(theEnv,theDeffunction))
{
OutputProfileInfo(theEnv,DeffunctionName(theDeffunction),
(struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theDeffunction->header.usrData),
NULL,NULL,NULL,&banner);
}
#endif
banner = "\n*** Defgenerics ***\n";
#if DEFGENERIC_CONSTRUCT
theSB = CreateStringBuilder(theEnv,512);
for (theDefgeneric = GetNextDefgeneric(theEnv,NULL);
theDefgeneric != NULL;
theDefgeneric = GetNextDefgeneric(theEnv,theDefgeneric))
{
prefixBefore = "\n";
prefix = DefgenericName(theDefgeneric);
prefixAfter = "\n";
for (methodIndex = GetNextDefmethod(theDefgeneric,0);
methodIndex != 0;
methodIndex = GetNextDefmethod(theDefgeneric,methodIndex))
{
theMethod = GetDefmethodPointer(theDefgeneric,methodIndex);
DefmethodDescription(theDefgeneric,methodIndex,theSB);
if (OutputProfileInfo(theEnv,theSB->contents,
(struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theMethod->header.usrData),
prefixBefore,prefix,prefixAfter,&banner))
{
prefixBefore = NULL;
prefix = NULL;
prefixAfter = NULL;
}
}
}
SBDispose(theSB);
#endif
banner = "\n*** Defclasses ***\n";
#if OBJECT_SYSTEM
for (theDefclass = GetNextDefclass(theEnv,NULL);
theDefclass != NULL;
theDefclass = GetNextDefclass(theEnv,theDefclass))
{
prefixAfter = "\n";
prefix = DefclassName(theDefclass);
prefixBefore = "\n";
for (handlerIndex = GetNextDefmessageHandler(theDefclass,0);
handlerIndex != 0;
handlerIndex = GetNextDefmessageHandler(theDefclass,handlerIndex))
{
theHandler = GetDefmessageHandlerPointer(theDefclass,handlerIndex);
if (OutputProfileInfo(theEnv,DefmessageHandlerName(theDefclass,handlerIndex),
(struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,
theHandler->header.usrData),
prefixBefore,prefix,prefixAfter,&banner))
{
prefixBefore = NULL;
prefix = NULL;
prefixAfter = NULL;
}
}
}
#endif
banner = "\n*** Defrules ***\n\n";
#if DEFRULE_CONSTRUCT
for (theDefrule = GetNextDefrule(theEnv,NULL);
theDefrule != NULL;
theDefrule = GetNextDefrule(theEnv,theDefrule))
{
OutputProfileInfo(theEnv,DefruleName(theDefrule),
(struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theDefrule->header.usrData),
NULL,NULL,NULL,&banner);
}
#endif
}
globle void ProfileInfoCommand(
void *theEnv)
{
int argCount;
DATA_OBJECT theValue;
char buffer[512];
/*===================================*/
/* The profile-info command expects */
/* at most a single symbol argument. */
/*===================================*/
if ((argCount = EnvArgCountCheck(theEnv,"profile",NO_MORE_THAN,1)) == -1) return;
/*===========================================*/
/* The first profile-info argument indicates */
/* the field on which sorting is performed. */
/*===========================================*/
if (argCount == 1)
{
if (EnvArgTypeCheck(theEnv,"profile",1,SYMBOL,&theValue) == FALSE) return;
}
/*==================================*/
/* If code is still being profiled, */
/* update the profile end time. */
/*==================================*/
if (ProfileFunctionData(theEnv)->ProfileUserFunctions || ProfileFunctionData(theEnv)->ProfileConstructs)
{
ProfileFunctionData(theEnv)->ProfileEndTime = gentime();
ProfileFunctionData(theEnv)->ProfileTotalTime += (ProfileFunctionData(theEnv)->ProfileEndTime - ProfileFunctionData(theEnv)->ProfileStartTime);
}
/*==================================*/
/* Print the profiling information. */
/*==================================*/
if (ProfileFunctionData(theEnv)->LastProfileInfo != NO_PROFILE)
{
sprintf(buffer,"Profile elapsed time = %g seconds\n",
ProfileFunctionData(theEnv)->ProfileTotalTime);
EnvPrintRouter(theEnv,WDISPLAY,buffer);
if (ProfileFunctionData(theEnv)->LastProfileInfo == USER_FUNCTIONS)
{ EnvPrintRouter(theEnv,WDISPLAY,"Function Name "); }
else if (ProfileFunctionData(theEnv)->LastProfileInfo == CONSTRUCTS_CODE)
{ EnvPrintRouter(theEnv,WDISPLAY,"Construct Name "); }
EnvPrintRouter(theEnv,WDISPLAY,"Entries Time % Time+Kids %+Kids\n");
if (ProfileFunctionData(theEnv)->LastProfileInfo == USER_FUNCTIONS)
{ EnvPrintRouter(theEnv,WDISPLAY,"------------- "); }
else if (ProfileFunctionData(theEnv)->LastProfileInfo == CONSTRUCTS_CODE)
{ EnvPrintRouter(theEnv,WDISPLAY,"-------------- "); }
EnvPrintRouter(theEnv,WDISPLAY,"------- ------ ----- --------- ------\n");
}
if (ProfileFunctionData(theEnv)->LastProfileInfo == USER_FUNCTIONS) OutputUserFunctionsInfo(theEnv);
if (ProfileFunctionData(theEnv)->LastProfileInfo == CONSTRUCTS_CODE) OutputConstructsCodeInfo(theEnv);
}
/****************************************************
NAME : CallDeffunction
DESCRIPTION : Executes the body of a deffunction
INPUTS : 1) The deffunction
2) Argument expressions
3) Data object buffer to hold result
RETURNS : Nothing useful
SIDE EFFECTS : Deffunction executed and result
stored in data object buffer
NOTES : Used in EvaluateExpression(theEnv,)
****************************************************/
globle void CallDeffunction(
void *theEnv,
DEFFUNCTION *dptr,
EXPRESSION *args,
DATA_OBJECT *result)
{
int oldce;
DEFFUNCTION *previouslyExecutingDeffunction;
struct garbageFrame newGarbageFrame;
struct garbageFrame *oldGarbageFrame;
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
EvaluationData(theEnv)->EvaluationError = FALSE;
if (EvaluationData(theEnv)->HaltExecution)
return;
oldGarbageFrame = UtilityData(theEnv)->CurrentGarbageFrame;
memset(&newGarbageFrame,0,sizeof(struct garbageFrame));
newGarbageFrame.priorFrame = oldGarbageFrame;
UtilityData(theEnv)->CurrentGarbageFrame = &newGarbageFrame;
oldce = ExecutingConstruct(theEnv);
SetExecutingConstruct(theEnv,TRUE);
previouslyExecutingDeffunction = DeffunctionData(theEnv)->ExecutingDeffunction;
DeffunctionData(theEnv)->ExecutingDeffunction = dptr;
EvaluationData(theEnv)->CurrentEvaluationDepth++;
dptr->executing++;
PushProcParameters(theEnv,args,CountArguments(args),EnvGetDeffunctionName(theEnv,(void *) dptr),
"deffunction",UnboundDeffunctionErr);
if (EvaluationData(theEnv)->EvaluationError)
{
dptr->executing--;
DeffunctionData(theEnv)->ExecutingDeffunction = previouslyExecutingDeffunction;
EvaluationData(theEnv)->CurrentEvaluationDepth--;
RestorePriorGarbageFrame(theEnv,&newGarbageFrame,oldGarbageFrame,result);
CallPeriodicTasks(theEnv);
SetExecutingConstruct(theEnv,oldce);
return;
}
#if DEBUGGING_FUNCTIONS
if (dptr->trace)
WatchDeffunction(theEnv,BEGIN_TRACE);
#endif
#if PROFILING_FUNCTIONS
StartProfile(theEnv,&profileFrame,
&dptr->header.usrData,
ProfileFunctionData(theEnv)->ProfileConstructs);
#endif
EvaluateProcActions(theEnv,dptr->header.whichModule->theModule,
dptr->code,dptr->numberOfLocalVars,
result,UnboundDeffunctionErr);
#if PROFILING_FUNCTIONS
EndProfile(theEnv,&profileFrame);
#endif
#if DEBUGGING_FUNCTIONS
if (dptr->trace)
WatchDeffunction(theEnv,END_TRACE);
#endif
ProcedureFunctionData(theEnv)->ReturnFlag = FALSE;
dptr->executing--;
PopProcParameters(theEnv);
DeffunctionData(theEnv)->ExecutingDeffunction = previouslyExecutingDeffunction;
EvaluationData(theEnv)->CurrentEvaluationDepth--;
RestorePriorGarbageFrame(theEnv,&newGarbageFrame,oldGarbageFrame,result);
CallPeriodicTasks(theEnv);
SetExecutingConstruct(theEnv,oldce);
}
double GetProfilePercentThreshold(
Environment *theEnv)
{
return(ProfileFunctionData(theEnv)->PercentThreshold);
}
globle long int EnvRun(
void *theEnv,
long int runLimit)
{
long int rulesFired = 0;
DATA_OBJECT result;
struct callFunctionItem *theRunFunction;
#if DEBUGGING_FUNCTIONS
unsigned long maxActivations = 0, sumActivations = 0;
#if DEFTEMPLATE_CONSTRUCT
unsigned long maxFacts = 0, sumFacts = 0;
#endif
#if OBJECT_SYSTEM
unsigned long maxInstances = 0, sumInstances = 0;
#endif
double endTime, startTime = 0.0;
unsigned long tempValue;
#endif
unsigned int i;
struct patternEntity *theMatchingItem;
struct partialMatch *theBasis;
ACTIVATION *theActivation;
char *ruleFiring;
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
/*=====================================================*/
/* Make sure the run command is not already executing. */
/*=====================================================*/
if (EngineData(theEnv)->AlreadyRunning) return(0);
EngineData(theEnv)->AlreadyRunning = TRUE;
/*================================*/
/* Set up statistics information. */
/*================================*/
#if DEBUGGING_FUNCTIONS
if (EngineData(theEnv)->WatchStatistics)
{
#if DEFTEMPLATE_CONSTRUCT
maxFacts = GetNumberOfFacts(theEnv);
sumFacts = maxFacts;
#endif
#if OBJECT_SYSTEM
maxInstances = GetGlobalNumberOfInstances(theEnv);
sumInstances = maxInstances;
#endif
maxActivations = GetNumberOfActivations(theEnv);
sumActivations = maxActivations;
startTime = gentime();
}
#endif
/*=============================*/
/* Set up execution variables. */
/*=============================*/
if (EvaluationData(theEnv)->CurrentEvaluationDepth == 0) SetHaltExecution(theEnv,FALSE);
EngineData(theEnv)->HaltRules = FALSE;
/*=====================================================*/
/* Fire rules until the agenda is empty, the run limit */
/* has been reached, or a rule execution error occurs. */
/*=====================================================*/
theActivation = NextActivationToFire(theEnv);
while ((theActivation != NULL) &&
(runLimit != 0) &&
(EvaluationData(theEnv)->HaltExecution == FALSE) &&
(EngineData(theEnv)->HaltRules == FALSE))
{
/*===========================================*/
/* Detach the activation from the agenda and */
/* determine which rule is firing. */
/*===========================================*/
DetachActivation(theEnv,theActivation);
ruleFiring = EnvGetActivationName(theEnv,theActivation);
theBasis = (struct partialMatch *) GetActivationBasis(theActivation);
EngineData(theEnv)->ExecutingRule = (struct defrule *) GetActivationRule(theActivation);
/*=============================================*/
/* Update the number of rules that have fired. */
/*=============================================*/
rulesFired++;
if (runLimit > 0) { runLimit--; }
/*==================================*/
/* If rules are being watched, then */
/* print an information message. */
/*==================================*/
#if DEBUGGING_FUNCTIONS
if (EngineData(theEnv)->ExecutingRule->watchFiring)
{
char printSpace[60];
sprintf(printSpace,"FIRE %4ld ",rulesFired);
EnvPrintRouter(theEnv,WTRACE,printSpace);
EnvPrintRouter(theEnv,WTRACE,ruleFiring);
EnvPrintRouter(theEnv,WTRACE,": ");
PrintPartialMatch(theEnv,WTRACE,theBasis);
EnvPrintRouter(theEnv,WTRACE,"\n");
}
#endif
/*=================================================*/
/* Remove the link between the activation and the */
/* completed match for the rule. Set the busy flag */
/* for the completed match to TRUE (so the match */
/* upon which our RHS variables are dependent is */
/* not deleted while our rule is firing). Set up */
/* the global pointers to the completed match for */
/* routines which do variable extractions. */
/*=================================================*/
theBasis->binds[theBasis->bcount].gm.theValue = NULL;
theBasis->busy = TRUE;
EngineData(theEnv)->GlobalLHSBinds = theBasis;
EngineData(theEnv)->GlobalRHSBinds = NULL;
/*===================================================================*/
/* Increment the count for each of the facts/objects associated with */
/* the rule activation so that the facts/objects cannot be deleted */
/* by garbage collection while the rule is executing. */
/*===================================================================*/
for (i = 0; i < theBasis->bcount; i++)
{
theMatchingItem = theBasis->binds[i].gm.theMatch->matchingItem;
if (theMatchingItem != NULL)
{ (*theMatchingItem->theInfo->incrementBasisCount)(theEnv,theMatchingItem); }
}
/*====================================================*/
/* Execute the rule's right hand side actions. If the */
/* rule has logical CEs, set up the pointer to the */
/* rules logical join so the assert command will */
/* attach the appropriate dependencies to the facts. */
/*====================================================*/
EngineData(theEnv)->TheLogicalJoin = EngineData(theEnv)->ExecutingRule->logicalJoin;
EvaluationData(theEnv)->CurrentEvaluationDepth++;
SetEvaluationError(theEnv,FALSE);
EngineData(theEnv)->ExecutingRule->executing = TRUE;
#if PROFILING_FUNCTIONS
StartProfile(theEnv,&profileFrame,
&EngineData(theEnv)->ExecutingRule->header.usrData,
ProfileFunctionData(theEnv)->ProfileConstructs);
#endif
EvaluateProcActions(theEnv,EngineData(theEnv)->ExecutingRule->header.whichModule->theModule,
EngineData(theEnv)->ExecutingRule->actions,EngineData(theEnv)->ExecutingRule->localVarCnt,
&result,NULL);
#if PROFILING_FUNCTIONS
EndProfile(theEnv,&profileFrame);
#endif
EngineData(theEnv)->ExecutingRule->executing = FALSE;
SetEvaluationError(theEnv,FALSE);
EvaluationData(theEnv)->CurrentEvaluationDepth--;
EngineData(theEnv)->TheLogicalJoin = NULL;
/*=====================================================*/
/* If rule execution was halted, then print a message. */
/*=====================================================*/
#if DEBUGGING_FUNCTIONS
if ((EvaluationData(theEnv)->HaltExecution) || (EngineData(theEnv)->HaltRules && EngineData(theEnv)->ExecutingRule->watchFiring))
#else
if ((EvaluationData(theEnv)->HaltExecution) || (EngineData(theEnv)->HaltRules))
#endif
{
PrintErrorID(theEnv,"PRCCODE",4,FALSE);
EnvPrintRouter(theEnv,WERROR,"Execution halted during the actions of defrule ");
EnvPrintRouter(theEnv,WERROR,ruleFiring);
EnvPrintRouter(theEnv,WERROR,".\n");
}
/*===================================================================*/
/* Decrement the count for each of the facts/objects associated with */
/* the rule activation. If the last match for the activation */
/* is from a not CE, then we need to make sure that the last */
/* match is an actual match for the CE and not a counter. */
/*===================================================================*/
theBasis->busy = FALSE;
for (i = 0; i < (theBasis->bcount - 1); i++)
{
theMatchingItem = theBasis->binds[i].gm.theMatch->matchingItem;
if (theMatchingItem != NULL)
{ (*theMatchingItem->theInfo->decrementBasisCount)(theEnv,theMatchingItem); }
}
i = (unsigned) (theBasis->bcount - 1);
if (theBasis->counterf == FALSE)
{
theMatchingItem = theBasis->binds[i].gm.theMatch->matchingItem;
if (theMatchingItem != NULL)
{ (*theMatchingItem->theInfo->decrementBasisCount)(theEnv,theMatchingItem); }
}
/*========================================*/
/* Return the agenda node to free memory. */
/*========================================*/
RemoveActivation(theEnv,theActivation,FALSE,FALSE);
/*======================================*/
/* Get rid of partial matches discarded */
/* while executing the rule's RHS. */
/*======================================*/
FlushGarbagePartialMatches(theEnv);
/*==================================*/
/* Get rid of other garbage created */
/* while executing the rule's RHS. */
/*==================================*/
PeriodicCleanup(theEnv,FALSE,TRUE);
/*==========================*/
/* Keep up with statistics. */
/*==========================*/
#if DEBUGGING_FUNCTIONS
if (EngineData(theEnv)->WatchStatistics)
{
#if DEFTEMPLATE_CONSTRUCT
tempValue = GetNumberOfFacts(theEnv);
if (tempValue > maxFacts) maxFacts = tempValue;
sumFacts += tempValue;
#endif
#if OBJECT_SYSTEM
tempValue = GetGlobalNumberOfInstances(theEnv);
if (tempValue > maxInstances) maxInstances = tempValue;
sumInstances += tempValue;
#endif
tempValue = GetNumberOfActivations(theEnv);
if (tempValue > maxActivations) maxActivations = tempValue;
sumActivations += tempValue;
}
#endif
/*==================================*/
/* Update saliences if appropriate. */
/*==================================*/
if (EnvGetSalienceEvaluation(theEnv) == EVERY_CYCLE) EnvRefreshAgenda(theEnv,NULL);
/*========================================*/
/* Execute the list of functions that are */
/* to be called after each rule firing. */
/*========================================*/
for (theRunFunction = EngineData(theEnv)->ListOfRunFunctions;
theRunFunction != NULL;
theRunFunction = theRunFunction->next)
{
if (theRunFunction->environmentAware)
{ (*theRunFunction->func)(theEnv); }
else
{ ((void (*)(void))(*theRunFunction->func))(); }
}
/*========================================*/
/* If a return was issued on the RHS of a */
/* rule, then remove *that* rule's module */
/* from the focus stack */
/*========================================*/
if (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE)
{ RemoveFocus(theEnv,EngineData(theEnv)->ExecutingRule->header.whichModule->theModule); }
ProcedureFunctionData(theEnv)->ReturnFlag = FALSE;
/*========================================*/
/* Determine the next activation to fire. */
/*========================================*/
theActivation = (struct activation *) NextActivationToFire(theEnv);
/*==============================*/
/* Check for a rule breakpoint. */
/*==============================*/
if (theActivation != NULL)
{
if (((struct defrule *) GetActivationRule(theActivation))->afterBreakpoint)
{
EngineData(theEnv)->HaltRules = TRUE;
EnvPrintRouter(theEnv,WDIALOG,"Breaking on rule ");
EnvPrintRouter(theEnv,WDIALOG,EnvGetActivationName(theEnv,theActivation));
EnvPrintRouter(theEnv,WDIALOG,".\n");
}
}
}
/*=====================================================*/
/* Make sure run functions are executed at least once. */
/*=====================================================*/
if (rulesFired == 0)
{
for (theRunFunction = EngineData(theEnv)->ListOfRunFunctions;
theRunFunction != NULL;
theRunFunction = theRunFunction->next)
{
if (theRunFunction->environmentAware)
{ (*theRunFunction->func)(theEnv); }
else
{ ((void (*)(void))(*theRunFunction->func))(); }
}
}
/*======================================================*/
/* If rule execution was halted because the rule firing */
/* limit was reached, then print a message. */
/*======================================================*/
if (runLimit == rulesFired)
{ EnvPrintRouter(theEnv,WDIALOG,"rule firing limit reached\n"); }
/*==============================*/
/* Restore execution variables. */
/*==============================*/
EngineData(theEnv)->ExecutingRule = NULL;
EngineData(theEnv)->HaltRules = FALSE;
/*=================================================*/
/* Print out statistics if they are being watched. */
/*=================================================*/
#if DEBUGGING_FUNCTIONS
if (EngineData(theEnv)->WatchStatistics)
{
char printSpace[60];
endTime = gentime();
PrintLongInteger(theEnv,WDIALOG,rulesFired);
EnvPrintRouter(theEnv,WDIALOG," rules fired");
#if (! GENERIC)
if (startTime != endTime)
{
EnvPrintRouter(theEnv,WDIALOG," Run time is ");
PrintFloat(theEnv,WDIALOG,endTime - startTime);
EnvPrintRouter(theEnv,WDIALOG," seconds.\n");
PrintFloat(theEnv,WDIALOG,(double) rulesFired / (endTime - startTime));
EnvPrintRouter(theEnv,WDIALOG," rules per second.\n");
}
else
{ EnvPrintRouter(theEnv,WDIALOG,"\n"); }
#endif
#if DEFTEMPLATE_CONSTRUCT
sprintf(printSpace,"%ld mean number of facts (%ld maximum).\n",
(long) (((double) sumFacts / (rulesFired + 1)) + 0.5),
maxFacts);
EnvPrintRouter(theEnv,WDIALOG,printSpace);
#endif
#if OBJECT_SYSTEM
sprintf(printSpace,"%ld mean number of instances (%ld maximum).\n",
(long) (((double) sumInstances / (rulesFired + 1)) + 0.5),
maxInstances);
EnvPrintRouter(theEnv,WDIALOG,printSpace);
#endif
sprintf(printSpace,"%ld mean number of activations (%ld maximum).\n",
(long) (((double) sumActivations / (rulesFired + 1)) + 0.5),
maxActivations);
EnvPrintRouter(theEnv,WDIALOG,printSpace);
}
#endif
/*==========================================*/
/* The current module should be the current */
/* focus when the run finishes. */
/*==========================================*/
if (EngineData(theEnv)->CurrentFocus != NULL)
{
if (EngineData(theEnv)->CurrentFocus->theModule != ((struct defmodule *) EnvGetCurrentModule(theEnv)))
{ EnvSetCurrentModule(theEnv,(void *) EngineData(theEnv)->CurrentFocus->theModule); }
}
/*===================================*/
/* Return the number of rules fired. */
/*===================================*/
EngineData(theEnv)->AlreadyRunning = FALSE;
return(rulesFired);
}
/***********************************************************************************
NAME : GenericDispatch
DESCRIPTION : Executes the most specific applicable method
INPUTS : 1) The generic function
2) The method to start after in the search for an applicable
method (ignored if arg #3 is not NULL).
3) A specific method to call (NULL if want highest precedence
method to be called)
4) The generic function argument expressions
5) The caller's result value buffer
RETURNS : Nothing useful
SIDE EFFECTS : Any side-effects of evaluating the generic function arguments
Any side-effects of evaluating query functions on method parameter
restrictions when determining the core (see warning #1)
Any side-effects of actual execution of methods (see warning #2)
Caller's buffer set to the result of the generic function call
In case of errors, the result is false, otherwise it is the
result returned by the most specific method (which can choose
to ignore or return the values of more general methods)
NOTES : WARNING #1: Query functions on method parameter restrictions
should not have side-effects, for they might be evaluated even
for methods that aren't applicable to the generic function call.
WARNING #2: Side-effects of method execution should not always rely
on only being executed once per generic function call. Every
time a method calls (shadow-call) the same next-most-specific
method is executed. Thus, it is possible for a method to be
executed multiple times per generic function call.
***********************************************************************************/
void GenericDispatch(
Environment *theEnv,
Defgeneric *gfunc,
Defmethod *prevmeth,
Defmethod *meth,
Expression *params,
UDFValue *returnValue)
{
Defgeneric *previousGeneric;
Defmethod *previousMethod;
bool oldce;
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
GCBlock gcb;
returnValue->value = FalseSymbol(theEnv);
EvaluationData(theEnv)->EvaluationError = false;
if (EvaluationData(theEnv)->HaltExecution)
return;
GCBlockStart(theEnv,&gcb);
oldce = ExecutingConstruct(theEnv);
SetExecutingConstruct(theEnv,true);
previousGeneric = DefgenericData(theEnv)->CurrentGeneric;
previousMethod = DefgenericData(theEnv)->CurrentMethod;
DefgenericData(theEnv)->CurrentGeneric = gfunc;
EvaluationData(theEnv)->CurrentEvaluationDepth++;
gfunc->busy++;
PushProcParameters(theEnv,params,CountArguments(params),
DefgenericName(gfunc),
"generic function",UnboundMethodErr);
if (EvaluationData(theEnv)->EvaluationError)
{
gfunc->busy--;
DefgenericData(theEnv)->CurrentGeneric = previousGeneric;
DefgenericData(theEnv)->CurrentMethod = previousMethod;
EvaluationData(theEnv)->CurrentEvaluationDepth--;
GCBlockEndUDF(theEnv,&gcb,returnValue);
CallPeriodicTasks(theEnv);
SetExecutingConstruct(theEnv,oldce);
return;
}
if (meth != NULL)
{
if (IsMethodApplicable(theEnv,meth))
{
meth->busy++;
DefgenericData(theEnv)->CurrentMethod = meth;
}
else
{
PrintErrorID(theEnv,"GENRCEXE",4,false);
SetEvaluationError(theEnv,true);
DefgenericData(theEnv)->CurrentMethod = NULL;
WriteString(theEnv,STDERR,"Generic function '");
WriteString(theEnv,STDERR,DefgenericName(gfunc));
WriteString(theEnv,STDERR,"' method #");
PrintUnsignedInteger(theEnv,STDERR,meth->index);
WriteString(theEnv,STDERR," is not applicable to the given arguments.\n");
}
}
else
DefgenericData(theEnv)->CurrentMethod = FindApplicableMethod(theEnv,gfunc,prevmeth);
if (DefgenericData(theEnv)->CurrentMethod != NULL)
{
#if DEBUGGING_FUNCTIONS
if (DefgenericData(theEnv)->CurrentGeneric->trace)
WatchGeneric(theEnv,BEGIN_TRACE);
if (DefgenericData(theEnv)->CurrentMethod->trace)
WatchMethod(theEnv,BEGIN_TRACE);
#endif
if (DefgenericData(theEnv)->CurrentMethod->system)
{
Expression fcall;
fcall.type = FCALL;
fcall.value = DefgenericData(theEnv)->CurrentMethod->actions->value;
fcall.nextArg = NULL;
fcall.argList = GetProcParamExpressions(theEnv);
EvaluateExpression(theEnv,&fcall,returnValue);
}
else
{
#if PROFILING_FUNCTIONS
StartProfile(theEnv,&profileFrame,
&DefgenericData(theEnv)->CurrentMethod->header.usrData,
ProfileFunctionData(theEnv)->ProfileConstructs);
#endif
EvaluateProcActions(theEnv,DefgenericData(theEnv)->CurrentGeneric->header.whichModule->theModule,
DefgenericData(theEnv)->CurrentMethod->actions,DefgenericData(theEnv)->CurrentMethod->localVarCount,
returnValue,UnboundMethodErr);
#if PROFILING_FUNCTIONS
EndProfile(theEnv,&profileFrame);
#endif
}
DefgenericData(theEnv)->CurrentMethod->busy--;
#if DEBUGGING_FUNCTIONS
if (DefgenericData(theEnv)->CurrentMethod->trace)
WatchMethod(theEnv,END_TRACE);
if (DefgenericData(theEnv)->CurrentGeneric->trace)
WatchGeneric(theEnv,END_TRACE);
#endif
}
else if (! EvaluationData(theEnv)->EvaluationError)
{
PrintErrorID(theEnv,"GENRCEXE",1,false);
WriteString(theEnv,STDERR,"No applicable methods for '");
WriteString(theEnv,STDERR,DefgenericName(gfunc));
WriteString(theEnv,STDERR,"'.\n");
SetEvaluationError(theEnv,true);
}
gfunc->busy--;
ProcedureFunctionData(theEnv)->ReturnFlag = false;
PopProcParameters(theEnv);
DefgenericData(theEnv)->CurrentGeneric = previousGeneric;
DefgenericData(theEnv)->CurrentMethod = previousMethod;
EvaluationData(theEnv)->CurrentEvaluationDepth--;
GCBlockEndUDF(theEnv,&gcb,returnValue);
CallPeriodicTasks(theEnv);
SetExecutingConstruct(theEnv,oldce);
}
globle double GetProfilePercentThreshold(
void *theEnv)
{
return(ProfileFunctionData(theEnv)->PercentThreshold);
}
/****************************************************
NAME : CallNextMethod
DESCRIPTION : Executes the next available method
in the core for a generic function
INPUTS : Caller's buffer for the result
RETURNS : Nothing useful
SIDE EFFECTS : Side effects of execution of shadow
EvaluationError set if no method
is available to execute.
NOTES : H/L Syntax: (call-next-method)
****************************************************/
void CallNextMethod(
UDFContext *context,
CLIPSValue *returnValue)
{
DEFMETHOD *oldMethod;
Environment *theEnv = UDFContextEnvironment(context);
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
mCVSetBoolean(returnValue,false);
if (EvaluationData(theEnv)->HaltExecution)
return;
oldMethod = DefgenericData(theEnv)->CurrentMethod;
if (DefgenericData(theEnv)->CurrentMethod != NULL)
DefgenericData(theEnv)->CurrentMethod = FindApplicableMethod(theEnv,DefgenericData(theEnv)->CurrentGeneric,DefgenericData(theEnv)->CurrentMethod);
if (DefgenericData(theEnv)->CurrentMethod == NULL)
{
DefgenericData(theEnv)->CurrentMethod = oldMethod;
PrintErrorID(theEnv,"GENRCEXE",2,false);
EnvPrintRouter(theEnv,WERROR,"Shadowed methods not applicable in current context.\n");
EnvSetEvaluationError(theEnv,true);
return;
}
#if DEBUGGING_FUNCTIONS
if (DefgenericData(theEnv)->CurrentMethod->trace)
WatchMethod(theEnv,BEGIN_TRACE);
#endif
if (DefgenericData(theEnv)->CurrentMethod->system)
{
EXPRESSION fcall;
fcall.type = FCALL;
fcall.value = DefgenericData(theEnv)->CurrentMethod->actions->value;
fcall.nextArg = NULL;
fcall.argList = GetProcParamExpressions(theEnv);
EvaluateExpression(theEnv,&fcall,returnValue);
}
else
{
#if PROFILING_FUNCTIONS
StartProfile(theEnv,&profileFrame,
&DefgenericData(theEnv)->CurrentGeneric->header.usrData,
ProfileFunctionData(theEnv)->ProfileConstructs);
#endif
EvaluateProcActions(theEnv,DefgenericData(theEnv)->CurrentGeneric->header.whichModule->theModule,
DefgenericData(theEnv)->CurrentMethod->actions,DefgenericData(theEnv)->CurrentMethod->localVarCount,
returnValue,UnboundMethodErr);
#if PROFILING_FUNCTIONS
EndProfile(theEnv,&profileFrame);
#endif
}
DefgenericData(theEnv)->CurrentMethod->busy--;
#if DEBUGGING_FUNCTIONS
if (DefgenericData(theEnv)->CurrentMethod->trace)
WatchMethod(theEnv,END_TRACE);
#endif
DefgenericData(theEnv)->CurrentMethod = oldMethod;
ProcedureFunctionData(theEnv)->ReturnFlag = false;
}
globle intBool Profile(
void *theEnv,
char *argument)
{
/*======================================================*/
/* If the argument is the symbol "user-functions", then */
/* user-defined functions should be profiled. If the */
/* argument is the symbol "constructs", then */
/* deffunctions, generic functions, message-handlers, */
/* and rule RHS actions are profiled. */
/*======================================================*/
if (strcmp(argument,"user-functions") == 0)
{
ProfileFunctionData(theEnv)->ProfileStartTime = gentime();
ProfileFunctionData(theEnv)->ProfileUserFunctions = TRUE;
ProfileFunctionData(theEnv)->ProfileConstructs = FALSE;
ProfileFunctionData(theEnv)->LastProfileInfo = USER_FUNCTIONS;
}
else if (strcmp(argument,"constructs") == 0)
{
ProfileFunctionData(theEnv)->ProfileStartTime = gentime();
ProfileFunctionData(theEnv)->ProfileUserFunctions = FALSE;
ProfileFunctionData(theEnv)->ProfileConstructs = TRUE;
ProfileFunctionData(theEnv)->LastProfileInfo = CONSTRUCTS_CODE;
}
/*======================================================*/
/* Otherwise, if the argument is the symbol "off", then */
/* don't profile constructs and user-defined functions. */
/*======================================================*/
else if (strcmp(argument,"off") == 0)
{
ProfileFunctionData(theEnv)->ProfileEndTime = gentime();
ProfileFunctionData(theEnv)->ProfileTotalTime += (ProfileFunctionData(theEnv)->ProfileEndTime - ProfileFunctionData(theEnv)->ProfileStartTime);
ProfileFunctionData(theEnv)->ProfileUserFunctions = FALSE;
ProfileFunctionData(theEnv)->ProfileConstructs = FALSE;
}
/*=====================================================*/
/* Otherwise, generate an error since the only allowed */
/* arguments are "on" or "off." */
/*=====================================================*/
else
{ return(FALSE); }
return(TRUE);
}
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);
}
