/*******************************************************
NAME : PutClassInTable
DESCRIPTION : Inserts a class in the class hash table
INPUTS : The class
RETURNS : Nothing useful
SIDE EFFECTS : Class inserted
NOTES : None
*******************************************************/
globle void PutClassInTable(
void *theEnv,
DEFCLASS *cls)
{
cls->hashTableIndex = HashClass(GetDefclassNamePointer((void *) cls));
cls->nxtHash = DefclassData(theEnv)->ClassTable[cls->hashTableIndex];
DefclassData(theEnv)->ClassTable[cls->hashTableIndex] = cls;
}
globle unsigned short EnvSetClassDefaultsMode(
void *theEnv,
unsigned short value)
{
unsigned short ov;
ov = DefclassData(theEnv)->ClassDefaultsMode;
DefclassData(theEnv)->ClassDefaultsMode = value;
return(ov);
}
globle unsigned short EnvSetClassDefaultsMode(
void *theEnv,
EXEC_STATUS,
unsigned short value)
{
unsigned short ov;
ov = DefclassData(theEnv,execStatus)->ClassDefaultsMode;
DefclassData(theEnv,execStatus)->ClassDefaultsMode = value;
return(ov);
}
/***********************************************************************
NAME : DefclassWatchPrint
DESCRIPTION : Parses a list of class names passed by
AddWatchItem() and displays the traces accordingly
INPUTS : 1) The logical name of the output
2) A code indicating which trace flag is to be examined
0 - Watch instance creation/deletion
1 - Watch slot changes to instances
3) A list of expressions containing the names
of the classes for which to examine traces
RETURNS : TRUE if all OK, FALSE otherwise
SIDE EFFECTS : Watch flags displayed for specified classes
NOTES : Accessory function for AddWatchItem()
***********************************************************************/
globle unsigned DefclassWatchPrint(
void *theEnv,
const char *logName,
int code,
EXPRESSION *argExprs)
{
if (code)
return(ConstructPrintWatchAccess(theEnv,DefclassData(theEnv)->DefclassConstruct,logName,argExprs,
EnvGetDefclassWatchSlots,EnvSetDefclassWatchSlots));
else
return(ConstructPrintWatchAccess(theEnv,DefclassData(theEnv)->DefclassConstruct,logName,argExprs,
EnvGetDefclassWatchInstances,EnvSetDefclassWatchInstances));
}
/******************************************************************
NAME : DefclassWatchAccess
DESCRIPTION : Parses a list of class names passed by
AddWatchItem() and sets the traces accordingly
INPUTS : 1) A code indicating which trace flag is to be set
0 - Watch instance creation/deletion
1 - Watch slot changes to instances
2) The value to which to set the trace flags
3) A list of expressions containing the names
of the classes for which to set traces
RETURNS : TRUE if all OK, FALSE otherwise
SIDE EFFECTS : Watch flags set in specified classes
NOTES : Accessory function for AddWatchItem()
******************************************************************/
globle unsigned DefclassWatchAccess(
void *theEnv,
int code,
unsigned newState,
EXPRESSION *argExprs)
{
if (code)
return(ConstructSetWatchAccess(theEnv,DefclassData(theEnv)->DefclassConstruct,newState,argExprs,
EnvGetDefclassWatchSlots,EnvSetDefclassWatchSlots));
else
return(ConstructSetWatchAccess(theEnv,DefclassData(theEnv)->DefclassConstruct,newState,argExprs,
EnvGetDefclassWatchInstances,EnvSetDefclassWatchInstances));
}
/***************************************************
NAME : InitializeClasses
DESCRIPTION : Allocates class hash table
Initializes class hash table
to all NULL addresses
Creates system classes
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : Hash table initialized
NOTES : None
***************************************************/
globle void InitializeClasses(
void *theEnv)
{
register int i;
DefclassData(theEnv)->ClassTable =
(DEFCLASS **) gm2(theEnv,(int) (sizeof(DEFCLASS *) * CLASS_TABLE_HASH_SIZE));
for (i = 0 ; i < CLASS_TABLE_HASH_SIZE ; i++)
DefclassData(theEnv)->ClassTable[i] = NULL;
DefclassData(theEnv)->SlotNameTable =
(SLOT_NAME **) gm2(theEnv,(int) (sizeof(SLOT_NAME *) * SLOT_NAME_TABLE_HASH_SIZE));
for (i = 0 ; i < SLOT_NAME_TABLE_HASH_SIZE ; i++)
DefclassData(theEnv)->SlotNameTable[i] = NULL;
}
/*********************************************************
NAME : GetDefclassListFunction
DESCRIPTION : Groups names of all defclasses into
a multifield variable
INPUTS : A data object buffer
RETURNS : Nothing useful
SIDE EFFECTS : Multifield set to list of classes
NOTES : None
*********************************************************/
globle void GetDefclassListFunction(
void *theEnv,
EXEC_STATUS,
DATA_OBJECT_PTR returnValue)
{
GetConstructListFunction(theEnv,execStatus,"get-defclass-list",returnValue,DefclassData(theEnv,execStatus)->DefclassConstruct);
}
/***************************************************
NAME : UpdateDefclassesScope
DESCRIPTION : This function updates the scope
bitmaps for existing classes when
a new module is defined
INPUTS : None
RETURNS : Nothing
SIDE EFFECTS : Class scope bitmaps are updated
NOTES : None
***************************************************/
static void UpdateDefclassesScope(
void *theEnv)
{
register unsigned i;
DEFCLASS *theDefclass;
int newModuleID,count;
char *newScopeMap;
unsigned newScopeMapSize;
char *className;
struct defmodule *matchModule;
newModuleID = (int) ((struct defmodule *) EnvGetCurrentModule(theEnv))->bsaveID;
newScopeMapSize = (sizeof(char) * ((GetNumberOfDefmodules(theEnv) / BITS_PER_BYTE) + 1));
newScopeMap = (char *) gm2(theEnv,newScopeMapSize);
for (i = 0 ; i < CLASS_TABLE_HASH_SIZE ; i++)
for (theDefclass = DefclassData(theEnv)->ClassTable[i] ;
theDefclass != NULL ;
theDefclass = theDefclass->nxtHash)
{
matchModule = theDefclass->header.whichModule->theModule;
className = ValueToString(theDefclass->header.name);
ClearBitString((void *) newScopeMap,newScopeMapSize);
GenCopyMemory(char,theDefclass->scopeMap->size,
newScopeMap,ValueToBitMap(theDefclass->scopeMap));
DecrementBitMapCount(theEnv,theDefclass->scopeMap);
if (theDefclass->system)
SetBitMap(newScopeMap,newModuleID);
else if (FindImportedConstruct(theEnv,(char*)"defclass",matchModule,
className,&count,TRUE,NULL) != NULL)
SetBitMap(newScopeMap,newModuleID);
theDefclass->scopeMap = (BITMAP_HN *) EnvAddBitMap(theEnv,(void *) newScopeMap,newScopeMapSize);
IncrementBitMapCount(theDefclass->scopeMap);
}
rm(theEnv,(void *) newScopeMap,newScopeMapSize);
}
static EXPRESSION *GenTypeExpression(
void *theEnv,
EXPRESSION *top,
int nonCOOLCode,
int primitiveCode,
char *COOLName)
{
#if OBJECT_SYSTEM
#if MAC_MCW || IBM_MCW
#pragma unused(nonCOOLCode)
#endif
#endif
EXPRESSION *tmp;
#if OBJECT_SYSTEM
if (primitiveCode != -1)
tmp = GenConstant(theEnv,0,(void *) DefclassData(theEnv)->PrimitiveClassMap[primitiveCode]);
else
tmp = GenConstant(theEnv,0,(void *) LookupDefclassByMdlOrScope(theEnv,COOLName));
#else
tmp = GenConstant(theEnv,0,EnvAddLong(theEnv,(long) nonCOOLCode));
#endif
tmp->nextArg = top;
return(tmp);
}
/*******************************************************************
NAME : EnvFindDefclass
DESCRIPTION : Looks up a specified class in the class hash table
(Only looks in current or specified module)
INPUTS : The name-string of the class (including module)
RETURNS : The address of the found class, NULL otherwise
SIDE EFFECTS : None
NOTES : None
******************************************************************/
globle void *EnvFindDefclass( // TBD Needs to look in imported
void *theEnv,
const char *classAndModuleName)
{
SYMBOL_HN *classSymbol = NULL;
DEFCLASS *cls;
struct defmodule *theModule = NULL;
const char *className;
SaveCurrentModule(theEnv);
className = ExtractModuleAndConstructName(theEnv,classAndModuleName);
if (className != NULL)
{
classSymbol = FindSymbolHN(theEnv,ExtractModuleAndConstructName(theEnv,classAndModuleName));
theModule = ((struct defmodule *) EnvGetCurrentModule(theEnv));
}
RestoreCurrentModule(theEnv);
if (classSymbol == NULL)
return(NULL);
cls = DefclassData(theEnv)->ClassTable[HashClass(classSymbol)];
while (cls != NULL)
{
if (cls->header.name == classSymbol)
{
if (cls->system || (cls->header.whichModule->theModule == theModule))
return(cls->installed ? (void *) cls : NULL);
}
cls = cls->nxtHash;
}
return(NULL);
}
/***************************************************
NAME : DetermineRestrictionClass
DESCRIPTION : Finds the class of an argument in
the ProcParamArray
INPUTS : The argument data object
RETURNS : The class address, NULL if error
SIDE EFFECTS : EvaluationError set on errors
NOTES : None
***************************************************/
static Defclass *DetermineRestrictionClass(
Environment *theEnv,
UDFValue *dobj)
{
Instance *ins;
Defclass *cls;
if (dobj->header->type == INSTANCE_NAME_TYPE)
{
ins = FindInstanceBySymbol(theEnv,dobj->lexemeValue);
cls = (ins != NULL) ? ins->cls : NULL;
}
else if (dobj->header->type == INSTANCE_ADDRESS_TYPE)
{
ins = dobj->instanceValue;
cls = (ins->garbage == 0) ? ins->cls : NULL;
}
else
return(DefclassData(theEnv)->PrimitiveClassMap[dobj->header->type]);
if (cls == NULL)
{
SetEvaluationError(theEnv,true);
PrintErrorID(theEnv,"GENRCEXE",3,false);
WriteString(theEnv,STDERR,"Unable to determine class of ");
WriteUDFValue(theEnv,STDERR,dobj);
WriteString(theEnv,STDERR," in generic function '");
WriteString(theEnv,STDERR,DefgenericName(DefgenericData(theEnv)->CurrentGeneric));
WriteString(theEnv,STDERR,"'.\n");
}
return(cls);
}
/***************************************************
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 : DetermineRestrictionClass
DESCRIPTION : Finds the class of an argument in
the ProcParamArray
INPUTS : The argument data object
RETURNS : The class address, NULL if error
SIDE EFFECTS : EvaluationError set on errors
NOTES : None
***************************************************/
static DEFCLASS *DetermineRestrictionClass(
void *theEnv,
DATA_OBJECT *dobj)
{
INSTANCE_TYPE *ins;
DEFCLASS *cls;
if (dobj->type == INSTANCE_NAME)
{
ins = FindInstanceBySymbol(theEnv,(SYMBOL_HN *) dobj->value);
cls = (ins != NULL) ? ins->cls : NULL;
}
else if (dobj->type == INSTANCE_ADDRESS)
{
ins = (INSTANCE_TYPE *) dobj->value;
cls = (ins->garbage == 0) ? ins->cls : NULL;
}
else
return(DefclassData(theEnv)->PrimitiveClassMap[dobj->type]);
if (cls == NULL)
{
EnvSetEvaluationError(theEnv,true);
PrintErrorID(theEnv,"GENRCEXE",3,false);
EnvPrintRouter(theEnv,WERROR,"Unable to determine class of ");
PrintDataObject(theEnv,WERROR,dobj);
EnvPrintRouter(theEnv,WERROR," in generic function ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) DefgenericData(theEnv)->CurrentGeneric));
EnvPrintRouter(theEnv,WERROR,".\n");
}
return(cls);
}
/************************************************************
NAME : GetDefclassModuleCommand
DESCRIPTION : Determines to which module a class belongs
INPUTS : None
RETURNS : The symbolic name of the module
SIDE EFFECTS : None
NOTES : H/L Syntax: (defclass-module <class-name>)
************************************************************/
void GetDefclassModuleCommand(
Environment *theEnv,
UDFContext *context,
UDFValue *returnValue)
{
returnValue->value = GetConstructModuleCommand(context,"defclass-module",DefclassData(theEnv)->DefclassConstruct);
}
/***************************************************************
NAME : EnvGetDefclassList
DESCRIPTION : Groups all defclass names into
a multifield list
INPUTS : 1) A data object buffer to hold
the multifield result
2) The module from which to obtain defclasses
RETURNS : Nothing useful
SIDE EFFECTS : Multifield allocated and filled
NOTES : External C access
***************************************************************/
globle void EnvGetDefclassList(
void *theEnv,
DATA_OBJECT *returnValue,
struct defmodule *theModule)
{
GetConstructList(theEnv,returnValue,DefclassData(theEnv)->DefclassConstruct,theModule);
}
/***************************************************
NAME : EnvListDefclasses
DESCRIPTION : Displays all defclass names
INPUTS : 1) The logical name of the output
2) The module
RETURNS : Nothing useful
SIDE EFFECTS : Defclass names printed
NOTES : C Interface
***************************************************/
globle void EnvListDefclasses(
void *theEnv,
const char *logicalName,
struct defmodule *theModule)
{
ListConstruct(theEnv,DefclassData(theEnv)->DefclassConstruct,logicalName,theModule);
}
/********************************************************************************
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);
}
/***************************************************************
NAME : EnvGetDefclassList
DESCRIPTION : Groups all defclass names into
a multifield list
INPUTS : 1) A data object buffer to hold
the multifield result
2) The module from which to obtain defclasses
RETURNS : Nothing useful
SIDE EFFECTS : Multifield allocated and filled
NOTES : External C access
***************************************************************/
globle void EnvGetDefclassList(
void *theEnv,
EXEC_STATUS,
DATA_OBJECT *returnValue,
struct defmodule *theModule)
{
GetConstructList(theEnv,execStatus,returnValue,DefclassData(theEnv,execStatus)->DefclassConstruct,theModule);
}
/***************************************************
NAME : EnvListDefclasses
DESCRIPTION : Displays all defclass names
INPUTS : 1) The logical name of the output
2) The module
RETURNS : Nothing useful
SIDE EFFECTS : Defclass names printed
NOTES : C Interface
***************************************************/
globle void EnvListDefclasses(
void *theEnv,
EXEC_STATUS,
char *logicalName,
struct defmodule *theModule)
{
ListConstruct(theEnv,execStatus,DefclassData(theEnv,execStatus)->DefclassConstruct,logicalName,theModule);
}
/***************************************************
NAME : ReturnModule
DESCRIPTION : Removes a deffunction module and
all associated deffunctions
INPUTS : The deffunction module
RETURNS : Nothing useful
SIDE EFFECTS : Module and deffunctions deleted
NOTES : None
***************************************************/
static void ReturnModule(
void *theEnv,
void *theItem)
{
FreeConstructHeaderModule(theEnv,(struct defmoduleItemHeader *) theItem,DefclassData(theEnv)->DefclassConstruct);
DeleteSlotName(theEnv,FindIDSlotNameHash(theEnv,ISA_ID));
DeleteSlotName(theEnv,FindIDSlotNameHash(theEnv,NAME_ID));
rtn_struct(theEnv,defclassModule,theItem);
}
/*********************************************************
NAME : RemoveClassFromTable
DESCRIPTION : Removes a class from the class hash table
INPUTS : The class
RETURNS : Nothing useful
SIDE EFFECTS : Class removed
NOTES : None
*********************************************************/
globle void RemoveClassFromTable(
void *theEnv,
DEFCLASS *cls)
{
DEFCLASS *prvhsh,*hshptr;
prvhsh = NULL;
hshptr = DefclassData(theEnv)->ClassTable[cls->hashTableIndex];
while (hshptr != cls)
{
prvhsh = hshptr;
hshptr = hshptr->nxtHash;
}
if (prvhsh == NULL)
DefclassData(theEnv)->ClassTable[cls->hashTableIndex] = cls->nxtHash;
else
prvhsh->nxtHash = cls->nxtHash;
}
/*********************************************************
NAME : AddSystemClass
DESCRIPTION : Performs all necessary allocations
for adding a system class
INPUTS : 1) The name-string of the system class
2) The address of the parent class
(NULL if none)
RETURNS : The address of the new system class
SIDE EFFECTS : Allocations performed
NOTES : Assumes system-class name is unique
Also assumes SINGLE INHERITANCE for
system classes to simplify precedence
list determination
Adds classes to has table but NOT to
class list (this is responsibility
of caller)
*********************************************************/
static DEFCLASS *AddSystemClass(
void *theEnv,
char *name,
DEFCLASS *parent)
{
DEFCLASS *sys;
long i;
char defaultScopeMap[1];
sys = NewClass(theEnv,(SYMBOL_HN *) EnvAddSymbol(theEnv,name));
sys->abstract = 1;
#if DEFRULE_CONSTRUCT
sys->reactive = 0;
#endif
IncrementSymbolCount(sys->header.name);
sys->installed = 1;
sys->system = 1;
sys->hashTableIndex = HashClass(sys->header.name);
AddClassLink(theEnv,&sys->allSuperclasses,sys,-1);
if (parent != NULL)
{
AddClassLink(theEnv,&sys->directSuperclasses,parent,-1);
AddClassLink(theEnv,&parent->directSubclasses,sys,-1);
AddClassLink(theEnv,&sys->allSuperclasses,parent,-1);
for (i = 1 ; i < parent->allSuperclasses.classCount ; i++)
AddClassLink(theEnv,&sys->allSuperclasses,parent->allSuperclasses.classArray[i],-1);
}
sys->nxtHash = DefclassData(theEnv)->ClassTable[sys->hashTableIndex];
DefclassData(theEnv)->ClassTable[sys->hashTableIndex] = sys;
/* =========================================
Add default scope maps for a system class
There is only one module (MAIN) so far -
which has an id of 0
========================================= */
ClearBitString((void *) defaultScopeMap,(int) sizeof(char));
SetBitMap(defaultScopeMap,0);
#if DEFMODULE_CONSTRUCT
sys->scopeMap = (BITMAP_HN *) EnvAddBitMap(theEnv,(void *) defaultScopeMap,(int) sizeof(char));
IncrementBitMapCount(sys->scopeMap);
#endif
return(sys);
}
/********************************************************
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 : SetupObjectSystem
DESCRIPTION : Initializes all COOL constructs, functions,
and data structures
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : COOL initialized
NOTES : Order of setup calls is important
**********************************************************/
globle void SetupObjectSystem(
void *theEnv)
{
ENTITY_RECORD defclassEntityRecord = { (char*)"DEFCLASS_PTR", DEFCLASS_PTR,1,0,0,
NULL,NULL,NULL,NULL,NULL,
DecrementDefclassBusyCount,
IncrementDefclassBusyCount,
NULL,NULL,NULL,NULL,NULL
};
AllocateEnvironmentData(theEnv,DEFCLASS_DATA,sizeof(struct defclassData),NULL);
AddEnvironmentCleanupFunction(theEnv,(char*)"defclasses",DeallocateDefclassData,-500);
memcpy(&DefclassData(theEnv)->DefclassEntityRecord,&defclassEntityRecord,sizeof(struct entityRecord));
#if ! RUN_TIME
DefclassData(theEnv)->ClassDefaultsMode = CONVENIENCE_MODE;
DefclassData(theEnv)->ISA_SYMBOL = (SYMBOL_HN *) EnvAddSymbol(theEnv,SUPERCLASS_RLN);
IncrementSymbolCount(DefclassData(theEnv)->ISA_SYMBOL);
DefclassData(theEnv)->NAME_SYMBOL = (SYMBOL_HN *) EnvAddSymbol(theEnv,NAME_RLN);
IncrementSymbolCount(DefclassData(theEnv)->NAME_SYMBOL);
#if DEFRULE_CONSTRUCT
DefclassData(theEnv)->INITIAL_OBJECT_SYMBOL = (SYMBOL_HN *) EnvAddSymbol(theEnv,INITIAL_OBJECT_NAME);
IncrementSymbolCount(DefclassData(theEnv)->INITIAL_OBJECT_SYMBOL);
#endif
#endif
SetupDefclasses(theEnv);
SetupInstances(theEnv);
SetupMessageHandlers(theEnv);
#if DEFINSTANCES_CONSTRUCT
SetupDefinstances(theEnv);
#endif
#if INSTANCE_SET_QUERIES
SetupQuery(theEnv);
#endif
#if BLOAD_AND_BSAVE || BLOAD || BLOAD_ONLY
SetupObjectsBload(theEnv);
#endif
#if CONSTRUCT_COMPILER && (! RUN_TIME)
SetupObjectsCompiler(theEnv);
#endif
#if DEFRULE_CONSTRUCT
SetupObjectPatternStuff(theEnv);
#endif
}
/***************************************************
NAME : SaveDefclasses
DESCRIPTION : Prints pretty print form of
defclasses to specified output
INPUTS : The logical name of the output
RETURNS : Nothing useful
SIDE EFFECTS : None
NOTES : None
***************************************************/
globle void SaveDefclasses(
void *theEnv,
void *theModule,
const char *logName)
{
#if DEBUGGING_FUNCTIONS
DoForAllConstructsInModule(theEnv,theModule,SaveDefclass,DefclassData(theEnv)->DefclassModuleIndex,FALSE,(void *) logName);
#else
#if MAC_XCD
#pragma unused(theEnv,theModule,logName)
#endif
#endif
}
globle void SaveDefclasses(
void *theEnv,
EXEC_STATUS,
void *theModule,
char *logName)
{
#if DEBUGGING_FUNCTIONS
DoForAllConstructsInModule(theEnv,execStatus,theModule,SaveDefclass,DefclassData(theEnv,execStatus)->DefclassModuleIndex,FALSE,(void *) logName);
#else
#if MAC_MCW || WIN_MCW || MAC_XCD
#pragma unused(theEnv,execStatus,theModule,logName)
#endif
#endif
}
/****************************************************
NAME : LookupDefclassInScope
DESCRIPTION : Finds a class in current or imported
modules (module specifier
is not allowed)
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 *LookupDefclassInScope(
void *theEnv,
const char *className)
{
DEFCLASS *cls;
SYMBOL_HN *classSymbol;
if ((classSymbol = FindSymbolHN(theEnv,className)) == NULL)
return(NULL);
cls = DefclassData(theEnv)->ClassTable[HashClass(classSymbol)];
while (cls != NULL)
{
if ((cls->header.name == classSymbol) && DefclassInScope(theEnv,cls,NULL))
return(cls->installed ? cls : NULL);
cls = cls->nxtHash;
}
return(NULL);
}
globle void *SetClassDefaultsModeCommand(
void *theEnv,
EXEC_STATUS)
{
DATA_OBJECT argPtr;
char *argument;
unsigned short oldMode;
oldMode = DefclassData(theEnv,execStatus)->ClassDefaultsMode;
/*=====================================================*/
/* Check for the correct number and type of arguments. */
/*=====================================================*/
if (EnvArgCountCheck(theEnv,execStatus,"set-class-defaults-mode",EXACTLY,1) == -1)
{ return((SYMBOL_HN *) EnvAddSymbol(theEnv,execStatus,GetClassDefaultsModeName(EnvGetClassDefaultsMode(theEnv,execStatus)))); }
if (EnvArgTypeCheck(theEnv,execStatus,"set-class-defaults-mode",1,SYMBOL,&argPtr) == FALSE)
{ return((SYMBOL_HN *) EnvAddSymbol(theEnv,execStatus,GetClassDefaultsModeName(EnvGetClassDefaultsMode(theEnv,execStatus)))); }
argument = DOToString(argPtr);
/*=============================================*/
/* Set the strategy to the specified strategy. */
/*=============================================*/
if (strcmp(argument,"conservation") == 0)
{ EnvSetClassDefaultsMode(theEnv,execStatus,CONSERVATION_MODE); }
else if (strcmp(argument,"convenience") == 0)
{ EnvSetClassDefaultsMode(theEnv,execStatus,CONVENIENCE_MODE); }
else
{
ExpectedTypeError1(theEnv,execStatus,"set-class-defaults-mode",1,
"symbol with value conservation or convenience");
return((SYMBOL_HN *) EnvAddSymbol(theEnv,execStatus,GetClassDefaultsModeName(EnvGetClassDefaultsMode(theEnv,execStatus))));
}
/*===================================*/
/* Return the old value of the mode. */
/*===================================*/
return((SYMBOL_HN *) EnvAddSymbol(theEnv,execStatus,GetClassDefaultsModeName(oldMode)));
}
/******************************************************
NAME : LookupDefclassAnywhere
DESCRIPTION : Finds a class in specified
(or any) module
INPUTS : 1) The module (NULL if don't care)
2) The class name (module specifier
in name not allowed)
RETURNS : The class (NULL if not found)
SIDE EFFECTS : None
NOTES : Does *not* generate an error if
multiple classes of the same name
exist as do the other lookup functions
******************************************************/
globle DEFCLASS *LookupDefclassAnywhere(
void *theEnv,
struct defmodule *theModule,
const char *className)
{
DEFCLASS *cls;
SYMBOL_HN *classSymbol;
if ((classSymbol = FindSymbolHN(theEnv,className)) == NULL)
return(NULL);
cls = DefclassData(theEnv)->ClassTable[HashClass(classSymbol)];
while (cls != NULL)
{
if ((cls->header.name == classSymbol) &&
((theModule == NULL) ||
(cls->header.whichModule->theModule == theModule)))
return(cls->installed ? cls : NULL);
cls = cls->nxtHash;
}
return(NULL);
}
/*************************************************************
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);
}