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