globle void EnvSlotCardinality(
void *theEnv,
void *clsptr,
const char *sname,
DATA_OBJECT *result)
{
register SLOT_DESC *sp;
if ((sp = SlotInfoSlot(theEnv,result,(DEFCLASS *) clsptr,sname,"slot-cardinality")) == NULL)
return;
if (sp->multiple == 0)
{
EnvSetMultifieldErrorValue(theEnv,result);
return;
}
result->end = 1;
result->value = EnvCreateMultifield(theEnv,2L);
if (sp->constraint != NULL)
{
SetMFType(result->value,1,sp->constraint->minFields->type);
SetMFValue(result->value,1,sp->constraint->minFields->value);
SetMFType(result->value,2,sp->constraint->maxFields->type);
SetMFValue(result->value,2,sp->constraint->maxFields->value);
}
else
{
SetMFType(result->value,1,INTEGER);
SetMFValue(result->value,1,SymbolData(theEnv)->Zero);
SetMFType(result->value,2,SYMBOL);
SetMFValue(result->value,2,SymbolData(theEnv)->PositiveInfinity);
}
}
static BOOLEAN GetDefglobalValue2(
void *theEnv,
void *theValue,
DATA_OBJECT_PTR vPtr)
{
struct defglobal *theGlobal;
int count;
/*===========================================*/
/* Search for the specified defglobal in the */
/* modules visible to the current module. */
/*===========================================*/
theGlobal = (struct defglobal *)
FindImportedConstruct(theEnv,"defglobal",NULL,ValueToString(theValue),
&count,TRUE,NULL);
/*=============================================*/
/* If it wasn't found, print an error message. */
/*=============================================*/
if (theGlobal == NULL)
{
PrintErrorID(theEnv,"GLOBLDEF",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Global variable ?*");
EnvPrintRouter(theEnv,WERROR,ValueToString(theValue));
EnvPrintRouter(theEnv,WERROR,"* is unbound.\n");
vPtr->type = SYMBOL;
vPtr->value = SymbolData(theEnv)->FalseSymbol;
SetEvaluationError(theEnv,TRUE);
return(FALSE);
}
/*========================================================*/
/* The current implementation of the defmodules shouldn't */
/* allow a construct to be defined which would cause an */
/* ambiguous reference, but we'll check for it anyway. */
/*========================================================*/
if (count > 1)
{
AmbiguousReferenceErrorMessage(theEnv,"defglobal",ValueToString(theValue));
vPtr->type = SYMBOL;
vPtr->value = SymbolData(theEnv)->FalseSymbol;
SetEvaluationError(theEnv,TRUE);
return(FALSE);
}
/*=================================*/
/* Get the value of the defglobal. */
/*=================================*/
QGetDefglobalValue(theEnv,theGlobal,vPtr);
return(TRUE);
}
static intBool CheckRangeAgainstCardinalityConstraint(
void *theEnv,
EXEC_STATUS,
int min,
int max,
CONSTRAINT_RECORD *constraints)
{
/*=========================================*/
/* If the constraint record is NULL, there */
/* are no cardinality restrictions. */
/*=========================================*/
if (constraints == NULL) return(TRUE);
/*===============================================================*/
/* If the minimum value of the range is greater than the maximum */
/* value of the cardinality, then there are no numbers in the */
/* range which could fall within the cardinality range, and so */
/* FALSE is returned. */
/*===============================================================*/
if (constraints->maxFields != NULL)
{
if (constraints->maxFields->value != SymbolData(theEnv,execStatus)->PositiveInfinity)
{
if (min > ValueToLong(constraints->maxFields->value))
{ return(FALSE); }
}
}
/*===============================================================*/
/* If the maximum value of the range is less than the minimum */
/* value of the cardinality, then there are no numbers in the */
/* range which could fall within the cardinality range, and so */
/* FALSE is returned. A maximum range value of -1 indicates that */
/* the maximum possible value of the range is positive infinity. */
/*===============================================================*/
if ((constraints->minFields != NULL) && (max != -1))
{
if (constraints->minFields->value != SymbolData(theEnv,execStatus)->NegativeInfinity)
{
if (max < ValueToLong(constraints->minFields->value))
{ return(FALSE); }
}
}
/*=============================================*/
/* At least one number in the specified range */
/* falls within the allowed cardinality range. */
/*=============================================*/
return(TRUE);
}
static void PrintRange(
void *theEnv,
const char *logicalName,
CONSTRAINT_RECORD *theConstraint)
{
if (theConstraint->minValue->value == SymbolData(theEnv)->NegativeInfinity)
{ EnvPrintRouter(theEnv,logicalName,ValueToString(SymbolData(theEnv)->NegativeInfinity)); }
else PrintExpression(theEnv,logicalName,theConstraint->minValue);
EnvPrintRouter(theEnv,logicalName," to ");
if (theConstraint->maxValue->value == SymbolData(theEnv)->PositiveInfinity)
{ EnvPrintRouter(theEnv,logicalName,ValueToString(SymbolData(theEnv)->PositiveInfinity)); }
else PrintExpression(theEnv,logicalName,theConstraint->maxValue);
}
static void ResetDefinstancesAction(
void *theEnv,
struct constructHeader *vDefinstances,
void *userBuffer)
{
#if MAC_MCW || IBM_MCW
#pragma unused(userBuffer)
#endif
DEFINSTANCES *theDefinstances = (DEFINSTANCES *) vDefinstances;
EXPRESSION *exp;
DATA_OBJECT temp;
SaveCurrentModule(theEnv);
EnvSetCurrentModule(theEnv,(void *) vDefinstances->whichModule->theModule);
theDefinstances->busy++;
for (exp = theDefinstances->mkinstance ;
exp != NULL ;
exp = GetNextArgument(exp))
{
EvaluateExpression(theEnv,exp,&temp);
if (EvaluationData(theEnv)->HaltExecution ||
((GetType(temp) == SYMBOL) &&
(GetValue(temp) == SymbolData(theEnv)->FalseSymbol)))
{
RestoreCurrentModule(theEnv);
theDefinstances->busy--;
return;
}
}
theDefinstances->busy--;
RestoreCurrentModule(theEnv);
}
globle intBool CheckCardinalityConstraint(
void *theEnv,
EXEC_STATUS,
long number,
CONSTRAINT_RECORD *constraints)
{
/*=========================================*/
/* If the constraint record is NULL, there */
/* are no cardinality restrictions. */
/*=========================================*/
if (constraints == NULL) return(TRUE);
/*==================================*/
/* Determine if the integer is less */
/* than the minimum cardinality. */
/*==================================*/
if (constraints->minFields != NULL)
{
if (constraints->minFields->value != SymbolData(theEnv,execStatus)->NegativeInfinity)
{
if (number < ValueToLong(constraints->minFields->value))
{ return(FALSE); }
}
}
/*=====================================*/
/* Determine if the integer is greater */
/* than the maximum cardinality. */
/*=====================================*/
if (constraints->maxFields != NULL)
{
if (constraints->maxFields->value != SymbolData(theEnv,execStatus)->PositiveInfinity)
{
if (number > ValueToLong(constraints->maxFields->value))
{ return(FALSE); }
}
}
/*=========================================================*/
/* The integer falls within the allowed cardinality range. */
/*=========================================================*/
return(TRUE);
}
globle void ReadNeededIntegers(
void *theEnv)
{
long long *integerValues;
long i;
/*==============================================*/
/* Determine the number of integers to be read. */
/*==============================================*/
GenReadBinary(theEnv,&SymbolData(theEnv)->NumberOfIntegers,(unsigned long) sizeof(unsigned long int));
if (SymbolData(theEnv)->NumberOfIntegers == 0)
{
SymbolData(theEnv)->IntegerArray = NULL;
return;
}
/*=================================*/
/* Allocate area for the integers. */
/*=================================*/
integerValues = (long long *) gm3(theEnv,(long) (sizeof(long long) * SymbolData(theEnv)->NumberOfIntegers));
GenReadBinary(theEnv,(void *) integerValues,(unsigned long) (sizeof(long long) * SymbolData(theEnv)->NumberOfIntegers));
/*==========================================*/
/* Store the integers in the integer array. */
/*==========================================*/
SymbolData(theEnv)->IntegerArray = (INTEGER_HN **)
gm3(theEnv,(long) (sizeof(INTEGER_HN *) * SymbolData(theEnv)->NumberOfIntegers));
for (i = 0; i < SymbolData(theEnv)->NumberOfIntegers; i++)
{ SymbolData(theEnv)->IntegerArray[i] = (INTEGER_HN *) EnvAddLong(theEnv,integerValues[i]); }
/*==========================*/
/* Free the integer buffer. */
/*==========================*/
rm3(theEnv,(void *) integerValues,(long) (sizeof(long long) * SymbolData(theEnv)->NumberOfIntegers));
}
globle void ReadNeededFloats(
void *theEnv)
{
double *floatValues;
long i;
/*============================================*/
/* Determine the number of floats to be read. */
/*============================================*/
GenReadBinary(theEnv,&SymbolData(theEnv)->NumberOfFloats,(unsigned long) sizeof(long int));
if (SymbolData(theEnv)->NumberOfFloats == 0)
{
SymbolData(theEnv)->FloatArray = NULL;
return;
}
/*===============================*/
/* Allocate area for the floats. */
/*===============================*/
floatValues = (double *) gm3(theEnv,(long) sizeof(double) * SymbolData(theEnv)->NumberOfFloats);
GenReadBinary(theEnv,(void *) floatValues,(unsigned long) (sizeof(double) * SymbolData(theEnv)->NumberOfFloats));
/*======================================*/
/* Store the floats in the float array. */
/*======================================*/
SymbolData(theEnv)->FloatArray = (FLOAT_HN **)
gm3(theEnv,(long) sizeof(FLOAT_HN *) * SymbolData(theEnv)->NumberOfFloats);
for (i = 0; i < SymbolData(theEnv)->NumberOfFloats; i++)
{ SymbolData(theEnv)->FloatArray[i] = (FLOAT_HN *) EnvAddDouble(theEnv,floatValues[i]); }
/*========================*/
/* Free the float buffer. */
/*========================*/
rm3(theEnv,(void *) floatValues,(long) (sizeof(double) * SymbolData(theEnv)->NumberOfFloats));
}
globle struct constraintRecord *GetConstraintRecord(
void *theEnv,
EXEC_STATUS)
{
CONSTRAINT_RECORD *constraints;
unsigned i;
constraints = get_struct(theEnv,execStatus,constraintRecord);
for (i = 0 ; i < sizeof(CONSTRAINT_RECORD) ; i++)
{ ((char *) constraints)[i] = '\0'; }
SetAnyAllowedFlags(constraints,TRUE);
constraints->multifieldsAllowed = FALSE;
constraints->singlefieldsAllowed = TRUE;
constraints->anyRestriction = FALSE;
constraints->symbolRestriction = FALSE;
constraints->stringRestriction = FALSE;
constraints->floatRestriction = FALSE;
constraints->integerRestriction = FALSE;
constraints->classRestriction = FALSE;
constraints->instanceNameRestriction = FALSE;
constraints->classList = NULL;
constraints->restrictionList = NULL;
constraints->minValue = GenConstant(theEnv,execStatus,SYMBOL,SymbolData(theEnv,execStatus)->NegativeInfinity);
constraints->maxValue = GenConstant(theEnv,execStatus,SYMBOL,SymbolData(theEnv,execStatus)->PositiveInfinity);
constraints->minFields = GenConstant(theEnv,execStatus,INTEGER,SymbolData(theEnv,execStatus)->Zero);
constraints->maxFields = GenConstant(theEnv,execStatus,SYMBOL,SymbolData(theEnv,execStatus)->PositiveInfinity);
constraints->bucket = -1;
constraints->count = 0;
constraints->multifield = NULL;
constraints->next = NULL;
return(constraints);
}
globle int SetFactDuplicationCommand(
void *theEnv)
{
int oldValue;
DATA_OBJECT theValue;
/*=====================================================*/
/* Get the old value of the fact duplication behavior. */
/*=====================================================*/
oldValue = EnvGetFactDuplication(theEnv);
/*============================================*/
/* Check for the correct number of arguments. */
/*============================================*/
if (EnvArgCountCheck(theEnv,"set-fact-duplication",EXACTLY,1) == -1)
{
return(oldValue);
}
/*========================*/
/* Evaluate the argument. */
/*========================*/
EnvRtnUnknown(theEnv,1,&theValue);
/*===============================================================*/
/* If the argument evaluated to FALSE, then the fact duplication */
/* behavior is disabled, otherwise it is enabled. */
/*===============================================================*/
if ((theValue.value == SymbolData(theEnv)->FalseSymbol) && (theValue.type == SYMBOL))
{
EnvSetFactDuplication(theEnv,FALSE);
}
else
{
EnvSetFactDuplication(theEnv,TRUE);
}
/*========================================================*/
/* Return the old value of the fact duplication behavior. */
/*========================================================*/
return(oldValue);
}
static void ReadNeededBitMaps(
void *theEnv)
{
char *bitMapStorage, *bitMapPtr;
unsigned long space;
long i;
unsigned short *tempSize;
/*=======================================*/
/* Determine the number of bitmaps to be */
/* read and space required for them. */
/*=======================================*/
GenReadBinary(theEnv,(void *) &SymbolData(theEnv)->NumberOfBitMaps,(unsigned long) sizeof(long int));
GenReadBinary(theEnv,&space,(unsigned long) sizeof(unsigned long int));
if (SymbolData(theEnv)->NumberOfBitMaps == 0)
{
SymbolData(theEnv)->BitMapArray = NULL;
return;
}
/*=======================================*/
/* Allocate area for bitmaps to be read. */
/*=======================================*/
bitMapStorage = (char *) gm3(theEnv,(long) space);
GenReadBinary(theEnv,(void *) bitMapStorage,space);
/*================================================*/
/* Store the bitMap pointers in the bitmap array. */
/*================================================*/
SymbolData(theEnv)->BitMapArray = (BITMAP_HN **)
gm3(theEnv,(long) sizeof(BITMAP_HN *) * SymbolData(theEnv)->NumberOfBitMaps);
bitMapPtr = bitMapStorage;
for (i = 0; i < SymbolData(theEnv)->NumberOfBitMaps; i++)
{
tempSize = (unsigned short *) bitMapPtr;
SymbolData(theEnv)->BitMapArray[i] = (BITMAP_HN *) EnvAddBitMap(theEnv,bitMapPtr+sizeof(unsigned short),*tempSize);
bitMapPtr += *tempSize + sizeof(unsigned short);
}
/*=========================*/
/* Free the bitmap buffer. */
/*=========================*/
rm3(theEnv,(void *) bitMapStorage,(long) space);
}
globle void ReadNeededSymbols(
void *theEnv)
{
char *symbolNames, *namePtr;
unsigned long space;
long i;
/*=================================================*/
/* Determine the number of symbol names to be read */
/* and space required for them. */
/*=================================================*/
GenReadBinary(theEnv,(void *) &SymbolData(theEnv)->NumberOfSymbols,(unsigned long) sizeof(long int));
GenReadBinary(theEnv,&space,(unsigned long) sizeof(unsigned long int));
if (SymbolData(theEnv)->NumberOfSymbols == 0)
{
SymbolData(theEnv)->SymbolArray = NULL;
return;
}
/*=======================================*/
/* Allocate area for strings to be read. */
/*=======================================*/
symbolNames = (char *) gm3(theEnv,(long) space);
GenReadBinary(theEnv,(void *) symbolNames,space);
/*================================================*/
/* Store the symbol pointers in the symbol array. */
/*================================================*/
SymbolData(theEnv)->SymbolArray = (SYMBOL_HN **)
gm3(theEnv,(long) sizeof(SYMBOL_HN *) * SymbolData(theEnv)->NumberOfSymbols);
namePtr = symbolNames;
for (i = 0; i < SymbolData(theEnv)->NumberOfSymbols; i++)
{
SymbolData(theEnv)->SymbolArray[i] = (SYMBOL_HN *) EnvAddSymbol(theEnv,namePtr);
namePtr += strlen(namePtr) + 1;
}
/*=======================*/
/* Free the name buffer. */
/*=======================*/
rm3(theEnv,(void *) symbolNames,(long) space);
}
static int DefaultCompareSwapFunction(
void *theEnv,
DATA_OBJECT *item1,
DATA_OBJECT *item2)
{
DATA_OBJECT returnValue;
SortFunctionData(theEnv)->SortComparisonFunction->argList = GenConstant(theEnv,item1->type,item1->value);
SortFunctionData(theEnv)->SortComparisonFunction->argList->nextArg = GenConstant(theEnv,item2->type,item2->value);
ExpressionInstall(theEnv,SortFunctionData(theEnv)->SortComparisonFunction);
EvaluateExpression(theEnv,SortFunctionData(theEnv)->SortComparisonFunction,&returnValue);
ExpressionDeinstall(theEnv,SortFunctionData(theEnv)->SortComparisonFunction);
ReturnExpression(theEnv,SortFunctionData(theEnv)->SortComparisonFunction->argList);
SortFunctionData(theEnv)->SortComparisonFunction->argList = NULL;
if ((GetType(returnValue) == SYMBOL) &&
(GetValue(returnValue) == SymbolData(theEnv)->FalseSymbol))
{ return(FALSE); }
return(TRUE);
}
globle void AssertStringFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
DATA_OBJECT argPtr;
struct fact *theFact;
/*===================================================*/
/* Set the default return value to the symbol FALSE. */
/*===================================================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,SymbolData(theEnv)->FalseSymbol);
/*=====================================================*/
/* Check for the correct number and type of arguments. */
/*=====================================================*/
if (EnvArgCountCheck(theEnv,"assert-string",EXACTLY,1) == -1) return;
if (EnvArgTypeCheck(theEnv,"assert-string",1,STRING,&argPtr) == FALSE)
{
return;
}
/*==========================================*/
/* Call the driver routine for converting a */
/* string to a fact and then assert it. */
/*==========================================*/
theFact = (struct fact *) EnvAssertString(theEnv,DOToString(argPtr));
if (theFact != NULL)
{
SetpType(returnValue,FACT_ADDRESS);
SetpValue(returnValue,(void *) theFact);
}
return;
}
globle BOOLEAN EvaluateJoinExpression(
void *theEnv,
struct expr *joinExpr,
struct partialMatch *lbinds,
struct partialMatch *rbinds,
struct joinNode *joinPtr)
{
DATA_OBJECT theResult;
int andLogic, result = TRUE;
struct partialMatch *oldLHSBinds;
struct partialMatch *oldRHSBinds;
struct joinNode *oldJoin;
/*======================================*/
/* A NULL expression evaluates to TRUE. */
/*======================================*/
if (joinExpr == NULL) return(TRUE);
/*=========================================*/
/* Initialize some of the global variables */
/* used when evaluating expressions. */
/*=========================================*/
oldLHSBinds = EngineData(theEnv)->GlobalLHSBinds;
oldRHSBinds = EngineData(theEnv)->GlobalRHSBinds;
oldJoin = EngineData(theEnv)->GlobalJoin;
EngineData(theEnv)->GlobalLHSBinds = lbinds;
EngineData(theEnv)->GlobalRHSBinds = rbinds;
EngineData(theEnv)->GlobalJoin = joinPtr;
/*=====================================================*/
/* Partial matches stored in joins that are associated */
/* with a not CE contain an additional slot shouldn't */
/* be considered when evaluating expressions. Since */
/* joins that have joins from the right don't have any */
/* expression, we don't have to do this for partial */
/* matches contained in these joins. */
/*=====================================================*/
if (joinPtr->patternIsNegated) lbinds->bcount--;
/*====================================================*/
/* Initialize some variables which allow this routine */
/* to avoid calling the "and" and "or" functions if */
/* they are the first part of the expression to be */
/* evaluated. Most of the join expressions do not use */
/* deeply nested and/or functions so this technique */
/* speeds up evaluation. */
/*====================================================*/
if (joinExpr->value == ExpressionData(theEnv)->PTR_AND)
{
andLogic = TRUE;
joinExpr = joinExpr->argList;
}
else if (joinExpr->value == ExpressionData(theEnv)->PTR_OR)
{
andLogic = FALSE;
joinExpr = joinExpr->argList;
}
else
{ andLogic = TRUE; }
/*=========================================*/
/* Evaluate each of the expressions linked */
/* together in the join expression. */
/*=========================================*/
while (joinExpr != NULL)
{
/*================================*/
/* Evaluate a primitive function. */
/*================================*/
if ((EvaluationData(theEnv)->PrimitivesArray[joinExpr->type] == NULL) ?
FALSE :
EvaluationData(theEnv)->PrimitivesArray[joinExpr->type]->evaluateFunction != NULL)
{
struct expr *oldArgument;
oldArgument = EvaluationData(theEnv)->CurrentExpression;
EvaluationData(theEnv)->CurrentExpression = joinExpr;
result = (*EvaluationData(theEnv)->PrimitivesArray[joinExpr->type]->evaluateFunction)(theEnv,joinExpr->value,&theResult);
EvaluationData(theEnv)->CurrentExpression = oldArgument;
}
/*=============================*/
/* Evaluate the "or" function. */
/*=============================*/
else if (joinExpr->value == ExpressionData(theEnv)->PTR_OR)
{
result = FALSE;
if (EvaluateJoinExpression(theEnv,joinExpr,lbinds,rbinds,joinPtr) == TRUE)
{
if (EvaluationData(theEnv)->EvaluationError)
{
if (joinPtr->patternIsNegated) lbinds->bcount++;
EngineData(theEnv)->GlobalLHSBinds = oldLHSBinds;
EngineData(theEnv)->GlobalRHSBinds = oldRHSBinds;
EngineData(theEnv)->GlobalJoin = oldJoin;
return(FALSE);
}
result = TRUE;
}
else if (EvaluationData(theEnv)->EvaluationError)
{
if (joinPtr->patternIsNegated) lbinds->bcount++;
EngineData(theEnv)->GlobalLHSBinds = oldLHSBinds;
EngineData(theEnv)->GlobalRHSBinds = oldRHSBinds;
EngineData(theEnv)->GlobalJoin = oldJoin;
return(FALSE);
}
}
/*==============================*/
/* Evaluate the "and" function. */
/*==============================*/
else if (joinExpr->value == ExpressionData(theEnv)->PTR_AND)
{
result = TRUE;
if (EvaluateJoinExpression(theEnv,joinExpr,lbinds,rbinds,joinPtr) == FALSE)
{
if (EvaluationData(theEnv)->EvaluationError)
{
if (joinPtr->patternIsNegated) lbinds->bcount++;
EngineData(theEnv)->GlobalLHSBinds = oldLHSBinds;
EngineData(theEnv)->GlobalRHSBinds = oldRHSBinds;
EngineData(theEnv)->GlobalJoin = oldJoin;
return(FALSE);
}
result = FALSE;
}
else if (EvaluationData(theEnv)->EvaluationError)
{
if (joinPtr->patternIsNegated) lbinds->bcount++;
EngineData(theEnv)->GlobalLHSBinds = oldLHSBinds;
EngineData(theEnv)->GlobalRHSBinds = oldRHSBinds;
EngineData(theEnv)->GlobalJoin = oldJoin;
return(FALSE);
}
}
/*==========================================================*/
/* Evaluate all other expressions using EvaluateExpression. */
/*==========================================================*/
else
{
EvaluateExpression(theEnv,joinExpr,&theResult);
if (EvaluationData(theEnv)->EvaluationError)
{
JoinNetErrorMessage(theEnv,joinPtr);
if (joinPtr->patternIsNegated) lbinds->bcount++;
EngineData(theEnv)->GlobalLHSBinds = oldLHSBinds;
EngineData(theEnv)->GlobalRHSBinds = oldRHSBinds;
EngineData(theEnv)->GlobalJoin = oldJoin;
return(FALSE);
}
if ((theResult.value == SymbolData(theEnv)->FalseSymbol) && (theResult.type == SYMBOL))
{ result = FALSE; }
else
{ result = TRUE; }
}
/*====================================*/
/* Handle the short cut evaluation of */
/* the "and" and "or" functions. */
/*====================================*/
if ((andLogic == TRUE) && (result == FALSE))
{
if (joinPtr->patternIsNegated) lbinds->bcount++;
EngineData(theEnv)->GlobalLHSBinds = oldLHSBinds;
EngineData(theEnv)->GlobalRHSBinds = oldRHSBinds;
EngineData(theEnv)->GlobalJoin = oldJoin;
return(FALSE);
}
else if ((andLogic == FALSE) && (result == TRUE))
{
if (joinPtr->patternIsNegated) lbinds->bcount++;
EngineData(theEnv)->GlobalLHSBinds = oldLHSBinds;
EngineData(theEnv)->GlobalRHSBinds = oldRHSBinds;
EngineData(theEnv)->GlobalJoin = oldJoin;
return(TRUE);
}
/*==============================================*/
/* Move to the next expression to be evaluated. */
/*==============================================*/
joinExpr = joinExpr->nextArg;
}
/*=======================================*/
/* Restore some of the global variables. */
/*=======================================*/
EngineData(theEnv)->GlobalLHSBinds = oldLHSBinds;
EngineData(theEnv)->GlobalRHSBinds = oldRHSBinds;
EngineData(theEnv)->GlobalJoin = oldJoin;
/*=====================================*/
/* Restore the count value for the LHS */
/* binds if it had to be modified. */
/*=====================================*/
if (joinPtr->patternIsNegated) lbinds->bcount++;
/*=================================================*/
/* Return the result of evaluating the expression. */
/*=================================================*/
return(result);
}
struct lhsParseNode *RestrictionParse(
void *theEnv,
char *readSource,
struct token *theToken,
int multifieldSlot,
struct symbolHashNode *theSlot,
short slotNumber,
CONSTRAINT_RECORD *theConstraints,
short position)
{
struct lhsParseNode *topNode = NULL, *lastNode = NULL, *nextNode;
int numberOfSingleFields = 0;
int numberOfMultifields = 0;
short startPosition = position;
int error = FALSE;
CONSTRAINT_RECORD *tempConstraints;
/*==================================================*/
/* Keep parsing fields until a right parenthesis is */
/* encountered. This will either indicate the end */
/* of an instance or deftemplate slot or the end of */
/* an ordered fact. */
/*==================================================*/
while (theToken->type != RPAREN)
{
/*========================================*/
/* Look for either a single or multifield */
/* wildcard or a conjuctive restriction. */
/*========================================*/
if ((theToken->type == SF_WILDCARD) ||
(theToken->type == MF_WILDCARD))
{
nextNode = GetLHSParseNode(theEnv);
nextNode->type = theToken->type;
nextNode->negated = FALSE;
nextNode->exists = FALSE;
GetToken(theEnv,readSource,theToken);
}
else
{
nextNode = ConjuctiveRestrictionParse(theEnv,readSource,theToken,&error);
if (nextNode == NULL)
{
ReturnLHSParseNodes(theEnv,topNode);
return(NULL);
}
}
/*========================================================*/
/* Fix up the pretty print representation of a multifield */
/* slot so that the fields don't run together. */
/*========================================================*/
if ((theToken->type != RPAREN) && (multifieldSlot == TRUE))
{
PPBackup(theEnv);
SavePPBuffer(theEnv," ");
SavePPBuffer(theEnv,theToken->printForm);
}
/*========================================*/
/* Keep track of the number of single and */
/* multifield restrictions encountered. */
/*========================================*/
if ((nextNode->type == SF_WILDCARD) || (nextNode->type == SF_VARIABLE))
{ numberOfSingleFields++; }
else
{ numberOfMultifields++; }
/*===================================*/
/* Assign the slot name and indices. */
/*===================================*/
nextNode->slot = theSlot;
nextNode->slotNumber = slotNumber;
nextNode->index = position++;
/*==============================================*/
/* If we're not dealing with a multifield slot, */
/* attach the constraints directly to the node */
/* and return. */
/*==============================================*/
if (! multifieldSlot)
{
if (theConstraints == NULL)
{
if (nextNode->type == SF_VARIABLE)
{ nextNode->constraints = GetConstraintRecord(theEnv); }
else nextNode->constraints = NULL;
}
else nextNode->constraints = theConstraints;
return(nextNode);
}
/*====================================================*/
/* Attach the restriction to the list of restrictions */
/* already parsed for this slot or ordered fact. */
/*====================================================*/
if (lastNode == NULL) topNode = nextNode;
else lastNode->right = nextNode;
lastNode = nextNode;
}
/*=====================================================*/
/* Once we're through parsing, check to make sure that */
/* a single field slot was given a restriction. If the */
/* following test fails, then we know we're dealing */
/* with a multifield slot. */
/*=====================================================*/
if ((topNode == NULL) && (! multifieldSlot))
{
SyntaxErrorMessage(theEnv,"defrule");
return(NULL);
}
/*===============================================*/
/* Loop through each of the restrictions in the */
/* list of restrictions for the multifield slot. */
/*===============================================*/
for (nextNode = topNode; nextNode != NULL; nextNode = nextNode->right)
{
/*===================================================*/
/* Assign a constraint record to each constraint. If */
/* the slot has an explicit constraint, then copy */
/* this and store it with the constraint. Otherwise, */
/* create a constraint record for a single field */
/* constraint and skip the constraint modifications */
/* for a multifield constraint. */
/*===================================================*/
if (theConstraints == NULL)
{
if (nextNode->type == SF_VARIABLE)
{ nextNode->constraints = GetConstraintRecord(theEnv); }
else
{ continue; }
}
else
{ nextNode->constraints = CopyConstraintRecord(theEnv,theConstraints); }
/*==========================================*/
/* Remove the min and max field constraints */
/* for the entire slot from the constraint */
/* record for this single constraint. */
/*==========================================*/
ReturnExpression(theEnv,nextNode->constraints->minFields);
ReturnExpression(theEnv,nextNode->constraints->maxFields);
nextNode->constraints->minFields = GenConstant(theEnv,SYMBOL,SymbolData(theEnv)->NegativeInfinity);
nextNode->constraints->maxFields = GenConstant(theEnv,SYMBOL,SymbolData(theEnv)->PositiveInfinity);
nextNode->derivedConstraints = TRUE;
/*====================================================*/
/* If we're not dealing with a multifield constraint, */
/* then no further modifications are needed to the */
/* min and max constraints for this constraint. */
/*====================================================*/
if ((nextNode->type != MF_WILDCARD) && (nextNode->type != MF_VARIABLE))
{ continue; }
/*==========================================================*/
/* Create a separate constraint record to keep track of the */
/* cardinality information for this multifield constraint. */
/*==========================================================*/
tempConstraints = GetConstraintRecord(theEnv);
SetConstraintType(MULTIFIELD,tempConstraints);
tempConstraints->singlefieldsAllowed = FALSE;
tempConstraints->multifield = nextNode->constraints;
nextNode->constraints = tempConstraints;
/*=====================================================*/
/* Adjust the min and max field values for this single */
/* multifield constraint based on the min and max */
/* fields for the entire slot and the number of single */
/* field values contained in the slot. */
/*=====================================================*/
if (theConstraints->maxFields->value != SymbolData(theEnv)->PositiveInfinity)
{
ReturnExpression(theEnv,tempConstraints->maxFields);
tempConstraints->maxFields = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,ValueToLong(theConstraints->maxFields->value) - numberOfSingleFields));
}
if ((numberOfMultifields == 1) && (theConstraints->minFields->value != SymbolData(theEnv)->NegativeInfinity))
{
ReturnExpression(theEnv,tempConstraints->minFields);
tempConstraints->minFields = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,ValueToLong(theConstraints->minFields->value) - numberOfSingleFields));
}
}
/*================================================*/
/* If a multifield slot is being parsed, place a */
/* node on top of the list of constraints parsed. */
/*================================================*/
if (multifieldSlot)
{
nextNode = GetLHSParseNode(theEnv);
nextNode->type = MF_WILDCARD;
nextNode->multifieldSlot = TRUE;
nextNode->bottom = topNode;
nextNode->slot = theSlot;
nextNode->slotNumber = slotNumber;
nextNode->index = startPosition;
nextNode->constraints = theConstraints;
topNode = nextNode;
TallyFieldTypes(topNode->bottom);
}
/*=================================*/
/* Return the list of constraints. */
/*=================================*/
return(topNode);
}
globle void SortFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
long argumentCount, i, j, k = 0;
DATA_OBJECT *theArguments, *theArguments2;
DATA_OBJECT theArg;
struct multifield *theMultifield, *tempMultifield;
char *functionName;
struct expr *functionReference;
int argumentSize = 0;
struct FunctionDefinition *fptr;
#if DEFFUNCTION_CONSTRUCT
DEFFUNCTION *dptr;
#endif
/*==================================*/
/* Set up the default return value. */
/*==================================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,SymbolData(theEnv)->FalseSymbol);
/*=============================================*/
/* The function expects at least one argument. */
/*=============================================*/
if ((argumentCount = EnvArgCountCheck(theEnv,"sort",AT_LEAST,1)) == -1)
{ return; }
/*=============================================*/
/* Verify that the comparison function exists. */
/*=============================================*/
if (EnvArgTypeCheck(theEnv,"sort",1,SYMBOL,&theArg) == FALSE)
{ return; }
functionName = DOToString(theArg);
functionReference = FunctionReferenceExpression(theEnv,functionName);
if (functionReference == NULL)
{
ExpectedTypeError1(theEnv,"sort",1,"function name, deffunction name, or defgeneric name");
return;
}
/*======================================*/
/* For an external function, verify the */
/* correct number of arguments. */
/*======================================*/
if (functionReference->type == FCALL)
{
fptr = (struct FunctionDefinition *) functionReference->value;
if ((GetMinimumArgs(fptr) > 2) ||
(GetMaximumArgs(fptr) == 0) ||
(GetMaximumArgs(fptr) == 1))
{
ExpectedTypeError1(theEnv,"sort",1,"function name expecting two arguments");
ReturnExpression(theEnv,functionReference);
return;
}
}
/*=======================================*/
/* For a deffunction, verify the correct */
/* number of arguments. */
/*=======================================*/
#if DEFFUNCTION_CONSTRUCT
if (functionReference->type == PCALL)
{
dptr = (DEFFUNCTION *) functionReference->value;
if ((dptr->minNumberOfParameters > 2) ||
(dptr->maxNumberOfParameters == 0) ||
(dptr->maxNumberOfParameters == 1))
{
ExpectedTypeError1(theEnv,"sort",1,"deffunction name expecting two arguments");
ReturnExpression(theEnv,functionReference);
return;
}
}
#endif
/*=====================================*/
/* If there are no items to be sorted, */
/* then return an empty multifield. */
/*=====================================*/
if (argumentCount == 1)
{
EnvSetMultifieldErrorValue(theEnv,returnValue);
ReturnExpression(theEnv,functionReference);
return;
}
/*=====================================*/
/* Retrieve the arguments to be sorted */
/* and determine how many there are. */
/*=====================================*/
theArguments = (DATA_OBJECT *) genalloc(theEnv,(argumentCount - 1) * sizeof(DATA_OBJECT));
for (i = 2; i <= argumentCount; i++)
{
EnvRtnUnknown(theEnv,i,&theArguments[i-2]);
if (GetType(theArguments[i-2]) == MULTIFIELD)
{ argumentSize += GetpDOLength(&theArguments[i-2]); }
else
{ argumentSize++; }
}
if (argumentSize == 0)
{
EnvSetMultifieldErrorValue(theEnv,returnValue);
ReturnExpression(theEnv,functionReference);
return;
}
/*====================================*/
/* Pack all of the items to be sorted */
/* into a data object array. */
/*====================================*/
theArguments2 = (DATA_OBJECT *) genalloc(theEnv,argumentSize * sizeof(DATA_OBJECT));
for (i = 2; i <= argumentCount; i++)
{
if (GetType(theArguments[i-2]) == MULTIFIELD)
{
tempMultifield = (struct multifield *) GetValue(theArguments[i-2]);
for (j = GetDOBegin(theArguments[i-2]); j <= GetDOEnd(theArguments[i-2]); j++, k++)
{
SetType(theArguments2[k],GetMFType(tempMultifield,j));
SetValue(theArguments2[k],GetMFValue(tempMultifield,j));
}
}
else
{
SetType(theArguments2[k],GetType(theArguments[i-2]));
SetValue(theArguments2[k],GetValue(theArguments[i-2]));
k++;
}
}
genfree(theEnv,theArguments,(argumentCount - 1) * sizeof(DATA_OBJECT));
functionReference->nextArg = SortFunctionData(theEnv)->SortComparisonFunction;
SortFunctionData(theEnv)->SortComparisonFunction = functionReference;
for (i = 0; i < argumentSize; i++)
{ ValueInstall(theEnv,&theArguments2[i]); }
MergeSort(theEnv,(unsigned long) argumentSize,theArguments2,DefaultCompareSwapFunction);
for (i = 0; i < argumentSize; i++)
{ ValueDeinstall(theEnv,&theArguments2[i]); }
SortFunctionData(theEnv)->SortComparisonFunction = SortFunctionData(theEnv)->SortComparisonFunction->nextArg;
functionReference->nextArg = NULL;
ReturnExpression(theEnv,functionReference);
theMultifield = (struct multifield *) EnvCreateMultifield(theEnv,(unsigned long) argumentSize);
for (i = 0; i < argumentSize; i++)
{
SetMFType(theMultifield,i+1,GetType(theArguments2[i]));
SetMFValue(theMultifield,i+1,GetValue(theArguments2[i]));
}
genfree(theEnv,theArguments2,argumentSize * sizeof(DATA_OBJECT));
SetpType(returnValue,MULTIFIELD);
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,argumentSize);
SetpValue(returnValue,(void *) theMultifield);
}
/*********************************************************
NAME : UpdateExpression
DESCRIPTION : Given a bloaded expression buffer,
this routine refreshes the pointers
in the expression array
INPUTS : 1) a bloaded expression buffer
2) the index of the expression to refresh
RETURNS : Nothing useful
SIDE EFFECTS : Expression updated
NOTES : None
*********************************************************/
static void UpdateExpression(
Environment *theEnv,
void *buf,
unsigned long obji)
{
BSAVE_EXPRESSION *bexp;
unsigned long theIndex;
bexp = (BSAVE_EXPRESSION *) buf;
ExpressionData(theEnv)->ExpressionArray[obji].type = bexp->type;
switch(bexp->type)
{
case FCALL:
ExpressionData(theEnv)->ExpressionArray[obji].value = BloadData(theEnv)->FunctionArray[bexp->value];
break;
case GCALL:
#if DEFGENERIC_CONSTRUCT
ExpressionData(theEnv)->ExpressionArray[obji].value = GenericPointer(bexp->value);
#else
ExpressionData(theEnv)->ExpressionArray[obji].value = NULL;
#endif
break;
case PCALL:
#if DEFFUNCTION_CONSTRUCT
ExpressionData(theEnv)->ExpressionArray[obji].value = DeffunctionPointer(bexp->value);
#else
ExpressionData(theEnv)->ExpressionArray[obji].value = NULL;
#endif
break;
case DEFTEMPLATE_PTR:
#if DEFTEMPLATE_CONSTRUCT
ExpressionData(theEnv)->ExpressionArray[obji].value = DeftemplatePointer(bexp->value);
#else
ExpressionData(theEnv)->ExpressionArray[obji].value = NULL;
#endif
break;
case DEFCLASS_PTR:
#if OBJECT_SYSTEM
ExpressionData(theEnv)->ExpressionArray[obji].value = DefclassPointer(bexp->value);
#else
ExpressionData(theEnv)->ExpressionArray[obji].value = NULL;
#endif
break;
case DEFGLOBAL_PTR:
#if DEFGLOBAL_CONSTRUCT
ExpressionData(theEnv)->ExpressionArray[obji].value = DefglobalPointer(bexp->value);
#else
ExpressionData(theEnv)->ExpressionArray[obji].value = NULL;
#endif
break;
case INTEGER_TYPE:
ExpressionData(theEnv)->ExpressionArray[obji].value = SymbolData(theEnv)->IntegerArray[bexp->value];
IncrementIntegerCount(ExpressionData(theEnv)->ExpressionArray[obji].integerValue);
break;
case FLOAT_TYPE:
ExpressionData(theEnv)->ExpressionArray[obji].value = SymbolData(theEnv)->FloatArray[bexp->value];
IncrementFloatCount(ExpressionData(theEnv)->ExpressionArray[obji].floatValue);
break;
case INSTANCE_NAME_TYPE:
#if ! OBJECT_SYSTEM
ExpressionData(theEnv)->ExpressionArray[obji].type = SYMBOL_TYPE;
#endif
case GBL_VARIABLE:
case SYMBOL_TYPE:
case STRING_TYPE:
ExpressionData(theEnv)->ExpressionArray[obji].value = SymbolData(theEnv)->SymbolArray[bexp->value];
IncrementLexemeCount(ExpressionData(theEnv)->ExpressionArray[obji].lexemeValue);
break;
#if DEFTEMPLATE_CONSTRUCT
case FACT_ADDRESS_TYPE:
ExpressionData(theEnv)->ExpressionArray[obji].value = &FactData(theEnv)->DummyFact;
RetainFact((Fact *) ExpressionData(theEnv)->ExpressionArray[obji].value);
break;
#endif
#if OBJECT_SYSTEM
case INSTANCE_ADDRESS_TYPE:
ExpressionData(theEnv)->ExpressionArray[obji].value = &InstanceData(theEnv)->DummyInstance;
RetainInstance((Instance *) ExpressionData(theEnv)->ExpressionArray[obji].value);
break;
#endif
case EXTERNAL_ADDRESS_TYPE:
ExpressionData(theEnv)->ExpressionArray[obji].value = NULL;
break;
case VOID_TYPE:
break;
default:
if (EvaluationData(theEnv)->PrimitivesArray[bexp->type] == NULL) break;
if (EvaluationData(theEnv)->PrimitivesArray[bexp->type]->bitMap)
{
ExpressionData(theEnv)->ExpressionArray[obji].value = SymbolData(theEnv)->BitMapArray[bexp->value];
IncrementBitMapCount((CLIPSBitMap *) ExpressionData(theEnv)->ExpressionArray[obji].value);
}
break;
}
theIndex = bexp->nextArg;
if (theIndex == ULONG_MAX)
{ ExpressionData(theEnv)->ExpressionArray[obji].nextArg = NULL; }
else
{ ExpressionData(theEnv)->ExpressionArray[obji].nextArg = (struct expr *) &ExpressionData(theEnv)->ExpressionArray[theIndex]; }
theIndex = bexp->argList;
if (theIndex == ULONG_MAX)
{ ExpressionData(theEnv)->ExpressionArray[obji].argList = NULL; }
else
{ ExpressionData(theEnv)->ExpressionArray[obji].argList = (struct expr *) &ExpressionData(theEnv)->ExpressionArray[theIndex]; }
}
/**********************************************************************
NAME : FormMethodsFromRestrictions
DESCRIPTION : Uses restriction string given in DefineFunction2()
for system function to create an equivalent method
INPUTS : 1) The generic function for the new methods
2) System function restriction string
(see DefineFunction2() last argument)
3) The actions to attach to a new method(s)
RETURNS : Nothing useful
SIDE EFFECTS : Implicit method(s) created
NOTES : None
**********************************************************************/
static void FormMethodsFromRestrictions(
void *theEnv,
DEFGENERIC *gfunc,
char *rstring,
EXPRESSION *actions)
{
DEFMETHOD *meth;
EXPRESSION *plist,*tmp,*bot,*svBot;
RESTRICTION *rptr;
char theChar[2],defaultc;
int min,max,mposn,needMinimumMethod;
register int i,j;
/* ===================================
The system function will accept any
number of any type of arguments
=================================== */
if (rstring == NULL)
{
tmp = get_struct(theEnv,expr);
rptr = get_struct(theEnv,restriction);
PackRestrictionTypes(theEnv,rptr,NULL);
rptr->query = NULL;
tmp->argList = (EXPRESSION *) rptr;
tmp->nextArg = NULL;
meth = AddMethod(theEnv,gfunc,NULL,0,0,tmp,1,0,(SYMBOL_HN *) SymbolData(theEnv)->TrueSymbol,
PackExpression(theEnv,actions),NULL,FALSE);
meth->system = 1;
DeleteTempRestricts(theEnv,tmp);
return;
}
/* ==============================
Extract the range of arguments
from the restriction string
============================== */
theChar[1] = '\0';
if (rstring[0] == '*')
min = 0;
else
{
theChar[0] = rstring[0];
min = atoi(theChar);
}
if (rstring[1] == '*')
max = -1;
else
{
theChar[0] = rstring[1];
max = atoi(theChar);
}
if (rstring[2] != '\0')
{
defaultc = rstring[2];
j = 3;
}
else
{
defaultc = 'u';
j= 2;
}
/* ================================================
Form a list of method restrictions corresponding
to the minimum number of arguments
================================================ */
plist = bot = NULL;
for (i = 0 ; i < min ; i++)
{
theChar[0] = (rstring[j] != '\0') ? rstring[j++] : defaultc;
rptr = ParseRestrictionType(theEnv,(int) theChar[0]);
tmp = get_struct(theEnv,expr);
tmp->argList = (EXPRESSION *) rptr;
tmp->nextArg = NULL;
if (plist == NULL)
plist = tmp;
else
bot->nextArg = tmp;
bot = tmp;
}
/* ===============================
Remember where restrictions end
for minimum number of arguments
=============================== */
svBot = bot;
needMinimumMethod = TRUE;
/* =======================================================
Attach one or more new methods to correspond
to the possible variations of the extra arguments
Add a separate method for each specified extra argument
======================================================= */
i = 0;
while (rstring[j] != '\0')
{
if ((rstring[j+1] == '\0') && ((min + i + 1) == max))
{
defaultc = rstring[j];
break;
}
rptr = ParseRestrictionType(theEnv,(int) rstring[j]);
tmp = get_struct(theEnv,expr);
tmp->argList = (EXPRESSION *) rptr;
tmp->nextArg = NULL;
if (plist == NULL)
plist = tmp;
else
bot->nextArg = tmp;
bot = tmp;
i++;
j++;
if ((rstring[j] != '\0') || ((min + i) == max))
{
FindMethodByRestrictions(gfunc,plist,min + i,NULL,&mposn);
meth = AddMethod(theEnv,gfunc,NULL,mposn,0,plist,min + i,0,NULL,
PackExpression(theEnv,actions),NULL,TRUE);
meth->system = 1;
}
}
/* ==============================================
Add a method to account for wildcard arguments
and attach a query in case there is a limit
============================================== */
if ((min + i) != max)
{
/* ================================================
If a wildcard is present immediately after the
minimum number of args - then the minimum case
will already be handled by this method. We don't
need to add an extra method for that case
================================================ */
if (i == 0)
needMinimumMethod = FALSE;
rptr = ParseRestrictionType(theEnv,(int) defaultc);
if (max != -1)
{
rptr->query = GenConstant(theEnv,FCALL,(void *) FindFunction(theEnv,"<="));
rptr->query->argList = GenConstant(theEnv,FCALL,(void *) FindFunction(theEnv,"length$"));
rptr->query->argList->argList = GenProcWildcardReference(theEnv,min + i + 1);
rptr->query->argList->nextArg =
GenConstant(theEnv,INTEGER,(void *) EnvAddLong(theEnv,(long) (max - min - i)));
}
tmp = get_struct(theEnv,expr);
tmp->argList = (EXPRESSION *) rptr;
tmp->nextArg = NULL;
if (plist == NULL)
plist = tmp;
else
bot->nextArg = tmp;
FindMethodByRestrictions(gfunc,plist,min + i + 1,(SYMBOL_HN *) SymbolData(theEnv)->TrueSymbol,&mposn);
meth = AddMethod(theEnv,gfunc,NULL,mposn,0,plist,min + i + 1,0,(SYMBOL_HN *) SymbolData(theEnv)->TrueSymbol,
PackExpression(theEnv,actions),NULL,FALSE);
meth->system = 1;
}
/* ===================================================
When extra methods had to be added because of
different restrictions on the optional arguments OR
the system function accepts a fixed number of args,
we must add a specific method for the minimum case.
Otherwise, the method with the wildcard covers it.
=================================================== */
if (needMinimumMethod)
{
if (svBot != NULL)
{
bot = svBot->nextArg;
svBot->nextArg = NULL;
DeleteTempRestricts(theEnv,bot);
}
FindMethodByRestrictions(gfunc,plist,min,NULL,&mposn);
meth = AddMethod(theEnv,gfunc,NULL,mposn,0,plist,min,0,NULL,
PackExpression(theEnv,actions),NULL,TRUE);
meth->system = 1;
}
DeleteTempRestricts(theEnv,plist);
}
globle void QSetDefglobalValue(
void *theEnv,
struct defglobal *theGlobal,
DATA_OBJECT_PTR vPtr,
int resetVar)
{
/*====================================================*/
/* If the new value passed for the defglobal is NULL, */
/* then reset the defglobal to the initial value it */
/* had when it was defined. */
/*====================================================*/
if (resetVar)
{
EvaluateExpression(theEnv,theGlobal->initial,vPtr);
if (EvaluationData(theEnv)->EvaluationError)
{
vPtr->type = SYMBOL;
vPtr->value = SymbolData(theEnv)->FalseSymbol;
}
}
/*==========================================*/
/* If globals are being watch, then display */
/* the change to the global variable. */
/*==========================================*/
#if DEBUGGING_FUNCTIONS
if (theGlobal->watch)
{
EnvPrintRouter(theEnv,WTRACE,":== ?*");
EnvPrintRouter(theEnv,WTRACE,ValueToString(theGlobal->header.name));
EnvPrintRouter(theEnv,WTRACE,"* ==> ");
PrintDataObject(theEnv,WTRACE,vPtr);
EnvPrintRouter(theEnv,WTRACE," <== ");
PrintDataObject(theEnv,WTRACE,&theGlobal->current);
EnvPrintRouter(theEnv,WTRACE,"\n");
}
#endif
/*==============================================*/
/* Remove the old value of the global variable. */
/*==============================================*/
ValueDeinstall(theEnv,&theGlobal->current);
if (theGlobal->current.type == MULTIFIELD)
{ ReturnMultifield(theEnv,(struct multifield *) theGlobal->current.value); }
/*===========================================*/
/* Set the new value of the global variable. */
/*===========================================*/
theGlobal->current.type = vPtr->type;
if (vPtr->type != MULTIFIELD) theGlobal->current.value = vPtr->value;
else DuplicateMultifield(theEnv,&theGlobal->current,vPtr);
ValueInstall(theEnv,&theGlobal->current);
/*===========================================*/
/* Set the variable indicating that a change */
/* has been made to a global variable. */
/*===========================================*/
DefglobalData(theEnv)->ChangeToGlobals = TRUE;
if ((EvaluationData(theEnv)->CurrentEvaluationDepth == 0) && (! CommandLineData(theEnv)->EvaluatingTopLevelCommand) &&
(EvaluationData(theEnv)->CurrentExpression == NULL))
{ PeriodicCleanup(theEnv,TRUE,FALSE); }
}
globle void AssertCommand(
void *theEnv,
DATA_OBJECT_PTR rv)
{
struct deftemplate *theDeftemplate;
struct field *theField;
DATA_OBJECT theValue;
struct expr *theExpression;
struct templateSlot *slotPtr;
struct fact *newFact;
int error = FALSE;
int i;
struct fact *theFact;
/*===================================================*/
/* Set the default return value to the symbol FALSE. */
/*===================================================*/
SetpType(rv,SYMBOL);
SetpValue(rv,SymbolData(theEnv)->FalseSymbol);
/*================================*/
/* Get the deftemplate associated */
/* with the fact being asserted. */
/*================================*/
theExpression = GetFirstArgument();
theDeftemplate = (struct deftemplate *) theExpression->value;
/*=======================================*/
/* Create the fact and store the name of */
/* the deftemplate as the 1st field. */
/*=======================================*/
if (theDeftemplate->implied == FALSE)
{
newFact = CreateFactBySize(theEnv,theDeftemplate->numberOfSlots);
slotPtr = theDeftemplate->slotList;
}
else
{
newFact = CreateFactBySize(theEnv,1);
if (theExpression->nextArg == NULL)
{
newFact->theProposition.theFields[0].type = MULTIFIELD;
newFact->theProposition.theFields[0].value = CreateMultifield2(theEnv,0L);
}
slotPtr = NULL;
}
newFact->whichDeftemplate = theDeftemplate;
/*===================================================*/
/* Evaluate the expression associated with each slot */
/* and store the result in the appropriate slot of */
/* the newly created fact. */
/*===================================================*/
theField = newFact->theProposition.theFields;
for (theExpression = theExpression->nextArg, i = 0;
theExpression != NULL;
theExpression = theExpression->nextArg, i++)
{
/*===================================================*/
/* Evaluate the expression to be stored in the slot. */
/*===================================================*/
EvaluateExpression(theEnv,theExpression,&theValue);
/*============================================================*/
/* A multifield value can't be stored in a single field slot. */
/*============================================================*/
if ((slotPtr != NULL) ?
(slotPtr->multislot == FALSE) && (theValue.type == MULTIFIELD) :
FALSE)
{
MultiIntoSingleFieldSlotError(theEnv,slotPtr,theDeftemplate);
theValue.type = SYMBOL;
theValue.value = SymbolData(theEnv)->FalseSymbol;
error = TRUE;
}
/*==============================*/
/* Store the value in the slot. */
/*==============================*/
theField[i].type = theValue.type;
theField[i].value = theValue.value;
/*========================================*/
/* Get the information for the next slot. */
/*========================================*/
if (slotPtr != NULL) slotPtr = slotPtr->next;
}
/*============================================*/
/* If an error occured while generating the */
/* fact's slot values, then abort the assert. */
/*============================================*/
if (error)
{
ReturnFact(theEnv,newFact);
return;
}
/*================================*/
/* Add the fact to the fact-list. */
/*================================*/
theFact = (struct fact *) EnvAssert(theEnv,(void *) newFact);
/*========================================*/
/* The asserted fact is the return value. */
/*========================================*/
if (theFact != NULL)
{
SetpType(rv,FACT_ADDRESS);
SetpValue(rv,(void *) theFact);
}
return;
}
static void DuplicateModifyCommand(
void *theEnv,
int retractIt,
DATA_OBJECT_PTR returnValue)
{
long int factNum;
struct fact *oldFact, *newFact, *theFact;
struct expr *testPtr;
DATA_OBJECT computeResult;
struct deftemplate *templatePtr;
struct templateSlot *slotPtr;
int i, position, found;
/*===================================================*/
/* Set the default return value to the symbol FALSE. */
/*===================================================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,SymbolData(theEnv)->FalseSymbol);
/*==================================================*/
/* Evaluate the first argument which is used to get */
/* a pointer to the fact to be modified/duplicated. */
/*==================================================*/
testPtr = GetFirstArgument();
EvaluateExpression(theEnv,testPtr,&computeResult);
/*==============================================================*/
/* If an integer is supplied, then treat it as a fact-index and */
/* search the fact-list for the fact with that fact-index. */
/*==============================================================*/
if (computeResult.type == INTEGER)
{
factNum = ValueToLong(computeResult.value);
if (factNum < 0)
{
if (retractIt) ExpectedTypeError2(theEnv,"modify",1);
else ExpectedTypeError2(theEnv,"duplicate",1);
SetEvaluationError(theEnv,TRUE);
return;
}
oldFact = (struct fact *) EnvGetNextFact(theEnv,NULL);
while (oldFact != NULL)
{
if (oldFact->factIndex == factNum)
{ break; }
else
{ oldFact = oldFact->nextFact; }
}
if (oldFact == NULL)
{
char tempBuffer[20];
sprintf(tempBuffer,"f-%ld",factNum);
CantFindItemErrorMessage(theEnv,"fact",tempBuffer);
return;
}
}
/*==========================================*/
/* Otherwise, if a pointer is supplied then */
/* no lookup is required. */
/*==========================================*/
else if (computeResult.type == FACT_ADDRESS)
{ oldFact = (struct fact *) computeResult.value; }
/*===========================================*/
/* Otherwise, the first argument is invalid. */
/*===========================================*/
else
{
if (retractIt) ExpectedTypeError2(theEnv,"modify",1);
else ExpectedTypeError2(theEnv,"duplicate",1);
SetEvaluationError(theEnv,TRUE);
return;
}
/*==================================*/
/* See if it is a deftemplate fact. */
/*==================================*/
templatePtr = oldFact->whichDeftemplate;
if (templatePtr->implied) return;
/*================================================================*/
/* Duplicate the values from the old fact (skipping multifields). */
/*================================================================*/
newFact = (struct fact *) CreateFactBySize(theEnv,oldFact->theProposition.multifieldLength);
newFact->whichDeftemplate = templatePtr;
for (i = 0; i < (int) oldFact->theProposition.multifieldLength; i++)
{
newFact->theProposition.theFields[i].type = oldFact->theProposition.theFields[i].type;
if (newFact->theProposition.theFields[i].type != MULTIFIELD)
{ newFact->theProposition.theFields[i].value = oldFact->theProposition.theFields[i].value; }
else
{ newFact->theProposition.theFields[i].value = NULL; }
}
/*========================*/
/* Start replacing slots. */
/*========================*/
testPtr = testPtr->nextArg;
while (testPtr != NULL)
{
/*============================================================*/
/* If the slot identifier is an integer, then the slot was */
/* previously identified and its position within the template */
/* was stored. Otherwise, the position of the slot within the */
/* deftemplate has to be determined by comparing the name of */
/* the slot against the list of slots for the deftemplate. */
/*============================================================*/
if (testPtr->type == INTEGER)
{ position = (int) ValueToLong(testPtr->value); }
else
{
found = FALSE;
position = 0;
slotPtr = templatePtr->slotList;
while (slotPtr != NULL)
{
if (slotPtr->slotName == (SYMBOL_HN *) testPtr->value)
{
found = TRUE;
slotPtr = NULL;
}
else
{
slotPtr = slotPtr->next;
position++;
}
}
if (! found)
{
InvalidDeftemplateSlotMessage(theEnv,ValueToString(testPtr->value),
ValueToString(templatePtr->header.name));
SetEvaluationError(theEnv,TRUE);
ReturnFact(theEnv,newFact);
return;
}
}
/*===================================================*/
/* If a single field slot is being replaced, then... */
/*===================================================*/
if (newFact->theProposition.theFields[position].type != MULTIFIELD)
{
/*======================================================*/
/* If the list of values to store in the slot is empty */
/* or contains more than one member than an error has */
/* occured because a single field slot can only contain */
/* a single value. */
/*======================================================*/
if ((testPtr->argList == NULL) ? TRUE : (testPtr->argList->nextArg != NULL))
{
MultiIntoSingleFieldSlotError(theEnv,GetNthSlot(templatePtr,position),templatePtr);
ReturnFact(theEnv,newFact);
return;
}
/*===================================================*/
/* Evaluate the expression to be stored in the slot. */
/*===================================================*/
EvaluateExpression(theEnv,testPtr->argList,&computeResult);
SetEvaluationError(theEnv,FALSE);
/*====================================================*/
/* If the expression evaluated to a multifield value, */
/* then an error occured since a multifield value can */
/* not be stored in a single field slot. */
/*====================================================*/
if (computeResult.type == MULTIFIELD)
{
ReturnFact(theEnv,newFact);
MultiIntoSingleFieldSlotError(theEnv,GetNthSlot(templatePtr,position),templatePtr);
return;
}
/*=============================*/
/* Store the value in the slot */
/*=============================*/
newFact->theProposition.theFields[position].type =
computeResult.type;
newFact->theProposition.theFields[position].value =
computeResult.value;
}
/*=================================*/
/* Else replace a multifield slot. */
/*=================================*/
else
{
/*======================================*/
/* Determine the new value of the slot. */
/*======================================*/
StoreInMultifield(theEnv,&computeResult,testPtr->argList,FALSE);
SetEvaluationError(theEnv,FALSE);
/*=============================*/
/* Store the value in the slot */
/*=============================*/
newFact->theProposition.theFields[position].type =
computeResult.type;
newFact->theProposition.theFields[position].value =
computeResult.value;
}
testPtr = testPtr->nextArg;
}
/*=====================================*/
/* Copy the multifield values from the */
/* old fact that were not replaced. */
/*=====================================*/
for (i = 0; i < (int) oldFact->theProposition.multifieldLength; i++)
{
if ((newFact->theProposition.theFields[i].type == MULTIFIELD) &&
(newFact->theProposition.theFields[i].value == NULL))
{
newFact->theProposition.theFields[i].value =
CopyMultifield(theEnv,(struct multifield *) oldFact->theProposition.theFields[i].value);
}
}
/*======================================*/
/* Perform the duplicate/modify action. */
/*======================================*/
if (retractIt) EnvRetract(theEnv,oldFact);
theFact = (struct fact *) EnvAssert(theEnv,newFact);
/*========================================*/
/* The asserted fact is the return value. */
/*========================================*/
if (theFact != NULL)
{
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,theFact->theProposition.multifieldLength);
SetpType(returnValue,FACT_ADDRESS);
SetpValue(returnValue,(void *) theFact);
}
return;
}
static BOOLEAN MultifieldCardinalityViolation(
void *theEnv,
struct lhsParseNode *theNode)
{
struct lhsParseNode *tmpNode;
struct expr *tmpMax;
long minFields = 0;
long maxFields = 0;
int posInfinity = FALSE;
CONSTRAINT_RECORD *newConstraint, *tempConstraint;
/*================================*/
/* A single field slot can't have */
/* a cardinality violation. */
/*================================*/
if (theNode->multifieldSlot == FALSE) return(FALSE);
/*=============================================*/
/* Determine the minimum and maximum number of */
/* fields the slot could contain based on the */
/* slot constraints found in the pattern. */
/*=============================================*/
for (tmpNode = theNode->bottom;
tmpNode != NULL;
tmpNode = tmpNode->right)
{
/*====================================================*/
/* A single field variable increases both the minimum */
/* and maximum number of fields by one. */
/*====================================================*/
if ((tmpNode->type == SF_VARIABLE) ||
(tmpNode->type == SF_WILDCARD))
{
minFields++;
maxFields++;
}
/*=================================================*/
/* Otherwise a multifield wildcard or variable has */
/* been encountered. If it is constrained then use */
/* minimum and maximum number of fields constraint */
/* associated with this LHS node. */
/*=================================================*/
else if (tmpNode->constraints != NULL)
{
/*=======================================*/
/* The lowest minimum of all the min/max */
/* pairs will be the first in the list. */
/*=======================================*/
if (tmpNode->constraints->minFields->value != SymbolData(theEnv)->NegativeInfinity)
{ minFields += ValueToLong(tmpNode->constraints->minFields->value); }
/*=========================================*/
/* The greatest maximum of all the min/max */
/* pairs will be the last in the list. */
/*=========================================*/
tmpMax = tmpNode->constraints->maxFields;
while (tmpMax->nextArg != NULL) tmpMax = tmpMax->nextArg;
if (tmpMax->value == SymbolData(theEnv)->PositiveInfinity)
{ posInfinity = TRUE; }
else
{ maxFields += ValueToLong(tmpMax->value); }
}
/*================================================*/
/* Otherwise an unconstrained multifield wildcard */
/* or variable increases the maximum number of */
/* fields to positive infinity. */
/*================================================*/
else
{ posInfinity = TRUE; }
}
/*==================================================================*/
/* Create a constraint record for the cardinality of the sum of the */
/* cardinalities of the restrictions inside the multifield slot. */
/*==================================================================*/
if (theNode->constraints == NULL) tempConstraint = GetConstraintRecord(theEnv);
else tempConstraint = CopyConstraintRecord(theEnv,theNode->constraints);
ReturnExpression(theEnv,tempConstraint->minFields);
ReturnExpression(theEnv,tempConstraint->maxFields);
tempConstraint->minFields = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,(long) minFields));
if (posInfinity) tempConstraint->maxFields = GenConstant(theEnv,SYMBOL,SymbolData(theEnv)->PositiveInfinity);
else tempConstraint->maxFields = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,(long) maxFields));
/*================================================================*/
/* Determine the final cardinality for the multifield slot by */
/* intersecting the cardinality sum of the restrictions within */
/* the multifield slot with the original cardinality of the slot. */
/*================================================================*/
newConstraint = IntersectConstraints(theEnv,theNode->constraints,tempConstraint);
if (theNode->derivedConstraints) RemoveConstraint(theEnv,theNode->constraints);
RemoveConstraint(theEnv,tempConstraint);
theNode->constraints = newConstraint;
theNode->derivedConstraints = TRUE;
/*===================================================================*/
/* Determine if the final cardinality for the slot can be satisfied. */
/*===================================================================*/
if (EnvGetStaticConstraintChecking(theEnv) == FALSE) return(FALSE);
if (UnmatchableConstraint(newConstraint)) return(TRUE);
return(FALSE);
}
globle int CompareNumbers(
void *theEnv,
EXEC_STATUS,
int type1,
void *vptr1,
int type2,
void *vptr2)
{
/*============================================*/
/* Handle the situation in which the values */
/* are exactly equal (same type, same value). */
/*============================================*/
if (vptr1 == vptr2) return(EQUAL);
/*=======================================*/
/* Handle the special cases for positive */
/* and negative infinity. */
/*=======================================*/
if (vptr1 == SymbolData(theEnv,execStatus)->PositiveInfinity) return(GREATER_THAN);
if (vptr1 == SymbolData(theEnv,execStatus)->NegativeInfinity) return(LESS_THAN);
if (vptr2 == SymbolData(theEnv,execStatus)->PositiveInfinity) return(LESS_THAN);
if (vptr2 == SymbolData(theEnv,execStatus)->NegativeInfinity) return(GREATER_THAN);
/*=======================*/
/* Compare two integers. */
/*=======================*/
if ((type1 == INTEGER) && (type2 == INTEGER))
{
if (ValueToLong(vptr1) < ValueToLong(vptr2))
{ return(LESS_THAN); }
else if (ValueToLong(vptr1) > ValueToLong(vptr2))
{ return(GREATER_THAN); }
return(EQUAL);
}
/*=====================*/
/* Compare two floats. */
/*=====================*/
if ((type1 == FLOAT) && (type2 == FLOAT))
{
if (ValueToDouble(vptr1) < ValueToDouble(vptr2))
{ return(LESS_THAN); }
else if (ValueToDouble(vptr1) > ValueToDouble(vptr2))
{ return(GREATER_THAN); }
return(EQUAL);
}
/*================================*/
/* Compare an integer to a float. */
/*================================*/
if ((type1 == INTEGER) && (type2 == FLOAT))
{
if (((double) ValueToLong(vptr1)) < ValueToDouble(vptr2))
{ return(LESS_THAN); }
else if (((double) ValueToLong(vptr1)) > ValueToDouble(vptr2))
{ return(GREATER_THAN); }
return(EQUAL);
}
/*================================*/
/* Compare a float to an integer. */
/*================================*/
if ((type1 == FLOAT) && (type2 == INTEGER))
{
if (ValueToDouble(vptr1) < ((double) ValueToLong(vptr2)))
{ return(LESS_THAN); }
else if (ValueToDouble(vptr1) > ((double) ValueToLong(vptr2)))
{ return(GREATER_THAN); }
return(EQUAL);
}
/*===================================*/
/* One of the arguments was invalid. */
/* Return -1 to indicate an error. */
/*===================================*/
return(-1);
}
globle void FreeAtomicValueStorage(
void *theEnv)
{
if (SymbolData(theEnv)->SymbolArray != NULL)
rm3(theEnv,(void *) SymbolData(theEnv)->SymbolArray,(long) sizeof(SYMBOL_HN *) * SymbolData(theEnv)->NumberOfSymbols);
if (SymbolData(theEnv)->FloatArray != NULL)
rm3(theEnv,(void *) SymbolData(theEnv)->FloatArray,(long) sizeof(FLOAT_HN *) * SymbolData(theEnv)->NumberOfFloats);
if (SymbolData(theEnv)->IntegerArray != NULL)
rm3(theEnv,(void *) SymbolData(theEnv)->IntegerArray,(long) sizeof(INTEGER_HN *) * SymbolData(theEnv)->NumberOfIntegers);
if (SymbolData(theEnv)->BitMapArray != NULL)
rm3(theEnv,(void *) SymbolData(theEnv)->BitMapArray,(long) sizeof(BITMAP_HN *) * SymbolData(theEnv)->NumberOfBitMaps);
SymbolData(theEnv)->SymbolArray = NULL;
SymbolData(theEnv)->FloatArray = NULL;
SymbolData(theEnv)->IntegerArray = NULL;
SymbolData(theEnv)->BitMapArray = NULL;
SymbolData(theEnv)->NumberOfSymbols = 0;
SymbolData(theEnv)->NumberOfFloats = 0;
SymbolData(theEnv)->NumberOfIntegers = 0;
SymbolData(theEnv)->NumberOfBitMaps = 0;
}
globle void DeriveDefaultFromConstraints(
void *theEnv,
CONSTRAINT_RECORD *constraints,
DATA_OBJECT *theDefault,
int multifield,
int garbageMultifield)
{
unsigned short theType;
unsigned long minFields;
void *theValue;
/*=============================================================*/
/* If no constraints are specified, then use the symbol nil as */
/* a default for single field slots and a multifield of length */
/* 0 as a default for multifield slots. */
/*=============================================================*/
if (constraints == NULL)
{
if (multifield)
{
SetpType(theDefault,MULTIFIELD);
SetpDOBegin(theDefault,1);
SetpDOEnd(theDefault,0);
if (garbageMultifield) SetpValue(theDefault,(void *) EnvCreateMultifield(theEnv,0L));
else SetpValue(theDefault,(void *) CreateMultifield2(theEnv,0L));
}
else
{
theDefault->type = SYMBOL;
theDefault->value = EnvAddSymbol(theEnv,(char*)"nil");
}
return;
}
/*=========================================*/
/* Determine the default's type and value. */
/*=========================================*/
if (constraints->anyAllowed || constraints->symbolsAllowed)
{
theType = SYMBOL;
theValue = FindDefaultValue(theEnv,SYMBOL,constraints,EnvAddSymbol(theEnv,(char*)"nil"));
}
else if (constraints->stringsAllowed)
{
theType = STRING;
theValue = FindDefaultValue(theEnv,STRING,constraints,EnvAddSymbol(theEnv,(char*)""));
}
else if (constraints->integersAllowed)
{
theType = INTEGER;
theValue = FindDefaultValue(theEnv,INTEGER,constraints,EnvAddLong(theEnv,0LL));
}
else if (constraints->floatsAllowed)
{
theType = FLOAT;
theValue = FindDefaultValue(theEnv,FLOAT,constraints,EnvAddDouble(theEnv,0.0));
}
#if OBJECT_SYSTEM
else if (constraints->instanceNamesAllowed)
{
theType = INSTANCE_NAME;
theValue = FindDefaultValue(theEnv,INSTANCE_NAME,constraints,EnvAddSymbol(theEnv,(char*)"nil"));
}
else if (constraints->instanceAddressesAllowed)
{
theType = INSTANCE_ADDRESS;
theValue = (void *) &InstanceData(theEnv)->DummyInstance;
}
#endif
#if DEFTEMPLATE_CONSTRUCT
else if (constraints->factAddressesAllowed)
{
theType = FACT_ADDRESS;
theValue = (void *) &FactData(theEnv)->DummyFact;
}
#endif
else if (constraints->externalAddressesAllowed)
{
theType = EXTERNAL_ADDRESS;
theValue = EnvAddExternalAddress(theEnv,NULL,0);
}
else
{
theType = SYMBOL;
theValue = EnvAddSymbol(theEnv,(char*)"nil");
}
/*=========================================================*/
/* If the default is for a multifield slot, then create a */
/* multifield default value that satisfies the cardinality */
/* constraints for the slot. The default value for a */
/* multifield slot is a multifield of length 0. */
/*=========================================================*/
if (multifield)
{
if (constraints->minFields == NULL) minFields = 0;
else if (constraints->minFields->value == SymbolData(theEnv)->NegativeInfinity) minFields = 0;
else minFields = (unsigned long) ValueToLong(constraints->minFields->value);
SetpType(theDefault,MULTIFIELD);
SetpDOBegin(theDefault,1);
SetpDOEnd(theDefault,(long) minFields);
if (garbageMultifield) SetpValue(theDefault,(void *) EnvCreateMultifield(theEnv,minFields));
else SetpValue(theDefault,(void *) CreateMultifield2(theEnv,minFields));
for (; minFields > 0; minFields--)
{
SetMFType(GetpValue(theDefault),minFields,theType);
SetMFValue(GetpValue(theDefault),minFields,theValue);
}
}
else
{
theDefault->type = theType;
theDefault->value = theValue;
}
}
