/**************************************************************
NAME : RemoveDefinstances
DESCRIPTION : Deallocates and removes a definstance construct
INPUTS : The definstance address
RETURNS : Nothing useful
SIDE EFFECTS : Existing definstance construct deleted
NOTES : Assumes busy count of definstance is 0
**************************************************************/
static void RemoveDefinstances(
void *theEnv,
void *vdptr)
{
DEFINSTANCES *dptr = (DEFINSTANCES *) vdptr;
DecrementSymbolCount(theEnv,GetDefinstancesNamePointer((void *) dptr));
ExpressionDeinstall(theEnv,dptr->mkinstance);
ReturnPackedExpression(theEnv,dptr->mkinstance);
SetDefinstancesPPForm((void *) dptr,NULL);
ClearUserDataList(theEnv,dptr->header.usrData);
rtn_struct(theEnv,definstances,dptr);
}
/***************************************************
NAME : RemoveDeffunction
DESCRIPTION : Removes a deffunction
INPUTS : Deffunction pointer
RETURNS : Nothing useful
SIDE EFFECTS : Deffunction deallocated
NOTES : Assumes deffunction is not in use!!
***************************************************/
globle void RemoveDeffunction(
void *theEnv,
void *vdptr)
{
DEFFUNCTION *dptr = (DEFFUNCTION *) vdptr;
if (dptr == NULL)
return;
DecrementSymbolCount(theEnv,GetDeffunctionNamePointer((void *) dptr));
ExpressionDeinstall(theEnv,dptr->code);
ReturnPackedExpression(theEnv,dptr->code);
SetDeffunctionPPForm((void *) dptr,NULL);
ClearUserDataList(theEnv,dptr->header.usrData);
rtn_struct(theEnv,deffunctionStruct,dptr);
}
/***************************************************
NAME : DeleteMethodInfo
DESCRIPTION : Deallocates all the data associated
w/ a method but does not release
the method structure itself
INPUTS : 1) The generic function address
2) The method address
RETURNS : Nothing useful
SIDE EFFECTS : Nodes deallocated
NOTES : None
***************************************************/
globle void DeleteMethodInfo(
void *theEnv,
EXEC_STATUS,
DEFGENERIC *gfunc,
DEFMETHOD *meth)
{
short j,k;
RESTRICTION *rptr;
SaveBusyCount(gfunc);
ExpressionDeinstall(theEnv,execStatus,meth->actions);
ReturnPackedExpression(theEnv,execStatus,meth->actions);
ClearUserDataList(theEnv,execStatus,meth->usrData);
if (meth->ppForm != NULL)
rm(theEnv,execStatus,(void *) meth->ppForm,(sizeof(char) * (strlen(meth->ppForm)+1)));
for (j = 0 ; j < meth->restrictionCount ; j++)
{
rptr = &meth->restrictions[j];
for (k = 0 ; k < rptr->tcnt ; k++)
#if OBJECT_SYSTEM
DecrementDefclassBusyCount(theEnv,execStatus,rptr->types[k]);
#else
DecrementIntegerCount(theEnv,execStatus,(INTEGER_HN *) rptr->types[k]);
#endif
if (rptr->types != NULL)
rm(theEnv,execStatus,(void *) rptr->types,(sizeof(void *) * rptr->tcnt));
ExpressionDeinstall(theEnv,execStatus,rptr->query);
ReturnPackedExpression(theEnv,execStatus,rptr->query);
}
if (meth->restrictions != NULL)
rm(theEnv,execStatus,(void *) meth->restrictions,
(sizeof(RESTRICTION) * meth->restrictionCount));
RestoreBusyCount(gfunc);
}
static void ReturnDeffacts(
Environment *theEnv,
Deffacts *theDeffacts)
{
#if (! BLOAD_ONLY) && (! RUN_TIME)
if (theDeffacts == NULL) return;
ExpressionDeinstall(theEnv,theDeffacts->assertList);
ReturnPackedExpression(theEnv,theDeffacts->assertList);
DeinstallConstructHeader(theEnv,&theDeffacts->header);
rtn_struct(theEnv,deffacts,theDeffacts);
#endif
}
static void DestroyDeffunctionAction(
void *theEnv,
struct constructHeader *theConstruct,
void *buffer)
{
#if (! BLOAD_ONLY) && (! RUN_TIME)
struct deffunctionStruct *theDeffunction = (struct deffunctionStruct *) theConstruct;
if (theDeffunction == NULL) return;
ReturnPackedExpression(theEnv,theDeffunction->code);
DestroyConstructHeader(theEnv,&theDeffunction->header);
rtn_struct(theEnv,deffunctionStruct,theDeffunction);
#else
#endif
}
/***************************************************
NAME : RemoveHashedExpression
DESCRIPTION : Removes a hashed expression from
the hash table
INPUTS : The expression
RETURNS : Nothing useful
SIDE EFFECTS : Hash node removed (or use count
decremented). If the hash node
is removed, the expression is
deinstalled and deleted
NOTES : If the expression is in use by
others, then the use count is
merely decremented
***************************************************/
globle void RemoveHashedExpression(
EXPRESSION *exp)
{
EXPRESSION_HN *exphash,*prv;
unsigned hashval;
exphash = FindHashedExpression(exp,&hashval,&prv);
if (exphash == NULL)
return;
if (--exphash->count != 0)
return;
if (prv == NULL)
ExpressionHashTable[hashval] = exphash->nxt;
else
prv->nxt = exphash->nxt;
ExpressionDeinstall(exphash->exp);
ReturnPackedExpression(exphash->exp);
rtn_struct(exprHashNode,exphash);
}
static void ReturnDeffacts(
void *theEnv,
void *vTheDeffacts)
{
#if (MAC_MCW || WIN_MCW) && (RUN_TIME || BLOAD_ONLY)
#pragma unused(theEnv,vTheDeffacts)
#endif
#if (! BLOAD_ONLY) && (! RUN_TIME)
struct deffacts *theDeffacts = (struct deffacts *) vTheDeffacts;
if (theDeffacts == NULL) return;
ExpressionDeinstall(theEnv,theDeffacts->assertList);
ReturnPackedExpression(theEnv,theDeffacts->assertList);
DeinstallConstructHeader(theEnv,&theDeffacts->header);
rtn_struct(theEnv,deffacts,theDeffacts);
#endif
}
static void DeallocateExpressionData(
void *theEnv)
{
#if ! RUN_TIME
int i;
EXPRESSION_HN *tmpPtr, *nextPtr;
#if (BLOAD || BLOAD_ONLY || BLOAD_AND_BSAVE)
if (! Bloaded(theEnv))
#endif
{
for (i = 0; i < EXPRESSION_HASH_SIZE; i++)
{
tmpPtr = ExpressionData(theEnv)->ExpressionHashTable[i];
while (tmpPtr != NULL)
{
nextPtr = tmpPtr->next;
ReturnPackedExpression(theEnv,tmpPtr->exp);
rtn_struct(theEnv,exprHashNode,tmpPtr);
tmpPtr = nextPtr;
}
}
}
rm(theEnv,ExpressionData(theEnv)->ExpressionHashTable,
(int) (sizeof(EXPRESSION_HN *) * EXPRESSION_HASH_SIZE));
#else
#if MAC_MCW || WIN_MCW || MAC_XCD
#pragma unused(theEnv)
#endif
#endif
#if (BLOAD || BLOAD_ONLY || BLOAD_AND_BSAVE)
if ((ExpressionData(theEnv)->NumberOfExpressions != 0) && Bloaded(theEnv))
{
genfree(theEnv,(void *) ExpressionData(theEnv)->ExpressionArray,
ExpressionData(theEnv)->NumberOfExpressions * sizeof(struct expr));
}
#endif
}
static void DestroyDeffactsAction(
void *theEnv,
struct constructHeader *theConstruct,
void *buffer)
{
#if MAC_MCW || WIN_MCW || MAC_XCD
#pragma unused(buffer)
#endif
#if (! BLOAD_ONLY) && (! RUN_TIME)
struct deffacts *theDeffacts = (struct deffacts *) theConstruct;
if (theDeffacts == NULL) return;
ReturnPackedExpression(theEnv,theDeffacts->assertList);
DestroyConstructHeader(theEnv,&theDeffacts->header);
rtn_struct(theEnv,deffacts,theDeffacts);
#else
#if MAC_MCW || WIN_MCW || MAC_XCD
#pragma unused(theEnv,theConstruct)
#endif
#endif
}
static void DestroyDefinstancesAction(
void *theEnv,
struct constructHeader *theConstruct,
void *buffer)
{
#if MAC_MCW || IBM_MCW || MAC_XCD
#pragma unused(buffer)
#endif
#if (! BLOAD_ONLY) && (! RUN_TIME)
struct definstances *theDefinstances = (struct definstances *) theConstruct;
if (theDefinstances == NULL) return;
ReturnPackedExpression(theEnv,theDefinstances->mkinstance);
DestroyConstructHeader(theEnv,&theDefinstances->header);
rtn_struct(theEnv,definstances,theDefinstances);
#else
#if MAC_MCW || IBM_MCW || MAC_XCD
#pragma unused(theConstruct,theEnv)
#endif
#endif
}
/***************************************************************************
NAME : ParseDeffunction
DESCRIPTION : Parses the deffunction construct
INPUTS : The input logical name
RETURNS : FALSE if successful parse, TRUE otherwise
SIDE EFFECTS : Creates valid deffunction definition
NOTES : H/L Syntax :
(deffunction <name> [<comment>]
(<single-field-varible>* [<multifield-variable>])
<action>*)
***************************************************************************/
globle BOOLEAN ParseDeffunction(
void *theEnv,
char *readSource)
{
SYMBOL_HN *deffunctionName;
EXPRESSION *actions;
EXPRESSION *parameterList;
SYMBOL_HN *wildcard;
int min,max,lvars,DeffunctionError = FALSE;
short overwrite = FALSE, owMin = 0, owMax = 0;
DEFFUNCTION *dptr;
SetPPBufferStatus(theEnv,ON);
FlushPPBuffer(theEnv);
SetIndentDepth(theEnv,3);
SavePPBuffer(theEnv,"(deffunction ");
#if BLOAD || BLOAD_AND_BSAVE
if ((Bloaded(theEnv) == TRUE) && (! ConstructData(theEnv)->CheckSyntaxMode))
{
CannotLoadWithBloadMessage(theEnv,"deffunctions");
return(TRUE);
}
#endif
/* =====================================================
Parse the name and comment fields of the deffunction.
===================================================== */
deffunctionName = GetConstructNameAndComment(theEnv,readSource,&DeffunctionData(theEnv)->DFInputToken,"deffunction",
EnvFindDeffunction,NULL,
"!",TRUE,TRUE,TRUE);
if (deffunctionName == NULL)
return(TRUE);
if (ValidDeffunctionName(theEnv,ValueToString(deffunctionName)) == FALSE)
return(TRUE);
/*==========================*/
/* Parse the argument list. */
/*==========================*/
parameterList = ParseProcParameters(theEnv,readSource,&DeffunctionData(theEnv)->DFInputToken,NULL,&wildcard,
&min,&max,&DeffunctionError,NULL);
if (DeffunctionError)
return(TRUE);
/*===================================================================*/
/* Go ahead and add the deffunction so it can be recursively called. */
/*===================================================================*/
if (ConstructData(theEnv)->CheckSyntaxMode)
{
dptr = (DEFFUNCTION *) EnvFindDeffunction(theEnv,ValueToString(deffunctionName));
if (dptr == NULL)
{ dptr = AddDeffunction(theEnv,deffunctionName,NULL,min,max,0,TRUE); }
else
{
overwrite = TRUE;
owMin = (short) dptr->minNumberOfParameters;
owMax = (short) dptr->maxNumberOfParameters;
dptr->minNumberOfParameters = min;
dptr->maxNumberOfParameters = max;
}
}
else
{ dptr = AddDeffunction(theEnv,deffunctionName,NULL,min,max,0,TRUE); }
if (dptr == NULL)
{
ReturnExpression(theEnv,parameterList);
return(TRUE);
}
/*==================================================*/
/* Parse the actions contained within the function. */
/*==================================================*/
PPCRAndIndent(theEnv);
ExpressionData(theEnv)->ReturnContext = TRUE;
actions = ParseProcActions(theEnv,"deffunction",readSource,
&DeffunctionData(theEnv)->DFInputToken,parameterList,wildcard,
NULL,NULL,&lvars,NULL);
if (actions == NULL)
{
ReturnExpression(theEnv,parameterList);
if (overwrite)
{
dptr->minNumberOfParameters = owMin;
dptr->maxNumberOfParameters = owMax;
}
if ((dptr->busy == 0) && (! overwrite))
{
RemoveConstructFromModule(theEnv,(struct constructHeader *) dptr);
RemoveDeffunction(theEnv,dptr);
}
return(TRUE);
}
/*==============================================*/
/* If we're only checking syntax, don't add the */
/* successfully parsed deffunction to the KB. */
/*==============================================*/
if (ConstructData(theEnv)->CheckSyntaxMode)
{
ReturnExpression(theEnv,parameterList);
ReturnPackedExpression(theEnv,actions);
if (overwrite)
{
dptr->minNumberOfParameters = owMin;
dptr->maxNumberOfParameters = owMax;
}
else
{
RemoveConstructFromModule(theEnv,(struct constructHeader *) dptr);
RemoveDeffunction(theEnv,dptr);
}
return(FALSE);
}
/*=============================*/
/* Reformat the closing token. */
/*=============================*/
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,DeffunctionData(theEnv)->DFInputToken.printForm);
SavePPBuffer(theEnv,"\n");
/*======================*/
/* Add the deffunction. */
/*======================*/
AddDeffunction(theEnv,deffunctionName,actions,min,max,lvars,FALSE);
ReturnExpression(theEnv,parameterList);
return(DeffunctionError);
}
/****************************************************
NAME : AddDeffunction
DESCRIPTION : Adds a deffunction to the list of
deffunctions
INPUTS : 1) The symbolic name
2) The action expressions
3) The minimum number of arguments
4) The maximum number of arguments
(can be -1)
5) The number of local variables
6) A flag indicating if this is
a header call so that the
deffunction can be recursively
called
RETURNS : The new deffunction (NULL on errors)
SIDE EFFECTS : Deffunction structures allocated
NOTES : Assumes deffunction is not executing
****************************************************/
static DEFFUNCTION *AddDeffunction(
void *theEnv,
SYMBOL_HN *name,
EXPRESSION *actions,
int min,
int max,
int lvars,
int headerp)
{
DEFFUNCTION *dfuncPtr;
unsigned oldbusy;
#if DEBUGGING_FUNCTIONS
unsigned DFHadWatch = FALSE;
#endif
/*===============================================================*/
/* If the deffunction doesn't exist, create a new structure to */
/* contain it and add it to the List of deffunctions. Otherwise, */
/* use the existing structure and remove the pretty print form */
/* and interpretive code. */
/*===============================================================*/
dfuncPtr = (DEFFUNCTION *) EnvFindDeffunction(theEnv,ValueToString(name));
if (dfuncPtr == NULL)
{
dfuncPtr = get_struct(theEnv,deffunctionStruct);
InitializeConstructHeader(theEnv,"deffunction",(struct constructHeader *) dfuncPtr,name);
IncrementSymbolCount(name);
dfuncPtr->code = NULL;
dfuncPtr->minNumberOfParameters = min;
dfuncPtr->maxNumberOfParameters = max;
dfuncPtr->numberOfLocalVars = lvars;
dfuncPtr->busy = 0;
dfuncPtr->executing = 0;
}
else
{
#if DEBUGGING_FUNCTIONS
DFHadWatch = EnvGetDeffunctionWatch(theEnv,(void *) dfuncPtr);
#endif
dfuncPtr->minNumberOfParameters = min;
dfuncPtr->maxNumberOfParameters = max;
dfuncPtr->numberOfLocalVars = lvars;
oldbusy = dfuncPtr->busy;
ExpressionDeinstall(theEnv,dfuncPtr->code);
dfuncPtr->busy = oldbusy;
ReturnPackedExpression(theEnv,dfuncPtr->code);
dfuncPtr->code = NULL;
SetDeffunctionPPForm((void *) dfuncPtr,NULL);
/* =======================================
Remove the deffunction from the list so
that it can be added at the end
======================================= */
RemoveConstructFromModule(theEnv,(struct constructHeader *) dfuncPtr);
}
AddConstructToModule((struct constructHeader *) dfuncPtr);
/* ==================================
Install the new interpretive code.
================================== */
if (actions != NULL)
{
/* ===============================
If a deffunction is recursive,
do not increment its busy count
based on self-references
=============================== */
oldbusy = dfuncPtr->busy;
ExpressionInstall(theEnv,actions);
dfuncPtr->busy = oldbusy;
dfuncPtr->code = actions;
}
/* ===============================================================
Install the pretty print form if memory is not being conserved.
=============================================================== */
#if DEBUGGING_FUNCTIONS
EnvSetDeffunctionWatch(theEnv,DFHadWatch ? TRUE : DeffunctionData(theEnv)->WatchDeffunctions,(void *) dfuncPtr);
if ((EnvGetConserveMemory(theEnv) == FALSE) && (headerp == FALSE))
SetDeffunctionPPForm((void *) dfuncPtr,CopyPPBuffer(theEnv));
#endif
return(dfuncPtr);
}
globle void DestroyDefrule(
void *theEnv,
void *vTheDefrule)
{
struct defrule *theDefrule = (struct defrule *) vTheDefrule;
struct defrule *nextDisjunct;
int first = TRUE;
if (theDefrule == NULL) return;
while (theDefrule != NULL)
{
DetachJoinsDriver(theEnv,theDefrule,TRUE);
if (first)
{
#if (! BLOAD_ONLY) && (! RUN_TIME)
if (theDefrule->dynamicSalience != NULL)
{ ReturnPackedExpression(theEnv,theDefrule->dynamicSalience); }
if (theDefrule->header.ppForm != NULL)
{
struct defrule *tmpPtr;
rm(theEnv,(void *) theDefrule->header.ppForm,strlen(theDefrule->header.ppForm) + 1);
/*=======================================================*/
/* All of the rule disjuncts share the same pretty print */
/* form, so we want to avoid deleting it again. */
/*=======================================================*/
for (tmpPtr = theDefrule->disjunct; tmpPtr != NULL; tmpPtr = tmpPtr->disjunct)
{ tmpPtr->header.ppForm = NULL; }
}
#if CERTAINTY_FACTORS
if (theDefrule->dynamicCF != NULL)
{ ReturnPackedExpression(theEnv,theDefrule->dynamicCF); }
#endif
#endif
first = FALSE;
}
if (theDefrule->header.usrData != NULL)
{ ClearUserDataList(theEnv,theDefrule->header.usrData); }
#if (! BLOAD_ONLY) && (! RUN_TIME)
if (theDefrule->actions != NULL)
{ ReturnPackedExpression(theEnv,theDefrule->actions); }
#if FUZZY_DEFTEMPLATES
if (theDefrule->numberOfFuzzySlots > 0)
{ rm(theEnv,theDefrule->pattern_fv_arrayPtr, sizeof(struct fzSlotLocator) * theDefrule->numberOfFuzzySlots); }
#endif
#endif
nextDisjunct = theDefrule->disjunct;
#if (! BLOAD_ONLY) && (! RUN_TIME)
rtn_struct(theEnv,defrule,theDefrule);
#endif
theDefrule = nextDisjunct;
}
}
/***********************************************************************
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 : EvaluateSlotDefaultValue
DESCRIPTION : Checks the default value against the slot
constraints and evaluates static default values
INPUTS : 1) The slot descriptor
2) The bitmap marking which facets were specified in
the original slot definition
RETURNS : TRUE if all OK, FALSE otherwise
SIDE EFFECTS : Static default value expressions deleted and
replaced with data object evaluation
NOTES : On errors, slot is marked as dynamix so that
DeleteSlots() will erase the slot expression
********************************************************************/
static intBool EvaluateSlotDefaultValue(
void *theEnv,
EXEC_STATUS,
SLOT_DESC *sd,
char *specbits)
{
DATA_OBJECT temp;
int oldce,olddcc,vCode;
/* ===================================================================
Slot default value expression is marked as dynamic until now so
that DeleteSlots() would erase in the event of an error. The delay
was so that the evaluation of a static default value could be
delayed until all the constraints were parsed.
=================================================================== */
if (TestBitMap(specbits,DEFAULT_DYNAMIC_BIT) == 0)
sd->dynamicDefault = 0;
if (sd->noDefault)
return(TRUE);
if (sd->dynamicDefault == 0)
{
if (TestBitMap(specbits,DEFAULT_BIT))
{
oldce = ExecutingConstruct(theEnv,execStatus);
SetExecutingConstruct(theEnv,execStatus,TRUE);
olddcc = EnvSetDynamicConstraintChecking(theEnv,execStatus,EnvGetStaticConstraintChecking(theEnv,execStatus));
vCode = EvaluateAndStoreInDataObject(theEnv,execStatus,(int) sd->multiple,
(EXPRESSION *) sd->defaultValue,&temp,TRUE);
if (vCode != FALSE)
vCode = ValidSlotValue(theEnv,execStatus,&temp,sd,NULL,"slot default value");
EnvSetDynamicConstraintChecking(theEnv,execStatus,olddcc);
SetExecutingConstruct(theEnv,execStatus,oldce);
if (vCode)
{
ExpressionDeinstall(theEnv,execStatus,(EXPRESSION *) sd->defaultValue);
ReturnPackedExpression(theEnv,execStatus,(EXPRESSION *) sd->defaultValue);
sd->defaultValue = (void *) get_struct(theEnv,execStatus,dataObject);
GenCopyMemory(DATA_OBJECT,1,sd->defaultValue,&temp);
ValueInstall(theEnv,execStatus,(DATA_OBJECT *) sd->defaultValue);
}
else
{
sd->dynamicDefault = 1;
return(FALSE);
}
}
else if (sd->defaultSpecified == 0)
{
sd->defaultValue = (void *) get_struct(theEnv,execStatus,dataObject);
DeriveDefaultFromConstraints(theEnv,execStatus,sd->constraint,
(DATA_OBJECT *) sd->defaultValue,(int) sd->multiple,TRUE);
ValueInstall(theEnv,execStatus,(DATA_OBJECT *) sd->defaultValue);
}
}
else if (EnvGetStaticConstraintChecking(theEnv,execStatus))
{
vCode = ConstraintCheckExpressionChain(theEnv,execStatus,(EXPRESSION *) sd->defaultValue,sd->constraint);
if (vCode != NO_VIOLATION)
{
PrintErrorID(theEnv,execStatus,"CSTRNCHK",1,FALSE);
EnvPrintRouter(theEnv,execStatus,WERROR,"Expression for ");
PrintSlot(theEnv,execStatus,WERROR,sd,NULL,"dynamic default value");
ConstraintViolationErrorMessage(theEnv,execStatus,NULL,NULL,0,0,NULL,0,
vCode,sd->constraint,FALSE);
return(FALSE);
}
}
return(TRUE);
}
globle int ParseDefrule(
void *theEnv,
const char *readSource)
{
#if (! RUN_TIME) && (! BLOAD_ONLY)
SYMBOL_HN *ruleName;
struct lhsParseNode *theLHS;
struct expr *actions;
struct token theToken;
struct defrule *topDisjunct, *tempPtr;
struct defruleModule *theModuleItem;
int error;
/*================================================*/
/* Flush the buffer which stores the pretty print */
/* representation for a rule. Add the already */
/* parsed keyword defrule to this buffer. */
/*================================================*/
SetPPBufferStatus(theEnv,ON);
FlushPPBuffer(theEnv);
SavePPBuffer(theEnv,"(defrule ");
/*=========================================================*/
/* Rules cannot be loaded when a binary load is in effect. */
/*=========================================================*/
#if BLOAD || BLOAD_ONLY || BLOAD_AND_BSAVE
if ((Bloaded(theEnv) == TRUE) && (! ConstructData(theEnv)->CheckSyntaxMode))
{
CannotLoadWithBloadMessage(theEnv,"defrule");
return(TRUE);
}
#endif
/*================================================*/
/* Parse the name and comment fields of the rule, */
/* deleting the rule if it already exists. */
/*================================================*/
#if DEBUGGING_FUNCTIONS
DefruleData(theEnv)->DeletedRuleDebugFlags = 0;
#endif
ruleName = GetConstructNameAndComment(theEnv,readSource,&theToken,"defrule",
EnvFindDefruleInModule,EnvUndefrule,"*",FALSE,
TRUE,TRUE,FALSE);
if (ruleName == NULL) return(TRUE);
/*============================*/
/* Parse the LHS of the rule. */
/*============================*/
theLHS = ParseRuleLHS(theEnv,readSource,&theToken,ValueToString(ruleName),&error);
if (error)
{
ReturnPackedExpression(theEnv,PatternData(theEnv)->SalienceExpression);
PatternData(theEnv)->SalienceExpression = NULL;
return(TRUE);
}
/*============================*/
/* Parse the RHS of the rule. */
/*============================*/
ClearParsedBindNames(theEnv);
ExpressionData(theEnv)->ReturnContext = TRUE;
actions = ParseRuleRHS(theEnv,readSource);
if (actions == NULL)
{
ReturnPackedExpression(theEnv,PatternData(theEnv)->SalienceExpression);
PatternData(theEnv)->SalienceExpression = NULL;
ReturnLHSParseNodes(theEnv,theLHS);
return(TRUE);
}
/*=======================*/
/* Process the rule LHS. */
/*=======================*/
topDisjunct = ProcessRuleLHS(theEnv,theLHS,actions,ruleName,&error);
ReturnExpression(theEnv,actions);
ClearParsedBindNames(theEnv);
ReturnLHSParseNodes(theEnv,theLHS);
if (error)
{
ReturnPackedExpression(theEnv,PatternData(theEnv)->SalienceExpression);
PatternData(theEnv)->SalienceExpression = NULL;
return(TRUE);
}
/*==============================================*/
/* If we're only checking syntax, don't add the */
/* successfully parsed defrule to the KB. */
/*==============================================*/
if (ConstructData(theEnv)->CheckSyntaxMode)
{
ReturnPackedExpression(theEnv,PatternData(theEnv)->SalienceExpression);
PatternData(theEnv)->SalienceExpression = NULL;
return(FALSE);
}
PatternData(theEnv)->SalienceExpression = NULL;
/*======================================*/
/* Save the nice printout of the rules. */
/*======================================*/
SavePPBuffer(theEnv,"\n");
if (EnvGetConserveMemory(theEnv) == TRUE)
{ topDisjunct->header.ppForm = NULL; }
else
{ topDisjunct->header.ppForm = CopyPPBuffer(theEnv); }
/*=======================================*/
/* Store a pointer to the rule's module. */
/*=======================================*/
theModuleItem = (struct defruleModule *)
GetModuleItem(theEnv,NULL,FindModuleItem(theEnv,"defrule")->moduleIndex);
for (tempPtr = topDisjunct; tempPtr != NULL; tempPtr = tempPtr->disjunct)
{
tempPtr->header.whichModule = (struct defmoduleItemHeader *) theModuleItem;
tempPtr->header.ppForm = topDisjunct->header.ppForm;
}
/*===============================================*/
/* Rule completely parsed. Add to list of rules. */
/*===============================================*/
AddToDefruleList(topDisjunct);
/*========================================================================*/
/* If a rule is redefined, then we want to restore its breakpoint status. */
/*========================================================================*/
#if DEBUGGING_FUNCTIONS
if (BitwiseTest(DefruleData(theEnv)->DeletedRuleDebugFlags,0))
{ EnvSetBreak(theEnv,topDisjunct); }
if (BitwiseTest(DefruleData(theEnv)->DeletedRuleDebugFlags,1) || EnvGetWatchItem(theEnv,"activations"))
{ EnvSetDefruleWatchActivations(theEnv,ON,(void *) topDisjunct); }
if (BitwiseTest(DefruleData(theEnv)->DeletedRuleDebugFlags,2) || EnvGetWatchItem(theEnv,"rules"))
{ EnvSetDefruleWatchFirings(theEnv,ON,(void *) topDisjunct); }
#endif
/*================================*/
/* Perform the incremental reset. */
/*================================*/
IncrementalReset(theEnv,topDisjunct);
/*=============================================*/
/* Return FALSE to indicate no errors occured. */
/*=============================================*/
#endif
return(FALSE);
}
globle void ReturnDefrule(
void *theEnv,
void *vWaste)
{
#if (MAC_MCW || IBM_MCW) && (RUN_TIME || BLOAD_ONLY)
#pragma unused(theEnv,vWaste)
#endif
#if (! RUN_TIME) && (! BLOAD_ONLY)
struct defrule *waste = (struct defrule *) vWaste;
int first = TRUE;
struct defrule *nextPtr;
if (waste == NULL) return;
/*======================================*/
/* If a rule is redefined, then we want */
/* to save its breakpoint status. */
/*======================================*/
#if DEBUGGING_FUNCTIONS
DefruleData(theEnv)->DeletedRuleDebugFlags = 0;
if (waste->afterBreakpoint) BitwiseSet(DefruleData(theEnv)->DeletedRuleDebugFlags,0);
if (waste->watchActivation) BitwiseSet(DefruleData(theEnv)->DeletedRuleDebugFlags,1);
if (waste->watchFiring) BitwiseSet(DefruleData(theEnv)->DeletedRuleDebugFlags,2);
#endif
/*================================*/
/* Clear the agenda of all the */
/* activations added by the rule. */
/*================================*/
ClearRuleFromAgenda(theEnv,waste);
/*======================*/
/* Get rid of the rule. */
/*======================*/
while (waste != NULL)
{
/*================================================*/
/* Remove the rule's joins from the join network. */
/*================================================*/
DetachJoins(theEnv,waste,FALSE);
/*=============================================*/
/* If this is the first disjunct, get rid of */
/* the dynamic salience and pretty print form. */
/*=============================================*/
if (first)
{
#if DYNAMIC_SALIENCE
if (waste->dynamicSalience != NULL)
{
ExpressionDeinstall(theEnv,waste->dynamicSalience);
ReturnPackedExpression(theEnv,waste->dynamicSalience);
waste->dynamicSalience = NULL;
}
#endif
if (waste->header.ppForm != NULL)
{
rm(theEnv,waste->header.ppForm,strlen(waste->header.ppForm) + 1);
waste->header.ppForm = NULL;
}
first = FALSE;
}
/*===========================*/
/* Get rid of any user data. */
/*===========================*/
if (waste->header.usrData != NULL)
{ ClearUserDataList(theEnv,waste->header.usrData); }
/*===========================================*/
/* Decrement the count for the defrule name. */
/*===========================================*/
DecrementSymbolCount(theEnv,waste->header.name);
/*========================================*/
/* Get rid of the the rule's RHS actions. */
/*========================================*/
if (waste->actions != NULL)
{
ExpressionDeinstall(theEnv,waste->actions);
ReturnPackedExpression(theEnv,waste->actions);
}
/*===============================*/
/* Move on to the next disjunct. */
/*===============================*/
nextPtr = waste->disjunct;
rtn_struct(theEnv,defrule,waste);
waste = nextPtr;
}
/*==========================*/
/* Free up partial matches. */
/*==========================*/
if (EngineData(theEnv)->ExecutingRule == NULL) FlushGarbagePartialMatches(theEnv);
#endif
}
/********************************************************************
NAME : EvaluateSlotDefaultValue
DESCRIPTION : Checks the default value against the slot
constraints and evaluates static default values
INPUTS : 1) The slot descriptor
2) The bitmap marking which facets were specified in
the original slot definition
RETURNS : True if all OK, false otherwise
SIDE EFFECTS : Static default value expressions deleted and
replaced with data object evaluation
NOTES : On errors, slot is marked as dynamix so that
DeleteSlots() will erase the slot expression
********************************************************************/
static bool EvaluateSlotDefaultValue(
Environment *theEnv,
SlotDescriptor *sd,
const char *specbits)
{
UDFValue temp;
bool oldce,olddcc, vPass;
ConstraintViolationType vCode;
/* ===================================================================
Slot default value expression is marked as dynamic until now so
that DeleteSlots() would erase in the event of an error. The delay
was so that the evaluation of a static default value could be
delayed until all the constraints were parsed.
=================================================================== */
if (! TestBitMap(specbits,DEFAULT_DYNAMIC_BIT))
sd->dynamicDefault = 0;
if (sd->noDefault)
return true;
if (sd->dynamicDefault == 0)
{
if (TestBitMap(specbits,DEFAULT_BIT))
{
oldce = ExecutingConstruct(theEnv);
SetExecutingConstruct(theEnv,true);
olddcc = SetDynamicConstraintChecking(theEnv,true);
vPass = EvaluateAndStoreInDataObject(theEnv,sd->multiple,
(Expression *) sd->defaultValue,&temp,true);
if (vPass != false)
vPass = (ValidSlotValue(theEnv,&temp,sd,NULL,"the 'default' facet") == PSE_NO_ERROR);
SetDynamicConstraintChecking(theEnv,olddcc);
SetExecutingConstruct(theEnv,oldce);
if (vPass)
{
ExpressionDeinstall(theEnv,(Expression *) sd->defaultValue);
ReturnPackedExpression(theEnv,(Expression *) sd->defaultValue);
sd->defaultValue = get_struct(theEnv,udfValue);
GenCopyMemory(UDFValue,1,sd->defaultValue,&temp);
RetainUDFV(theEnv,(UDFValue *) sd->defaultValue);
}
else
{
sd->dynamicDefault = 1;
return false;
}
}
else if (sd->defaultSpecified == 0)
{
sd->defaultValue = get_struct(theEnv,udfValue);
DeriveDefaultFromConstraints(theEnv,sd->constraint,
(UDFValue *) sd->defaultValue,sd->multiple,true);
RetainUDFV(theEnv,(UDFValue *) sd->defaultValue);
}
}
else
{
vCode = ConstraintCheckExpressionChain(theEnv,(Expression *) sd->defaultValue,sd->constraint);
if (vCode != NO_VIOLATION)
{
PrintErrorID(theEnv,"CSTRNCHK",1,false);
WriteString(theEnv,STDERR,"Expression for ");
PrintSlot(theEnv,STDERR,sd,NULL,"dynamic default value");
ConstraintViolationErrorMessage(theEnv,NULL,NULL,0,0,NULL,0,
vCode,sd->constraint,false);
return false;
}
}
return true;
}
globle void ReturnDefrule(
void *theEnv,
void *vWaste)
{
#if (! RUN_TIME) && (! BLOAD_ONLY)
struct defrule *waste = (struct defrule *) vWaste;
int first = TRUE;
struct defrule *nextPtr, *tmpPtr;
if (waste == NULL) return;
/*======================================*/
/* If a rule is redefined, then we want */
/* to save its breakpoint status. */
/*======================================*/
#if DEBUGGING_FUNCTIONS
DefruleData(theEnv)->DeletedRuleDebugFlags = 0;
if (waste->afterBreakpoint) BitwiseSet(DefruleData(theEnv)->DeletedRuleDebugFlags,0);
if (waste->watchActivation) BitwiseSet(DefruleData(theEnv)->DeletedRuleDebugFlags,1);
if (waste->watchFiring) BitwiseSet(DefruleData(theEnv)->DeletedRuleDebugFlags,2);
#endif
/*================================*/
/* Clear the agenda of all the */
/* activations added by the rule. */
/*================================*/
ClearRuleFromAgenda(theEnv,waste);
/*======================*/
/* Get rid of the rule. */
/*======================*/
while (waste != NULL)
{
/*================================================*/
/* Remove the rule's joins from the join network. */
/*================================================*/
DetachJoinsDriver(theEnv,waste,FALSE);
/*=============================================*/
/* If this is the first disjunct, get rid of */
/* the dynamic salience and pretty print form. */
/*=============================================*/
if (first)
{
if (waste->dynamicSalience != NULL)
{
ExpressionDeinstall(theEnv,waste->dynamicSalience);
ReturnPackedExpression(theEnv,waste->dynamicSalience);
waste->dynamicSalience = NULL;
}
#if CERTAINTY_FACTORS /* changed 03-12-96 */
if (waste->dynamicCF != NULL)
{
ExpressionDeinstall(theEnv,waste->dynamicCF);
ReturnPackedExpression(theEnv,waste->dynamicCF);
waste->dynamicCF = NULL;
}
#endif
if (waste->header.ppForm != NULL)
{
rm(theEnv,(void *) waste->header.ppForm,strlen(waste->header.ppForm) + 1);
waste->header.ppForm = NULL;
/*=======================================================*/
/* All of the rule disjuncts share the same pretty print */
/* form, so we want to avoid deleting it again. */
/*=======================================================*/
for (tmpPtr = waste->disjunct; tmpPtr != NULL; tmpPtr = tmpPtr->disjunct)
{ tmpPtr->header.ppForm = NULL; }
}
first = FALSE;
}
/*===========================*/
/* Get rid of any user data. */
/*===========================*/
if (waste->header.usrData != NULL)
{ ClearUserDataList(theEnv,waste->header.usrData); }
/*===========================================*/
/* Decrement the count for the defrule name. */
/*===========================================*/
DecrementSymbolCount(theEnv,waste->header.name);
/*========================================*/
/* Get rid of the the rule's RHS actions. */
/*========================================*/
if (waste->actions != NULL)
{
ExpressionDeinstall(theEnv,waste->actions);
ReturnPackedExpression(theEnv,waste->actions);
}
/*===============================*/
/* Move on to the next disjunct. */
/*===============================*/
nextPtr = waste->disjunct;
#if FUZZY_DEFTEMPLATES
if (waste != EngineData(theEnv)->ExecutingRule)
{
if (waste->numberOfFuzzySlots > 0)
rm(theEnv,waste->pattern_fv_arrayPtr, sizeof(struct fzSlotLocator) * waste->numberOfFuzzySlots);
}
#endif
rtn_struct(theEnv,defrule,waste);
waste = nextPtr;
}
/*==========================*/
/* Free up partial matches. */
/*==========================*/
if (EngineData(theEnv)->ExecutingRule == NULL) FlushGarbagePartialMatches(theEnv);
#endif
}
/***************************************************
NAME : DeallocateMarkedHandlers
DESCRIPTION : Removes any handlers from a class
that have been previously marked
for deletion.
INPUTS : The class
RETURNS : Nothing useful
SIDE EFFECTS : Marked handlers are deleted
NOTES : Assumes none of the handlers are
currently executing or have a
busy count != 0 for any reason
***************************************************/
globle void DeallocateMarkedHandlers(
void *theEnv,
EXEC_STATUS,
DEFCLASS *cls)
{
short count;
HANDLER *hnd,*nhnd;
unsigned *arr,*narr;
long i,j;
for (i = 0 , count = 0 ; i < cls->handlerCount ; i++)
{
hnd = &cls->handlers[i];
if (hnd->mark == 1)
{
count++;
DecrementSymbolCount(theEnv,execStatus,hnd->name);
ExpressionDeinstall(theEnv,execStatus,hnd->actions);
ReturnPackedExpression(theEnv,execStatus,hnd->actions);
ClearUserDataList(theEnv,execStatus,hnd->usrData);
if (hnd->ppForm != NULL)
rm(theEnv,execStatus,(void *) hnd->ppForm,
(sizeof(char) * (strlen(hnd->ppForm)+1)));
}
else
/* ============================================
Use the busy field to count how many
message-handlers are removed before this one
============================================ */
hnd->busy = count;
}
if (count == 0)
return;
if (count == cls->handlerCount)
{
rm(theEnv,execStatus,(void *) cls->handlers,(sizeof(HANDLER) * cls->handlerCount));
rm(theEnv,execStatus,(void *) cls->handlerOrderMap,(sizeof(unsigned) * cls->handlerCount));
cls->handlers = NULL;
cls->handlerOrderMap = NULL;
cls->handlerCount = 0;
}
else
{
count = (short) (cls->handlerCount - count);
hnd = cls->handlers;
arr = cls->handlerOrderMap;
nhnd = (HANDLER *) gm2(theEnv,execStatus,(sizeof(HANDLER) * count));
narr = (unsigned *) gm2(theEnv,execStatus,(sizeof(unsigned) * count));
for (i = 0 , j = 0 ; j < count ; i++)
{
if (hnd[arr[i]].mark == 0)
{
/* ==============================================================
The offsets in the map need to be decremented by the number of
preceding nodes which were deleted. Use the value of the busy
field set in the first loop.
============================================================== */
narr[j] = arr[i] - hnd[arr[i]].busy;
j++;
}
}
for (i = 0 , j = 0 ; j < count ; i++)
{
if (hnd[i].mark == 0)
{
hnd[i].busy = 0;
GenCopyMemory(HANDLER,1,&nhnd[j],&hnd[i]);
j++;
}
}
rm(theEnv,execStatus,(void *) hnd,(sizeof(HANDLER) * cls->handlerCount));
rm(theEnv,execStatus,(void *) arr,(sizeof(unsigned) * cls->handlerCount));
cls->handlers = nhnd;
cls->handlerOrderMap = narr;
cls->handlerCount = count;
}
}