/***************************************************
NAME : LookupDefclassByMdlOrScope
DESCRIPTION : Finds a class anywhere (if module
is specified) or in current or
imported modules
INPUTS : The class name
RETURNS : The class (NULL if not found)
SIDE EFFECTS : Error message printed on
ambiguous references
NOTES : Assumes no two classes of the same
name are ever in the same scope
***************************************************/
globle DEFCLASS *LookupDefclassByMdlOrScope(
void *theEnv,
const char *classAndModuleName)
{
DEFCLASS *cls;
const char *className;
SYMBOL_HN *classSymbol;
struct defmodule *theModule;
if (FindModuleSeparator(classAndModuleName) == FALSE)
return(LookupDefclassInScope(theEnv,classAndModuleName));
SaveCurrentModule(theEnv);
className = ExtractModuleAndConstructName(theEnv,classAndModuleName);
theModule = ((struct defmodule *) EnvGetCurrentModule(theEnv));
RestoreCurrentModule(theEnv);
if(className == NULL)
return(NULL);
if ((classSymbol = FindSymbolHN(theEnv,className)) == NULL)
return(NULL);
cls = DefclassData(theEnv)->ClassTable[HashClass(classSymbol)];
while (cls != NULL)
{
if ((cls->header.name == classSymbol) &&
(cls->header.whichModule->theModule == theModule))
return(cls->installed ? cls : NULL);
cls = cls->nxtHash;
}
return(NULL);
}
globle char *ExtractModuleAndConstructName(
void *theEnv,
EXEC_STATUS,
char *theName)
{
unsigned separatorPosition;
SYMBOL_HN *moduleName, *shortName;
struct defmodule *theModule;
/*========================*/
/* Find the :: separator. */
/*========================*/
separatorPosition = FindModuleSeparator(theName);
if (! separatorPosition) return(theName);
/*==========================*/
/* Extract the module name. */
/*==========================*/
moduleName = ExtractModuleName(theEnv,execStatus,separatorPosition,theName);
if (moduleName == NULL) return(NULL);
/*====================================*/
/* Check to see if the module exists. */
/*====================================*/
theModule = (struct defmodule *) EnvFindDefmodule(theEnv,execStatus,ValueToString(moduleName));
if (theModule == NULL) return(NULL);
/*============================*/
/* Change the current module. */
/*============================*/
EnvSetCurrentModule(theEnv,execStatus,(void *) theModule);
/*=============================*/
/* Extract the construct name. */
/*=============================*/
shortName = ExtractConstructName(theEnv,execStatus,separatorPosition,theName);
if (shortName == NULL) return(NULL);
return(ValueToString(shortName));
}
globle int FindImportExportConflict(
void *theEnv,
char *constructName,
struct defmodule *matchModule,
char *findName)
{
struct defmodule *theModule;
struct moduleItem *theModuleItem;
int count;
/*===========================================================*/
/* If the construct type can't be imported or exported, then */
/* it's not possible to have an import/export conflict. */
/*===========================================================*/
if (ValidPortConstructItem(theEnv,constructName) == NULL) return(FALSE);
/*============================================*/
/* There module name should already have been */
/* separated fromthe construct's name. */
/*============================================*/
if (FindModuleSeparator(findName)) return(FALSE);
/*===============================================================*/
/* The construct must be capable of being stored within a module */
/* (this test should never fail). The construct must also have */
/* a find function associated with it so we can actually look */
/* for import/export conflicts. */
/*===============================================================*/
if ((theModuleItem = FindModuleItem(theEnv,constructName)) == NULL) return(FALSE);
if (theModuleItem->findFunction == NULL) return(FALSE);
/*==========================*/
/* Save the current module. */
/*==========================*/
SaveCurrentModule(theEnv);
/*================================================================*/
/* Look at each module and count each definition of the specified */
/* construct which is visible to the module. If more than one */
/* definition is visible, then an import/export conflict exists */
/* and TRUE is returned. */
/*================================================================*/
for (theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,NULL);
theModule != NULL;
theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,theModule))
{
EnvSetCurrentModule(theEnv,(void *) theModule);
FindImportedConstruct(theEnv,constructName,NULL,findName,&count,TRUE,matchModule);
if (count > 1)
{
RestoreCurrentModule(theEnv);
return(TRUE);
}
}
/*==========================================*/
/* Restore the current module. No conflicts */
/* were detected so FALSE is returned. */
/*==========================================*/
RestoreCurrentModule(theEnv);
return(FALSE);
}
globle struct expr *GetRHSPattern(
char *readSource,
struct token *tempToken,
int *error,
int constantsOnly,
int readFirstParen,
int checkFirstParen,
int endType)
{
struct expr *lastOne = NULL;
struct expr *nextOne, *firstOne, *argHead = NULL;
int printError, count;
struct deftemplate *theDeftemplate;
struct symbolHashNode *templateName;
/*=================================================*/
/* Get the opening parenthesis of the RHS pattern. */
/*=================================================*/
*error = FALSE;
if (readFirstParen) GetToken(readSource,tempToken);
if (checkFirstParen)
{
if (tempToken->type == endType) return(NULL);
if (tempToken->type != LPAREN)
{
SyntaxErrorMessage("RHS patterns");
*error = TRUE;
return(NULL);
}
}
/*======================================================*/
/* The first field of an asserted fact must be a symbol */
/* (but not = or : which have special significance). */
/*======================================================*/
GetToken(readSource,tempToken);
if (tempToken->type != SYMBOL)
{
SyntaxErrorMessage("first field of a RHS pattern");
*error = TRUE;
return(NULL);
}
else if ((strcmp(ValueToString(tempToken->value),"=") == 0) ||
(strcmp(ValueToString(tempToken->value),":") == 0))
{
SyntaxErrorMessage("first field of a RHS pattern");
*error = TRUE;
return(NULL);
}
/*=========================================================*/
/* Check to see if the relation name is a reserved symbol. */
/*=========================================================*/
templateName = (struct symbolHashNode *) tempToken->value;
if (ReservedPatternSymbol(ValueToString(templateName),NULL))
{
ReservedPatternSymbolErrorMsg(ValueToString(templateName),"a relation name");
*error = TRUE;
return(NULL);
}
/*============================================================*/
/* A module separator in the name is illegal in this context. */
/*============================================================*/
if (FindModuleSeparator(ValueToString(templateName)))
{
IllegalModuleSpecifierMessage();
*error = TRUE;
return(NULL);
}
/*=============================================================*/
/* Determine if there is an associated deftemplate. If so, let */
/* the deftemplate parsing functions parse the RHS pattern and */
/* then return the fact pattern that was parsed. */
/*=============================================================*/
theDeftemplate = (struct deftemplate *)
FindImportedConstruct("deftemplate",NULL,ValueToString(templateName),
&count,TRUE,NULL);
if (count > 1)
{
AmbiguousReferenceErrorMessage("deftemplate",ValueToString(templateName));
*error = TRUE;
return(NULL);
}
/*======================================================*/
/* If no deftemplate exists with the specified relation */
/* name, then create an implied deftemplate. */
/*======================================================*/
if (theDeftemplate == NULL)
#if (! BLOAD_ONLY) && (! RUN_TIME)
{
#if BLOAD || BLOAD_AND_BSAVE
if ((Bloaded()) && (! CheckSyntaxMode))
{
NoSuchTemplateError(ValueToString(templateName));
*error = TRUE;
return(NULL);
}
#endif
#if DEFMODULE_CONSTRUCT
if (FindImportExportConflict("deftemplate",((struct defmodule *) GetCurrentModule()),ValueToString(templateName)))
{
ImportExportConflictMessage("implied deftemplate",ValueToString(templateName),NULL,NULL);
*error = TRUE;
return(NULL);
}
#endif
if (! CheckSyntaxMode)
{ theDeftemplate = CreateImpliedDeftemplate((SYMBOL_HN *) templateName,TRUE); }
}
#else
{
NoSuchTemplateError(ValueToString(templateName));
*error = TRUE;
return(NULL);
}
#endif
/*=========================================*/
/* If an explicit deftemplate exists, then */
/* parse the fact as a deftemplate fact. */
/*=========================================*/
if ((theDeftemplate != NULL) && (theDeftemplate->implied == FALSE))
{
firstOne = GenConstant(DEFTEMPLATE_PTR,theDeftemplate);
firstOne->nextArg = ParseAssertTemplate(readSource,tempToken,
error,endType,
constantsOnly,theDeftemplate);
if (*error)
{
ReturnExpression(firstOne);
firstOne = NULL;
}
return(firstOne);
}
/*========================================*/
/* Parse the fact as an ordered RHS fact. */
/*========================================*/
firstOne = GenConstant(DEFTEMPLATE_PTR,theDeftemplate);
#if (! RUN_TIME) && (! BLOAD_ONLY)
SavePPBuffer(" ");
#endif
while ((nextOne = GetAssertArgument(readSource,tempToken,
error,endType,constantsOnly,&printError)) != NULL)
{
if (argHead == NULL) argHead = nextOne;
else lastOne->nextArg = nextOne;
lastOne = nextOne;
#if (! RUN_TIME) && (! BLOAD_ONLY)
SavePPBuffer(" ");
#endif
}
/*===========================================================*/
/* If an error occurred, set the error flag and return NULL. */
/*===========================================================*/
if (*error)
{
if (printError) SyntaxErrorMessage("RHS patterns");
ReturnExpression(firstOne);
ReturnExpression(argHead);
return(NULL);
}
/*=====================================*/
/* Fix the pretty print representation */
/* of the RHS ordered fact. */
/*=====================================*/
#if (! RUN_TIME) && (! BLOAD_ONLY)
PPBackup();
PPBackup();
SavePPBuffer(tempToken->printForm);
#endif
/*==========================================================*/
/* Ordered fact assertions are processed by stuffing all of */
/* the fact's proposition (except the relation name) into a */
/* single multifield slot. */
/*==========================================================*/
firstOne->nextArg = GenConstant(FACT_STORE_MULTIFIELD,AddBitMap("\0",1));
firstOne->nextArg->argList = argHead;
/*==============================*/
/* Return the RHS ordered fact. */
/*==============================*/
return(firstOne);
}
globle struct lhsParseNode *FactPatternParse(
void *theEnv,
char *readSource,
struct token *theToken)
{
struct deftemplate *theDeftemplate;
int count;
/*=========================================*/
/* A module separator can not be included */
/* as part of the pattern's relation name. */
/*=========================================*/
if (FindModuleSeparator(ValueToString(theToken->value)))
{
IllegalModuleSpecifierMessage(theEnv);
return(NULL);
}
/*=========================================================*/
/* Find the deftemplate associated with the relation name. */
/*=========================================================*/
theDeftemplate = (struct deftemplate *)
FindImportedConstruct(theEnv,"deftemplate",NULL,ValueToString(theToken->value),
&count,TRUE,NULL);
if (count > 1)
{
AmbiguousReferenceErrorMessage(theEnv,"deftemplate",ValueToString(theToken->value));
return(NULL);
}
/*======================================================*/
/* If no deftemplate exists with the specified relation */
/* name, then create an implied deftemplate. */
/*======================================================*/
if (theDeftemplate == NULL)
{
#if DEFMODULE_CONSTRUCT
if (FindImportExportConflict(theEnv,"deftemplate",((struct defmodule *) EnvGetCurrentModule(theEnv)),ValueToString(theToken->value)))
{
ImportExportConflictMessage(theEnv,"implied deftemplate",ValueToString(theToken->value),NULL,NULL);
return(NULL);
}
#endif /* DEFMODULE_CONSTRUCT */
if (! ConstructData(theEnv)->CheckSyntaxMode)
{ theDeftemplate = CreateImpliedDeftemplate(theEnv,(SYMBOL_HN *) theToken->value,TRUE); }
else
{ theDeftemplate = NULL; }
}
/*===============================================*/
/* If an explicit deftemplate exists, then parse */
/* the pattern as a deftemplate pattern. */
/*===============================================*/
if ((theDeftemplate != NULL) && (theDeftemplate->implied == FALSE))
{ return(DeftemplateLHSParse(theEnv,readSource,theDeftemplate)); }
/*================================*/
/* Parse an ordered fact pattern. */
/*================================*/
return(SequenceRestrictionParse(theEnv,readSource,theToken));
}
globle intBool ParseDefglobal(
void *theEnv,
char *readSource)
{
int defglobalError = FALSE;
#if (MAC_MCW || IBM_MCW) && (RUN_TIME || BLOAD_ONLY)
#pragma unused(theEnv,readSource)
#endif
#if (! RUN_TIME) && (! BLOAD_ONLY)
struct token theToken;
int tokenRead = TRUE;
struct defmodule *theModule;
/*=====================================*/
/* Pretty print buffer initialization. */
/*=====================================*/
SetPPBufferStatus(theEnv,ON);
FlushPPBuffer(theEnv);
SetIndentDepth(theEnv,3);
SavePPBuffer(theEnv,"(defglobal ");
/*=================================================*/
/* Individual defglobal constructs can't be parsed */
/* while a binary load is in effect. */
/*=================================================*/
#if BLOAD || BLOAD_ONLY || BLOAD_AND_BSAVE
if ((Bloaded(theEnv) == TRUE) && (! ConstructData(theEnv)->CheckSyntaxMode))
{
CannotLoadWithBloadMessage(theEnv,"defglobal");
return(TRUE);
}
#endif
/*===========================*/
/* Look for the module name. */
/*===========================*/
GetToken(theEnv,readSource,&theToken);
if (theToken.type == SYMBOL)
{
/*=================================================*/
/* The optional module name can't contain a module */
/* separator like other constructs. For example, */
/* (defrule X::foo is OK for rules, but the right */
/* syntax for defglobals is (defglobal X ?*foo*. */
/*=================================================*/
tokenRead = FALSE;
if (FindModuleSeparator(ValueToString(theToken.value)))
{
SyntaxErrorMessage(theEnv,"defglobal");
return(TRUE);
}
/*=================================*/
/* Determine if the module exists. */
/*=================================*/
theModule = (struct defmodule *) EnvFindDefmodule(theEnv,ValueToString(theToken.value));
if (theModule == NULL)
{
CantFindItemErrorMessage(theEnv,"defmodule",ValueToString(theToken.value));
return(TRUE);
}
/*=========================================*/
/* If the module name was OK, then set the */
/* current module to the specified module. */
/*=========================================*/
SavePPBuffer(theEnv," ");
EnvSetCurrentModule(theEnv,(void *) theModule);
}
/*===========================================*/
/* If the module name wasn't specified, then */
/* use the current module's name in the */
/* defglobal's pretty print representation. */
/*===========================================*/
else
{
PPBackup(theEnv);
SavePPBuffer(theEnv,EnvGetDefmoduleName(theEnv,((struct defmodule *) EnvGetCurrentModule(theEnv))));
SavePPBuffer(theEnv," ");
SavePPBuffer(theEnv,theToken.printForm);
}
/*======================*/
/* Parse the variables. */
/*======================*/
while (GetVariableDefinition(theEnv,readSource,&defglobalError,tokenRead,&theToken))
{
tokenRead = FALSE;
FlushPPBuffer(theEnv);
SavePPBuffer(theEnv,"(defglobal ");
SavePPBuffer(theEnv,EnvGetDefmoduleName(theEnv,((struct defmodule *) EnvGetCurrentModule(theEnv))));
SavePPBuffer(theEnv," ");
}
#endif
/*==================================*/
/* Return the parsing error status. */
/*==================================*/
return(defglobalError);
}
globle 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 void *FindImportedConstruct(
void *theEnv,
EXEC_STATUS,
char *constructName,
struct defmodule *matchModule,
char *findName,
int *count,
int searchCurrent,
struct defmodule *notYetDefinedInModule)
{
void *rv;
struct moduleItem *theModuleItem;
/*=============================================*/
/* Set the number of references found to zero. */
/*=============================================*/
*count = 0;
/*===============================*/
/* The :: should not be included */
/* in the construct's name. */
/*===============================*/
if (FindModuleSeparator(findName)) return(NULL);
/*=============================================*/
/* Remember the current module since we'll be */
/* changing it during the search and will want */
/* to restore it once the search is completed. */
/*=============================================*/
SaveCurrentModule(theEnv,execStatus);
/*==========================================*/
/* Find the module related access functions */
/* for the construct type being sought. */
/*==========================================*/
if ((theModuleItem = FindModuleItem(theEnv,execStatus,constructName)) == NULL)
{
RestoreCurrentModule(theEnv,execStatus);
return(NULL);
}
/*===========================================*/
/* If the construct type doesn't have a find */
/* function, then we can't look for it. */
/*===========================================*/
if (theModuleItem->findFunction == NULL)
{
RestoreCurrentModule(theEnv,execStatus);
return(NULL);
}
/*==================================*/
/* Initialize the search by marking */
/* all modules as unvisited. */
/*==================================*/
MarkModulesAsUnvisited(theEnv,execStatus);
/*===========================*/
/* Search for the construct. */
/*===========================*/
rv = SearchImportedConstructModules(theEnv,execStatus,(SYMBOL_HN *) EnvAddSymbol(theEnv,execStatus,constructName),
matchModule,theModuleItem,
(SYMBOL_HN *) EnvAddSymbol(theEnv,execStatus,findName),count,
searchCurrent,notYetDefinedInModule);
/*=============================*/
/* Restore the current module. */
/*=============================*/
RestoreCurrentModule(theEnv,execStatus);
/*====================================*/
/* Return a pointer to the construct. */
/*====================================*/
return(rv);
}
globle struct expr *Function2Parse(
void *theEnv,
char *logicalName,
char *name)
{
struct FunctionDefinition *theFunction;
struct expr *top;
#if DEFGENERIC_CONSTRUCT
void *gfunc;
#endif
#if DEFFUNCTION_CONSTRUCT
void *dptr;
#endif
/*=========================================================*/
/* Module specification cannot be used in a function call. */
/*=========================================================*/
if (FindModuleSeparator(name))
{
IllegalModuleSpecifierMessage(theEnv);
return(NULL);
}
/*================================*/
/* Has the function been defined? */
/*================================*/
theFunction = FindFunction(theEnv,name);
#if DEFGENERIC_CONSTRUCT
gfunc = (void *) LookupDefgenericInScope(theEnv,name);
#endif
#if DEFFUNCTION_CONSTRUCT
if ((theFunction == NULL)
#if DEFGENERIC_CONSTRUCT
&& (gfunc == NULL)
#endif
)
dptr = (void *) LookupDeffunctionInScope(theEnv,name);
else
dptr = NULL;
#endif
/*=============================*/
/* Define top level structure. */
/*=============================*/
#if DEFFUNCTION_CONSTRUCT
if (dptr != NULL)
top = GenConstant(theEnv,PCALL,dptr);
else
#endif
#if DEFGENERIC_CONSTRUCT
if (gfunc != NULL)
top = GenConstant(theEnv,GCALL,gfunc);
else
#endif
if (theFunction != NULL)
top = GenConstant(theEnv,FCALL,theFunction);
else
{
PrintErrorID(theEnv,"EXPRNPSR",3,TRUE);
EnvPrintRouter(theEnv,WERROR,"Missing function declaration for ");
EnvPrintRouter(theEnv,WERROR,name);
EnvPrintRouter(theEnv,WERROR,".\n");
return(NULL);
}
/*=======================================================*/
/* Check to see if function has its own parsing routine. */
/*=======================================================*/
PushRtnBrkContexts(theEnv);
ExpressionData(theEnv)->ReturnContext = FALSE;
ExpressionData(theEnv)->BreakContext = FALSE;
#if DEFGENERIC_CONSTRUCT || DEFFUNCTION_CONSTRUCT
if (top->type == FCALL)
#endif
{
if (theFunction->parser != NULL)
{
top = (*theFunction->parser)(theEnv,top,logicalName);
PopRtnBrkContexts(theEnv);
if (top == NULL) return(NULL);
if (ReplaceSequenceExpansionOps(theEnv,top->argList,top,FindFunction(theEnv,"(expansion-call)"),
FindFunction(theEnv,"expand$")))
{
ReturnExpression(theEnv,top);
return(NULL);
}
return(top);
}
}
/*========================================*/
/* Default parsing routine for functions. */
/*========================================*/
top = CollectArguments(theEnv,top,logicalName);
PopRtnBrkContexts(theEnv);
if (top == NULL) return(NULL);
if (ReplaceSequenceExpansionOps(theEnv,top->argList,top,FindFunction(theEnv,"(expansion-call)"),
FindFunction(theEnv,"expand$")))
{
ReturnExpression(theEnv,top);
return(NULL);
}
/*============================================================*/
/* If the function call uses the sequence expansion operator, */
/* its arguments cannot be checked until runtime. */
/*============================================================*/
if (top->value == (void *) FindFunction(theEnv,"(expansion-call)"))
{ return(top); }
/*============================*/
/* Check for argument errors. */
/*============================*/
if ((top->type == FCALL) && EnvGetStaticConstraintChecking(theEnv))
{
if (CheckExpressionAgainstRestrictions(theEnv,top,theFunction->restrictions,name))
{
ReturnExpression(theEnv,top);
return(NULL);
}
}
#if DEFFUNCTION_CONSTRUCT
else if (top->type == PCALL)
{
if (CheckDeffunctionCall(theEnv,top->value,CountArguments(top->argList)) == FALSE)
{
ReturnExpression(theEnv,top);
return(NULL);
}
}
#endif
/*========================*/
/* Return the expression. */
/*========================*/
return(top);
}
/**************************************************************
NAME : ParseSuperclasses
DESCRIPTION : Parses the (is-a <superclass>+) portion of
the (defclass ...) construct and returns
a list of direct superclasses. The
class "standard-class" is the precedence list
for classes with no direct superclasses.
The final precedence list (not calculated here)
will have the class in question first followed
by the merged precedence lists of its direct
superclasses.
INPUTS : 1) The logical name of the input source
2) The symbolic name of the new class
RETURNS : The address of the superclass list
or NULL if there was an error
SIDE EFFECTS : None
NOTES : Assumes "(defclass <name> [<comment>] ("
has already been scanned.
All superclasses must be defined before
their subclasses. Duplicates in the (is-a
...) list are are not allowed (a class may only
inherits from a superclass once).
This routine also checks the class-precedence
lists of each of the direct superclasses for
an occurrence of the new class - i.e. cycles!
This can only happen when a class is redefined
(a new class cannot have an unspecified
superclass).
This routine allocates the space for the list
***************************************************************/
globle PACKED_CLASS_LINKS *ParseSuperclasses(
void *theEnv,
char *readSource,
SYMBOL_HN *newClassName)
{
CLASS_LINK *clink = NULL,*cbot = NULL,*ctmp;
DEFCLASS *sclass;
PACKED_CLASS_LINKS *plinks;
if (GetType(DefclassData(theEnv)->ObjectParseToken) != LPAREN)
{
SyntaxErrorMessage(theEnv,(char*)"defclass inheritance");
return(NULL);
}
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
if ((GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL) ? TRUE :
(DefclassData(theEnv)->ObjectParseToken.value != (void *) DefclassData(theEnv)->ISA_SYMBOL))
{
SyntaxErrorMessage(theEnv,(char*)"defclass inheritance");
return(NULL);
}
SavePPBuffer(theEnv,(char*)" ");
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
while (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN)
{
if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL)
{
SyntaxErrorMessage(theEnv,(char*)"defclass");
goto SuperclassParseError;
}
if (FindModuleSeparator(ValueToString(newClassName)))
{
IllegalModuleSpecifierMessage(theEnv);
goto SuperclassParseError;
}
if (GetValue(DefclassData(theEnv)->ObjectParseToken) == (void *) newClassName)
{
PrintErrorID(theEnv,(char*)"INHERPSR",1,FALSE);
EnvPrintRouter(theEnv,WERROR,(char*)"A class may not have itself as a superclass.\n");
goto SuperclassParseError;
}
for (ctmp = clink ; ctmp != NULL ; ctmp = ctmp->nxt)
{
if (GetValue(DefclassData(theEnv)->ObjectParseToken) == (void *) ctmp->cls->header.name)
{
PrintErrorID(theEnv,(char*)"INHERPSR",2,FALSE);
EnvPrintRouter(theEnv,WERROR,(char*)"A class may inherit from a superclass only once.\n");
goto SuperclassParseError;
}
}
sclass = LookupDefclassInScope(theEnv,ValueToString(GetValue(DefclassData(theEnv)->ObjectParseToken)));
if (sclass == NULL)
{
PrintErrorID(theEnv,(char*)"INHERPSR",3,FALSE);
EnvPrintRouter(theEnv,WERROR,(char*)"A class must be defined after all its superclasses.\n");
goto SuperclassParseError;
}
if ((sclass == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME]) ||
(sclass == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_ADDRESS]) ||
(sclass == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME]->directSuperclasses.classArray[0]))
{
PrintErrorID(theEnv,(char*)"INHERPSR",6,FALSE);
EnvPrintRouter(theEnv,WERROR,(char*)"A user-defined class cannot be a subclass of ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefclassName(theEnv,(void *) sclass));
EnvPrintRouter(theEnv,WERROR,(char*)".\n");
goto SuperclassParseError;
}
ctmp = get_struct(theEnv,classLink);
ctmp->cls = sclass;
if (clink == NULL)
clink = ctmp;
else
cbot->nxt = ctmp;
ctmp->nxt = NULL;
cbot = ctmp;
SavePPBuffer(theEnv,(char*)" ");
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
}
if (clink == NULL)
{
PrintErrorID(theEnv,(char*)"INHERPSR",4,FALSE);
EnvPrintRouter(theEnv,WERROR,(char*)"Must have at least one superclass.\n");
return(NULL);
}
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,(char*)")");
plinks = get_struct(theEnv,packedClassLinks);
PackClassLinks(theEnv,plinks,clink);
return(plinks);
SuperclassParseError:
DeleteClassLinks(theEnv,clink);
return(NULL);
}
globle struct expr *GetRHSPattern(
char *readSource,
struct token *tempToken,
int *error,
int constantsOnly,
int readFirstParen,
int checkFirstParen,
int endType)
{
struct expr *lastOne = NULL;
struct expr *nextOne, *firstOne, *argHead = NULL;
int printError, count;
struct deftemplate *theDeftemplate;
struct symbolHashNode *templateName;
/*=================================================*/
/* Get the opening parenthesis of the RHS pattern. */
/*=================================================*/
*error = FALSE;
if (readFirstParen) GetToken(readSource,tempToken);
if (checkFirstParen)
{
if (tempToken->type == endType) return(NULL);
if (tempToken->type != LPAREN)
{
SyntaxErrorMessage("RHS patterns");
*error = TRUE;
return(NULL);
}
}
/*======================================================*/
/* The first field of an asserted fact must be a symbol */
/* (but not = or : which have special significance). */
/*======================================================*/
GetToken(readSource,tempToken);
if (tempToken->type != SYMBOL)
{
SyntaxErrorMessage("first field of a RHS pattern");
*error = TRUE;
return(NULL);
}
else if ((strcmp(ValueToString(tempToken->value),"=") == 0) ||
(strcmp(ValueToString(tempToken->value),":") == 0))
{
SyntaxErrorMessage("first field of a RHS pattern");
*error = TRUE;
return(NULL);
}
/*=========================================================*/
/* Check to see if the relation name is a reserved symbol. */
/*=========================================================*/
templateName = (struct symbolHashNode *) tempToken->value;
if (ReservedPatternSymbol(ValueToString(templateName),NULL))
{
ReservedPatternSymbolErrorMsg(ValueToString(templateName),"a relation name");
*error = TRUE;
return(NULL);
}
/*============================================================*/
/* A module separator in the name is illegal in this context. */
/*============================================================*/
if (FindModuleSeparator(ValueToString(templateName)))
{
IllegalModuleSpecifierMessage();
*error = TRUE;
return(NULL);
}
/*=============================================================*/
/* Determine if there is an associated deftemplate. If so, let */
/* the deftemplate parsing functions parse the RHS pattern and */
/* then return the fact pattern that was parsed. */
/*=============================================================*/
theDeftemplate = (struct deftemplate *)
FindImportedConstruct("deftemplate",NULL,ValueToString(templateName),
&count,TRUE,NULL);
if (count > 1)
{
AmbiguousReferenceErrorMessage("deftemplate",ValueToString(templateName));
*error = TRUE;
return(NULL);
}
/*======================================================*/
/* If no deftemplate exists with the specified relation */
/* name, then create an implied deftemplate. */
/*======================================================*/
if (theDeftemplate == NULL)
#if (! BLOAD_ONLY) && (! RUN_TIME)
{
#if BLOAD || BLOAD_AND_BSAVE
if ((Bloaded()) && (! CheckSyntaxMode))
{
NoSuchTemplateError(ValueToString(templateName));
*error = TRUE;
return(NULL);
}
#endif
#if DEFMODULE_CONSTRUCT
if (FindImportExportConflict("deftemplate",((struct defmodule *) GetCurrentModule()),ValueToString(templateName)))
{
ImportExportConflictMessage("implied deftemplate",ValueToString(templateName),NULL,NULL);
*error = TRUE;
return(NULL);
}
#endif
if (! CheckSyntaxMode)
{ theDeftemplate = CreateImpliedDeftemplate((SYMBOL_HN *) templateName,TRUE); }
}
#else
{
NoSuchTemplateError(ValueToString(templateName));
*error = TRUE;
return(NULL);
}
#endif
/*=========================================*/
/* If an explicit deftemplate exists, then */
/* parse the fact as a deftemplate fact. */
/*=========================================*/
if ((theDeftemplate != NULL) && (theDeftemplate->implied == FALSE))
{
firstOne = GenConstant(DEFTEMPLATE_PTR,theDeftemplate);
#if FUZZY_DEFTEMPLATES
if (theDeftemplate->fuzzyTemplate != NULL)
firstOne->nextArg = ParseAssertFuzzyFact(readSource,tempToken,
error,endType,
constantsOnly,theDeftemplate,
TRUE);
else
#endif
firstOne->nextArg = ParseAssertTemplate(readSource,tempToken,
error,endType,
constantsOnly,theDeftemplate);
if (*error)
{
ReturnExpression(firstOne);
firstOne = NULL;
}
#if CERTAINTY_FACTORS
else
{
/* if certaintly factors allowed then the next item after a fact
specifier COULD be a certainty factor spec --- CF x.xxx
*/
SavePPBuffer(" ");
GetToken(readSource,tempToken);
if ((tempToken->type == SYMBOL) &&
((strcmp(ValueToString(tempToken->value),"CF") == 0) ||
(strcmp(ValueToString(tempToken->value),"cf") == 0))
)
{
struct expr *CFexpr;
/* expecting a certainty factor (float) expression */
/* tokenToFloatExpression expect 1st token already read */
SavePPBuffer(" ");
GetToken(readSource,tempToken);
CFexpr = tokenToFloatExpression(readSource,tempToken,error,constantsOnly);
if (*error)
{
ReturnExpression(firstOne);
return( NULL );
}
if (CFexpr->type == FLOAT) /* if constant -- check range */
{
double cfval = ValueToDouble(CFexpr->value);
if (cfval > 1.0 || cfval < 0.0)
{
*error = TRUE;
ReturnExpression(CFexpr);
cfRangeError();
ReturnExpression(firstOne);
return( NULL );
}
}
/* store the CF expression in the argList of the DEFTEMPLATE_PTR expr */
firstOne->argList = CFexpr;
}
else
{
/* Do an 'UnGetToken' function here to undo the lookahead for a CF.
Also need to PPBackup over the space added before reading the
potential CF expression -- UnGetToken does one PPBackup over the
token which was added to the PP Buffer
*/
UnGetToken(tempToken);
PPBackup();
}
}
#endif
return(firstOne);
}
/*========================================*/
/* Parse the fact as an ordered RHS fact. */
/*========================================*/
firstOne = GenConstant(DEFTEMPLATE_PTR,theDeftemplate);
#if FUZZY_DEFTEMPLATES
/*=============================================*/
/* Fuzzy facts parsed differently */
/*=============================================*/
if (theDeftemplate->fuzzyTemplate != NULL)
{
firstOne->nextArg = ParseAssertFuzzyFact(readSource,tempToken,
error,endType,
constantsOnly,theDeftemplate,
TRUE);
if (*error)
{
ReturnExpression(firstOne);
return(NULL);
}
}
else
{ /* --- matches } below with FUZZY_DEFTEMPLATES */
#endif /* FUZZY_DEFTEMPLATES */
#if (! RUN_TIME) && (! BLOAD_ONLY)
SavePPBuffer(" ");
#endif
while ((nextOne = GetAssertArgument(readSource,tempToken,
error,endType,constantsOnly,&printError)) != NULL)
{
if (argHead == NULL) argHead = nextOne;
else lastOne->nextArg = nextOne;
lastOne = nextOne;
#if (! RUN_TIME) && (! BLOAD_ONLY)
SavePPBuffer(" ");
#endif
}
/*===========================================================*/
/* If an error occurred, set the error flag and return NULL. */
/*===========================================================*/
if (*error)
{
if (printError) SyntaxErrorMessage("RHS patterns");
ReturnExpression(firstOne);
ReturnExpression(argHead);
return(NULL);
}
/*=====================================*/
/* Fix the pretty print representation */
/* of the RHS ordered fact. */
/*=====================================*/
#if (! RUN_TIME) && (! BLOAD_ONLY)
PPBackup();
PPBackup();
SavePPBuffer(tempToken->printForm);
#endif
/*==========================================================*/
/* Ordered fact assertions are processed by stuffing all of */
/* the fact's proposition (except the relation name) into a */
/* single multifield slot. */
/*==========================================================*/
firstOne->nextArg = GenConstant(FACT_STORE_MULTIFIELD,AddBitMap("\0",1));
firstOne->nextArg->argList = argHead;
#if FUZZY_DEFTEMPLATES
} /* --- matches else { above with FUZZY_DEFTEMPLATES */
#endif
#if CERTAINTY_FACTORS
/* if certaintly factors allowed then the next item after a fact
specifier could be a certainty factor spec --- CF x.xxx
*/
#if (! RUN_TIME) && (! BLOAD_ONLY)
SavePPBuffer(" ");
#endif
GetToken(readSource,tempToken);
if ((tempToken->type == SYMBOL) &&
((strcmp(ValueToString(tempToken->value),"CF") == 0) ||
(strcmp(ValueToString(tempToken->value),"cf") == 0))
)
{
struct expr *CFexpr;
/* expecting a certainty factor (float) expression */
/* tokenToFloatExpression expect 1st token already read */
#if (! RUN_TIME) && (! BLOAD_ONLY)
SavePPBuffer(" ");
#endif
GetToken(readSource,tempToken);
CFexpr = tokenToFloatExpression(readSource,tempToken,error,constantsOnly);
if (*error)
{
ReturnExpression(firstOne);
return( NULL );
}
if (CFexpr->type == FLOAT) /* if constant -- check range */
{
double cfval = ValueToDouble(CFexpr->value);
if (cfval > 1.0 || cfval < 0.0)
{
*error = TRUE;
ReturnExpression(CFexpr);
cfRangeError();
ReturnExpression(firstOne);
return( NULL );
}
}
/* store the CF expression in the argList of the DEFTEMPLATE_PTR expr */
firstOne->argList = CFexpr;
}
else
{
/* Do an 'UnGetToken' function here to undo the lookahead for a CF.
Also need to PPBackup over the space added before reading the
potential CF expression -- UnGetToken does one PPBackup over the
token which was added to the PP Buffer
*/
UnGetToken(tempToken);
#if (! RUN_TIME) && (! BLOAD_ONLY)
PPBackup();
#endif
}
#endif /* CERTAINTY_FACTORS */
/*==============================*/
/* Return the RHS ordered fact. */
/*==============================*/
return(firstOne);
}