/***********************************************************************
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);
}
/***********************************************************************
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 : 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);
}
/********************************************************************************
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 *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);
}
/********************************************************************************
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(
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 : 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);
}
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);
}
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);
}
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 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);
}
/*************************************************************************************
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 : ParseDefmessageHandler
DESCRIPTION : Parses a message-handler for a class of objects
INPUTS : The logical name of the input source
RETURNS : FALSE if successful parse, TRUE otherwise
SIDE EFFECTS : Handler allocated and inserted into class
NOTES : H/L Syntax:
(defmessage-handler <class> <name> [<type>] [<comment>]
(<params>)
<action>*)
<params> ::= <var>* | <var>* $?<name>
***********************************************************************/
globle int ParseDefmessageHandler(
void *theEnv,
char *readSource)
{
DEFCLASS *cls;
SYMBOL_HN *cname,*mname,*wildcard;
unsigned mtype = MPRIMARY;
int min,max,error,lvars;
EXPRESSION *hndParams,*actions;
HANDLER *hnd;
SetPPBufferStatus(theEnv,ON);
FlushPPBuffer(theEnv);
SetIndentDepth(theEnv,3);
SavePPBuffer(theEnv,"(defmessage-handler ");
#if BLOAD || BLOAD_AND_BSAVE
if ((Bloaded(theEnv)) && (! ConstructData(theEnv)->CheckSyntaxMode))
{
CannotLoadWithBloadMessage(theEnv,"defmessage-handler");
return(TRUE);
}
#endif
cname = GetConstructNameAndComment(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken,"defmessage-handler",
NULL,NULL,"~",TRUE,FALSE,DEFMODULE_CONSTRUCT);
if (cname == NULL)
return(TRUE);
cls = LookupDefclassByMdlOrScope(theEnv,ValueToString(cname));
if (cls == NULL)
{
PrintErrorID(theEnv,"MSGPSR",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"A class must be defined before its message-handlers.\n");
return(TRUE);
}
if ((cls == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME]) ||
(cls == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_ADDRESS]) ||
(cls == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME]->directSuperclasses.classArray[0]))
{
PrintErrorID(theEnv,"MSGPSR",8,FALSE);
EnvPrintRouter(theEnv,WERROR,"Message-handlers cannot be attached to the class ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefclassName(theEnv,(void *) cls));
EnvPrintRouter(theEnv,WERROR,".\n");
return(TRUE);
}
if (HandlersExecuting(cls))
{
PrintErrorID(theEnv,"MSGPSR",2,FALSE);
EnvPrintRouter(theEnv,WERROR,"Cannot (re)define message-handlers during execution of \n");
EnvPrintRouter(theEnv,WERROR," other message-handlers for the same class.\n");
return(TRUE);
}
if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL)
{
SyntaxErrorMessage(theEnv,"defmessage-handler");
return(TRUE);
}
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv," ");
SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm);
SavePPBuffer(theEnv," ");
mname = (SYMBOL_HN *) GetValue(DefclassData(theEnv)->ObjectParseToken);
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
if (GetType(DefclassData(theEnv)->ObjectParseToken) != LPAREN)
{
SavePPBuffer(theEnv," ");
if (GetType(DefclassData(theEnv)->ObjectParseToken) != STRING)
{
if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL)
{
SyntaxErrorMessage(theEnv,"defmessage-handler");
return(TRUE);
}
mtype = HandlerType(theEnv,"defmessage-handler",DOToString(DefclassData(theEnv)->ObjectParseToken));
if (mtype == MERROR)
return(TRUE);
#if ! IMPERATIVE_MESSAGE_HANDLERS
if (mtype == MAROUND)
return(TRUE);
#endif
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
if (GetType(DefclassData(theEnv)->ObjectParseToken) == STRING)
{
SavePPBuffer(theEnv," ");
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
}
}
else
{
SavePPBuffer(theEnv," ");
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
}
}
PPBackup(theEnv);
PPBackup(theEnv);
PPCRAndIndent(theEnv);
SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm);
hnd = FindHandlerByAddress(cls,mname,mtype);
if (GetPrintWhileLoading(theEnv) && GetCompilationsWatch(theEnv))
{
EnvPrintRouter(theEnv,WDIALOG," Handler ");
EnvPrintRouter(theEnv,WDIALOG,ValueToString(mname));
EnvPrintRouter(theEnv,WDIALOG," ");
EnvPrintRouter(theEnv,WDIALOG,MessageHandlerData(theEnv)->hndquals[mtype]);
EnvPrintRouter(theEnv,WDIALOG,(char *) ((hnd == NULL) ? " defined.\n" : " redefined.\n"));
}
if ((hnd != NULL) ? hnd->system : FALSE)
{
PrintErrorID(theEnv,"MSGPSR",3,FALSE);
EnvPrintRouter(theEnv,WERROR,"System message-handlers may not be modified.\n");
return(TRUE);
}
hndParams = GenConstant(theEnv,SYMBOL,(void *) MessageHandlerData(theEnv)->SELF_SYMBOL);
hndParams = ParseProcParameters(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken,hndParams,
&wildcard,&min,&max,&error,IsParameterSlotReference);
if (error)
return(TRUE);
PPCRAndIndent(theEnv);
ExpressionData(theEnv)->ReturnContext = TRUE;
actions = ParseProcActions(theEnv,"message-handler",readSource,
&DefclassData(theEnv)->ObjectParseToken,hndParams,wildcard,
SlotReferenceVar,BindSlotReference,&lvars,
(void *) cls);
if (actions == NULL)
{
ReturnExpression(theEnv,hndParams);
return(TRUE);
}
if (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN)
{
SyntaxErrorMessage(theEnv,"defmessage-handler");
ReturnExpression(theEnv,hndParams);
ReturnPackedExpression(theEnv,actions);
return(TRUE);
}
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm);
SavePPBuffer(theEnv,"\n");
/* ===================================================
If we're only checking syntax, don't add the
successfully parsed defmessage-handler to the KB.
=================================================== */
if (ConstructData(theEnv)->CheckSyntaxMode)
{
ReturnExpression(theEnv,hndParams);
ReturnPackedExpression(theEnv,actions);
return(FALSE);
}
if (hnd != NULL)
{
ExpressionDeinstall(theEnv,hnd->actions);
ReturnPackedExpression(theEnv,hnd->actions);
if (hnd->ppForm != NULL)
rm(theEnv,(void *) hnd->ppForm,
(sizeof(char) * (strlen(hnd->ppForm)+1)));
}
else
{
hnd = InsertHandlerHeader(theEnv,cls,mname,(int) mtype);
IncrementSymbolCount(hnd->name);
}
ReturnExpression(theEnv,hndParams);
hnd->minParams = min;
hnd->maxParams = max;
hnd->localVarCount = lvars;
hnd->actions = actions;
ExpressionInstall(theEnv,hnd->actions);
#if DEBUGGING_FUNCTIONS
/* ===================================================
Old handler trace status is automatically preserved
=================================================== */
if (EnvGetConserveMemory(theEnv) == FALSE)
hnd->ppForm = CopyPPBuffer(theEnv);
else
#endif
hnd->ppForm = NULL;
return(FALSE);
}
static struct lhsParseNode *RuleBodyParse(
void *theEnv,
char *readSource,
struct token *theToken,
char *ruleName,
int *error)
{
struct lhsParseNode *theNode, *otherNodes;
/*=============================*/
/* Set the error return value. */
/*=============================*/
*error = FALSE;
/*==================================================*/
/* If we're already at the separator, "=>", between */
/* the LHS and RHS, then the LHS is empty. */
/*==================================================*/
if ((theToken->type == SYMBOL) ?
(strcmp(ValueToString(theToken->value),"=>") == 0) : FALSE)
{ return(NULL); }
/*===========================================*/
/* Parse the first pattern as a special case */
/* (the declare statement is allowed). */
/*===========================================*/
theNode = LHSPattern(theEnv,readSource,SYMBOL,"=>",error,TRUE,theToken,ruleName);
if (*error == TRUE)
{
ReturnLHSParseNodes(theEnv,theNode);
return(NULL);
}
PPCRAndIndent(theEnv);
/*======================================*/
/* Parse the other patterns in the LHS. */
/*======================================*/
otherNodes = GroupPatterns(theEnv,readSource,SYMBOL,"=>",error);
if (*error == TRUE)
{
ReturnLHSParseNodes(theEnv,theNode);
return(NULL);
}
/*================================================*/
/* Construct the final LHS by combining the first */
/* pattern with the remaining patterns. */
/*================================================*/
if (theNode == NULL)
{ theNode = otherNodes; }
else
{ theNode->bottom = otherNodes; }
/*=======================*/
/* Return the final LHS. */
/*=======================*/
return(theNode);
}
/***************************************************************************************
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);
}
static struct lhsParseNode *ConnectedPatternParse(
void *theEnv,
char *readSource,
struct token *theToken,
int *error)
{
unsigned short connectorValue = 0;
struct lhsParseNode *theNode, *tempNode, *theGroup;
char *errorCE = NULL;
int logical = FALSE;
int tempValue;
/*==========================================================*/
/* Use appropriate spacing for pretty printing of the rule. */
/*==========================================================*/
IncrementIndentDepth(theEnv,5);
if (strcmp(ValueToString(theToken->value),"or") == 0)
{
connectorValue = OR_CE;
errorCE = "the or conditional element";
SavePPBuffer(theEnv," ");
}
else if (strcmp(ValueToString(theToken->value),"and") == 0)
{
connectorValue = AND_CE;
errorCE = "the and conditional element";
SavePPBuffer(theEnv," ");
}
else if (strcmp(ValueToString(theToken->value),"not") == 0)
{
connectorValue = NOT_CE;
errorCE = "the not conditional element";
SavePPBuffer(theEnv," ");
}
else if (strcmp(ValueToString(theToken->value),"exists") == 0)
{
connectorValue = EXISTS_CE;
errorCE = "the exists conditional element";
PPCRAndIndent(theEnv);
}
else if (strcmp(ValueToString(theToken->value),"forall") == 0)
{
connectorValue = FORALL_CE;
errorCE = "the forall conditional element";
PPCRAndIndent(theEnv);
}
else if (strcmp(ValueToString(theToken->value),"logical") == 0)
{
connectorValue = AND_CE;
errorCE = "the logical conditional element";
logical = TRUE;
PPCRAndIndent(theEnv);
}
/*=====================================================*/
/* The logical CE cannot be contained within a not CE. */
/*=====================================================*/
if (PatternData(theEnv)->WithinNotCE && logical)
{
PrintErrorID(theEnv,"RULELHS",1,TRUE);
EnvPrintRouter(theEnv,WERROR,"The logical CE cannot be used within a not/exists/forall CE.\n");
*error = TRUE;
return(NULL);
}
/*=====================================================*/
/* Remember if we're currently within a *not* CE and */
/* then check to see if we're entering a new *not* CE. */
/*=====================================================*/
tempValue = PatternData(theEnv)->WithinNotCE;
if ((connectorValue == NOT_CE) ||
(connectorValue == EXISTS_CE) ||
(connectorValue == FORALL_CE))
{ PatternData(theEnv)->WithinNotCE = TRUE; }
/*===========================================*/
/* Parse all of the CEs contained with the */
/* CE. A ) will terminate the end of the CE. */
/*===========================================*/
theGroup = GroupPatterns(theEnv,readSource,RPAREN,")",error);
/*====================================*/
/* Restore the "with a *not* CE" flag */
/* and reset the indentation depth. */
/*====================================*/
PatternData(theEnv)->WithinNotCE = tempValue;
DecrementIndentDepth(theEnv,5);
/*============================================*/
/* If an error occured while parsing, return. */
/*============================================*/
if (*error == TRUE)
{
ReturnLHSParseNodes(theEnv,theGroup);
return(NULL);
}
/*=========================================================*/
/* If we parsed a *logical* CE, then mark the logical flag */
/* for all of the CEs contained within the logical CE. */
/*=========================================================*/
if (logical) TagLHSLogicalNodes(theGroup);
/*=====================================================*/
/* All the connected CEs must contain at least one CE. */
/*=====================================================*/
if (theGroup == NULL)
{
SyntaxErrorMessage(theEnv,errorCE);
*error = TRUE;
return(NULL);
}
/*============================================*/
/* A not CE may not contain more than one CE. */
/*============================================*/
if ((connectorValue == NOT_CE) && (theGroup->bottom != NULL))
{
SyntaxErrorMessage(theEnv,errorCE);
ReturnLHSParseNodes(theEnv,theGroup);
*error = TRUE;
return(NULL);
}
/*============================================*/
/* A forall CE must contain at least two CEs. */
/*============================================*/
if ((connectorValue == FORALL_CE) && (theGroup->bottom == NULL))
{
SyntaxErrorMessage(theEnv,errorCE);
ReturnLHSParseNodes(theEnv,theGroup);
*error = TRUE;
return(NULL);
}
/*========================================================*/
/* Remove an "and" and "or" CE that only contains one CE. */
/*========================================================*/
if (((connectorValue == AND_CE) || (connectorValue == OR_CE)) &&
(theGroup->bottom == NULL))
{
theGroup->logical = logical;
return(theGroup);
}
/*===========================================================*/
/* Create the top most node which connects the CEs together. */
/*===========================================================*/
theNode = GetLHSParseNode(theEnv);
theNode->logical = logical;
/*======================================================*/
/* Attach and/or/not CEs directly to the top most node. */
/*======================================================*/
if ((connectorValue == AND_CE) ||
(connectorValue == OR_CE) ||
(connectorValue == NOT_CE))
{
theNode->type = connectorValue;
theNode->right = theGroup;
}
/*=================================================================*/
/* Wrap two not CEs around the patterns contained in an exists CE. */
/*=================================================================*/
else if (connectorValue == EXISTS_CE)
{
theNode->type = NOT_CE;
theNode->right = GetLHSParseNode(theEnv);
theNode->right->type = NOT_CE;
theNode->right->logical = logical;
if (theGroup->bottom != NULL)
{
theNode->right->right = GetLHSParseNode(theEnv);
theNode->right->right->type = AND_CE;
theNode->right->right->logical = logical;
theNode->right->right->right = theGroup;
}
else
{ theNode->right->right = theGroup; }
}
/*==================================================*/
/* For a forall CE, wrap a not CE around all of the */
/* CEs and a not CE around the 2nd through nth CEs. */
/*==================================================*/
else if (connectorValue == FORALL_CE)
{
theNode->type = NOT_CE;
tempNode = theGroup->bottom;
theGroup->bottom = NULL;
theNode->right = GetLHSParseNode(theEnv);
theNode->right->type = AND_CE;
theNode->right->logical = logical;
theNode->right->right = theGroup;
theGroup = tempNode;
theNode->right->right->bottom = GetLHSParseNode(theEnv);
theNode->right->right->bottom->type = NOT_CE;
theNode->right->right->bottom->logical = logical;
tempNode = theNode->right->right->bottom;
if (theGroup->bottom == NULL)
{ tempNode->right = theGroup; }
else
{
tempNode->right = GetLHSParseNode(theEnv);
tempNode->right->type = AND_CE;
tempNode->right->logical = logical;
tempNode->right->right = theGroup;
}
}
/*================*/
/* Return the CE. */
/*================*/
return(theNode);
}
static struct lhsParseNode *GroupPatterns(
void *theEnv,
char *readSource,
int terminator,
char *terminatorString,
int *error)
{
struct lhsParseNode *lastNode, *newNode, *theNode;
lastNode = theNode = NULL;
while (TRUE)
{
/*==================*/
/* Get the next CE. */
/*==================*/
newNode = LHSPattern(theEnv,readSource,terminator,terminatorString,
error,FALSE,NULL,NULL);
/*=======================================================*/
/* If an error occurred, release any LHS data structures */
/* previously allocated by this routine. */
/*=======================================================*/
if (*error)
{
ReturnLHSParseNodes(theEnv,theNode);
return(NULL);
}
/*===============================================*/
/* A NULL value for the CE just parsed indicates */
/* that the terminator for the group of patterns */
/* was encountered (either a "=>" or a ")". */
/*===============================================*/
if (newNode == NULL)
{
PPBackup(theEnv);
PPBackup(theEnv);
if (terminator == RPAREN)
{ SavePPBuffer(theEnv,terminatorString); }
else
{
PPCRAndIndent(theEnv);
SavePPBuffer(theEnv,terminatorString);
}
return(theNode);
}
/*============================*/
/* Add the new CE to the list */
/* of CEs being grouped. */
/*============================*/
if (lastNode == NULL)
{ theNode = newNode; }
else
{ lastNode->bottom = newNode; }
lastNode = newNode;
/*======================================*/
/* Fix the pretty print representation. */
/*======================================*/
PPCRAndIndent(theEnv);
}
}
/*********************************************************************
NAME : ParseDefinstances
DESCRIPTION : Parses and allocates a definstances construct
INPUTS : The logical name of the input source
RETURNS : FALSE if no errors, TRUE otherwise
SIDE EFFECTS : Definstances parsed and created
NOTES : H/L Syntax :
(definstances <name> [active] [<comment>]
<instance-definition>+)
<instance-definition> ::=
(<instance-name> of <class-name> <slot-override>*)
<slot-override> ::= (<slot-name> <value-expression>*)
*********************************************************************/
static int ParseDefinstances(
void *theEnv,
char *readSource)
{
SYMBOL_HN *dname;
void *mkinsfcall;
EXPRESSION *mkinstance,*mkbot = NULL;
DEFINSTANCES *dobj;
int active;
SetPPBufferStatus(theEnv,ON);
FlushPPBuffer(theEnv);
SetIndentDepth(theEnv,3);
SavePPBuffer(theEnv,(char*)"(definstances ");
#if BLOAD || BLOAD_AND_BSAVE
if ((Bloaded(theEnv)) && (! ConstructData(theEnv)->CheckSyntaxMode))
{
CannotLoadWithBloadMessage(theEnv,(char*)"definstances");
return(TRUE);
}
#endif
dname = ParseDefinstancesName(theEnv,readSource,&active);
if (dname == NULL)
return(TRUE);
dobj = get_struct(theEnv,definstances);
InitializeConstructHeader(theEnv,(char*)"definstances",(struct constructHeader *) dobj,dname);
dobj->busy = 0;
dobj->mkinstance = NULL;
#if DEFRULE_CONSTRUCT
if (active)
mkinsfcall = (void *) FindFunction(theEnv,(char*)"active-make-instance");
else
mkinsfcall = (void *) FindFunction(theEnv,(char*)"make-instance");
#else
mkinsfcall = (void *) FindFunction(theEnv,(char*)"make-instance");
#endif
while (GetType(DefclassData(theEnv)->ObjectParseToken) == LPAREN)
{
mkinstance = GenConstant(theEnv,UNKNOWN_VALUE,mkinsfcall);
mkinstance = ParseInitializeInstance(theEnv,mkinstance,readSource);
if (mkinstance == NULL)
{
ReturnExpression(theEnv,dobj->mkinstance);
rtn_struct(theEnv,definstances,dobj);
return(TRUE);
}
if (ExpressionContainsVariables(mkinstance,FALSE) == TRUE)
{
LocalVariableErrorMessage(theEnv,(char*)"definstances");
ReturnExpression(theEnv,mkinstance);
ReturnExpression(theEnv,dobj->mkinstance);
rtn_struct(theEnv,definstances,dobj);
return(TRUE);
}
if (mkbot == NULL)
dobj->mkinstance = mkinstance;
else
GetNextArgument(mkbot) = mkinstance;
mkbot = mkinstance;
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
PPBackup(theEnv);
PPCRAndIndent(theEnv);
SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm);
}
if (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN)
{
ReturnExpression(theEnv,dobj->mkinstance);
rtn_struct(theEnv,definstances,dobj);
SyntaxErrorMessage(theEnv,(char*)"definstances");
return(TRUE);
}
else
{
if (ConstructData(theEnv)->CheckSyntaxMode)
{
ReturnExpression(theEnv,dobj->mkinstance);
rtn_struct(theEnv,definstances,dobj);
return(FALSE);
}
#if DEBUGGING_FUNCTIONS
if (EnvGetConserveMemory(theEnv) == FALSE)
{
if (dobj->mkinstance != NULL)
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,(char*)")\n");
SetDefinstancesPPForm((void *) dobj,CopyPPBuffer(theEnv));
}
#endif
mkinstance = dobj->mkinstance;
dobj->mkinstance = PackExpression(theEnv,mkinstance);
ReturnExpression(theEnv,mkinstance);
IncrementSymbolCount(GetDefinstancesNamePointer((void *) dobj));
ExpressionInstall(theEnv,dobj->mkinstance);
}
AddConstructToModule((struct constructHeader *) dobj);
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);
}
globle struct expr *GroupActions(
void *theEnv,
char *logicalName,
struct token *theToken,
int readFirstToken,
char *endWord,
int functionNameParsed)
{
struct expr *top, *nextOne, *lastOne = NULL;
/*=============================*/
/* Create the enclosing progn. */
/*=============================*/
top = GenConstant(theEnv,FCALL,FindFunction(theEnv,"progn"));
/*========================================================*/
/* Continue until all appropriate commands are processed. */
/*========================================================*/
while (TRUE)
{
/*================================================*/
/* Skip reading in the token if this is the first */
/* pass and the initial token was already read */
/* before calling this function. */
/*================================================*/
if (readFirstToken)
{ GetToken(theEnv,logicalName,theToken); }
else
{ readFirstToken = TRUE; }
/*=================================================*/
/* Look to see if a symbol has terminated the list */
/* of actions (such as "else" in an if function). */
/*=================================================*/
if ((theToken->type == SYMBOL) &&
(endWord != NULL) &&
(! functionNameParsed))
{
if (strcmp(ValueToString(theToken->value),endWord) == 0)
{ return(top); }
}
/*====================================*/
/* Process a function if the function */
/* name has already been read. */
/*====================================*/
if (functionNameParsed)
{
nextOne = Function2Parse(theEnv,logicalName,ValueToString(theToken->value));
functionNameParsed = FALSE;
}
/*========================================*/
/* Process a constant or global variable. */
/*========================================*/
else if ((theToken->type == SYMBOL) || (theToken->type == STRING) ||
(theToken->type == INTEGER) || (theToken->type == FLOAT) ||
#if DEFGLOBAL_CONSTRUCT
(theToken->type == GBL_VARIABLE) ||
(theToken->type == MF_GBL_VARIABLE) ||
#endif
#if OBJECT_SYSTEM
(theToken->type == INSTANCE_NAME) ||
#endif
(theToken->type == SF_VARIABLE) || (theToken->type == MF_VARIABLE))
{ nextOne = GenConstant(theEnv,theToken->type,theToken->value); }
/*=============================*/
/* Otherwise parse a function. */
/*=============================*/
else if (theToken->type == LPAREN)
{ nextOne = Function1Parse(theEnv,logicalName); }
/*======================================*/
/* Otherwise replace sequence expansion */
/* variables and return the expression. */
/*======================================*/
else
{
if (ReplaceSequenceExpansionOps(theEnv,top,NULL,
FindFunction(theEnv,"(expansion-call)"),
FindFunction(theEnv,"expand$")))
{
ReturnExpression(theEnv,top);
return(NULL);
}
return(top);
}
/*===========================*/
/* Add the new action to the */
/* list of progn arguments. */
/*===========================*/
if (nextOne == NULL)
{
theToken->type = UNKNOWN_VALUE;
ReturnExpression(theEnv,top);
return(NULL);
}
if (lastOne == NULL)
{ top->argList = nextOne; }
else
{ lastOne->nextArg = nextOne; }
lastOne = nextOne;
PPCRAndIndent(theEnv);
}
}
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);
}
/************************************************************
NAME : ParseSlot
DESCRIPTION : Parses slot definitions for a
defclass statement
INPUTS : 1) The logical name of the input source
2) The current slot list
3) The class precedence list for the class
to which this slot is being attached
(used to find facets for composite slots)
4) A flag indicating if this is a multifield
slot or not
5) A flag indicating if the type of slot
(single or multi) was explicitly
specified or not
RETURNS : The address of the list of slots,
NULL if there was an error
SIDE EFFECTS : The slot list is allocated
NOTES : Assumes "(slot" has already been parsed.
************************************************************/
globle TEMP_SLOT_LINK *ParseSlot(
void *theEnv,
EXEC_STATUS,
char *readSource,
TEMP_SLOT_LINK *slist,
PACKED_CLASS_LINKS *preclist,
int multiSlot,
int fieldSpecified)
{
SLOT_DESC *slot;
CONSTRAINT_PARSE_RECORD parsedConstraint;
char specbits[2];
int rtnCode;
SYMBOL_HN *newOverrideMsg;
/* ===============================================================
Bits in specbits are when slot qualifiers are specified so that
duplicate or conflicting qualifiers can be detected.
Shared/local bit-0
Single/multiple bit-1
Read-only/Read-write/Initialize-Only bit-2
Inherit/No-inherit bit-3
Composite/Exclusive bit-4
Reactive/Nonreactive bit-5
Default bit-6
Default-dynamic bit-7
Visibility bit-8
Override-message bit-9
=============================================================== */
SavePPBuffer(theEnv,execStatus," ");
specbits[0] = specbits[1] = '\0';
GetToken(theEnv,execStatus,readSource,&DefclassData(theEnv,execStatus)->ObjectParseToken);
if (GetType(DefclassData(theEnv,execStatus)->ObjectParseToken) != SYMBOL)
{
DeleteSlots(theEnv,execStatus,slist);
SyntaxErrorMessage(theEnv,execStatus,"defclass slot");
return(NULL);
}
if ((DefclassData(theEnv,execStatus)->ObjectParseToken.value == (void *) DefclassData(theEnv,execStatus)->ISA_SYMBOL) ||
(DefclassData(theEnv,execStatus)->ObjectParseToken.value == (void *) DefclassData(theEnv,execStatus)->NAME_SYMBOL))
{
DeleteSlots(theEnv,execStatus,slist);
SyntaxErrorMessage(theEnv,execStatus,"defclass slot");
return(NULL);
}
slot = NewSlot(theEnv,execStatus,(SYMBOL_HN *) GetValue(DefclassData(theEnv,execStatus)->ObjectParseToken));
slist = InsertSlot(theEnv,execStatus,slist,slot);
if (slist == NULL)
return(NULL);
if (multiSlot)
slot->multiple = TRUE;
if (fieldSpecified)
SetBitMap(specbits,FIELD_BIT);
GetToken(theEnv,execStatus,readSource,&DefclassData(theEnv,execStatus)->ObjectParseToken);
IncrementIndentDepth(theEnv,execStatus,3);
InitializeConstraintParseRecord(&parsedConstraint);
while (GetType(DefclassData(theEnv,execStatus)->ObjectParseToken) == LPAREN)
{
PPBackup(theEnv,execStatus);
PPCRAndIndent(theEnv,execStatus);
SavePPBuffer(theEnv,execStatus,"(");
GetToken(theEnv,execStatus,readSource,&DefclassData(theEnv,execStatus)->ObjectParseToken);
if (GetType(DefclassData(theEnv,execStatus)->ObjectParseToken) != SYMBOL)
{
SyntaxErrorMessage(theEnv,execStatus,"defclass slot");
goto ParseSlotError;
}
else if (strcmp(DOToString(DefclassData(theEnv,execStatus)->ObjectParseToken),DEFAULT_FACET) == 0)
{
if (ParseDefaultFacet(theEnv,execStatus,readSource,specbits,slot) == FALSE)
goto ParseSlotError;
}
else if (strcmp(DOToString(DefclassData(theEnv,execStatus)->ObjectParseToken),DYNAMIC_FACET) == 0)
{
SetBitMap(specbits,DEFAULT_DYNAMIC_BIT);
if (ParseDefaultFacet(theEnv,execStatus,readSource,specbits,slot) == FALSE)
goto ParseSlotError;
}
else if (strcmp(DOToString(DefclassData(theEnv,execStatus)->ObjectParseToken),ACCESS_FACET) == 0)
{
rtnCode = ParseSimpleFacet(theEnv,execStatus,readSource,specbits,ACCESS_FACET,ACCESS_BIT,
SLOT_RDWRT_RLN,SLOT_RDONLY_RLN,SLOT_INIT_RLN,
NULL,NULL);
if (rtnCode == -1)
goto ParseSlotError;
else if (rtnCode == 1)
slot->noWrite = 1;
else if (rtnCode == 2)
slot->initializeOnly = 1;
}
else if (strcmp(DOToString(DefclassData(theEnv,execStatus)->ObjectParseToken),STORAGE_FACET) == 0)
{
rtnCode = ParseSimpleFacet(theEnv,execStatus,readSource,specbits,STORAGE_FACET,STORAGE_BIT,
SLOT_LOCAL_RLN,SLOT_SHARE_RLN,NULL,NULL,NULL);
if (rtnCode == -1)
goto ParseSlotError;
slot->shared = rtnCode;
}
else if (strcmp(DOToString(DefclassData(theEnv,execStatus)->ObjectParseToken),PROPAGATION_FACET) == 0)
{
rtnCode = ParseSimpleFacet(theEnv,execStatus,readSource,specbits,PROPAGATION_FACET,PROPAGATION_BIT,
SLOT_INH_RLN,SLOT_NO_INH_RLN,NULL,NULL,NULL);
if (rtnCode == -1)
goto ParseSlotError;
slot->noInherit = rtnCode;
}
else if (strcmp(DOToString(DefclassData(theEnv,execStatus)->ObjectParseToken),SOURCE_FACET) == 0)
{
rtnCode = ParseSimpleFacet(theEnv,execStatus,readSource,specbits,SOURCE_FACET,SOURCE_BIT,
SLOT_EXCLUSIVE_RLN,SLOT_COMPOSITE_RLN,NULL,NULL,NULL);
if (rtnCode == -1)
goto ParseSlotError;
slot->composite = rtnCode;
}
#if DEFRULE_CONSTRUCT
else if (strcmp(DOToString(DefclassData(theEnv,execStatus)->ObjectParseToken),MATCH_FACET) == 0)
{
rtnCode = ParseSimpleFacet(theEnv,execStatus,readSource,specbits,MATCH_FACET,MATCH_BIT,
SLOT_NONREACTIVE_RLN,SLOT_REACTIVE_RLN,NULL,NULL,NULL);
if (rtnCode == -1)
goto ParseSlotError;
slot->reactive = rtnCode;
}
#endif
else if (strcmp(DOToString(DefclassData(theEnv,execStatus)->ObjectParseToken),VISIBILITY_FACET) == 0)
{
rtnCode = ParseSimpleFacet(theEnv,execStatus,readSource,specbits,VISIBILITY_FACET,VISIBILITY_BIT,
SLOT_PRIVATE_RLN,SLOT_PUBLIC_RLN,NULL,NULL,NULL);
if (rtnCode == -1)
goto ParseSlotError;
slot->publicVisibility = rtnCode;
}
else if (strcmp(DOToString(DefclassData(theEnv,execStatus)->ObjectParseToken),CREATE_ACCESSOR_FACET) == 0)
{
rtnCode = ParseSimpleFacet(theEnv,execStatus,readSource,specbits,CREATE_ACCESSOR_FACET,
CREATE_ACCESSOR_BIT,
SLOT_READ_RLN,SLOT_WRITE_RLN,SLOT_RDWRT_RLN,
SLOT_NONE_RLN,NULL);
if (rtnCode == -1)
goto ParseSlotError;
if ((rtnCode == 0) || (rtnCode == 2))
slot->createReadAccessor = TRUE;
if ((rtnCode == 1) || (rtnCode == 2))
slot->createWriteAccessor = TRUE;
}
else if (strcmp(DOToString(DefclassData(theEnv,execStatus)->ObjectParseToken),OVERRIDE_MSG_FACET) == 0)
{
rtnCode = ParseSimpleFacet(theEnv,execStatus,readSource,specbits,OVERRIDE_MSG_FACET,OVERRIDE_MSG_BIT,
NULL,NULL,NULL,SLOT_DEFAULT_RLN,&newOverrideMsg);
if (rtnCode == -1)
goto ParseSlotError;
if (rtnCode == 4)
{
DecrementSymbolCount(theEnv,execStatus,slot->overrideMessage);
slot->overrideMessage = newOverrideMsg;
IncrementSymbolCount(slot->overrideMessage);
}
slot->overrideMessageSpecified = TRUE;
}
else if (StandardConstraint(DOToString(DefclassData(theEnv,execStatus)->ObjectParseToken)))
{
if (ParseStandardConstraint(theEnv,execStatus,readSource,DOToString(DefclassData(theEnv,execStatus)->ObjectParseToken),
slot->constraint,&parsedConstraint,TRUE) == FALSE)
goto ParseSlotError;
}
else
{
SyntaxErrorMessage(theEnv,execStatus,"defclass slot");
goto ParseSlotError;
}
GetToken(theEnv,execStatus,readSource,&DefclassData(theEnv,execStatus)->ObjectParseToken);
}
if (GetType(DefclassData(theEnv,execStatus)->ObjectParseToken) != RPAREN)
{
SyntaxErrorMessage(theEnv,execStatus,"defclass slot");
goto ParseSlotError;
}
if (DefclassData(theEnv,execStatus)->ClassDefaultsMode == CONVENIENCE_MODE)
{
if (! TestBitMap(specbits,CREATE_ACCESSOR_BIT))
{
slot->createReadAccessor = TRUE;
if (! slot->noWrite)
{ slot->createWriteAccessor = TRUE; }
}
}
if (slot->composite)
BuildCompositeFacets(theEnv,execStatus,slot,preclist,specbits,&parsedConstraint);
if (CheckForFacetConflicts(theEnv,execStatus,slot,&parsedConstraint) == FALSE)
goto ParseSlotError;
if (CheckConstraintParseConflicts(theEnv,execStatus,slot->constraint) == FALSE)
goto ParseSlotError;
if (EvaluateSlotDefaultValue(theEnv,execStatus,slot,specbits) == FALSE)
goto ParseSlotError;
if ((slot->dynamicDefault == 0) && (slot->noWrite == 1) &&
(slot->initializeOnly == 0))
slot->shared = 1;
slot->constraint = AddConstraint(theEnv,execStatus,slot->constraint);
DecrementIndentDepth(theEnv,execStatus,3);
return(slist);
ParseSlotError:
DecrementIndentDepth(theEnv,execStatus,3);
DeleteSlots(theEnv,execStatus,slist);
return(NULL);
}
