static struct joinNode *CreateNewJoin(
void *theEnv,
struct expr *joinTest,
struct expr *secondaryJoinTest,
struct joinNode *lhsEntryStruct,
void *rhsEntryStruct,
int joinFromTheRight,
int negatedRHSPattern,
int existsRHSPattern,
struct expr *leftHash,
struct expr *rightHash)
{
struct joinNode *newJoin;
struct joinLink *theLink;
/*===============================================*/
/* If compilations are being watch, print +j to */
/* indicate that a new join has been created for */
/* this pattern of the rule (i.e. a join could */
/* not be shared with another rule. */
/*===============================================*/
#if DEBUGGING_FUNCTIONS
if ((EnvGetWatchItem(theEnv,(char*)"compilations") == TRUE) && GetPrintWhileLoading(theEnv))
{ EnvPrintRouter(theEnv,WDIALOG,(char*)"+j"); }
#endif
/*======================*/
/* Create the new join. */
/*======================*/
newJoin = get_struct(theEnv,joinNode);
/*======================================================*/
/* The first join of a rule does not have a beta memory */
/* unless the RHS pattern is an exists or not CE. */
/*======================================================*/
if ((lhsEntryStruct != NULL) || existsRHSPattern || negatedRHSPattern || joinFromTheRight)
{
if (leftHash == NULL)
{
newJoin->leftMemory = get_struct(theEnv,betaMemory);
newJoin->leftMemory->beta = (struct partialMatch **) genalloc(theEnv,sizeof(struct partialMatch *));
newJoin->leftMemory->beta[0] = NULL;
newJoin->leftMemory->last = NULL;
newJoin->leftMemory->size = 1;
newJoin->leftMemory->count = 0;
}
else
{
newJoin->leftMemory = get_struct(theEnv,betaMemory);
newJoin->leftMemory->beta = (struct partialMatch **) genalloc(theEnv,sizeof(struct partialMatch *) * INITIAL_BETA_HASH_SIZE);
memset(newJoin->leftMemory->beta,0,sizeof(struct partialMatch *) * INITIAL_BETA_HASH_SIZE);
newJoin->leftMemory->last = NULL;
newJoin->leftMemory->size = INITIAL_BETA_HASH_SIZE;
newJoin->leftMemory->count = 0;
}
/*===========================================================*/
/* If the first join of a rule connects to an exists or not */
/* CE, then we create an empty partial match for the usually */
/* empty left beta memory so that we can track the current */
/* current right memory partial match satisfying the CE. */
/*===========================================================*/
if ((lhsEntryStruct == NULL) && (existsRHSPattern || negatedRHSPattern || joinFromTheRight))
{
newJoin->leftMemory->beta[0] = CreateEmptyPartialMatch(theEnv);
newJoin->leftMemory->beta[0]->owner = newJoin;
newJoin->leftMemory->count = 1;
}
}
else
{ newJoin->leftMemory = NULL; }
if (joinFromTheRight)
{
if (leftHash == NULL)
{
newJoin->rightMemory = get_struct(theEnv,betaMemory);
newJoin->rightMemory->beta = (struct partialMatch **) genalloc(theEnv,sizeof(struct partialMatch *));
newJoin->rightMemory->last = (struct partialMatch **) genalloc(theEnv,sizeof(struct partialMatch *));
newJoin->rightMemory->beta[0] = NULL;
newJoin->rightMemory->last[0] = NULL;
newJoin->rightMemory->size = 1;
newJoin->rightMemory->count = 0;
}
else
{
newJoin->rightMemory = get_struct(theEnv,betaMemory);
newJoin->rightMemory->beta = (struct partialMatch **) genalloc(theEnv,sizeof(struct partialMatch *) * INITIAL_BETA_HASH_SIZE);
newJoin->rightMemory->last = (struct partialMatch **) genalloc(theEnv,sizeof(struct partialMatch *) * INITIAL_BETA_HASH_SIZE);
memset(newJoin->rightMemory->beta,0,sizeof(struct partialMatch *) * INITIAL_BETA_HASH_SIZE);
memset(newJoin->rightMemory->last,0,sizeof(struct partialMatch *) * INITIAL_BETA_HASH_SIZE);
newJoin->rightMemory->size = INITIAL_BETA_HASH_SIZE;
newJoin->rightMemory->count = 0;
}
}
else if ((lhsEntryStruct == NULL) && (rhsEntryStruct == NULL))
{
newJoin->rightMemory = get_struct(theEnv,betaMemory);
newJoin->rightMemory->beta = (struct partialMatch **) genalloc(theEnv,sizeof(struct partialMatch *));
newJoin->rightMemory->last = (struct partialMatch **) genalloc(theEnv,sizeof(struct partialMatch *));
newJoin->rightMemory->beta[0] = CreateEmptyPartialMatch(theEnv);
newJoin->rightMemory->beta[0]->owner = newJoin;
newJoin->rightMemory->beta[0]->rhsMemory = TRUE;
newJoin->rightMemory->last[0] = newJoin->rightMemory->beta[0];
newJoin->rightMemory->size = 1;
newJoin->rightMemory->count = 1;
}
else
{ newJoin->rightMemory = NULL; }
newJoin->nextLinks = NULL;
newJoin->joinFromTheRight = joinFromTheRight;
if (existsRHSPattern)
{ newJoin->patternIsNegated = FALSE; }
else
{ newJoin->patternIsNegated = negatedRHSPattern; }
newJoin->patternIsExists = existsRHSPattern;
newJoin->marked = FALSE;
newJoin->initialize = EnvGetIncrementalReset(theEnv);
newJoin->logicalJoin = FALSE;
newJoin->ruleToActivate = NULL;
newJoin->memoryAdds = 0;
newJoin->memoryDeletes = 0;
newJoin->memoryCompares = 0;
/*==============================================*/
/* Install the expressions used to determine */
/* if a partial match satisfies the constraints */
/* associated with this join. */
/*==============================================*/
newJoin->networkTest = AddHashedExpression(theEnv,joinTest);
newJoin->secondaryNetworkTest = AddHashedExpression(theEnv,secondaryJoinTest);
/*=====================================================*/
/* Install the expression used to hash the beta memory */
/* partial match to determine the location to search */
/* in the alpha memory. */
/*=====================================================*/
newJoin->leftHash = AddHashedExpression(theEnv,leftHash);
newJoin->rightHash = AddHashedExpression(theEnv,rightHash);
/*============================================================*/
/* Initialize the values associated with the LHS of the join. */
/*============================================================*/
newJoin->lastLevel = lhsEntryStruct;
if (lhsEntryStruct == NULL)
{
newJoin->firstJoin = TRUE;
newJoin->depth = 1;
}
else
{
newJoin->firstJoin = FALSE;
newJoin->depth = lhsEntryStruct->depth;
newJoin->depth++; /* To work around Sparcworks C compiler bug */
theLink = get_struct(theEnv,joinLink);
theLink->join = newJoin;
theLink->enterDirection = LHS;
theLink->next = lhsEntryStruct->nextLinks;
lhsEntryStruct->nextLinks = theLink;
}
/*=======================================================*/
/* Initialize the pointer values associated with the RHS */
/* of the join (both for the new join and the join or */
/* pattern which enters this join from the right. */
/*=======================================================*/
newJoin->rightSideEntryStructure = rhsEntryStruct;
if (rhsEntryStruct == NULL)
{
if (newJoin->firstJoin)
{
theLink = get_struct(theEnv,joinLink);
theLink->join = newJoin;
theLink->enterDirection = RHS;
theLink->next = DefruleData(theEnv)->RightPrimeJoins;
DefruleData(theEnv)->RightPrimeJoins = theLink;
}
newJoin->rightMatchNode = NULL;
return(newJoin);
}
/*===========================================================*/
/* If the first join of a rule is a not CE, then it needs to */
/* be "primed" under certain circumstances. This used to be */
/* handled by adding the (initial-fact) pattern to a rule */
/* with the not CE as its first pattern, but this alternate */
/* mechanism is now used so patterns don't have to be added. */
/*===========================================================*/
if (newJoin->firstJoin && (newJoin->patternIsNegated || newJoin->joinFromTheRight) && (! newJoin->patternIsExists))
{
theLink = get_struct(theEnv,joinLink);
theLink->join = newJoin;
theLink->enterDirection = LHS;
theLink->next = DefruleData(theEnv)->LeftPrimeJoins;
DefruleData(theEnv)->LeftPrimeJoins = theLink;
}
if (joinFromTheRight)
{
theLink = get_struct(theEnv,joinLink);
theLink->join = newJoin;
theLink->enterDirection = RHS;
theLink->next = ((struct joinNode *) rhsEntryStruct)->nextLinks;
((struct joinNode *) rhsEntryStruct)->nextLinks = theLink;
newJoin->rightMatchNode = NULL;
}
else
{
newJoin->rightMatchNode = ((struct patternNodeHeader *) rhsEntryStruct)->entryJoin;
((struct patternNodeHeader *) rhsEntryStruct)->entryJoin = newJoin;
}
/*================================*/
/* Return the newly created join. */
/*================================*/
return(newJoin);
}
globle struct joinNode *ConstructJoins(
void *theEnv,
int logicalJoin,
struct lhsParseNode *theLHS,
int startDepth)
{
struct joinNode *lastJoin = NULL;
struct patternNodeHeader *lastPattern;
unsigned firstJoin = TRUE;
int tryToReuse = TRUE;
struct joinNode *listOfJoins = NULL;
struct joinNode *oldJoin;
int joinNumber = 1;
int isLogical, isExists;
struct joinNode *lastRightJoin;
int lastIteration = FALSE;
int rhsType;
struct expr *leftHash, *rightHash;
void *rhsStruct;
struct lhsParseNode *nextLHS;
struct expr *networkTest, *secondaryNetworkTest, *secondaryExternalTest;
int joinFromTheRight;
struct joinLink *theLinks;
intBool useLinks;
/*===================================================*/
/* Remove any test CEs from the LHS and attach their */
/* expression to the closest preceeding non-negated */
/* join at the same not/and depth. */
/*===================================================*/
if (startDepth == 1)
{ AttachTestCEsToPatternCEs(theEnv,theLHS); }
if (theLHS == NULL)
{
lastJoin = FindShareableJoin(DefruleData(theEnv)->RightPrimeJoins,NULL,TRUE,NULL,TRUE,
FALSE,FALSE,FALSE,NULL,NULL,NULL,NULL);
if (lastJoin == NULL)
{ lastJoin = CreateNewJoin(theEnv,NULL,NULL,NULL,NULL,FALSE,FALSE,FALSE,NULL,NULL); }
}
/*=====================================================*/
/* Process each pattern CE in the rule. At this point, */
/* there should be no and/or/not/test CEs in the LHS. */
/*=====================================================*/
while (theLHS != NULL)
{
/*======================================================*/
/* Find the beginning of the next group of patterns. If */
/* the current pattern is not the beginning of a "join */
/* from the right" group of patterns, then the next */
/* pattern is the next pattern. Otherwise skip over all */
/* the patterns that belong to the group of subjoins. */
/*======================================================*/
nextLHS = theLHS->bottom;
secondaryExternalTest = NULL;
if (theLHS->endNandDepth > startDepth)
{
while ((nextLHS != NULL) &&
(nextLHS->endNandDepth > startDepth))
{ nextLHS = nextLHS->bottom; }
/*====================================================*/
/* Variable nextLHS is now pointing to the end of the */
/* not/and group beginning with variable theLHS. If */
/* the end depth of the group is less than the depth */
/* of the current enclosing not/and group, then this */
/* is the last iteration for the enclosing group. */
/*====================================================*/
if (nextLHS != NULL)
{
if (nextLHS->endNandDepth < startDepth)
{ lastIteration = TRUE; }
}
if (nextLHS != NULL)
{ nextLHS = nextLHS->bottom; }
if ((nextLHS != NULL) && (nextLHS->type == TEST_CE))
{
secondaryExternalTest = nextLHS->networkTest;
nextLHS = nextLHS->bottom;
}
}
/*=======================================*/
/* Is this the last pattern to be added? */
/*=======================================*/
if (nextLHS == NULL)
{ lastIteration = TRUE; }
else if (theLHS->endNandDepth < startDepth)
{ lastIteration = TRUE; }
else if ((nextLHS->type == TEST_CE) &&
(theLHS->beginNandDepth > startDepth) &&
(nextLHS->endNandDepth < startDepth))
{ lastIteration = TRUE; }
/*===============================================*/
/* If the pattern is a join from the right, then */
/* construct the subgroup of patterns and use */
/* that as the RHS of the join to be added. */
/*===============================================*/
if (theLHS->beginNandDepth > startDepth)
{
joinFromTheRight = TRUE;
isExists = theLHS->existsNand;
lastRightJoin = ConstructJoins(theEnv,logicalJoin,theLHS,startDepth+1);
rhsStruct = lastRightJoin;
rhsType = 0;
lastPattern = NULL;
networkTest = theLHS->externalNetworkTest; /* TBD */
secondaryNetworkTest = secondaryExternalTest;
leftHash = theLHS->externalLeftHash;
rightHash = theLHS->externalRightHash;
}
/*=======================================================*/
/* Otherwise, add the pattern to the appropriate pattern */
/* network and use the pattern node containing the alpha */
/* memory as the RHS of the join to be added. */
/*=======================================================*/
else if (theLHS->right == NULL)
{
joinFromTheRight = FALSE;
rhsType = 0;
lastPattern = NULL;
rhsStruct = NULL;
lastRightJoin = NULL;
isExists = theLHS->exists;
networkTest = theLHS->networkTest;
secondaryNetworkTest = theLHS->secondaryNetworkTest;
leftHash = NULL;
rightHash = NULL;
}
else
{
joinFromTheRight = FALSE;
rhsType = theLHS->patternType->positionInArray;
lastPattern = (*theLHS->patternType->addPatternFunction)(theEnv,theLHS);
rhsStruct = lastPattern;
lastRightJoin = NULL;
isExists = theLHS->exists;
networkTest = theLHS->networkTest;
secondaryNetworkTest = theLHS->secondaryNetworkTest;
leftHash = theLHS->leftHash;
rightHash = theLHS->rightHash;
}
/*======================================================*/
/* Determine if the join being added is a logical join. */
/*======================================================*/
if ((startDepth == 1) && (joinNumber == logicalJoin)) isLogical = TRUE;
else isLogical = FALSE;
/*===============================================*/
/* Get the list of joins which could potentially */
/* be reused in place of the join being added. */
/*===============================================*/
useLinks = TRUE;
if (firstJoin == TRUE)
{
if (theLHS->right == NULL)
{ theLinks = DefruleData(theEnv)->RightPrimeJoins; }
else if (lastPattern != NULL)
{
listOfJoins = lastPattern->entryJoin;
theLinks = NULL;
useLinks = FALSE;
}
else
{ theLinks = lastRightJoin->nextLinks; }
}
else
{ theLinks = lastJoin->nextLinks; }
/*=======================================================*/
/* Determine if the next join to be added can be shared. */
/*=======================================================*/
if ((tryToReuse == TRUE) &&
((oldJoin = FindShareableJoin(theLinks,listOfJoins,useLinks,rhsStruct,firstJoin,
theLHS->negated,isExists,isLogical,
networkTest,secondaryNetworkTest,
leftHash,rightHash)) != NULL) )
{
#if DEBUGGING_FUNCTIONS
if ((EnvGetWatchItem(theEnv,(char*)"compilations") == TRUE) && GetPrintWhileLoading(theEnv))
{ EnvPrintRouter(theEnv,WDIALOG,(char*)"=j"); }
#endif
lastJoin = oldJoin;
}
else
{
tryToReuse = FALSE;
if (! joinFromTheRight)
{
lastJoin = CreateNewJoin(theEnv,networkTest,secondaryNetworkTest,lastJoin,
lastPattern,FALSE,(int) theLHS->negated, isExists,
leftHash,rightHash);
lastJoin->rhsType = rhsType;
}
else
{
lastJoin = CreateNewJoin(theEnv,networkTest,secondaryNetworkTest,lastJoin,
lastRightJoin,TRUE,(int) theLHS->negated, isExists,
leftHash,rightHash);
lastJoin->rhsType = rhsType;
}
}
/*============================================*/
/* If we've reached the end of the subgroup, */
/* then return the last join of the subgroup. */
/*============================================*/
if (lastIteration)
{ break; }
/*=======================================*/
/* Move on to the next join to be added. */
/*=======================================*/
theLHS = nextLHS;
joinNumber++;
firstJoin = FALSE;
}
/*=================================================*/
/* Add the final join which stores the activations */
/* of the rule. This join is never shared. */
/*=================================================*/
if (startDepth == 1)
{
lastJoin = CreateNewJoin(theEnv,NULL,NULL,lastJoin,NULL,
FALSE,FALSE,FALSE,NULL,NULL);
}
/*===================================================*/
/* If compilations are being watched, put a carriage */
/* return after all of the =j's and +j's */
/*===================================================*/
#if DEBUGGING_FUNCTIONS
if ((startDepth == 1) &&
(EnvGetWatchItem(theEnv,(char*)"compilations") == TRUE) &&
GetPrintWhileLoading(theEnv))
{ EnvPrintRouter(theEnv,WDIALOG,(char*)"\n"); }
#endif
/*=============================*/
/* Return the last join added. */
/*=============================*/
return(lastJoin);
}
static intBool GetVariableDefinition(
void *theEnv,
char *readSource,
int *defglobalError,
int tokenRead,
struct token *theToken)
{
SYMBOL_HN *variableName;
struct expr *assignPtr;
DATA_OBJECT assignValue;
/*========================================*/
/* Get next token, which should either be */
/* a closing parenthesis or a variable. */
/*========================================*/
if (! tokenRead) GetToken(theEnv,readSource,theToken);
if (theToken->type == RPAREN) return(FALSE);
if (theToken->type == SF_VARIABLE)
{
SyntaxErrorMessage(theEnv,"defglobal");
*defglobalError = TRUE;
return(FALSE);
}
else if (theToken->type != GBL_VARIABLE)
{
SyntaxErrorMessage(theEnv,"defglobal");
*defglobalError = TRUE;
return(FALSE);
}
variableName = (SYMBOL_HN *) theToken->value;
SavePPBuffer(theEnv," ");
/*================================*/
/* Print out compilation message. */
/*================================*/
#if DEBUGGING_FUNCTIONS
if ((EnvGetWatchItem(theEnv,"compilations") == ON) && GetPrintWhileLoading(theEnv))
{
if (QFindDefglobal(theEnv,variableName) != NULL)
{
PrintWarningID(theEnv,"CSTRCPSR",1,TRUE);
EnvPrintRouter(theEnv,WDIALOG,"Redefining defglobal: ");
}
else EnvPrintRouter(theEnv,WDIALOG,"Defining defglobal: ");
EnvPrintRouter(theEnv,WDIALOG,ValueToString(variableName));
EnvPrintRouter(theEnv,WDIALOG,"\n");
}
else
#endif
{ if (GetPrintWhileLoading(theEnv)) EnvPrintRouter(theEnv,WDIALOG,":"); }
/*==================================================================*/
/* Check for import/export conflicts from the construct definition. */
/*==================================================================*/
#if DEFMODULE_CONSTRUCT
if (FindImportExportConflict(theEnv,"defglobal",((struct defmodule *) EnvGetCurrentModule(theEnv)),ValueToString(variableName)))
{
ImportExportConflictMessage(theEnv,"defglobal",ValueToString(variableName),NULL,NULL);
*defglobalError = TRUE;
return(FALSE);
}
#endif
/*==============================*/
/* The next token must be an =. */
/*==============================*/
GetToken(theEnv,readSource,theToken);
if (strcmp(theToken->printForm,"=") != 0)
{
SyntaxErrorMessage(theEnv,"defglobal");
*defglobalError = TRUE;
return(FALSE);
}
SavePPBuffer(theEnv," ");
/*======================================================*/
/* Parse the expression to be assigned to the variable. */
/*======================================================*/
assignPtr = ParseAtomOrExpression(theEnv,readSource,NULL);
if (assignPtr == NULL)
{
*defglobalError = TRUE;
return(FALSE);
}
/*==========================*/
/* Evaluate the expression. */
/*==========================*/
if (! ConstructData(theEnv)->CheckSyntaxMode)
{
SetEvaluationError(theEnv,FALSE);
if (EvaluateExpression(theEnv,assignPtr,&assignValue))
{
ReturnExpression(theEnv,assignPtr);
*defglobalError = TRUE;
return(FALSE);
}
}
else
{ ReturnExpression(theEnv,assignPtr); }
SavePPBuffer(theEnv,")");
/*======================================*/
/* Add the variable to the global list. */
/*======================================*/
if (! ConstructData(theEnv)->CheckSyntaxMode)
{ AddDefglobal(theEnv,variableName,&assignValue,assignPtr); }
/*==================================================*/
/* Return TRUE to indicate that the global variable */
/* definition was successfully parsed. */
/*==================================================*/
return(TRUE);
}
globle SYMBOL_HN *GetConstructNameAndComment(
void *theEnv,
char *readSource,
struct token *inputToken,
char *constructName,
void *(*findFunction)(void *,char *),
int (*deleteFunction)(void *,void *),
char *constructSymbol,
int fullMessageCR,
int getComment,
int moduleNameAllowed)
{
#if (MAC_MCW || WIN_MCW || MAC_XCD) && (! DEBUGGING_FUNCTIONS)
#pragma unused(fullMessageCR)
#endif
SYMBOL_HN *name, *moduleName;
int redefining = FALSE;
void *theConstruct;
unsigned separatorPosition;
struct defmodule *theModule;
/*==========================*/
/* Next token should be the */
/* name of the construct. */
/*==========================*/
GetToken(theEnv,readSource,inputToken);
if (inputToken->type != SYMBOL)
{
PrintErrorID(theEnv,"CSTRCPSR",2,TRUE);
EnvPrintRouter(theEnv,WERROR,"Missing name for ");
EnvPrintRouter(theEnv,WERROR,constructName);
EnvPrintRouter(theEnv,WERROR," construct\n");
return(NULL);
}
name = (SYMBOL_HN *) inputToken->value;
/*===============================*/
/* Determine the current module. */
/*===============================*/
separatorPosition = FindModuleSeparator(ValueToString(name));
if (separatorPosition)
{
if (moduleNameAllowed == FALSE)
{
SyntaxErrorMessage(theEnv,"module specifier");
return(NULL);
}
moduleName = ExtractModuleName(theEnv,separatorPosition,ValueToString(name));
if (moduleName == NULL)
{
SyntaxErrorMessage(theEnv,"construct name");
return(NULL);
}
theModule = (struct defmodule *) EnvFindDefmodule(theEnv,ValueToString(moduleName));
if (theModule == NULL)
{
CantFindItemErrorMessage(theEnv,"defmodule",ValueToString(moduleName));
return(NULL);
}
EnvSetCurrentModule(theEnv,(void *) theModule);
name = ExtractConstructName(theEnv,separatorPosition,ValueToString(name));
if (name == NULL)
{
SyntaxErrorMessage(theEnv,"construct name");
return(NULL);
}
}
/*=====================================================*/
/* If the module was not specified, record the current */
/* module name as part of the pretty-print form. */
/*=====================================================*/
else
{
theModule = ((struct defmodule *) EnvGetCurrentModule(theEnv));
if (moduleNameAllowed)
{
PPBackup(theEnv);
SavePPBuffer(theEnv,EnvGetDefmoduleName(theEnv,theModule));
SavePPBuffer(theEnv,"::");
SavePPBuffer(theEnv,ValueToString(name));
}
}
/*==================================================================*/
/* Check for import/export conflicts from the construct definition. */
/*==================================================================*/
#if DEFMODULE_CONSTRUCT
if (FindImportExportConflict(theEnv,constructName,theModule,ValueToString(name)))
{
ImportExportConflictMessage(theEnv,constructName,ValueToString(name),NULL,NULL);
return(NULL);
}
#endif
/*========================================================*/
/* Remove the construct if it is already in the knowledge */
/* base and we're not just checking syntax. */
/*========================================================*/
if ((findFunction != NULL) && (! ConstructData(theEnv)->CheckSyntaxMode))
{
theConstruct = (*findFunction)(theEnv,ValueToString(name));
if (theConstruct != NULL)
{
redefining = TRUE;
if (deleteFunction != NULL)
{
if ((*deleteFunction)(theEnv,theConstruct) == FALSE)
{
PrintErrorID(theEnv,"CSTRCPSR",4,TRUE);
EnvPrintRouter(theEnv,WERROR,"Cannot redefine ");
EnvPrintRouter(theEnv,WERROR,constructName);
EnvPrintRouter(theEnv,WERROR," ");
EnvPrintRouter(theEnv,WERROR,ValueToString(name));
EnvPrintRouter(theEnv,WERROR," while it is in use.\n");
return(NULL);
}
}
}
}
/*=============================================*/
/* If compilations are being watched, indicate */
/* that a construct is being compiled. */
/*=============================================*/
#if DEBUGGING_FUNCTIONS
if ((EnvGetWatchItem(theEnv,"compilations") == TRUE) &&
GetPrintWhileLoading(theEnv) && (! ConstructData(theEnv)->CheckSyntaxMode))
{
if (redefining)
{
PrintWarningID(theEnv,"CSTRCPSR",1,TRUE);
EnvPrintRouter(theEnv,WDIALOG,"Redefining ");
}
else EnvPrintRouter(theEnv,WDIALOG,"Defining ");
EnvPrintRouter(theEnv,WDIALOG,constructName);
EnvPrintRouter(theEnv,WDIALOG,": ");
EnvPrintRouter(theEnv,WDIALOG,ValueToString(name));
if (fullMessageCR) EnvPrintRouter(theEnv,WDIALOG,"\n");
else EnvPrintRouter(theEnv,WDIALOG," ");
}
else
#endif
{
if (GetPrintWhileLoading(theEnv) && (! ConstructData(theEnv)->CheckSyntaxMode))
{ EnvPrintRouter(theEnv,WDIALOG,constructSymbol); }
}
/*===============================*/
/* Get the comment if it exists. */
/*===============================*/
GetToken(theEnv,readSource,inputToken);
if ((inputToken->type == STRING) && getComment)
{
PPBackup(theEnv);
SavePPBuffer(theEnv," ");
SavePPBuffer(theEnv,inputToken->printForm);
GetToken(theEnv,readSource,inputToken);
if (inputToken->type != RPAREN)
{
PPBackup(theEnv);
SavePPBuffer(theEnv,"\n ");
SavePPBuffer(theEnv,inputToken->printForm);
}
}
else if (inputToken->type != RPAREN)
{
PPBackup(theEnv);
SavePPBuffer(theEnv,"\n ");
SavePPBuffer(theEnv,inputToken->printForm);
}
/*===================================*/
/* Return the name of the construct. */
/*===================================*/
return(name);
}
globle int LoadConstructsFromLogicalName(
void *theEnv,
char *readSource)
{
int constructFlag;
struct token theToken;
int noErrors = TRUE;
int foundConstruct;
/*=========================================*/
/* Reset the halt execution and evaluation */
/* error flags in preparation for parsing. */
/*=========================================*/
if (EvaluationData(theEnv)->CurrentEvaluationDepth == 0) SetHaltExecution(theEnv,FALSE);
SetEvaluationError(theEnv,FALSE);
/*========================================================*/
/* Find the beginning of the first construct in the file. */
/*========================================================*/
EvaluationData(theEnv)->CurrentEvaluationDepth++;
GetToken(theEnv,readSource,&theToken);
foundConstruct = FindConstructBeginning(theEnv,readSource,&theToken,FALSE,&noErrors);
/*==================================================*/
/* Parse the file until the end of file is reached. */
/*==================================================*/
while ((foundConstruct == TRUE) && (GetHaltExecution(theEnv) == FALSE))
{
/*===========================================================*/
/* Clear the pretty print buffer in preparation for parsing. */
/*===========================================================*/
FlushPPBuffer(theEnv);
/*======================*/
/* Parse the construct. */
/*======================*/
constructFlag = ParseConstruct(theEnv,ValueToString(theToken.value),readSource);
/*==============================================================*/
/* If an error occurred while parsing, then find the beginning */
/* of the next construct (but don't generate any more error */
/* messages--in effect, skip everything until another construct */
/* is found). */
/*==============================================================*/
if (constructFlag == 1)
{
EnvPrintRouter(theEnv,WERROR,"\nERROR:\n");
PrintInChunks(theEnv,WERROR,GetPPBuffer(theEnv));
EnvPrintRouter(theEnv,WERROR,"\n");
noErrors = FALSE;
GetToken(theEnv,readSource,&theToken);
foundConstruct = FindConstructBeginning(theEnv,readSource,&theToken,TRUE,&noErrors);
}
/*======================================================*/
/* Otherwise, find the beginning of the next construct. */
/*======================================================*/
else
{
GetToken(theEnv,readSource,&theToken);
foundConstruct = FindConstructBeginning(theEnv,readSource,&theToken,FALSE,&noErrors);
}
/*=====================================================*/
/* Yield time if necessary to foreground applications. */
/*=====================================================*/
if (foundConstruct)
{ IncrementSymbolCount(theToken.value); }
EvaluationData(theEnv)->CurrentEvaluationDepth--;
PeriodicCleanup(theEnv,FALSE,TRUE);
YieldTime(theEnv);
EvaluationData(theEnv)->CurrentEvaluationDepth++;
if (foundConstruct)
{ DecrementSymbolCount(theEnv,(SYMBOL_HN *) theToken.value); }
}
EvaluationData(theEnv)->CurrentEvaluationDepth--;
/*========================================================*/
/* Print a carriage return if a single character is being */
/* printed to indicate constructs are being processed. */
/*========================================================*/
#if DEBUGGING_FUNCTIONS
if ((EnvGetWatchItem(theEnv,"compilations") != TRUE) && GetPrintWhileLoading(theEnv))
#else
if (GetPrintWhileLoading(theEnv))
#endif
{ EnvPrintRouter(theEnv,WDIALOG,"\n"); }
/*=============================================================*/
/* Once the load is complete, destroy the pretty print buffer. */
/* This frees up any memory that was used to create the pretty */
/* print forms for constructs during parsing. Thus calls to */
/* the mem-used function will accurately reflect the amount of */
/* memory being used after a load command. */
/*=============================================================*/
DestroyPPBuffer(theEnv);
/*==========================================================*/
/* Return a boolean flag which indicates whether any errors */
/* were encountered while loading the constructs. */
/*==========================================================*/
return(noErrors);
}
/***********************************************************************
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);
}
/*******************************************************************************
NAME : CreateGetAndPutHandlers
DESCRIPTION : Creates two message-handlers with
the following syntax for the slot:
(defmessage-handler <class> get-<slot-name> primary ()
?self:<slot-name>)
For single-field slots:
(defmessage-handler <class> put-<slot-name> primary (?value)
(bind ?self:<slot-name> ?value))
For multifield slots:
(defmessage-handler <class> put-<slot-name> primary ($?value)
(bind ?self:<slot-name> ?value))
INPUTS : The class slot descriptor
RETURNS : Nothing useful
SIDE EFFECTS : Message-handlers created
NOTES : A put handler is not created for read-only slots
*******************************************************************************/
globle void CreateGetAndPutHandlers(
void *theEnv,
SLOT_DESC *sd)
{
char *className,*slotName;
unsigned bufsz;
char *buf,*handlerRouter = "*** Default Public Handlers ***";
int oldPWL,oldCM;
char *oldRouter;
char *oldString;
long oldIndex;
if ((sd->createReadAccessor == 0) && (sd->createWriteAccessor == 0))
return;
className = ValueToString(sd->cls->header.name);
slotName = ValueToString(sd->slotName->name);
bufsz = (sizeof(char) * (strlen(className) + (strlen(slotName) * 2) + 80));
buf = (char *) gm2(theEnv,bufsz);
oldPWL = GetPrintWhileLoading(theEnv);
SetPrintWhileLoading(theEnv,FALSE);
oldCM = EnvSetConserveMemory(theEnv,TRUE);
if (sd->createReadAccessor)
{
sprintf(buf,"%s get-%s () ?self:%s)",className,slotName,slotName);
oldRouter = RouterData(theEnv)->FastCharGetRouter;
oldString = RouterData(theEnv)->FastCharGetString;
oldIndex = RouterData(theEnv)->FastCharGetIndex;
RouterData(theEnv)->FastCharGetRouter = handlerRouter;
RouterData(theEnv)->FastCharGetIndex = 0;
RouterData(theEnv)->FastCharGetString = buf;
ParseDefmessageHandler(theEnv,handlerRouter);
DestroyPPBuffer(theEnv);
/*
if (OpenStringSource(theEnv,handlerRouter,buf,0))
{
ParseDefmessageHandler(handlerRouter);
DestroyPPBuffer();
CloseStringSource(theEnv,handlerRouter);
}
*/
RouterData(theEnv)->FastCharGetRouter = oldRouter;
RouterData(theEnv)->FastCharGetIndex = oldIndex;
RouterData(theEnv)->FastCharGetString = oldString;
}
if (sd->createWriteAccessor)
{
sprintf(buf,"%s put-%s ($?value) (bind ?self:%s ?value))",
className,slotName,slotName);
oldRouter = RouterData(theEnv)->FastCharGetRouter;
oldString = RouterData(theEnv)->FastCharGetString;
oldIndex = RouterData(theEnv)->FastCharGetIndex;
RouterData(theEnv)->FastCharGetRouter = handlerRouter;
RouterData(theEnv)->FastCharGetIndex = 0;
RouterData(theEnv)->FastCharGetString = buf;
ParseDefmessageHandler(theEnv,handlerRouter);
DestroyPPBuffer(theEnv);
/*
if (OpenStringSource(theEnv,handlerRouter,buf,0))
{
ParseDefmessageHandler(handlerRouter);
DestroyPPBuffer();
CloseStringSource(theEnv,handlerRouter);
}
*/
RouterData(theEnv)->FastCharGetRouter = oldRouter;
RouterData(theEnv)->FastCharGetIndex = oldIndex;
RouterData(theEnv)->FastCharGetString = oldString;
}
SetPrintWhileLoading(theEnv,oldPWL);
EnvSetConserveMemory(theEnv,oldCM);
rm(theEnv,(void *) buf,bufsz);
}