/***********************************************************************
NAME : ParseQueryNoAction
DESCRIPTION : Parses the following functions :
(any-instancep)
(find-first-instance)
(find-all-instances)
INPUTS : 1) The address of the top node of the query function
2) The logical name of the input
RETURNS : The completed expression chain, or NULL on errors
SIDE EFFECTS : The expression chain is extended, or the "top" node
is deleted on errors
NOTES : H/L Syntax :
(<function> <query-block>)
<query-block> :== (<instance-var>+) <query-expression>
<instance-var> :== (<var-name> <class-name>+)
Parses into following form :
<query-function>
|
V
<query-expression> ->
<class-1a> -> <class-1b> -> (QDS) ->
<class-2a> -> <class-2b> -> (QDS) -> ...
***********************************************************************/
globle EXPRESSION *ParseQueryNoAction(
void *theEnv,
EXPRESSION *top,
char *readSource)
{
EXPRESSION *insQuerySetVars;
struct token queryInputToken;
insQuerySetVars = ParseQueryRestrictions(theEnv,top,readSource,&queryInputToken);
if (insQuerySetVars == NULL)
return(NULL);
IncrementIndentDepth(theEnv,3);
PPCRAndIndent(theEnv);
if (ParseQueryTestExpression(theEnv,top,readSource) == FALSE)
{
DecrementIndentDepth(theEnv,3);
ReturnExpression(theEnv,insQuerySetVars);
return(NULL);
}
DecrementIndentDepth(theEnv,3);
GetToken(theEnv,readSource,&queryInputToken);
if (GetType(queryInputToken) != RPAREN)
{
SyntaxErrorMessage(theEnv,"instance-set query function");
ReturnExpression(theEnv,top);
ReturnExpression(theEnv,insQuerySetVars);
return(NULL);
}
ReplaceInstanceVariables(theEnv,insQuerySetVars,top->argList,TRUE,0);
ReturnExpression(theEnv,insQuerySetVars);
return(top);
}
globle struct expr *Function0Parse(
void *theEnv,
char *logicalName)
{
struct token theToken;
struct expr *top;
/*=================================*/
/* All functions begin with a '('. */
/*=================================*/
GetToken(theEnv,logicalName,&theToken);
if (theToken.type != LPAREN)
{
SyntaxErrorMessage(theEnv,"function calls");
return(NULL);
}
/*=================================*/
/* Parse the rest of the function. */
/*=================================*/
top = Function1Parse(theEnv,logicalName);
return(top);
}
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);
}
/**********************************************************
NAME : DetermineQueryTemplates
DESCRIPTION : Builds a list of templates to be used in
fact queries - uses parse form.
INPUTS : 1) The parse template expression chain
2) The name of the function being executed
3) Caller's buffer for restriction count
(# of separate lists)
RETURNS : The query list, or NULL on errors
SIDE EFFECTS : Memory allocated for list
Busy count incremented for all templates
NOTES : Each restriction is linked by nxt pointer,
multiple templates in a restriction are
linked by the chain pointer.
Rcnt caller's buffer is set to reflect the
total number of chains
Assumes templateExp is not NULL and that each
restriction chain is terminated with
the QUERY_DELIMITER_SYMBOL "(QDS)"
**********************************************************/
static QUERY_TEMPLATE *DetermineQueryTemplates(
Environment *theEnv,
Expression *templateExp,
const char *func,
unsigned *rcnt)
{
QUERY_TEMPLATE *clist = NULL, *cnxt = NULL, *cchain = NULL, *tmp;
bool new_list = false;
UDFValue temp;
Deftemplate *theDeftemplate;
*rcnt = 0;
while (templateExp != NULL)
{
theDeftemplate = NULL;
if (templateExp->type == DEFTEMPLATE_PTR)
{ theDeftemplate = (Deftemplate *) templateExp->value; }
else if (EvaluateExpression(theEnv,templateExp,&temp))
{
DeleteQueryTemplates(theEnv,clist);
return NULL;
}
if ((theDeftemplate == NULL) &&
(temp.value == (void *) FactQueryData(theEnv)->QUERY_DELIMITER_SYMBOL))
{
new_list = true;
(*rcnt)++;
}
else if ((tmp = FormChain(theEnv,func,theDeftemplate,&temp)) != NULL)
{
if (clist == NULL)
{ clist = cnxt = cchain = tmp; }
else if (new_list == true)
{
new_list = false;
cnxt->nxt = tmp;
cnxt = cchain = tmp;
}
else
{ cchain->chain = tmp; }
while (cchain->chain != NULL)
{ cchain = cchain->chain; }
}
else
{
SyntaxErrorMessage(theEnv,"fact-set query class restrictions");
DeleteQueryTemplates(theEnv,clist);
SetEvaluationError(theEnv,true);
return NULL;
}
templateExp = templateExp->nextArg;
}
return clist;
}
globle struct lhsParseNode *DeftemplateLHSParse(
void *theEnv,
char *readSource,
struct deftemplate *theDeftemplate)
{
struct lhsParseNode *head, *firstSlot;
struct token theToken;
int error;
/*===============================================================*/
/* Make sure the deftemplate name is not connected to subfields. */
/*===============================================================*/
GetToken(theEnv,readSource,&theToken);
if ((theToken.type == OR_CONSTRAINT) || (theToken.type == AND_CONSTRAINT))
{
SyntaxErrorMessage(theEnv,(char*)"deftemplate patterns");
return(NULL);
}
/*===================================================*/
/* Create the pattern node for the deftemplate name. */
/*===================================================*/
head = GetLHSParseNode(theEnv);
head->type = SF_WILDCARD;
head->negated = FALSE;
head->exists = FALSE;
head->index = 0;
head->slotNumber = 1;
head->bottom = GetLHSParseNode(theEnv);
head->bottom->type = SYMBOL;
head->bottom->negated = FALSE;
head->bottom->exists = FALSE;
head->bottom->value = (void *) theDeftemplate->header.name;
/*==========================================*/
/* Get the other fields in the deftemplate. */
/*==========================================*/
error = FALSE;
firstSlot = GetLHSSlots(theEnv,readSource,&theToken,theDeftemplate,&error);
if (error)
{
ReturnLHSParseNodes(theEnv,firstSlot);
ReturnLHSParseNodes(theEnv,head);
return(NULL);
}
/*=========================*/
/* Return the LHS pattern. */
/*=========================*/
head->right = firstSlot;
return(head);
}
/*************************************************************
NAME : ParseQueryTestExpression
DESCRIPTION : Parses the test-expression for a query
INPUTS : 1) The top node of the query expression
2) The logical name of the input
RETURNS : TRUE if all OK, FALSE otherwise
SIDE EFFECTS : Entire query-expression deleted on errors
Nodes allocated for new expression
Test shoved in front of class-restrictions on
query argument list
NOTES : Expects top != NULL
*************************************************************/
static int ParseQueryTestExpression(
void *theEnv,
EXPRESSION *top,
const char *readSource)
{
EXPRESSION *qtest;
int error;
struct BindInfo *oldBindList;
error = FALSE;
oldBindList = GetParsedBindNames(theEnv);
SetParsedBindNames(theEnv,NULL);
qtest = ArgumentParse(theEnv,readSource,&error);
if (error == TRUE)
{
ClearParsedBindNames(theEnv);
SetParsedBindNames(theEnv,oldBindList);
ReturnExpression(theEnv,top);
return(FALSE);
}
if (qtest == NULL)
{
ClearParsedBindNames(theEnv);
SetParsedBindNames(theEnv,oldBindList);
SyntaxErrorMessage(theEnv,"fact-set query function");
ReturnExpression(theEnv,top);
return(FALSE);
}
qtest->nextArg = top->argList;
top->argList = qtest;
if (ParsedBindNamesEmpty(theEnv) == FALSE)
{
ClearParsedBindNames(theEnv);
SetParsedBindNames(theEnv,oldBindList);
PrintErrorID(theEnv,"FACTQPSR",2,FALSE);
EnvPrintRouter(theEnv,WERROR,"Binds are not allowed in fact-set query in function ");
EnvPrintRouter(theEnv,WERROR,ValueToString(ExpressionFunctionCallName(top)));
EnvPrintRouter(theEnv,WERROR,".\n");
ReturnExpression(theEnv,top);
return(FALSE);
}
SetParsedBindNames(theEnv,oldBindList);
return(TRUE);
}
static void ParseAutoFocus(
void *theEnv,
EXEC_STATUS,
char *readSource,
int *error)
{
struct token theToken;
/*========================================*/
/* The auto-focus value must be a symbol. */
/*========================================*/
SavePPBuffer(theEnv,execStatus," ");
GetToken(theEnv,execStatus,readSource,&theToken);
if (theToken.type != SYMBOL)
{
SyntaxErrorMessage(theEnv,execStatus,"auto-focus statement");
*error = TRUE;
return;
}
/*====================================================*/
/* The auto-focus value must be either TRUE or FALSE. */
/* If a valid value is parsed, then set the value of */
/* the global variable GlobalAutoFocus. */
/*====================================================*/
if (strcmp(ValueToString(theToken.value),"TRUE") == 0)
{ PatternData(theEnv,execStatus)->GlobalAutoFocus = TRUE; }
else if (strcmp(ValueToString(theToken.value),"FALSE") == 0)
{ PatternData(theEnv,execStatus)->GlobalAutoFocus = FALSE; }
else
{
SyntaxErrorMessage(theEnv,execStatus,"auto-focus statement");
*error = TRUE;
}
}
/**********************************************************
NAME : DetermineQueryClasses
DESCRIPTION : Builds a list of classes to be used in
instance queries - uses parse form.
INPUTS : 1) The parse class expression chain
2) The name of the function being executed
3) Caller's buffer for restriction count
(# of separate lists)
RETURNS : The query list, or NULL on errors
SIDE EFFECTS : Memory allocated for list
Busy count incremented for all classes
NOTES : Each restriction is linked by nxt pointer,
multiple classes in a restriction are
linked by the chain pointer.
Rcnt caller's buffer is set to reflect the
total number of chains
Assumes classExp is not NULL and that each
restriction chain is terminated with
the QUERY_DELIMITER_SYMBOL "(QDS)"
**********************************************************/
static QUERY_CLASS *DetermineQueryClasses(
void *theEnv,
EXEC_STATUS,
EXPRESSION *classExp,
char *func,
unsigned *rcnt)
{
QUERY_CLASS *clist = NULL,*cnxt = NULL,*cchain = NULL,*tmp;
int new_list = FALSE;
DATA_OBJECT temp;
*rcnt = 0;
while (classExp != NULL)
{
if (EvaluateExpression(theEnv,execStatus,classExp,&temp))
{
DeleteQueryClasses(theEnv,execStatus,clist);
return(NULL);
}
if ((temp.type == SYMBOL) && (temp.value == (void *) InstanceQueryData(theEnv,execStatus)->QUERY_DELIMETER_SYMBOL))
{
new_list = TRUE;
(*rcnt)++;
}
else if ((tmp = FormChain(theEnv,execStatus,func,&temp)) != NULL)
{
if (clist == NULL)
clist = cnxt = cchain = tmp;
else if (new_list == TRUE)
{
new_list = FALSE;
cnxt->nxt = tmp;
cnxt = cchain = tmp;
}
else
cchain->chain = tmp;
while (cchain->chain != NULL)
cchain = cchain->chain;
}
else
{
SyntaxErrorMessage(theEnv,execStatus,"instance-set query class restrictions");
DeleteQueryClasses(theEnv,execStatus,clist);
SetEvaluationError(theEnv,execStatus,TRUE);
return(NULL);
}
classExp = classExp->nextArg;
}
return(clist);
}
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 : DetermineQueryTemplates
DESCRIPTION : Builds a list of templates to be used in
fact queries - uses parse form.
INPUTS : 1) The parse template expression chain
2) The name of the function being executed
3) Caller's buffer for restriction count
(# of separate lists)
RETURNS : The query list, or NULL on errors
SIDE EFFECTS : Memory allocated for list
Busy count incremented for all templates
NOTES : Each restriction is linked by nxt pointer,
multiple templates in a restriction are
linked by the chain pointer.
Rcnt caller's buffer is set to reflect the
total number of chains
Assumes classExp is not NULL and that each
restriction chain is terminated with
the QUERY_DELIMITER_SYMBOL "(QDS)"
**********************************************************/
static QUERY_TEMPLATE *DetermineQueryTemplates(
void *theEnv,
EXPRESSION *templateExp,
char *func,
unsigned *rcnt)
{
QUERY_TEMPLATE *clist = NULL,*cnxt = NULL,*cchain = NULL,*tmp;
int new_list = FALSE;
DATA_OBJECT temp;
*rcnt = 0;
while (templateExp != NULL)
{
if (EvaluateExpression(theEnv,templateExp,&temp))
{
DeleteQueryTemplates(theEnv,clist);
return(NULL);
}
if ((temp.type == SYMBOL) && (temp.value == (void *) FactQueryData(theEnv)->QUERY_DELIMETER_SYMBOL))
{
new_list = TRUE;
(*rcnt)++;
}
else if ((tmp = FormChain(theEnv,func,&temp)) != NULL)
{
if (clist == NULL)
clist = cnxt = cchain = tmp;
else if (new_list == TRUE)
{
new_list = FALSE;
cnxt->nxt = tmp;
cnxt = cchain = tmp;
}
else
cchain->chain = tmp;
while (cchain->chain != NULL)
cchain = cchain->chain;
}
else
{
SyntaxErrorMessage(theEnv,"fact-set query class restrictions");
DeleteQueryTemplates(theEnv,clist);
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
templateExp = templateExp->nextArg;
}
return(clist);
}
/********************************************************************************
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 lhsParseNode *TestPattern(
void *theEnv,
EXEC_STATUS,
char *readSource,
int *error)
{
struct lhsParseNode *theNode;
struct token theToken;
struct expr *theExpression;
/*================================================*/
/* Create the data specification for the test CE. */
/*================================================*/
SavePPBuffer(theEnv,execStatus," ");
theNode = GetLHSParseNode(theEnv,execStatus);
theNode->type = TEST_CE;
theExpression = Function0Parse(theEnv,execStatus,readSource);
theNode->expression = ExpressionToLHSParseNodes(theEnv,execStatus,theExpression);
ReturnExpression(theEnv,execStatus,theExpression);
if (theNode->expression == NULL)
{
*error = TRUE;
ReturnLHSParseNodes(theEnv,execStatus,theNode);
return(NULL);
}
/*=========================================================*/
/* Check for the closing right parenthesis of the test CE. */
/*=========================================================*/
GetToken(theEnv,execStatus,readSource,&theToken);
if (theToken.type != RPAREN)
{
SyntaxErrorMessage(theEnv,execStatus,"test conditional element");
*error = TRUE;
ReturnLHSParseNodes(theEnv,execStatus,theNode);
return(NULL);
}
/*=====================*/
/* Return the test CE. */
/*=====================*/
return(theNode);
}
/***********************************************************************
NAME : FactParseQueryAction
DESCRIPTION : Parses the following functions :
(do-for-fact)
(do-for-all-facts)
(delayed-do-for-all-facts)
INPUTS : 1) The address of the top node of the query function
2) The logical name of the input
RETURNS : The completed expression chain, or NULL on errors
SIDE EFFECTS : The expression chain is extended, or the "top" node
is deleted on errors
NOTES : H/L Syntax :
(<function> <query-block> <query-action>)
<query-block> :== (<fact-var>+) <query-expression>
<fact-var> :== (<var-name> <template-name>+)
Parses into following form :
<query-function>
|
V
<query-expression> -> <query-action> ->
<template-1a> -> <template-1b> -> (QDS) ->
<template-2a> -> <template-2b> -> (QDS) -> ...
***********************************************************************/
globle EXPRESSION *FactParseQueryAction(
void *theEnv,
EXPRESSION *top,
const char *readSource)
{
EXPRESSION *factQuerySetVars;
struct token queryInputToken;
factQuerySetVars = ParseQueryRestrictions(theEnv,top,readSource,&queryInputToken);
if (factQuerySetVars == NULL)
{ return(NULL); }
IncrementIndentDepth(theEnv,3);
PPCRAndIndent(theEnv);
if (ParseQueryTestExpression(theEnv,top,readSource) == FALSE)
{
DecrementIndentDepth(theEnv,3);
ReturnExpression(theEnv,factQuerySetVars);
return(NULL);
}
PPCRAndIndent(theEnv);
if (ParseQueryActionExpression(theEnv,top,readSource,factQuerySetVars,&queryInputToken) == FALSE)
{
DecrementIndentDepth(theEnv,3);
ReturnExpression(theEnv,factQuerySetVars);
return(NULL);
}
DecrementIndentDepth(theEnv,3);
if (GetType(queryInputToken) != RPAREN)
{
SyntaxErrorMessage(theEnv,"fact-set query function");
ReturnExpression(theEnv,top);
ReturnExpression(theEnv,factQuerySetVars);
return(NULL);
}
ReplaceFactVariables(theEnv,factQuerySetVars,top->argList,TRUE,0);
ReplaceFactVariables(theEnv,factQuerySetVars,top->argList->nextArg,FALSE,0);
ReturnExpression(theEnv,factQuerySetVars);
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(
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 *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 : 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 : ClassInfoFnxArgs
DESCRIPTION : Examines arguments for:
class-slots, get-defmessage-handler-list,
class-superclasses and class-subclasses
INPUTS : 1) Name of function
2) A buffer to hold a flag indicating if
the inherit keyword was specified
RETURNS : Pointer to the class on success,
NULL on errors
SIDE EFFECTS : inhp flag set
error flag set
NOTES : None
***********************************************************/
globle void *ClassInfoFnxArgs(
void *theEnv,
const char *fnx,
int *inhp)
{
void *clsptr;
DATA_OBJECT tmp;
*inhp = 0;
if (EnvRtnArgCount(theEnv) == 0)
{
ExpectedCountError(theEnv,fnx,AT_LEAST,1);
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
if (EnvArgTypeCheck(theEnv,fnx,1,SYMBOL,&tmp) == FALSE)
return(NULL);
clsptr = (void *) LookupDefclassByMdlOrScope(theEnv,DOToString(tmp));
if (clsptr == NULL)
{
ClassExistError(theEnv,fnx,ValueToString(tmp.value));
return(NULL);
}
if (EnvRtnArgCount(theEnv) == 2)
{
if (EnvArgTypeCheck(theEnv,fnx,2,SYMBOL,&tmp) == FALSE)
return(NULL);
if (strcmp(ValueToString(tmp.value),"inherit") == 0)
*inhp = 1;
else
{
SyntaxErrorMessage(theEnv,fnx);
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
}
return(clsptr);
}
/***************************************************************
NAME : ParseSimpleQualifier
DESCRIPTION : Parses abstract/concrete role and
pattern-matching reactivity for class
INPUTS : 1) The input logical name
2) The name of the qualifier being parsed
3) The qualifier value indicating that the
qualifier should be false
4) The qualifier value indicating that the
qualifier should be TRUE
5) A pointer to a bitmap indicating
if the qualifier has already been parsed
6) A buffer to store the value of the qualifier
RETURNS : TRUE if all OK, FALSE otherwise
SIDE EFFECTS : Bitmap and qualifier buffers set
Messages printed on errors
NOTES : None
***************************************************************/
static intBool ParseSimpleQualifier(
void *theEnv,
char *readSource,
char *classQualifier,
char *clearRelation,
char *setRelation,
intBool *alreadyTestedFlag,
intBool *binaryFlag)
{
if (*alreadyTestedFlag)
{
PrintErrorID(theEnv,"CLASSPSR",4,FALSE);
EnvPrintRouter(theEnv,WERROR,"Class ");
EnvPrintRouter(theEnv,WERROR,classQualifier);
EnvPrintRouter(theEnv,WERROR," already declared.\n");
return(FALSE);
}
SavePPBuffer(theEnv," ");
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL)
goto ParseSimpleQualifierError;
if (strcmp(DOToString(DefclassData(theEnv)->ObjectParseToken),setRelation) == 0)
*binaryFlag = TRUE;
else if (strcmp(DOToString(DefclassData(theEnv)->ObjectParseToken),clearRelation) == 0)
*binaryFlag = FALSE;
else
goto ParseSimpleQualifierError;
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
if (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN)
goto ParseSimpleQualifierError;
*alreadyTestedFlag = TRUE;
return(TRUE);
ParseSimpleQualifierError:
SyntaxErrorMessage(theEnv,"defclass");
return(FALSE);
}
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);
}
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 int ParseImportSpec(
void *theEnv,
char *readSource,
struct token *theToken,
struct defmodule *newModule)
{
struct defmodule *theModule;
struct portItem *thePort, *oldImportSpec;
int found, count;
/*===========================*/
/* Look for the module name. */
/*===========================*/
SavePPBuffer(theEnv," ");
GetToken(theEnv,readSource,theToken);
if (theToken->type != SYMBOL)
{
SyntaxErrorMessage(theEnv,"defmodule import specification");
return(TRUE);
}
/*=====================================*/
/* Verify the existence of the module. */
/*=====================================*/
if ((theModule = (struct defmodule *)
EnvFindDefmodule(theEnv,ValueToString(theToken->value))) == NULL)
{
CantFindItemErrorMessage(theEnv,"defmodule",ValueToString(theToken->value));
return(TRUE);
}
/*========================================*/
/* If the specified module doesn't export */
/* any constructs, then the import */
/* specification is meaningless. */
/*========================================*/
if (theModule->exportList == NULL)
{
NotExportedErrorMessage(theEnv,EnvGetDefmoduleName(theEnv,theModule),NULL,NULL);
return(TRUE);
}
/*==============================================*/
/* Parse the remaining portion of the import */
/* specification and return if an error occurs. */
/*==============================================*/
oldImportSpec = newModule->importList;
if (ParseExportSpec(theEnv,readSource,theToken,newModule,theModule)) return(TRUE);
/*========================================================*/
/* If the ?NONE keyword was used with the import spec, */
/* then no constructs were actually imported and the */
/* import spec does not need to be checked for conflicts. */
/*========================================================*/
if (newModule->importList == oldImportSpec) return(FALSE);
/*======================================================*/
/* Check to see if the construct being imported can be */
/* by the specified module. This check exported doesn't */
/* guarantee that a specific named construct actually */
/* exists. It just checks that it could be exported if */
/* it does exists. */
/*======================================================*/
if (newModule->importList->constructType != NULL)
{
/*=============================*/
/* Look for the construct in */
/* the module that exports it. */
/*=============================*/
found = FALSE;
for (thePort = theModule->exportList;
(thePort != NULL) && (! found);
thePort = thePort->next)
{
if (thePort->constructType == NULL) found = TRUE;
else if (thePort->constructType == newModule->importList->constructType)
{
if (newModule->importList->constructName == NULL) found = TRUE;
else if (thePort->constructName == NULL) found = TRUE;
else if (thePort->constructName == newModule->importList->constructName)
{ found = TRUE; }
}
}
/*=======================================*/
/* If it's not exported by the specified */
/* module, print an error message. */
/*=======================================*/
if (! found)
{
if (newModule->importList->constructName == NULL)
{
NotExportedErrorMessage(theEnv,EnvGetDefmoduleName(theEnv,theModule),
ValueToString(newModule->importList->constructType),
NULL);
}
else
{
NotExportedErrorMessage(theEnv,EnvGetDefmoduleName(theEnv,theModule),
ValueToString(newModule->importList->constructType),
ValueToString(newModule->importList->constructName));
}
return(TRUE);
}
}
/*======================================================*/
/* Verify that specific named constructs actually exist */
/* and can be seen from the module importing them. */
/*======================================================*/
SaveCurrentModule(theEnv);
EnvSetCurrentModule(theEnv,(void *) newModule);
for (thePort = newModule->importList;
thePort != NULL;
thePort = thePort->next)
{
if ((thePort->constructType == NULL) || (thePort->constructName == NULL))
{ continue; }
theModule = (struct defmodule *)
EnvFindDefmodule(theEnv,ValueToString(thePort->moduleName));
EnvSetCurrentModule(theEnv,theModule);
if (FindImportedConstruct(theEnv,ValueToString(thePort->constructType),NULL,
ValueToString(thePort->constructName),&count,
TRUE,FALSE) == NULL)
{
NotExportedErrorMessage(theEnv,EnvGetDefmoduleName(theEnv,theModule),
ValueToString(thePort->constructType),
ValueToString(thePort->constructName));
RestoreCurrentModule(theEnv);
return(TRUE);
}
}
RestoreCurrentModule(theEnv);
/*===============================================*/
/* The import list has been successfully parsed. */
/*===============================================*/
return(FALSE);
}
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);
}
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 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);
}
static intBool ParseRangeCardinalityAttribute(
void *theEnv,
char *readSource,
CONSTRAINT_RECORD *constraints,
CONSTRAINT_PARSE_RECORD *parsedConstraints,
char *constraintName,
int multipleValuesAllowed)
{
struct token inputToken;
int range;
char *tempPtr = NULL;
/*=================================*/
/* Determine if we're parsing the */
/* range or cardinality attribute. */
/*=================================*/
if (strcmp(constraintName,"range") == 0)
{
parsedConstraints->range = TRUE;
range = TRUE;
}
else
{
parsedConstraints->cardinality = TRUE;
range = FALSE;
}
/*===================================================================*/
/* The cardinality attribute can only be used with multifield slots. */
/*===================================================================*/
if ((range == FALSE) &&
(multipleValuesAllowed == FALSE))
{
PrintErrorID(theEnv,"CSTRNPSR",5,TRUE);
EnvPrintRouter(theEnv,WERROR,"The cardinality attribute ");
EnvPrintRouter(theEnv,WERROR,"can only be used with multifield slots.\n");
return(FALSE);
}
/*====================================================*/
/* The range attribute is not allowed with the */
/* allowed-values/numbers/integers/floats attributes. */
/*====================================================*/
if ((range == TRUE) &&
(parsedConstraints->allowedValues ||
parsedConstraints->allowedNumbers ||
parsedConstraints->allowedIntegers ||
parsedConstraints->allowedFloats))
{
if (parsedConstraints->allowedValues) tempPtr = "allowed-values";
else if (parsedConstraints->allowedIntegers) tempPtr = "allowed-integers";
else if (parsedConstraints->allowedFloats) tempPtr = "allowed-floats";
else if (parsedConstraints->allowedNumbers) tempPtr = "allowed-numbers";
NoConjunctiveUseError(theEnv,"range",tempPtr);
return(FALSE);
}
/*==========================*/
/* Parse the minimum value. */
/*==========================*/
SavePPBuffer(theEnv," ");
GetToken(theEnv,readSource,&inputToken);
if ((inputToken.type == INTEGER) || ((inputToken.type == FLOAT) && range))
{
if (range)
{
ReturnExpression(theEnv,constraints->minValue);
constraints->minValue = GenConstant(theEnv,inputToken.type,inputToken.value);
}
else
{
ReturnExpression(theEnv,constraints->minFields);
constraints->minFields = GenConstant(theEnv,inputToken.type,inputToken.value);
}
}
else if ((inputToken.type == SF_VARIABLE) && (strcmp(inputToken.printForm,"?VARIABLE") == 0))
{ /* Do nothing. */ }
else
{
char tempBuffer[120];
gensprintf(tempBuffer,"%s attribute",constraintName);
SyntaxErrorMessage(theEnv,tempBuffer);
return(FALSE);
}
/*==========================*/
/* Parse the maximum value. */
/*==========================*/
SavePPBuffer(theEnv," ");
GetToken(theEnv,readSource,&inputToken);
if ((inputToken.type == INTEGER) || ((inputToken.type == FLOAT) && range))
{
if (range)
{
ReturnExpression(theEnv,constraints->maxValue);
constraints->maxValue = GenConstant(theEnv,inputToken.type,inputToken.value);
}
else
{
ReturnExpression(theEnv,constraints->maxFields);
constraints->maxFields = GenConstant(theEnv,inputToken.type,inputToken.value);
}
}
else if ((inputToken.type == SF_VARIABLE) && (strcmp(inputToken.printForm,"?VARIABLE") == 0))
{ /* Do nothing. */ }
else
{
char tempBuffer[120];
gensprintf(tempBuffer,"%s attribute",constraintName);
SyntaxErrorMessage(theEnv,tempBuffer);
return(FALSE);
}
/*================================*/
/* Parse the closing parenthesis. */
/*================================*/
GetToken(theEnv,readSource,&inputToken);
if (inputToken.type != RPAREN)
{
SyntaxErrorMessage(theEnv,"range attribute");
return(FALSE);
}
/*====================================================*/
/* Minimum value must be less than the maximum value. */
/*====================================================*/
if (range)
{
if (CompareNumbers(theEnv,constraints->minValue->type,
constraints->minValue->value,
constraints->maxValue->type,
constraints->maxValue->value) == GREATER_THAN)
{
PrintErrorID(theEnv,"CSTRNPSR",2,TRUE);
EnvPrintRouter(theEnv,WERROR,"Minimum range value must be less than\n");
EnvPrintRouter(theEnv,WERROR,"or equal to the maximum range value\n");
return(FALSE);
}
}
else
{
if (CompareNumbers(theEnv,constraints->minFields->type,
constraints->minFields->value,
constraints->maxFields->type,
constraints->maxFields->value) == GREATER_THAN)
{
PrintErrorID(theEnv,"CSTRNPSR",2,TRUE);
EnvPrintRouter(theEnv,WERROR,"Minimum cardinality value must be less than\n");
EnvPrintRouter(theEnv,WERROR,"or equal to the maximum cardinality value\n");
return(FALSE);
}
}
/*====================================*/
/* Return TRUE to indicate that the */
/* attribute was successfully parsed. */
/*====================================*/
return(TRUE);
}
static struct lhsParseNode *LiteralRestrictionParse(
char *readSource,
struct token *theToken,
int *error)
{
struct lhsParseNode *topNode;
struct expr *theExpression;
/*============================================*/
/* Create a node to represent the constraint. */
/*============================================*/
topNode = GetLHSParseNode();
/*=================================================*/
/* Determine if the constraint has a '~' preceding */
/* it. If it does, then the field is negated */
/* (e.g. ~red means "not the constant red." */
/*=================================================*/
if (theToken->type == NOT_CONSTRAINT)
{
GetToken(readSource,theToken);
topNode->negated = TRUE;
}
else
{ topNode->negated = FALSE; }
/*===========================================*/
/* Determine if the constraint is one of the */
/* recognized types. These are ?variables, */
/* symbols, strings, numbers, :(expression), */
/* and =(expression). */
/*===========================================*/
topNode->type = theToken->type;
/*============================================*/
/* Any symbol is valid, but an = signifies a */
/* return value constraint and an : signifies */
/* a predicate constraint. */
/*============================================*/
if (theToken->type == SYMBOL)
{
/*==============================*/
/* If the symbol is an =, parse */
/* a return value constraint. */
/*==============================*/
if (strcmp(ValueToString(theToken->value),"=") == 0)
{
theExpression = Function0Parse(readSource);
if (theExpression == NULL)
{
*error = TRUE;
ReturnLHSParseNodes(topNode);
return(NULL);
}
topNode->type = RETURN_VALUE_CONSTRAINT;
topNode->expression = ExpressionToLHSParseNodes(theExpression);
ReturnExpression(theExpression);
}
/*=============================*/
/* If the symbol is a :, parse */
/* a predicate constraint. */
/*=============================*/
else if (strcmp(ValueToString(theToken->value),":") == 0)
{
theExpression = Function0Parse(readSource);
if (theExpression == NULL)
{
*error = TRUE;
ReturnLHSParseNodes(topNode);
return(NULL);
}
topNode->type = PREDICATE_CONSTRAINT;
topNode->expression = ExpressionToLHSParseNodes(theExpression);
ReturnExpression(theExpression);
}
/*==============================================*/
/* Otherwise, treat the constraint as a symbol. */
/*==============================================*/
else
{ topNode->value = theToken->value; }
}
/*=====================================================*/
/* Single and multifield variables and float, integer, */
/* string, and instance name constants are also valid. */
/*=====================================================*/
else if ((theToken->type == SF_VARIABLE) ||
(theToken->type == MF_VARIABLE) ||
(theToken->type == FLOAT) ||
(theToken->type == INTEGER) ||
(theToken->type == STRING) ||
(theToken->type == INSTANCE_NAME))
{ topNode->value = theToken->value; }
/*===========================*/
/* Anything else is invalid. */
/*===========================*/
else
{
SyntaxErrorMessage("defrule");
*error = TRUE;
ReturnLHSParseNodes(topNode);
return(NULL);
}
/*===============================*/
/* Return the parsed constraint. */
/*===============================*/
return(topNode);
}
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);
}
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);
}
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 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);
}
