/*********************************************************
NAME : DisplayGenericCore
DESCRIPTION : Prints out a description of a core
frame of applicable methods for
a particular call of a generic function
INPUTS : The generic function
RETURNS : Nothing useful
SIDE EFFECTS : None
NOTES : None
*********************************************************/
static void DisplayGenericCore(
void *theEnv,
DEFGENERIC *gfunc)
{
long i;
char buf[256];
int rtn = FALSE;
for (i = 0 ; i < gfunc->mcnt ; i++)
{
gfunc->methods[i].busy++;
if (IsMethodApplicable(theEnv,&gfunc->methods[i]))
{
rtn = TRUE;
EnvPrintRouter(theEnv,WDISPLAY,EnvGetDefgenericName(theEnv,(void *) gfunc));
EnvPrintRouter(theEnv,WDISPLAY,(char*)" #");
PrintMethod(theEnv,buf,255,&gfunc->methods[i]);
EnvPrintRouter(theEnv,WDISPLAY,buf);
EnvPrintRouter(theEnv,WDISPLAY,(char*)"\n");
}
gfunc->methods[i].busy--;
}
if (rtn == FALSE)
{
EnvPrintRouter(theEnv,WDISPLAY,(char*)"No applicable methods for ");
EnvPrintRouter(theEnv,WDISPLAY,EnvGetDefgenericName(theEnv,(void *) gfunc));
EnvPrintRouter(theEnv,WDISPLAY,(char*)".\n");
}
}
/****************************************************************
NAME : ClearDefgenerics
DESCRIPTION : Deletes all generic headers
INPUTS : None
RETURNS : TRUE if all methods deleted, FALSE otherwise
SIDE EFFECTS : Generic headers deleted (and any implicit system
function methods)
NOTES : None
****************************************************************/
globle int ClearDefgenerics(
void *theEnv)
{
register DEFGENERIC *gfunc,*gtmp;
int success = TRUE;
#if BLOAD || BLOAD_AND_BSAVE
if (Bloaded(theEnv) == TRUE) return(FALSE);
#endif
gfunc = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,NULL);
while (gfunc != NULL)
{
gtmp = gfunc;
gfunc = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,(void *) gfunc);
if (RemoveAllExplicitMethods(theEnv,gtmp) == FALSE)
{
CantDeleteItemErrorMessage(theEnv,(char*)"generic function",EnvGetDefgenericName(theEnv,gtmp));
success = FALSE;
}
else
{
RemoveConstructFromModule(theEnv,(struct constructHeader *) gtmp);
RemoveDefgeneric(theEnv,(void *) gtmp);
}
}
return(success);
}
/***************************************************
NAME : DetermineRestrictionClass
DESCRIPTION : Finds the class of an argument in
the ProcParamArray
INPUTS : The argument data object
RETURNS : The class address, NULL if error
SIDE EFFECTS : EvaluationError set on errors
NOTES : None
***************************************************/
static DEFCLASS *DetermineRestrictionClass(
void *theEnv,
DATA_OBJECT *dobj)
{
INSTANCE_TYPE *ins;
DEFCLASS *cls;
if (dobj->type == INSTANCE_NAME)
{
ins = FindInstanceBySymbol(theEnv,(SYMBOL_HN *) dobj->value);
cls = (ins != NULL) ? ins->cls : NULL;
}
else if (dobj->type == INSTANCE_ADDRESS)
{
ins = (INSTANCE_TYPE *) dobj->value;
cls = (ins->garbage == 0) ? ins->cls : NULL;
}
else
return(DefclassData(theEnv)->PrimitiveClassMap[dobj->type]);
if (cls == NULL)
{
EnvSetEvaluationError(theEnv,true);
PrintErrorID(theEnv,"GENRCEXE",3,false);
EnvPrintRouter(theEnv,WERROR,"Unable to determine class of ");
PrintDataObject(theEnv,WERROR,dobj);
EnvPrintRouter(theEnv,WERROR," in generic function ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) DefgenericData(theEnv)->CurrentGeneric));
EnvPrintRouter(theEnv,WERROR,".\n");
}
return(cls);
}
/********************************************************
NAME : MethodAlterError
DESCRIPTION : Prints out an error message reflecting
that a generic function's methods
cannot be altered while any of them
are executing
INPUTS : The generic function
RETURNS : Nothing useful
SIDE EFFECTS : None
NOTES : None
********************************************************/
globle void MethodAlterError(
void *theEnv,
DEFGENERIC *gfunc)
{
PrintErrorID(theEnv,(char*)"GENRCFUN",1,FALSE);
EnvPrintRouter(theEnv,WERROR,(char*)"Defgeneric ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) gfunc));
EnvPrintRouter(theEnv,WERROR,(char*)" cannot be modified while one of its methods is executing.\n");
}
/*******************************************************
NAME : UnboundMethodErr
DESCRIPTION : Print out a synopis of the currently
executing method for unbound variable
errors
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : Error synopsis printed to WERROR
NOTES : None
*******************************************************/
void UnboundMethodErr(
void *theEnv)
{
EnvPrintRouter(theEnv,WERROR,"generic function ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) DefgenericData(theEnv)->CurrentGeneric));
EnvPrintRouter(theEnv,WERROR," method #");
PrintLongInteger(theEnv,WERROR,(long long) DefgenericData(theEnv)->CurrentMethod->index);
EnvPrintRouter(theEnv,WERROR,".\n");
}
/*************************************************************
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,
EXEC_STATUS)
{
DEFGENERIC *gfunc;
DEFGENERIC *previousGeneric;
int oldce;
DATA_OBJECT temp;
execStatus->EvaluationError = FALSE;
if (EnvArgTypeCheck(theEnv,execStatus,"preview-generic",1,SYMBOL,&temp) == FALSE)
return;
gfunc = LookupDefgenericByMdlOrScope(theEnv,execStatus,DOToString(temp));
if (gfunc == NULL)
{
PrintErrorID(theEnv,execStatus,"GENRCFUN",3,FALSE);
EnvPrintRouter(theEnv,execStatus,WERROR,"Unable to find generic function ");
EnvPrintRouter(theEnv,execStatus,WERROR,DOToString(temp));
EnvPrintRouter(theEnv,execStatus,WERROR," in function preview-generic.\n");
return;
}
oldce = ExecutingConstruct(theEnv,execStatus);
SetExecutingConstruct(theEnv,execStatus,TRUE);
previousGeneric = DefgenericData(theEnv,execStatus)->CurrentGeneric;
DefgenericData(theEnv,execStatus)->CurrentGeneric = gfunc;
execStatus->CurrentEvaluationDepth++;
PushProcParameters(theEnv,execStatus,GetFirstArgument()->nextArg,
CountArguments(GetFirstArgument()->nextArg),
EnvGetDefgenericName(theEnv,execStatus,(void *) gfunc),"generic function",
UnboundMethodErr);
if (execStatus->EvaluationError)
{
PopProcParameters(theEnv,execStatus);
DefgenericData(theEnv,execStatus)->CurrentGeneric = previousGeneric;
execStatus->CurrentEvaluationDepth--;
SetExecutingConstruct(theEnv,execStatus,oldce);
return;
}
gfunc->busy++;
DisplayGenericCore(theEnv,execStatus,gfunc);
gfunc->busy--;
PopProcParameters(theEnv,execStatus);
DefgenericData(theEnv,execStatus)->CurrentGeneric = previousGeneric;
execStatus->CurrentEvaluationDepth--;
SetExecutingConstruct(theEnv,execStatus,oldce);
}
/***************************************************
NAME : CheckMethodExists
DESCRIPTION : Finds the array index of the
specified method and prints out
error message if not found
INPUTS : 1) Calling function
2) Generic function address
3) Index of method
RETURNS : Method array index (-1 if not found)
SIDE EFFECTS : None
NOTES : None
***************************************************/
globle long CheckMethodExists(
void *theEnv,
char *fname,
DEFGENERIC *gfunc,
long mi)
{
long fi;
fi = FindMethodByIndex(gfunc,mi);
if (fi == -1)
{
PrintErrorID(theEnv,(char*)"GENRCFUN",2,FALSE);
EnvPrintRouter(theEnv,WERROR,(char*)"Unable to find method ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) gfunc));
EnvPrintRouter(theEnv,WERROR,(char*)" #");
PrintLongInteger(theEnv,WERROR,mi);
EnvPrintRouter(theEnv,WERROR,(char*)" in function ");
EnvPrintRouter(theEnv,WERROR,fname);
EnvPrintRouter(theEnv,WERROR,(char*)".\n");
SetEvaluationError(theEnv,TRUE);
}
return(fi);
}
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
}
/************************************************************
NAME : ValidDeffunctionName
DESCRIPTION : Determines if a new deffunction of the given
name can be defined in the current module
INPUTS : The new deffunction name
RETURNS : TRUE if OK, FALSE otherwise
SIDE EFFECTS : Error message printed if not OK
NOTES : GetConstructNameAndComment() (called before
this function) ensures that the deffunction
name does not conflict with one from
another module
************************************************************/
static BOOLEAN ValidDeffunctionName(
void *theEnv,
char *theDeffunctionName)
{
struct constructHeader *theDeffunction;
#if DEFGENERIC_CONSTRUCT
struct defmodule *theModule;
struct constructHeader *theDefgeneric;
#endif
/* ============================================
A deffunction cannot be named the same as a
construct type, e.g, defclass, defrule, etc.
============================================ */
if (FindConstruct(theEnv,theDeffunctionName) != NULL)
{
PrintErrorID(theEnv,"DFFNXPSR",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Deffunctions are not allowed to replace constructs.\n");
return(FALSE);
}
/* ============================================
A deffunction cannot be named the same as a
pre-defined system function, e.g, watch,
list-defrules, etc.
============================================ */
if (FindFunction(theEnv,theDeffunctionName) != NULL)
{
PrintErrorID(theEnv,"DFFNXPSR",2,FALSE);
EnvPrintRouter(theEnv,WERROR,"Deffunctions are not allowed to replace external functions.\n");
return(FALSE);
}
#if DEFGENERIC_CONSTRUCT
/* ============================================
A deffunction cannot be named the same as a
generic function (either in this module or
imported from another)
============================================ */
theDefgeneric =
(struct constructHeader *) LookupDefgenericInScope(theEnv,theDeffunctionName);
if (theDefgeneric != NULL)
{
theModule = GetConstructModuleItem(theDefgeneric)->theModule;
if (theModule != ((struct defmodule *) EnvGetCurrentModule(theEnv)))
{
PrintErrorID(theEnv,"DFFNXPSR",5,FALSE);
EnvPrintRouter(theEnv,WERROR,"Defgeneric ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) theDefgeneric));
EnvPrintRouter(theEnv,WERROR," imported from module ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefmoduleName(theEnv,(void *) theModule));
EnvPrintRouter(theEnv,WERROR," conflicts with this deffunction.\n");
return(FALSE);
}
else
{
PrintErrorID(theEnv,"DFFNXPSR",3,FALSE);
EnvPrintRouter(theEnv,WERROR,"Deffunctions are not allowed to replace generic functions.\n");
}
return(FALSE);
}
#endif
theDeffunction = (struct constructHeader *) EnvFindDeffunction(theEnv,theDeffunctionName);
if (theDeffunction != NULL)
{
/* ===========================================
And a deffunction in the current module can
only be redefined if it is not executing.
=========================================== */
if (((DEFFUNCTION *) theDeffunction)->executing)
{
PrintErrorID(theEnv,"DFNXPSR",4,FALSE);
EnvPrintRouter(theEnv,WERROR,"Deffunction ");
EnvPrintRouter(theEnv,WERROR,EnvGetDeffunctionName(theEnv,(void *) theDeffunction));
EnvPrintRouter(theEnv,WERROR," may not be redefined while it is executing.\n");
return(FALSE);
}
}
return(TRUE);
}
/***********************************************************************************
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);
}
