void SaveExecutionInformation()
{
HKEY hKey;
DWORD lpdwDisposition;
struct ExecutionInformation executionInfo;
if (RegCreateKeyEx(HKEY_CURRENT_USER,TEXT("Software\\CLIPS\\CLIPSWin"),0,"",0,
KEY_READ | KEY_WRITE,NULL,&hKey,&lpdwDisposition) != ERROR_SUCCESS)
{ return; }
executionInfo.salienceEvaluation = EnvGetSalienceEvaluation(GlobalEnv);
executionInfo.strategy = EnvGetStrategy(GlobalEnv);
executionInfo.staticConstraintChecking = (boolean) EnvGetStaticConstraintChecking(GlobalEnv);
executionInfo.dynamicConstraintChecking = (boolean) EnvGetDynamicConstraintChecking(GlobalEnv);
executionInfo.autoFloatDividend = (boolean) EnvGetAutoFloatDividend(GlobalEnv);
executionInfo.resetGlobals = (boolean) EnvGetResetGlobals(GlobalEnv);
executionInfo.factDuplication = (boolean) EnvGetFactDuplication(GlobalEnv);
executionInfo.incrementalReset = (boolean) EnvGetIncrementalReset(GlobalEnv);
executionInfo.sequenceOperatorRecognition = (boolean) EnvGetSequenceOperatorRecognition(GlobalEnv);
if (RegSetValueEx(hKey,"Execution",0,REG_BINARY,(BYTE *) &executionInfo,
sizeof(struct ExecutionInformation)) != ERROR_SUCCESS)
{
RegCloseKey(hKey);
return;
}
RegCloseKey(hKey);
}
globle int GSCCommand(
void *theEnv)
{
int oldValue;
oldValue = EnvGetStaticConstraintChecking(theEnv);
if (EnvArgCountCheck(theEnv,"get-static-constraint-checking",EXACTLY,0) == -1)
{ return(oldValue); }
return(oldValue);
}
static BOOLEAN CheckForUnmatchableConstraints(
void *theEnv,
struct lhsParseNode *theNode,
int whichCE)
{
if (EnvGetStaticConstraintChecking(theEnv) == FALSE) return(FALSE);
if (UnmatchableConstraint(theNode->constraints))
{
ConstraintConflictMessage(theEnv,(SYMBOL_HN *) theNode->value,whichCE,
theNode->index,theNode->slot);
return(TRUE);
}
return(FALSE);
}
globle int SSCCommand(
void *theEnv)
{
int oldValue;
DATA_OBJECT arg_ptr;
oldValue = EnvGetStaticConstraintChecking(theEnv);
if (EnvArgCountCheck(theEnv,"set-static-constraint-checking",EXACTLY,1) == -1)
{ return(oldValue); }
EnvRtnUnknown(theEnv,1,&arg_ptr);
if ((arg_ptr.value == EnvFalseSymbol(theEnv)) && (arg_ptr.type == SYMBOL))
{ EnvSetStaticConstraintChecking(theEnv,FALSE); }
else
{ EnvSetStaticConstraintChecking(theEnv,TRUE); }
return(oldValue);
}
static struct templateSlot *ParseSlot(
void *theEnv,
char *readSource,
struct token *inputToken,
struct templateSlot *slotList)
{
int parsingMultislot;
SYMBOL_HN *slotName;
struct templateSlot *newSlot;
int rv;
/*=====================================================*/
/* Slots must begin with keyword field or multifield. */
/*=====================================================*/
if ((strcmp(ValueToString(inputToken->value),"field") != 0) &&
(strcmp(ValueToString(inputToken->value),"multifield") != 0) &&
(strcmp(ValueToString(inputToken->value),"slot") != 0) &&
(strcmp(ValueToString(inputToken->value),"multislot") != 0))
{
SyntaxErrorMessage(theEnv,"deftemplate");
DeftemplateData(theEnv)->DeftemplateError = TRUE;
return(NULL);
}
/*===============================================*/
/* Determine if multifield slot is being parsed. */
/*===============================================*/
if ((strcmp(ValueToString(inputToken->value),"multifield") == 0) ||
(strcmp(ValueToString(inputToken->value),"multislot") == 0))
{ parsingMultislot = TRUE; }
else
{ parsingMultislot = FALSE; }
/*========================================*/
/* The name of the slot must be a symbol. */
/*========================================*/
SavePPBuffer(theEnv," ");
GetToken(theEnv,readSource,inputToken);
if (inputToken->type != SYMBOL)
{
SyntaxErrorMessage(theEnv,"deftemplate");
DeftemplateData(theEnv)->DeftemplateError = TRUE;
return(NULL);
}
slotName = (SYMBOL_HN *) inputToken->value;
/*================================================*/
/* Determine if the slot has already been parsed. */
/*================================================*/
while (slotList != NULL)
{
if (slotList->slotName == slotName)
{
AlreadyParsedErrorMessage(theEnv,"slot ",ValueToString(slotList->slotName));
DeftemplateData(theEnv)->DeftemplateError = TRUE;
return(NULL);
}
slotList = slotList->next;
}
/*===================================*/
/* Parse the attributes of the slot. */
/*===================================*/
newSlot = DefinedSlots(theEnv,readSource,slotName,parsingMultislot,inputToken);
if (newSlot == NULL)
{
DeftemplateData(theEnv)->DeftemplateError = TRUE;
return(NULL);
}
/*=================================*/
/* Check for slot conflict errors. */
/*=================================*/
if (CheckConstraintParseConflicts(theEnv,newSlot->constraints) == FALSE)
{
ReturnSlots(theEnv,newSlot);
DeftemplateData(theEnv)->DeftemplateError = TRUE;
return(NULL);
}
if ((newSlot->defaultPresent) || (newSlot->defaultDynamic))
{ rv = ConstraintCheckExpressionChain(theEnv,newSlot->defaultList,newSlot->constraints); }
else
{ rv = NO_VIOLATION; }
if ((rv != NO_VIOLATION) && EnvGetStaticConstraintChecking(theEnv))
{
char *temp;
if (newSlot->defaultDynamic) temp = "the default-dynamic attribute";
else temp = "the default attribute";
ConstraintViolationErrorMessage(theEnv,"An expression",temp,FALSE,0,
newSlot->slotName,0,rv,newSlot->constraints,TRUE);
ReturnSlots(theEnv,newSlot);
DeftemplateData(theEnv)->DeftemplateError = TRUE;
return(NULL);
}
/*==================*/
/* Return the slot. */
/*==================*/
return(newSlot);
}
/*******************************************************************************
Name: UpdateOptionsMenu
Description: Set menu item mark on options selected
Arguments: None
Returns: None
*******************************************************************************/
void UpdateOptionsMenu()
{
int i;
unsigned n = 0;
void *theEnv = GetCurrentEnvironment();
XtSetArg(TheArgs[n], XtNleftBitmap, None);n++;
for(i = 0; i <= RANDOM_STRATEGY;i++)
XtSetValues(strategy_widgets[i], TheArgs, n);
for(i = 0; i <= EVERY_CYCLE;i++)
XtSetValues(sal_opt_widgets[i],TheArgs,n);
n = 0;
XtSetArg(TheArgs[n], XtNleftBitmap, checker);n++;
XtSetValues(strategy_widgets[EnvGetStrategy(theEnv)],TheArgs,n);
XtSetValues(sal_opt_widgets[EnvGetSalienceEvaluation(theEnv)],TheArgs,n);
n = 0;
if (EnvGetFactDuplication(theEnv))
{
XtSetArg(TheArgs[n], XtNstate,True);n++;
XtSetValues(option_widgets[INT_FACT_DUPLICATION], TheArgs, n);
}
else
{
XtSetArg(TheArgs[n], XtNstate,False);n++;
XtSetValues(option_widgets[INT_FACT_DUPLICATION], TheArgs, n);
}
n = 0;
if (EnvGetDynamicConstraintChecking(theEnv))
{
XtSetArg(TheArgs[n], XtNstate,True);n++;
XtSetValues(option_widgets[INT_DYN_CONSTRAINT_CHK], TheArgs, n);
}
else
{
XtSetArg(TheArgs[n], XtNstate,False);n++;
XtSetValues(option_widgets[INT_DYN_CONSTRAINT_CHK], TheArgs, n);
}
n = 0;
if (EnvGetStaticConstraintChecking(theEnv))
{
XtSetArg(TheArgs[n], XtNstate,True);n++;
XtSetValues(option_widgets[INT_STA_CONSTRAINT_CHK], TheArgs, n);
}
else
{
XtSetArg(TheArgs[n], XtNstate,False);n++;
XtSetValues(option_widgets[INT_STA_CONSTRAINT_CHK], TheArgs, n);
}
n = 0;
if (EnvGetSequenceOperatorRecognition(theEnv))
{
XtSetArg(TheArgs[n], XtNstate,True);n++;
XtSetValues(option_widgets[INT_SEQUENCE_OPT_REG], TheArgs, n);
}
else
{
XtSetArg(TheArgs[n], XtNstate,False);n++;
XtSetValues(option_widgets[INT_SEQUENCE_OPT_REG], TheArgs, n);
}
n = 0;
if (EnvGetAutoFloatDividend(theEnv))
{
XtSetArg(TheArgs[n], XtNstate,True);n++;
XtSetValues(option_widgets[INT_AUTO_FLOAT_DIV], TheArgs, n);
}
else
{
XtSetArg(TheArgs[n], XtNstate,False);n++;
XtSetValues(option_widgets[INT_AUTO_FLOAT_DIV], TheArgs, n);
}
n = 0;
if (EnvGetIncrementalReset(theEnv))
{
XtSetArg(TheArgs[n], XtNstate,True);n++;
XtSetValues(option_widgets[INT_INCREMENTAL_RESET], TheArgs, n);
}
else
{
XtSetArg(TheArgs[n], XtNstate,False);n++;
XtSetValues(option_widgets[INT_INCREMENTAL_RESET], TheArgs, n);
}
n = 0;
if (EnvGetResetGlobals(theEnv))
{
XtSetArg(TheArgs[n], XtNstate,True);n++;
XtSetValues(option_widgets[INT_RESET_GLOBALS], TheArgs, n);
}
else
{
XtSetArg(TheArgs[n], XtNstate,False);n++;
XtSetValues(option_widgets[INT_RESET_GLOBALS], TheArgs, n);
}
}
/*********************************************************
NAME : CheckSlotReference
DESCRIPTION : Examines a ?self:<slot-name> reference
If the reference is a single-field or
global variable, checking and evaluation
is delayed until run-time. If the
reference is a symbol, this routine
verifies that the slot is a legal
slot for the reference (i.e., it exists
in the class to which the message-handler
is being attached, it is visible and it
is writable for write reference)
INPUTS : 1) A buffer holding the class
of the handler being parsed
2) The type of the slot reference
3) The value of the slot reference
4) A flag indicating if this is a read
or write access
5) Value expression for write
RETURNS : Class slot on success, NULL on errors
SIDE EFFECTS : Messages printed on errors.
NOTES : For static references, this function
insures that the slot is either
publicly visible or that the handler
is being attached to the same class in
which the private slot is defined.
*********************************************************/
static SLOT_DESC *CheckSlotReference(
void *theEnv,
DEFCLASS *theDefclass,
int theType,
void *theValue,
CLIPS_BOOLEAN writeFlag,
EXPRESSION *writeExpression)
{
int slotIndex;
SLOT_DESC *sd;
int vCode;
if (theType != SYMBOL)
{
PrintErrorID(theEnv,"MSGPSR",7,FALSE);
EnvPrintRouter(theEnv,WERROR,"Illegal value for ?self reference.\n");
return(NULL);
}
slotIndex = FindInstanceTemplateSlot(theEnv,theDefclass,(SYMBOL_HN *) theValue);
if (slotIndex == -1)
{
PrintErrorID(theEnv,"MSGPSR",6,FALSE);
EnvPrintRouter(theEnv,WERROR,"No such slot ");
EnvPrintRouter(theEnv,WERROR,ValueToString(theValue));
EnvPrintRouter(theEnv,WERROR," in class ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefclassName(theEnv,(void *) theDefclass));
EnvPrintRouter(theEnv,WERROR," for ?self reference.\n");
return(NULL);
}
sd = theDefclass->instanceTemplate[slotIndex];
if ((sd->publicVisibility == 0) && (sd->cls != theDefclass))
{
SlotVisibilityViolationError(theEnv,sd,theDefclass);
return(NULL);
}
if (! writeFlag)
return(sd);
/* =================================================
If a slot is initialize-only, the WithinInit flag
still needs to be checked at run-time, for the
handler could be called out of the context of
an init.
================================================= */
if (sd->noWrite && (sd->initializeOnly == 0))
{
SlotAccessViolationError(theEnv,ValueToString(theValue),
FALSE,(void *) theDefclass);
return(NULL);
}
if (EnvGetStaticConstraintChecking(theEnv))
{
vCode = ConstraintCheckExpressionChain(theEnv,writeExpression,sd->constraint);
if (vCode != NO_VIOLATION)
{
PrintErrorID(theEnv,"CSTRNCHK",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Expression for ");
PrintSlot(theEnv,WERROR,sd,NULL,"direct slot write");
ConstraintViolationErrorMessage(theEnv,NULL,NULL,0,0,NULL,0,
vCode,sd->constraint,FALSE);
return(NULL);
}
}
return(sd);
}
/********************************************************************
NAME : EvaluateSlotDefaultValue
DESCRIPTION : Checks the default value against the slot
constraints and evaluates static default values
INPUTS : 1) The slot descriptor
2) The bitmap marking which facets were specified in
the original slot definition
RETURNS : TRUE if all OK, FALSE otherwise
SIDE EFFECTS : Static default value expressions deleted and
replaced with data object evaluation
NOTES : On errors, slot is marked as dynamix so that
DeleteSlots() will erase the slot expression
********************************************************************/
static intBool EvaluateSlotDefaultValue(
void *theEnv,
EXEC_STATUS,
SLOT_DESC *sd,
char *specbits)
{
DATA_OBJECT temp;
int oldce,olddcc,vCode;
/* ===================================================================
Slot default value expression is marked as dynamic until now so
that DeleteSlots() would erase in the event of an error. The delay
was so that the evaluation of a static default value could be
delayed until all the constraints were parsed.
=================================================================== */
if (TestBitMap(specbits,DEFAULT_DYNAMIC_BIT) == 0)
sd->dynamicDefault = 0;
if (sd->noDefault)
return(TRUE);
if (sd->dynamicDefault == 0)
{
if (TestBitMap(specbits,DEFAULT_BIT))
{
oldce = ExecutingConstruct(theEnv,execStatus);
SetExecutingConstruct(theEnv,execStatus,TRUE);
olddcc = EnvSetDynamicConstraintChecking(theEnv,execStatus,EnvGetStaticConstraintChecking(theEnv,execStatus));
vCode = EvaluateAndStoreInDataObject(theEnv,execStatus,(int) sd->multiple,
(EXPRESSION *) sd->defaultValue,&temp,TRUE);
if (vCode != FALSE)
vCode = ValidSlotValue(theEnv,execStatus,&temp,sd,NULL,"slot default value");
EnvSetDynamicConstraintChecking(theEnv,execStatus,olddcc);
SetExecutingConstruct(theEnv,execStatus,oldce);
if (vCode)
{
ExpressionDeinstall(theEnv,execStatus,(EXPRESSION *) sd->defaultValue);
ReturnPackedExpression(theEnv,execStatus,(EXPRESSION *) sd->defaultValue);
sd->defaultValue = (void *) get_struct(theEnv,execStatus,dataObject);
GenCopyMemory(DATA_OBJECT,1,sd->defaultValue,&temp);
ValueInstall(theEnv,execStatus,(DATA_OBJECT *) sd->defaultValue);
}
else
{
sd->dynamicDefault = 1;
return(FALSE);
}
}
else if (sd->defaultSpecified == 0)
{
sd->defaultValue = (void *) get_struct(theEnv,execStatus,dataObject);
DeriveDefaultFromConstraints(theEnv,execStatus,sd->constraint,
(DATA_OBJECT *) sd->defaultValue,(int) sd->multiple,TRUE);
ValueInstall(theEnv,execStatus,(DATA_OBJECT *) sd->defaultValue);
}
}
else if (EnvGetStaticConstraintChecking(theEnv,execStatus))
{
vCode = ConstraintCheckExpressionChain(theEnv,execStatus,(EXPRESSION *) sd->defaultValue,sd->constraint);
if (vCode != NO_VIOLATION)
{
PrintErrorID(theEnv,execStatus,"CSTRNCHK",1,FALSE);
EnvPrintRouter(theEnv,execStatus,WERROR,"Expression for ");
PrintSlot(theEnv,execStatus,WERROR,sd,NULL,"dynamic default value");
ConstraintViolationErrorMessage(theEnv,execStatus,NULL,NULL,0,0,NULL,0,
vCode,sd->constraint,FALSE);
return(FALSE);
}
}
return(TRUE);
}
globle intBool GetStaticConstraintChecking()
{
return EnvGetStaticConstraintChecking(GetCurrentEnvironment());
}
static BOOLEAN CheckArgumentForConstraintError(
void *theEnv,
struct expr *expressionList,
struct expr *lastOne,
int i,
struct FunctionDefinition *theFunction,
struct lhsParseNode *theLHS)
{
int theRestriction;
CONSTRAINT_RECORD *constraint1, *constraint2, *constraint3, *constraint4;
struct lhsParseNode *theVariable;
struct expr *tmpPtr;
int rv = FALSE;
/*=============================================================*/
/* Skip anything that isn't a variable or isn't an argument to */
/* a user defined function (i.e. deffunctions and generic have */
/* no constraint information so they aren't checked). */
/*=============================================================*/
if ((expressionList->type != SF_VARIABLE) || (theFunction == NULL))
{ return (rv); }
/*===========================================*/
/* Get the restrictions for the argument and */
/* convert them to a constraint record. */
/*===========================================*/
theRestriction = GetNthRestriction(theFunction,i);
constraint1 = ArgumentTypeToConstraintRecord(theEnv,theRestriction);
/*================================================*/
/* Look for the constraint record associated with */
/* binding the variable in the LHS of the rule. */
/*================================================*/
theVariable = FindVariable((SYMBOL_HN *) expressionList->value,theLHS);
if (theVariable != NULL)
{
if (theVariable->type == MF_VARIABLE)
{
constraint2 = GetConstraintRecord(theEnv);
SetConstraintType(MULTIFIELD,constraint2);
}
else if (theVariable->constraints == NULL)
{ constraint2 = GetConstraintRecord(theEnv); }
else
{ constraint2 = CopyConstraintRecord(theEnv,theVariable->constraints); }
}
else
{ constraint2 = NULL; }
/*================================================*/
/* Look for the constraint record associated with */
/* binding the variable on the RHS of the rule. */
/*================================================*/
constraint3 = FindBindConstraints(theEnv,(SYMBOL_HN *) expressionList->value);
/*====================================================*/
/* Union the LHS and RHS variable binding constraints */
/* (the variable must satisfy one or the other). */
/*====================================================*/
constraint3 = UnionConstraints(theEnv,constraint3,constraint2);
/*====================================================*/
/* Intersect the LHS/RHS variable binding constraints */
/* with the function argument restriction constraints */
/* (the variable must satisfy both). */
/*====================================================*/
constraint4 = IntersectConstraints(theEnv,constraint3,constraint1);
/*====================================*/
/* Check for unmatchable constraints. */
/*====================================*/
if (UnmatchableConstraint(constraint4) && EnvGetStaticConstraintChecking(theEnv))
{
PrintErrorID(theEnv,"RULECSTR",3,TRUE);
EnvPrintRouter(theEnv,WERROR,"Previous variable bindings of ?");
EnvPrintRouter(theEnv,WERROR,ValueToString((SYMBOL_HN *) expressionList->value));
EnvPrintRouter(theEnv,WERROR," caused the type restrictions");
EnvPrintRouter(theEnv,WERROR,"\nfor argument #");
PrintLongInteger(theEnv,WERROR,(long int) i);
EnvPrintRouter(theEnv,WERROR," of the expression ");
tmpPtr = lastOne->nextArg;
lastOne->nextArg = NULL;
PrintExpression(theEnv,WERROR,lastOne);
lastOne->nextArg = tmpPtr;
EnvPrintRouter(theEnv,WERROR,"\nfound in the rule's RHS to be violated.\n");
rv = TRUE;
}
/*===========================================*/
/* Free the temporarily created constraints. */
/*===========================================*/
RemoveConstraint(theEnv,constraint1);
RemoveConstraint(theEnv,constraint2);
RemoveConstraint(theEnv,constraint3);
RemoveConstraint(theEnv,constraint4);
/*========================================*/
/* Return TRUE if unmatchable constraints */
/* were detected, otherwise FALSE. */
/*========================================*/
return(rv);
}
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 struct expr *Function2Parse(
void *theEnv,
char *logicalName,
char *name)
{
struct FunctionDefinition *theFunction;
struct expr *top;
#if DEFGENERIC_CONSTRUCT
void *gfunc;
#endif
#if DEFFUNCTION_CONSTRUCT
void *dptr;
#endif
/*=========================================================*/
/* Module specification cannot be used in a function call. */
/*=========================================================*/
if (FindModuleSeparator(name))
{
IllegalModuleSpecifierMessage(theEnv);
return(NULL);
}
/*================================*/
/* Has the function been defined? */
/*================================*/
theFunction = FindFunction(theEnv,name);
#if DEFGENERIC_CONSTRUCT
gfunc = (void *) LookupDefgenericInScope(theEnv,name);
#endif
#if DEFFUNCTION_CONSTRUCT
if ((theFunction == NULL)
#if DEFGENERIC_CONSTRUCT
&& (gfunc == NULL)
#endif
)
dptr = (void *) LookupDeffunctionInScope(theEnv,name);
else
dptr = NULL;
#endif
/*=============================*/
/* Define top level structure. */
/*=============================*/
#if DEFFUNCTION_CONSTRUCT
if (dptr != NULL)
top = GenConstant(theEnv,PCALL,dptr);
else
#endif
#if DEFGENERIC_CONSTRUCT
if (gfunc != NULL)
top = GenConstant(theEnv,GCALL,gfunc);
else
#endif
if (theFunction != NULL)
top = GenConstant(theEnv,FCALL,theFunction);
else
{
PrintErrorID(theEnv,"EXPRNPSR",3,TRUE);
EnvPrintRouter(theEnv,WERROR,"Missing function declaration for ");
EnvPrintRouter(theEnv,WERROR,name);
EnvPrintRouter(theEnv,WERROR,".\n");
return(NULL);
}
/*=======================================================*/
/* Check to see if function has its own parsing routine. */
/*=======================================================*/
PushRtnBrkContexts(theEnv);
ExpressionData(theEnv)->ReturnContext = FALSE;
ExpressionData(theEnv)->BreakContext = FALSE;
#if DEFGENERIC_CONSTRUCT || DEFFUNCTION_CONSTRUCT
if (top->type == FCALL)
#endif
{
if (theFunction->parser != NULL)
{
top = (*theFunction->parser)(theEnv,top,logicalName);
PopRtnBrkContexts(theEnv);
if (top == NULL) return(NULL);
if (ReplaceSequenceExpansionOps(theEnv,top->argList,top,FindFunction(theEnv,"(expansion-call)"),
FindFunction(theEnv,"expand$")))
{
ReturnExpression(theEnv,top);
return(NULL);
}
return(top);
}
}
/*========================================*/
/* Default parsing routine for functions. */
/*========================================*/
top = CollectArguments(theEnv,top,logicalName);
PopRtnBrkContexts(theEnv);
if (top == NULL) return(NULL);
if (ReplaceSequenceExpansionOps(theEnv,top->argList,top,FindFunction(theEnv,"(expansion-call)"),
FindFunction(theEnv,"expand$")))
{
ReturnExpression(theEnv,top);
return(NULL);
}
/*============================================================*/
/* If the function call uses the sequence expansion operator, */
/* its arguments cannot be checked until runtime. */
/*============================================================*/
if (top->value == (void *) FindFunction(theEnv,"(expansion-call)"))
{ return(top); }
/*============================*/
/* Check for argument errors. */
/*============================*/
if ((top->type == FCALL) && EnvGetStaticConstraintChecking(theEnv))
{
if (CheckExpressionAgainstRestrictions(theEnv,top,theFunction->restrictions,name))
{
ReturnExpression(theEnv,top);
return(NULL);
}
}
#if DEFFUNCTION_CONSTRUCT
else if (top->type == PCALL)
{
if (CheckDeffunctionCall(theEnv,top->value,CountArguments(top->argList)) == FALSE)
{
ReturnExpression(theEnv,top);
return(NULL);
}
}
#endif
/*========================*/
/* Return the expression. */
/*========================*/
return(top);
}
static struct lhsParseNode *CheckExpression(
void *theEnv,
struct lhsParseNode *exprPtr,
struct lhsParseNode *lastOne,
int whichCE,
struct symbolHashNode *slotName,
int theField)
{
struct lhsParseNode *rv;
int i = 1;
while (exprPtr != NULL)
{
/*===============================================================*/
/* Check that single field variables contained in the expression */
/* were previously defined in the LHS. Also check to see if the */
/* variable has unmatchable constraints. */
/*===============================================================*/
if (exprPtr->type == SF_VARIABLE)
{
if (exprPtr->referringNode == NULL)
{
VariableReferenceErrorMessage(theEnv,(SYMBOL_HN *) exprPtr->value,lastOne,
whichCE,slotName,theField);
return(exprPtr);
}
else if ((UnmatchableConstraint(exprPtr->constraints)) &&
EnvGetStaticConstraintChecking(theEnv))
{
ConstraintReferenceErrorMessage(theEnv,(SYMBOL_HN *) exprPtr->value,lastOne,i,
whichCE,slotName,theField);
return(exprPtr);
}
}
/*==================================================*/
/* Check that multifield variables contained in the */
/* expression were previously defined in the LHS. */
/*==================================================*/
else if ((exprPtr->type == MF_VARIABLE) && (exprPtr->referringNode == NULL))
{
VariableReferenceErrorMessage(theEnv,(SYMBOL_HN *) exprPtr->value,lastOne,
whichCE,slotName,theField);
return(exprPtr);
}
/*=====================================================*/
/* Check that global variables are referenced properly */
/* (i.e. if you reference a global variable, it must */
/* already be defined by a defglobal construct). */
/*=====================================================*/
#if DEFGLOBAL_CONSTRUCT
else if (exprPtr->type == GBL_VARIABLE)
{
int count;
if (FindImportedConstruct(theEnv,"defglobal",NULL,ValueToString(exprPtr->value),
&count,TRUE,NULL) == NULL)
{
VariableReferenceErrorMessage(theEnv,(SYMBOL_HN *) exprPtr->value,lastOne,
whichCE,slotName,theField);
return(exprPtr);
}
}
#endif
/*============================================*/
/* Recursively check other function calls to */
/* insure variables are referenced correctly. */
/*============================================*/
else if (((exprPtr->type == FCALL)
#if DEFGENERIC_CONSTRUCT
|| (exprPtr->type == GCALL)
#endif
#if DEFFUNCTION_CONSTRUCT
|| (exprPtr->type == PCALL)
#endif
) && (exprPtr->bottom != NULL))
{
if ((rv = CheckExpression(theEnv,exprPtr->bottom,exprPtr,whichCE,slotName,theField)) != NULL)
{ return(rv); }
}
/*=============================================*/
/* Move on to the next part of the expression. */
/*=============================================*/
i++;
exprPtr = exprPtr->right;
}
/*================================================*/
/* Return NULL to indicate no error was detected. */
/*================================================*/
return(NULL);
}
static intBool UnboundVariablesInPattern(
void *theEnv,
struct lhsParseNode *theSlot,
int pattern)
{
struct lhsParseNode *andField;
struct lhsParseNode *rv;
int result;
struct lhsParseNode *orField;
struct symbolHashNode *slotName;
CONSTRAINT_RECORD *theConstraints;
int theField;
/*===================================================*/
/* If a multifield slot is being checked, then check */
/* each of the fields grouped with the multifield. */
/*===================================================*/
if (theSlot->multifieldSlot)
{
theSlot = theSlot->bottom;
while (theSlot != NULL)
{
if (UnboundVariablesInPattern(theEnv,theSlot,pattern))
{ return(TRUE); }
theSlot = theSlot->right;
}
return(FALSE);
}
/*=======================*/
/* Check a single field. */
/*=======================*/
slotName = theSlot->slot;
theField = theSlot->index;
theConstraints = theSlot->constraints;
/*===========================================*/
/* Loop through each of the '|' constraints. */
/*===========================================*/
for (orField = theSlot->bottom;
orField != NULL;
orField = orField->bottom)
{
/*===========================================*/
/* Loop through each of the fields connected */
/* by the '&' within the '|' constraint. */
/*===========================================*/
for (andField = orField;
andField != NULL;
andField = andField->right)
{
/*=======================================================*/
/* If this is not a binding occurence of a variable and */
/* there is no previous binding occurence of a variable, */
/* then generate an error message for a variable that is */
/* referred to but not bound. */
/*=======================================================*/
if (((andField->type == SF_VARIABLE) || (andField->type == MF_VARIABLE)) &&
(andField->referringNode == NULL))
{
VariableReferenceErrorMessage(theEnv,(SYMBOL_HN *) andField->value,NULL,pattern,
slotName,theField);
return(TRUE);
}
/*==============================================*/
/* Check predicate and return value constraints */
/* to insure that all variables used within the */
/* constraint have been previously bound. */
/*==============================================*/
else if ((andField->type == PREDICATE_CONSTRAINT) ||
(andField->type == RETURN_VALUE_CONSTRAINT))
{
rv = CheckExpression(theEnv,andField->expression,NULL,pattern,slotName,theField);
if (rv != NULL) return(TRUE);
}
/*========================================================*/
/* If static constraint checking is being performed, then */
/* determine if constant values have violated the set of */
/* derived constraints for the slot/field (based on the */
/* deftemplate definition and propagated constraints). */
/*========================================================*/
else if (((andField->type == INTEGER) || (andField->type == FLOAT) ||
(andField->type == SYMBOL) || (andField->type == STRING) ||
(andField->type == INSTANCE_NAME)) &&
EnvGetStaticConstraintChecking(theEnv))
{
result = ConstraintCheckValue(theEnv,andField->type,andField->value,theConstraints);
if (result != NO_VIOLATION)
{
ConstraintViolationErrorMessage(theEnv,"A literal restriction value",
NULL,FALSE,pattern,
slotName,theField,result,
theConstraints,TRUE);
return(TRUE);
}
}
}
}
/*===============================*/
/* Return FALSE to indicate that */
/* no errors were detected. */
/*===============================*/
return(FALSE);
}
