/*************************************************************** NAME : CheckHandlerArgCount DESCRIPTION : Verifies that the current argument list satisfies the current handler's parameter count restriction INPUTS : None RETURNS : TRUE if all OK, FALSE otherwise SIDE EFFECTS : EvaluationError set on errors NOTES : Uses ProcParamArraySize and CurrentCore globals ***************************************************************/ globle int CheckHandlerArgCount( void *theEnv, EXEC_STATUS) { HANDLER *hnd; hnd = MessageHandlerData(theEnv,execStatus)->CurrentCore->hnd; if ((hnd->maxParams == -1) ? (ProceduralPrimitiveData(theEnv,execStatus)->ProcParamArraySize < hnd->minParams) : (ProceduralPrimitiveData(theEnv,execStatus)->ProcParamArraySize != hnd->minParams)) { SetEvaluationError(theEnv,execStatus,TRUE); PrintErrorID(theEnv,execStatus,"MSGFUN",2,FALSE); EnvPrintRouter(theEnv,execStatus,WERROR,"Message-handler "); EnvPrintRouter(theEnv,execStatus,WERROR,ValueToString(hnd->name)); EnvPrintRouter(theEnv,execStatus,WERROR," "); EnvPrintRouter(theEnv,execStatus,WERROR,MessageHandlerData(theEnv,execStatus)->hndquals[hnd->type]); EnvPrintRouter(theEnv,execStatus,WERROR," in class "); EnvPrintRouter(theEnv,execStatus,WERROR,EnvGetDefclassName(theEnv,execStatus,(void *) hnd->cls)); EnvPrintRouter(theEnv,execStatus,WERROR," expected "); if (hnd->maxParams == -1) EnvPrintRouter(theEnv,execStatus,WERROR,"at least "); else EnvPrintRouter(theEnv,execStatus,WERROR,"exactly "); PrintLongInteger(theEnv,execStatus,WERROR,(long long) (hnd->minParams-1)); EnvPrintRouter(theEnv,execStatus,WERROR," argument(s).\n"); return(FALSE); } return(TRUE); }
globle void PrintMethod( void *theEnv, EXEC_STATUS, char *buf, int buflen, DEFMETHOD *meth) { #if MAC_MCW || WIN_MCW || MAC_XCD #pragma unused(theEnv,execStatus) #endif long j,k; register RESTRICTION *rptr; char numbuf[15]; buf[0] = '\0'; if (meth->system) genstrncpy(buf,"SYS",(STD_SIZE) buflen); gensprintf(numbuf,"%-2d ",meth->index); genstrncat(buf,numbuf,(STD_SIZE) buflen-3); for (j = 0 ; j < meth->restrictionCount ; j++) { rptr = &meth->restrictions[j]; if ((((int) j) == meth->restrictionCount-1) && (meth->maxRestrictions == -1)) { if ((rptr->tcnt == 0) && (rptr->query == NULL)) { genstrncat(buf,"$?",buflen-strlen(buf)); break; } genstrncat(buf,"($? ",buflen-strlen(buf)); } else genstrncat(buf,"(",buflen-strlen(buf)); for (k = 0 ; k < rptr->tcnt ; k++) { #if OBJECT_SYSTEM genstrncat(buf,EnvGetDefclassName(theEnv,execStatus,rptr->types[k]),buflen-strlen(buf)); #else genstrncat(buf,TypeName(theEnv,execStatus,ValueToInteger(rptr->types[k])),buflen-strlen(buf)); #endif if (((int) k) < (((int) rptr->tcnt) - 1)) genstrncat(buf," ",buflen-strlen(buf)); } if (rptr->query != NULL) { if (rptr->tcnt != 0) genstrncat(buf," ",buflen-strlen(buf)); genstrncat(buf,"<qry>",buflen-strlen(buf)); } genstrncat(buf,")",buflen-strlen(buf)); if (((int) j) != (((int) meth->restrictionCount)-1)) genstrncat(buf," ",buflen-strlen(buf)); } }
/*************************************************** NAME : PrintHandlerWatchFlag DESCRIPTION : Displays trace value for handler INPUTS : 1) The logical name of the output 2) The class 3) The handler index RETURNS : Nothing useful SIDE EFFECTS : None NOTES : None ***************************************************/ static void PrintHandlerWatchFlag( void *theEnv, char *logName, void *theClass, unsigned theHandler) { EnvPrintRouter(theEnv,logName,EnvGetDefclassName(theEnv,theClass)); EnvPrintRouter(theEnv,logName," "); EnvPrintRouter(theEnv,logName,EnvGetDefmessageHandlerName(theEnv,theClass,theHandler)); EnvPrintRouter(theEnv,logName," "); EnvPrintRouter(theEnv,logName,EnvGetDefmessageHandlerType(theEnv,theClass,theHandler)); EnvPrintRouter(theEnv,logName,(char *) (EnvGetDefmessageHandlerWatch(theEnv,theClass,theHandler) ? " = on\n" : " = off\n")); }
/*********************************************************** NAME : EnvUndefmessageHandler DESCRIPTION : Deletes a handler from a class INPUTS : 1) Class address (Can be NULL) 2) Handler index (can be 0) RETURNS : 1 if successful, 0 otherwise SIDE EFFECTS : Handler deleted if possible NOTES : None ***********************************************************/ globle int EnvUndefmessageHandler( void *theEnv, void *vptr, unsigned mhi) { #if (MAC_MCW || IBM_MCW) && (RUN_TIME || BLOAD_ONLY) #pragma unused(vptr) #pragma unused(mhi) #endif #if RUN_TIME || BLOAD_ONLY PrintErrorID(theEnv,"MSGCOM",3,FALSE); EnvPrintRouter(theEnv,WERROR,"Unable to delete message-handlers.\n"); return(0); #else DEFCLASS *cls; #if BLOAD || BLOAD_AND_BSAVE if (Bloaded(theEnv)) { PrintErrorID(theEnv,"MSGCOM",3,FALSE); EnvPrintRouter(theEnv,WERROR,"Unable to delete message-handlers.\n"); return(0); } #endif if (vptr == NULL) { if (mhi != 0) { PrintErrorID(theEnv,"MSGCOM",1,FALSE); EnvPrintRouter(theEnv,WERROR,"Incomplete message-handler specification for deletion.\n"); return(0); } return(WildDeleteHandler(theEnv,NULL,NULL,NULL)); } if (mhi == 0) return(WildDeleteHandler(theEnv,(DEFCLASS *) vptr,NULL,NULL)); cls = (DEFCLASS *) vptr; if (HandlersExecuting(cls)) { HandlerDeleteError(theEnv,EnvGetDefclassName(theEnv,(void *) cls)); return(0); } cls->handlers[mhi-1].mark = 1; DeallocateMarkedHandlers(theEnv,cls); return(1); #endif }
/**************************************************************** NAME : PrintClassBrowse DESCRIPTION : Displays a "graph" of class and subclasses INPUTS : 1) The logical name of the output 2) The class address 3) The depth of the graph RETURNS : Nothing useful SIDE EFFECTS : None NOTES : None ****************************************************************/ static void PrintClassBrowse( void *theEnv, char *logicalName, DEFCLASS *cls, long depth) { long i; for (i = 0 ; i < depth ; i++) EnvPrintRouter(theEnv,logicalName," "); EnvPrintRouter(theEnv,logicalName,EnvGetDefclassName(theEnv,(void *) cls)); if (cls->directSuperclasses.classCount > 1) EnvPrintRouter(theEnv,logicalName," *"); EnvPrintRouter(theEnv,logicalName,"\n"); for (i = 0 ;i < cls->directSubclasses.classCount ; i++) PrintClassBrowse(theEnv,logicalName,cls->directSubclasses.classArray[i],depth+1); }
/*************************************************** NAME : PrintHandlerWatchFlag DESCRIPTION : Displays trace value for handler INPUTS : 1) The logical name of the output 2) The class 3) The handler index RETURNS : Nothing useful SIDE EFFECTS : None NOTES : None ***************************************************/ static void PrintHandlerWatchFlag( void *theEnv, const char *logName, void *theClass, int theHandler) { EnvPrintRouter(theEnv,logName,EnvGetDefclassName(theEnv,theClass)); EnvPrintRouter(theEnv,logName," "); EnvPrintRouter(theEnv,logName,EnvGetDefmessageHandlerName(theEnv,theClass,theHandler)); EnvPrintRouter(theEnv,logName," "); EnvPrintRouter(theEnv,logName,EnvGetDefmessageHandlerType(theEnv,theClass,theHandler)); if (EnvGetDefmessageHandlerWatch(theEnv,theClass,theHandler)) EnvPrintRouter(theEnv,logName," = on\n"); else EnvPrintRouter(theEnv,logName," = off\n"); }
/*********************************************************** NAME : ValidClassName DESCRIPTION : Determines if a new class of the given name can be defined in the current module INPUTS : 1) The new class name 2) Buffer to hold class address RETURNS : TRUE if OK, FALSE otherwise SIDE EFFECTS : Error message printed if not OK NOTES : GetConstructNameAndComment() (called before this function) ensures that the defclass name does not conflict with one from another module ***********************************************************/ static intBool ValidClassName( void *theEnv, char *theClassName, DEFCLASS **theDefclass) { *theDefclass = (DEFCLASS *) EnvFindDefclass(theEnv,theClassName); if (*theDefclass != NULL) { /* =================================== System classes (which are visible in all modules) cannot be redefined =================================== */ if ((*theDefclass)->system) { PrintErrorID(theEnv,"CLASSPSR",2,FALSE); EnvPrintRouter(theEnv,WERROR,"Cannot redefine a predefined system class.\n"); return(FALSE); } /* =============================================== A class in the current module can only be redefined if it is not in use, e.g., instances, generic function method restrictions, etc. =============================================== */ if ((EnvIsDefclassDeletable(theEnv,(void *) *theDefclass) == FALSE) && (! ConstructData(theEnv)->CheckSyntaxMode)) { PrintErrorID(theEnv,"CLASSPSR",3,FALSE); EnvPrintRouter(theEnv,WERROR,EnvGetDefclassName(theEnv,(void *) *theDefclass)); EnvPrintRouter(theEnv,WERROR," class cannot be redefined while\n"); EnvPrintRouter(theEnv,WERROR," outstanding references to it still exist.\n"); return(FALSE); } } return(TRUE); }
static void OutputConstructsCodeInfo( void *theEnv) { #if (! DEFFUNCTION_CONSTRUCT) && (! DEFGENERIC_CONSTRUCT) && (! OBJECT_SYSTEM) && (! DEFRULE_CONSTRUCT) #pragma unused(theEnv) #endif #if DEFFUNCTION_CONSTRUCT DEFFUNCTION *theDeffunction; #endif #if DEFRULE_CONSTRUCT struct defrule *theDefrule; #endif #if DEFGENERIC_CONSTRUCT DEFGENERIC *theDefgeneric; DEFMETHOD *theMethod; unsigned methodIndex; char methodBuffer[512]; #endif #if OBJECT_SYSTEM DEFCLASS *theDefclass; HANDLER *theHandler; unsigned handlerIndex; #endif #if DEFGENERIC_CONSTRUCT || OBJECT_SYSTEM char *prefix, *prefixBefore, *prefixAfter; #endif char *banner; banner = "\n*** Deffunctions ***\n\n"; #if DEFFUNCTION_CONSTRUCT for (theDeffunction = (DEFFUNCTION *) EnvGetNextDeffunction(theEnv,NULL); theDeffunction != NULL; theDeffunction = (DEFFUNCTION *) EnvGetNextDeffunction(theEnv,theDeffunction)) { OutputProfileInfo(theEnv,EnvGetDeffunctionName(theEnv,theDeffunction), (struct constructProfileInfo *) TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theDeffunction->header.usrData), NULL,NULL,NULL,&banner); } #endif banner = "\n*** Defgenerics ***\n"; #if DEFGENERIC_CONSTRUCT for (theDefgeneric = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,NULL); theDefgeneric != NULL; theDefgeneric = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,theDefgeneric)) { prefixBefore = "\n"; prefix = EnvGetDefgenericName(theEnv,theDefgeneric); prefixAfter = "\n"; for (methodIndex = EnvGetNextDefmethod(theEnv,theDefgeneric,0); methodIndex != 0; methodIndex = EnvGetNextDefmethod(theEnv,theDefgeneric,methodIndex)) { theMethod = GetDefmethodPointer(theDefgeneric,methodIndex); EnvGetDefmethodDescription(theEnv,methodBuffer,510,theDefgeneric,methodIndex); if (OutputProfileInfo(theEnv,methodBuffer, (struct constructProfileInfo *) TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theMethod->usrData), prefixBefore,prefix,prefixAfter,&banner)) { prefixBefore = NULL; prefix = NULL; prefixAfter = NULL; } } } #endif banner = "\n*** Defclasses ***\n"; #if OBJECT_SYSTEM for (theDefclass = (DEFCLASS *) EnvGetNextDefclass(theEnv,NULL); theDefclass != NULL; theDefclass = (DEFCLASS *) EnvGetNextDefclass(theEnv,theDefclass)) { prefixAfter = "\n"; prefix = EnvGetDefclassName(theEnv,theDefclass); prefixBefore = "\n"; for (handlerIndex = EnvGetNextDefmessageHandler(theEnv,theDefclass,0); handlerIndex != 0; handlerIndex = EnvGetNextDefmessageHandler(theEnv,theDefclass,handlerIndex)) { theHandler = GetDefmessageHandlerPointer(theDefclass,handlerIndex); if (OutputProfileInfo(theEnv,EnvGetDefmessageHandlerName(theEnv,theDefclass,handlerIndex), (struct constructProfileInfo *) TestUserData(ProfileFunctionData(theEnv)->ProfileDataID, theHandler->usrData), prefixBefore,prefix,prefixAfter,&banner)) { prefixBefore = NULL; prefix = NULL; prefixAfter = NULL; } } } #endif banner = "\n*** Defrules ***\n\n"; #if DEFRULE_CONSTRUCT for (theDefrule = (struct defrule *) EnvGetNextDefrule(theEnv,NULL); theDefrule != NULL; theDefrule = (struct defrule *) EnvGetNextDefrule(theEnv,theDefrule)) { OutputProfileInfo(theEnv,EnvGetDefruleName(theEnv,theDefrule), (struct constructProfileInfo *) TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theDefrule->header.usrData), NULL,NULL,NULL,&banner); } #endif }
/***************************************************************************** NAME : AddClass DESCRIPTION : Determines the precedence list of the new class. If it is valid, the routine checks to see if the class already exists. If it does not, all the subclass links are made from the class's direct superclasses, and the class is inserted in the hash table. If it does, all sublclasses are deleted. An error will occur if any instances of the class (direct or indirect) exist. If all checks out, the old definition is replaced by the new. INPUTS : The new class description RETURNS : Nothing useful SIDE EFFECTS : The class is deleted if there is an error. NOTES : No change in the class graph state will occur if there were any errors. Assumes class is not busy!!! *****************************************************************************/ static void AddClass( void *theEnv, DEFCLASS *cls) { DEFCLASS *ctmp; #if DEBUGGING_FUNCTIONS int oldTraceInstances = FALSE, oldTraceSlots = FALSE; #endif /* =============================================== If class does not already exist, insert and form progeny links with all direct superclasses =============================================== */ cls->hashTableIndex = HashClass(GetDefclassNamePointer((void *) cls)); ctmp = (DEFCLASS *) EnvFindDefclass(theEnv,EnvGetDefclassName(theEnv,(void *) cls)); if (ctmp != NULL) { #if DEBUGGING_FUNCTIONS oldTraceInstances = ctmp->traceInstances; oldTraceSlots = ctmp->traceSlots; #endif DeleteClassUAG(theEnv,ctmp); } PutClassInTable(theEnv,cls); BuildSubclassLinks(theEnv,cls); InstallClass(theEnv,cls,TRUE); AddConstructToModule((struct constructHeader *) cls); FormInstanceTemplate(theEnv,cls); FormSlotNameMap(theEnv,cls); AssignClassID(theEnv,cls); #if DEBUGGING_FUNCTIONS if (cls->abstract) { cls->traceInstances = FALSE; cls->traceSlots = FALSE; } else { if (oldTraceInstances) cls->traceInstances = TRUE; if (oldTraceSlots) cls->traceSlots = TRUE; } #endif #if DEBUGGING_FUNCTIONS if (EnvGetConserveMemory(theEnv) == FALSE) SetDefclassPPForm((void *) cls,CopyPPBuffer(theEnv)); #endif #if DEFMODULE_CONSTRUCT /* ========================================= Create a bitmap indicating whether this class is in scope or not for every module ========================================= */ cls->scopeMap = (BITMAP_HN *) CreateClassScopeMap(theEnv,cls); #endif /* ============================================== Define get- and put- handlers for public slots ============================================== */ CreatePublicSlotMessageHandlers(theEnv,cls); }
globle const char *GetDefclassName( void *theClass) { return EnvGetDefclassName(GetCurrentEnvironment(),theClass); }
/********************************************************** NAME : PrintOPNLevel DESCRIPTION : Recursivley prints object pattern network INPUTS : 1) The current object pattern network node 2) A buffer holding preceding indentation text showing the level in the tree 3) The length of the indentation text RETURNS : Nothing useful SIDE EFFECTS : Pattern nodes recursively printed NOTES : None **********************************************************/ static void PrintOPNLevel( void *theEnv, OBJECT_PATTERN_NODE *pptr, char *indentbuf, int ilen) { CLASS_BITMAP *cbmp; SLOT_BITMAP *sbmp; register unsigned i; OBJECT_PATTERN_NODE *uptr; OBJECT_ALPHA_NODE *alphaPtr; while (pptr != NULL) { EnvPrintRouter(theEnv,WDISPLAY,indentbuf); if (pptr->alphaNode != NULL) EnvPrintRouter(theEnv,WDISPLAY,"+"); EnvPrintRouter(theEnv,WDISPLAY,ValueToString(FindIDSlotName(theEnv,pptr->slotNameID))); EnvPrintRouter(theEnv,WDISPLAY," ("); PrintLongInteger(theEnv,WDISPLAY,(long) pptr->slotNameID); EnvPrintRouter(theEnv,WDISPLAY,") "); EnvPrintRouter(theEnv,WDISPLAY,pptr->endSlot ? "EPF#" : "PF#"); PrintLongInteger(theEnv,WDISPLAY,(long) pptr->whichField); EnvPrintRouter(theEnv,WDISPLAY," "); EnvPrintRouter(theEnv,WDISPLAY,pptr->multifieldNode ? "$? " : "? "); if (pptr->networkTest != NULL) PrintExpression(theEnv,WDISPLAY,pptr->networkTest); EnvPrintRouter(theEnv,WDISPLAY,"\n"); alphaPtr = pptr->alphaNode; while (alphaPtr != NULL) { EnvPrintRouter(theEnv,WDISPLAY,indentbuf); EnvPrintRouter(theEnv,WDISPLAY," Classes:"); cbmp = (CLASS_BITMAP *) ValueToBitMap(alphaPtr->classbmp); for (i = 0 ; i <= cbmp->maxid ; i++) if (TestBitMap(cbmp->map,i)) { EnvPrintRouter(theEnv,WDISPLAY," "); EnvPrintRouter(theEnv,WDISPLAY,EnvGetDefclassName(theEnv,(void *) DefclassData(theEnv)->ClassIDMap[i])); } if (alphaPtr->slotbmp != NULL) { sbmp = (SLOT_BITMAP *) ValueToBitMap(pptr->alphaNode->slotbmp); EnvPrintRouter(theEnv,WDISPLAY," *** Slots:"); for (i = NAME_ID ; i <= sbmp->maxid ; i++) if (TestBitMap(sbmp->map,i)) { for (uptr = pptr ; uptr != NULL ; uptr = uptr->lastLevel) if (uptr->slotNameID == i) break; if (uptr == NULL) { EnvPrintRouter(theEnv,WDISPLAY," "); EnvPrintRouter(theEnv,WDISPLAY,ValueToString(FindIDSlotName(theEnv,i))); } } } EnvPrintRouter(theEnv,WDISPLAY,"\n"); alphaPtr = alphaPtr->nxtInGroup; } indentbuf[ilen++] = (char) ((pptr->rightNode != NULL) ? '|' : ' '); indentbuf[ilen++] = ' '; indentbuf[ilen++] = ' '; indentbuf[ilen] = '\0'; PrintOPNLevel(theEnv,pptr->nextLevel,indentbuf,ilen); ilen -= 3; indentbuf[ilen] = '\0'; pptr = pptr->rightNode; } }
/********************************************************************* NAME : DeleteHandler DESCRIPTION : Deletes one or more message-handlers from a class definition INPUTS : 1) The class address 2) The message-handler name (if this is * and there is no handler called *, then the delete operations will be applied to all handlers matching the type 3) The message-handler type (if this is -1, then the delete operations will be applied to all handlers matching the name 4) A flag saying whether to print error messages when handlers are not found meeting specs RETURNS : 1 if successful, 0 otherwise SIDE EFFECTS : Handlers deleted NOTES : If any handlers for the class are currently executing, this routine will fail **********************************************************************/ globle int DeleteHandler( void *theEnv, EXEC_STATUS, DEFCLASS *cls, SYMBOL_HN *mname, int mtype, int indicate_missing) { long i; HANDLER *hnd; int found,success = 1; if (cls->handlerCount == 0) { if (indicate_missing) { HandlerDeleteError(theEnv,execStatus,EnvGetDefclassName(theEnv,execStatus,(void *) cls)); return(0); } return(1); } if (HandlersExecuting(cls)) { HandlerDeleteError(theEnv,execStatus,EnvGetDefclassName(theEnv,execStatus,(void *) cls)); return(0); } if (mtype == -1) { found = FALSE; for (i = MAROUND ; i <= MAFTER ; i++) { hnd = FindHandlerByAddress(cls,mname,(unsigned) i); if (hnd != NULL) { found = TRUE; if (hnd->system == 0) hnd->mark = 1; else { PrintErrorID(theEnv,execStatus,"MSGPSR",3,FALSE); EnvPrintRouter(theEnv,execStatus,WERROR,"System message-handlers may not be modified.\n"); success = 0; } } } if ((found == FALSE) ? (strcmp(ValueToString(mname),"*") == 0) : FALSE) { for (i = 0 ; i < cls->handlerCount ; i++) if (cls->handlers[i].system == 0) cls->handlers[i].mark = 1; } } else { hnd = FindHandlerByAddress(cls,mname,(unsigned) mtype); if (hnd == NULL) { if (strcmp(ValueToString(mname),"*") == 0) { for (i = 0 ; i < cls->handlerCount ; i++) if ((cls->handlers[i].type == (unsigned) mtype) && (cls->handlers[i].system == 0)) cls->handlers[i].mark = 1; } else { if (indicate_missing) HandlerDeleteError(theEnv,execStatus,EnvGetDefclassName(theEnv,execStatus,(void *) cls)); success = 0; } } else if (hnd->system == 0) hnd->mark = 1; else { if (indicate_missing) { PrintErrorID(theEnv,execStatus,"MSGPSR",3,FALSE); EnvPrintRouter(theEnv,execStatus,WERROR,"System message-handlers may not be modified.\n"); } success = 0; } } DeallocateMarkedHandlers(theEnv,execStatus,cls); return(success); }
/*********************************************************************** NAME : ParseDefmessageHandler DESCRIPTION : Parses a message-handler for a class of objects INPUTS : The logical name of the input source RETURNS : FALSE if successful parse, TRUE otherwise SIDE EFFECTS : Handler allocated and inserted into class NOTES : H/L Syntax: (defmessage-handler <class> <name> [<type>] [<comment>] (<params>) <action>*) <params> ::= <var>* | <var>* $?<name> ***********************************************************************/ globle int ParseDefmessageHandler( void *theEnv, char *readSource) { DEFCLASS *cls; SYMBOL_HN *cname,*mname,*wildcard; unsigned mtype = MPRIMARY; int min,max,error,lvars; EXPRESSION *hndParams,*actions; HANDLER *hnd; SetPPBufferStatus(theEnv,ON); FlushPPBuffer(theEnv); SetIndentDepth(theEnv,3); SavePPBuffer(theEnv,"(defmessage-handler "); #if BLOAD || BLOAD_AND_BSAVE if ((Bloaded(theEnv)) && (! ConstructData(theEnv)->CheckSyntaxMode)) { CannotLoadWithBloadMessage(theEnv,"defmessage-handler"); return(TRUE); } #endif cname = GetConstructNameAndComment(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken,"defmessage-handler", NULL,NULL,"~",TRUE,FALSE,DEFMODULE_CONSTRUCT); if (cname == NULL) return(TRUE); cls = LookupDefclassByMdlOrScope(theEnv,ValueToString(cname)); if (cls == NULL) { PrintErrorID(theEnv,"MSGPSR",1,FALSE); EnvPrintRouter(theEnv,WERROR,"A class must be defined before its message-handlers.\n"); return(TRUE); } if ((cls == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME]) || (cls == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_ADDRESS]) || (cls == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME]->directSuperclasses.classArray[0])) { PrintErrorID(theEnv,"MSGPSR",8,FALSE); EnvPrintRouter(theEnv,WERROR,"Message-handlers cannot be attached to the class "); EnvPrintRouter(theEnv,WERROR,EnvGetDefclassName(theEnv,(void *) cls)); EnvPrintRouter(theEnv,WERROR,".\n"); return(TRUE); } if (HandlersExecuting(cls)) { PrintErrorID(theEnv,"MSGPSR",2,FALSE); EnvPrintRouter(theEnv,WERROR,"Cannot (re)define message-handlers during execution of \n"); EnvPrintRouter(theEnv,WERROR," other message-handlers for the same class.\n"); return(TRUE); } if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL) { SyntaxErrorMessage(theEnv,"defmessage-handler"); return(TRUE); } PPBackup(theEnv); PPBackup(theEnv); SavePPBuffer(theEnv," "); SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm); SavePPBuffer(theEnv," "); mname = (SYMBOL_HN *) GetValue(DefclassData(theEnv)->ObjectParseToken); GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken); if (GetType(DefclassData(theEnv)->ObjectParseToken) != LPAREN) { SavePPBuffer(theEnv," "); if (GetType(DefclassData(theEnv)->ObjectParseToken) != STRING) { if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL) { SyntaxErrorMessage(theEnv,"defmessage-handler"); return(TRUE); } mtype = HandlerType(theEnv,"defmessage-handler",DOToString(DefclassData(theEnv)->ObjectParseToken)); if (mtype == MERROR) return(TRUE); #if ! IMPERATIVE_MESSAGE_HANDLERS if (mtype == MAROUND) return(TRUE); #endif GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken); if (GetType(DefclassData(theEnv)->ObjectParseToken) == STRING) { SavePPBuffer(theEnv," "); GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken); } } else { SavePPBuffer(theEnv," "); GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken); } } PPBackup(theEnv); PPBackup(theEnv); PPCRAndIndent(theEnv); SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm); hnd = FindHandlerByAddress(cls,mname,mtype); if (GetPrintWhileLoading(theEnv) && GetCompilationsWatch(theEnv)) { EnvPrintRouter(theEnv,WDIALOG," Handler "); EnvPrintRouter(theEnv,WDIALOG,ValueToString(mname)); EnvPrintRouter(theEnv,WDIALOG," "); EnvPrintRouter(theEnv,WDIALOG,MessageHandlerData(theEnv)->hndquals[mtype]); EnvPrintRouter(theEnv,WDIALOG,(char *) ((hnd == NULL) ? " defined.\n" : " redefined.\n")); } if ((hnd != NULL) ? hnd->system : FALSE) { PrintErrorID(theEnv,"MSGPSR",3,FALSE); EnvPrintRouter(theEnv,WERROR,"System message-handlers may not be modified.\n"); return(TRUE); } hndParams = GenConstant(theEnv,SYMBOL,(void *) MessageHandlerData(theEnv)->SELF_SYMBOL); hndParams = ParseProcParameters(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken,hndParams, &wildcard,&min,&max,&error,IsParameterSlotReference); if (error) return(TRUE); PPCRAndIndent(theEnv); ExpressionData(theEnv)->ReturnContext = TRUE; actions = ParseProcActions(theEnv,"message-handler",readSource, &DefclassData(theEnv)->ObjectParseToken,hndParams,wildcard, SlotReferenceVar,BindSlotReference,&lvars, (void *) cls); if (actions == NULL) { ReturnExpression(theEnv,hndParams); return(TRUE); } if (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN) { SyntaxErrorMessage(theEnv,"defmessage-handler"); ReturnExpression(theEnv,hndParams); ReturnPackedExpression(theEnv,actions); return(TRUE); } PPBackup(theEnv); PPBackup(theEnv); SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm); SavePPBuffer(theEnv,"\n"); /* =================================================== If we're only checking syntax, don't add the successfully parsed defmessage-handler to the KB. =================================================== */ if (ConstructData(theEnv)->CheckSyntaxMode) { ReturnExpression(theEnv,hndParams); ReturnPackedExpression(theEnv,actions); return(FALSE); } if (hnd != NULL) { ExpressionDeinstall(theEnv,hnd->actions); ReturnPackedExpression(theEnv,hnd->actions); if (hnd->ppForm != NULL) rm(theEnv,(void *) hnd->ppForm, (sizeof(char) * (strlen(hnd->ppForm)+1))); } else { hnd = InsertHandlerHeader(theEnv,cls,mname,(int) mtype); IncrementSymbolCount(hnd->name); } ReturnExpression(theEnv,hndParams); hnd->minParams = min; hnd->maxParams = max; hnd->localVarCount = lvars; hnd->actions = actions; ExpressionInstall(theEnv,hnd->actions); #if DEBUGGING_FUNCTIONS /* =================================================== Old handler trace status is automatically preserved =================================================== */ if (EnvGetConserveMemory(theEnv) == FALSE) hnd->ppForm = CopyPPBuffer(theEnv); else #endif hnd->ppForm = NULL; return(FALSE); }
/********************************************************* NAME : CheckSlotReference DESCRIPTION : Examines a ?self:<slot-name> reference If the reference is a single-field or global variable, checking and evaluation is delayed until run-time. If the reference is a symbol, this routine verifies that the slot is a legal slot for the reference (i.e., it exists in the class to which the message-handler is being attached, it is visible and it is writable for write reference) INPUTS : 1) A buffer holding the class of the handler being parsed 2) The type of the slot reference 3) The value of the slot reference 4) A flag indicating if this is a read or write access 5) Value expression for write RETURNS : Class slot on success, NULL on errors SIDE EFFECTS : Messages printed on errors. NOTES : For static references, this function insures that the slot is either publicly visible or that the handler is being attached to the same class in which the private slot is defined. *********************************************************/ static SLOT_DESC *CheckSlotReference( void *theEnv, DEFCLASS *theDefclass, int theType, void *theValue, CLIPS_BOOLEAN writeFlag, EXPRESSION *writeExpression) { int slotIndex; SLOT_DESC *sd; int vCode; if (theType != SYMBOL) { PrintErrorID(theEnv,"MSGPSR",7,FALSE); EnvPrintRouter(theEnv,WERROR,"Illegal value for ?self reference.\n"); return(NULL); } slotIndex = FindInstanceTemplateSlot(theEnv,theDefclass,(SYMBOL_HN *) theValue); if (slotIndex == -1) { PrintErrorID(theEnv,"MSGPSR",6,FALSE); EnvPrintRouter(theEnv,WERROR,"No such slot "); EnvPrintRouter(theEnv,WERROR,ValueToString(theValue)); EnvPrintRouter(theEnv,WERROR," in class "); EnvPrintRouter(theEnv,WERROR,EnvGetDefclassName(theEnv,(void *) theDefclass)); EnvPrintRouter(theEnv,WERROR," for ?self reference.\n"); return(NULL); } sd = theDefclass->instanceTemplate[slotIndex]; if ((sd->publicVisibility == 0) && (sd->cls != theDefclass)) { SlotVisibilityViolationError(theEnv,sd,theDefclass); return(NULL); } if (! writeFlag) return(sd); /* ================================================= If a slot is initialize-only, the WithinInit flag still needs to be checked at run-time, for the handler could be called out of the context of an init. ================================================= */ if (sd->noWrite && (sd->initializeOnly == 0)) { SlotAccessViolationError(theEnv,ValueToString(theValue), FALSE,(void *) theDefclass); return(NULL); } if (EnvGetStaticConstraintChecking(theEnv)) { vCode = ConstraintCheckExpressionChain(theEnv,writeExpression,sd->constraint); if (vCode != NO_VIOLATION) { PrintErrorID(theEnv,"CSTRNCHK",1,FALSE); EnvPrintRouter(theEnv,WERROR,"Expression for "); PrintSlot(theEnv,WERROR,sd,NULL,"direct slot write"); ConstraintViolationErrorMessage(theEnv,NULL,NULL,0,0,NULL,0, vCode,sd->constraint,FALSE); return(NULL); } } return(sd); }
/************************************************************** NAME : ParseSuperclasses DESCRIPTION : Parses the (is-a <superclass>+) portion of the (defclass ...) construct and returns a list of direct superclasses. The class "standard-class" is the precedence list for classes with no direct superclasses. The final precedence list (not calculated here) will have the class in question first followed by the merged precedence lists of its direct superclasses. INPUTS : 1) The logical name of the input source 2) The symbolic name of the new class RETURNS : The address of the superclass list or NULL if there was an error SIDE EFFECTS : None NOTES : Assumes "(defclass <name> [<comment>] (" has already been scanned. All superclasses must be defined before their subclasses. Duplicates in the (is-a ...) list are are not allowed (a class may only inherits from a superclass once). This routine also checks the class-precedence lists of each of the direct superclasses for an occurrence of the new class - i.e. cycles! This can only happen when a class is redefined (a new class cannot have an unspecified superclass). This routine allocates the space for the list ***************************************************************/ globle PACKED_CLASS_LINKS *ParseSuperclasses( void *theEnv, char *readSource, SYMBOL_HN *newClassName) { CLASS_LINK *clink = NULL,*cbot = NULL,*ctmp; DEFCLASS *sclass; PACKED_CLASS_LINKS *plinks; if (GetType(DefclassData(theEnv)->ObjectParseToken) != LPAREN) { SyntaxErrorMessage(theEnv,(char*)"defclass inheritance"); return(NULL); } GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken); if ((GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL) ? TRUE : (DefclassData(theEnv)->ObjectParseToken.value != (void *) DefclassData(theEnv)->ISA_SYMBOL)) { SyntaxErrorMessage(theEnv,(char*)"defclass inheritance"); return(NULL); } SavePPBuffer(theEnv,(char*)" "); GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken); while (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN) { if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL) { SyntaxErrorMessage(theEnv,(char*)"defclass"); goto SuperclassParseError; } if (FindModuleSeparator(ValueToString(newClassName))) { IllegalModuleSpecifierMessage(theEnv); goto SuperclassParseError; } if (GetValue(DefclassData(theEnv)->ObjectParseToken) == (void *) newClassName) { PrintErrorID(theEnv,(char*)"INHERPSR",1,FALSE); EnvPrintRouter(theEnv,WERROR,(char*)"A class may not have itself as a superclass.\n"); goto SuperclassParseError; } for (ctmp = clink ; ctmp != NULL ; ctmp = ctmp->nxt) { if (GetValue(DefclassData(theEnv)->ObjectParseToken) == (void *) ctmp->cls->header.name) { PrintErrorID(theEnv,(char*)"INHERPSR",2,FALSE); EnvPrintRouter(theEnv,WERROR,(char*)"A class may inherit from a superclass only once.\n"); goto SuperclassParseError; } } sclass = LookupDefclassInScope(theEnv,ValueToString(GetValue(DefclassData(theEnv)->ObjectParseToken))); if (sclass == NULL) { PrintErrorID(theEnv,(char*)"INHERPSR",3,FALSE); EnvPrintRouter(theEnv,WERROR,(char*)"A class must be defined after all its superclasses.\n"); goto SuperclassParseError; } if ((sclass == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME]) || (sclass == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_ADDRESS]) || (sclass == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME]->directSuperclasses.classArray[0])) { PrintErrorID(theEnv,(char*)"INHERPSR",6,FALSE); EnvPrintRouter(theEnv,WERROR,(char*)"A user-defined class cannot be a subclass of "); EnvPrintRouter(theEnv,WERROR,EnvGetDefclassName(theEnv,(void *) sclass)); EnvPrintRouter(theEnv,WERROR,(char*)".\n"); goto SuperclassParseError; } ctmp = get_struct(theEnv,classLink); ctmp->cls = sclass; if (clink == NULL) clink = ctmp; else cbot->nxt = ctmp; ctmp->nxt = NULL; cbot = ctmp; SavePPBuffer(theEnv,(char*)" "); GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken); } if (clink == NULL) { PrintErrorID(theEnv,(char*)"INHERPSR",4,FALSE); EnvPrintRouter(theEnv,WERROR,(char*)"Must have at least one superclass.\n"); return(NULL); } PPBackup(theEnv); PPBackup(theEnv); SavePPBuffer(theEnv,(char*)")"); plinks = get_struct(theEnv,packedClassLinks); PackClassLinks(theEnv,plinks,clink); return(plinks); SuperclassParseError: DeleteClassLinks(theEnv,clink); return(NULL); }