/*******************************************************/ /* "C" Language Integrated Production System */ /* */ /* CLIPS Version 6.40 02/19/20 */ /* */ /* */ /*******************************************************/ /*************************************************************/ /* Purpose: Generic Functions Interface Routines */ /* */ /* Principal Programmer(s): */ /* Brian L. Dantes */ /* */ /* Contributing Programmer(s): */ /* */ /* Revision History: */ /* 6.23: Correction for FalseSymbol/TrueSymbol. DR0859 */ /* */ /* Corrected compilation errors for files */ /* generated by constructs-to-c. DR0861 */ /* */ /* Changed name of variable log to logName */ /* because of Unix compiler warnings of shadowed */ /* definitions. */ /* */ /* 6.24: Removed IMPERATIVE_METHODS compilation flag. */ /* */ /* Renamed BOOLEAN macro type to intBool. */ /* */ /* Corrected code to remove run-time program */ /* compiler warning. */ /* */ /* 6.30: Removed conditional code for unsupported */ /* compilers/operating systems (IBM_MCW, */ /* MAC_MCW, and IBM_TBC). */ /* */ /* Changed integer type/precision. */ /* */ /* Added const qualifiers to remove C++ */ /* deprecation warnings. */ /* */ /* Converted API macros to function calls. */ /* */ /* Fixed linkage issue when DEBUGGING_FUNCTIONS */ /* is set to 0 and PROFILING_FUNCTIONS is set to */ /* 1. */ /* */ /* Changed find construct functionality so that */ /* imported modules are search when locating a */ /* named construct. */ /* */ /* Added code to keep track of pointers to */ /* constructs that are contained externally to */ /* to constructs, DanglingConstructs. */ /* */ /* 6.40: Added Env prefix to GetEvaluationError and */ /* SetEvaluationError functions. */ /* */ /* Pragma once and other inclusion changes. */ /* */ /* Added support for booleans with . */ /* */ /* Removed use of void pointers for specific */ /* data structures. */ /* */ /* ALLOW_ENVIRONMENT_GLOBALS no longer supported. */ /* */ /* UDF redesign. */ /* */ /* Pretty print functions accept optional logical */ /* name argument. */ /* */ /*************************************************************/ /* ========================================= ***************************************** EXTERNAL DEFINITIONS ========================================= ***************************************** */ #include "setup.h" #if DEFGENERIC_CONSTRUCT #include #include "argacces.h" #if BLOAD || BLOAD_AND_BSAVE #include "bload.h" #endif #if OBJECT_SYSTEM #include "classcom.h" #include "inscom.h" #endif #include "constrct.h" #include "cstrccom.h" #include "cstrcpsr.h" #include "envrnmnt.h" #include "evaluatn.h" #include "extnfunc.h" #if BLOAD || BLOAD_ONLY || BLOAD_AND_BSAVE #include "genrcbin.h" #endif #if CONSTRUCT_COMPILER #include "genrccmp.h" #endif #include "genrcexe.h" #if (! BLOAD_ONLY) && (! RUN_TIME) #include "genrcpsr.h" #endif #include "memalloc.h" #include "modulpsr.h" #include "modulutl.h" #include "multifld.h" #include "router.h" #include "strngrtr.h" #if DEBUGGING_FUNCTIONS #include "watch.h" #endif #include "prntutil.h" #include "genrccom.h" /* ========================================= ***************************************** INTERNALLY VISIBLE FUNCTION HEADERS ========================================= ***************************************** */ static void PrintGenericCall(Environment *,const char *,Defgeneric *); static bool EvaluateGenericCall(Environment *,Defgeneric *,UDFValue *); static void DecrementGenericBusyCount(Environment *,Defgeneric *); static void IncrementGenericBusyCount(Environment *,Defgeneric *); static void DeallocateDefgenericData(Environment *); #if ! RUN_TIME static void DestroyDefgenericAction(Environment *,ConstructHeader *,void *); #endif #if (! BLOAD_ONLY) && (! RUN_TIME) static void SaveDefgenerics(Environment *,Defmodule *,const char *,void *); static void SaveDefmethods(Environment *,Defmodule *,const char *,void *); static void SaveDefmethodsForDefgeneric(Environment *,ConstructHeader *,void *); static void RemoveDefgenericMethod(Environment *,Defgeneric *,unsigned short); #endif #if DEBUGGING_FUNCTIONS static unsigned short ListMethodsForGeneric(Environment *,const char *,Defgeneric *); static bool DefgenericWatchAccess(Environment *,int,bool,Expression *); static bool DefgenericWatchPrint(Environment *,const char *,int,Expression *); static bool DefmethodWatchAccess(Environment *,int,bool,Expression *); static bool DefmethodWatchPrint(Environment *,const char *,int,Expression *); static bool DefmethodWatchSupport(Environment *,const char *,const char *,bool, void (*)(Environment *,const char *,Defgeneric *,unsigned short), void (*)(Defgeneric *,unsigned short,bool), Expression *); static void PrintMethodWatchFlag(Environment *,const char *,Defgeneric *,unsigned short); #endif /* ========================================= ***************************************** EXTERNALLY VISIBLE FUNCTIONS ========================================= ***************************************** */ /*********************************************************** NAME : SetupGenericFunctions DESCRIPTION : Initializes all generic function data structures, constructs and functions INPUTS : None RETURNS : Nothing useful SIDE EFFECTS : Generic function H/L functions set up NOTES : None ***********************************************************/ void SetupGenericFunctions( Environment *theEnv) { EntityRecord genericEntityRecord = { "GCALL", GCALL,0,0,1, (EntityPrintFunction *) PrintGenericCall, (EntityPrintFunction *) PrintGenericCall, NULL, (EntityEvaluationFunction *) EvaluateGenericCall, NULL, (EntityBusyCountFunction *) DecrementGenericBusyCount, (EntityBusyCountFunction *) IncrementGenericBusyCount, NULL,NULL,NULL,NULL,NULL }; AllocateEnvironmentData(theEnv,DEFGENERIC_DATA,sizeof(struct defgenericData),DeallocateDefgenericData); memcpy(&DefgenericData(theEnv)->GenericEntityRecord,&genericEntityRecord,sizeof(struct entityRecord)); InstallPrimitive(theEnv,&DefgenericData(theEnv)->GenericEntityRecord,GCALL); DefgenericData(theEnv)->DefgenericModuleIndex = RegisterModuleItem(theEnv,"defgeneric", #if (! RUN_TIME) AllocateDefgenericModule, FreeDefgenericModule, #else NULL,NULL, #endif #if BLOAD_AND_BSAVE || BLOAD || BLOAD_ONLY BloadDefgenericModuleReference, #else NULL, #endif #if CONSTRUCT_COMPILER && (! RUN_TIME) DefgenericCModuleReference, #else NULL, #endif (FindConstructFunction *) FindDefgenericInModule); DefgenericData(theEnv)->DefgenericConstruct = AddConstruct(theEnv,"defgeneric","defgenerics", #if (! BLOAD_ONLY) && (! RUN_TIME) ParseDefgeneric, #else NULL, #endif (FindConstructFunction *) FindDefgeneric, GetConstructNamePointer,GetConstructPPForm, GetConstructModuleItem, (GetNextConstructFunction *) GetNextDefgeneric, SetNextConstruct, (IsConstructDeletableFunction *) DefgenericIsDeletable, (DeleteConstructFunction *) Undefgeneric, #if (! BLOAD_ONLY) && (! RUN_TIME) (FreeConstructFunction *) RemoveDefgeneric #else NULL #endif ); #if ! RUN_TIME AddClearReadyFunction(theEnv,"defgeneric",ClearDefgenericsReady,0,NULL); #if BLOAD || BLOAD_ONLY || BLOAD_AND_BSAVE SetupGenericsBload(theEnv); #endif #if CONSTRUCT_COMPILER SetupGenericsCompiler(theEnv); #endif #if ! BLOAD_ONLY #if DEFMODULE_CONSTRUCT AddPortConstructItem(theEnv,"defgeneric",SYMBOL_TOKEN); #endif AddConstruct(theEnv,"defmethod","defmethods",ParseDefmethod, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL); /* ================================================================ Make sure defmethods are cleared last, for other constructs may be using them and need to be cleared first Need to be cleared in two stages so that mutually dependent constructs (like classes) can be cleared ================================================================ */ AddSaveFunction(theEnv,"defgeneric",SaveDefgenerics,1000,NULL); AddSaveFunction(theEnv,"defmethod",SaveDefmethods,-1000,NULL); AddUDF(theEnv,"undefgeneric","v",1,1,"y",UndefgenericCommand,"UndefgenericCommand",NULL); AddUDF(theEnv,"undefmethod","v",2,2,"*;y;ly",UndefmethodCommand,"UndefmethodCommand",NULL); #endif AddUDF(theEnv,"call-next-method","*",0,0,NULL,CallNextMethod,"CallNextMethod",NULL); FuncSeqOvlFlags(theEnv,"call-next-method",true,false); AddUDF(theEnv,"call-specific-method","*",2,UNBOUNDED,"*;y;l",CallSpecificMethod,"CallSpecificMethod",NULL); FuncSeqOvlFlags(theEnv,"call-specific-method",true,false); AddUDF(theEnv,"override-next-method","*",0,UNBOUNDED,NULL,OverrideNextMethod,"OverrideNextMethod",NULL); FuncSeqOvlFlags(theEnv,"override-next-method",true,false); AddUDF(theEnv,"next-methodp","b",0,0,NULL,NextMethodPCommand,"NextMethodPCommand",NULL); FuncSeqOvlFlags(theEnv,"next-methodp",true,false); AddUDF(theEnv,"(gnrc-current-arg)","*",0,UNBOUNDED,NULL,GetGenericCurrentArgument,"GetGenericCurrentArgument",NULL); #if DEBUGGING_FUNCTIONS AddUDF(theEnv,"ppdefgeneric","vs",1,2,";y;ldsyn",PPDefgenericCommand,"PPDefgenericCommand",NULL); AddUDF(theEnv,"list-defgenerics","v",0,1,"y",ListDefgenericsCommand,"ListDefgenericsCommand",NULL); AddUDF(theEnv,"ppdefmethod","v",2,3,"*;y;l;ldsyn",PPDefmethodCommand,"PPDefmethodCommand",NULL); AddUDF(theEnv,"list-defmethods","v",0,1,"y",ListDefmethodsCommand,"ListDefmethodsCommand",NULL); AddUDF(theEnv,"preview-generic","v",1,UNBOUNDED,"*;y",PreviewGeneric,"PreviewGeneric",NULL); #endif AddUDF(theEnv,"get-defgeneric-list","m",0,1,"y",GetDefgenericListFunction,"GetDefgenericListFunction",NULL); AddUDF(theEnv,"get-defmethod-list","m",0,1,"y",GetDefmethodListCommand,"GetDefmethodListCommand",NULL); AddUDF(theEnv,"get-method-restrictions","m",2,2,"l;y",GetMethodRestrictionsCommand,"GetMethodRestrictionsCommand",NULL); AddUDF(theEnv,"defgeneric-module","y",1,1,"y",GetDefgenericModuleCommand,"GetDefgenericModuleCommand",NULL); #if OBJECT_SYSTEM AddUDF(theEnv,"type","*",1,1,"*",ClassCommand,"ClassCommand",NULL); #else AddUDF(theEnv,"type","*",1,1,"*",TypeCommand,"TypeCommand",NULL); #endif #endif #if DEBUGGING_FUNCTIONS AddWatchItem(theEnv,"generic-functions",0,&DefgenericData(theEnv)->WatchGenerics,34, DefgenericWatchAccess,DefgenericWatchPrint); AddWatchItem(theEnv,"methods",0,&DefgenericData(theEnv)->WatchMethods,33, DefmethodWatchAccess,DefmethodWatchPrint); #endif } /*****************************************************/ /* DeallocateDefgenericData: Deallocates environment */ /* data for the defgeneric construct. */ /*****************************************************/ static void DeallocateDefgenericData( Environment *theEnv) { #if ! RUN_TIME struct defgenericModule *theModuleItem; Defmodule *theModule; #if BLOAD || BLOAD_AND_BSAVE if (Bloaded(theEnv)) return; #endif DoForAllConstructs(theEnv, DestroyDefgenericAction, DefgenericData(theEnv)->DefgenericModuleIndex,false,NULL); for (theModule = GetNextDefmodule(theEnv,NULL); theModule != NULL; theModule = GetNextDefmodule(theEnv,theModule)) { theModuleItem = (struct defgenericModule *) GetModuleItem(theEnv,theModule, DefgenericData(theEnv)->DefgenericModuleIndex); rtn_struct(theEnv,defgenericModule,theModuleItem); } #else #if MAC_XCD #pragma unused(theEnv) #endif #endif } #if ! RUN_TIME /****************************************************/ /* DestroyDefgenericAction: Action used to remove */ /* defgenerics as a result of DestroyEnvironment. */ /****************************************************/ static void DestroyDefgenericAction( Environment *theEnv, ConstructHeader *theConstruct, void *buffer) { #if MAC_XCD #pragma unused(buffer) #endif #if (! BLOAD_ONLY) && (! RUN_TIME) Defgeneric *theDefgeneric = (Defgeneric *) theConstruct; long i; if (theDefgeneric == NULL) return; for (i = 0 ; i < theDefgeneric->mcnt ; i++) { DestroyMethodInfo(theEnv,theDefgeneric,&theDefgeneric->methods[i]); } if (theDefgeneric->mcnt != 0) { rm(theEnv,theDefgeneric->methods,(sizeof(Defmethod) * theDefgeneric->mcnt)); } DestroyConstructHeader(theEnv,&theDefgeneric->header); rtn_struct(theEnv,defgeneric,theDefgeneric); #else #if MAC_XCD #pragma unused(theEnv,theConstruct) #endif #endif } #endif /*************************************************** NAME : FindDefgeneric DESCRIPTION : Searches for a generic INPUTS : The name of the generic (possibly including a module name) RETURNS : Pointer to the generic if found, otherwise NULL SIDE EFFECTS : None NOTES : None ***************************************************/ Defgeneric *FindDefgeneric( Environment *theEnv, const char *genericModuleAndName) { return (Defgeneric *) FindNamedConstructInModuleOrImports(theEnv,genericModuleAndName,DefgenericData(theEnv)->DefgenericConstruct); } /*************************************************** NAME : FindDefgenericInModule DESCRIPTION : Searches for a generic INPUTS : The name of the generic (possibly including a module name) RETURNS : Pointer to the generic if found, otherwise NULL SIDE EFFECTS : None NOTES : None ***************************************************/ Defgeneric *FindDefgenericInModule( Environment *theEnv, const char *genericModuleAndName) { return (Defgeneric *) FindNamedConstructInModule(theEnv,genericModuleAndName,DefgenericData(theEnv)->DefgenericConstruct); } /*************************************************** NAME : LookupDefgenericByMdlOrScope DESCRIPTION : Finds a defgeneric anywhere (if module is specified) or in current or imported modules INPUTS : The defgeneric name RETURNS : The defgeneric (NULL if not found) SIDE EFFECTS : Error message printed on ambiguous references NOTES : None ***************************************************/ Defgeneric *LookupDefgenericByMdlOrScope( Environment *theEnv, const char *defgenericName) { return (Defgeneric *) LookupConstruct(theEnv,DefgenericData(theEnv)->DefgenericConstruct,defgenericName,true); } /*************************************************** NAME : LookupDefgenericInScope DESCRIPTION : Finds a defgeneric in current or imported modules (module specifier is not allowed) INPUTS : The defgeneric name RETURNS : The defgeneric (NULL if not found) SIDE EFFECTS : Error message printed on ambiguous references NOTES : None ***************************************************/ Defgeneric *LookupDefgenericInScope( Environment *theEnv, const char *defgenericName) { return (Defgeneric *) LookupConstruct(theEnv,DefgenericData(theEnv)->DefgenericConstruct,defgenericName,false); } /*********************************************************** NAME : GetNextDefgeneric DESCRIPTION : Finds first or next generic function INPUTS : The address of the current generic function RETURNS : The address of the next generic function (NULL if none) SIDE EFFECTS : None NOTES : If ptr == NULL, the first generic function is returned. ***********************************************************/ Defgeneric *GetNextDefgeneric( Environment *theEnv, Defgeneric *theDefgeneric) { return (Defgeneric *) GetNextConstructItem(theEnv,&theDefgeneric->header,DefgenericData(theEnv)->DefgenericModuleIndex); } /*********************************************************** NAME : GetNextDefmethod DESCRIPTION : Find the next method for a generic function INPUTS : 1) The generic function address 2) The index of the current method RETURNS : The index of the next method (0 if none) SIDE EFFECTS : None NOTES : If index == 0, the index of the first method is returned ***********************************************************/ unsigned short GetNextDefmethod( Defgeneric *theDefgeneric, unsigned short theIndex) { unsigned short mi; if (theIndex == 0) { if (theDefgeneric->methods != NULL) { return theDefgeneric->methods[0].index; } return 0; } mi = FindMethodByIndex(theDefgeneric,theIndex); if ((mi+1) == theDefgeneric->mcnt) { return 0; } return theDefgeneric->methods[mi+1].index; } /***************************************************** NAME : GetDefmethodPointer DESCRIPTION : Returns a pointer to a method INPUTS : 1) Pointer to a defgeneric 2) Array index of method in generic's method array (+1) RETURNS : Pointer to the method. SIDE EFFECTS : None NOTES : None *****************************************************/ Defmethod *GetDefmethodPointer( Defgeneric *theDefgeneric, long theIndex) { return &theDefgeneric->methods[theIndex-1]; } /*************************************************** NAME : IsDefgenericDeletable DESCRIPTION : Determines if a generic function can be deleted INPUTS : Address of the generic function RETURNS : True if deletable, false otherwise SIDE EFFECTS : None NOTES : None ***************************************************/ bool DefgenericIsDeletable( Defgeneric *theDefgeneric) { Environment *theEnv = theDefgeneric->header.env; if (! ConstructsDeletable(theEnv)) { return false; } return (theDefgeneric->busy == 0) ? true : false; } /*************************************************** NAME : DefmethodIsDeletable DESCRIPTION : Determines if a generic function method can be deleted INPUTS : 1) Address of the generic function 2) Index of the method RETURNS : True if deletable, false otherwise SIDE EFFECTS : None NOTES : None ***************************************************/ bool DefmethodIsDeletable( Defgeneric *theDefgeneric, unsigned short theIndex) { Environment *theEnv = theDefgeneric->header.env; unsigned short mi; if (! ConstructsDeletable(theEnv)) { return false; } mi = FindMethodByIndex(theDefgeneric,theIndex); if (mi == METHOD_NOT_FOUND) return false; if (theDefgeneric->methods[mi].system) return false; #if (! BLOAD_ONLY) && (! RUN_TIME) return (MethodsExecuting(theDefgeneric) == false) ? true : false; #else return false; #endif } /********************************************************** NAME : UndefgenericCommand DESCRIPTION : Deletes all methods for a generic function INPUTS : None RETURNS : Nothing useful SIDE EFFECTS : methods deallocated NOTES : H/L Syntax: (undefgeneric | *) **********************************************************/ void UndefgenericCommand( Environment *theEnv, UDFContext *context, UDFValue *returnValue) { UndefconstructCommand(context,"undefgeneric",DefgenericData(theEnv)->DefgenericConstruct); } /**************************************************************** NAME : GetDefgenericModuleCommand DESCRIPTION : Determines to which module a defgeneric belongs INPUTS : None RETURNS : The symbolic name of the module SIDE EFFECTS : None NOTES : H/L Syntax: (defgeneric-module ) ****************************************************************/ void GetDefgenericModuleCommand( Environment *theEnv, UDFContext *context, UDFValue *returnValue) { returnValue->value = GetConstructModuleCommand(context,"defgeneric-module",DefgenericData(theEnv)->DefgenericConstruct); } /************************************************************** NAME : UndefmethodCommand DESCRIPTION : Deletes one method for a generic function INPUTS : None RETURNS : Nothing useful SIDE EFFECTS : methods deallocated NOTES : H/L Syntax: (undefmethod | *) **************************************************************/ void UndefmethodCommand( Environment *theEnv, UDFContext *context, UDFValue *returnValue) { UDFValue theArg; Defgeneric *gfunc; unsigned short mi; if (! UDFFirstArgument(context,SYMBOL_BIT,&theArg)) return; gfunc = LookupDefgenericByMdlOrScope(theEnv,theArg.lexemeValue->contents); if ((gfunc == NULL) ? (strcmp(theArg.lexemeValue->contents,"*") != 0) : false) { PrintErrorID(theEnv,"GENRCCOM",1,false); WriteString(theEnv,STDERR,"No such generic function '"); WriteString(theEnv,STDERR,theArg.lexemeValue->contents); WriteString(theEnv,STDERR,"' in function undefmethod.\n"); return; } if (! UDFNextArgument(context,ANY_TYPE_BITS,&theArg)) return; if (CVIsType(&theArg,SYMBOL_BIT)) { if (strcmp(theArg.lexemeValue->contents,"*") != 0) { PrintErrorID(theEnv,"GENRCCOM",2,false); WriteString(theEnv,STDERR,"Expected a valid method index in function undefmethod.\n"); return; } mi = 0; } else if (CVIsType(&theArg,INTEGER_BIT)) { mi = (unsigned short) theArg.integerValue->contents; if (mi == 0) { PrintErrorID(theEnv,"GENRCCOM",2,false); WriteString(theEnv,STDERR,"Expected a valid method index in function undefmethod.\n"); return; } } else { PrintErrorID(theEnv,"GENRCCOM",2,false); WriteString(theEnv,STDERR,"Expected a valid method index in function undefmethod.\n"); return; } Undefmethod(gfunc,mi,theEnv); } /************************************************************** NAME : EnvUndefgeneric DESCRIPTION : Deletes all methods for a generic function INPUTS : The generic-function address (NULL for all) RETURNS : True if generic successfully deleted, false otherwise SIDE EFFECTS : methods deallocated NOTES : None **************************************************************/ bool Undefgeneric( Defgeneric *theDefgeneric, Environment *allEnv) { #if RUN_TIME || BLOAD_ONLY return false; #else Environment *theEnv; bool success = true; GCBlock gcb; if (theDefgeneric == NULL) { theEnv = allEnv; } else { theEnv = theDefgeneric->header.env; } GCBlockStart(theEnv,&gcb); if (theDefgeneric == NULL) { if (ClearDefmethods(theEnv) == false) success = false; if (ClearDefgenerics(theEnv) == false) success = false; GCBlockEnd(theEnv,&gcb); return success ; } if (DefgenericIsDeletable(theDefgeneric) == false) { GCBlockEnd(theEnv,&gcb); return false; } RemoveConstructFromModule(theEnv,&theDefgeneric->header); RemoveDefgeneric(theEnv,theDefgeneric); GCBlockEnd(theEnv,&gcb); return true; #endif } /************************************************************** NAME : Undefmethod DESCRIPTION : Deletes one method for a generic function INPUTS : 1) Address of generic function (can be NULL) 2) Method index (0 for all) RETURNS : True if method deleted successfully, false otherwise SIDE EFFECTS : methods deallocated NOTES : None **************************************************************/ bool Undefmethod( Defgeneric *theDefgeneric, unsigned short mi, Environment *allEnv) { Environment *theEnv; #if (! RUN_TIME) && (! BLOAD_ONLY) GCBlock gcb; #endif if (theDefgeneric == NULL) { theEnv = allEnv; } else { theEnv = theDefgeneric->header.env; } #if RUN_TIME || BLOAD_ONLY PrintErrorID(theEnv,"PRNTUTIL",4,false); WriteString(theEnv,STDERR,"Unable to delete method "); if (theDefgeneric != NULL) { WriteString(theEnv,STDERR,"'"); PrintGenericName(theEnv,STDERR,theDefgeneric); WriteString(theEnv,STDERR,"'"); WriteString(theEnv,STDERR," #"); PrintUnsignedInteger(theEnv,STDERR,mi); } else WriteString(theEnv,STDERR,"*"); WriteString(theEnv,STDERR,".\n"); return false; #else #if BLOAD || BLOAD_AND_BSAVE if (Bloaded(theEnv) == true) { PrintErrorID(theEnv,"PRNTUTIL",4,false); WriteString(theEnv,STDERR,"Unable to delete method "); if (theDefgeneric != NULL) { WriteString(theEnv,STDERR,"'"); WriteString(theEnv,STDERR,DefgenericName(theDefgeneric)); WriteString(theEnv,STDERR,"'"); WriteString(theEnv,STDERR," #"); PrintUnsignedInteger(theEnv,STDERR,mi); } else WriteString(theEnv,STDERR,"*"); WriteString(theEnv,STDERR,".\n"); return false; } #endif GCBlockStart(theEnv,&gcb); if (theDefgeneric == NULL) { bool success; if (mi != 0) { PrintErrorID(theEnv,"GENRCCOM",3,false); WriteString(theEnv,STDERR,"Incomplete method specification for deletion.\n"); GCBlockEnd(theEnv,&gcb); return false; } success = ClearDefmethods(theEnv); GCBlockEnd(theEnv,&gcb); return success; } if (MethodsExecuting(theDefgeneric)) { MethodAlterError(theEnv,theDefgeneric); GCBlockEnd(theEnv,&gcb); return false; } if (mi == 0) { RemoveAllExplicitMethods(theEnv,theDefgeneric); } else { unsigned short nmi = CheckMethodExists(theEnv,"undefmethod",theDefgeneric,mi); if (nmi == METHOD_NOT_FOUND) { GCBlockEnd(theEnv,&gcb); return false; } RemoveDefgenericMethod(theEnv,theDefgeneric,nmi); } GCBlockEnd(theEnv,&gcb); return true; #endif } #if DEBUGGING_FUNCTIONS || PROFILING_FUNCTIONS /***************************************************** NAME : DefmethodDescription DESCRIPTION : Prints a synopsis of method parameter restrictions into caller's buffer INPUTS : 1) Caller's buffer 2) Buffer size (not including space for terminating '\0') 3) Address of generic function 4) Index of method RETURNS : Nothing useful SIDE EFFECTS : Caller's buffer written NOTES : Terminating '\n' not written *****************************************************/ void DefmethodDescription( Defgeneric *theDefgeneric, unsigned short theIndex, StringBuilder *theSB) { long mi; Environment *theEnv = theDefgeneric->header.env; mi = FindMethodByIndex(theDefgeneric,theIndex); OpenStringBuilderDestination(theEnv,"MethodDescription",theSB); if (mi != METHOD_NOT_FOUND) { PrintMethod(theEnv,&theDefgeneric->methods[mi],theSB); } CloseStringBuilderDestination(theEnv,"MethodDescription"); } #endif /* DEBUGGING_FUNCTIONS || PROFILING_FUNCTIONS */ #if DEBUGGING_FUNCTIONS /********************************************************* NAME : GetDefgenericWatch DESCRIPTION : Determines if trace messages are gnerated when executing generic function INPUTS : A pointer to the generic RETURNS : True if a trace is active, false otherwise SIDE EFFECTS : None NOTES : None *********************************************************/ bool DefgenericGetWatch( Defgeneric *theGeneric) { return theGeneric->trace; } /********************************************************* NAME : SetDefgenericWatch DESCRIPTION : Sets the trace to ON/OFF for the generic function INPUTS : 1) True to set the trace on, False to set it off 2) A pointer to the generic RETURNS : Nothing useful SIDE EFFECTS : Watch flag for the generic set NOTES : None *********************************************************/ void DefgenericSetWatch( Defgeneric *theGeneric, bool newState) { theGeneric->trace = newState; } /********************************************************* NAME : DefmethodGetWatch DESCRIPTION : Determines if trace messages for calls to this method will be generated or not INPUTS : 1) A pointer to the generic 2) The index of the method RETURNS : True if a trace is active, false otherwise SIDE EFFECTS : None NOTES : None *********************************************************/ bool DefmethodGetWatch( Defgeneric *theGeneric, unsigned short theIndex) { unsigned short mi; mi = FindMethodByIndex(theGeneric,theIndex); if (mi != METHOD_NOT_FOUND) { return theGeneric->methods[mi].trace; } return false; } /********************************************************* NAME : DefmethodSetWatch DESCRIPTION : Sets the trace to ON/OFF for the calling of the method INPUTS : 1) True to set the trace on, false to set it off 2) A pointer to the generic 3) The index of the method RETURNS : Nothing useful SIDE EFFECTS : Watch flag for the method set NOTES : None *********************************************************/ void DefmethodSetWatch( Defgeneric *theGeneric, unsigned short theIndex, bool newState) { unsigned short mi; mi = FindMethodByIndex(theGeneric,theIndex); if (mi != METHOD_NOT_FOUND) { theGeneric->methods[mi].trace = newState; } } /******************************************************** NAME : PPDefgenericCommand DESCRIPTION : Displays the pretty-print form of a generic function header INPUTS : None RETURNS : Nothing useful SIDE EFFECTS : None NOTES : H/L Syntax: (ppdefgeneric ) ********************************************************/ void PPDefgenericCommand( Environment *theEnv, UDFContext *context, UDFValue *returnValue) { PPConstructCommand(context,"ppdefgeneric",DefgenericData(theEnv)->DefgenericConstruct,returnValue); } /********************************************************** NAME : PPDefmethodCommand DESCRIPTION : Displays the pretty-print form of a method INPUTS : None RETURNS : Nothing useful SIDE EFFECTS : None NOTES : H/L Syntax: (ppdefmethod ) **********************************************************/ void PPDefmethodCommand( Environment *theEnv, UDFContext *context, UDFValue *returnValue) { UDFValue theArg; const char *gname; const char *logicalName; Defgeneric *gfunc; unsigned short gi; if (! UDFFirstArgument(context,SYMBOL_BIT,&theArg)) return; gname = theArg.lexemeValue->contents; if (! UDFNextArgument(context,INTEGER_BIT,&theArg)) return; if (UDFHasNextArgument(context)) { logicalName = GetLogicalName(context,STDOUT); if (logicalName == NULL) { IllegalLogicalNameMessage(theEnv,"ppdefmethod"); SetHaltExecution(theEnv,true); SetEvaluationError(theEnv,true); return; } } else { logicalName = STDOUT; } gfunc = CheckGenericExists(theEnv,"ppdefmethod",gname); if (gfunc == NULL) return; gi = CheckMethodExists(theEnv,"ppdefmethod",gfunc,(unsigned short) theArg.integerValue->contents); if (gi == METHOD_NOT_FOUND) return; if (strcmp(logicalName,"nil") == 0) { if (gfunc->methods[gi].header.ppForm != NULL) { returnValue->lexemeValue = CreateString(theEnv,gfunc->methods[gi].header.ppForm); } else { returnValue->lexemeValue = CreateString(theEnv,""); } } else { if (gfunc->methods[gi].header.ppForm != NULL) WriteString(theEnv,logicalName,gfunc->methods[gi].header.ppForm); } } /****************************************************** NAME : ListDefmethodsCommand DESCRIPTION : Lists a brief description of methods for a particular generic function INPUTS : None RETURNS : Nothing useful SIDE EFFECTS : None NOTES : H/L Syntax: (list-defmethods ) ******************************************************/ void ListDefmethodsCommand( Environment *theEnv, UDFContext *context, UDFValue *returnValue) { UDFValue theArg; Defgeneric *gfunc; if (! UDFHasNextArgument(context)) { ListDefmethods(theEnv,STDOUT,NULL); } else { if (! UDFFirstArgument(context,SYMBOL_BIT,&theArg)) return; gfunc = CheckGenericExists(theEnv,"list-defmethods",theArg.lexemeValue->contents); if (gfunc != NULL) { ListDefmethods(theEnv,STDOUT,gfunc); } } } /*************************************************************** NAME : DefmethodPPForm DESCRIPTION : Getsa generic function method pretty print form INPUTS : 1) Address of the generic function 2) Index of the method RETURNS : Method ppform SIDE EFFECTS : None NOTES : None ***************************************************************/ const char *DefmethodPPForm( Defgeneric *theDefgeneric, unsigned short theIndex) { unsigned short mi; mi = FindMethodByIndex(theDefgeneric,theIndex); if (mi != METHOD_NOT_FOUND) { return theDefgeneric->methods[mi].header.ppForm; } return ""; } /*************************************************** NAME : ListDefgenericsCommand DESCRIPTION : Displays all defgeneric names INPUTS : None RETURNS : Nothing useful SIDE EFFECTS : Defgeneric names printed NOTES : H/L Interface ***************************************************/ void ListDefgenericsCommand( Environment *theEnv, UDFContext *context, UDFValue *returnValue) { ListConstructCommand(context,DefgenericData(theEnv)->DefgenericConstruct); } /*************************************************** NAME : ListDefgenerics DESCRIPTION : Displays all defgeneric names INPUTS : 1) The logical name of the output 2) The module RETURNS : Nothing useful SIDE EFFECTS : Defgeneric names printed NOTES : C Interface ***************************************************/ void ListDefgenerics( Environment *theEnv, const char *logicalName, Defmodule *theModule) { ListConstruct(theEnv,DefgenericData(theEnv)->DefgenericConstruct,logicalName,theModule); } /****************************************************** NAME : ListDefmethods DESCRIPTION : Lists a brief description of methods for a particular generic function INPUTS : 1) The logical name of the output 2) Generic function to list methods for (NULL means list all methods) RETURNS : Nothing useful SIDE EFFECTS : None NOTES : None ******************************************************/ void ListDefmethods( Environment *theEnv, const char *logicalName, Defgeneric *theDefgeneric) { Defgeneric *gfunc; unsigned long count; if (theDefgeneric != NULL) count = ListMethodsForGeneric(theEnv,logicalName,theDefgeneric); else { count = 0; for (gfunc = GetNextDefgeneric(theEnv,NULL) ; gfunc != NULL ; gfunc = GetNextDefgeneric(theEnv,gfunc)) { count += ListMethodsForGeneric(theEnv,logicalName,gfunc); if (GetNextDefgeneric(theEnv,gfunc) != NULL) WriteString(theEnv,logicalName,"\n"); } } PrintTally(theEnv,logicalName,count,"method","methods"); } #endif /* DEBUGGING_FUNCTIONS */ /*************************************************************** NAME : GetDefgenericListFunction DESCRIPTION : Groups all defgeneric names into a multifield list INPUTS : A data object buffer to hold the multifield result RETURNS : Nothing useful SIDE EFFECTS : Multifield allocated and filled NOTES : H/L Syntax: (get-defgeneric-list []) ***************************************************************/ void GetDefgenericListFunction( Environment *theEnv, UDFContext *context, UDFValue *returnValue) { GetConstructListFunction(context,returnValue,DefgenericData(theEnv)->DefgenericConstruct); } /*************************************************************** NAME : GetDefgenericList DESCRIPTION : Groups all defgeneric names into a multifield list INPUTS : 1) A data object buffer to hold the multifield result 2) The module from which to obtain defgenerics RETURNS : Nothing useful SIDE EFFECTS : Multifield allocated and filled NOTES : External C access ***************************************************************/ void GetDefgenericList( Environment *theEnv, CLIPSValue *returnValue, Defmodule *theModule) { UDFValue result; GetConstructList(theEnv,&result,DefgenericData(theEnv)->DefgenericConstruct,theModule); NormalizeMultifield(theEnv,&result); returnValue->value = result.value; } /*********************************************************** NAME : GetDefmethodListCommand DESCRIPTION : Groups indices of all methdos for a generic function into a multifield variable (NULL means get methods for all generics) INPUTS : A data object buffer RETURNS : Nothing useful SIDE EFFECTS : Multifield set to list of method indices NOTES : None ***********************************************************/ void GetDefmethodListCommand( Environment *theEnv, UDFContext *context, UDFValue *returnValue) { UDFValue theArg; Defgeneric *gfunc; CLIPSValue result; if (! UDFHasNextArgument(context)) { GetDefmethodList(theEnv,&result,NULL); CLIPSToUDFValue(&result,returnValue); } else { if (! UDFFirstArgument(context,SYMBOL_BIT,&theArg)) { return; } gfunc = CheckGenericExists(theEnv,"get-defmethod-list",theArg.lexemeValue->contents); if (gfunc != NULL) { GetDefmethodList(theEnv,&result,gfunc); CLIPSToUDFValue(&result,returnValue); } else { SetMultifieldErrorValue(theEnv,returnValue); } } } /*********************************************************** NAME : GetDefmethodList DESCRIPTION : Groups indices of all methdos for a generic function into a multifield variable (NULL means get methods for all generics) INPUTS : 1) A pointer to a generic function 2) A data object buffer RETURNS : Nothing useful SIDE EFFECTS : Multifield set to list of method indices NOTES : None ***********************************************************/ void GetDefmethodList( Environment *theEnv, CLIPSValue *returnValue, Defgeneric *theDefgeneric) { Defgeneric *gfunc, *svg, *svnxt; long i,j; unsigned long count; Multifield *theList; if (theDefgeneric != NULL) { gfunc = theDefgeneric; svnxt = GetNextDefgeneric(theEnv,theDefgeneric); SetNextDefgeneric(theDefgeneric,NULL); } else { gfunc = GetNextDefgeneric(theEnv,NULL); svnxt = (gfunc != NULL) ? GetNextDefgeneric(theEnv,gfunc) : NULL; } count = 0; for (svg = gfunc ; gfunc != NULL ; gfunc = GetNextDefgeneric(theEnv,gfunc)) count += gfunc->mcnt; count *= 2; theList = CreateMultifield(theEnv,count); returnValue->value = theList; for (gfunc = svg , i = 0 ; gfunc != NULL ; gfunc = GetNextDefgeneric(theEnv,gfunc)) { for (j = 0 ; j < gfunc->mcnt ; j++) { theList->contents[i++].value = GetDefgenericNamePointer(gfunc); theList->contents[i++].integerValue = CreateInteger(theEnv,(long long) gfunc->methods[j].index); } } if (svg != NULL) SetNextDefgeneric(svg,svnxt); } /*********************************************************************************** NAME : GetMethodRestrictionsCommand DESCRIPTION : Stores restrictions of a method in multifield INPUTS : A data object buffer to hold a multifield RETURNS : Nothing useful SIDE EFFECTS : Multifield created (length zero on errors) NOTES : Syntax: (get-method-restrictions ) ***********************************************************************************/ void GetMethodRestrictionsCommand( Environment *theEnv, UDFContext *context, UDFValue *returnValue) { UDFValue theArg; Defgeneric *gfunc; CLIPSValue result; unsigned short mi; if (! UDFFirstArgument(context,SYMBOL_BIT,&theArg)) { return; } gfunc = CheckGenericExists(theEnv,"get-method-restrictions",theArg.lexemeValue->contents); if (gfunc == NULL) { SetMultifieldErrorValue(theEnv,returnValue); return; } if (! UDFNextArgument(context,INTEGER_BIT,&theArg)) { return; } mi = (unsigned short) theArg.integerValue->contents; if (CheckMethodExists(theEnv,"get-method-restrictions",gfunc,mi) == METHOD_NOT_FOUND) { SetMultifieldErrorValue(theEnv,returnValue); return; } GetMethodRestrictions(gfunc,mi,&result); CLIPSToUDFValue(&result,returnValue); } /*********************************************************************** NAME : GetMethodRestrictions DESCRIPTION : Stores restrictions of a method in multifield INPUTS : 1) Pointer to the generic function 2) The method index 3) A data object buffer to hold a multifield RETURNS : Nothing useful SIDE EFFECTS : Multifield created (length zero on errors) NOTES : The restrictions are stored in the multifield in the following format: (-1 if wildcard allowed) . . . . . . . Thus, for the method (defmethod foo ((?a NUMBER SYMBOL_TYPE) (?b (= 1 1)) $?c)) (get-method-restrictions foo 1) would yield (2 -1 3 7 11 13 FALSE 2 NUMBER SYMBOL_TYPE TRUE 0 FALSE 0) ***********************************************************************/ void GetMethodRestrictions( Defgeneric *theDefgeneric, unsigned short mi, CLIPSValue *returnValue) { short i,j; Defmethod *meth; RESTRICTION *rptr; size_t count; int roffset,rstrctIndex; Multifield *theList; Environment *theEnv = theDefgeneric->header.env; meth = theDefgeneric->methods + FindMethodByIndex(theDefgeneric,mi); count = 3; for (i = 0 ; i < meth->restrictionCount ; i++) count += meth->restrictions[i].tcnt + 3; theList = CreateMultifield(theEnv,count); returnValue->value = theList; if (meth->minRestrictions == RESTRICTIONS_UNBOUNDED) { theList->contents[0].integerValue = CreateInteger(theEnv,-1); } else { theList->contents[0].integerValue = CreateInteger(theEnv,(long long) meth->minRestrictions); } if (meth->maxRestrictions == RESTRICTIONS_UNBOUNDED) { theList->contents[1].integerValue = CreateInteger(theEnv,-1); } else { theList->contents[1].integerValue = CreateInteger(theEnv,(long long) meth->maxRestrictions); } theList->contents[2].integerValue = CreateInteger(theEnv,(long long) meth->restrictionCount); roffset = 3 + meth->restrictionCount; rstrctIndex = 3; for (i = 0 ; i < meth->restrictionCount ; i++) { rptr = meth->restrictions + i; theList->contents[rstrctIndex++].integerValue = CreateInteger(theEnv,(long long) roffset + 1); theList->contents[roffset++].lexemeValue = (rptr->query != NULL) ? TrueSymbol(theEnv) : FalseSymbol(theEnv); theList->contents[roffset++].integerValue = CreateInteger(theEnv,(long long) rptr->tcnt); for (j = 0 ; j < rptr->tcnt ; j++) { #if OBJECT_SYSTEM theList->contents[roffset++].lexemeValue = CreateSymbol(theEnv,DefclassName((Defclass *) rptr->types[j])); #else theList->contents[roffset++].lexemeValue = CreateSymbol(theEnv,TypeName(theEnv,((CLIPSInteger *) rptr->types[j])->contents)); #endif } } } /* ========================================= ***************************************** INTERNALLY VISIBLE FUNCTIONS ========================================= ***************************************** */ /*************************************************** NAME : PrintGenericCall DESCRIPTION : PrintExpression() support function for generic function calls INPUTS : 1) The output logical name 2) The generic function RETURNS : Nothing useful SIDE EFFECTS : Call expression printed NOTES : None ***************************************************/ static void PrintGenericCall( Environment *theEnv, const char *logName, Defgeneric *theDefgeneric) { #if DEVELOPER WriteString(theEnv,logName,"("); WriteString(theEnv,logName,DefgenericName(theDefgeneric)); if (GetFirstArgument() != NULL) { WriteString(theEnv,logName," "); PrintExpression(theEnv,logName,GetFirstArgument()); } WriteString(theEnv,logName,")"); #else #if MAC_XCD #pragma unused(theEnv) #pragma unused(logName) #pragma unused(theDefgeneric) #endif #endif } /******************************************************* NAME : EvaluateGenericCall DESCRIPTION : Primitive support function for calling a generic function INPUTS : 1) The generic function 2) A data object buffer to hold the evaluation result RETURNS : False if the generic function returns the symbol false, true otherwise SIDE EFFECTS : Data obejct buffer set and any side-effects of calling the generic NOTES : None *******************************************************/ static bool EvaluateGenericCall( Environment *theEnv, Defgeneric *theDefgeneric, UDFValue *returnValue) { GenericDispatch(theEnv,theDefgeneric,NULL,NULL,GetFirstArgument(),returnValue); if ((returnValue->header->type == SYMBOL_TYPE) && (returnValue->value == FalseSymbol(theEnv))) return false; return true; } /*************************************************** NAME : DecrementGenericBusyCount DESCRIPTION : Lowers the busy count of a generic function construct INPUTS : The generic function RETURNS : Nothing useful SIDE EFFECTS : Busy count decremented if a clear is not in progress (see comment) NOTES : None ***************************************************/ static void DecrementGenericBusyCount( Environment *theEnv, Defgeneric *theDefgeneric) { /* ============================================== The generics to which expressions in other constructs may refer may already have been deleted - thus, it is important not to modify the busy flag during a clear. ============================================== */ if (! ConstructData(theEnv)->ClearInProgress) { theDefgeneric->busy--; } } /*************************************************** NAME : IncrementGenericBusyCount DESCRIPTION : Raises the busy count of a generic function construct INPUTS : The generic function RETURNS : Nothing useful SIDE EFFECTS : Busy count incremented NOTES : None ***************************************************/ static void IncrementGenericBusyCount( Environment *theEnv, Defgeneric *theDefgeneric) { #if MAC_XCD #pragma unused(theEnv) #endif #if (! RUN_TIME) && (! BLOAD_ONLY) if (! ConstructData(theEnv)->ParsingConstruct) { ConstructData(theEnv)->DanglingConstructs++; } #endif theDefgeneric->busy++; } #if (! BLOAD_ONLY) && (! RUN_TIME) /********************************************************************** NAME : SaveDefgenerics DESCRIPTION : Outputs pretty-print forms of generic function headers INPUTS : The logical name of the output RETURNS : Nothing useful SIDE EFFECTS : None NOTES : None **********************************************************************/ static void SaveDefgenerics( Environment *theEnv, Defmodule *theModule, const char *logName, void *context) { SaveConstruct(theEnv,theModule,logName,DefgenericData(theEnv)->DefgenericConstruct); } /********************************************************************** NAME : SaveDefmethods DESCRIPTION : Outputs pretty-print forms of generic function methods INPUTS : The logical name of the output RETURNS : Nothing useful SIDE EFFECTS : None NOTES : None **********************************************************************/ static void SaveDefmethods( Environment *theEnv, Defmodule *theModule, const char *logName, void *context) { DoForAllConstructsInModule(theEnv,theModule, SaveDefmethodsForDefgeneric, DefgenericData(theEnv)->DefgenericModuleIndex, false,(void *) logName); } /*************************************************** NAME : SaveDefmethodsForDefgeneric DESCRIPTION : Save the pretty-print forms of all methods for a generic function to a file INPUTS : 1) The defgeneric 2) The logical name of the output RETURNS : Nothing useful SIDE EFFECTS : Methods written NOTES : None ***************************************************/ static void SaveDefmethodsForDefgeneric( Environment *theEnv, ConstructHeader *theDefgeneric, void *userBuffer) { Defgeneric *gfunc = (Defgeneric *) theDefgeneric; const char *logName = (const char *) userBuffer; long i; for (i = 0 ; i < gfunc->mcnt ; i++) { if (gfunc->methods[i].header.ppForm != NULL) { WriteString(theEnv,logName,gfunc->methods[i].header.ppForm); WriteString(theEnv,logName,"\n"); } } } /**************************************************** NAME : RemoveDefgenericMethod DESCRIPTION : Removes a generic function method from the array and removes the generic too if its the last method INPUTS : 1) The generic function 2) The array index of the method RETURNS : Nothing useful SIDE EFFECTS : List adjusted Nodes deallocated NOTES : Assumes deletion is safe ****************************************************/ static void RemoveDefgenericMethod( Environment *theEnv, Defgeneric *gfunc, unsigned short gi) { Defmethod *narr; unsigned short b,e; if (gfunc->methods[gi].system) { SetEvaluationError(theEnv,true); PrintErrorID(theEnv,"GENRCCOM",4,false); WriteString(theEnv,STDERR,"Cannot remove implicit system function method for generic function '"); WriteString(theEnv,STDERR,DefgenericName(gfunc)); WriteString(theEnv,STDERR,"'.\n"); return; } DeleteMethodInfo(theEnv,gfunc,&gfunc->methods[gi]); if (gfunc->mcnt == 1) { rm(theEnv,gfunc->methods,sizeof(Defmethod)); gfunc->mcnt = 0; gfunc->methods = NULL; } else { gfunc->mcnt--; narr = (Defmethod *) gm2(theEnv,(sizeof(Defmethod) * gfunc->mcnt)); for (b = e = 0 ; b < gfunc->mcnt ; b++ , e++) { if (b == gi) e++; GenCopyMemory(Defmethod,1,&narr[b],&gfunc->methods[e]); } rm(theEnv,gfunc->methods,(sizeof(Defmethod) * (gfunc->mcnt+1))); gfunc->methods = narr; } } #endif #if DEBUGGING_FUNCTIONS /****************************************************** NAME : ListMethodsForGeneric DESCRIPTION : Lists a brief description of methods for a particular generic function INPUTS : 1) The logical name of the output 2) Generic function to list methods for RETURNS : The number of methods printed SIDE EFFECTS : None NOTES : None ******************************************************/ static unsigned short ListMethodsForGeneric( Environment *theEnv, const char *logicalName, Defgeneric *gfunc) { unsigned short gi; StringBuilder *theSB; theSB = CreateStringBuilder(theEnv,256); for (gi = 0 ; gi < gfunc->mcnt ; gi++) { WriteString(theEnv,logicalName,DefgenericName(gfunc)); WriteString(theEnv,logicalName," #"); PrintMethod(theEnv,&gfunc->methods[gi],theSB); WriteString(theEnv,logicalName,theSB->contents); WriteString(theEnv,logicalName,"\n"); } SBDispose(theSB); return gfunc->mcnt; } /****************************************************************** NAME : DefgenericWatchAccess DESCRIPTION : Parses a list of generic names passed by AddWatchItem() and sets the traces accordingly INPUTS : 1) A code indicating which trace flag is to be set Ignored 2) The value to which to set the trace flags 3) A list of expressions containing the names of the generics for which to set traces RETURNS : True if all OK, false otherwise SIDE EFFECTS : Watch flags set in specified generics NOTES : Accessory function for AddWatchItem() ******************************************************************/ static bool DefgenericWatchAccess( Environment *theEnv, int code, bool newState, Expression *argExprs) { #if MAC_XCD #pragma unused(code) #endif return(ConstructSetWatchAccess(theEnv,DefgenericData(theEnv)->DefgenericConstruct,newState,argExprs, (ConstructGetWatchFunction *) DefgenericGetWatch, (ConstructSetWatchFunction *) DefgenericSetWatch)); } /*********************************************************************** NAME : DefgenericWatchPrint DESCRIPTION : Parses a list of generic names passed by AddWatchItem() and displays the traces accordingly INPUTS : 1) The logical name of the output 2) A code indicating which trace flag is to be examined Ignored 3) A list of expressions containing the names of the generics for which to examine traces RETURNS : True if all OK, false otherwise SIDE EFFECTS : Watch flags displayed for specified generics NOTES : Accessory function for AddWatchItem() ***********************************************************************/ static bool DefgenericWatchPrint( Environment *theEnv, const char *logName, int code, Expression *argExprs) { #if MAC_XCD #pragma unused(code) #endif return(ConstructPrintWatchAccess(theEnv,DefgenericData(theEnv)->DefgenericConstruct,logName,argExprs, (ConstructGetWatchFunction *) DefgenericGetWatch, (ConstructSetWatchFunction *) DefgenericSetWatch)); } /****************************************************************** NAME : DefmethodWatchAccess DESCRIPTION : Parses a list of methods passed by AddWatchItem() and sets the traces accordingly INPUTS : 1) A code indicating which trace flag is to be set Ignored 2) The value to which to set the trace flags 3) A list of expressions containing the methods for which to set traces RETURNS : True if all OK, false otherwise SIDE EFFECTS : Watch flags set in specified methods NOTES : Accessory function for AddWatchItem() ******************************************************************/ static bool DefmethodWatchAccess( Environment *theEnv, int code, bool newState, Expression *argExprs) { #if MAC_XCD #pragma unused(code) #endif if (newState) return(DefmethodWatchSupport(theEnv,"watch",NULL,newState,NULL,DefmethodSetWatch,argExprs)); else return(DefmethodWatchSupport(theEnv,"unwatch",NULL,newState,NULL,DefmethodSetWatch,argExprs)); } /*********************************************************************** NAME : DefmethodWatchPrint DESCRIPTION : Parses a list of methods passed by AddWatchItem() and displays the traces accordingly INPUTS : 1) The logical name of the output 2) A code indicating which trace flag is to be examined Ignored 3) A list of expressions containing the methods for which to examine traces RETURNS : True if all OK, false otherwise SIDE EFFECTS : Watch flags displayed for specified methods NOTES : Accessory function for AddWatchItem() ***********************************************************************/ static bool DefmethodWatchPrint( Environment *theEnv, const char *logName, int code, Expression *argExprs) { #if MAC_XCD #pragma unused(code) #endif return(DefmethodWatchSupport(theEnv,"list-watch-items",logName,0, PrintMethodWatchFlag,NULL,argExprs)); } /******************************************************* NAME : DefmethodWatchSupport DESCRIPTION : Sets or displays methods specified INPUTS : 1) The calling function name 2) The logical output name for displays (can be NULL) 3) The new set state 4) The print function (can be NULL) 5) The trace function (can be NULL) 6) The methods expression list RETURNS : True if all OK, false otherwise SIDE EFFECTS : Method trace flags set or displayed NOTES : None *******************************************************/ static bool DefmethodWatchSupport( Environment *theEnv, const char *funcName, const char *logName, bool newState, void (*printFunc)(Environment *,const char *,Defgeneric *,unsigned short), void (*traceFunc)(Defgeneric *,unsigned short,bool), Expression *argExprs) { Defgeneric *theGeneric = NULL; unsigned short theMethod = 0; unsigned int argIndex = 2; UDFValue genericName, methodIndex; Defmodule *theModule; /* ============================== If no methods are specified, show the trace for all methods in all generics ============================== */ if (argExprs == NULL) { SaveCurrentModule(theEnv); theModule = GetNextDefmodule(theEnv,NULL); while (theModule != NULL) { SetCurrentModule(theEnv,theModule); if (traceFunc == NULL) { WriteString(theEnv,logName,DefmoduleName(theModule)); WriteString(theEnv,logName,":\n"); } theGeneric = GetNextDefgeneric(theEnv,NULL); while (theGeneric != NULL) { theMethod = GetNextDefmethod(theGeneric,0); while (theMethod != 0) { if (traceFunc != NULL) (*traceFunc)(theGeneric,theMethod,newState); else { WriteString(theEnv,logName," "); (*printFunc)(theEnv,logName,theGeneric,theMethod); } theMethod = GetNextDefmethod(theGeneric,theMethod); } theGeneric = GetNextDefgeneric(theEnv,theGeneric); } theModule = GetNextDefmodule(theEnv,theModule); } RestoreCurrentModule(theEnv); return true; } /* ========================================= Set the traces for every method specified ========================================= */ while (argExprs != NULL) { if (EvaluateExpression(theEnv,argExprs,&genericName)) return false; if ((genericName.header->type != SYMBOL_TYPE) ? true : ((theGeneric = LookupDefgenericByMdlOrScope(theEnv,genericName.lexemeValue->contents)) == NULL)) { ExpectedTypeError1(theEnv,funcName,argIndex,"'generic function name'"); return false; } if (GetNextArgument(argExprs) == NULL) theMethod = 0; else { argExprs = GetNextArgument(argExprs); argIndex++; if (EvaluateExpression(theEnv,argExprs,&methodIndex)) return false; if ((methodIndex.header->type != INTEGER_TYPE) ? false : ((methodIndex.integerValue->contents <= 0) ? false : (FindMethodByIndex(theGeneric,theMethod) != METHOD_NOT_FOUND))) theMethod = (unsigned short) methodIndex.integerValue->contents; else { ExpectedTypeError1(theEnv,funcName,argIndex,"'method index'"); return false; } } if (theMethod == 0) { theMethod = GetNextDefmethod(theGeneric,0); while (theMethod != 0) { if (traceFunc != NULL) (*traceFunc)(theGeneric,theMethod,newState); else (*printFunc)(theEnv,logName,theGeneric,theMethod); theMethod = GetNextDefmethod(theGeneric,theMethod); } } else { if (traceFunc != NULL) (*traceFunc)(theGeneric,theMethod,newState); else (*printFunc)(theEnv,logName,theGeneric,theMethod); } argExprs = GetNextArgument(argExprs); argIndex++; } return true; } /*************************************************** NAME : PrintMethodWatchFlag DESCRIPTION : Displays trace value for method INPUTS : 1) The logical name of the output 2) The generic function 3) The method index RETURNS : Nothing useful SIDE EFFECTS : None NOTES : None ***************************************************/ static void PrintMethodWatchFlag( Environment *theEnv, const char *logName, Defgeneric *theGeneric, unsigned short theMethod) { StringBuilder *theSB = CreateStringBuilder(theEnv,60); WriteString(theEnv,logName,DefgenericName(theGeneric)); WriteString(theEnv,logName," "); DefmethodDescription(theGeneric,theMethod,theSB); WriteString(theEnv,logName,theSB->contents); if (DefmethodGetWatch(theGeneric,theMethod)) WriteString(theEnv,logName," = on\n"); else WriteString(theEnv,logName," = off\n"); SBDispose(theSB); } #endif #if ! OBJECT_SYSTEM /*************************************************** NAME : TypeCommand DESCRIPTION : Works like "class" in COOL INPUTS : None RETURNS : Nothing useful SIDE EFFECTS : None NOTES : H/L Syntax: (type ) ***************************************************/ void TypeCommand( Environment *theEnv, UDFContext *context, UDFValue *returnValue) { UDFValue result; EvaluateExpression(theEnv,GetFirstArgument(),&result); returnValue->lexemeValue = CreateSymbol(theEnv,TypeName(theEnv,result.header->type)); } #endif /*#############################*/ /* Additional Access Functions */ /*#############################*/ void SetNextDefgeneric( Defgeneric *theDefgeneric, Defgeneric *targetDefgeneric) { SetNextConstruct(&theDefgeneric->header, &targetDefgeneric->header); } /*##################################*/ /* Additional Environment Functions */ /*##################################*/ const char *DefgenericModule( Defgeneric *theDefgeneric) { return GetConstructModuleName(&theDefgeneric->header); } const char *DefgenericName( Defgeneric *theDefgeneric) { return GetConstructNameString(&theDefgeneric->header); } const char *DefgenericPPForm( Defgeneric *theDefgeneric) { return GetConstructPPForm(&theDefgeneric->header); } CLIPSLexeme *GetDefgenericNamePointer( Defgeneric *theDefgeneric) { return GetConstructNamePointer(&theDefgeneric->header); } void SetDefgenericPPForm( Environment *theEnv, Defgeneric *theDefgeneric, const char *thePPForm) { SetConstructPPForm(theEnv,&theDefgeneric->header,thePPForm); } #endif /* DEFGENERIC_CONSTRUCT */