static int GetcString(
void *theEnv,
char *logicalName)
{
struct stringRouter *head;
int rc;
head = FindStringRouter(theEnv,logicalName);
if (head == NULL)
{
SystemError(theEnv,(char*)"ROUTER",1);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
if (head->readWriteType != READ_STRING) return(EOF);
if (head->currentPosition >= head->maximumPosition)
{
head->currentPosition++;
return(EOF);
}
rc = (unsigned char) head->str[head->currentPosition];
head->currentPosition++;
return(rc);
}
globle void *RequestChunk(
void *theEnv,
size_t requestSize)
{
struct chunkInfo *chunkPtr;
struct blockInfo *blockPtr;
/*==================================================*/
/* Allocate initial memory pool block if it has not */
/* already been allocated. */
/*==================================================*/
if (MemoryData(theEnv)->BlockMemoryInitialized == FALSE)
{
if (InitializeBlockMemory(theEnv,requestSize) == 0) return(NULL);
}
/*====================================================*/
/* Make sure that the amount of memory requested will */
/* fall on a boundary of strictest alignment */
/*====================================================*/
requestSize = (((requestSize - 1) / STRICT_ALIGN_SIZE) + 1) * STRICT_ALIGN_SIZE;
/*=====================================================*/
/* Search through the list of free memory for a block */
/* of the appropriate size. If a block is found, then */
/* allocate and return a pointer to it. */
/*=====================================================*/
blockPtr = MemoryData(theEnv)->TopMemoryBlock;
while (blockPtr != NULL)
{
chunkPtr = blockPtr->nextFree;
while (chunkPtr != NULL)
{
if ((chunkPtr->size == requestSize) ||
(chunkPtr->size > (requestSize + MemoryData(theEnv)->ChunkInfoSize)))
{
AllocateChunk(theEnv,blockPtr,chunkPtr,requestSize);
return((void *) (((char *) chunkPtr) + MemoryData(theEnv)->ChunkInfoSize));
}
chunkPtr = chunkPtr->nextFree;
}
if (blockPtr->nextBlock == NULL)
{
if (AllocateBlock(theEnv,blockPtr,requestSize) == 0) /* get another block */
{ return(NULL); }
}
blockPtr = blockPtr->nextBlock;
}
SystemError(theEnv,(char*)"MEMORY",2);
EnvExitRouter(theEnv,EXIT_FAILURE);
return(NULL); /* Unreachable, but prevents warning. */
}
globle void InitializeConstraints(
void *theEnv)
{
#if (! RUN_TIME) && (! BLOAD_ONLY)
int i;
#endif
AllocateEnvironmentData(theEnv,CONSTRAINT_DATA,sizeof(struct constraintData),DeallocateConstraintData);
ConstraintData(theEnv)->StaticConstraintChecking = TRUE;
#if (! RUN_TIME) && (! BLOAD_ONLY)
ConstraintData(theEnv)->ConstraintHashtable = (struct constraintRecord **)
gm2(theEnv,(int) sizeof (struct constraintRecord *) *
SIZE_CONSTRAINT_HASH);
if (ConstraintData(theEnv)->ConstraintHashtable == NULL) EnvExitRouter(theEnv,EXIT_FAILURE);
for (i = 0; i < SIZE_CONSTRAINT_HASH; i++) ConstraintData(theEnv)->ConstraintHashtable[i] = NULL;
#endif
#if (! RUN_TIME)
EnvDefineFunction2(theEnv,"get-dynamic-constraint-checking",'b',GDCCommand,"GDCCommand", "00");
EnvDefineFunction2(theEnv,"set-dynamic-constraint-checking",'b',SDCCommand,"SDCCommand", "11");
EnvDefineFunction2(theEnv,"get-static-constraint-checking",'b',GSCCommand,"GSCCommand", "00");
EnvDefineFunction2(theEnv,"set-static-constraint-checking",'b',SSCCommand,"SSCCommand", "11");
#endif
}
globle void InitializeMemory(
void *theEnv)
{
AllocateEnvironmentData(theEnv,MEMORY_DATA,sizeof(struct memoryData),NULL);
MemoryData(theEnv)->OutOfMemoryFunction = DefaultOutOfMemoryFunction;
#if (MEM_TABLE_SIZE > 0)
MemoryData(theEnv)->MemoryTable = (struct memoryPtr **)
malloc((STD_SIZE) (sizeof(struct memoryPtr *) * MEM_TABLE_SIZE));
if (MemoryData(theEnv)->MemoryTable == NULL)
{
PrintErrorID(theEnv,"MEMORY",1,TRUE);
EnvPrintRouter(theEnv,WERROR,"Out of memory.\n");
EnvExitRouter(theEnv,EXIT_FAILURE);
}
else
{
int i;
for (i = 0; i < MEM_TABLE_SIZE; i++) MemoryData(theEnv)->MemoryTable[i] = NULL;
}
#else // MEM_TABLE_SIZE == 0
MemoryData(theEnv)->MemoryTable = NULL;
#endif
}
static int PrintString(
void *theEnv,
char *logicalName,
char *str)
{
struct stringRouter *head;
head = FindStringRouter(theEnv,logicalName);
if (head == NULL)
{
SystemError(theEnv,(char*)"ROUTER",3);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
if (head->readWriteType != WRITE_STRING) return(1);
if (head->maximumPosition == 0) return(1);
if ((head->currentPosition + 1) >= head->maximumPosition) return(1);
genstrncpy(&head->str[head->currentPosition],
str,(STD_SIZE) (head->maximumPosition - head->currentPosition) - 1);
head->currentPosition += strlen(str);
return(1);
}
globle void ExitCommand(
void *theEnv)
{
int argCnt;
int status;
if ((argCnt = EnvArgCountCheck(theEnv,"exit",NO_MORE_THAN,1)) == -1) return;
if (argCnt == 0)
{ EnvExitRouter(theEnv,EXIT_SUCCESS); }
else
{
status = (int) EnvRtnLong(theEnv,1);
if (GetEvaluationError(theEnv)) return;
EnvExitRouter(theEnv,status);
}
return;
}
/*******************************************************************************
Name: InitializeInterface
Description: initializes the the X window interface
Arguments: None
Returns: None
*******************************************************************************/
void InitializeInterface()
{
void *theEnv = GetCurrentEnvironment();
if (! InitalizeLogTable())
{
EnvPrintRouter(theEnv,"werror", "Could not initialize logical name hash table\n");
XclipsExit(theEnv,0);
EnvExitRouter(theEnv,0);
}
//SetDribbleStatusFunction(GetCurrentEnvironment(),NULL);
/*==================================================================*/
/* Tell CLIPS which GetEvent function to call when an event needed. */
/*==================================================================*/
SetEventFunction(theEnv,GetEvent);
/* SetMemoryStatusFunction((int(*)())ActivateTheMenus());*/
/*=================================================*/
/* Tell CLIPS which function to call periodically. */
/*=================================================*/
EnvAddPeriodicFunction(theEnv,"PeriodicUpdate",PeriodicUpdate,90);
/*========================*/
/* Add a main I/O router. */
/*========================*/
if (! EnvAddRouter(theEnv,"wclips", 10, XclipsQuery, XclipsPrint, XclipsGetc, XclipsUngetc,
XclipsExit))
{
printf("Could not allocate xclips router!\n");
XclipsExit(theEnv,0);
EnvExitRouter(theEnv,0);
}
EnvPrintRouter(theEnv,"wclips", " XCLIPS for:");
}
globle int DefaultOutOfMemoryFunction(
void *theEnv,
unsigned long size)
{
#if MAC_MCW || IBM_MCW || MAC_XCD
#pragma unused(size)
#endif
PrintErrorID(theEnv,"MEMORY",1,TRUE);
EnvPrintRouter(theEnv,WERROR,"Out of memory.\n");
EnvExitRouter(theEnv,EXIT_FAILURE);
return(TRUE);
}
globle void InstallPrimitive(
void *theEnv,
struct entityRecord *thePrimitive,
int whichPosition)
{
if (EvaluationData(theEnv)->PrimitivesArray[whichPosition] != NULL)
{
SystemError(theEnv,"EVALUATN",5);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
EvaluationData(theEnv)->PrimitivesArray[whichPosition] = thePrimitive;
}
globle int DefaultOutOfMemoryFunction(
void *theEnv,
size_t size)
{
#if MAC_MCW || WIN_MCW || MAC_XCD
#pragma unused(size)
#endif
PrintErrorID(theEnv,(char*)"MEMORY",1,TRUE);
EnvPrintRouter(theEnv,WERROR,(char*)"Out of memory.\n");
EnvExitRouter(theEnv,EXIT_FAILURE);
return(TRUE);
}
void ExitCommand(
UDFContext *context,
CLIPSValue *returnValue)
{
int argCnt;
int status;
CLIPSValue value;
Environment *theEnv = UDFContextEnvironment(context);
argCnt = UDFArgumentCount(context);
if (argCnt == 0)
{ EnvExitRouter(theEnv,EXIT_SUCCESS); }
else
{
if (! UDFFirstArgument(context,INTEGER_TYPE,&value))
{ EnvExitRouter(theEnv,EXIT_SUCCESS); }
status = (int) mCVToInteger(&value);
if (EnvGetEvaluationError(theEnv)) return;
EnvExitRouter(theEnv,status);
}
return;
}
globle void InitExpressionPointers(
void *theEnv)
{
ExpressionData(theEnv)->PTR_AND = (void *) FindFunction(theEnv,(char*)"and");
ExpressionData(theEnv)->PTR_OR = (void *) FindFunction(theEnv,(char*)"or");
ExpressionData(theEnv)->PTR_EQ = (void *) FindFunction(theEnv,(char*)"eq");
ExpressionData(theEnv)->PTR_NEQ = (void *) FindFunction(theEnv,(char*)"neq");
ExpressionData(theEnv)->PTR_NOT = (void *) FindFunction(theEnv,(char*)"not");
if ((ExpressionData(theEnv)->PTR_AND == NULL) || (ExpressionData(theEnv)->PTR_OR == NULL) ||
(ExpressionData(theEnv)->PTR_EQ == NULL) || (ExpressionData(theEnv)->PTR_NEQ == NULL) || (ExpressionData(theEnv)->PTR_NOT == NULL))
{
SystemError(theEnv,(char*)"EXPRESSN",1);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
}
globle void RemoveConstructFromModule(
void *theEnv,
struct constructHeader *theConstruct)
{
struct constructHeader *lastConstruct,*currentConstruct;
/*==============================*/
/* Find the specified construct */
/* in the module's list. */
/*==============================*/
lastConstruct = NULL;
currentConstruct = theConstruct->whichModule->firstItem;
while (currentConstruct != theConstruct)
{
lastConstruct = currentConstruct;
currentConstruct = currentConstruct->next;
}
/*========================================*/
/* If it wasn't there, something's wrong. */
/*========================================*/
if (currentConstruct == NULL)
{
SystemError(theEnv,"CSTRCPSR",1);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
/*==========================*/
/* Remove it from the list. */
/*==========================*/
if (lastConstruct == NULL)
{ theConstruct->whichModule->firstItem = theConstruct->next; }
else
{ lastConstruct->next = theConstruct->next; }
/*=================================================*/
/* Update the pointer to the last item in the list */
/* if the construct just deleted was at the end. */
/*=================================================*/
if (theConstruct == theConstruct->whichModule->lastItem)
{ theConstruct->whichModule->lastItem = lastConstruct; }
}
globle int InstallExternalAddressType(
void *theEnv,
struct externalAddressType *theAddressType)
{
struct externalAddressType *copyEAT;
int rv = EvaluationData(theEnv)->numberOfAddressTypes;
if (EvaluationData(theEnv)->numberOfAddressTypes == MAXIMUM_EXTERNAL_ADDRESS_TYPES)
{
SystemError(theEnv,"EVALUATN",6);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
copyEAT = (struct externalAddressType *) genalloc(theEnv,sizeof(struct externalAddressType));
memcpy(copyEAT,theAddressType,sizeof(struct externalAddressType));
EvaluationData(theEnv)->ExternalAddressTypes[EvaluationData(theEnv)->numberOfAddressTypes++] = copyEAT;
return rv;
}
static int UngetcString(
void *theEnv,
int ch,
char *logicalName)
{
struct stringRouter *head;
head = FindStringRouter(theEnv,logicalName);
if (head == NULL)
{
SystemError(theEnv,(char*)"ROUTER",2);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
if (head->readWriteType != READ_STRING) return(0);
if (head->currentPosition > 0)
{ head->currentPosition--; }
return(1);
}
globle int rm3(
void *theEnv,
void *str,
size_t size)
{
struct memoryPtr *memPtr;
if (size == 0)
{
SystemError(theEnv,(char*)"MEMORY",1);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
if (size < (long) sizeof(char *)) size = sizeof(char *);
if (size >= MEM_TABLE_SIZE) return(genfree(theEnv,(void *) str,(unsigned long) size));
memPtr = (struct memoryPtr *) str;
memPtr->next = MemoryData(theEnv)->MemoryTable[(int) size];
MemoryData(theEnv)->MemoryTable[(int) size] = memPtr;
return(1);
}
static void EmptyDrive(
void *theEnv,
struct joinNode *join,
struct partialMatch *rhsBinds)
{
struct partialMatch *linker;
struct joinNode *listOfJoins;
int joinExpr;
/*======================================================*/
/* Determine if the alpha memory partial match satifies */
/* the join expression. If it doesn't then no further */
/* action is taken. */
/*======================================================*/
if (join->networkTest != NULL)
{
joinExpr = EvaluateJoinExpression(theEnv,join->networkTest,NULL,rhsBinds,join);
EvaluationData(theEnv)->EvaluationError = FALSE;
if (joinExpr == FALSE) return;
}
/*===========================================================*/
/* The first join of a rule cannot be connected to a NOT CE. */
/*===========================================================*/
if (join->patternIsNegated == TRUE)
{
SystemError(theEnv,"DRIVE",2);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
/*=========================================================*/
/* If the join's RHS entry is associated with a pattern CE */
/* (positive entry), then copy the alpha memory partial */
/* match and send it to all child joins. */
/*=========================================================*/
linker = CopyPartialMatch(theEnv,rhsBinds,
(join->ruleToActivate == NULL) ? 0 : 1,
(int) join->logicalJoin);
/*=======================================================*/
/* Add the partial match to the beta memory of the join. */
/*=======================================================*/
linker->next = join->beta;
join->beta = linker;
/*====================================================*/
/* Activate the rule satisfied by this partial match. */
/*====================================================*/
if (join->ruleToActivate != NULL) AddActivation(theEnv,join->ruleToActivate,linker);
/*============================================*/
/* Send the partial match to all child joins. */
/*============================================*/
listOfJoins = join->nextLevel;
while (listOfJoins != NULL)
{
NetworkAssert(theEnv,linker,listOfJoins,LHS);
listOfJoins = listOfJoins->rightDriveNode;
}
}
globle void NetworkAssert(
void *theEnv,
struct partialMatch *binds,
struct joinNode *join,
int enterDirection)
{
struct partialMatch *lhsBinds = NULL, *rhsBinds = NULL;
struct partialMatch *comparePMs = NULL, *newBinds;
int exprResult;
/*=========================================================*/
/* If an incremental reset is being performed and the join */
/* is not part of the network to be reset, then return. */
/*=========================================================*/
#if INCREMENTAL_RESET && (! BLOAD_ONLY) && (! RUN_TIME)
if (EngineData(theEnv)->IncrementalResetInProgress && (join->initialize == FALSE)) return;
#endif
/*=========================================================*/
/* If the associated LHS pattern is a not CE or the join */
/* is a nand join, then we need an additional field in the */
/* partial match to keep track of the pseudo fact if one */
/* is created. The partial match is automatically stored */
/* in the beta memory and the counterf slot is used to */
/* determine if it is an actual partial match. If counterf */
/* is TRUE, there are one or more fact or instances */
/* keeping the not or nand join from being satisfied. */
/*=========================================================*/
if ((enterDirection == LHS) &&
((join->patternIsNegated) || (join->joinFromTheRight)))
{
newBinds = AddSingleMatch(theEnv,binds,NULL,
(join->ruleToActivate == NULL) ? 0 : 1,
(int) join->logicalJoin);
newBinds->notOriginf = TRUE;
newBinds->counterf = TRUE;
binds = newBinds;
binds->next = join->beta;
join->beta = binds;
}
/*==================================================*/
/* Use a special routine if this is the first join. */
/*==================================================*/
if (join->firstJoin)
{
EmptyDrive(theEnv,join,binds);
return;
}
/*==================================================*/
/* Initialize some variables used to indicate which */
/* side is being compared to the new partial match. */
/*==================================================*/
if (enterDirection == LHS)
{
if (join->joinFromTheRight)
{ comparePMs = ((struct joinNode *) join->rightSideEntryStructure)->beta;}
else
{ comparePMs = ((struct patternNodeHeader *) join->rightSideEntryStructure)->alphaMemory; }
lhsBinds = binds;
}
else if (enterDirection == RHS)
{
if (join->patternIsNegated || join->joinFromTheRight)
{ comparePMs = join->beta; }
else
{ comparePMs = join->lastLevel->beta; }
rhsBinds = binds;
}
else
{
SystemError(theEnv,"DRIVE",1);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
/*===================================================*/
/* Compare each set of binds on the opposite side of */
/* the join with the set of binds that entered this */
/* join. If the binds don't mismatch, then perform */
/* the appropriate action for the logic of the join. */
/*===================================================*/
while (comparePMs != NULL)
{
/*===========================================================*/
/* Initialize some variables pointing to the partial matches */
/* in the LHS and RHS of the join. In addition, check for */
/* certain conditions under which the partial match can be */
/* skipped since it's not a "real" partial match. */
/*===========================================================*/
if (enterDirection == RHS)
{
lhsBinds = comparePMs;
/*=====================================================*/
/* The partial matches entering from the LHS of a join */
/* are stored in the beta memory of the previous join */
/* (unless the current join is a join from the right */
/* or is attached to a not CE). If the previous join */
/* is a join from the right or associated with a not */
/* CE, then some of its partial matches in its beta */
/* memory will not be "real" partial matches. That is, */
/* there may be a partial match in the alpha memory */
/* that prevents the partial match from satisfying the */
/* join's conditions. If this is the case, then the */
/* counterf flag in the partial match will be set to */
/* TRUE and in this case, we move on to the next */
/* partial match to be checked. */
/*=====================================================*/
if (lhsBinds->counterf &&
(join->patternIsNegated == FALSE) &&
(join->joinFromTheRight == FALSE))
{
comparePMs = comparePMs->next;
continue;
}
/*==================================================*/
/* If the join is associated with a not CE or has a */
/* join from the right, then the LHS partial match */
/* currently being checked may already have a */
/* partial match from the alpha memory preventing */
/* it from being satisfied. If this is the case, */
/* then move on to the next partial match in the */
/* beta memory of the join. */
/*==================================================*/
if ((join->patternIsNegated || join->joinFromTheRight) &&
(lhsBinds->counterf))
{
comparePMs = comparePMs->next;
continue;
}
}
else
{ rhsBinds = comparePMs; }
/*========================================================*/
/* If the join has no expression associated with it, then */
/* the new partial match derived from the LHS and RHS */
/* partial matches is valid. In the event that the join */
/* is a join from the right, it must also be checked that */
/* the RHS partial match is the same partial match that */
/* the LHS partial match was generated from. Each LHS */
/* partial match in a join from the right corresponds */
/* uniquely to a partial match from the RHS of the join. */
/* To determine whether the LHS partial match is the one */
/* associated with the RHS partial match, we compare the */
/* the entity addresses found in the partial matches to */
/* make sure they're equal. */
/*========================================================*/
if (join->networkTest == NULL)
{
exprResult = TRUE;
if (join->joinFromTheRight)
{
int i;
for (i = 0; i < (int) (lhsBinds->bcount - 1); i++)
{
if (lhsBinds->binds[i].gm.theMatch != rhsBinds->binds[i].gm.theMatch)
{
exprResult = FALSE;
break;
}
}
}
}
/*=========================================================*/
/* If the join has an expression associated with it, then */
/* evaluate the expression to determine if the new partial */
/* match derived from the LHS and RHS partial matches is */
/* valid (i.e. variable bindings are consistent and */
/* predicate expressions evaluate to TRUE). */
/*=========================================================*/
else
{
exprResult = EvaluateJoinExpression(theEnv,join->networkTest,lhsBinds,rhsBinds,join);
if (EvaluationData(theEnv)->EvaluationError)
{
if (join->patternIsNegated) exprResult = TRUE;
SetEvaluationError(theEnv,FALSE);
}
}
/*====================================================*/
/* If the join expression evaluated to TRUE (i.e. */
/* there were no conflicts between variable bindings, */
/* all tests were satisfied, etc.), then perform the */
/* appropriate action given the logic of this join. */
/*====================================================*/
if (exprResult != FALSE)
{
/*==============================================*/
/* Use the PPDrive routine when the join isn't */
/* associated with a not CE and it doesn't have */
/* a join from the right. */
/*==============================================*/
if ((join->patternIsNegated == FALSE) &&
(join->joinFromTheRight == FALSE))
{ PPDrive(theEnv,lhsBinds,rhsBinds,join); }
/*=====================================================*/
/* Use the PNRDrive routine when the new partial match */
/* enters from the RHS of the join and the join either */
/* is associated with a not CE or has a join from the */
/* right. */
/*=====================================================*/
else if (enterDirection == RHS)
{ PNRDrive(theEnv,join,comparePMs,rhsBinds); }
/*===========================================================*/
/* If the new partial match entered from the LHS of the join */
/* and the join is either associated with a not CE or the */
/* join has a join from the right, then mark the LHS partial */
/* match indicating that there is a RHS partial match */
/* preventing this join from being satisfied. Once this has */
/* happened, the other RHS partial matches don't have to be */
/* tested since it only takes one partial match to prevent */
/* the LHS from being satisfied. */
/*===========================================================*/
else if (enterDirection == LHS)
{
binds->binds[binds->bcount - 1].gm.theValue = (void *) rhsBinds;
comparePMs = NULL;
continue;
}
}
/*====================================*/
/* Move on to the next partial match. */
/*====================================*/
comparePMs = comparePMs->next;
}
/*==================================================================*/
/* If a join with an associated not CE or join from the right was */
/* entered from the LHS side of the join, and the join expression */
/* failed for all sets of matches for the new bindings on the LHS */
/* side (there was no RHS partial match preventing the LHS partial */
/* match from being satisfied), then the LHS partial match appended */
/* with an pseudo-fact that represents the instance of the not */
/* pattern or join from the right that was satisfied should be sent */
/* to the joins below this join. */
/*==================================================================*/
if ((join->patternIsNegated || join->joinFromTheRight) &&
(enterDirection == LHS) &&
(binds->binds[binds->bcount - 1].gm.theValue == NULL))
{ PNLDrive(theEnv,join,binds); }
return;
}
static struct lhsParseNode *ConjuctiveRestrictionParse(
void *theEnv,
char *readSource,
struct token *theToken,
int *error)
{
struct lhsParseNode *bindNode;
struct lhsParseNode *theNode, *nextOr, *nextAnd;
int connectorType;
/*=====================================*/
/* Get the first node and determine if */
/* it is a binding variable. */
/*=====================================*/
theNode = LiteralRestrictionParse(theEnv,readSource,theToken,error);
if (*error == TRUE)
{ return(NULL); }
GetToken(theEnv,readSource,theToken);
if (((theNode->type == SF_VARIABLE) || (theNode->type == MF_VARIABLE)) &&
(theNode->negated == FALSE) &&
(theToken->type != OR_CONSTRAINT))
{
theNode->bindingVariable = TRUE;
bindNode = theNode;
nextOr = NULL;
nextAnd = NULL;
}
else
{
bindNode = GetLHSParseNode(theEnv);
if (theNode->type == MF_VARIABLE) bindNode->type = MF_WILDCARD;
else bindNode->type = SF_WILDCARD;
bindNode->negated = FALSE;
bindNode->bottom = theNode;
nextOr = theNode;
nextAnd = theNode;
}
/*===================================*/
/* Process the connected constraints */
/* within the constraint */
/*===================================*/
while ((theToken->type == OR_CONSTRAINT) || (theToken->type == AND_CONSTRAINT))
{
/*==========================*/
/* Get the next constraint. */
/*==========================*/
connectorType = theToken->type;
GetToken(theEnv,readSource,theToken);
theNode = LiteralRestrictionParse(theEnv,readSource,theToken,error);
if (*error == TRUE)
{
ReturnLHSParseNodes(theEnv,bindNode);
return(NULL);
}
/*=======================================*/
/* Attach the new constraint to the list */
/* of constraints for this field. */
/*=======================================*/
if (connectorType == OR_CONSTRAINT)
{
if (nextOr == NULL)
{ bindNode->bottom = theNode; }
else
{ nextOr->bottom = theNode; }
nextOr = theNode;
nextAnd = theNode;
}
else if (connectorType == AND_CONSTRAINT)
{
if (nextAnd == NULL)
{
bindNode->bottom = theNode;
nextOr = theNode;
}
else
{ nextAnd->right = theNode; }
nextAnd = theNode;
}
else
{
SystemError(theEnv,"RULEPSR",1);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
/*==================================================*/
/* Determine if any more restrictions are connected */
/* to the current list of restrictions. */
/*==================================================*/
GetToken(theEnv,readSource,theToken);
}
/*==========================================*/
/* Check for illegal mixing of single and */
/* multifield values within the constraint. */
/*==========================================*/
if (CheckForVariableMixing(theEnv,bindNode))
{
*error = TRUE;
ReturnLHSParseNodes(theEnv,bindNode);
return(NULL);
}
/*========================*/
/* Return the constraint. */
/*========================*/
return(bindNode);
}
globle void GetNextPatternEntity(
void *theEnv,
struct patternParser **theParser,
struct patternEntity **theEntity)
{
/*=============================================================*/
/* If the current parser is NULL, then we want to retrieve the */
/* very first data entity. The traversal of entities is done */
/* by entity type (e.g. all facts are traversed followed by */
/* all instances). To get the first entity type to traverse, */
/* the current parser is set to the first parser on the list */
/* of pattern parsers. */
/*=============================================================*/
if (*theParser == NULL)
{
*theParser = PatternData(theEnv)->ListOfPatternParsers;
*theEntity = NULL;
}
/*================================================================*/
/* Otherwise try to retrieve the next entity following the entity */
/* returned by the last call to GetNextEntity. If that entity was */
/* the last of its data type, then move on to the next pattern */
/* parser, otherwise return that entity as the next one. */
/*================================================================*/
else if (theEntity != NULL)
{
*theEntity = (struct patternEntity *)
(*(*theParser)->entityType->base.getNextFunction)(theEnv,*theEntity);
if ((*theEntity) != NULL) return;
*theParser = (*theParser)->next;
}
/*===============================================================*/
/* Otherwise, we encountered a situation which should not occur. */
/* Once a NULL entity is returned from GetNextEntity, it should */
/* not be passed back to GetNextEntity. */
/*===============================================================*/
else
{
SystemError(theEnv,"PATTERN",1);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
/*================================================*/
/* Keep looping through the lists of entities and */
/* pattern parsers until an entity is found. */
/*================================================*/
while ((*theEntity == NULL) && (*theParser != NULL))
{
*theEntity = (struct patternEntity *)
(*(*theParser)->entityType->base.getNextFunction)(theEnv,*theEntity);
if (*theEntity != NULL) return;
*theParser = (*theParser)->next;
}
return;
}
globle void FieldConversion(
void *theEnv,
struct lhsParseNode *theField,
struct lhsParseNode *thePattern,
struct nandFrame *theNandFrames)
{
int testInPatternNetwork = TRUE;
struct lhsParseNode *patternPtr;
struct expr *headOfPNExpression, *headOfJNExpression;
struct expr *lastPNExpression, *lastJNExpression;
struct expr *tempExpression;
struct expr *patternNetTest = NULL;
struct expr *joinNetTest = NULL;
struct expr *constantSelector = NULL;
struct expr *constantValue = NULL;
/*==================================================*/
/* Consider a NULL pointer to be an internal error. */
/*==================================================*/
if (theField == NULL)
{
SystemError(theEnv,"ANALYSIS",3);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
/*========================================================*/
/* Determine if constant testing must be performed in the */
/* join network. Only possible when a field contains an */
/* or ('|') and references are made to variables outside */
/* the pattern. */
/*========================================================*/
if (theField->bottom != NULL)
{
if (theField->bottom->bottom != NULL)
{ testInPatternNetwork = AllVariablesInPattern(theField->bottom,theField->pattern); }
}
/*=============================================================*/
/* Extract pattern and join network expressions. Loop through */
/* the or'ed constraints of the field, extracting pattern and */
/* join network expressions and adding them to a running list. */
/*=============================================================*/
headOfPNExpression = lastPNExpression = NULL;
headOfJNExpression = lastJNExpression = NULL;
for (patternPtr = theField->bottom;
patternPtr != NULL;
patternPtr = patternPtr->bottom)
{
/*=============================================*/
/* Extract pattern and join network tests from */
/* the or'ed constraint being examined. */
/*=============================================*/
ExtractAnds(theEnv,patternPtr,testInPatternNetwork,&patternNetTest,&joinNetTest,
&constantSelector,&constantValue,theNandFrames);
/*=============================================================*/
/* Constant hashing is only used in the pattern network if the */
/* field doesn't contain an or'ed constraint. For example, the */
/* constaint "red | blue" can not use hashing. */
/*=============================================================*/
if (constantSelector != NULL)
{
if ((patternPtr == theField->bottom) &&
(patternPtr->bottom == NULL))
{
theField->constantSelector = constantSelector;
theField->constantValue = constantValue;
}
else
{
ReturnExpression(theEnv,constantSelector);
ReturnExpression(theEnv,constantValue);
ReturnExpression(theEnv,theField->constantSelector);
ReturnExpression(theEnv,theField->constantValue);
theField->constantSelector = NULL;
theField->constantValue = NULL;
}
}
/*=====================================================*/
/* Add the new pattern network expressions to the list */
/* of pattern network expressions being constructed. */
/*=====================================================*/
if (patternNetTest != NULL)
{
if (lastPNExpression == NULL)
{ headOfPNExpression = patternNetTest; }
else
{ lastPNExpression->nextArg = patternNetTest; }
lastPNExpression = patternNetTest;
}
/*==================================================*/
/* Add the new join network expressions to the list */
/* of join network expressions being constructed. */
/*==================================================*/
if (joinNetTest != NULL)
{
if (lastJNExpression == NULL)
{ headOfJNExpression = joinNetTest; }
else
{ lastJNExpression->nextArg = joinNetTest; }
lastJNExpression = joinNetTest;
}
}
/*==========================================================*/
/* If there was more than one expression generated from the */
/* or'ed field constraints for the pattern network, then */
/* enclose the expressions within an "or" function call. */
/*==========================================================*/
if ((headOfPNExpression != NULL) ? (headOfPNExpression->nextArg != NULL) : FALSE)
{
tempExpression = GenConstant(theEnv,FCALL,ExpressionData(theEnv)->PTR_OR);
tempExpression->argList = headOfPNExpression;
headOfPNExpression = tempExpression;
}
/*==========================================================*/
/* If there was more than one expression generated from the */
/* or'ed field constraints for the join network, then */
/* enclose the expressions within an "or" function call. */
/*==========================================================*/
if ((headOfJNExpression != NULL) ? (headOfJNExpression->nextArg != NULL) : FALSE)
{
tempExpression = GenConstant(theEnv,FCALL,ExpressionData(theEnv)->PTR_OR);
tempExpression->argList = headOfJNExpression;
headOfJNExpression = tempExpression;
}
/*===============================================================*/
/* If the field constraint binds a variable that was previously */
/* bound somewhere in the LHS of the rule, then generate an */
/* expression to compare this binding occurrence of the variable */
/* to the previous binding occurrence. */
/*===============================================================*/
if (((theField->type == MF_VARIABLE) || (theField->type == SF_VARIABLE)) &&
(theField->referringNode != NULL))
{
/*================================================================*/
/* If the previous variable reference is within the same pattern, */
/* then the variable comparison can occur in the pattern network. */
/*================================================================*/
if (theField->referringNode->pattern == theField->pattern)
{
tempExpression = GenPNVariableComparison(theEnv,theField,theField->referringNode);
headOfPNExpression = CombineExpressions(theEnv,tempExpression,headOfPNExpression);
}
/*====================================*/
/* Otherwise, the variable comparison */
/* must occur in the join network. */
/*====================================*/
else if (theField->referringNode->pattern > 0)
{
AddNandUnification(theEnv,theField,theNandFrames);
/*====================================*/
/* Generate an expression to test the */
/* variable in a non-nand join. */
/*====================================*/
tempExpression = GenJNVariableComparison(theEnv,theField,theField->referringNode,FALSE);
headOfJNExpression = CombineExpressions(theEnv,tempExpression,headOfJNExpression);
/*==========================*/
/* Generate the hash index. */
/*==========================*/
if (theField->patternType->genGetPNValueFunction != NULL)
{
tempExpression = (*theField->patternType->genGetPNValueFunction)(theEnv,theField);
thePattern->rightHash = AppendExpressions(tempExpression,thePattern->rightHash);
}
if (theField->referringNode->patternType->genGetJNValueFunction)
{
tempExpression = (*theField->referringNode->patternType->genGetJNValueFunction)(theEnv,theField->referringNode,LHS);
thePattern->leftHash = AppendExpressions(tempExpression,thePattern->leftHash);
}
}
}
/*======================================================*/
/* Attach the pattern network expressions to the field. */
/*======================================================*/
theField->networkTest = headOfPNExpression;
/*=====================================================*/
/* Attach the join network expressions to the pattern. */
/*=====================================================*/
thePattern->networkTest = CombineExpressions(theEnv,thePattern->networkTest,headOfJNExpression);
}
globle int EvaluateExpression(
void *theEnv,
struct expr *problem,
DATA_OBJECT_PTR returnValue)
{
struct expr *oldArgument;
void *oldContext;
struct FunctionDefinition *fptr;
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
if (problem == NULL)
{
returnValue->type = SYMBOL;
returnValue->value = EnvFalseSymbol(theEnv);
return(EvaluationData(theEnv)->EvaluationError);
}
switch (problem->type)
{
case STRING:
case SYMBOL:
case FLOAT:
case INTEGER:
#if OBJECT_SYSTEM
case INSTANCE_NAME:
case INSTANCE_ADDRESS:
#endif
case EXTERNAL_ADDRESS:
returnValue->type = problem->type;
returnValue->value = problem->value;
break;
case DATA_OBJECT_ARRAY: /* TBD Remove with AddPrimitive */
returnValue->type = problem->type;
returnValue->value = problem->value;
break;
case FCALL:
{
fptr = (struct FunctionDefinition *) problem->value;
oldContext = SetEnvironmentFunctionContext(theEnv,fptr->context);
#if PROFILING_FUNCTIONS
StartProfile(theEnv,&profileFrame,
&fptr->usrData,
ProfileFunctionData(theEnv)->ProfileUserFunctions);
#endif
oldArgument = EvaluationData(theEnv)->CurrentExpression;
EvaluationData(theEnv)->CurrentExpression = problem;
switch(fptr->returnValueType)
{
case 'v' :
if (fptr->environmentAware)
{ (* (void (*)(void *)) fptr->functionPointer)(theEnv); }
else
{ (* (void (*)(void)) fptr->functionPointer)(); }
returnValue->type = RVOID;
returnValue->value = EnvFalseSymbol(theEnv);
break;
case 'b' :
returnValue->type = SYMBOL;
if (fptr->environmentAware)
{
if ((* (int (*)(void *)) fptr->functionPointer)(theEnv))
returnValue->value = EnvTrueSymbol(theEnv);
else
returnValue->value = EnvFalseSymbol(theEnv);
}
else
{
if ((* (int (*)(void)) fptr->functionPointer)())
returnValue->value = EnvTrueSymbol(theEnv);
else
returnValue->value = EnvFalseSymbol(theEnv);
}
break;
case 'a' :
returnValue->type = EXTERNAL_ADDRESS;
if (fptr->environmentAware)
{
returnValue->value =
(* (void *(*)(void *)) fptr->functionPointer)(theEnv);
}
else
{
returnValue->value =
(* (void *(*)(void)) fptr->functionPointer)();
}
break;
case 'g' :
returnValue->type = INTEGER;
if (fptr->environmentAware)
{
returnValue->value = (void *)
EnvAddLong(theEnv,(* (long long (*)(void *)) fptr->functionPointer)(theEnv));
}
else
{
returnValue->value = (void *)
EnvAddLong(theEnv,(* (long long (*)(void)) fptr->functionPointer)());
}
break;
case 'i' :
returnValue->type = INTEGER;
if (fptr->environmentAware)
{
returnValue->value = (void *)
EnvAddLong(theEnv,(long long) (* (int (*)(void *)) fptr->functionPointer)(theEnv));
}
else
{
returnValue->value = (void *)
EnvAddLong(theEnv,(long long) (* (int (*)(void)) fptr->functionPointer)());
}
break;
case 'l' :
returnValue->type = INTEGER;
if (fptr->environmentAware)
{
returnValue->value = (void *)
EnvAddLong(theEnv,(long long) (* (long int (*)(void *)) fptr->functionPointer)(theEnv));
}
else
{
returnValue->value = (void *)
EnvAddLong(theEnv,(long long) (* (long int (*)(void)) fptr->functionPointer)());
}
break;
case 'f' :
returnValue->type = FLOAT;
if (fptr->environmentAware)
{
returnValue->value = (void *)
EnvAddDouble(theEnv,(double) (* (float (*)(void *)) fptr->functionPointer)(theEnv));
}
else
{
returnValue->value = (void *)
EnvAddDouble(theEnv,(double) (* (float (*)(void)) fptr->functionPointer)());
}
break;
case 'd' :
returnValue->type = FLOAT;
if (fptr->environmentAware)
{
returnValue->value = (void *)
EnvAddDouble(theEnv,(* (double (*)(void *)) fptr->functionPointer)(theEnv));
}
else
{
returnValue->value = (void *)
EnvAddDouble(theEnv,(* (double (*)(void)) fptr->functionPointer)());
}
break;
case 's' :
returnValue->type = STRING;
if (fptr->environmentAware)
{
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void *)) fptr->functionPointer)(theEnv);
}
else
{
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
}
break;
case 'w' :
returnValue->type = SYMBOL;
if (fptr->environmentAware)
{
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void *)) fptr->functionPointer)(theEnv);
}
else
{
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
}
break;
#if OBJECT_SYSTEM
case 'x' :
returnValue->type = INSTANCE_ADDRESS;
if (fptr->environmentAware)
{
returnValue->value =
(* (void *(*)(void *)) fptr->functionPointer)(theEnv);
}
else
{
returnValue->value =
(* (void *(*)(void)) fptr->functionPointer)();
}
break;
case 'o' :
returnValue->type = INSTANCE_NAME;
if (fptr->environmentAware)
{
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void *)) fptr->functionPointer)(theEnv);
}
else
{
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
}
break;
#endif
case 'c' :
{
char cbuff[2];
if (fptr->environmentAware)
{
cbuff[0] = (* (char (*)(void *)) fptr->functionPointer)(theEnv);
}
else
{
cbuff[0] = (* (char (*)(void)) fptr->functionPointer)();
}
cbuff[1] = EOS;
returnValue->type = SYMBOL;
returnValue->value = (void *) EnvAddSymbol(theEnv,cbuff);
break;
}
case 'j' :
case 'k' :
case 'm' :
case 'n' :
case 'u' :
if (fptr->environmentAware)
{
(* (void (*)(void *,DATA_OBJECT_PTR)) fptr->functionPointer)(theEnv,returnValue);
}
else
{
(* (void (*)(DATA_OBJECT_PTR)) fptr->functionPointer)(returnValue);
}
break;
default :
SystemError(theEnv,"EVALUATN",2);
EnvExitRouter(theEnv,EXIT_FAILURE);
break;
}
#if PROFILING_FUNCTIONS
EndProfile(theEnv,&profileFrame);
#endif
SetEnvironmentFunctionContext(theEnv,oldContext);
EvaluationData(theEnv)->CurrentExpression = oldArgument;
break;
}
case MULTIFIELD:
returnValue->type = MULTIFIELD;
returnValue->value = ((DATA_OBJECT_PTR) (problem->value))->value;
returnValue->begin = ((DATA_OBJECT_PTR) (problem->value))->begin;
returnValue->end = ((DATA_OBJECT_PTR) (problem->value))->end;
break;
case MF_VARIABLE:
case SF_VARIABLE:
if (GetBoundVariable(theEnv,returnValue,(SYMBOL_HN *) problem->value) == FALSE)
{
PrintErrorID(theEnv,"EVALUATN",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Variable ");
EnvPrintRouter(theEnv,WERROR,ValueToString(problem->value));
EnvPrintRouter(theEnv,WERROR," is unbound\n");
returnValue->type = SYMBOL;
returnValue->value = EnvFalseSymbol(theEnv);
SetEvaluationError(theEnv,TRUE);
}
break;
default:
if (EvaluationData(theEnv)->PrimitivesArray[problem->type] == NULL)
{
SystemError(theEnv,"EVALUATN",3);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
if (EvaluationData(theEnv)->PrimitivesArray[problem->type]->copyToEvaluate)
{
returnValue->type = problem->type;
returnValue->value = problem->value;
break;
}
if (EvaluationData(theEnv)->PrimitivesArray[problem->type]->evaluateFunction == NULL)
{
SystemError(theEnv,"EVALUATN",4);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
oldArgument = EvaluationData(theEnv)->CurrentExpression;
EvaluationData(theEnv)->CurrentExpression = problem;
#if PROFILING_FUNCTIONS
StartProfile(theEnv,&profileFrame,
&EvaluationData(theEnv)->PrimitivesArray[problem->type]->usrData,
ProfileFunctionData(theEnv)->ProfileUserFunctions);
#endif
(*EvaluationData(theEnv)->PrimitivesArray[problem->type]->evaluateFunction)(theEnv,problem->value,returnValue);
#if PROFILING_FUNCTIONS
EndProfile(theEnv,&profileFrame);
#endif
EvaluationData(theEnv)->CurrentExpression = oldArgument;
break;
}
return(EvaluationData(theEnv)->EvaluationError);
}
globle void *genlongalloc(
void *theEnv,
unsigned long size)
{
#if (! MAC) && (! IBM_TBC) && (! IBM_MSC) && (! IBM_ICB) && (! IBM_ZTC) && (! IBM_SC) && (! IBM_MCW)
unsigned int test;
#else
void *memPtr;
#endif
#if BLOCK_MEMORY
struct longMemoryPtr *theLongMemory;
#endif
if (sizeof(int) == sizeof(long))
{ return(genalloc(theEnv,(unsigned) size)); }
#if (! MAC) && (! IBM_TBC) && (! IBM_MSC) && (! IBM_ICB) && (! IBM_ZTC) && (! IBM_SC) && (! IBM_MCW)
test = (unsigned int) size;
if (test != size)
{
PrintErrorID(theEnv,"MEMORY",3,TRUE);
EnvPrintRouter(theEnv,WERROR,"Unable to allocate memory block > 32K.\n");
EnvExitRouter(theEnv,EXIT_FAILURE);
}
return((void *) genalloc(theEnv,(unsigned) test));
#else
#if BLOCK_MEMORY
size += sizeof(struct longMemoryPtr);
#endif
memPtr = (void *) SpecialMalloc(size);
if (memPtr == NULL)
{
EnvReleaseMem(theEnv,(long) ((size * 5 > 4096) ? size * 5 : 4096),FALSE);
memPtr = (void *) SpecialMalloc(size);
if (memPtr == NULL)
{
EnvReleaseMem(theEnv,-1L,TRUE);
memPtr = (void *) SpecialMalloc(size);
while (memPtr == NULL)
{
if ((*MemoryData(theEnv)->OutOfMemoryFunction)(theEnv,size))
return(NULL);
memPtr = (void *) SpecialMalloc(size);
}
}
}
MemoryData(theEnv)->MemoryAmount += (long) size;
MemoryData(theEnv)->MemoryCalls++;
#if BLOCK_MEMORY
theLongMemory = (struct longMemoryPtr *) memPtr;
theLongMemory->next = MemoryData(theEnv)->TopLongMemoryPtr;
theLongMemory->prev = NULL;
theLongMemory->size = (long) size;
memPtr = (void *) (theLongMemory + 1);
#endif
return(memPtr);
#endif
}
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);
}
globle void NetworkRetract(
void *theEnv,
struct patternMatch *listOfMatchedPatterns)
{
struct patternMatch *tempMatch;
struct partialMatch *deletedMatches, *theLast;
struct joinNode *joinPtr;
/*===============================*/
/* Remember the beginning of the */
/* list of matched patterns. */
/*===============================*/
tempMatch = listOfMatchedPatterns;
/*============================================*/
/* Remove the data entity from all joins that */
/* aren't directly enclosed by a not CE. */
/*============================================*/
for (;
listOfMatchedPatterns != NULL;
listOfMatchedPatterns = listOfMatchedPatterns->next)
{
/*====================================*/
/* Loop through the list of all joins */
/* attached to this pattern. */
/*====================================*/
for (joinPtr = listOfMatchedPatterns->matchingPattern->entryJoin;
joinPtr != NULL;
joinPtr = joinPtr->rightMatchNode)
{
if (joinPtr->patternIsNegated == FALSE)
{ PosEntryRetract(theEnv,joinPtr,
listOfMatchedPatterns->theMatch->binds[0].gm.theMatch,
listOfMatchedPatterns->theMatch,
(int) joinPtr->depth - 1,TRUE); }
}
}
/*============================================*/
/* Remove the data entity from all joins that */
/* are directly enclosed by a not CE. */
/*============================================*/
listOfMatchedPatterns = tempMatch;
while (listOfMatchedPatterns != NULL)
{
/*====================================*/
/* Loop through the list of all joins */
/* attached to this pattern. */
/*====================================*/
for (joinPtr = listOfMatchedPatterns->matchingPattern->entryJoin;
joinPtr != NULL;
joinPtr = joinPtr->rightMatchNode)
{
if (joinPtr->patternIsNegated == TRUE)
{
if (joinPtr->firstJoin == TRUE)
{
SystemError(theEnv,"RETRACT",3);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
else
{ NegEntryRetract(theEnv,joinPtr,listOfMatchedPatterns->theMatch,TRUE); }
}
}
/*===================================================*/
/* Remove from the alpha memory of the pattern node. */
/*===================================================*/
theLast = NULL;
listOfMatchedPatterns->matchingPattern->alphaMemory =
RemovePartialMatches(theEnv,listOfMatchedPatterns->theMatch->binds[0].gm.theMatch,
listOfMatchedPatterns->matchingPattern->alphaMemory,
&deletedMatches,0,&theLast);
listOfMatchedPatterns->matchingPattern->endOfQueue = theLast;
DeletePartialMatches(theEnv,deletedMatches,0);
tempMatch = listOfMatchedPatterns->next;
rtn_struct(theEnv,patternMatch,listOfMatchedPatterns);
listOfMatchedPatterns = tempMatch;
}
/*=========================================*/
/* Filter new partial matches generated by */
/* retraction through the join network. */
/*=========================================*/
DriveRetractions(theEnv);
}
