globle void ExpressionInstall(
struct expr *expression)
{
if (expression == NULL) return;
while (expression != NULL)
{
AtomInstall(expression->type,expression->value);
ExpressionInstall(expression->argList);
expression = expression->nextArg;
}
}
static void ClearDeffacts(
void *theEnv)
{
#if (! RUN_TIME) && (! BLOAD_ONLY)
struct expr *stub;
struct deffacts *newDeffacts;
/*=====================================*/
/* Create the data structures for the */
/* expression (assert (initial-fact)). */
/*=====================================*/
stub = GenConstant(theEnv,FCALL,FindFunction(theEnv,"assert"));
stub->argList = GenConstant(theEnv,DEFTEMPLATE_PTR,EnvFindDeftemplate(theEnv,"initial-fact"));
ExpressionInstall(theEnv,stub);
/*=============================================*/
/* Create a deffacts data structure to contain */
/* the expression and initialize it. */
/*=============================================*/
newDeffacts = get_struct(theEnv,deffacts);
newDeffacts->header.whichModule =
(struct defmoduleItemHeader *) GetDeffactsModuleItem(theEnv,NULL);
newDeffacts->header.name = (SYMBOL_HN *) EnvAddSymbol(theEnv,"initial-fact");
IncrementSymbolCount(newDeffacts->header.name);
newDeffacts->assertList = PackExpression(theEnv,stub);
newDeffacts->header.next = NULL;
newDeffacts->header.ppForm = NULL;
newDeffacts->header.usrData = NULL;
ReturnExpression(theEnv,stub);
/*===========================================*/
/* Store the deffacts in the current module. */
/*===========================================*/
AddConstructToModule(&newDeffacts->header);
#else
#if MAC_MCW || WIN_MCW || MAC_XCD
#pragma unused(theEnv)
#endif
#endif
}
/*************************************************************
NAME : ParseDefaultFacet
DESCRIPTION : Parses the facet for a slot
INPUTS : 1) The input logical name
2) The bitmap indicating which facets have
already been parsed
3) The slot descriptor to set
RETURNS : True if all OK, false otherwise
SIDE EFFECTS : Slot set and parsed facet bitmap set
NOTES : Syntax: (default ?NONE|<expression>*)
(default-dynamic <expression>*)
*************************************************************/
static bool ParseDefaultFacet(
Environment *theEnv,
const char *readSource,
char *specbits,
SlotDescriptor *slot)
{
Expression *tmp;
bool error, noneSpecified, deriveSpecified;
if (TestBitMap(specbits,DEFAULT_BIT))
{
PrintErrorID(theEnv,"CLSLTPSR",2,false);
WriteString(theEnv,STDERR,"The 'default' facet for slot '");
WriteString(theEnv,STDERR,slot->slotName->name->contents);
WriteString(theEnv,STDERR,"' is already specified.\n");
return false;
}
SetBitMap(specbits,DEFAULT_BIT);
error = false;
tmp = ParseDefault(theEnv,readSource,true,TestBitMap(specbits,DEFAULT_DYNAMIC_BIT),
false,&noneSpecified,&deriveSpecified,&error);
if (error == true)
return false;
if (noneSpecified || deriveSpecified)
{
if (noneSpecified)
{
slot->noDefault = 1;
slot->defaultSpecified = 1;
}
else
ClearBitMap(specbits,DEFAULT_BIT);
}
else
{
slot->defaultValue = PackExpression(theEnv,tmp);
ReturnExpression(theEnv,tmp);
ExpressionInstall(theEnv,(Expression *) slot->defaultValue);
slot->defaultSpecified = 1;
}
return true;
}
/********************************************************
NAME : CreateInitialDefinstances
DESCRIPTION : Makes the initial-object definstances
structure for creating an initial-object
which will match default object patterns
in defrules
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : initial-object definstances created
NOTES : None
********************************************************/
static void CreateInitialDefinstances(
void *theEnv)
{
EXPRESSION *tmp;
DEFINSTANCES *theDefinstances;
theDefinstances = get_struct(theEnv,definstances);
InitializeConstructHeader(theEnv,(char*)"definstances",(struct constructHeader *) theDefinstances,
DefclassData(theEnv)->INITIAL_OBJECT_SYMBOL);
theDefinstances->busy = 0;
tmp = GenConstant(theEnv,FCALL,(void *) FindFunction(theEnv,(char*)"make-instance"));
tmp->argList = GenConstant(theEnv,INSTANCE_NAME,(void *) DefclassData(theEnv)->INITIAL_OBJECT_SYMBOL);
tmp->argList->nextArg =
GenConstant(theEnv,DEFCLASS_PTR,(void *) LookupDefclassInScope(theEnv,INITIAL_OBJECT_CLASS_NAME));
theDefinstances->mkinstance = PackExpression(theEnv,tmp);
ReturnExpression(theEnv,tmp);
IncrementSymbolCount(GetDefinstancesNamePointer((void *) theDefinstances));
ExpressionInstall(theEnv,theDefinstances->mkinstance);
AddConstructToModule((struct constructHeader *) theDefinstances);
}
/*************************************************************
NAME : ParseDefaultFacet
DESCRIPTION : Parses the facet for a slot
INPUTS : 1) The input logical name
2) The bitmap indicating which facets have
already been parsed
3) The slot descriptor to set
RETURNS : TRUE if all OK, FALSE otherwise
SIDE EFFECTS : Slot set and parsed facet bitmap set
NOTES : Syntax: (default ?NONE|<expression>*)
(default-dynamic <expression>*)
*************************************************************/
static intBool ParseDefaultFacet(
void *theEnv,
EXEC_STATUS,
char *readSource,
char *specbits,
SLOT_DESC *slot)
{
EXPRESSION *tmp;
int error,noneSpecified,deriveSpecified;
if (TestBitMap(specbits,DEFAULT_BIT))
{
PrintErrorID(theEnv,execStatus,"CLSLTPSR",2,FALSE);
EnvPrintRouter(theEnv,execStatus,WERROR,"default facet already specified.\n");
return(FALSE);
}
SetBitMap(specbits,DEFAULT_BIT);
error = FALSE;
tmp = ParseDefault(theEnv,execStatus,readSource,1,(int) TestBitMap(specbits,DEFAULT_DYNAMIC_BIT),
0,&noneSpecified,&deriveSpecified,&error);
if (error == TRUE)
return(FALSE);
if (noneSpecified || deriveSpecified)
{
if (noneSpecified)
{
slot->noDefault = 1;
slot->defaultSpecified = 1;
}
else
ClearBitMap(specbits,DEFAULT_BIT);
}
else
{
slot->defaultValue = (void *) PackExpression(theEnv,execStatus,tmp);
ReturnExpression(theEnv,execStatus,tmp);
ExpressionInstall(theEnv,execStatus,(EXPRESSION *) slot->defaultValue);
slot->defaultSpecified = 1;
}
return(TRUE);
}
static int DefaultCompareSwapFunction(
void *theEnv,
DATA_OBJECT *item1,
DATA_OBJECT *item2)
{
DATA_OBJECT returnValue;
SortFunctionData(theEnv)->SortComparisonFunction->argList = GenConstant(theEnv,item1->type,item1->value);
SortFunctionData(theEnv)->SortComparisonFunction->argList->nextArg = GenConstant(theEnv,item2->type,item2->value);
ExpressionInstall(theEnv,SortFunctionData(theEnv)->SortComparisonFunction);
EvaluateExpression(theEnv,SortFunctionData(theEnv)->SortComparisonFunction,&returnValue);
ExpressionDeinstall(theEnv,SortFunctionData(theEnv)->SortComparisonFunction);
ReturnExpression(theEnv,SortFunctionData(theEnv)->SortComparisonFunction->argList);
SortFunctionData(theEnv)->SortComparisonFunction->argList = NULL;
if ((GetType(returnValue) == SYMBOL) &&
(GetValue(returnValue) == EnvFalseSymbol(theEnv)))
{ return(FALSE); }
return(TRUE);
}
/*****************************************************
NAME : AddHashedExpression
DESCRIPTION : Adds a new expression to the
expression hash table (or increments
the use count if it is already there)
INPUTS : The (new) expression
RETURNS : A pointer to the (new) hash node
SIDE EFFECTS : Adds the new hash node or increments
the count of an existing one
NOTES : It is the caller's responsibility to
delete the passed expression. This
routine copies, packs and installs
the given expression
*****************************************************/
globle EXPRESSION *AddHashedExpression(
EXPRESSION *exp)
{
EXPRESSION_HN *prv,*exphash;
unsigned hashval;
if (exp == NULL) return(NULL);
exphash = FindHashedExpression(exp,&hashval,&prv);
if (exphash != NULL)
{
exphash->count++;
return(exphash->exp);
}
exphash = get_struct(exprHashNode);
exphash->hashval = hashval;
exphash->count = 1;
exphash->exp = PackExpression(exp);
ExpressionInstall(exphash->exp);
exphash->nxt = ExpressionHashTable[exphash->hashval];
ExpressionHashTable[exphash->hashval] = exphash;
exphash->bsaveID = 0L;
return(exphash->exp);
}
/*********************************************************************
NAME : ParseDefinstances
DESCRIPTION : Parses and allocates a definstances construct
INPUTS : The logical name of the input source
RETURNS : FALSE if no errors, TRUE otherwise
SIDE EFFECTS : Definstances parsed and created
NOTES : H/L Syntax :
(definstances <name> [active] [<comment>]
<instance-definition>+)
<instance-definition> ::=
(<instance-name> of <class-name> <slot-override>*)
<slot-override> ::= (<slot-name> <value-expression>*)
*********************************************************************/
static int ParseDefinstances(
void *theEnv,
char *readSource)
{
SYMBOL_HN *dname;
void *mkinsfcall;
EXPRESSION *mkinstance,*mkbot = NULL;
DEFINSTANCES *dobj;
int active;
SetPPBufferStatus(theEnv,ON);
FlushPPBuffer(theEnv);
SetIndentDepth(theEnv,3);
SavePPBuffer(theEnv,(char*)"(definstances ");
#if BLOAD || BLOAD_AND_BSAVE
if ((Bloaded(theEnv)) && (! ConstructData(theEnv)->CheckSyntaxMode))
{
CannotLoadWithBloadMessage(theEnv,(char*)"definstances");
return(TRUE);
}
#endif
dname = ParseDefinstancesName(theEnv,readSource,&active);
if (dname == NULL)
return(TRUE);
dobj = get_struct(theEnv,definstances);
InitializeConstructHeader(theEnv,(char*)"definstances",(struct constructHeader *) dobj,dname);
dobj->busy = 0;
dobj->mkinstance = NULL;
#if DEFRULE_CONSTRUCT
if (active)
mkinsfcall = (void *) FindFunction(theEnv,(char*)"active-make-instance");
else
mkinsfcall = (void *) FindFunction(theEnv,(char*)"make-instance");
#else
mkinsfcall = (void *) FindFunction(theEnv,(char*)"make-instance");
#endif
while (GetType(DefclassData(theEnv)->ObjectParseToken) == LPAREN)
{
mkinstance = GenConstant(theEnv,UNKNOWN_VALUE,mkinsfcall);
mkinstance = ParseInitializeInstance(theEnv,mkinstance,readSource);
if (mkinstance == NULL)
{
ReturnExpression(theEnv,dobj->mkinstance);
rtn_struct(theEnv,definstances,dobj);
return(TRUE);
}
if (ExpressionContainsVariables(mkinstance,FALSE) == TRUE)
{
LocalVariableErrorMessage(theEnv,(char*)"definstances");
ReturnExpression(theEnv,mkinstance);
ReturnExpression(theEnv,dobj->mkinstance);
rtn_struct(theEnv,definstances,dobj);
return(TRUE);
}
if (mkbot == NULL)
dobj->mkinstance = mkinstance;
else
GetNextArgument(mkbot) = mkinstance;
mkbot = mkinstance;
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
PPBackup(theEnv);
PPCRAndIndent(theEnv);
SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm);
}
if (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN)
{
ReturnExpression(theEnv,dobj->mkinstance);
rtn_struct(theEnv,definstances,dobj);
SyntaxErrorMessage(theEnv,(char*)"definstances");
return(TRUE);
}
else
{
if (ConstructData(theEnv)->CheckSyntaxMode)
{
ReturnExpression(theEnv,dobj->mkinstance);
rtn_struct(theEnv,definstances,dobj);
return(FALSE);
}
#if DEBUGGING_FUNCTIONS
if (EnvGetConserveMemory(theEnv) == FALSE)
{
if (dobj->mkinstance != NULL)
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,(char*)")\n");
SetDefinstancesPPForm((void *) dobj,CopyPPBuffer(theEnv));
}
#endif
mkinstance = dobj->mkinstance;
dobj->mkinstance = PackExpression(theEnv,mkinstance);
ReturnExpression(theEnv,mkinstance);
IncrementSymbolCount(GetDefinstancesNamePointer((void *) dobj));
ExpressionInstall(theEnv,dobj->mkinstance);
}
AddConstructToModule((struct constructHeader *) dobj);
return(FALSE);
}
/***********************************************************************
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 : BuildCompositeFacets
DESCRIPTION : Composite slots are ones that get their facets
from more than one class. By default, the most
specific class in object's precedence list specifies
the complete set of facets for a slot. The composite
facet in a slot allows facets that are not overridden
by the most specific class to be obtained from other
classes.
Since all superclasses are predetermined before creating
a new class based on them, this routine need only
examine the immediately next most specific class for
extra facets. Even if that slot is also composite, the
other facets have already been filtered down. If the
slot is no-inherit, the next most specific class must
be examined.
INPUTS : 1) The slot descriptor
2) The class precedence list
3) The bitmap marking which facets were specified in
the original slot definition
RETURNS : Nothing useful
SIDE EFFECTS : Composite slot is updated to reflect facets from
a less specific class
NOTES : Assumes slot is composite
*************************************************************************/
static void BuildCompositeFacets(
void *theEnv,
EXEC_STATUS,
SLOT_DESC *sd,
PACKED_CLASS_LINKS *preclist,
char *specbits,
CONSTRAINT_PARSE_RECORD *parsedConstraint)
{
SLOT_DESC *compslot = NULL;
long i;
for (i = 1 ; i < preclist->classCount ; i++)
{
compslot = FindClassSlot(preclist->classArray[i],sd->slotName->name);
if ((compslot != NULL) ? (compslot->noInherit == 0) : FALSE)
break;
}
if (compslot != NULL)
{
if ((sd->defaultSpecified == 0) && (compslot->defaultSpecified == 1))
{
sd->dynamicDefault = compslot->dynamicDefault;
sd->noDefault = compslot->noDefault;
sd->defaultSpecified = 1;
if (compslot->defaultValue != NULL)
{
if (sd->dynamicDefault)
{
sd->defaultValue = (void *) PackExpression(theEnv,execStatus,(EXPRESSION *) compslot->defaultValue);
ExpressionInstall(theEnv,execStatus,(EXPRESSION *) sd->defaultValue);
}
else
{
sd->defaultValue = (void *) get_struct(theEnv,execStatus,dataObject);
GenCopyMemory(DATA_OBJECT,1,sd->defaultValue,compslot->defaultValue);
ValueInstall(theEnv,execStatus,(DATA_OBJECT *) sd->defaultValue);
}
}
}
if (TestBitMap(specbits,FIELD_BIT) == 0)
sd->multiple = compslot->multiple;
if (TestBitMap(specbits,STORAGE_BIT) == 0)
sd->shared = compslot->shared;
if (TestBitMap(specbits,ACCESS_BIT) == 0)
{
sd->noWrite = compslot->noWrite;
sd->initializeOnly = compslot->initializeOnly;
}
#if DEFRULE_CONSTRUCT
if (TestBitMap(specbits,MATCH_BIT) == 0)
sd->reactive = compslot->reactive;
#endif
if (TestBitMap(specbits,VISIBILITY_BIT) == 0)
sd->publicVisibility = compslot->publicVisibility;
if (TestBitMap(specbits,CREATE_ACCESSOR_BIT) == 0)
{
sd->createReadAccessor = compslot->createReadAccessor;
sd->createWriteAccessor = compslot->createWriteAccessor;
}
if ((TestBitMap(specbits,OVERRIDE_MSG_BIT) == 0) &&
compslot->overrideMessageSpecified)
{
DecrementSymbolCount(theEnv,execStatus,sd->overrideMessage);
sd->overrideMessage = compslot->overrideMessage;
IncrementSymbolCount(sd->overrideMessage);
sd->overrideMessageSpecified = TRUE;
}
OverlayConstraint(theEnv,execStatus,parsedConstraint,sd->constraint,compslot->constraint);
}
}
globle struct fact *StringToFact(
char *str)
{
struct token theToken;
struct fact *factPtr;
int numberOfFields = 0, whichField;
struct expr *assertArgs, *tempPtr;
int error = FALSE;
DATA_OBJECT theResult;
/*=========================================*/
/* Open a string router and parse the fact */
/* using the router as an input source. */
/*=========================================*/
OpenStringSource("assert_str",str,0);
assertArgs = GetRHSPattern("assert_str",&theToken,
&error,FALSE,TRUE,
TRUE,RPAREN);
CloseStringSource("assert_str");
#if CERTAINTY_FACTORS
/* GetRHSPattern called above may have left a token
in the lookahead Token (theUnToken) -- see GetRHSPattern and
Scanner.c -- clear it since we are closing the string source
and it should not be read when next token requested
NOTE: this may not be needed now that am not unGetting STOP tokens?
*/
ClearTheUnToken();
#endif
/*===========================================*/
/* Check for errors or the use of variables. */
/*===========================================*/
if (error)
{
ReturnExpression(assertArgs);
return(NULL);
}
if (ExpressionContainsVariables(assertArgs,FALSE))
{
LocalVariableErrorMessage("the assert-string function");
SetEvaluationError(TRUE);
ReturnExpression(assertArgs);
return(NULL);
}
/*=======================================================*/
/* Count the number of fields needed for the fact and */
/* create a fact data structure of the appropriate size. */
/*=======================================================*/
for (tempPtr = assertArgs->nextArg; tempPtr != NULL; tempPtr = tempPtr->nextArg)
{ numberOfFields++; }
factPtr = (struct fact *) CreateFactBySize(numberOfFields);
factPtr->whichDeftemplate = (struct deftemplate *) assertArgs->value;
#if CERTAINTY_FACTORS
/* get the CF from the argList of the DEFTEMPLATE_PTR expr struct currently
pointed at be assertArgs
*/
if (assertArgs->argList == NULL)
factPtr->factCF = 1.0;
else
{
EvaluateExpression(assertArgs->argList,&theResult);
if (theResult.type != FLOAT && theResult.type != INTEGER)
{
cfNonNumberError();
factPtr->factCF = 1.0;
}
else
factPtr->factCF = (theResult.type == FLOAT) ?
ValueToDouble(theResult.value) :
(double)ValueToLong(theResult.value);
}
#endif
/*=============================================*/
/* Copy the fields to the fact data structure. */
/*=============================================*/
ExpressionInstall(assertArgs); /* DR0836 */
whichField = 0;
for (tempPtr = assertArgs->nextArg; tempPtr != NULL; tempPtr = tempPtr->nextArg)
{
#if FUZZY_DEFTEMPLATES /* 03-07-96 */
/* NOTE: a fuzzy fact should have been parsed to give a single constant arg
of type FUZZY_VALUE
*/
#endif
EvaluateExpression(tempPtr,&theResult);
factPtr->theProposition.theFields[whichField].type = (short) theResult.type;
factPtr->theProposition.theFields[whichField].value = theResult.value;
whichField++;
}
ExpressionDeinstall(assertArgs); /* DR0836 */
ReturnExpression(assertArgs);
/*==================*/
/* Return the fact. */
/*==================*/
return(factPtr);
}
bool RouteCommand(
void *theEnv,
const char *command,
bool printResult)
{
DATA_OBJECT result;
struct expr *top;
const char *commandName;
struct token theToken;
int danglingConstructs;
if (command == NULL)
{ return(0); }
/*========================================*/
/* Open a string input source and get the */
/* first token from that source. */
/*========================================*/
OpenStringSource(theEnv,"command",command,0);
GetToken(theEnv,"command",&theToken);
/*=====================*/
/* Evaluate constants. */
/*=====================*/
if ((theToken.type == SYMBOL) || (theToken.type == STRING) ||
(theToken.type == FLOAT) || (theToken.type == INTEGER) ||
(theToken.type == INSTANCE_NAME))
{
CloseStringSource(theEnv,"command");
if (printResult)
{
PrintAtom(theEnv,STDOUT,theToken.type,theToken.value);
EnvPrintRouter(theEnv,STDOUT,"\n");
}
return(1);
}
/*=====================*/
/* Evaluate variables. */
/*=====================*/
if ((theToken.type == GBL_VARIABLE) ||
(theToken.type == SF_VARIABLE) ||
(theToken.type == MF_VARIABLE))
{
CloseStringSource(theEnv,"command");
top = GenConstant(theEnv,theToken.type,theToken.value);
EvaluateExpression(theEnv,top,&result);
rtn_struct(theEnv,expr,top);
if (printResult)
{
PrintDataObject(theEnv,STDOUT,&result);
EnvPrintRouter(theEnv,STDOUT,"\n");
}
return(1);
}
/*========================================================*/
/* If the next token isn't the beginning left parenthesis */
/* of a command or construct, then whatever was entered */
/* cannot be evaluated at the command prompt. */
/*========================================================*/
if (theToken.type != LPAREN)
{
PrintErrorID(theEnv,"COMMLINE",1,false);
EnvPrintRouter(theEnv,WERROR,"Expected a '(', constant, or variable\n");
CloseStringSource(theEnv,"command");
return(0);
}
/*===========================================================*/
/* The next token must be a function name or construct type. */
/*===========================================================*/
GetToken(theEnv,"command",&theToken);
if (theToken.type != SYMBOL)
{
PrintErrorID(theEnv,"COMMLINE",2,false);
EnvPrintRouter(theEnv,WERROR,"Expected a command.\n");
CloseStringSource(theEnv,"command");
return(0);
}
commandName = ValueToString(theToken.value);
/*======================*/
/* Evaluate constructs. */
/*======================*/
#if (! RUN_TIME) && (! BLOAD_ONLY)
{
int errorFlag;
errorFlag = ParseConstruct(theEnv,commandName,"command");
if (errorFlag != -1)
{
CloseStringSource(theEnv,"command");
if (errorFlag == 1)
{
EnvPrintRouter(theEnv,WERROR,"\nERROR:\n");
PrintInChunks(theEnv,WERROR,GetPPBuffer(theEnv));
EnvPrintRouter(theEnv,WERROR,"\n");
}
DestroyPPBuffer(theEnv);
if (errorFlag) return 0;
else return 1;
}
}
#endif
/*========================*/
/* Parse a function call. */
/*========================*/
danglingConstructs = ConstructData(theEnv)->DanglingConstructs;
CommandLineData(theEnv)->ParsingTopLevelCommand = true;
top = Function2Parse(theEnv,"command",commandName);
CommandLineData(theEnv)->ParsingTopLevelCommand = false;
ClearParsedBindNames(theEnv);
/*================================*/
/* Close the string input source. */
/*================================*/
CloseStringSource(theEnv,"command");
/*=========================*/
/* Evaluate function call. */
/*=========================*/
if (top == NULL)
{
ConstructData(theEnv)->DanglingConstructs = danglingConstructs;
return false;
}
ExpressionInstall(theEnv,top);
CommandLineData(theEnv)->EvaluatingTopLevelCommand = true;
CommandLineData(theEnv)->CurrentCommand = top;
EvaluateExpression(theEnv,top,&result);
CommandLineData(theEnv)->CurrentCommand = NULL;
CommandLineData(theEnv)->EvaluatingTopLevelCommand = false;
ExpressionDeinstall(theEnv,top);
ReturnExpression(theEnv,top);
ConstructData(theEnv)->DanglingConstructs = danglingConstructs;
/*=================================================*/
/* Print the return value of the function/command. */
/*=================================================*/
if ((result.type != RVOID) && printResult)
{
PrintDataObject(theEnv,STDOUT,&result);
EnvPrintRouter(theEnv,STDOUT,"\n");
}
return true;
}
globle int ParseDeffacts(
char *readSource)
{
#if (MAC_MPW || MAC_MCW) && (RUN_TIME || BLOAD_ONLY)
#pragma unused(readSource)
#endif
#if (! RUN_TIME) && (! BLOAD_ONLY)
SYMBOL_HN *deffactsName;
struct expr *temp;
struct deffacts *newDeffacts;
int deffactsError;
struct token inputToken;
/*=========================*/
/* Parsing initialization. */
/*=========================*/
deffactsError = FALSE;
SetPPBufferStatus(ON);
FlushPPBuffer();
SetIndentDepth(3);
SavePPBuffer("(deffacts ");
/*==========================================================*/
/* Deffacts can not be added when a binary image is loaded. */
/*==========================================================*/
#if BLOAD || BLOAD_AND_BSAVE
if ((Bloaded() == TRUE) && (! CheckSyntaxMode))
{
CannotLoadWithBloadMessage("deffacts");
return(TRUE);
}
#endif
/*============================*/
/* Parse the deffacts header. */
/*============================*/
deffactsName = GetConstructNameAndComment(readSource,&inputToken,"deffacts",
FindDeffacts,Undeffacts,"$",TRUE,
TRUE,TRUE);
if (deffactsName == NULL) { return(TRUE); }
/*===============================================*/
/* Parse the list of facts in the deffacts body. */
/*===============================================*/
temp = BuildRHSAssert(readSource,&inputToken,&deffactsError,FALSE,FALSE,"deffacts");
if (deffactsError == TRUE) { return(TRUE); }
if (ExpressionContainsVariables(temp,FALSE))
{
LocalVariableErrorMessage("a deffacts construct");
ReturnExpression(temp);
return(TRUE);
}
SavePPBuffer("\n");
/*==============================================*/
/* If we're only checking syntax, don't add the */
/* successfully parsed deffacts to the KB. */
/*==============================================*/
if (CheckSyntaxMode)
{
ReturnExpression(temp);
return(FALSE);
}
/*==========================*/
/* Create the new deffacts. */
/*==========================*/
ExpressionInstall(temp);
newDeffacts = get_struct(deffacts);
newDeffacts->header.name = deffactsName;
IncrementSymbolCount(deffactsName);
newDeffacts->assertList = PackExpression(temp);
newDeffacts->header.whichModule = (struct defmoduleItemHeader *)
GetModuleItem(NULL,FindModuleItem("deffacts")->moduleIndex);
newDeffacts->header.next = NULL;
newDeffacts->header.usrData = NULL;
ReturnExpression(temp);
/*=======================================================*/
/* Save the pretty print representation of the deffacts. */
/*=======================================================*/
if (GetConserveMemory() == TRUE)
{ newDeffacts->header.ppForm = NULL; }
else
{ newDeffacts->header.ppForm = CopyPPBuffer(); }
/*=============================================*/
/* Add the deffacts to the appropriate module. */
/*=============================================*/
AddConstructToModule(&newDeffacts->header);
#endif /* (! RUN_TIME) && (! BLOAD_ONLY) */
/*================================================================*/
/* Return FALSE to indicate the deffacts was successfully parsed. */
/*================================================================*/
return(FALSE);
}
globle struct fact *StringToFact(
void *theEnv,
char *str)
{
struct token theToken;
struct fact *factPtr;
unsigned numberOfFields = 0, whichField;
struct expr *assertArgs, *tempPtr;
int error = FALSE;
DATA_OBJECT theResult;
/*=========================================*/
/* Open a string router and parse the fact */
/* using the router as an input source. */
/*=========================================*/
SetEvaluationError(theEnv,FALSE);
OpenStringSource(theEnv,"assert_str",str,0);
assertArgs = GetRHSPattern(theEnv,"assert_str",&theToken,
&error,FALSE,TRUE,
TRUE,RPAREN);
CloseStringSource(theEnv,"assert_str");
/*===========================================*/
/* Check for errors or the use of variables. */
/*===========================================*/
if ((assertArgs == NULL) && (! error))
{
SyntaxErrorMessage(theEnv,"RHS patterns");
ReturnExpression(theEnv,assertArgs);
return(NULL);
}
if (error)
{
ReturnExpression(theEnv,assertArgs);
return(NULL);
}
if (ExpressionContainsVariables(assertArgs,FALSE))
{
LocalVariableErrorMessage(theEnv,"the assert-string function");
SetEvaluationError(theEnv,TRUE);
ReturnExpression(theEnv,assertArgs);
return(NULL);
}
/*=======================================================*/
/* Count the number of fields needed for the fact and */
/* create a fact data structure of the appropriate size. */
/*=======================================================*/
for (tempPtr = assertArgs->nextArg; tempPtr != NULL; tempPtr = tempPtr->nextArg)
{ numberOfFields++; }
factPtr = (struct fact *) CreateFactBySize(theEnv,numberOfFields);
factPtr->whichDeftemplate = (struct deftemplate *) assertArgs->value;
/*=============================================*/
/* Copy the fields to the fact data structure. */
/*=============================================*/
ExpressionInstall(theEnv,assertArgs); /* DR0836 */
whichField = 0;
for (tempPtr = assertArgs->nextArg; tempPtr != NULL; tempPtr = tempPtr->nextArg)
{
EvaluateExpression(theEnv,tempPtr,&theResult);
factPtr->theProposition.theFields[whichField].type = theResult.type;
factPtr->theProposition.theFields[whichField].value = theResult.value;
whichField++;
}
ExpressionDeinstall(theEnv,assertArgs); /* DR0836 */
ReturnExpression(theEnv,assertArgs);
/*==================*/
/* Return the fact. */
/*==================*/
return(factPtr);
}
/**************************************************************************
NAME : BuildCompositeFacets
DESCRIPTION : Composite slots are ones that get their facets
from more than one class. By default, the most
specific class in object's precedence list specifies
the complete set of facets for a slot. The composite
facet in a slot allows facets that are not overridden
by the most specific class to be obtained from other
classes.
Since all superclasses are predetermined before creating
a new class based on them, this routine need only
examine the immediately next most specific class for
extra facets. Even if that slot is also composite, the
other facets have already been filtered down. If the
slot is no-inherit, the next most specific class must
be examined.
INPUTS : 1) The slot descriptor
2) The class precedence list
3) The bitmap marking which facets were specified in
the original slot definition
RETURNS : Nothing useful
SIDE EFFECTS : Composite slot is updated to reflect facets from
a less specific class
NOTES : Assumes slot is composite
*************************************************************************/
static void BuildCompositeFacets(
Environment *theEnv,
SlotDescriptor *sd,
PACKED_CLASS_LINKS *preclist,
const char *specbits,
CONSTRAINT_PARSE_RECORD *parsedConstraint)
{
SlotDescriptor *compslot = NULL;
unsigned long i;
for (i = 1 ; i < preclist->classCount ; i++)
{
compslot = FindClassSlot(preclist->classArray[i],sd->slotName->name);
if ((compslot != NULL) ? (compslot->noInherit == 0) : false)
break;
}
if (compslot != NULL)
{
if ((sd->defaultSpecified == 0) && (compslot->defaultSpecified == 1))
{
sd->dynamicDefault = compslot->dynamicDefault;
sd->noDefault = compslot->noDefault;
sd->defaultSpecified = 1;
if (compslot->defaultValue != NULL)
{
if (sd->dynamicDefault)
{
sd->defaultValue = PackExpression(theEnv,(Expression *) compslot->defaultValue);
ExpressionInstall(theEnv,(Expression *) sd->defaultValue);
}
else
{
sd->defaultValue = get_struct(theEnv,udfValue);
GenCopyMemory(UDFValue,1,sd->defaultValue,compslot->defaultValue);
RetainUDFV(theEnv,(UDFValue *) sd->defaultValue);
}
}
}
if (! TestBitMap(specbits,FIELD_BIT))
sd->multiple = compslot->multiple;
if (! TestBitMap(specbits,STORAGE_BIT))
sd->shared = compslot->shared;
if (! TestBitMap(specbits,ACCESS_BIT))
{
sd->noWrite = compslot->noWrite;
sd->initializeOnly = compslot->initializeOnly;
}
#if DEFRULE_CONSTRUCT
if (! TestBitMap(specbits,MATCH_BIT))
sd->reactive = compslot->reactive;
#endif
if (! TestBitMap(specbits,VISIBILITY_BIT))
sd->publicVisibility = compslot->publicVisibility;
if (! TestBitMap(specbits,CREATE_ACCESSOR_BIT))
{
sd->createReadAccessor = compslot->createReadAccessor;
sd->createWriteAccessor = compslot->createWriteAccessor;
}
if ((! TestBitMap(specbits,OVERRIDE_MSG_BIT)) &&
compslot->overrideMessageSpecified)
{
ReleaseLexeme(theEnv,sd->overrideMessage);
sd->overrideMessage = compslot->overrideMessage;
IncrementLexemeCount(sd->overrideMessage);
sd->overrideMessageSpecified = true;
}
OverlayConstraint(theEnv,parsedConstraint,sd->constraint,compslot->constraint);
}
}
globle int EnvEval(
void *theEnv,
char *theString,
DATA_OBJECT_PTR returnValue)
{
struct expr *top;
int ov;
static int depth = 0;
char logicalNameBuffer[20];
struct BindInfo *oldBinds;
/*======================================================*/
/* Evaluate the string. Create a different logical name */
/* for use each time the eval function is called. */
/*======================================================*/
depth++;
sprintf(logicalNameBuffer,"Eval-%d",depth);
if (OpenStringSource(theEnv,logicalNameBuffer,theString,0) == 0)
{
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
depth--;
return(FALSE);
}
/*================================================*/
/* Save the current parsing state before routines */
/* are called to parse the eval string. */
/*================================================*/
ov = GetPPBufferStatus(theEnv);
SetPPBufferStatus(theEnv,FALSE);
oldBinds = GetParsedBindNames(theEnv);
SetParsedBindNames(theEnv,NULL);
/*========================================================*/
/* Parse the string argument passed to the eval function. */
/*========================================================*/
top = ParseAtomOrExpression(theEnv,logicalNameBuffer,NULL);
/*============================*/
/* Restore the parsing state. */
/*============================*/
SetPPBufferStatus(theEnv,ov);
ClearParsedBindNames(theEnv);
SetParsedBindNames(theEnv,oldBinds);
/*===========================================*/
/* Return if an error occured while parsing. */
/*===========================================*/
if (top == NULL)
{
SetEvaluationError(theEnv,TRUE);
CloseStringSource(theEnv,logicalNameBuffer);
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
depth--;
return(FALSE);
}
/*==============================================*/
/* The sequence expansion operator must be used */
/* within the argument list of a function call. */
/*==============================================*/
if ((top->type == MF_GBL_VARIABLE) || (top->type == MF_VARIABLE))
{
PrintErrorID(theEnv,"MISCFUN",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"expand$ must be used in the argument list of a function call.\n");
SetEvaluationError(theEnv,TRUE);
CloseStringSource(theEnv,logicalNameBuffer);
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
ReturnExpression(theEnv,top);
depth--;
return(FALSE);
}
/*=======================================*/
/* The expression to be evaluated cannot */
/* contain any local variables. */
/*=======================================*/
if (ExpressionContainsVariables(top,FALSE))
{
PrintErrorID(theEnv,"STRNGFUN",2,FALSE);
EnvPrintRouter(theEnv,WERROR,"Some variables could not be accessed by the eval function.\n");
SetEvaluationError(theEnv,TRUE);
CloseStringSource(theEnv,logicalNameBuffer);
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
ReturnExpression(theEnv,top);
depth--;
return(FALSE);
}
/*====================================*/
/* Evaluate the expression and return */
/* the memory used to parse it. */
/*====================================*/
ExpressionInstall(theEnv,top);
EvaluateExpression(theEnv,top,returnValue);
ExpressionDeinstall(theEnv,top);
depth--;
ReturnExpression(theEnv,top);
CloseStringSource(theEnv,logicalNameBuffer);
if (GetEvaluationError(theEnv)) return(FALSE);
return(TRUE);
}
globle void FuncallFunction(
void *theEnv,
DATA_OBJECT *returnValue)
{
int argCount, i, j;
DATA_OBJECT theValue;
FUNCTION_REFERENCE theReference;
char *name;
struct multifield *theMultifield;
struct expr *lastAdd = NULL, *nextAdd, *multiAdd;
/*==================================*/
/* Set up the default return value. */
/*==================================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
/*=================================================*/
/* The funcall function has at least one argument: */
/* the name of the function being called. */
/*=================================================*/
if ((argCount = EnvArgCountCheck(theEnv,"funcall",AT_LEAST,1)) == -1) return;
/*============================================*/
/* Get the name of the function to be called. */
/*============================================*/
if (EnvArgTypeCheck(theEnv,"funcall",1,SYMBOL_OR_STRING,&theValue) == FALSE)
{
return;
}
/*====================*/
/* Find the function. */
/*====================*/
name = DOToString(theValue);
if (! GetFunctionReference(theEnv,name,&theReference))
{
ExpectedTypeError1(theEnv,"funcall",1,"function, deffunction, or generic function name");
return;
}
ExpressionInstall(theEnv,&theReference);
/*======================================*/
/* Add the arguments to the expression. */
/*======================================*/
for (i = 2; i <= argCount; i++)
{
EnvRtnUnknown(theEnv,i,&theValue);
if (GetEvaluationError(theEnv))
{
ExpressionDeinstall(theEnv,&theReference);
return;
}
switch(GetType(theValue))
{
case MULTIFIELD:
nextAdd = GenConstant(theEnv,FCALL,(void *) FindFunction(theEnv,"create$"));
if (lastAdd == NULL)
{
theReference.argList = nextAdd;
}
else
{
lastAdd->nextArg = nextAdd;
}
lastAdd = nextAdd;
multiAdd = NULL;
theMultifield = (struct multifield *) GetValue(theValue);
for (j = GetDOBegin(theValue); j <= GetDOEnd(theValue); j++)
{
nextAdd = GenConstant(theEnv,GetMFType(theMultifield,j),GetMFValue(theMultifield,j));
if (multiAdd == NULL)
{
lastAdd->argList = nextAdd;
}
else
{
multiAdd->nextArg = nextAdd;
}
multiAdd = nextAdd;
}
ExpressionInstall(theEnv,lastAdd);
break;
default:
nextAdd = GenConstant(theEnv,GetType(theValue),GetValue(theValue));
if (lastAdd == NULL)
{
theReference.argList = nextAdd;
}
else
{
lastAdd->nextArg = nextAdd;
}
lastAdd = nextAdd;
ExpressionInstall(theEnv,lastAdd);
break;
}
}
/*===========================================================*/
/* Verify a deffunction has the correct number of arguments. */
/*===========================================================*/
#if DEFFUNCTION_CONSTRUCT
if (theReference.type == PCALL)
{
if (CheckDeffunctionCall(theEnv,theReference.value,CountArguments(theReference.argList)) == FALSE)
{
PrintErrorID(theEnv,"MISCFUN",4,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function funcall called with the wrong number of arguments for deffunction ");
EnvPrintRouter(theEnv,WERROR,EnvGetDeffunctionName(theEnv,theReference.value));
EnvPrintRouter(theEnv,WERROR,"\n");
ExpressionDeinstall(theEnv,&theReference);
ReturnExpression(theEnv,theReference.argList);
return;
}
}
#endif
/*======================*/
/* Call the expression. */
/*======================*/
EvaluateExpression(theEnv,&theReference,returnValue);
/*========================================*/
/* Return the expression data structures. */
/*========================================*/
ExpressionDeinstall(theEnv,&theReference);
ReturnExpression(theEnv,theReference.argList);
}
bool ParseDeffacts(
Environment *theEnv,
const char *readSource)
{
#if (! RUN_TIME) && (! BLOAD_ONLY)
CLIPSLexeme *deffactsName;
struct expr *temp;
Deffacts *newDeffacts;
bool deffactsError;
struct token inputToken;
/*=========================*/
/* Parsing initialization. */
/*=========================*/
deffactsError = false;
SetPPBufferStatus(theEnv,true);
FlushPPBuffer(theEnv);
SetIndentDepth(theEnv,3);
SavePPBuffer(theEnv,"(deffacts ");
/*==========================================================*/
/* Deffacts can not be added when a binary image is loaded. */
/*==========================================================*/
#if BLOAD || BLOAD_AND_BSAVE
if ((Bloaded(theEnv) == true) && (! ConstructData(theEnv)->CheckSyntaxMode))
{
CannotLoadWithBloadMessage(theEnv,"deffacts");
return true;
}
#endif
/*============================*/
/* Parse the deffacts header. */
/*============================*/
deffactsName = GetConstructNameAndComment(theEnv,readSource,&inputToken,"deffacts",
(FindConstructFunction *) FindDeffactsInModule,
(DeleteConstructFunction *) Undeffacts,"$",true,
true,true,false);
if (deffactsName == NULL) { return true; }
/*===============================================*/
/* Parse the list of facts in the deffacts body. */
/*===============================================*/
temp = BuildRHSAssert(theEnv,readSource,&inputToken,&deffactsError,false,false,"deffacts");
if (deffactsError == true) { return true; }
if (ExpressionContainsVariables(temp,false))
{
LocalVariableErrorMessage(theEnv,"a deffacts construct");
ReturnExpression(theEnv,temp);
return true;
}
SavePPBuffer(theEnv,"\n");
/*==============================================*/
/* If we're only checking syntax, don't add the */
/* successfully parsed deffacts to the KB. */
/*==============================================*/
if (ConstructData(theEnv)->CheckSyntaxMode)
{
ReturnExpression(theEnv,temp);
return false;
}
/*==========================*/
/* Create the new deffacts. */
/*==========================*/
ExpressionInstall(theEnv,temp);
newDeffacts = get_struct(theEnv,deffacts);
IncrementLexemeCount(deffactsName);
InitializeConstructHeader(theEnv,"deffacts",DEFFACTS,&newDeffacts->header,deffactsName);
newDeffacts->assertList = PackExpression(theEnv,temp);
ReturnExpression(theEnv,temp);
/*=======================================================*/
/* Save the pretty print representation of the deffacts. */
/*=======================================================*/
if (GetConserveMemory(theEnv) == true)
{ newDeffacts->header.ppForm = NULL; }
else
{ newDeffacts->header.ppForm = CopyPPBuffer(theEnv); }
/*=============================================*/
/* Add the deffacts to the appropriate module. */
/*=============================================*/
AddConstructToModule(&newDeffacts->header);
#endif /* (! RUN_TIME) && (! BLOAD_ONLY) */
/*================================================================*/
/* Return false to indicate the deffacts was successfully parsed. */
/*================================================================*/
return false;
}
static struct defrule *ProcessRuleLHS(
void *theEnv,
struct lhsParseNode *theLHS,
struct expr *actions,
SYMBOL_HN *ruleName,
int *error)
{
struct lhsParseNode *tempNode = NULL;
struct defrule *topDisjunct = NULL, *currentDisjunct, *lastDisjunct = NULL;
struct expr *newActions, *packPtr;
int logicalJoin;
int localVarCnt;
int complexity;
struct joinNode *lastJoin;
intBool emptyLHS;
/*================================================*/
/* Initially set the parsing error flag to FALSE. */
/*================================================*/
*error = FALSE;
/*===========================================================*/
/* The top level of the construct representing the LHS of a */
/* rule is assumed to be an OR. If the implied OR is at the */
/* top level of the pattern construct, then remove it. */
/*===========================================================*/
if (theLHS == NULL)
{ emptyLHS = TRUE; }
else
{
emptyLHS = FALSE;
if (theLHS->type == OR_CE) theLHS = theLHS->right;
}
/*=========================================*/
/* Loop through each disjunct of the rule. */
/*=========================================*/
localVarCnt = CountParsedBindNames(theEnv);
while ((theLHS != NULL) || (emptyLHS == TRUE))
{
/*===================================*/
/* Analyze the LHS of this disjunct. */
/*===================================*/
if (emptyLHS)
{ tempNode = NULL; }
else
{
if (theLHS->type == AND_CE) tempNode = theLHS->right;
else if (theLHS->type == PATTERN_CE) tempNode = theLHS;
}
if (VariableAnalysis(theEnv,tempNode))
{
*error = TRUE;
ReturnDefrule(theEnv,topDisjunct);
return(NULL);
}
/*=========================================*/
/* Perform entity dependent post analysis. */
/*=========================================*/
if (PostPatternAnalysis(theEnv,tempNode))
{
*error = TRUE;
ReturnDefrule(theEnv,topDisjunct);
return(NULL);
}
/*========================================================*/
/* Print out developer information if it's being watched. */
/*========================================================*/
#if DEVELOPER && DEBUGGING_FUNCTIONS
if (EnvGetWatchItem(theEnv,"rule-analysis"))
{ DumpRuleAnalysis(theEnv,tempNode); }
#endif
/*========================================*/
/* Check to see that logical CEs are used */
/* appropriately in the LHS of the rule. */
/*========================================*/
if ((logicalJoin = LogicalAnalysis(theEnv,tempNode)) < 0)
{
*error = TRUE;
ReturnDefrule(theEnv,topDisjunct);
return(NULL);
}
/*======================================================*/
/* Check to see if there are any RHS constraint errors. */
/*======================================================*/
if (CheckRHSForConstraintErrors(theEnv,actions,tempNode))
{
*error = TRUE;
ReturnDefrule(theEnv,topDisjunct);
return(NULL);
}
/*=================================================*/
/* Replace variable references in the RHS with the */
/* appropriate variable retrieval functions. */
/*=================================================*/
newActions = CopyExpression(theEnv,actions);
if (ReplaceProcVars(theEnv,"RHS of defrule",newActions,NULL,NULL,
ReplaceRHSVariable,(void *) tempNode))
{
*error = TRUE;
ReturnDefrule(theEnv,topDisjunct);
ReturnExpression(theEnv,newActions);
return(NULL);
}
/*==================================*/
/* We're finished for this disjunct */
/* if we're only checking syntax. */
/*==================================*/
if (ConstructData(theEnv)->CheckSyntaxMode)
{
ReturnExpression(theEnv,newActions);
if (emptyLHS)
{ emptyLHS = FALSE; }
else
{ theLHS = theLHS->bottom; }
continue;
}
/*=================================*/
/* Install the disjunct's actions. */
/*=================================*/
ExpressionInstall(theEnv,newActions);
packPtr = PackExpression(theEnv,newActions);
ReturnExpression(theEnv,newActions);
/*===============================================================*/
/* Create the pattern and join data structures for the new rule. */
/*===============================================================*/
lastJoin = ConstructJoins(theEnv,logicalJoin,tempNode,1,NULL,TRUE,TRUE);
/*===================================================================*/
/* Determine the rule's complexity for use with conflict resolution. */
/*===================================================================*/
complexity = RuleComplexity(theEnv,tempNode);
/*=====================================================*/
/* Create the defrule data structure for this disjunct */
/* and put it in the list of disjuncts for this rule. */
/*=====================================================*/
currentDisjunct = CreateNewDisjunct(theEnv,ruleName,localVarCnt,packPtr,complexity,
(unsigned) logicalJoin,lastJoin);
/*============================================================*/
/* Place the disjunct in the list of disjuncts for this rule. */
/* If the disjunct is the first disjunct, then increment the */
/* reference counts for the dynamic salience (the expression */
/* for the dynamic salience is only stored with the first */
/* disjuncts and the other disjuncts refer back to the first */
/* disjunct for their dynamic salience value. */
/*============================================================*/
if (topDisjunct == NULL)
{
topDisjunct = currentDisjunct;
ExpressionInstall(theEnv,topDisjunct->dynamicSalience);
}
else lastDisjunct->disjunct = currentDisjunct;
/*===========================================*/
/* Move on to the next disjunct of the rule. */
/*===========================================*/
lastDisjunct = currentDisjunct;
if (emptyLHS)
{ emptyLHS = FALSE; }
else
{ theLHS = theLHS->bottom; }
}
return(topDisjunct);
}
/****************************************************
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);
}
static struct defrule *ProcessRuleLHS(
void *theEnv,
struct lhsParseNode *theLHS,
struct expr *actions,
SYMBOL_HN *ruleName,
int *error)
{
struct lhsParseNode *tempNode = NULL;
struct defrule *topDisjunct = NULL, *currentDisjunct, *lastDisjunct = NULL;
struct expr *newActions, *packPtr;
int logicalJoin;
int localVarCnt;
int complexity;
struct joinNode *lastJoin;
intBool emptyLHS;
/*================================================*/
/* Initially set the parsing error flag to FALSE. */
/*================================================*/
*error = FALSE;
/*===========================================================*/
/* The top level of the construct representing the LHS of a */
/* rule is assumed to be an OR. If the implied OR is at the */
/* top level of the pattern construct, then remove it. */
/*===========================================================*/
if (theLHS == NULL)
{ emptyLHS = TRUE; }
else
{
emptyLHS = FALSE;
if (theLHS->type == OR_CE) theLHS = theLHS->right;
}
/*=========================================*/
/* Loop through each disjunct of the rule. */
/*=========================================*/
localVarCnt = CountParsedBindNames(theEnv);
while ((theLHS != NULL) || (emptyLHS == TRUE))
{
#if FUZZY_DEFTEMPLATES
unsigned int LHSRuleType; /* LHSRuleType is set to FUZZY_LHS or CRISP_LHS */
unsigned int numFuzzySlots;
int patternNum;
#endif
/*===================================*/
/* Analyze the LHS of this disjunct. */
/*===================================*/
if (emptyLHS)
{ tempNode = NULL; }
else
{
if (theLHS->type == AND_CE) tempNode = theLHS->right;
else if (theLHS->type == PATTERN_CE) tempNode = theLHS;
}
if (VariableAnalysis(theEnv,tempNode))
{
*error = TRUE;
ReturnDefrule(theEnv,topDisjunct);
return(NULL);
}
/*=========================================*/
/* Perform entity dependent post analysis. */
/*=========================================*/
if (PostPatternAnalysis(theEnv,tempNode))
{
*error = TRUE;
ReturnDefrule(theEnv,topDisjunct);
return(NULL);
}
#if FUZZY_DEFTEMPLATES
/* calculate the number of fuzzy value slots in patterns with
the rule disjunct and also determine LHS type of the
rule -- if number of fuzzy slots in non-NOT patterns >0
then FUZZY LHS [if pattern is (not (xxx (fuzzySlot ...) ...))
then they don't count when considering the LHS type]
*/
if (emptyLHS)
{ tempNode = NULL; }
else
{
if (theLHS->type == AND_CE) tempNode = theLHS->right;
else if (theLHS->type == PATTERN_CE) tempNode = theLHS;
}
{
int numFuzzySlotsInNonNotPatterns = 0;
numFuzzySlots = FuzzySlotAnalysis(theEnv,tempNode, &numFuzzySlotsInNonNotPatterns);
if (numFuzzySlotsInNonNotPatterns > 0)
LHSRuleType = FUZZY_LHS;
else
LHSRuleType = CRISP_LHS;
}
#endif
/*========================================================*/
/* Print out developer information if it's being watched. */
/*========================================================*/
#if DEVELOPER && DEBUGGING_FUNCTIONS
if (EnvGetWatchItem(theEnv,"rule-analysis"))
{ DumpRuleAnalysis(theEnv,tempNode); }
#endif
/*======================================================*/
/* Check to see if there are any RHS constraint errors. */
/*======================================================*/
if (CheckRHSForConstraintErrors(theEnv,actions,tempNode))
{
*error = TRUE;
ReturnDefrule(theEnv,topDisjunct);
return(NULL);
}
/*=================================================*/
/* Replace variable references in the RHS with the */
/* appropriate variable retrieval functions. */
/*=================================================*/
newActions = CopyExpression(theEnv,actions);
if (ReplaceProcVars(theEnv,"RHS of defrule",newActions,NULL,NULL,
ReplaceRHSVariable,(void *) tempNode))
{
*error = TRUE;
ReturnDefrule(theEnv,topDisjunct);
ReturnExpression(theEnv,newActions);
return(NULL);
}
/*===================================================*/
/* Remove any test CEs from the LHS and attach their */
/* expression to the closest preceeding non-negated */
/* join at the same not/and depth. */
/*===================================================*/
AttachTestCEsToPatternCEs(theEnv,tempNode);
/*========================================*/
/* Check to see that logical CEs are used */
/* appropriately in the LHS of the rule. */
/*========================================*/
if ((logicalJoin = LogicalAnalysis(theEnv,tempNode)) < 0)
{
*error = TRUE;
ReturnDefrule(theEnv,topDisjunct);
ReturnExpression(theEnv,newActions);
return(NULL);
}
/*==================================*/
/* We're finished for this disjunct */
/* if we're only checking syntax. */
/*==================================*/
if (ConstructData(theEnv)->CheckSyntaxMode)
{
ReturnExpression(theEnv,newActions);
if (emptyLHS)
{ emptyLHS = FALSE; }
else
{ theLHS = theLHS->bottom; }
continue;
}
/*=================================*/
/* Install the disjunct's actions. */
/*=================================*/
ExpressionInstall(theEnv,newActions);
packPtr = PackExpression(theEnv,newActions);
ReturnExpression(theEnv,newActions);
/*===============================================================*/
/* Create the pattern and join data structures for the new rule. */
/*===============================================================*/
lastJoin = ConstructJoins(theEnv,logicalJoin,tempNode,1,NULL,TRUE,TRUE);
/*===================================================================*/
/* Determine the rule's complexity for use with conflict resolution. */
/*===================================================================*/
complexity = RuleComplexity(theEnv,tempNode);
/*=====================================================*/
/* Create the defrule data structure for this disjunct */
/* and put it in the list of disjuncts for this rule. */
/*=====================================================*/
#if FUZZY_DEFTEMPLATES
/* if not a FUZZY LHS then no need to allocate space to store ptrs to
fuzzy slots of the patterns on the LHS since there won't be any
-- numFuzzySlots will be 0.
*/
currentDisjunct = CreateNewDisjunct(theEnv,ruleName,localVarCnt,packPtr,complexity,
logicalJoin,lastJoin,numFuzzySlots);
/* set the type of LHS of Rule disjunct and also
save fuzzy slot locator info for any fuzzy patterns
*/
currentDisjunct->lhsRuleType = LHSRuleType;
if (numFuzzySlots > 0)
{
struct lhsParseNode *lhsPNPtr, *lhsSlotPtr;
int i;
/* get ptr to a pattern CE */
if (theLHS->type == AND_CE) lhsPNPtr = theLHS->right;
else if (theLHS->type == PATTERN_CE) lhsPNPtr = theLHS;
else lhsPNPtr = NULL;
patternNum = 0; /* indexed from 0 */
i = 0;
while (lhsPNPtr != NULL)
{
if (lhsPNPtr->type == PATTERN_CE)
{
lhsSlotPtr = lhsPNPtr->right;
while (lhsSlotPtr != NULL)
{
/*==========================================================*/
/* If fuzzy template slot then save ptr to fuzzy value */
/* */
/* NOTE: when the pattern was added to the pattern net, the */
/* pattern node for the template name was removed (see */
/* PlaceFactPattern) and the pattern node of the FUZZY_VALUE*/
/* was changed a networkTest link in the SF_VARIABLE or */
/* SF_WILDCARD node as an SCALL_PN_FUZZY_VALUE expression. */
/* We need to search for that fuzzy value to put it in the */
/* rule (pattern_fv_arrayPtr points to an array of */
/* structures that holds the pattern number, slot number and*/
/* fuzzy value HN ptrs connected to the patterns of LHS). */
/*==========================================================*/
if (lhsSlotPtr->type == SF_WILDCARD ||
lhsSlotPtr->type == SF_VARIABLE)
{
FUZZY_VALUE_HN *fv_ptr;
struct fzSlotLocator * fzSL_ptr;
fv_ptr = findFuzzyValueInNetworktest(lhsSlotPtr->networkTest);
if (fv_ptr != NULL)
{
fzSL_ptr = currentDisjunct->pattern_fv_arrayPtr + i;
fzSL_ptr->patternNum = patternNum;
fzSL_ptr->slotNum = (lhsSlotPtr->slotNumber)-1;
fzSL_ptr->fvhnPtr = fv_ptr;
i++;
}
}
/*=====================================================*/
/* Move on to the next slot in the pattern. */
/*=====================================================*/
lhsSlotPtr = lhsSlotPtr->right;
}
}
/*=====================================================*/
/* Move on to the next pattern in the LHS of the rule. */
/*=====================================================*/
lhsPNPtr = lhsPNPtr->bottom;
patternNum++;
}
/* i should == numFuzzySlots OR something internal is screwed up --
OR this algorithm has a problem.
*/
if (i != numFuzzySlots)
{
EnvPrintRouter(theEnv,WERROR,"Internal ERROR *** Fuzzy structures -- routine ProcessRuleLHS\n");
EnvExitRouter(theEnv,EXIT_FAILURE);
}
}
#else
currentDisjunct = CreateNewDisjunct(theEnv,ruleName,localVarCnt,packPtr,complexity,
(unsigned) logicalJoin,lastJoin);
#endif
/*============================================================*/
/* Place the disjunct in the list of disjuncts for this rule. */
/* If the disjunct is the first disjunct, then increment the */
/* reference counts for the dynamic salience (the expression */
/* for the dynamic salience is only stored with the first */
/* disjuncts and the other disjuncts refer back to the first */
/* disjunct for their dynamic salience value. */
/*============================================================*/
if (topDisjunct == NULL)
{
topDisjunct = currentDisjunct;
ExpressionInstall(theEnv,topDisjunct->dynamicSalience);
#if CERTAINTY_FACTORS
ExpressionInstall(theEnv,topDisjunct->dynamicCF);
#endif
}
else lastDisjunct->disjunct = currentDisjunct;
/*===========================================*/
/* Move on to the next disjunct of the rule. */
/*===========================================*/
lastDisjunct = currentDisjunct;
if (emptyLHS)
{ emptyLHS = FALSE; }
else
{ theLHS = theLHS->bottom; }
}
return(topDisjunct);
}
