/**********************************************
Build functions used by AddPatternParser() to
provide object access to the pattern network
**********************************************/
globle EXPRESSION *GenObjectPNConstantCompare(
void *theEnv,
struct lhsParseNode *theNode)
{
struct ObjectCmpPNConstant hack;
EXPRESSION *theExp;
unsigned short tmpType;
/* ===============================================================
If the value of a single field slot (or relation name) is being
compared against a constant, then use specialized routines for
doing the comparison.
If a constant comparison is being done within a multifield slot
and the constant's position has no multifields to the left or
no multifields to the right, then use the same routine used for
the single field slot case, but include the offset from either
the beginning or end of the slot.
Otherwise, use a general eq/neq test.
=============================================================== */
ClearBitString((void *) &hack,(int) sizeof(struct ObjectCmpPNConstant));
if (theNode->negated)
hack.fail = 1;
else
hack.pass = 1;
if (((theNode->withinMultifieldSlot == FALSE) ||
(theNode->multiFieldsAfter == 0) ||
(theNode->multiFieldsBefore == 0)) &&
(theNode->slotNumber != ISA_ID) && (theNode->slotNumber != NAME_ID))
{
if (theNode->withinMultifieldSlot == FALSE)
hack.fromBeginning = TRUE;
else if (theNode->multiFieldsBefore == 0)
{
hack.fromBeginning = TRUE;
hack.offset = theNode->singleFieldsBefore;
}
else
hack.offset = theNode->singleFieldsAfter;
theExp = GenConstant(theEnv,OBJ_PN_CONSTANT,AddBitMap(theEnv,(void *) &hack,
(int) sizeof(struct ObjectCmpPNConstant)));
theExp->argList = GenConstant(theEnv,theNode->type,theNode->value);
}
else
{
hack.general = 1;
theExp = GenConstant(theEnv,OBJ_PN_CONSTANT,AddBitMap(theEnv,(void *) &hack,
(int) sizeof(struct ObjectCmpPNConstant)));
theExp->argList = GenConstant(theEnv,0,NULL);
tmpType = theNode->type;
theNode->type = SF_VARIABLE;
GenObjectGetVar(theEnv,FALSE,theExp->argList,theNode);
theNode->type = tmpType;
theExp->argList->nextArg = GenConstant(theEnv,theNode->type,theNode->value);
}
return(theExp);
}
static void IntersectAllowedValueExpressions(
CONSTRAINT_RECORD *constraint1,
CONSTRAINT_RECORD *constraint2,
CONSTRAINT_RECORD *newConstraint)
{
struct expr *theList1, *theList2;
struct expr *theHead = NULL, *tmpExpr;
/*===========================================*/
/* Loop through each value in allowed-values */
/* list of the first constraint record. Add */
/* each value to a list if it satisfies the */
/* restrictions for both constraint records. */
/*===========================================*/
for (theList1 = constraint1->restrictionList;
theList1 != NULL;
theList1 = theList1->nextArg)
{
if (CheckAllowedValuesConstraint(theList1->type,theList1->value,constraint1) &&
CheckAllowedValuesConstraint(theList1->type,theList1->value,constraint2))
{
tmpExpr = GenConstant(theList1->type,theList1->value);
tmpExpr->nextArg = theHead;
theHead = tmpExpr;
}
}
/*===========================================*/
/* Loop through each value in allowed-values */
/* list of the second constraint record. Add */
/* each value to a list if it satisfies the */
/* restrictions for both constraint records. */
/*===========================================*/
for (theList2 = constraint2->restrictionList;
theList2 != NULL;
theList2 = theList2->nextArg)
{
if (FindItemInExpression(theList2->type,theList2->value,TRUE,theHead))
{ /* The value is already in the list--Do nothing */ }
else if (CheckAllowedValuesConstraint(theList2->type,theList2->value,constraint1) &&
CheckAllowedValuesConstraint(theList2->type,theList2->value,constraint2))
{
tmpExpr = GenConstant(theList2->type,theList2->value);
tmpExpr->nextArg = theHead;
theHead = tmpExpr;
}
}
/*================================================*/
/* Set the allowed values list for the constraint */
/* record to the intersected values of the two */
/* other constraint records. */
/*================================================*/
newConstraint->restrictionList = theHead;
}
globle struct expr *FactPNVariableComparison(
struct lhsParseNode *selfNode,
struct lhsParseNode *referringNode)
{
struct expr *top;
struct factCompVarsPN1Call hack;
/*===================================================*/
/* Clear the bitmap for storing the argument values. */
/*===================================================*/
ClearBitString(&hack,sizeof(struct factCompVarsPN1Call));
/*================================================================*/
/* If two single field slots of a deftemplate are being compared, */
/* then use the following specified variable comparison routine. */
/*================================================================*/
if ((selfNode->withinMultifieldSlot == FALSE) &&
(selfNode->slotNumber > 0) &&
(referringNode->withinMultifieldSlot == FALSE) &&
(referringNode->slotNumber > 0))
{
hack.pass = 0;
hack.fail = 0;
hack.field1 = (unsigned int) selfNode->slotNumber - 1;
hack.field2 = (unsigned int) referringNode->slotNumber - 1;
if (selfNode->negated) hack.fail = 1;
else hack.pass = 1;
top = GenConstant(FACT_PN_CMP1,AddBitMap(&hack,sizeof(struct factCompVarsPN1Call)));
}
/*================================================================*/
/* Otherwise, use the eq function to compare the values retrieved */
/* by the appropriate get variable value functions. */
/*================================================================*/
else
{
if (selfNode->negated) top = GenConstant(FCALL,PTR_NEQ);
else top = GenConstant(FCALL,PTR_EQ);
top->argList = FactGenGetfield(selfNode);
top->argList->nextArg = FactGenGetfield(referringNode);
}
/*======================================*/
/* Return the expression for performing */
/* the variable comparison. */
/*======================================*/
return(top);
}
/*************************************************************************
NAME : ReplaceSlotReference
DESCRIPTION : Replaces instance-set query function variable
references of the form: <instance-variable>:<slot-name>
with function calls to get these instance-slots at run
time
INPUTS : 1) The instance-set variable list
2) The expression containing the variable
3) The address of the instance slot access function
4) Nesting depth of query functions
RETURNS : Nothing useful
SIDE EFFECTS : If the variable is a slot reference, then it is replaced
with the appropriate function-call.
NOTES : None
*************************************************************************/
static void ReplaceSlotReference(
void *theEnv,
EXEC_STATUS,
EXPRESSION *vlist,
EXPRESSION *theExp,
struct FunctionDefinition *func,
int ndepth)
{
size_t len;
int posn,oldpp;
size_t i;
register char *str;
EXPRESSION *eptr;
struct token itkn;
str = ValueToString(theExp->value);
len = strlen(str);
if (len < 3)
return;
for (i = len-2 ; i >= 1 ; i--)
{
if ((str[i] == INSTANCE_SLOT_REF) ? (i >= 1) : FALSE)
{
eptr = vlist;
posn = 0;
while (eptr && ((i != strlen(ValueToString(eptr->value))) ||
strncmp(ValueToString(eptr->value),str,
(STD_SIZE) i)))
{
eptr = eptr->nextArg;
posn++;
}
if (eptr != NULL)
{
OpenStringSource(theEnv,execStatus,"query-var",str+i+1,0);
oldpp = GetPPBufferStatus(theEnv,execStatus);
SetPPBufferStatus(theEnv,execStatus,OFF);
GetToken(theEnv,execStatus,"query-var",&itkn);
SetPPBufferStatus(theEnv,execStatus,oldpp);
CloseStringSource(theEnv,execStatus,"query-var");
theExp->type = FCALL;
theExp->value = (void *) func;
theExp->argList = GenConstant(theEnv,execStatus,INTEGER,(void *) EnvAddLong(theEnv,execStatus,(long long) ndepth));
theExp->argList->nextArg =
GenConstant(theEnv,execStatus,INTEGER,(void *) EnvAddLong(theEnv,execStatus,(long long) posn));
theExp->argList->nextArg->nextArg = GenConstant(theEnv,execStatus,itkn.type,itkn.value);
break;
}
}
}
}
static void ReplaceLoopCountVars(
SYMBOL_HN *loopVar,
EXPRESSION *exp,
int depth)
{
while (exp != NULL)
{
if ((exp->type != SF_VARIABLE) ? FALSE :
(strcmp(ValueToString(exp->value),ValueToString(loopVar)) == 0))
{
exp->type = FCALL;
exp->value = (void *) FindFunction("(get-loop-count)");
exp->argList = GenConstant(INTEGER,AddLong((long) depth));
}
else if (exp->argList != NULL)
{
if ((exp->type != FCALL) ? FALSE :
(exp->value == (void *) FindFunction("loop-for-count")))
ReplaceLoopCountVars(loopVar,exp->argList,depth+1);
else
ReplaceLoopCountVars(loopVar,exp->argList,depth);
}
exp = exp->nextArg;
}
}
static struct expr *GenPNColon(
void *theEnv,
struct lhsParseNode *theField)
{
struct expr *top, *conversion;
/*==================================================*/
/* Replace variables with function calls to extract */
/* the appropriate value from the data entity. */
/*==================================================*/
conversion = GetfieldReplace(theEnv,theField->expression);
/*================================================*/
/* If the predicate constraint is negated by a ~, */
/* then wrap a "not" function call around the */
/* expression before returning it. Otherwise, */
/* just return the expression. */
/*================================================*/
if (theField->negated)
{
top = GenConstant(theEnv,FCALL,ExpressionData(theEnv)->PTR_NOT);
top->argList = conversion;
}
else
{ top = conversion; }
return(top);
}
static void ReplaceLoopCountVars(
void *theEnv,
SYMBOL_HN *loopVar,
EXPRESSION *theExp,
int depth)
{
while (theExp != NULL)
{
if ((theExp->type != SF_VARIABLE) ? FALSE :
(strcmp(ValueToString(theExp->value),ValueToString(loopVar)) == 0))
{
theExp->type = FCALL;
theExp->value = (void *) FindFunction(theEnv,"(get-loop-count)");
theExp->argList = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,(long) depth));
}
else if (theExp->argList != NULL)
{
if ((theExp->type != FCALL) ? FALSE :
(theExp->value == (void *) FindFunction(theEnv,"loop-for-count")))
ReplaceLoopCountVars(theEnv,loopVar,theExp->argList,depth+1);
else
ReplaceLoopCountVars(theEnv,loopVar,theExp->argList,depth);
}
theExp = theExp->nextArg;
}
}
/***************************************************
NAME : Send
DESCRIPTION : C Interface for sending messages to
instances
INPUTS : 1) The data object of the instance
2) The message name-string
3) The message arguments string
(Constants only)
4) Caller's buffer for result
RETURNS : Nothing useful
SIDE EFFECTS : Executes message and stores result
caller's buffer
NOTES : None
***************************************************/
globle void Send(
DATA_OBJECT *idata,
char *msg,
char *args,
DATA_OBJECT *result)
{
int error;
EXPRESSION *iexp;
SYMBOL_HN *msym;
SetEvaluationError(FALSE);
result->type = SYMBOL;
result->value = FalseSymbol;
msym = FindSymbol(msg);
if (msym == NULL)
{
PrintNoHandlerError(msg);
SetEvaluationError(TRUE);
return;
}
iexp = GenConstant(idata->type,idata->value);
iexp->nextArg = ParseConstantArguments(args,&error);
if (error == TRUE)
{
ReturnExpression(iexp);
SetEvaluationError(TRUE);
return;
}
PerformMessage(result,iexp,msym);
ReturnExpression(iexp);
if ((CurrentEvaluationDepth == 0) && (! EvaluatingTopLevelCommand) &&
(CurrentExpression == NULL))
{ PeriodicCleanup(TRUE,FALSE); }
}
static struct expr *StandardLoadFact(
void *theEnv,
char *logicalName,
struct token *theToken)
{
int error = FALSE;
struct expr *temp;
GetToken(theEnv,logicalName,theToken);
if (theToken->type != LPAREN) return(NULL);
temp = GenConstant(theEnv,FCALL,FindFunction(theEnv,(char*)"assert"));
temp->argList = GetRHSPattern(theEnv,logicalName,theToken,&error,
TRUE,FALSE,TRUE,RPAREN);
if (error == TRUE)
{
EnvPrintRouter(theEnv,WERROR,(char*)"Function load-facts encountered an error\n");
SetEvaluationError(theEnv,TRUE);
ReturnExpression(theEnv,temp);
return(NULL);
}
if (ExpressionContainsVariables(temp,TRUE))
{
ReturnExpression(theEnv,temp);
return(NULL);
}
return(temp);
}
/****************************************************
NAME : GenObjectLengthTest
DESCRIPTION : Generates a test on the cardinality
of a slot matching an object pattern
INPUTS : The first lhsParseNode for a slot
in an object pattern
RETURNS : Nothing useful
SIDE EFFECTS : The lhsParseNode network test is
modified to include the length test
NOTES : None
****************************************************/
globle void GenObjectLengthTest(
void *theEnv,
struct lhsParseNode *theNode)
{
struct ObjectMatchLength hack;
EXPRESSION *theTest;
if ((theNode->singleFieldsAfter == 0) &&
(theNode->type != SF_VARIABLE) &&
(theNode->type != SF_WILDCARD))
return;
ClearBitString((void *) &hack,(int) sizeof(struct ObjectMatchLength));
if ((theNode->type != MF_VARIABLE) &&
(theNode->type != MF_WILDCARD) &&
(theNode->multiFieldsAfter == 0))
hack.exactly = 1;
else
hack.exactly = 0;
if ((theNode->type == SF_VARIABLE) || (theNode->type == SF_WILDCARD))
hack.minLength = 1 + theNode->singleFieldsAfter;
else
hack.minLength = theNode->singleFieldsAfter;
theTest = GenConstant(theEnv,OBJ_SLOT_LENGTH,EnvAddBitMap(theEnv,(void *) &hack,
(int) sizeof(struct ObjectMatchLength)));
if (theNode->constantSelector != NULL)
{ theNode->constantSelector->nextArg = CopyExpression(theEnv,theTest); }
theNode->networkTest = CombineExpressions(theEnv,theTest,theNode->networkTest);
}
/***********************************************************************************
NAME : ReplaceInstanceVariables
DESCRIPTION : Replaces all references to instance-variables within an
instance query-function with function calls to query-instance
(which references the instance array at run-time)
INPUTS : 1) The instance-variable list
2) A boolean expression containing variable references
3) A flag indicating whether to allow slot references of the type
<instance-query-variable>:<slot-name> for direct slot access
or not
4) Nesting depth of query functions
RETURNS : Nothing useful
SIDE EFFECTS : If a SF_VARIABLE node is found and is on the list of instance
variables, it is replaced with a query-instance function call.
NOTES : Other SF_VARIABLE(S) are left alone for replacement by other
parsers. This implies that a user may use defgeneric,
defrule, and defmessage-handler variables within a query-function
where they do not conflict with instance-variable names.
***********************************************************************************/
static void ReplaceInstanceVariables(
void *theEnv,
EXEC_STATUS,
EXPRESSION *vlist,
EXPRESSION *bexp,
int sdirect,
int ndepth)
{
EXPRESSION *eptr;
struct FunctionDefinition *rindx_func,*rslot_func;
int posn;
rindx_func = FindFunction(theEnv,execStatus,"(query-instance)");
rslot_func = FindFunction(theEnv,execStatus,"(query-instance-slot)");
while (bexp != NULL)
{
if (bexp->type == SF_VARIABLE)
{
eptr = vlist;
posn = 0;
while ((eptr != NULL) ? (eptr->value != bexp->value) : FALSE)
{
eptr = eptr->nextArg;
posn++;
}
if (eptr != NULL)
{
bexp->type = FCALL;
bexp->value = (void *) rindx_func;
eptr = GenConstant(theEnv,execStatus,INTEGER,(void *) EnvAddLong(theEnv,execStatus,(long long) ndepth));
eptr->nextArg = GenConstant(theEnv,execStatus,INTEGER,(void *) EnvAddLong(theEnv,execStatus,(long long) posn));
bexp->argList = eptr;
}
else if (sdirect == TRUE)
ReplaceSlotReference(theEnv,execStatus,vlist,bexp,rslot_func,ndepth);
}
if (bexp->argList != NULL)
{
if (IsQueryFunction(bexp))
ReplaceInstanceVariables(theEnv,execStatus,vlist,bexp->argList,sdirect,ndepth+1);
else
ReplaceInstanceVariables(theEnv,execStatus,vlist,bexp->argList,sdirect,ndepth);
}
bexp = bexp->nextArg;
}
}
static struct expr *GenJNVariableComparison(
void *theEnv,
EXEC_STATUS,
struct lhsParseNode *selfNode,
struct lhsParseNode *referringNode,
int isNand)
{
struct expr *top;
/*========================================================*/
/* If either pattern is missing a function for generating */
/* the appropriate test, then no test is generated. */
/*========================================================*/
if ((selfNode->patternType->genCompareJNValuesFunction == NULL) ||
(referringNode->patternType->genCompareJNValuesFunction == NULL))
{ return(NULL); }
/*=====================================================*/
/* If both patterns are of the same type, then use the */
/* special function for generating the join test. */
/*=====================================================*/
if (selfNode->patternType->genCompareJNValuesFunction ==
referringNode->patternType->genCompareJNValuesFunction)
{
return (*selfNode->patternType->genCompareJNValuesFunction)(theEnv,execStatus,selfNode,
referringNode,isNand);
}
/*===========================================================*/
/* If the patterns are of different types, then generate a */
/* join test by using the eq/neq function with its arguments */
/* being function calls to retrieve the appropriate values */
/* from the patterns. */
/*===========================================================*/
if (selfNode->negated) top = GenConstant(theEnv,execStatus,FCALL,ExpressionData(theEnv,execStatus)->PTR_NEQ);
else top = GenConstant(theEnv,execStatus,FCALL,ExpressionData(theEnv,execStatus)->PTR_EQ);
top->argList = (*selfNode->patternType->genGetJNValueFunction)(theEnv,execStatus,selfNode,RHS);
top->argList->nextArg = (*referringNode->patternType->genGetJNValueFunction)(theEnv,execStatus,referringNode,LHS);
return(top);
}
globle struct expr *FunctionReferenceExpression(
void *theEnv,
const char *name)
{
#if DEFGENERIC_CONSTRUCT
void *gfunc;
#endif
#if DEFFUNCTION_CONSTRUCT
void *dptr;
#endif
struct FunctionDefinition *fptr;
/*=====================================================*/
/* Check to see if the function call is a deffunction. */
/*=====================================================*/
#if DEFFUNCTION_CONSTRUCT
if ((dptr = (void *) LookupDeffunctionInScope(theEnv,name)) != NULL)
{ return(GenConstant(theEnv,PCALL,dptr)); }
#endif
/*====================================================*/
/* Check to see if the function call is a defgeneric. */
/*====================================================*/
#if DEFGENERIC_CONSTRUCT
if ((gfunc = (void *) LookupDefgenericInScope(theEnv,name)) != NULL)
{ return(GenConstant(theEnv,GCALL,gfunc)); }
#endif
/*======================================*/
/* Check to see if the function call is */
/* a system or user defined function. */
/*======================================*/
if ((fptr = FindFunction(theEnv,name)) != NULL)
{ return(GenConstant(theEnv,FCALL,fptr)); }
/*===================================================*/
/* The specified function name is not a deffunction, */
/* defgeneric, or user/system defined function. */
/*===================================================*/
return(NULL);
}
globle EXPRESSION *GenGetJNObjectValue(
struct lhsParseNode *theNode)
{
EXPRESSION *theItem;
theItem = GenConstant(0,NULL);
GenObjectGetVar(TRUE,theItem,theNode);
return(theItem);
}
static struct expr *AddToUnionList(
void *theEnv,
struct expr *theList1,
struct expr *theHead,
CONSTRAINT_RECORD *theConstraint)
{
struct expr *theList2;
int flag;
/*======================================*/
/* Loop through each value in the list */
/* being added to the unioned set. */
/*======================================*/
for (;theList1 != NULL; theList1 = theList1->nextArg)
{
/*===================================*/
/* Determine if the value is already */
/* in the unioned list. */
/*===================================*/
flag = TRUE;
for (theList2 = theHead;
theList2 != NULL;
theList2 = theList2->nextArg)
{
if ((theList1->type == theList2->type) &&
(theList1->value == theList2->value))
{
flag = FALSE;
break;
}
}
/*=====================================================*/
/* If the value wasn't in the unioned list and doesn't */
/* violate any of the unioned list's constraints, then */
/* add it to the list. */
/*=====================================================*/
if (flag)
{
if (RestrictionOnType(theList1->type,theConstraint))
{
theList2 = GenConstant(theEnv,theList1->type,theList1->value);
theList2->nextArg = theHead;
theHead = theList2;
}
}
}
/*==============================*/
/* Return the new unioned list. */
/*==============================*/
return(theHead);
}
static void ClearDeffacts(
void *theEnv)
{
#if (! RUN_TIME) && (! BLOAD_ONLY)
struct expr *stub;
struct deffacts *newDeffacts;
/*=====================================*/
/* Create the data structures for the */
/* expression (assert (initial-fact)). */
/*=====================================*/
stub = GenConstant(theEnv,FCALL,FindFunction(theEnv,"assert"));
stub->argList = GenConstant(theEnv,DEFTEMPLATE_PTR,EnvFindDeftemplate(theEnv,"initial-fact"));
ExpressionInstall(theEnv,stub);
/*=============================================*/
/* Create a deffacts data structure to contain */
/* the expression and initialize it. */
/*=============================================*/
newDeffacts = get_struct(theEnv,deffacts);
newDeffacts->header.whichModule =
(struct defmoduleItemHeader *) GetDeffactsModuleItem(theEnv,NULL);
newDeffacts->header.name = (SYMBOL_HN *) EnvAddSymbol(theEnv,"initial-fact");
IncrementSymbolCount(newDeffacts->header.name);
newDeffacts->assertList = PackExpression(theEnv,stub);
newDeffacts->header.next = NULL;
newDeffacts->header.ppForm = NULL;
newDeffacts->header.usrData = NULL;
ReturnExpression(theEnv,stub);
/*===========================================*/
/* Store the deffacts in the current module. */
/*===========================================*/
AddConstructToModule(&newDeffacts->header);
#else
#if MAC_MCW || WIN_MCW || MAC_XCD
#pragma unused(theEnv)
#endif
#endif
}
static struct expr *GenJNConstant(
void *theEnv,
EXEC_STATUS,
struct lhsParseNode *theField,
int isNand)
{
struct expr *top;
/*===============================================*/
/* If the pattern parser is capable of creating */
/* a specialized test, then call the function to */
/* generate the join network test and return the */
/* expression generated. */
/*===============================================*/
if (theField->patternType->genJNConstantFunction != NULL)
{
if (isNand)
{ return (*theField->patternType->genJNConstantFunction)(theEnv,execStatus,theField,NESTED_RHS); }
else
{ return (*theField->patternType->genJNConstantFunction)(theEnv,execStatus,theField,RHS); }
}
/*===================================================*/
/* Otherwise, generate a test which uses the eq/neq */
/* function to compare the pattern field/slot to the */
/* constant and then return the expression. */
/*===================================================*/
if (theField->negated)
{ top = GenConstant(theEnv,execStatus,FCALL,ExpressionData(theEnv,execStatus)->PTR_NEQ); }
else
{ top = GenConstant(theEnv,execStatus,FCALL,ExpressionData(theEnv,execStatus)->PTR_EQ); }
if (isNand)
{ top->argList = (*theField->patternType->genGetJNValueFunction)(theEnv,execStatus,theField,NESTED_RHS); }
else
{ top->argList = (*theField->patternType->genGetJNValueFunction)(theEnv,execStatus,theField,RHS); }
top->argList->nextArg = GenConstant(theEnv,execStatus,theField->type,theField->value);
return(top);
}
globle EXPRESSION *GenGetPNObjectValue(
void *theEnv,
struct lhsParseNode *theNode)
{
EXPRESSION *theItem;
theItem = GenConstant(theEnv,0,NULL);
GenObjectGetVar(theEnv,FALSE,theItem,theNode,-1);
return(theItem);
}
/***************************************************
NAME : CheckForFacetConflicts
DESCRIPTION : Determines if all facets specified
(and inherited) for a slot are
consistent
INPUTS : 1) The slot descriptor
2) The parse record for the
type constraints on the slot
RETURNS : TRUE if all OK,
FALSE otherwise
SIDE EFFECTS : Min and Max fields replaced in
constraint for single-field slot
NOTES : None
***************************************************/
static intBool CheckForFacetConflicts(
void *theEnv,
EXEC_STATUS,
SLOT_DESC *sd,
CONSTRAINT_PARSE_RECORD *parsedConstraint)
{
if (sd->multiple == 0)
{
if (parsedConstraint->cardinality)
{
PrintErrorID(theEnv,execStatus,"CLSLTPSR",3,TRUE);
EnvPrintRouter(theEnv,execStatus,WERROR,"Cardinality facet can only be used with multifield slots\n");
return(FALSE);
}
else
{
ReturnExpression(theEnv,execStatus,sd->constraint->minFields);
ReturnExpression(theEnv,execStatus,sd->constraint->maxFields);
sd->constraint->minFields = GenConstant(theEnv,execStatus,INTEGER,EnvAddLong(theEnv,execStatus,1LL));
sd->constraint->maxFields = GenConstant(theEnv,execStatus,INTEGER,EnvAddLong(theEnv,execStatus,1LL));
}
}
if (sd->noDefault && sd->noWrite)
{
PrintErrorID(theEnv,execStatus,"CLSLTPSR",4,TRUE);
EnvPrintRouter(theEnv,execStatus,WERROR,"read-only slots must have a default value\n");
return(FALSE);
}
if (sd->noWrite && (sd->createWriteAccessor || sd->overrideMessageSpecified))
{
PrintErrorID(theEnv,execStatus,"CLSLTPSR",5,TRUE);
EnvPrintRouter(theEnv,execStatus,WERROR,"read-only slots cannot have a write accessor\n");
return(FALSE);
}
if (sd->noInherit && sd->publicVisibility)
{
PrintErrorID(theEnv,execStatus,"CLSLTPSR",6,TRUE);
EnvPrintRouter(theEnv,execStatus,WERROR,"no-inherit slots cannot also be public\n");
return(FALSE);
}
return(TRUE);
}
/********************************************************
NAME : CreateInitialDefinstances
DESCRIPTION : Makes the initial-object definstances
structure for creating an initial-object
which will match default object patterns
in defrules
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : initial-object definstances created
NOTES : None
********************************************************/
static void CreateInitialDefinstances(
void *theEnv)
{
EXPRESSION *tmp;
DEFINSTANCES *theDefinstances;
theDefinstances = get_struct(theEnv,definstances);
InitializeConstructHeader(theEnv,(char*)"definstances",(struct constructHeader *) theDefinstances,
DefclassData(theEnv)->INITIAL_OBJECT_SYMBOL);
theDefinstances->busy = 0;
tmp = GenConstant(theEnv,FCALL,(void *) FindFunction(theEnv,(char*)"make-instance"));
tmp->argList = GenConstant(theEnv,INSTANCE_NAME,(void *) DefclassData(theEnv)->INITIAL_OBJECT_SYMBOL);
tmp->argList->nextArg =
GenConstant(theEnv,DEFCLASS_PTR,(void *) LookupDefclassInScope(theEnv,INITIAL_OBJECT_CLASS_NAME));
theDefinstances->mkinstance = PackExpression(theEnv,tmp);
ReturnExpression(theEnv,tmp);
IncrementSymbolCount(GetDefinstancesNamePointer((void *) theDefinstances));
ExpressionInstall(theEnv,theDefinstances->mkinstance);
AddConstructToModule((struct constructHeader *) theDefinstances);
}
/***************************************************
NAME : CheckForFacetConflicts
DESCRIPTION : Determines if all facets specified
(and inherited) for a slot are
consistent
INPUTS : 1) The slot descriptor
2) The parse record for the
type constraints on the slot
RETURNS : True if all OK,
false otherwise
SIDE EFFECTS : Min and Max fields replaced in
constraint for single-field slot
NOTES : None
***************************************************/
static bool CheckForFacetConflicts(
Environment *theEnv,
SlotDescriptor *sd,
CONSTRAINT_PARSE_RECORD *parsedConstraint)
{
if (sd->multiple == 0)
{
if (parsedConstraint->cardinality)
{
PrintErrorID(theEnv,"CLSLTPSR",3,true);
WriteString(theEnv,STDERR,"The 'cardinality' facet can only be used with multifield slots.\n");
return false;
}
else
{
ReturnExpression(theEnv,sd->constraint->minFields);
ReturnExpression(theEnv,sd->constraint->maxFields);
sd->constraint->minFields = GenConstant(theEnv,INTEGER_TYPE,CreateInteger(theEnv,1LL));
sd->constraint->maxFields = GenConstant(theEnv,INTEGER_TYPE,CreateInteger(theEnv,1LL));
}
}
if (sd->noDefault && sd->noWrite)
{
PrintErrorID(theEnv,"CLSLTPSR",4,true);
WriteString(theEnv,STDERR,"Slots with an 'access' facet value of 'read-only' must have a default value.\n");
return false;
}
if (sd->noWrite && (sd->createWriteAccessor || sd->overrideMessageSpecified))
{
PrintErrorID(theEnv,"CLSLTPSR",5,true);
WriteString(theEnv,STDERR,"Slots with an 'access' facet value of 'read-only' cannot have a write accessor.\n");
return false;
}
if (sd->noInherit && sd->publicVisibility)
{
PrintErrorID(theEnv,"CLSLTPSR",6,true);
WriteString(theEnv,STDERR,"Slots with a 'propagation' facet value of 'no-inherit' cannot have a 'visibility' facet value of 'public'.\n");
return false;
}
return true;
}
globle struct expr *ArgumentParse(
void *theEnv,
char *logicalName,
int *errorFlag)
{
struct expr *top;
struct token theToken;
/*===============*/
/* Grab a token. */
/*===============*/
GetToken(theEnv,logicalName,&theToken);
/*============================*/
/* ')' counts as no argument. */
/*============================*/
if (theToken.type == RPAREN)
{ return(NULL); }
/*================================*/
/* Parse constants and variables. */
/*================================*/
if ((theToken.type == SF_VARIABLE) || (theToken.type == MF_VARIABLE) ||
(theToken.type == SYMBOL) || (theToken.type == STRING) ||
#if DEFGLOBAL_CONSTRUCT
(theToken.type == GBL_VARIABLE) ||
(theToken.type == MF_GBL_VARIABLE) ||
#endif
#if OBJECT_SYSTEM
(theToken.type == INSTANCE_NAME) ||
#endif
(theToken.type == FLOAT) || (theToken.type == INTEGER))
{ return(GenConstant(theEnv,theToken.type,theToken.value)); }
/*======================*/
/* Parse function call. */
/*======================*/
if (theToken.type != LPAREN)
{
PrintErrorID(theEnv,"EXPRNPSR",2,TRUE);
EnvPrintRouter(theEnv,WERROR,"Expected a constant, variable, or expression.\n");
*errorFlag = TRUE;
return(NULL);
}
top = Function1Parse(theEnv,logicalName);
if (top == NULL) *errorFlag = TRUE;
return(top);
}
static int DefaultCompareSwapFunction(
void *theEnv,
DATA_OBJECT *item1,
DATA_OBJECT *item2)
{
DATA_OBJECT returnValue;
SortFunctionData(theEnv)->SortComparisonFunction->argList = GenConstant(theEnv,item1->type,item1->value);
SortFunctionData(theEnv)->SortComparisonFunction->argList->nextArg = GenConstant(theEnv,item2->type,item2->value);
ExpressionInstall(theEnv,SortFunctionData(theEnv)->SortComparisonFunction);
EvaluateExpression(theEnv,SortFunctionData(theEnv)->SortComparisonFunction,&returnValue);
ExpressionDeinstall(theEnv,SortFunctionData(theEnv)->SortComparisonFunction);
ReturnExpression(theEnv,SortFunctionData(theEnv)->SortComparisonFunction->argList);
SortFunctionData(theEnv)->SortComparisonFunction->argList = NULL;
if ((GetType(returnValue) == SYMBOL) &&
(GetValue(returnValue) == EnvFalseSymbol(theEnv)))
{ return(FALSE); }
return(TRUE);
}
static struct expr *GenJNEq(
void *theEnv,
struct lhsParseNode *theField,
int isNand,
struct nandFrame *theNandFrames)
{
struct expr *top, *conversion;
/*==================================================*/
/* Replace variables with function calls to extract */
/* the appropriate value from the data entity. */
/*==================================================*/
if (isNand)
{ conversion = GetvarReplace(theEnv,theField->expression,TRUE,theNandFrames); }
else
{ conversion = GetvarReplace(theEnv,theField->expression,FALSE,theNandFrames); }
/*============================================================*/
/* If the return value constraint is negated by a ~, then use */
/* the neq function to compare the value of the field to the */
/* value returned by the function call. Otherwise, use eq to */
/* compare the two values. */
/*============================================================*/
if (theField->negated)
{ top = GenConstant(theEnv,FCALL,ExpressionData(theEnv)->PTR_NEQ); }
else
{ top = GenConstant(theEnv,FCALL,ExpressionData(theEnv)->PTR_EQ); }
if (isNand)
{ top->argList = (*theField->patternType->genGetJNValueFunction)(theEnv,theField,NESTED_RHS); }
else
{ top->argList = (*theField->patternType->genGetJNValueFunction)(theEnv,theField,RHS); }
top->argList->nextArg = conversion;
return(top);
}
/****************************************************
NAME : GenObjectZeroLengthTest
DESCRIPTION : Generates a test on the cardinality
of a slot matching an object pattern
INPUTS : The first lhsParseNode for a slot
in an object pattern
RETURNS : Nothing useful
SIDE EFFECTS : The lhsParseNode network test is
modified to include the length test
NOTES : None
****************************************************/
globle void GenObjectZeroLengthTest(
struct lhsParseNode *theNode)
{
struct ObjectMatchLength hack;
EXPRESSION *theTest;
ClearBitString((void *) &hack,(int) sizeof(struct ObjectMatchLength));
hack.exactly = 1;
hack.minLength = 0;
theTest = GenConstant(OBJ_SLOT_LENGTH,AddBitMap((void *) &hack,
(int) sizeof(struct ObjectMatchLength)));
theNode->networkTest = CombineExpressions(theTest,theNode->networkTest);
}
globle struct expr *FactGenCheckZeroLength(
int theSlot)
{
struct factCheckLengthPNCall hack;
ClearBitString(&hack,sizeof(struct factCheckLengthPNCall));
hack.whichSlot = theSlot-1;
hack.exactly = 1;
hack.minLength = 0;
return(GenConstant(FACT_SLOT_LENGTH,AddBitMap(&hack,sizeof(struct factCheckLengthPNCall))));
}
globle struct expr *ConvertValueToExpression(
DATA_OBJECT *theValue)
{
long i;
struct expr *head = NULL, *last = NULL, *newItem;
if (GetpType(theValue) != MULTIFIELD)
{ return(GenConstant(GetpType(theValue),GetpValue(theValue))); }
for (i = GetpDOBegin(theValue); i <= GetpDOEnd(theValue); i++)
{
newItem = GenConstant(GetMFType(GetpValue(theValue),i),
GetMFValue(GetpValue(theValue),i));
if (last == NULL) head = newItem;
else last->nextArg = newItem;
last = newItem;
}
if (head == NULL)
return(GenConstant(FCALL,(void *) FindFunction("create$")));
return(head);
}
globle struct expr *FactGenCheckLength(
struct lhsParseNode *theNode)
{
struct factCheckLengthPNCall hack;
/*===================================================*/
/* If the slot contains no single field constraints, */
/* then a length test is not necessary. */
/*===================================================*/
if ((theNode->singleFieldsAfter == 0) &&
(theNode->type != SF_VARIABLE) &&
(theNode->type != SF_WILDCARD))
{ return(NULL); }
/*=======================================*/
/* Initialize the length test arguments. */
/*=======================================*/
ClearBitString(&hack,sizeof(struct factCheckLengthPNCall));
hack.whichSlot = theNode->slotNumber - 1;
/*============================================*/
/* If the slot has no multifield constraints, */
/* then the length must match exactly. */
/*============================================*/
if ((theNode->type != MF_VARIABLE) &&
(theNode->type != MF_WILDCARD) &&
(theNode->multiFieldsAfter == 0))
{ hack.exactly = 1; }
else
{ hack.exactly = 0; }
/*============================================*/
/* The minimum length is the number of single */
/* field constraints contained in the slot. */
/*============================================*/
if ((theNode->type == SF_VARIABLE) || (theNode->type == SF_WILDCARD))
{ hack.minLength = 1 + theNode->singleFieldsAfter; }
else
{ hack.minLength = theNode->singleFieldsAfter; }
/*========================================================*/
/* Generate call to test the length of a multifield slot. */
/*========================================================*/
return(GenConstant(FACT_SLOT_LENGTH,AddBitMap(&hack,sizeof(struct factCheckLengthPNCall))));
}
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 struct expr *CopyExpression(
struct expr *original)
{
struct expr *topLevel, *next, *last;
if (original == NULL) return(NULL);
topLevel = GenConstant(original->type,original->value);
topLevel->argList = CopyExpression(original->argList);
last = topLevel;
original = original->nextArg;
while (original != NULL)
{
next = GenConstant(original->type,original->value);
next->argList = CopyExpression(original->argList);
last->nextArg = next;
last = next;
original = original->nextArg;
}
return(topLevel);
}