static struct expr *BreakParse(
void *theEnv,
struct expr *top,
char *infile)
{
struct token theToken;
if (ExpressionData(theEnv)->svContexts->brk == FALSE)
{
PrintErrorID(theEnv,"PRCDRPSR",2,TRUE);
EnvPrintRouter(theEnv,WERROR,"The break function not valid in this context.\n");
ReturnExpression(theEnv,top);
return(NULL);
}
SavePPBuffer(theEnv," ");
GetToken(theEnv,infile,&theToken);
if (theToken.type != RPAREN)
{
SyntaxErrorMessage(theEnv,"break function");
ReturnExpression(theEnv,top);
return(NULL);
}
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,")");
return(top);
}
static struct expr *ReturnParse(
void *theEnv,
struct expr *top,
char *infile)
{
int error_flag = FALSE;
struct token theToken;
if (ExpressionData(theEnv)->svContexts->rtn == TRUE)
ExpressionData(theEnv)->ReturnContext = TRUE;
if (ExpressionData(theEnv)->ReturnContext == FALSE)
{
PrintErrorID(theEnv,"PRCDRPSR",2,TRUE);
EnvPrintRouter(theEnv,WERROR,"The return function is not valid in this context.\n");
ReturnExpression(theEnv,top);
return(NULL);
}
ExpressionData(theEnv)->ReturnContext = FALSE;
SavePPBuffer(theEnv," ");
top->argList = ArgumentParse(theEnv,infile,&error_flag);
if (error_flag)
{
ReturnExpression(theEnv,top);
return(NULL);
}
else if (top->argList == NULL)
{
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,")");
}
else
{
SavePPBuffer(theEnv," ");
GetToken(theEnv,infile,&theToken);
if (theToken.type != RPAREN)
{
SyntaxErrorMessage(theEnv,"return function");
ReturnExpression(theEnv,top);
return(NULL);
}
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,")");
}
return(top);
}
/********************************************************************************
NAME : ParseSlotOverrides
DESCRIPTION : Forms expressions for slot-overrides
INPUTS : 1) The logical name of the input
2) Caller's buffer for error flkag
RETURNS : Address override expressions, NULL
if none or error.
SIDE EFFECTS : Slot-expression built
Caller's error flag set
NOTES : <slot-override> ::= (<slot-name> <value>*)*
goes to
<slot-name> --> <dummy-node> --> <slot-name> --> <dummy-node>...
|
V
<value-expression> --> <value-expression> --> ...
Assumes first token has already been scanned
********************************************************************************/
globle EXPRESSION *ParseSlotOverrides(
void *theEnv,
const char *readSource,
int *error)
{
EXPRESSION *top = NULL,*bot = NULL,*theExp;
EXPRESSION *theExpNext;
while (GetType(DefclassData(theEnv)->ObjectParseToken) == LPAREN)
{
*error = FALSE;
theExp = ArgumentParse(theEnv,readSource,error);
if (*error == TRUE)
{
ReturnExpression(theEnv,top);
return(NULL);
}
else if (theExp == NULL)
{
SyntaxErrorMessage(theEnv,"slot-override");
*error = TRUE;
ReturnExpression(theEnv,top);
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
theExpNext = GenConstant(theEnv,SYMBOL,EnvTrueSymbol(theEnv));
if (CollectArguments(theEnv,theExpNext,readSource) == NULL)
{
*error = TRUE;
ReturnExpression(theEnv,top);
ReturnExpression(theEnv,theExp);
return(NULL);
}
theExp->nextArg = theExpNext;
if (top == NULL)
top = theExp;
else
bot->nextArg = theExp;
bot = theExp->nextArg;
PPCRAndIndent(theEnv);
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
}
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm);
return(top);
}
static struct expr *ParseRuleRHS(
void *theEnv,
const char *readSource)
{
struct expr *actions;
struct token theToken;
/*=========================================================*/
/* Process the actions on the right hand side of the rule. */
/*=========================================================*/
SavePPBuffer(theEnv,"\n ");
SetIndentDepth(theEnv,3);
actions = GroupActions(theEnv,readSource,&theToken,TRUE,NULL,FALSE);
if (actions == NULL) return(NULL);
/*=============================*/
/* Reformat the closing token. */
/*=============================*/
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,theToken.printForm);
/*======================================================*/
/* Check for the closing right parenthesis of the rule. */
/*======================================================*/
if (theToken.type != RPAREN)
{
SyntaxErrorMessage(theEnv,"defrule");
ReturnExpression(theEnv,actions);
return(NULL);
}
/*========================*/
/* Return the rule's RHS. */
/*========================*/
return(actions);
}
/********************************************************************************
NAME : ParseSlotOverrides
DESCRIPTION : Forms expressions for slot-overrides
INPUTS : 1) The logical name of the input
2) Caller's buffer for error flkag
RETURNS : Address override expressions, NULL
if none or error.
SIDE EFFECTS : Slot-expression built
Caller's error flag set
NOTES : <slot-override> ::= (<slot-name> <value>*)*
goes to
<slot-name> --> <dummy-node> --> <slot-name> --> <dummy-node>...
|
V
<value-expression> --> <value-expression> --> ...
Assumes first token has already been scanned
********************************************************************************/
globle EXPRESSION *ParseSlotOverrides(
char *readSource,
int *error)
{
EXPRESSION *top = NULL,*bot = NULL,*exp;
while (GetType(ObjectParseToken) == LPAREN)
{
*error = FALSE;
exp = ArgumentParse(readSource,error);
if (*error == TRUE)
{
ReturnExpression(top);
return(NULL);
}
else if (exp == NULL)
{
SyntaxErrorMessage("slot-override");
*error = TRUE;
ReturnExpression(top);
SetEvaluationError(TRUE);
return(NULL);
}
exp->nextArg = GenConstant(SYMBOL,TrueSymbol);
if (CollectArguments(exp->nextArg,readSource) == NULL)
{
*error = TRUE;
ReturnExpression(top);
return(NULL);
}
if (top == NULL)
top = exp;
else
bot->nextArg = exp;
bot = exp->nextArg;
PPCRAndIndent();
GetToken(readSource,&ObjectParseToken);
}
PPBackup();
PPBackup();
SavePPBuffer(ObjectParseToken.print_rep);
return(top);
}
static struct expr *PrognParse(
struct expr *top,
char *infile)
{
struct token tkn;
struct expr *tmp;
ReturnExpression(top);
BreakContext = svContexts->brk;
ReturnContext = svContexts->rtn;
IncrementIndentDepth(3);
PPCRAndIndent();
tmp = GroupActions(infile,&tkn,TRUE,NULL,FALSE);
DecrementIndentDepth(3);
PPBackup();
PPBackup();
SavePPBuffer(tkn.printForm);
return(tmp);
}
globle struct expr *CollectArguments(
void *theEnv,
struct expr *top,
char *logicalName)
{
int errorFlag;
struct expr *lastOne, *nextOne;
/*========================================*/
/* Default parsing routine for functions. */
/*========================================*/
lastOne = NULL;
while (TRUE)
{
SavePPBuffer(theEnv," ");
errorFlag = FALSE;
nextOne = ArgumentParse(theEnv,logicalName,&errorFlag);
if (errorFlag == TRUE)
{
ReturnExpression(theEnv,top);
return(NULL);
}
if (nextOne == NULL)
{
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,")");
return(top);
}
if (lastOne == NULL)
{ top->argList = nextOne; }
else
{ lastOne->nextArg = nextOne; }
lastOne = nextOne;
}
}
static struct expr *PrognParse(
void *theEnv,
struct expr *top,
char *infile)
{
struct token tkn;
struct expr *tmp;
ReturnExpression(theEnv,top);
ExpressionData(theEnv)->BreakContext = ExpressionData(theEnv)->svContexts->brk;
ExpressionData(theEnv)->ReturnContext = ExpressionData(theEnv)->svContexts->rtn;
IncrementIndentDepth(theEnv,3);
PPCRAndIndent(theEnv);
tmp = GroupActions(theEnv,infile,&tkn,TRUE,NULL,FALSE);
DecrementIndentDepth(theEnv,3);
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,tkn.printForm);
return(tmp);
}
/***************************************************
NAME : ReadUntilClosingParen
DESCRIPTION : Skips over tokens until a ')' is
encountered.
INPUTS : 1) The logical input source
2) A buffer for scanned tokens
RETURNS : TRUE if ')' read, FALSE
otherwise
SIDE EFFECTS : Tokens read
NOTES : Expects first token after opening
paren has already been scanned
***************************************************/
static intBool ReadUntilClosingParen(
void *theEnv,
char *readSource,
struct token *inputToken)
{
int cnt = 1,lparen_read = FALSE;
do
{
if (lparen_read == FALSE)
SavePPBuffer(theEnv," ");
GetToken(theEnv,readSource,inputToken);
if (inputToken->type == STOP)
{
SyntaxErrorMessage(theEnv,"message-handler declaration");
return(FALSE);
}
else if (inputToken->type == LPAREN)
{
lparen_read = TRUE;
cnt++;
}
else if (inputToken->type == RPAREN)
{
cnt--;
if (lparen_read == FALSE)
{
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,")");
}
lparen_read = FALSE;
}
else
lparen_read = FALSE;
}
while (cnt > 0);
return(TRUE);
}
/*************************************************************
NAME : ParseDefinstancesName
DESCRIPTION : Parses definstance name and optional comment
and optional "active" keyword
INPUTS : 1) The logical name of the input source
2) Buffer to hold flag indicating if
definstances should cause pattern-matching
to occur during slot-overrides
RETURNS : Address of name symbol, or
NULL if there was an error
SIDE EFFECTS : Token after name or comment is scanned
NOTES : Assumes "(definstances" has already
been scanned.
*************************************************************/
static SYMBOL_HN *ParseDefinstancesName(
void *theEnv,
char *readSource,
int *active)
{
SYMBOL_HN *dname;
*active = FALSE;
dname = GetConstructNameAndComment(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken,(char*)"definstances",
EnvFindDefinstances,EnvUndefinstances,(char*)"@",
TRUE,FALSE,TRUE);
if (dname == NULL)
return(NULL);
#if DEFRULE_CONSTRUCT
if ((GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL) ? FALSE :
(strcmp(ValueToString(GetValue(DefclassData(theEnv)->ObjectParseToken)),ACTIVE_RLN) == 0))
{
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,(char*)" ");
SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm);
PPCRAndIndent(theEnv);
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
*active = TRUE;
}
#endif
if (GetType(DefclassData(theEnv)->ObjectParseToken) == STRING)
{
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,(char*)" ");
SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm);
PPCRAndIndent(theEnv);
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
}
return(dname);
}
static struct lhsParseNode *GetLHSSlots(
void *theEnv,
char *readSource,
struct token *tempToken,
struct deftemplate *theDeftemplate,
int *error)
{
struct lhsParseNode *firstSlot = NULL, *nextSlot, *lastSlot = NULL;
struct templateSlot *slotPtr;
short position;
/*=======================================================*/
/* Continue parsing slot definitions until the pattern's */
/* closing right parenthesis is encountered. */
/*=======================================================*/
while (tempToken->type != RPAREN)
{
PPBackup(theEnv);
SavePPBuffer(theEnv,(char*)" ");
SavePPBuffer(theEnv,tempToken->printForm);
/*=================================================*/
/* Slot definitions begin with a left parenthesis. */
/*=================================================*/
if (tempToken->type != LPAREN)
{
*error = TRUE;
SyntaxErrorMessage(theEnv,(char*)"deftemplate patterns");
ReturnLHSParseNodes(theEnv,firstSlot);
return(NULL);
}
/*====================*/
/* Get the slot name. */
/*====================*/
GetToken(theEnv,readSource,tempToken);
if (tempToken->type != SYMBOL)
{
*error = TRUE;
SyntaxErrorMessage(theEnv,(char*)"deftemplate patterns");
ReturnLHSParseNodes(theEnv,firstSlot);
return(NULL);
}
/*==========================================================*/
/* Determine if the slot name is valid for the deftemplate. */
/*==========================================================*/
if ((slotPtr = FindSlot(theDeftemplate,(SYMBOL_HN *) tempToken->value,&position)) == NULL)
{
*error = TRUE;
InvalidDeftemplateSlotMessage(theEnv,ValueToString(tempToken->value),
ValueToString(theDeftemplate->header.name),TRUE);
ReturnLHSParseNodes(theEnv,firstSlot);
return(NULL);
}
/*============================================*/
/* Determine if the slot is multiply defined. */
/*============================================*/
if (MultiplyDefinedLHSSlots(theEnv,firstSlot,(SYMBOL_HN *) tempToken->value) == TRUE)
{
*error = TRUE;
ReturnLHSParseNodes(theEnv,firstSlot);
return(NULL);
}
/*==============================================================*/
/* Get the pattern matching values used in the slot definition. */
/*==============================================================*/
nextSlot = GetSingleLHSSlot(theEnv,readSource,tempToken,slotPtr,error,(short) (position+1));
if (*error)
{
ReturnLHSParseNodes(theEnv,firstSlot);
ReturnLHSParseNodes(theEnv,nextSlot);
return(NULL);
}
/*=====================================*/
/* Add the slot definition to the list */
/* of slot definitions already parsed. */
/*=====================================*/
if (lastSlot == NULL)
{ firstSlot = nextSlot; }
else
{ lastSlot->right = nextSlot; }
while (nextSlot->right != NULL) nextSlot = nextSlot->right;
lastSlot = nextSlot;
/*==============================*/
/* Begin parsing the next slot. */
/*==============================*/
GetToken(theEnv,readSource,tempToken);
}
/*===========================================================*/
/* Return all the slot definitions found in the lhs pattern. */
/*===========================================================*/
return(firstSlot);
}
static struct expr *IfParse(
void *theEnv,
struct expr *top,
char *infile)
{
struct token theToken;
/*============================*/
/* Process the if expression. */
/*============================*/
SavePPBuffer(theEnv," ");
top->argList = ParseAtomOrExpression(theEnv,infile,NULL);
if (top->argList == NULL)
{
ReturnExpression(theEnv,top);
return(NULL);
}
/*========================================*/
/* Keyword 'then' must follow expression. */
/*========================================*/
IncrementIndentDepth(theEnv,3);
PPCRAndIndent(theEnv);
GetToken(theEnv,infile,&theToken);
if ((theToken.type != SYMBOL) || (strcmp(ValueToString(theToken.value),"then") != 0))
{
SyntaxErrorMessage(theEnv,"if function");
ReturnExpression(theEnv,top);
return(NULL);
}
/*==============================*/
/* Process the if then actions. */
/*==============================*/
PPCRAndIndent(theEnv);
if (ExpressionData(theEnv)->svContexts->rtn == TRUE)
ExpressionData(theEnv)->ReturnContext = TRUE;
if (ExpressionData(theEnv)->svContexts->brk == TRUE)
ExpressionData(theEnv)->BreakContext = TRUE;
top->argList->nextArg = GroupActions(theEnv,infile,&theToken,TRUE,"else",FALSE);
if (top->argList->nextArg == NULL)
{
ReturnExpression(theEnv,top);
return(NULL);
}
top->argList->nextArg = RemoveUnneededProgn(theEnv,top->argList->nextArg);
/*===========================================*/
/* A ')' signals an if then without an else. */
/*===========================================*/
if (theToken.type == RPAREN)
{
DecrementIndentDepth(theEnv,3);
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,theToken.printForm);
return(top);
}
/*=============================================*/
/* Keyword 'else' must follow if then actions. */
/*=============================================*/
if ((theToken.type != SYMBOL) || (strcmp(ValueToString(theToken.value),"else") != 0))
{
SyntaxErrorMessage(theEnv,"if function");
ReturnExpression(theEnv,top);
return(NULL);
}
/*==============================*/
/* Process the if else actions. */
/*==============================*/
PPCRAndIndent(theEnv);
top->argList->nextArg->nextArg = GroupActions(theEnv,infile,&theToken,TRUE,NULL,FALSE);
if (top->argList->nextArg->nextArg == NULL)
{
ReturnExpression(theEnv,top);
return(NULL);
}
top->argList->nextArg->nextArg = RemoveUnneededProgn(theEnv,top->argList->nextArg->nextArg);
/*======================================================*/
/* Check for the closing right parenthesis of the if. */
/*======================================================*/
if (theToken.type != RPAREN)
{
SyntaxErrorMessage(theEnv,"if function");
ReturnExpression(theEnv,top);
return(NULL);
}
/*===========================================*/
/* A ')' signals an if then without an else. */
/*===========================================*/
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,")");
DecrementIndentDepth(theEnv,3);
return(top);
}
globle intBool ParseDefglobal(
void *theEnv,
char *readSource)
{
int defglobalError = FALSE;
#if (MAC_MCW || IBM_MCW) && (RUN_TIME || BLOAD_ONLY)
#pragma unused(theEnv,readSource)
#endif
#if (! RUN_TIME) && (! BLOAD_ONLY)
struct token theToken;
int tokenRead = TRUE;
struct defmodule *theModule;
/*=====================================*/
/* Pretty print buffer initialization. */
/*=====================================*/
SetPPBufferStatus(theEnv,ON);
FlushPPBuffer(theEnv);
SetIndentDepth(theEnv,3);
SavePPBuffer(theEnv,"(defglobal ");
/*=================================================*/
/* Individual defglobal constructs can't be parsed */
/* while a binary load is in effect. */
/*=================================================*/
#if BLOAD || BLOAD_ONLY || BLOAD_AND_BSAVE
if ((Bloaded(theEnv) == TRUE) && (! ConstructData(theEnv)->CheckSyntaxMode))
{
CannotLoadWithBloadMessage(theEnv,"defglobal");
return(TRUE);
}
#endif
/*===========================*/
/* Look for the module name. */
/*===========================*/
GetToken(theEnv,readSource,&theToken);
if (theToken.type == SYMBOL)
{
/*=================================================*/
/* The optional module name can't contain a module */
/* separator like other constructs. For example, */
/* (defrule X::foo is OK for rules, but the right */
/* syntax for defglobals is (defglobal X ?*foo*. */
/*=================================================*/
tokenRead = FALSE;
if (FindModuleSeparator(ValueToString(theToken.value)))
{
SyntaxErrorMessage(theEnv,"defglobal");
return(TRUE);
}
/*=================================*/
/* Determine if the module exists. */
/*=================================*/
theModule = (struct defmodule *) EnvFindDefmodule(theEnv,ValueToString(theToken.value));
if (theModule == NULL)
{
CantFindItemErrorMessage(theEnv,"defmodule",ValueToString(theToken.value));
return(TRUE);
}
/*=========================================*/
/* If the module name was OK, then set the */
/* current module to the specified module. */
/*=========================================*/
SavePPBuffer(theEnv," ");
EnvSetCurrentModule(theEnv,(void *) theModule);
}
/*===========================================*/
/* If the module name wasn't specified, then */
/* use the current module's name in the */
/* defglobal's pretty print representation. */
/*===========================================*/
else
{
PPBackup(theEnv);
SavePPBuffer(theEnv,EnvGetDefmoduleName(theEnv,((struct defmodule *) EnvGetCurrentModule(theEnv))));
SavePPBuffer(theEnv," ");
SavePPBuffer(theEnv,theToken.printForm);
}
/*======================*/
/* Parse the variables. */
/*======================*/
while (GetVariableDefinition(theEnv,readSource,&defglobalError,tokenRead,&theToken))
{
tokenRead = FALSE;
FlushPPBuffer(theEnv);
SavePPBuffer(theEnv,"(defglobal ");
SavePPBuffer(theEnv,EnvGetDefmoduleName(theEnv,((struct defmodule *) EnvGetCurrentModule(theEnv))));
SavePPBuffer(theEnv," ");
}
#endif
/*==================================*/
/* Return the parsing error status. */
/*==================================*/
return(defglobalError);
}
globle struct expr *BuildRHSAssert(
char *logicalName,
struct token *theToken,
int *error,
int atLeastOne,
int readFirstParen,
char *whereParsed)
{
struct expr *lastOne, *nextOne, *assertList, *stub;
*error = FALSE;
/*===============================================================*/
/* If the first parenthesis of the RHS fact pattern has not been */
/* read yet, then get the next token. If a right parenthesis is */
/* encountered then exit (however, set the error return value if */
/* at least one fact was expected). */
/*===============================================================*/
if (readFirstParen == FALSE)
{
if (theToken->type == RPAREN)
{
if (atLeastOne)
{
*error = TRUE;
SyntaxErrorMessage(whereParsed);
}
return(NULL);
}
}
/*================================================*/
/* Parse the facts until no more are encountered. */
/*================================================*/
lastOne = assertList = NULL;
while ((nextOne = GetRHSPattern(logicalName,theToken,
error,FALSE,readFirstParen,
TRUE,RPAREN)) != NULL)
{
PPCRAndIndent();
stub = GenConstant(FCALL,(void *) FindFunction("assert"));
stub->argList = nextOne;
nextOne = stub;
if (lastOne == NULL)
{ assertList = nextOne; }
else
{ lastOne->nextArg = nextOne; }
lastOne = nextOne;
readFirstParen = TRUE;
}
/*======================================================*/
/* If an error was detected while parsing, then return. */
/*======================================================*/
if (*error)
{
ReturnExpression(assertList);
return(NULL);
}
/*======================================*/
/* Fix the pretty print representation. */
/*======================================*/
if (theToken->type == RPAREN)
{
PPBackup();
PPBackup();
SavePPBuffer(")");
}
/*==============================================================*/
/* If no facts are being asserted then return NULL. In addition */
/* if at least one fact was required, then signal an error. */
/*==============================================================*/
if (assertList == NULL)
{
if (atLeastOne)
{
*error = TRUE;
SyntaxErrorMessage(whereParsed);
}
return(NULL);
}
/*===============================================*/
/* If more than one fact is being asserted, then */
/* wrap the assert commands within a progn call. */
/*===============================================*/
if (assertList->nextArg != NULL)
{
stub = GenConstant(FCALL,(void *) FindFunction("progn"));
stub->argList = assertList;
assertList = stub;
}
/*==========================================================*/
/* Return the expression for asserting the specified facts. */
/*==========================================================*/
return(assertList);
}
/***************************************************************************
NAME : ParseDeffunction
DESCRIPTION : Parses the deffunction construct
INPUTS : The input logical name
RETURNS : FALSE if successful parse, TRUE otherwise
SIDE EFFECTS : Creates valid deffunction definition
NOTES : H/L Syntax :
(deffunction <name> [<comment>]
(<single-field-varible>* [<multifield-variable>])
<action>*)
***************************************************************************/
globle BOOLEAN ParseDeffunction(
void *theEnv,
char *readSource)
{
SYMBOL_HN *deffunctionName;
EXPRESSION *actions;
EXPRESSION *parameterList;
SYMBOL_HN *wildcard;
int min,max,lvars,DeffunctionError = FALSE;
short overwrite = FALSE, owMin = 0, owMax = 0;
DEFFUNCTION *dptr;
SetPPBufferStatus(theEnv,ON);
FlushPPBuffer(theEnv);
SetIndentDepth(theEnv,3);
SavePPBuffer(theEnv,"(deffunction ");
#if BLOAD || BLOAD_AND_BSAVE
if ((Bloaded(theEnv) == TRUE) && (! ConstructData(theEnv)->CheckSyntaxMode))
{
CannotLoadWithBloadMessage(theEnv,"deffunctions");
return(TRUE);
}
#endif
/* =====================================================
Parse the name and comment fields of the deffunction.
===================================================== */
deffunctionName = GetConstructNameAndComment(theEnv,readSource,&DeffunctionData(theEnv)->DFInputToken,"deffunction",
EnvFindDeffunction,NULL,
"!",TRUE,TRUE,TRUE);
if (deffunctionName == NULL)
return(TRUE);
if (ValidDeffunctionName(theEnv,ValueToString(deffunctionName)) == FALSE)
return(TRUE);
/*==========================*/
/* Parse the argument list. */
/*==========================*/
parameterList = ParseProcParameters(theEnv,readSource,&DeffunctionData(theEnv)->DFInputToken,NULL,&wildcard,
&min,&max,&DeffunctionError,NULL);
if (DeffunctionError)
return(TRUE);
/*===================================================================*/
/* Go ahead and add the deffunction so it can be recursively called. */
/*===================================================================*/
if (ConstructData(theEnv)->CheckSyntaxMode)
{
dptr = (DEFFUNCTION *) EnvFindDeffunction(theEnv,ValueToString(deffunctionName));
if (dptr == NULL)
{ dptr = AddDeffunction(theEnv,deffunctionName,NULL,min,max,0,TRUE); }
else
{
overwrite = TRUE;
owMin = (short) dptr->minNumberOfParameters;
owMax = (short) dptr->maxNumberOfParameters;
dptr->minNumberOfParameters = min;
dptr->maxNumberOfParameters = max;
}
}
else
{ dptr = AddDeffunction(theEnv,deffunctionName,NULL,min,max,0,TRUE); }
if (dptr == NULL)
{
ReturnExpression(theEnv,parameterList);
return(TRUE);
}
/*==================================================*/
/* Parse the actions contained within the function. */
/*==================================================*/
PPCRAndIndent(theEnv);
ExpressionData(theEnv)->ReturnContext = TRUE;
actions = ParseProcActions(theEnv,"deffunction",readSource,
&DeffunctionData(theEnv)->DFInputToken,parameterList,wildcard,
NULL,NULL,&lvars,NULL);
if (actions == NULL)
{
ReturnExpression(theEnv,parameterList);
if (overwrite)
{
dptr->minNumberOfParameters = owMin;
dptr->maxNumberOfParameters = owMax;
}
if ((dptr->busy == 0) && (! overwrite))
{
RemoveConstructFromModule(theEnv,(struct constructHeader *) dptr);
RemoveDeffunction(theEnv,dptr);
}
return(TRUE);
}
/*==============================================*/
/* If we're only checking syntax, don't add the */
/* successfully parsed deffunction to the KB. */
/*==============================================*/
if (ConstructData(theEnv)->CheckSyntaxMode)
{
ReturnExpression(theEnv,parameterList);
ReturnPackedExpression(theEnv,actions);
if (overwrite)
{
dptr->minNumberOfParameters = owMin;
dptr->maxNumberOfParameters = owMax;
}
else
{
RemoveConstructFromModule(theEnv,(struct constructHeader *) dptr);
RemoveDeffunction(theEnv,dptr);
}
return(FALSE);
}
/*=============================*/
/* Reformat the closing token. */
/*=============================*/
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,DeffunctionData(theEnv)->DFInputToken.printForm);
SavePPBuffer(theEnv,"\n");
/*======================*/
/* Add the deffunction. */
/*======================*/
AddDeffunction(theEnv,deffunctionName,actions,min,max,lvars,FALSE);
ReturnExpression(theEnv,parameterList);
return(DeffunctionError);
}
/*************************************************************************************
NAME : ParseInitializeInstance
DESCRIPTION : Parses initialize-instance and make-instance function
calls into an EXPRESSION form that
can later be evaluated with EvaluateExpression(theEnv,)
INPUTS : 1) The address of the top node of the expression
containing the initialize-instance function call
2) The logical name of the input source
RETURNS : The address of the modified expression, or NULL
if there is an error
SIDE EFFECTS : The expression is enhanced to include all
aspects of the initialize-instance call
(slot-overrides etc.)
The "top" expression is deleted on errors.
NOTES : This function parses a initialize-instance call into
an expression of the following form :
(initialize-instance <instance-name> <slot-override>*)
where <slot-override> ::= (<slot-name> <expression>+)
goes to -->
initialize-instance
|
V
<instance or name>-><slot-name>-><dummy-node>...
|
V
<value-expression>...
(make-instance <instance> of <class> <slot-override>*)
goes to -->
make-instance
|
V
<instance-name>-><class-name>-><slot-name>-><dummy-node>...
|
V
<value-expression>...
(make-instance of <class> <slot-override>*)
goes to -->
make-instance
|
V
(gensym*)-><class-name>-><slot-name>-><dummy-node>...
|
V
<value-expression>...
(modify-instance <instance> <slot-override>*)
goes to -->
modify-instance
|
V
<instance or name>-><slot-name>-><dummy-node>...
|
V
<value-expression>...
(duplicate-instance <instance> [to <new-name>] <slot-override>*)
goes to -->
duplicate-instance
|
V
<instance or name>-><new-name>-><slot-name>-><dummy-node>...
OR |
(gensym*) V
<value-expression>...
*************************************************************************************/
globle EXPRESSION *ParseInitializeInstance(
void *theEnv,
EXPRESSION *top,
const char *readSource)
{
int error,fcalltype,readclass;
if ((top->value == (void *) FindFunction(theEnv,"make-instance")) ||
(top->value == (void *) FindFunction(theEnv,"active-make-instance")))
fcalltype = MAKE_TYPE;
else if ((top->value == (void *) FindFunction(theEnv,"initialize-instance")) ||
(top->value == (void *) FindFunction(theEnv,"active-initialize-instance")))
fcalltype = INITIALIZE_TYPE;
else if ((top->value == (void *) FindFunction(theEnv,"modify-instance")) ||
(top->value == (void *) FindFunction(theEnv,"active-modify-instance")) ||
(top->value == (void *) FindFunction(theEnv,"message-modify-instance")) ||
(top->value == (void *) FindFunction(theEnv,"active-message-modify-instance")))
fcalltype = MODIFY_TYPE;
else
fcalltype = DUPLICATE_TYPE;
IncrementIndentDepth(theEnv,3);
error = FALSE;
if (top->type == UNKNOWN_VALUE)
top->type = FCALL;
else
SavePPBuffer(theEnv," ");
top->argList = ArgumentParse(theEnv,readSource,&error);
if (error)
goto ParseInitializeInstanceError;
else if (top->argList == NULL)
{
SyntaxErrorMessage(theEnv,"instance");
goto ParseInitializeInstanceError;
}
SavePPBuffer(theEnv," ");
if (fcalltype == MAKE_TYPE)
{
/* ======================================
Handle the case of anonymous instances
where the name was not specified
====================================== */
if ((top->argList->type != SYMBOL) ? FALSE :
(strcmp(ValueToString(top->argList->value),CLASS_RLN) == 0))
{
top->argList->nextArg = ArgumentParse(theEnv,readSource,&error);
if (error == TRUE)
goto ParseInitializeInstanceError;
if (top->argList->nextArg == NULL)
{
SyntaxErrorMessage(theEnv,"instance class");
goto ParseInitializeInstanceError;
}
if ((top->argList->nextArg->type != SYMBOL) ? TRUE :
(strcmp(ValueToString(top->argList->nextArg->value),CLASS_RLN) != 0))
{
top->argList->type = FCALL;
top->argList->value = (void *) FindFunction(theEnv,"gensym*");
readclass = FALSE;
}
else
readclass = TRUE;
}
else
{
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
if ((GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL) ? TRUE :
(strcmp(CLASS_RLN,DOToString(DefclassData(theEnv)->ObjectParseToken)) != 0))
{
SyntaxErrorMessage(theEnv,"make-instance");
goto ParseInitializeInstanceError;
}
SavePPBuffer(theEnv," ");
readclass = TRUE;
}
if (readclass)
{
top->argList->nextArg = ArgumentParse(theEnv,readSource,&error);
if (error)
goto ParseInitializeInstanceError;
if (top->argList->nextArg == NULL)
{
SyntaxErrorMessage(theEnv,"instance class");
goto ParseInitializeInstanceError;
}
}
/* ==============================================
If the class name is a constant, go ahead and
look it up now and replace it with the pointer
============================================== */
if (ReplaceClassNameWithReference(theEnv,top->argList->nextArg) == FALSE)
goto ParseInitializeInstanceError;
PPCRAndIndent(theEnv);
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
top->argList->nextArg->nextArg =
ParseSlotOverrides(theEnv,readSource,&error);
}
else
{
PPCRAndIndent(theEnv);
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
if (fcalltype == DUPLICATE_TYPE)
{
if ((DefclassData(theEnv)->ObjectParseToken.type != SYMBOL) ? FALSE :
(strcmp(DOToString(DefclassData(theEnv)->ObjectParseToken),DUPLICATE_NAME_REF) == 0))
{
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm);
SavePPBuffer(theEnv," ");
top->argList->nextArg = ArgumentParse(theEnv,readSource,&error);
if (error)
goto ParseInitializeInstanceError;
if (top->argList->nextArg == NULL)
{
SyntaxErrorMessage(theEnv,"instance name");
goto ParseInitializeInstanceError;
}
PPCRAndIndent(theEnv);
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
}
else
top->argList->nextArg = GenConstant(theEnv,FCALL,(void *) FindFunction(theEnv,"gensym*"));
top->argList->nextArg->nextArg = ParseSlotOverrides(theEnv,readSource,&error);
}
else
top->argList->nextArg = ParseSlotOverrides(theEnv,readSource,&error);
}
if (error)
goto ParseInitializeInstanceError;
if (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN)
{
SyntaxErrorMessage(theEnv,"slot-override");
goto ParseInitializeInstanceError;
}
DecrementIndentDepth(theEnv,3);
return(top);
ParseInitializeInstanceError:
SetEvaluationError(theEnv,TRUE);
ReturnExpression(theEnv,top);
DecrementIndentDepth(theEnv,3);
return(NULL);
}
/***************************************************************************************
NAME : ParseDefclass
DESCRIPTION : (defclass ...) is a construct (as
opposed to a function), thus no variables
may be used. This means classes may only
be STATICALLY defined (like rules).
INPUTS : The logical name of the router
for the parser input
RETURNS : FALSE if successful parse, TRUE otherwise
SIDE EFFECTS : Inserts valid class definition into
Class Table.
NOTES : H/L Syntax :
(defclass <name> [<comment>]
(is-a <superclass-name>+)
<class-descriptor>*)
<class-descriptor> :== (slot <name> <slot-descriptor>*) |
(role abstract|concrete) |
(pattern-match reactive|non-reactive)
These are for documentation only:
(message-handler <name> [<type>])
<slot-descriptor> :== (default <default-expression>) |
(default-dynamic <default-expression>) |
(storage shared|local) |
(access read-only|read-write|initialize-only) |
(propagation no-inherit|inherit) |
(source composite|exclusive)
(pattern-match reactive|non-reactive)
(visibility public|private)
(override-message <message-name>)
(type ...) |
(cardinality ...) |
(allowed-symbols ...) |
(allowed-strings ...) |
(allowed-numbers ...) |
(allowed-integers ...) |
(allowed-floats ...) |
(allowed-values ...) |
(allowed-instance-names ...) |
(allowed-classes ...) |
(range ...)
<default-expression> ::= ?NONE | ?VARIABLE | <expression>*
***************************************************************************************/
globle int ParseDefclass(
void *theEnv,
char *readSource)
{
SYMBOL_HN *cname;
DEFCLASS *cls;
PACKED_CLASS_LINKS *sclasses,*preclist;
TEMP_SLOT_LINK *slots = NULL;
int roleSpecified = FALSE,
abstract = FALSE,
parseError;
#if DEFRULE_CONSTRUCT
int patternMatchSpecified = FALSE,
reactive = TRUE;
#endif
SetPPBufferStatus(theEnv,ON);
FlushPPBuffer(theEnv);
SetIndentDepth(theEnv,3);
SavePPBuffer(theEnv,"(defclass ");
#if BLOAD || BLOAD_ONLY || BLOAD_AND_BSAVE
if ((Bloaded(theEnv)) && (! ConstructData(theEnv)->CheckSyntaxMode))
{
CannotLoadWithBloadMessage(theEnv,"defclass");
return(TRUE);
}
#endif
cname = GetConstructNameAndComment(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken,"defclass",
EnvFindDefclass,NULL,"#",TRUE,
TRUE,TRUE);
if (cname == NULL)
return(TRUE);
if (ValidClassName(theEnv,ValueToString(cname),&cls) == FALSE)
return(TRUE);
sclasses = ParseSuperclasses(theEnv,readSource,cname);
if (sclasses == NULL)
return(TRUE);
preclist = FindPrecedenceList(theEnv,cls,sclasses);
if (preclist == NULL)
{
DeletePackedClassLinks(theEnv,sclasses,TRUE);
return(TRUE);
}
parseError = FALSE;
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
while (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN)
{
if (GetType(DefclassData(theEnv)->ObjectParseToken) != LPAREN)
{
SyntaxErrorMessage(theEnv,"defclass");
parseError = TRUE;
break;
}
PPBackup(theEnv);
PPCRAndIndent(theEnv);
SavePPBuffer(theEnv,"(");
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL)
{
SyntaxErrorMessage(theEnv,"defclass");
parseError = TRUE;
break;
}
if (strcmp(DOToString(DefclassData(theEnv)->ObjectParseToken),ROLE_RLN) == 0)
{
if (ParseSimpleQualifier(theEnv,readSource,ROLE_RLN,CONCRETE_RLN,ABSTRACT_RLN,
&roleSpecified,&abstract) == FALSE)
{
parseError = TRUE;
break;
}
}
#if DEFRULE_CONSTRUCT
else if (strcmp(DOToString(DefclassData(theEnv)->ObjectParseToken),MATCH_RLN) == 0)
{
if (ParseSimpleQualifier(theEnv,readSource,MATCH_RLN,NONREACTIVE_RLN,REACTIVE_RLN,
&patternMatchSpecified,&reactive) == FALSE)
{
parseError = TRUE;
break;
}
}
#endif
else if (strcmp(DOToString(DefclassData(theEnv)->ObjectParseToken),SLOT_RLN) == 0)
{
slots = ParseSlot(theEnv,readSource,slots,preclist,FALSE,FALSE);
if (slots == NULL)
{
parseError = TRUE;
break;
}
}
else if (strcmp(DOToString(DefclassData(theEnv)->ObjectParseToken),SGL_SLOT_RLN) == 0)
{
slots = ParseSlot(theEnv,readSource,slots,preclist,FALSE,TRUE);
if (slots == NULL)
{
parseError = TRUE;
break;
}
}
else if (strcmp(DOToString(DefclassData(theEnv)->ObjectParseToken),MLT_SLOT_RLN) == 0)
{
slots = ParseSlot(theEnv,readSource,slots,preclist,TRUE,TRUE);
if (slots == NULL)
{
parseError = TRUE;
break;
}
}
else if (strcmp(DOToString(DefclassData(theEnv)->ObjectParseToken),HANDLER_DECL) == 0)
{
if (ReadUntilClosingParen(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken) == FALSE)
{
parseError = TRUE;
break;
}
}
else
{
SyntaxErrorMessage(theEnv,"defclass");
parseError = TRUE;
break;
}
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
}
if ((GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN) || (parseError == TRUE))
{
DeletePackedClassLinks(theEnv,sclasses,TRUE);
DeletePackedClassLinks(theEnv,preclist,TRUE);
DeleteSlots(theEnv,slots);
return(TRUE);
}
SavePPBuffer(theEnv,"\n");
/* =========================================================================
The abstract/reactive qualities of a class are inherited if not specified
========================================================================= */
if (roleSpecified == FALSE)
{
if (preclist->classArray[1]->system && /* Change to cause */
(DefclassData(theEnv)->ClassDefaultsMode == CONVENIENCE_MODE)) /* default role of */
{ abstract = FALSE; } /* classes to be concrete. */
else
{ abstract = preclist->classArray[1]->abstract; }
}
#if DEFRULE_CONSTRUCT
if (patternMatchSpecified == FALSE)
{
if ((preclist->classArray[1]->system) && /* Change to cause */
(! abstract) && /* default pattern-match */
(DefclassData(theEnv)->ClassDefaultsMode == CONVENIENCE_MODE)) /* of classes to be */
{ reactive = TRUE; } /* reactive. */
else
{ reactive = preclist->classArray[1]->reactive; }
}
/* ================================================================
An abstract class cannot have direct instances, thus it makes no
sense for it to be reactive since it will have no objects to
respond to pattern-matching
================================================================ */
if (abstract && reactive)
{
PrintErrorID(theEnv,"CLASSPSR",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"An abstract class cannot be reactive.\n");
DeletePackedClassLinks(theEnv,sclasses,TRUE);
DeletePackedClassLinks(theEnv,preclist,TRUE);
DeleteSlots(theEnv,slots);
return(TRUE);
}
#endif
/* =======================================================
If we're only checking syntax, don't add the
successfully parsed defclass to the KB.
======================================================= */
if (ConstructData(theEnv)->CheckSyntaxMode)
{
DeletePackedClassLinks(theEnv,sclasses,TRUE);
DeletePackedClassLinks(theEnv,preclist,TRUE);
DeleteSlots(theEnv,slots);
return(FALSE);
}
cls = NewClass(theEnv,cname);
cls->abstract = abstract;
#if DEFRULE_CONSTRUCT
cls->reactive = reactive;
#endif
cls->directSuperclasses.classCount = sclasses->classCount;
cls->directSuperclasses.classArray = sclasses->classArray;
/* =======================================================
This is a hack to let functions which need to iterate
over a class AND its superclasses to conveniently do so
The real precedence list starts in position 1
======================================================= */
preclist->classArray[0] = cls;
cls->allSuperclasses.classCount = preclist->classCount;
cls->allSuperclasses.classArray = preclist->classArray;
rtn_struct(theEnv,packedClassLinks,sclasses);
rtn_struct(theEnv,packedClassLinks,preclist);
/* =================================
Shove slots into contiguous array
================================= */
if (slots != NULL)
PackSlots(theEnv,cls,slots);
AddClass(theEnv,cls);
return(FALSE);
}
/*************************************************************
NAME : ParseQueryActionExpression
DESCRIPTION : Parses the action-expression for a query
INPUTS : 1) The top node of the query expression
2) The logical name of the input
3) List of query parameters
RETURNS : TRUE if all OK, FALSE otherwise
SIDE EFFECTS : Entire query-expression deleted on errors
Nodes allocated for new expression
Action shoved in front of template-restrictions
and in back of test-expression on query
argument list
NOTES : Expects top != NULL && top->argList != NULL
*************************************************************/
static int ParseQueryActionExpression(
void *theEnv,
EXPRESSION *top,
const char *readSource,
EXPRESSION *factQuerySetVars,
struct token *queryInputToken)
{
EXPRESSION *qaction,*tmpFactSetVars;
struct BindInfo *oldBindList,*newBindList,*prev;
oldBindList = GetParsedBindNames(theEnv);
SetParsedBindNames(theEnv,NULL);
ExpressionData(theEnv)->BreakContext = TRUE;
ExpressionData(theEnv)->ReturnContext = ExpressionData(theEnv)->svContexts->rtn;
qaction = GroupActions(theEnv,readSource,queryInputToken,TRUE,NULL,FALSE);
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,queryInputToken->printForm);
ExpressionData(theEnv)->BreakContext = FALSE;
if (qaction == NULL)
{
ClearParsedBindNames(theEnv);
SetParsedBindNames(theEnv,oldBindList);
SyntaxErrorMessage(theEnv,"fact-set query function");
ReturnExpression(theEnv,top);
return(FALSE);
}
qaction->nextArg = top->argList->nextArg;
top->argList->nextArg = qaction;
newBindList = GetParsedBindNames(theEnv);
prev = NULL;
while (newBindList != NULL)
{
tmpFactSetVars = factQuerySetVars;
while (tmpFactSetVars != NULL)
{
if (tmpFactSetVars->value == (void *) newBindList->name)
{
ClearParsedBindNames(theEnv);
SetParsedBindNames(theEnv,oldBindList);
PrintErrorID(theEnv,"FACTQPSR",3,FALSE);
EnvPrintRouter(theEnv,WERROR,"Cannot rebind fact-set member variable ");
EnvPrintRouter(theEnv,WERROR,ValueToString(tmpFactSetVars->value));
EnvPrintRouter(theEnv,WERROR," in function ");
EnvPrintRouter(theEnv,WERROR,ValueToString(ExpressionFunctionCallName(top)));
EnvPrintRouter(theEnv,WERROR,".\n");
ReturnExpression(theEnv,top);
return(FALSE);
}
tmpFactSetVars = tmpFactSetVars->nextArg;
}
prev = newBindList;
newBindList = newBindList->next;
}
if (prev == NULL)
{ SetParsedBindNames(theEnv,oldBindList); }
else
{ prev->next = oldBindList; }
return(TRUE);
}
/***************************************************************
NAME : ParseQueryRestrictions
DESCRIPTION : Parses the template restrictions for a query
INPUTS : 1) The top node of the query expression
2) The logical name of the input
3) Caller's token buffer
RETURNS : The fact-variable expressions
SIDE EFFECTS : Entire query expression deleted on errors
Nodes allocated for restrictions and fact
variable expressions
Template restrictions attached to query-expression
as arguments
NOTES : Expects top != NULL
***************************************************************/
static EXPRESSION *ParseQueryRestrictions(
void *theEnv,
EXPRESSION *top,
const char *readSource,
struct token *queryInputToken)
{
EXPRESSION *factQuerySetVars = NULL,*lastFactQuerySetVars = NULL,
*templateExp = NULL,*lastTemplateExp,
*tmp,*lastOne = NULL;
int error = FALSE;
SavePPBuffer(theEnv," ");
GetToken(theEnv,readSource,queryInputToken);
if (queryInputToken->type != LPAREN)
{ goto ParseQueryRestrictionsError1; }
GetToken(theEnv,readSource,queryInputToken);
if (queryInputToken->type != LPAREN)
{ goto ParseQueryRestrictionsError1; }
while (queryInputToken->type == LPAREN)
{
GetToken(theEnv,readSource,queryInputToken);
if (queryInputToken->type != SF_VARIABLE)
{ goto ParseQueryRestrictionsError1; }
tmp = factQuerySetVars;
while (tmp != NULL)
{
if (tmp->value == queryInputToken->value)
{
PrintErrorID(theEnv,"FACTQPSR",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Duplicate fact member variable name in function ");
EnvPrintRouter(theEnv,WERROR,ValueToString(ExpressionFunctionCallName(top)));
EnvPrintRouter(theEnv,WERROR,".\n");
goto ParseQueryRestrictionsError2;
}
tmp = tmp->nextArg;
}
tmp = GenConstant(theEnv,SF_VARIABLE,queryInputToken->value);
if (factQuerySetVars == NULL)
{ factQuerySetVars = tmp; }
else
{ lastFactQuerySetVars->nextArg = tmp; }
lastFactQuerySetVars = tmp;
SavePPBuffer(theEnv," ");
templateExp = ArgumentParse(theEnv,readSource,&error);
if (error)
{ goto ParseQueryRestrictionsError2; }
if (templateExp == NULL)
{ goto ParseQueryRestrictionsError1; }
if (ReplaceTemplateNameWithReference(theEnv,templateExp) == FALSE)
{ goto ParseQueryRestrictionsError2; }
lastTemplateExp = templateExp;
SavePPBuffer(theEnv," ");
while ((tmp = ArgumentParse(theEnv,readSource,&error)) != NULL)
{
if (ReplaceTemplateNameWithReference(theEnv,tmp) == FALSE)
goto ParseQueryRestrictionsError2;
lastTemplateExp->nextArg = tmp;
lastTemplateExp = tmp;
SavePPBuffer(theEnv," ");
}
if (error)
{ goto ParseQueryRestrictionsError2; }
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,")");
tmp = GenConstant(theEnv,SYMBOL,(void *) FactQueryData(theEnv)->QUERY_DELIMETER_SYMBOL);
lastTemplateExp->nextArg = tmp;
lastTemplateExp = tmp;
if (top->argList == NULL)
{ top->argList = templateExp; }
else
{ lastOne->nextArg = templateExp; }
lastOne = lastTemplateExp;
templateExp = NULL;
SavePPBuffer(theEnv," ");
GetToken(theEnv,readSource,queryInputToken);
}
if (queryInputToken->type != RPAREN)
{ goto ParseQueryRestrictionsError1; }
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,")");
return(factQuerySetVars);
ParseQueryRestrictionsError1:
SyntaxErrorMessage(theEnv,"fact-set query function");
ParseQueryRestrictionsError2:
ReturnExpression(theEnv,templateExp);
ReturnExpression(theEnv,top);
ReturnExpression(theEnv,factQuerySetVars);
return(NULL);
}
static struct expr *SwitchParse(
void *theEnv,
struct expr *top,
char *infile)
{
struct token theToken;
EXPRESSION *theExp,*chk;
int default_count = 0;
/*============================*/
/* Process the switch value */
/*============================*/
IncrementIndentDepth(theEnv,3);
SavePPBuffer(theEnv," ");
top->argList = theExp = ParseAtomOrExpression(theEnv,infile,NULL);
if (theExp == NULL)
goto SwitchParseError;
/*========================*/
/* Parse case statements. */
/*========================*/
GetToken(theEnv,infile,&theToken);
while (theToken.type != RPAREN)
{
PPBackup(theEnv);
PPCRAndIndent(theEnv);
SavePPBuffer(theEnv,theToken.printForm);
if (theToken.type != LPAREN)
goto SwitchParseErrorAndMessage;
GetToken(theEnv,infile,&theToken);
SavePPBuffer(theEnv," ");
if ((theToken.type == SYMBOL) &&
(strcmp(ValueToString(theToken.value),"case") == 0))
{
if (default_count != 0)
goto SwitchParseErrorAndMessage;
theExp->nextArg = ParseAtomOrExpression(theEnv,infile,NULL);
SavePPBuffer(theEnv," ");
if (theExp->nextArg == NULL)
goto SwitchParseError;
for (chk = top->argList->nextArg ; chk != theExp->nextArg ; chk = chk->nextArg)
{
if ((chk->type == theExp->nextArg->type) &&
(chk->value == theExp->nextArg->value) &&
IdenticalExpression(chk->argList,theExp->nextArg->argList))
{
PrintErrorID(theEnv,"PRCDRPSR",3,TRUE);
EnvPrintRouter(theEnv,WERROR,"Duplicate case found in switch function.\n");
goto SwitchParseError;
}
}
GetToken(theEnv,infile,&theToken);
if ((theToken.type != SYMBOL) ? TRUE :
(strcmp(ValueToString(theToken.value),"then") != 0))
goto SwitchParseErrorAndMessage;
}
else if ((theToken.type == SYMBOL) &&
(strcmp(ValueToString(theToken.value),"default") == 0))
{
if (default_count)
goto SwitchParseErrorAndMessage;
theExp->nextArg = GenConstant(theEnv,RVOID,NULL);
default_count = 1;
}
else
goto SwitchParseErrorAndMessage;
theExp = theExp->nextArg;
if (ExpressionData(theEnv)->svContexts->rtn == TRUE)
ExpressionData(theEnv)->ReturnContext = TRUE;
if (ExpressionData(theEnv)->svContexts->brk == TRUE)
ExpressionData(theEnv)->BreakContext = TRUE;
IncrementIndentDepth(theEnv,3);
PPCRAndIndent(theEnv);
theExp->nextArg = GroupActions(theEnv,infile,&theToken,TRUE,NULL,FALSE);
DecrementIndentDepth(theEnv,3);
ExpressionData(theEnv)->ReturnContext = FALSE;
ExpressionData(theEnv)->BreakContext = FALSE;
if (theExp->nextArg == NULL)
goto SwitchParseError;
theExp = theExp->nextArg;
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,theToken.printForm);
GetToken(theEnv,infile,&theToken);
}
DecrementIndentDepth(theEnv,3);
return(top);
SwitchParseErrorAndMessage:
SyntaxErrorMessage(theEnv,"switch function");
SwitchParseError:
ReturnExpression(theEnv,top);
DecrementIndentDepth(theEnv,3);
return(NULL);
}
globle struct lhsParseNode *SequenceRestrictionParse(
void *theEnv,
char *readSource,
struct token *theToken)
{
struct lhsParseNode *topNode;
struct lhsParseNode *nextField;
/*================================================*/
/* Create the pattern node for the relation name. */
/*================================================*/
topNode = GetLHSParseNode(theEnv);
topNode->type = SF_WILDCARD;
topNode->negated = FALSE;
topNode->exists = FALSE;
topNode->index = -1;
topNode->slotNumber = 1;
topNode->bottom = GetLHSParseNode(theEnv);
topNode->bottom->type = SYMBOL;
topNode->bottom->negated = FALSE;
topNode->bottom->exists = FALSE;
topNode->bottom->value = (void *) theToken->value;
/*======================================================*/
/* Connective constraints cannot be used in conjunction */
/* with the first field of a pattern. */
/*======================================================*/
SavePPBuffer(theEnv," ");
GetToken(theEnv,readSource,theToken);
if ((theToken->type == OR_CONSTRAINT) || (theToken->type == AND_CONSTRAINT))
{
ReturnLHSParseNodes(theEnv,topNode);
SyntaxErrorMessage(theEnv,"the first field of a pattern");
return(NULL);
}
/*============================================================*/
/* Treat the remaining constraints of an ordered fact pattern */
/* as if they were contained in a multifield slot. */
/*============================================================*/
nextField = RestrictionParse(theEnv,readSource,theToken,TRUE,NULL,1,NULL,1);
if (nextField == NULL)
{
ReturnLHSParseNodes(theEnv,topNode);
return(NULL);
}
topNode->right = nextField;
/*================================================*/
/* The pattern must end with a right parenthesis. */
/*================================================*/
if (theToken->type != RPAREN)
{
PPBackup(theEnv);
SavePPBuffer(theEnv," ");
SavePPBuffer(theEnv,theToken->printForm);
SyntaxErrorMessage(theEnv,"fact patterns");
ReturnLHSParseNodes(theEnv,topNode);
return(NULL);
}
/*====================================*/
/* Fix the pretty print output if the */
/* slot contained no restrictions. */
/*====================================*/
if (nextField->bottom == NULL)
{
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,")");
}
/*===================================*/
/* If no errors, return the pattern. */
/*===================================*/
return(topNode);
}
static intBool ParseAllowedValuesAttribute(
void *theEnv,
char *readSource,
char *constraintName,
CONSTRAINT_RECORD *constraints,
CONSTRAINT_PARSE_RECORD *parsedConstraints)
{
struct token inputToken;
int expectedType, restrictionType, error = FALSE;
struct expr *newValue, *lastValue;
int constantParsed = FALSE, variableParsed = FALSE;
char *tempPtr = NULL;
/*======================================================*/
/* The allowed-values attribute is not allowed if other */
/* allowed-... attributes have already been parsed. */
/*======================================================*/
if ((strcmp(constraintName,"allowed-values") == 0) &&
((parsedConstraints->allowedSymbols) ||
(parsedConstraints->allowedStrings) ||
(parsedConstraints->allowedLexemes) ||
(parsedConstraints->allowedIntegers) ||
(parsedConstraints->allowedFloats) ||
(parsedConstraints->allowedNumbers) ||
(parsedConstraints->allowedInstanceNames)))
{
if (parsedConstraints->allowedSymbols) tempPtr = "allowed-symbols";
else if (parsedConstraints->allowedStrings) tempPtr = "allowed-strings";
else if (parsedConstraints->allowedLexemes) tempPtr = "allowed-lexemes";
else if (parsedConstraints->allowedIntegers) tempPtr = "allowed-integers";
else if (parsedConstraints->allowedFloats) tempPtr = "allowed-floats";
else if (parsedConstraints->allowedNumbers) tempPtr = "allowed-numbers";
else if (parsedConstraints->allowedInstanceNames) tempPtr = "allowed-instance-names";
NoConjunctiveUseError(theEnv,"allowed-values",tempPtr);
return(FALSE);
}
/*=======================================================*/
/* The allowed-values/numbers/integers/floats attributes */
/* are not allowed with the range attribute. */
/*=======================================================*/
if (((strcmp(constraintName,"allowed-values") == 0) ||
(strcmp(constraintName,"allowed-numbers") == 0) ||
(strcmp(constraintName,"allowed-integers") == 0) ||
(strcmp(constraintName,"allowed-floats") == 0)) &&
(parsedConstraints->range))
{
NoConjunctiveUseError(theEnv,constraintName,"range");
return(FALSE);
}
/*===================================================*/
/* The allowed-... attributes are not allowed if the */
/* allowed-values attribute has already been parsed. */
/*===================================================*/
if ((strcmp(constraintName,"allowed-values") != 0) &&
(parsedConstraints->allowedValues))
{
NoConjunctiveUseError(theEnv,constraintName,"allowed-values");
return(FALSE);
}
/*==================================================*/
/* The allowed-numbers attribute is not allowed if */
/* the allowed-integers or allowed-floats attribute */
/* has already been parsed. */
/*==================================================*/
if ((strcmp(constraintName,"allowed-numbers") == 0) &&
((parsedConstraints->allowedFloats) || (parsedConstraints->allowedIntegers)))
{
if (parsedConstraints->allowedFloats) tempPtr = "allowed-floats";
else tempPtr = "allowed-integers";
NoConjunctiveUseError(theEnv,"allowed-numbers",tempPtr);
return(FALSE);
}
/*============================================================*/
/* The allowed-integers/floats attributes are not allowed if */
/* the allowed-numbers attribute has already been parsed. */
/*============================================================*/
if (((strcmp(constraintName,"allowed-integers") == 0) ||
(strcmp(constraintName,"allowed-floats") == 0)) &&
(parsedConstraints->allowedNumbers))
{
NoConjunctiveUseError(theEnv,constraintName,"allowed-number");
return(FALSE);
}
/*==================================================*/
/* The allowed-lexemes attribute is not allowed if */
/* the allowed-symbols or allowed-strings attribute */
/* has already been parsed. */
/*==================================================*/
if ((strcmp(constraintName,"allowed-lexemes") == 0) &&
((parsedConstraints->allowedSymbols) || (parsedConstraints->allowedStrings)))
{
if (parsedConstraints->allowedSymbols) tempPtr = "allowed-symbols";
else tempPtr = "allowed-strings";
NoConjunctiveUseError(theEnv,"allowed-lexemes",tempPtr);
return(FALSE);
}
/*===========================================================*/
/* The allowed-symbols/strings attributes are not allowed if */
/* the allowed-lexemes attribute has already been parsed. */
/*===========================================================*/
if (((strcmp(constraintName,"allowed-symbols") == 0) ||
(strcmp(constraintName,"allowed-strings") == 0)) &&
(parsedConstraints->allowedLexemes))
{
NoConjunctiveUseError(theEnv,constraintName,"allowed-lexemes");
return(FALSE);
}
/*========================*/
/* Get the expected type. */
/*========================*/
restrictionType = GetConstraintTypeFromAllowedName(constraintName);
SetRestrictionFlag(restrictionType,constraints,TRUE);
if (strcmp(constraintName,"allowed-classes") == 0)
{ expectedType = SYMBOL; }
else
{ expectedType = restrictionType; }
/*=================================================*/
/* Get the last value in the restriction list (the */
/* allowed values will be appended there). */
/*=================================================*/
if (strcmp(constraintName,"allowed-classes") == 0)
{ lastValue = constraints->classList; }
else
{ lastValue = constraints->restrictionList; }
if (lastValue != NULL)
{ while (lastValue->nextArg != NULL) lastValue = lastValue->nextArg; }
/*==================================================*/
/* Read the allowed values and add them to the list */
/* until a right parenthesis is encountered. */
/*==================================================*/
SavePPBuffer(theEnv," ");
GetToken(theEnv,readSource,&inputToken);
while (inputToken.type != RPAREN)
{
SavePPBuffer(theEnv," ");
/*=============================================*/
/* Determine the type of the token just parsed */
/* and if it is an appropriate value. */
/*=============================================*/
switch(inputToken.type)
{
case INTEGER:
if ((expectedType != UNKNOWN_VALUE) &&
(expectedType != INTEGER) &&
(expectedType != INTEGER_OR_FLOAT)) error = TRUE;
constantParsed = TRUE;
break;
case FLOAT:
if ((expectedType != UNKNOWN_VALUE) &&
(expectedType != FLOAT) &&
(expectedType != INTEGER_OR_FLOAT)) error = TRUE;
constantParsed = TRUE;
break;
case STRING:
if ((expectedType != UNKNOWN_VALUE) &&
(expectedType != STRING) &&
(expectedType != SYMBOL_OR_STRING)) error = TRUE;
constantParsed = TRUE;
break;
case SYMBOL:
if ((expectedType != UNKNOWN_VALUE) &&
(expectedType != SYMBOL) &&
(expectedType != SYMBOL_OR_STRING)) error = TRUE;
constantParsed = TRUE;
break;
#if OBJECT_SYSTEM
case INSTANCE_NAME:
if ((expectedType != UNKNOWN_VALUE) &&
(expectedType != INSTANCE_NAME)) error = TRUE;
constantParsed = TRUE;
break;
#endif
case SF_VARIABLE:
if (strcmp(inputToken.printForm,"?VARIABLE") == 0)
{ variableParsed = TRUE; }
else
{
char tempBuffer[120];
gensprintf(tempBuffer,"%s attribute",constraintName);
SyntaxErrorMessage(theEnv,tempBuffer);
return(FALSE);
}
break;
default:
{
char tempBuffer[120];
gensprintf(tempBuffer,"%s attribute",constraintName);
SyntaxErrorMessage(theEnv,tempBuffer);
}
return(FALSE);
}
/*=====================================*/
/* Signal an error if an inappropriate */
/* value was found. */
/*=====================================*/
if (error)
{
PrintErrorID(theEnv,"CSTRNPSR",4,TRUE);
EnvPrintRouter(theEnv,WERROR,"Value does not match the expected type for the ");
EnvPrintRouter(theEnv,WERROR,constraintName);
EnvPrintRouter(theEnv,WERROR," attribute\n");
return(FALSE);
}
/*======================================*/
/* The ?VARIABLE argument can't be used */
/* in conjunction with constants. */
/*======================================*/
if (constantParsed && variableParsed)
{
char tempBuffer[120];
gensprintf(tempBuffer,"%s attribute",constraintName);
SyntaxErrorMessage(theEnv,tempBuffer);
return(FALSE);
}
/*===========================================*/
/* Add the constant to the restriction list. */
/*===========================================*/
newValue = GenConstant(theEnv,inputToken.type,inputToken.value);
if (lastValue == NULL)
{
if (strcmp(constraintName,"allowed-classes") == 0)
{ constraints->classList = newValue; }
else
{ constraints->restrictionList = newValue; }
}
else
{ lastValue->nextArg = newValue; }
lastValue = newValue;
/*=======================================*/
/* Begin parsing the next allowed value. */
/*=======================================*/
GetToken(theEnv,readSource,&inputToken);
}
/*======================================================*/
/* There must be at least one value for this attribute. */
/*======================================================*/
if ((! constantParsed) && (! variableParsed))
{
char tempBuffer[120];
gensprintf(tempBuffer,"%s attribute",constraintName);
SyntaxErrorMessage(theEnv,tempBuffer);
return(FALSE);
}
/*======================================*/
/* If ?VARIABLE was parsed, then remove */
/* the restrictions for the type being */
/* restricted. */
/*======================================*/
if (variableParsed)
{
switch(restrictionType)
{
case UNKNOWN_VALUE:
constraints->anyRestriction = FALSE;
break;
case SYMBOL:
constraints->symbolRestriction = FALSE;
break;
case STRING:
constraints->stringRestriction = FALSE;
break;
case INTEGER:
constraints->integerRestriction = FALSE;
break;
case FLOAT:
constraints->floatRestriction = FALSE;
break;
case INTEGER_OR_FLOAT:
constraints->floatRestriction = FALSE;
constraints->integerRestriction = FALSE;
break;
case SYMBOL_OR_STRING:
constraints->symbolRestriction = FALSE;
constraints->stringRestriction = FALSE;
break;
case INSTANCE_NAME:
constraints->instanceNameRestriction = FALSE;
break;
case INSTANCE_OR_INSTANCE_NAME:
constraints->classRestriction = FALSE;
break;
}
}
/*=====================================*/
/* Fix up pretty print representation. */
/*=====================================*/
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,")");
/*=======================================*/
/* Return TRUE to indicate the attribute */
/* was successfully parsed. */
/*=======================================*/
return(TRUE);
}
globle struct expr *GetRHSPattern(
char *readSource,
struct token *tempToken,
int *error,
int constantsOnly,
int readFirstParen,
int checkFirstParen,
int endType)
{
struct expr *lastOne = NULL;
struct expr *nextOne, *firstOne, *argHead = NULL;
int printError, count;
struct deftemplate *theDeftemplate;
struct symbolHashNode *templateName;
/*=================================================*/
/* Get the opening parenthesis of the RHS pattern. */
/*=================================================*/
*error = FALSE;
if (readFirstParen) GetToken(readSource,tempToken);
if (checkFirstParen)
{
if (tempToken->type == endType) return(NULL);
if (tempToken->type != LPAREN)
{
SyntaxErrorMessage("RHS patterns");
*error = TRUE;
return(NULL);
}
}
/*======================================================*/
/* The first field of an asserted fact must be a symbol */
/* (but not = or : which have special significance). */
/*======================================================*/
GetToken(readSource,tempToken);
if (tempToken->type != SYMBOL)
{
SyntaxErrorMessage("first field of a RHS pattern");
*error = TRUE;
return(NULL);
}
else if ((strcmp(ValueToString(tempToken->value),"=") == 0) ||
(strcmp(ValueToString(tempToken->value),":") == 0))
{
SyntaxErrorMessage("first field of a RHS pattern");
*error = TRUE;
return(NULL);
}
/*=========================================================*/
/* Check to see if the relation name is a reserved symbol. */
/*=========================================================*/
templateName = (struct symbolHashNode *) tempToken->value;
if (ReservedPatternSymbol(ValueToString(templateName),NULL))
{
ReservedPatternSymbolErrorMsg(ValueToString(templateName),"a relation name");
*error = TRUE;
return(NULL);
}
/*============================================================*/
/* A module separator in the name is illegal in this context. */
/*============================================================*/
if (FindModuleSeparator(ValueToString(templateName)))
{
IllegalModuleSpecifierMessage();
*error = TRUE;
return(NULL);
}
/*=============================================================*/
/* Determine if there is an associated deftemplate. If so, let */
/* the deftemplate parsing functions parse the RHS pattern and */
/* then return the fact pattern that was parsed. */
/*=============================================================*/
theDeftemplate = (struct deftemplate *)
FindImportedConstruct("deftemplate",NULL,ValueToString(templateName),
&count,TRUE,NULL);
if (count > 1)
{
AmbiguousReferenceErrorMessage("deftemplate",ValueToString(templateName));
*error = TRUE;
return(NULL);
}
/*======================================================*/
/* If no deftemplate exists with the specified relation */
/* name, then create an implied deftemplate. */
/*======================================================*/
if (theDeftemplate == NULL)
#if (! BLOAD_ONLY) && (! RUN_TIME)
{
#if BLOAD || BLOAD_AND_BSAVE
if ((Bloaded()) && (! CheckSyntaxMode))
{
NoSuchTemplateError(ValueToString(templateName));
*error = TRUE;
return(NULL);
}
#endif
#if DEFMODULE_CONSTRUCT
if (FindImportExportConflict("deftemplate",((struct defmodule *) GetCurrentModule()),ValueToString(templateName)))
{
ImportExportConflictMessage("implied deftemplate",ValueToString(templateName),NULL,NULL);
*error = TRUE;
return(NULL);
}
#endif
if (! CheckSyntaxMode)
{ theDeftemplate = CreateImpliedDeftemplate((SYMBOL_HN *) templateName,TRUE); }
}
#else
{
NoSuchTemplateError(ValueToString(templateName));
*error = TRUE;
return(NULL);
}
#endif
/*=========================================*/
/* If an explicit deftemplate exists, then */
/* parse the fact as a deftemplate fact. */
/*=========================================*/
if ((theDeftemplate != NULL) && (theDeftemplate->implied == FALSE))
{
firstOne = GenConstant(DEFTEMPLATE_PTR,theDeftemplate);
firstOne->nextArg = ParseAssertTemplate(readSource,tempToken,
error,endType,
constantsOnly,theDeftemplate);
if (*error)
{
ReturnExpression(firstOne);
firstOne = NULL;
}
return(firstOne);
}
/*========================================*/
/* Parse the fact as an ordered RHS fact. */
/*========================================*/
firstOne = GenConstant(DEFTEMPLATE_PTR,theDeftemplate);
#if (! RUN_TIME) && (! BLOAD_ONLY)
SavePPBuffer(" ");
#endif
while ((nextOne = GetAssertArgument(readSource,tempToken,
error,endType,constantsOnly,&printError)) != NULL)
{
if (argHead == NULL) argHead = nextOne;
else lastOne->nextArg = nextOne;
lastOne = nextOne;
#if (! RUN_TIME) && (! BLOAD_ONLY)
SavePPBuffer(" ");
#endif
}
/*===========================================================*/
/* If an error occurred, set the error flag and return NULL. */
/*===========================================================*/
if (*error)
{
if (printError) SyntaxErrorMessage("RHS patterns");
ReturnExpression(firstOne);
ReturnExpression(argHead);
return(NULL);
}
/*=====================================*/
/* Fix the pretty print representation */
/* of the RHS ordered fact. */
/*=====================================*/
#if (! RUN_TIME) && (! BLOAD_ONLY)
PPBackup();
PPBackup();
SavePPBuffer(tempToken->printForm);
#endif
/*==========================================================*/
/* Ordered fact assertions are processed by stuffing all of */
/* the fact's proposition (except the relation name) into a */
/* single multifield slot. */
/*==========================================================*/
firstOne->nextArg = GenConstant(FACT_STORE_MULTIFIELD,AddBitMap("\0",1));
firstOne->nextArg->argList = argHead;
/*==============================*/
/* Return the RHS ordered fact. */
/*==============================*/
return(firstOne);
}
static int ParsePortSpecifications(
void *theEnv,
char *readSource,
struct token *theToken,
struct defmodule *theDefmodule)
{
int error;
/*=============================*/
/* The import and export lists */
/* are initially empty. */
/*=============================*/
theDefmodule->importList = NULL;
theDefmodule->exportList = NULL;
/*==========================================*/
/* Parse import/export specifications until */
/* a right parenthesis is encountered. */
/*==========================================*/
while (theToken->type != RPAREN)
{
/*========================================*/
/* Look for the opening left parenthesis. */
/*========================================*/
if (theToken->type != LPAREN)
{
SyntaxErrorMessage(theEnv,"defmodule");
return(TRUE);
}
/*====================================*/
/* Look for the import/export keyword */
/* and call the appropriate functions */
/* for parsing the specification. */
/*====================================*/
GetToken(theEnv,readSource,theToken);
if (theToken->type != SYMBOL)
{
SyntaxErrorMessage(theEnv,"defmodule");
return(TRUE);
}
if (strcmp(ValueToString(theToken->value),"import") == 0)
{
error = ParseImportSpec(theEnv,readSource,theToken,theDefmodule);
}
else if (strcmp(ValueToString(theToken->value),"export") == 0)
{
error = ParseExportSpec(theEnv,readSource,theToken,theDefmodule,NULL);
}
else
{
SyntaxErrorMessage(theEnv,"defmodule");
return(TRUE);
}
if (error) return(TRUE);
/*============================================*/
/* Begin parsing the next port specification. */
/*============================================*/
PPCRAndIndent(theEnv);
GetToken(theEnv,readSource,theToken);
if (theToken->type == RPAREN)
{
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,")");
}
}
/*===================================*/
/* Return FALSE to indicate no error */
/* occurred while parsing the */
/* import/export specifications. */
/*===================================*/
return(FALSE);
}
struct lhsParseNode *RestrictionParse(
char *readSource,
struct token *theToken,
int multifieldSlot,
struct symbolHashNode *theSlot,
int slotNumber,
CONSTRAINT_RECORD *theConstraints,
int position)
{
struct lhsParseNode *topNode = NULL, *lastNode = NULL, *nextNode;
int numberOfSingleFields = 0;
int numberOfMultifields = 0;
int 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();
nextNode->type = theToken->type;
nextNode->negated = FALSE;
GetToken(readSource,theToken);
}
else
{
nextNode = ConjuctiveRestrictionParse(readSource,theToken,&error);
if (nextNode == NULL)
{
ReturnLHSParseNodes(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();
SavePPBuffer(" ");
SavePPBuffer(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(); }
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("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(); }
else
{ continue; }
}
else
{ nextNode->constraints = CopyConstraintRecord(theConstraints); }
/*==========================================*/
/* Remove the min and max field constraints */
/* for the entire slot from the constraint */
/* record for this single constraint. */
/*==========================================*/
ReturnExpression(nextNode->constraints->minFields);
ReturnExpression(nextNode->constraints->maxFields);
nextNode->constraints->minFields = GenConstant(SYMBOL,NegativeInfinity);
nextNode->constraints->maxFields = GenConstant(SYMBOL,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();
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 != PositiveInfinity)
{
ReturnExpression(tempConstraints->maxFields);
tempConstraints->maxFields = GenConstant(INTEGER,AddLong(ValueToLong(theConstraints->maxFields->value) - numberOfSingleFields));
}
if ((numberOfMultifields == 1) && (theConstraints->minFields->value != NegativeInfinity))
{
ReturnExpression(tempConstraints->minFields);
tempConstraints->minFields = GenConstant(INTEGER,AddLong(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();
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);
}
static struct lhsParseNode *GetSingleLHSSlot(
void *theEnv,
char *readSource,
struct token *tempToken,
struct templateSlot *slotPtr,
int *error,
short position)
{
struct lhsParseNode *nextSlot;
SYMBOL_HN *slotName;
/*================================================*/
/* Get the slot name and read in the first token. */
/*================================================*/
slotName = (SYMBOL_HN *) tempToken->value;
SavePPBuffer(theEnv,(char*)" ");
GetToken(theEnv,readSource,tempToken);
/*====================================*/
/* Get value for a single field slot. */
/*====================================*/
if (slotPtr->multislot == FALSE)
{
/*=======================*/
/* Get the single value. */
/*=======================*/
nextSlot = RestrictionParse(theEnv,readSource,tempToken,FALSE,
slotPtr->slotName,(short) (position - 1),
slotPtr->constraints,0);
if (nextSlot == NULL)
{
*error = TRUE;
return(NULL);
}
/*======================================*/
/* Multi field wildcards and variables */
/* not allowed in a single field slot. */
/*======================================*/
if ((nextSlot->type == MF_VARIABLE) ||
(nextSlot->type == MULTIFIELD))
{
SingleFieldSlotCardinalityError(theEnv,slotPtr->slotName->contents);
*error = TRUE;
ReturnLHSParseNodes(theEnv,nextSlot);
return(NULL);
}
}
/*===================================*/
/* Get values for a multifield slot. */
/*===================================*/
else
{
nextSlot = RestrictionParse(theEnv,readSource,tempToken,TRUE,slotName,(short) (position - 1),
slotPtr->constraints,1);
if (nextSlot == NULL)
{
*error = TRUE;
return(NULL);
}
}
/*========================================================*/
/* The slot definition must end with a right parenthesis. */
/*========================================================*/
if (tempToken->type != RPAREN)
{
PPBackup(theEnv);
SavePPBuffer(theEnv,(char*)" ");
SavePPBuffer(theEnv,tempToken->printForm);
SyntaxErrorMessage(theEnv,(char*)"deftemplate patterns");
*error = TRUE;
ReturnLHSParseNodes(theEnv,nextSlot);
return(NULL);
}
/*===============================================*/
/* Fix the pretty print output if the multifield */
/* slot contained no restrictions. */
/*===============================================*/
if ((nextSlot->bottom == NULL) && slotPtr->multislot)
{
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,(char*)")");
}
/*=================================*/
/* Add the slot values to the slot */
/* structure and return it. */
/*=================================*/
return(nextSlot);
}
static intBool ParseTypeAttribute(
void *theEnv,
char *readSource,
CONSTRAINT_RECORD *constraints)
{
int typeParsed = FALSE;
int variableParsed = FALSE;
int theType;
struct token inputToken;
/*======================================*/
/* Continue parsing types until a right */
/* parenthesis is encountered. */
/*======================================*/
SavePPBuffer(theEnv," ");
for (GetToken(theEnv,readSource,&inputToken);
inputToken.type != RPAREN;
GetToken(theEnv,readSource,&inputToken))
{
SavePPBuffer(theEnv," ");
/*==================================*/
/* If the token is a symbol then... */
/*==================================*/
if (inputToken.type == SYMBOL)
{
/*==============================================*/
/* ?VARIABLE can't be used with type constants. */
/*==============================================*/
if (variableParsed == TRUE)
{
SyntaxErrorMessage(theEnv,"type attribute");
return(FALSE);
}
/*========================================*/
/* Check for an appropriate type constant */
/* (e.g. SYMBOL, FLOAT, INTEGER, etc.). */
/*========================================*/
theType = GetConstraintTypeFromTypeName(ValueToString(inputToken.value));
if (theType < 0)
{
SyntaxErrorMessage(theEnv,"type attribute");
return(FALSE);
}
/*==================================================*/
/* Change the type restriction flags to reflect the */
/* type restriction. If the type restriction was */
/* already specified, then a error is generated. */
/*==================================================*/
if (SetConstraintType(theType,constraints))
{
SyntaxErrorMessage(theEnv,"type attribute");
return(FALSE);
}
constraints->anyAllowed = FALSE;
/*===========================================*/
/* Remember that a type constant was parsed. */
/*===========================================*/
typeParsed = TRUE;
}
/*==============================================*/
/* Otherwise if the token is a variable then... */
/*==============================================*/
else if (inputToken.type == SF_VARIABLE)
{
/*========================================*/
/* The only variable allowd is ?VARIABLE. */
/*========================================*/
if (strcmp(inputToken.printForm,"?VARIABLE") != 0)
{
SyntaxErrorMessage(theEnv,"type attribute");
return(FALSE);
}
/*===================================*/
/* ?VARIABLE can't be used more than */
/* once or with type constants. */
/*===================================*/
if (typeParsed || variableParsed)
{
SyntaxErrorMessage(theEnv,"type attribute");
return(FALSE);
}
/*======================================*/
/* Remember that a variable was parsed. */
/*======================================*/
variableParsed = TRUE;
}
/*====================================*/
/* Otherwise this is an invalid value */
/* for the type attribute. */
/*====================================*/
else
{
SyntaxErrorMessage(theEnv,"type attribute");
return(FALSE);
}
}
/*=====================================*/
/* Fix up pretty print representation. */
/*=====================================*/
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,")");
/*=======================================*/
/* The type attribute must have a value. */
/*=======================================*/
if ((! typeParsed) && (! variableParsed))
{
SyntaxErrorMessage(theEnv,"type attribute");
return(FALSE);
}
/*===========================================*/
/* Return TRUE indicating the type attibuted */
/* was successfully parsed. */
/*===========================================*/
return(TRUE);
}
static struct expr *WhileParse(
void *theEnv,
struct expr *parse,
char *infile)
{
struct token theToken;
int read_first_paren;
/*===============================*/
/* Process the while expression. */
/*===============================*/
SavePPBuffer(theEnv," ");
parse->argList = ParseAtomOrExpression(theEnv,infile,NULL);
if (parse->argList == NULL)
{
ReturnExpression(theEnv,parse);
return(NULL);
}
/*====================================*/
/* Process the do keyword if present. */
/*====================================*/
GetToken(theEnv,infile,&theToken);
if ((theToken.type == SYMBOL) && (strcmp(ValueToString(theToken.value),"do") == 0))
{
read_first_paren = TRUE;
PPBackup(theEnv);
SavePPBuffer(theEnv," ");
SavePPBuffer(theEnv,theToken.printForm);
IncrementIndentDepth(theEnv,3);
PPCRAndIndent(theEnv);
}
else if (theToken.type == LPAREN)
{
read_first_paren = FALSE;
PPBackup(theEnv);
IncrementIndentDepth(theEnv,3);
PPCRAndIndent(theEnv);
SavePPBuffer(theEnv,theToken.printForm);
}
else
{
SyntaxErrorMessage(theEnv,"while function");
ReturnExpression(theEnv,parse);
return(NULL);
}
/*============================*/
/* Process the while actions. */
/*============================*/
if (ExpressionData(theEnv)->svContexts->rtn == TRUE)
ExpressionData(theEnv)->ReturnContext = TRUE;
ExpressionData(theEnv)->BreakContext = TRUE;
parse->argList->nextArg = GroupActions(theEnv,infile,&theToken,read_first_paren,NULL,FALSE);
if (parse->argList->nextArg == NULL)
{
ReturnExpression(theEnv,parse);
return(NULL);
}
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,theToken.printForm);
/*=======================================================*/
/* Check for the closing right parenthesis of the while. */
/*=======================================================*/
if (theToken.type != RPAREN)
{
SyntaxErrorMessage(theEnv,"while function");
ReturnExpression(theEnv,parse);
return(NULL);
}
DecrementIndentDepth(theEnv,3);
return(parse);
}
static int ParseExportSpec(
void *theEnv,
char *readSource,
struct token *theToken,
struct defmodule *newModule,
struct defmodule *importModule)
{
struct portItem *newPort;
SYMBOL_HN *theConstruct, *moduleName;
struct portConstructItem *thePortConstruct;
char *errorMessage;
/*===========================================*/
/* Set up some variables for error messages. */
/*===========================================*/
if (importModule != NULL)
{
errorMessage = "defmodule import specification";
moduleName = importModule->name;
}
else
{
errorMessage = "defmodule export specification";
moduleName = NULL;
}
/*=============================================*/
/* Handle the special variables ?ALL and ?NONE */
/* in the import/export specification. */
/*=============================================*/
SavePPBuffer(theEnv," ");
GetToken(theEnv,readSource,theToken);
if (theToken->type == SF_VARIABLE)
{
/*==============================*/
/* Check to see if the variable */
/* is either ?ALL or ?NONE. */
/*==============================*/
if (strcmp(ValueToString(theToken->value),"ALL") == 0)
{
newPort = (struct portItem *) get_struct(theEnv,portItem);
newPort->moduleName = moduleName;
newPort->constructType = NULL;
newPort->constructName = NULL;
newPort->next = NULL;
}
else if (strcmp(ValueToString(theToken->value),"NONE") == 0)
{ newPort = NULL; }
else
{
SyntaxErrorMessage(theEnv,errorMessage);
return(TRUE);
}
/*=======================================================*/
/* The export/import specification must end with a right */
/* parenthesis after ?ALL or ?NONE at this point. */
/*=======================================================*/
GetToken(theEnv,readSource,theToken);
if (theToken->type != RPAREN)
{
if (newPort != NULL) rtn_struct(theEnv,portItem,newPort);
PPBackup(theEnv);
SavePPBuffer(theEnv," ");
SavePPBuffer(theEnv,theToken->printForm);
SyntaxErrorMessage(theEnv,errorMessage);
return(TRUE);
}
/*=====================================*/
/* Add the new specification to either */
/* the import or export list. */
/*=====================================*/
if (newPort != NULL)
{
if (importModule != NULL)
{
newPort->next = newModule->importList;
newModule->importList = newPort;
}
else
{
newPort->next = newModule->exportList;
newModule->exportList = newPort;
}
}
/*============================================*/
/* Return FALSE to indicate the import/export */
/* specification was successfully parsed. */
/*============================================*/
return(FALSE);
}
/*========================================================*/
/* If the ?ALL and ?NONE keywords were not used, then the */
/* token must be the name of an importable construct. */
/*========================================================*/
if (theToken->type != SYMBOL)
{
SyntaxErrorMessage(theEnv,errorMessage);
return(TRUE);
}
theConstruct = (SYMBOL_HN *) theToken->value;
if ((thePortConstruct = ValidPortConstructItem(theEnv,ValueToString(theConstruct))) == NULL)
{
SyntaxErrorMessage(theEnv,errorMessage);
return(TRUE);
}
/*=============================================================*/
/* If the next token is the special variable ?ALL, then all */
/* constructs of the specified type are imported/exported. If */
/* the next token is the special variable ?NONE, then no */
/* constructs of the specified type will be imported/exported. */
/*=============================================================*/
SavePPBuffer(theEnv," ");
GetToken(theEnv,readSource,theToken);
if (theToken->type == SF_VARIABLE)
{
/*==============================*/
/* Check to see if the variable */
/* is either ?ALL or ?NONE. */
/*==============================*/
if (strcmp(ValueToString(theToken->value),"ALL") == 0)
{
newPort = (struct portItem *) get_struct(theEnv,portItem);
newPort->moduleName = moduleName;
newPort->constructType = theConstruct;
newPort->constructName = NULL;
newPort->next = NULL;
}
else if (strcmp(ValueToString(theToken->value),"NONE") == 0)
{ newPort = NULL; }
else
{
SyntaxErrorMessage(theEnv,errorMessage);
return(TRUE);
}
/*=======================================================*/
/* The export/import specification must end with a right */
/* parenthesis after ?ALL or ?NONE at this point. */
/*=======================================================*/
GetToken(theEnv,readSource,theToken);
if (theToken->type != RPAREN)
{
if (newPort != NULL) rtn_struct(theEnv,portItem,newPort);
PPBackup(theEnv);
SavePPBuffer(theEnv," ");
SavePPBuffer(theEnv,theToken->printForm);
SyntaxErrorMessage(theEnv,errorMessage);
return(TRUE);
}
/*=====================================*/
/* Add the new specification to either */
/* the import or export list. */
/*=====================================*/
if (newPort != NULL)
{
if (importModule != NULL)
{
newPort->next = newModule->importList;
newModule->importList = newPort;
}
else
{
newPort->next = newModule->exportList;
newModule->exportList = newPort;
}
}
/*============================================*/
/* Return FALSE to indicate the import/export */
/* specification was successfully parsed. */
/*============================================*/
return(FALSE);
}
/*============================================*/
/* There must be at least one named construct */
/* in the import/export list at this point. */
/*============================================*/
if (theToken->type == RPAREN)
{
SyntaxErrorMessage(theEnv,errorMessage);
return(TRUE);
}
/*=====================================*/
/* Read in the list of imported items. */
/*=====================================*/
while (theToken->type != RPAREN)
{
if (theToken->type != thePortConstruct->typeExpected)
{
SyntaxErrorMessage(theEnv,errorMessage);
return(TRUE);
}
/*========================================*/
/* Create the data structure to represent */
/* the import/export specification for */
/* the named construct. */
/*========================================*/
newPort = (struct portItem *) get_struct(theEnv,portItem);
newPort->moduleName = moduleName;
newPort->constructType = theConstruct;
newPort->constructName = (SYMBOL_HN *) theToken->value;
/*=====================================*/
/* Add the new specification to either */
/* the import or export list. */
/*=====================================*/
if (importModule != NULL)
{
newPort->next = newModule->importList;
newModule->importList = newPort;
}
else
{
newPort->next = newModule->exportList;
newModule->exportList = newPort;
}
/*===================================*/
/* Move on to the next import/export */
/* specification. */
/*===================================*/
SavePPBuffer(theEnv," ");
GetToken(theEnv,readSource,theToken);
}
/*=============================*/
/* Fix up pretty print buffer. */
/*=============================*/
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,")");
/*============================================*/
/* Return FALSE to indicate the import/export */
/* specification was successfully parsed. */
/*============================================*/
return(FALSE);
}
static struct expr *LoopForCountParse(
void *theEnv,
struct expr *parse,
char *infile)
{
struct token theToken;
SYMBOL_HN *loopVar = NULL;
EXPRESSION *tmpexp;
int read_first_paren;
struct BindInfo *oldBindList,*newBindList,*prev;
/*======================================*/
/* Process the loop counter expression. */
/*======================================*/
SavePPBuffer(theEnv," ");
GetToken(theEnv,infile,&theToken);
/* ==========================================
Simple form: loop-for-count <end> [do] ...
========================================== */
if (theToken.type != LPAREN)
{
parse->argList = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,1L));
parse->argList->nextArg = ParseAtomOrExpression(theEnv,infile,&theToken);
if (parse->argList->nextArg == NULL)
{
ReturnExpression(theEnv,parse);
return(NULL);
}
}
else
{
GetToken(theEnv,infile,&theToken);
if (theToken.type != SF_VARIABLE)
{
if (theToken.type != SYMBOL)
goto LoopForCountParseError;
parse->argList = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,1L));
parse->argList->nextArg = Function2Parse(theEnv,infile,ValueToString(theToken.value));
if (parse->argList->nextArg == NULL)
{
ReturnExpression(theEnv,parse);
return(NULL);
}
}
/* =============================================================
Complex form: loop-for-count (<var> [<start>] <end>) [do] ...
============================================================= */
else
{
loopVar = (SYMBOL_HN *) theToken.value;
SavePPBuffer(theEnv," ");
parse->argList = ParseAtomOrExpression(theEnv,infile,NULL);
if (parse->argList == NULL)
{
ReturnExpression(theEnv,parse);
return(NULL);
}
if (CheckArgumentAgainstRestriction(theEnv,parse->argList,(int) 'i'))
goto LoopForCountParseError;
SavePPBuffer(theEnv," ");
GetToken(theEnv,infile,&theToken);
if (theToken.type == RPAREN)
{
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,theToken.printForm);
tmpexp = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,1L));
tmpexp->nextArg = parse->argList;
parse->argList = tmpexp;
}
else
{
parse->argList->nextArg = ParseAtomOrExpression(theEnv,infile,&theToken);
if (parse->argList->nextArg == NULL)
{
ReturnExpression(theEnv,parse);
return(NULL);
}
GetToken(theEnv,infile,&theToken);
if (theToken.type != RPAREN)
goto LoopForCountParseError;
}
SavePPBuffer(theEnv," ");
}
}
if (CheckArgumentAgainstRestriction(theEnv,parse->argList->nextArg,(int) 'i'))
goto LoopForCountParseError;
/*====================================*/
/* Process the do keyword if present. */
/*====================================*/
GetToken(theEnv,infile,&theToken);
if ((theToken.type == SYMBOL) && (strcmp(ValueToString(theToken.value),"do") == 0))
{
read_first_paren = TRUE;
PPBackup(theEnv);
SavePPBuffer(theEnv," ");
SavePPBuffer(theEnv,theToken.printForm);
IncrementIndentDepth(theEnv,3);
PPCRAndIndent(theEnv);
}
else if (theToken.type == LPAREN)
{
read_first_paren = FALSE;
PPBackup(theEnv);
IncrementIndentDepth(theEnv,3);
PPCRAndIndent(theEnv);
SavePPBuffer(theEnv,theToken.printForm);
}
else
goto LoopForCountParseError;
/*=====================================*/
/* Process the loop-for-count actions. */
/*=====================================*/
if (ExpressionData(theEnv)->svContexts->rtn == TRUE)
ExpressionData(theEnv)->ReturnContext = TRUE;
ExpressionData(theEnv)->BreakContext = TRUE;
oldBindList = GetParsedBindNames(theEnv);
SetParsedBindNames(theEnv,NULL);
parse->argList->nextArg->nextArg =
GroupActions(theEnv,infile,&theToken,read_first_paren,NULL,FALSE);
if (parse->argList->nextArg->nextArg == NULL)
{
SetParsedBindNames(theEnv,oldBindList);
ReturnExpression(theEnv,parse);
return(NULL);
}
newBindList = GetParsedBindNames(theEnv);
prev = NULL;
while (newBindList != NULL)
{
if ((loopVar == NULL) ? FALSE :
(strcmp(ValueToString(newBindList->name),ValueToString(loopVar)) == 0))
{
ClearParsedBindNames(theEnv);
SetParsedBindNames(theEnv,oldBindList);
PrintErrorID(theEnv,"PRCDRPSR",1,TRUE);
EnvPrintRouter(theEnv,WERROR,"Cannot rebind loop variable in function loop-for-count.\n");
ReturnExpression(theEnv,parse);
return(NULL);
}
prev = newBindList;
newBindList = newBindList->next;
}
if (prev == NULL)
SetParsedBindNames(theEnv,oldBindList);
else
prev->next = oldBindList;
if (loopVar != NULL)
ReplaceLoopCountVars(theEnv,loopVar,parse->argList->nextArg->nextArg,0);
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,theToken.printForm);
/*================================================================*/
/* Check for the closing right parenthesis of the loop-for-count. */
/*================================================================*/
if (theToken.type != RPAREN)
{
SyntaxErrorMessage(theEnv,"loop-for-count function");
ReturnExpression(theEnv,parse);
return(NULL);
}
DecrementIndentDepth(theEnv,3);
return(parse);
LoopForCountParseError:
SyntaxErrorMessage(theEnv,"loop-for-count function");
ReturnExpression(theEnv,parse);
return(NULL);
}
