void InitializeConstraints(
Environment *theEnv)
{
#if (! RUN_TIME) && (! BLOAD_ONLY)
int i;
#endif
AllocateEnvironmentData(theEnv,CONSTRAINT_DATA,sizeof(struct constraintData),DeallocateConstraintData);
#if (! RUN_TIME) && (! BLOAD_ONLY)
ConstraintData(theEnv)->ConstraintHashtable = (struct constraintRecord **)
gm2(theEnv,sizeof (struct constraintRecord *) *
SIZE_CONSTRAINT_HASH);
if (ConstraintData(theEnv)->ConstraintHashtable == NULL) ExitRouter(theEnv,EXIT_FAILURE);
for (i = 0; i < SIZE_CONSTRAINT_HASH; i++) ConstraintData(theEnv)->ConstraintHashtable[i] = NULL;
#endif
#if (! RUN_TIME)
AddUDF(theEnv,"get-dynamic-constraint-checking","b",0,0,NULL,GDCCommand,"GDCCommand",NULL);
AddUDF(theEnv,"set-dynamic-constraint-checking","b",1,1,NULL,SDCCommand,"SDCCommand",NULL);
#endif
}
static void WriteStringCallback(
Environment *theEnv,
const char *logicalName,
const char *str,
void *context)
{
struct stringRouter *head;
head = FindStringRouter(theEnv,logicalName);
if (head == NULL)
{
SystemError(theEnv,"ROUTER",3);
ExitRouter(theEnv,EXIT_FAILURE);
return;
}
if (head->readWriteType != WRITE_STRING) return;
if (head->maximumPosition == 0) return;
if ((head->currentPosition + 1) >= head->maximumPosition) return;
genstrncpy(&head->writeString[head->currentPosition],
str,(STD_SIZE) (head->maximumPosition - head->currentPosition) - 1);
head->currentPosition += strlen(str);
}
static int UnreadStringCallback(
Environment *theEnv,
const char *logicalName,
int ch,
void *context)
{
struct stringRouter *head;
#if MAC_XCD
#pragma unused(ch)
#endif
head = FindStringRouter(theEnv,logicalName);
if (head == NULL)
{
SystemError(theEnv,"ROUTER",2);
ExitRouter(theEnv,EXIT_FAILURE);
}
if (head->readWriteType != READ_STRING) return 0;
if (head->currentPosition > 0)
{ head->currentPosition--; }
return 1;
}
static int ReadStringCallback(
Environment *theEnv,
const char *logicalName,
void *context)
{
struct stringRouter *head;
int rc;
head = FindStringRouter(theEnv,logicalName);
if (head == NULL)
{
SystemError(theEnv,"ROUTER",1);
ExitRouter(theEnv,EXIT_FAILURE);
}
if (head->readWriteType != READ_STRING) return(EOF);
if (head->currentPosition >= head->maximumPosition)
{
head->currentPosition++;
return(EOF);
}
rc = (unsigned char) head->readString[head->currentPosition];
head->currentPosition++;
return(rc);
}
globle void InitializeFactHashTable()
{
int i;
FactHashTable = (struct factHashEntry **)
gm2((int) sizeof (struct factHashEntry *) * SIZE_FACT_HASH);
if (FactHashTable == NULL) ExitRouter(EXIT_FAILURE);
for (i = 0; i < SIZE_FACT_HASH; i++) FactHashTable[i] = NULL;
}
globle void InstallPrimitive(
struct entityRecord *thePrimitive,
int whichPosition)
{
if (PrimitivesArray[whichPosition] != NULL)
{
SystemError("EVALUATN",5);
ExitRouter(EXIT_FAILURE);
}
PrimitivesArray[whichPosition] = thePrimitive;
}
globle void InitExpressionPointers()
{
PTR_AND = (void *) FindFunction("and");
PTR_OR = (void *) FindFunction("or");
PTR_EQ = (void *) FindFunction("eq");
PTR_NEQ = (void *) FindFunction("neq");
PTR_NOT = (void *) FindFunction("not");
if ((PTR_AND == NULL) || (PTR_OR == NULL) ||
(PTR_EQ == NULL) || (PTR_NEQ == NULL) || (PTR_NOT == NULL))
{
SystemError("EXPRESSN",1);
ExitRouter(EXIT_FAILURE);
}
}
static void WriteStringBuilderCallback(
Environment *theEnv,
const char *logicalName,
const char *str,
void *context)
{
StringBuilderRouter *head;
head = FindStringBuilderRouter(theEnv,logicalName);
if (head == NULL)
{
SystemError(theEnv,"ROUTER",3);
ExitRouter(theEnv,EXIT_FAILURE);
return;
}
SBAppend(head->SBR,str);
}
globle void NetworkAssert(
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 (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(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(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("DRIVE",1);
ExitRouter(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(join->networkTest,lhsBinds,rhsBinds,join);
if (EvaluationError)
{
if (join->patternIsNegated) exprResult = TRUE;
SetEvaluationError(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(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(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(join,binds); }
return;
}
globle int EvaluateExpression(
struct expr *problem,
DATA_OBJECT_PTR returnValue)
{
struct expr *oldArgument;
struct FunctionDefinition *fptr;
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
if (problem == NULL)
{
returnValue->type = SYMBOL;
returnValue->value = FalseSymbol;
return(EvaluationError);
}
switch (problem->type)
{
case STRING:
case SYMBOL:
case FLOAT:
case INTEGER:
#if OBJECT_SYSTEM
case INSTANCE_NAME:
case INSTANCE_ADDRESS:
#endif
#if FUZZY_DEFTEMPLATES
case FUZZY_VALUE:
#endif
case EXTERNAL_ADDRESS:
returnValue->type = problem->type;
returnValue->value = problem->value;
break;
#if FUZZY_DEFTEMPLATES
case S_FUNCTION:
case PI_FUNCTION:
case Z_FUNCTION:
case SINGLETON_EXPRESSION:
/* At some time it may be worthwhile making this into an FCALL
but only when we allow user's to create functions that return
fuzzy values -- this may not happen
*/
{
struct fuzzy_value *fvptr;
fvptr = getConstantFuzzyValue(problem, &EvaluationError);
returnValue->type = FUZZY_VALUE;
if (fvptr != NULL)
{
returnValue->value = (VOID *)AddFuzzyValue(fvptr);
/* AddFuzzyValue makes a copy of the fuzzy value -- so remove this one */
rtnFuzzyValue(fvptr);
}
else
{
returnValue->type = RVOID;
returnValue->value = CLIPSFalseSymbol;
SetEvaluationError(TRUE);
}
}
break;
#endif
case FCALL:
{
fptr = (struct FunctionDefinition *) problem->value;
#if PROFILING_FUNCTIONS
StartProfile(&profileFrame,
&fptr->usrData,
ProfileUserFunctions);
#endif
oldArgument = CurrentExpression;
CurrentExpression = problem;
switch(fptr->returnValueType)
{
case 'v' :
(* (void (*)(void)) fptr->functionPointer)();
returnValue->type = RVOID;
returnValue->value = FalseSymbol;
break;
case 'b' :
returnValue->type = SYMBOL;
if ((* (int (*)(void)) fptr->functionPointer)())
returnValue->value = TrueSymbol;
else
returnValue->value = FalseSymbol;
break;
case 'a' :
returnValue->type = EXTERNAL_ADDRESS;
returnValue->value =
(* (void *(*)(void)) fptr->functionPointer)();
break;
case 'i' :
returnValue->type = INTEGER;
returnValue->value = (void *)
AddLong((long) (* (int (*)(void)) fptr->functionPointer)());
break;
case 'l' :
returnValue->type = INTEGER;
returnValue->value = (void *)
AddLong((* (long int (*)(void)) fptr->functionPointer)());
break;
#if FUZZY_DEFTEMPLATES
case 'F' :
{
struct fuzzy_value *fvPtr;
fvPtr = (* (struct fuzzy_value * (*)(VOID_ARG)) fptr->functionPointer)();
if (fvPtr != NULL)
{
returnValue->type = FUZZY_VALUE;
returnValue->value = (VOID *)AddFuzzyValue( fvPtr );
/* AddFuzzyValue makes a copy of fv .. so return it */
rtnFuzzyValue( fvPtr );
}
else
{
returnValue->type = RVOID;
returnValue->value = CLIPSFalseSymbol;
}
}
break;
#endif
case 'f' :
returnValue->type = FLOAT;
returnValue->value = (void *)
AddDouble((double) (* (float (*)(void)) fptr->functionPointer)());
break;
case 'd' :
returnValue->type = FLOAT;
returnValue->value = (void *)
AddDouble((* (double (*)(void)) fptr->functionPointer)());
break;
case 's' :
returnValue->type = STRING;
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
break;
case 'w' :
returnValue->type = SYMBOL;
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
break;
#if OBJECT_SYSTEM
case 'x' :
returnValue->type = INSTANCE_ADDRESS;
returnValue->value =
(* (void *(*)(void)) fptr->functionPointer)();
break;
case 'o' :
returnValue->type = INSTANCE_NAME;
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
break;
#endif
case 'c' :
{
char cbuff[2];
cbuff[0] = (* (char (*)(void)) fptr->functionPointer)();
cbuff[1] = EOS;
returnValue->type = SYMBOL;
returnValue->value = (void *) AddSymbol(cbuff);
break;
}
case 'j' :
case 'k' :
case 'm' :
case 'n' :
case 'u' :
(* (void (*)(DATA_OBJECT_PTR)) fptr->functionPointer)(returnValue);
break;
default :
SystemError("EVALUATN",2);
ExitRouter(EXIT_FAILURE);
break;
}
#if PROFILING_FUNCTIONS
EndProfile(&profileFrame);
#endif
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(returnValue,(SYMBOL_HN *) problem->value) == FALSE)
{
PrintErrorID("EVALUATN",1,FALSE);
PrintRouter(WERROR,"Variable ");
PrintRouter(WERROR,ValueToString(problem->value));
PrintRouter(WERROR," is unbound\n");
returnValue->type = SYMBOL;
returnValue->value = FalseSymbol;
SetEvaluationError(TRUE);
}
break;
default:
if (PrimitivesArray[problem->type] == NULL)
{
SystemError("EVALUATN",3);
ExitRouter(EXIT_FAILURE);
}
if (PrimitivesArray[problem->type]->copyToEvaluate)
{
returnValue->type = problem->type;
returnValue->value = problem->value;
break;
}
if (PrimitivesArray[problem->type]->evaluateFunction == NULL)
{
SystemError("EVALUATN",4);
ExitRouter(EXIT_FAILURE);
}
oldArgument = CurrentExpression;
CurrentExpression = problem;
#if PROFILING_FUNCTIONS
StartProfile(&profileFrame,
&PrimitivesArray[problem->type]->usrData,
ProfileUserFunctions);
#endif
(*PrimitivesArray[problem->type]->evaluateFunction)(problem->value,returnValue);
#if PROFILING_FUNCTIONS
EndProfile(&profileFrame);
#endif
CurrentExpression = oldArgument;
break;
}
PropagateReturnValue(returnValue);
return(EvaluationError);
}
static struct lhsParseNode *ConjuctiveRestrictionParse(
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(readSource,theToken,error);
if (*error == TRUE)
{ return(NULL); }
GetToken(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();
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(readSource,theToken);
theNode = LiteralRestrictionParse(readSource,theToken,error);
if (*error == TRUE)
{
ReturnLHSParseNodes(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("RULEPSR",1);
ExitRouter(EXIT_FAILURE);
}
/*==================================================*/
/* Determine if any more restrictions are connected */
/* to the current list of restrictions. */
/*==================================================*/
GetToken(readSource,theToken);
}
/*==========================================*/
/* Check for illegal mixing of single and */
/* multifield values within the constraint. */
/*==========================================*/
if (CheckForVariableMixing(bindNode))
{
*error = TRUE;
ReturnLHSParseNodes(bindNode);
return(NULL);
}
/*========================*/
/* Return the constraint. */
/*========================*/
return(bindNode);
}
globle FILE *OpenFileIfNeeded(
FILE *theFile,
char *fileName,
int fileID,
int imageID,
int *fileCount,
int arrayVersion,
FILE *headerFP,
char *structureName,
char *structPrefix,
int reopenOldFile,
struct CodeGeneratorFile *codeFile)
{
char arrayName[80];
char *newName;
int newID, newVersion;
/*===========================================*/
/* If a file is being reopened, use the same */
/* version number, name, and ID as before. */
/*===========================================*/
if (reopenOldFile)
{
if (codeFile == NULL)
{
SystemError("CONSCOMP",5);
ExitRouter(EXIT_FAILURE);
}
newName = codeFile->filePrefix;
newID = codeFile->id;
newVersion = codeFile->version;
}
/*=====================================================*/
/* Otherwise, use the specified version number, name, */
/* and ID. If the appropriate argument is supplied, */
/* remember these values for later reopening the file. */
/*=====================================================*/
else
{
newName = fileName;
newVersion = *fileCount;
newID = fileID;
if (codeFile != NULL)
{
codeFile->version = newVersion;
codeFile->filePrefix = newName;
codeFile->id = newID;
}
}
/*=========================================*/
/* If the file is already open, return it. */
/*=========================================*/
if (theFile != NULL)
{
fprintf(theFile,",\n");
return(theFile);
}
/*================*/
/* Open the file. */
/*================*/
if ((theFile = NewCFile(newName,newID,newVersion,reopenOldFile)) == NULL)
{ return(NULL); }
/*=========================================*/
/* If this is the first time the file has */
/* been opened, write out the beginning of */
/* the array variable definition. */
/*=========================================*/
if (reopenOldFile == FALSE)
{
(*fileCount)++;
sprintf(arrayName,"%s%d_%d",structPrefix,imageID,arrayVersion);
#if SHORT_LINK_NAMES
if (strlen(arrayName) > 6)
{
PrintWarningID("CONSCOMP",2,FALSE);
PrintRouter(WWARNING,"Array name ");
PrintRouter(WWARNING,arrayName);
PrintRouter(WWARNING,"exceeds 6 characters in length.\n");
PrintRouter(WWARNING," This variable may be indistinguishable from another by the linker.\n");
}
#endif
fprintf(theFile,"%s %s[] = {\n",structureName,arrayName);
fprintf(headerFP,"extern %s %s[];\n",structureName,arrayName);
}
else
{ fprintf(theFile,",\n"); }
/*==================*/
/* Return the file. */
/*==================*/
return(theFile);
}
globle FILE *CloseFileIfNeeded(
FILE *theFile,
int *theCount,
int *arrayVersion,
int maxIndices,
int *canBeReopened,
struct CodeGeneratorFile *codeFile)
{
/*==========================================*/
/* If the maximum number of entries for the */
/* file hasn't been exceeded, then... */
/*==========================================*/
if (*theCount < maxIndices)
{
/*====================================*/
/* If the file can be reopened later, */
/* close it. Otherwise, keep it open. */
/*====================================*/
if (canBeReopened != NULL)
{
*canBeReopened = TRUE;
fclose(theFile);
return(NULL);
}
return(theFile);
}
/*===========================================*/
/* Otherwise, the number of entries allowed */
/* in a file has been reached. Indicate that */
/* the file can't be reopened. */
/*===========================================*/
if (canBeReopened != NULL)
{ *canBeReopened = FALSE; }
/*===============================================*/
/* If the file is closed, then we need to reopen */
/* it to print the final closing right brace. */
/*===============================================*/
if (theFile == NULL)
{
if ((canBeReopened == NULL) || (codeFile == NULL))
{
SystemError("CONSCOMP",3);
ExitRouter(EXIT_FAILURE);
}
if (codeFile->filePrefix == NULL)
{ return(NULL); }
theFile = NewCFile(codeFile->filePrefix,codeFile->id,codeFile->version,TRUE);
if (theFile == NULL)
{
SystemError("CONSCOMP",4);
ExitRouter(EXIT_FAILURE);
}
}
/*================================*/
/* Print the final closing brace. */
/*================================*/
fprintf(theFile,"};\n");
fclose(theFile);
/*============================================*/
/* Update index values for subsequent writing */
/* of data structures to files. */
/*============================================*/
*theCount = 0;
(*arrayVersion)++;
/*=========================*/
/* Return NULL to indicate */
/* the file is closed. */
/*=========================*/
return(NULL);
}
/***********************************************************************
NAME : BloadStorageObjects
DESCRIPTION : This routine reads class and handler information from
a binary file in five chunks:
Class count
Handler count
Class array
Handler array
INPUTS : Notthing
RETURNS : Nothing useful
SIDE EFFECTS : Arrays allocated and set
NOTES : This routine makes no attempt to reset any pointers
within the structures
Bload fails if there are still classes in the system!!
***********************************************************************/
static void BloadStorageObjects()
{
UNLN space;
long counts[9];
if ((ClassIDMap != NULL) || (MaxClassID != 0))
{
SystemError("OBJBIN",1);
ExitRouter(EXIT_FAILURE);
}
GenRead((void *) &space,(UNLN) sizeof(UNLN));
if (space == 0L)
{
ClassCount = HandlerCount = 0L;
return;
}
GenRead((void *) counts,space);
ModuleCount = counts[0];
ClassCount = counts[1];
LinkCount = counts[2];
SlotNameCount = counts[3];
SlotCount = counts[4];
TemplateSlotCount = counts[5];
SlotNameMapCount = counts[6];
HandlerCount = counts[7];
MaxClassID = (unsigned short) counts[8];
if (ModuleCount != 0L)
{
space = (UNLN) (sizeof(DEFCLASS_MODULE) * ModuleCount);
ModuleArray = (DEFCLASS_MODULE *) genlongalloc(space);
}
if (ClassCount != 0L)
{
space = (UNLN) (sizeof(DEFCLASS) * ClassCount);
defclassArray = (DEFCLASS *) genlongalloc(space);
ClassIDMap = (DEFCLASS **) gm2((int) (sizeof(DEFCLASS *) * MaxClassID));
}
if (LinkCount != 0L)
{
space = (UNLN) (sizeof(DEFCLASS *) * LinkCount);
linkArray = (DEFCLASS * *) genlongalloc(space);
}
if (SlotCount != 0L)
{
space = (UNLN) (sizeof(SLOT_DESC) * SlotCount);
slotArray = (SLOT_DESC *) genlongalloc(space);
}
if (SlotNameCount != 0L)
{
space = (UNLN) (sizeof(SLOT_NAME) * SlotNameCount);
slotNameArray = (SLOT_NAME *) genlongalloc(space);
}
if (TemplateSlotCount != 0L)
{
space = (UNLN) (sizeof(SLOT_DESC *) * TemplateSlotCount);
tmpslotArray = (SLOT_DESC * *) genlongalloc(space);
}
if (SlotNameMapCount != 0L)
{
space = (UNLN) (sizeof(unsigned) * SlotNameMapCount);
mapslotArray = (unsigned *) genlongalloc(space);
}
if (HandlerCount != 0L)
{
space = (UNLN) (sizeof(HANDLER) * HandlerCount);
handlerArray = (HANDLER *) genlongalloc(space);
space = (UNLN) (sizeof(unsigned) * HandlerCount);
maphandlerArray = (unsigned *) genlongalloc(space);
}
}
static void EmptyDrive(
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(join->networkTest,NULL,rhsBinds,join);
EvaluationError = FALSE;
if (joinExpr == FALSE) return;
}
/*===========================================================*/
/* The first join of a rule cannot be connected to a NOT CE. */
/*===========================================================*/
if (join->patternIsNegated == TRUE)
{
SystemError("DRIVE",2);
ExitRouter(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(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(join->ruleToActivate,linker);
/*============================================*/
/* Send the partial match to all child joins. */
/*============================================*/
listOfJoins = join->nextLevel;
while (listOfJoins != NULL)
{
NetworkAssert(linker,listOfJoins,LHS);
listOfJoins = listOfJoins->rightDriveNode;
}
}
globle void GetNextPatternEntity(
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 = 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)(*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("PATTERN",1);
ExitRouter(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)(*theEntity);
if (*theEntity != NULL) return;
*theParser = (*theParser)->next;
}
return;
}
globle struct CodeGeneratorItem *AddCodeGeneratorItem(
char *name,
int priority,
void (*beforeFunction)(void),
void (*initFunction)(FILE *,int,int),
int (*generateFunction)(char *,int,FILE *,int,int),
int arrayCount)
{
struct CodeGeneratorItem *newPtr, *currentPtr, *lastPtr = NULL;
static int theCount = 0;
register int i;
char theBuffer[3];
/*======================================*/
/* Create the code generator item data */
/* structure and initialize its values. */
/*======================================*/
newPtr = get_struct(CodeGeneratorItem);
newPtr->name = name;
newPtr->beforeFunction = beforeFunction;
newPtr->initFunction = initFunction;
newPtr->generateFunction = generateFunction;
newPtr->priority = priority;
/*================================================*/
/* Create the primary and secondary codes used to */
/* provide names for the C data structure arrays. */
/* (The maximum number of arrays is currently */
/* limited to 47. */
/*================================================*/
if (arrayCount != 0)
{
if ((arrayCount + theCount) > (PRIMARY_LEN + SECONDARY_LEN))
{
SystemError("CONSCOMP",2);
ExitRouter(EXIT_FAILURE);
}
newPtr->arrayNames = (char **) gm2((int) (sizeof(char *) * arrayCount));
for (i = 0 ; i < arrayCount ; i++)
{
if (theCount < PRIMARY_LEN)
{ sprintf(theBuffer,"%c",PRIMARY_CODES[theCount]); }
else
{ sprintf(theBuffer,"%c_",SECONDARY_CODES[theCount - PRIMARY_LEN]); }
theCount++;
newPtr->arrayNames[i] = (char *) gm2((int) (strlen(theBuffer) + 1));
strcpy(newPtr->arrayNames[i],theBuffer);
}
}
else
{ newPtr->arrayNames = NULL; }
/*===========================================*/
/* Add the new item in the appropriate place */
/* in the code generator item list. */
/*===========================================*/
if (ListOfCodeGeneratorItems == NULL)
{
newPtr->next = NULL;
ListOfCodeGeneratorItems = newPtr;
return(newPtr);
}
currentPtr = ListOfCodeGeneratorItems;
while ((currentPtr != NULL) ? (priority < currentPtr->priority) : FALSE)
{
lastPtr = currentPtr;
currentPtr = currentPtr->next;
}
if (lastPtr == NULL)
{
newPtr->next = ListOfCodeGeneratorItems;
ListOfCodeGeneratorItems = newPtr;
}
else
{
newPtr->next = currentPtr;
lastPtr->next = newPtr;
}
/*=========================*/
/* Return a pointer to the */
/* code generator item. */
/*=========================*/
return(newPtr);
}
globle void NetworkRetract(
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(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("RETRACT",3);
ExitRouter(EXIT_FAILURE);
}
else
{ NegEntryRetract(joinPtr,listOfMatchedPatterns->theMatch,TRUE); }
}
}
/*===================================================*/
/* Remove from the alpha memory of the pattern node. */
/*===================================================*/
theLast = NULL;
listOfMatchedPatterns->matchingPattern->alphaMemory =
RemovePartialMatches(listOfMatchedPatterns->theMatch->binds[0].gm.theMatch,
listOfMatchedPatterns->matchingPattern->alphaMemory,
&deletedMatches,0,&theLast);
listOfMatchedPatterns->matchingPattern->endOfQueue = theLast;
DeletePartialMatches(deletedMatches,0);
tempMatch = listOfMatchedPatterns->next;
rtn_struct(patternMatch,listOfMatchedPatterns);
listOfMatchedPatterns = tempMatch;
}
/*=========================================*/
/* Filter new partial matches generated by */
/* retraction through the join network. */
/*=========================================*/
DriveRetractions();
}
/*****************************************************
NAME : PerformMessage
DESCRIPTION : Calls core framework for a message
INPUTS : 1) Caller's result buffer
2) Message argument expressions
(including implicit object)
3) Message name
RETURNS : Nothing useful
SIDE EFFECTS : Any side-effects of message execution
and caller's result buffer set
NOTES : None
*****************************************************/
static void PerformMessage(
DATA_OBJECT *result,
EXPRESSION *args,
SYMBOL_HN *mname)
{
int oldce;
HANDLER_LINK *oldCore;
DEFCLASS *cls = NULL;
INSTANCE_TYPE *ins = NULL;
SYMBOL_HN *oldName;
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
result->type = SYMBOL;
result->value = FalseSymbol;
EvaluationError = FALSE;
if (HaltExecution)
return;
oldce = ExecutingConstruct();
SetExecutingConstruct(TRUE);
oldName = CurrentMessageName;
CurrentMessageName = mname;
CurrentEvaluationDepth++;
PushProcParameters(args,CountArguments(args),
ValueToString(CurrentMessageName),"message",
UnboundHandlerErr);
if (EvaluationError)
{
CurrentEvaluationDepth--;
CurrentMessageName = oldName;
PeriodicCleanup(FALSE,TRUE);
SetExecutingConstruct(oldce);
return;
}
if (ProcParamArray->type == INSTANCE_ADDRESS)
{
ins = (INSTANCE_TYPE *) ProcParamArray->value;
if (ins->garbage == 1)
{
StaleInstanceAddress("send",0);
SetEvaluationError(TRUE);
}
else if (DefclassInScope(ins->cls,(struct defmodule *) GetCurrentModule()) == FALSE)
NoInstanceError(ValueToString(ins->name),"send");
else
{
cls = ins->cls;
ins->busy++;
}
}
else if (ProcParamArray->type == INSTANCE_NAME)
{
ins = FindInstanceBySymbol((SYMBOL_HN *) ProcParamArray->value);
if (ins == NULL)
{
PrintErrorID("MSGPASS",2,FALSE);
PrintRouter(WERROR,"No such instance ");
PrintRouter(WERROR,ValueToString((SYMBOL_HN *) ProcParamArray->value));
PrintRouter(WERROR," in function send.\n");
SetEvaluationError(TRUE);
}
else
{
ProcParamArray->value = (void *) ins;
ProcParamArray->type = INSTANCE_ADDRESS;
cls = ins->cls;
ins->busy++;
}
}
else if ((cls = PrimitiveClassMap[ProcParamArray->type]) == NULL)
{
SystemError("MSGPASS",1);
ExitRouter(EXIT_FAILURE);
}
if (EvaluationError)
{
PopProcParameters();
CurrentEvaluationDepth--;
CurrentMessageName = oldName;
PeriodicCleanup(FALSE,TRUE);
SetExecutingConstruct(oldce);
return;
}
oldCore = TopOfCore;
TopOfCore = FindApplicableHandlers(cls,mname);
if (TopOfCore != NULL)
{
HANDLER_LINK *oldCurrent,*oldNext;
oldCurrent = CurrentCore;
oldNext = NextInCore;
#if IMPERATIVE_MESSAGE_HANDLERS
if (TopOfCore->hnd->type == MAROUND)
{
CurrentCore = TopOfCore;
NextInCore = TopOfCore->nxt;
#if DEBUGGING_FUNCTIONS
if (WatchMessages)
WatchMessage(WTRACE,BEGIN_TRACE);
if (CurrentCore->hnd->trace)
WatchHandler(WTRACE,CurrentCore,BEGIN_TRACE);
#endif
if (CheckHandlerArgCount())
{
#if PROFILING_FUNCTIONS
StartProfile(&profileFrame,
&CurrentCore->hnd->usrData,
ProfileConstructs);
#endif
EvaluateProcActions(CurrentCore->hnd->cls->header.whichModule->theModule,
CurrentCore->hnd->actions,
CurrentCore->hnd->localVarCount,
result,UnboundHandlerErr);
#if PROFILING_FUNCTIONS
EndProfile(&profileFrame);
#endif
}
#if DEBUGGING_FUNCTIONS
if (CurrentCore->hnd->trace)
WatchHandler(WTRACE,CurrentCore,END_TRACE);
if (WatchMessages)
WatchMessage(WTRACE,END_TRACE);
#endif
}
else
#endif /* IMPERATIVE_MESSAGE_HANDLERS */
{
CurrentCore = NULL;
NextInCore = TopOfCore;
#if DEBUGGING_FUNCTIONS
if (WatchMessages)
WatchMessage(WTRACE,BEGIN_TRACE);
#endif
CallHandlers(result);
#if DEBUGGING_FUNCTIONS
if (WatchMessages)
WatchMessage(WTRACE,END_TRACE);
#endif
}
DestroyHandlerLinks(TopOfCore);
CurrentCore = oldCurrent;
NextInCore = oldNext;
}
TopOfCore = oldCore;
ReturnFlag = FALSE;
if (ins != NULL)
ins->busy--;
/* ==================================
Restore the original calling frame
================================== */
PopProcParameters();
CurrentEvaluationDepth--;
CurrentMessageName = oldName;
PropagateReturnValue(result);
PeriodicCleanup(FALSE,TRUE);
SetExecutingConstruct(oldce);
if (EvaluationError)
{
result->type = SYMBOL;
result->value = FalseSymbol;
}
}
