/********************************************************* 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); }