/***************************************************
NAME : ReplaceClassNameWithReference
DESCRIPTION : In parsing a make instance call,
this function replaces a constant
class name with an actual pointer
to the class
INPUTS : The expression
RETURNS : TRUE if all OK, FALSE
if class cannot be found
SIDE EFFECTS : The expression type and value are
modified if class is found
NOTES : Searches current nd imported
modules for reference
***************************************************/
static intBool ReplaceClassNameWithReference(
void *theEnv,
EXPRESSION *theExp)
{
char *theClassName;
void *theDefclass;
if (theExp->type == SYMBOL)
{
theClassName = ValueToString(theExp->value);
theDefclass = (void *) LookupDefclassInScope(theEnv,theClassName);
if (theDefclass == NULL)
{
CantFindItemErrorMessage(theEnv,(char*)"class",theClassName);
return(FALSE);
}
if (EnvClassAbstractP(theEnv,theDefclass))
{
PrintErrorID(theEnv,(char*)"INSMNGR",3,FALSE);
EnvPrintRouter(theEnv,WERROR,(char*)"Cannot create instances of abstract class ");
EnvPrintRouter(theEnv,WERROR,theClassName);
EnvPrintRouter(theEnv,WERROR,(char*)".\n");
return(FALSE);
}
theExp->type = DEFCLASS_PTR;
theExp->value = theDefclass;
}
return(TRUE);
}
/***************************************************
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);
}
/***************************************************
NAME : ReplaceClassNameWithReference
DESCRIPTION : In parsing a make instance call,
this function replaces a constant
class name with an actual pointer
to the class
INPUTS : The expression
RETURNS : TRUE if all OK, FALSE
if class cannot be found
SIDE EFFECTS : The expression type and value are
modified if class is found
NOTES : Searches current nd imported
modules for reference
***************************************************/
static BOOLEAN ReplaceClassNameWithReference(
EXPRESSION *exp)
{
char *theClassName;
void *theDefclass;
if (exp->type == SYMBOL)
{
theClassName = ValueToString(exp->value);
theDefclass = (void *) LookupDefclassInScope(theClassName);
if (theDefclass == NULL)
{
CantFindItemErrorMessage("class",theClassName);
return(FALSE);
}
if (ClassAbstractP(theDefclass))
{
PrintErrorID("INSMNGR",3,FALSE);
PrintRouter(WERROR,"Cannot create instances of abstract class ");
PrintRouter(WERROR,theClassName);
PrintRouter(WERROR,".\n");
return(FALSE);
}
exp->type = DEFCLASS_PTR;
exp->value = theDefclass;
}
return(TRUE);
}
/********************************************************
NAME : CreateInitialDefinstances
DESCRIPTION : Makes the initial-object definstances
structure for creating an initial-object
which will match default object patterns
in defrules
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : initial-object definstances created
NOTES : None
********************************************************/
static void CreateInitialDefinstances(
void *theEnv)
{
EXPRESSION *tmp;
DEFINSTANCES *theDefinstances;
theDefinstances = get_struct(theEnv,definstances);
InitializeConstructHeader(theEnv,(char*)"definstances",(struct constructHeader *) theDefinstances,
DefclassData(theEnv)->INITIAL_OBJECT_SYMBOL);
theDefinstances->busy = 0;
tmp = GenConstant(theEnv,FCALL,(void *) FindFunction(theEnv,(char*)"make-instance"));
tmp->argList = GenConstant(theEnv,INSTANCE_NAME,(void *) DefclassData(theEnv)->INITIAL_OBJECT_SYMBOL);
tmp->argList->nextArg =
GenConstant(theEnv,DEFCLASS_PTR,(void *) LookupDefclassInScope(theEnv,INITIAL_OBJECT_CLASS_NAME));
theDefinstances->mkinstance = PackExpression(theEnv,tmp);
ReturnExpression(theEnv,tmp);
IncrementSymbolCount(GetDefinstancesNamePointer((void *) theDefinstances));
ExpressionInstall(theEnv,theDefinstances->mkinstance);
AddConstructToModule((struct constructHeader *) theDefinstances);
}
/******************************************************************************
NAME : NewSystemHandler
DESCRIPTION : Adds a new system handler for a system class
The handler is assumed to be primary and of
the form:
(defmessage-handler <class> <handler> () (<func>))
INPUTS : 1) Name-string of the system class
2) Name-string of the system handler
3) Name-string of the internal H/L function to implement
this handler
4) The number of extra arguments (past the instance itself)
that the handler willl accept
RETURNS : Nothing useful
SIDE EFFECTS : Creates the new handler and inserts it in the system class's
handler array
On errors, generate a system error and exits.
NOTES : Does not check to see if handler already exists
*******************************************************************************/
globle void NewSystemHandler(
void *theEnv,
EXEC_STATUS,
char *cname,
char *mname,
char *fname,
int extraargs)
{
DEFCLASS *cls;
HANDLER *hnd;
cls = LookupDefclassInScope(theEnv,execStatus,cname);
hnd = InsertHandlerHeader(theEnv,execStatus,cls,(SYMBOL_HN *) EnvAddSymbol(theEnv,execStatus,mname),MPRIMARY);
IncrementSymbolCount(hnd->name);
hnd->system = 1;
hnd->minParams = hnd->maxParams = (short) (extraargs + 1);
hnd->localVarCount = 0;
hnd->actions = get_struct(theEnv,execStatus,expr);
hnd->actions->argList = NULL;
hnd->actions->type = FCALL;
hnd->actions->value = (void *) FindFunction(theEnv,execStatus,fname);
hnd->actions->nextArg = NULL;
}
/**************************************************************
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);
}
