/****************************************************************
NAME : BrowseClassesCommand
DESCRIPTION : Displays a "graph" of the class hierarchy
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : None
NOTES : Syntax : (browse-classes [<class>])
****************************************************************/
globle void BrowseClassesCommand(
void *theEnv)
{
register DEFCLASS *cls;
if (EnvRtnArgCount(theEnv) == 0)
/* ================================================
Find the OBJECT root class (has no superclasses)
================================================ */
cls = LookupDefclassByMdlOrScope(theEnv,OBJECT_TYPE_NAME);
else
{
DATA_OBJECT tmp;
if (EnvArgTypeCheck(theEnv,"browse-classes",1,SYMBOL,&tmp) == FALSE)
return;
cls = LookupDefclassByMdlOrScope(theEnv,DOToString(tmp));
if (cls == NULL)
{
ClassExistError(theEnv,"browse-classes",DOToString(tmp));
return;
}
}
EnvBrowseClasses(theEnv,WDISPLAY,(void *) cls);
}
/******************************************************
NAME : CheckTwoClasses
DESCRIPTION : Checks for exactly two class arguments
for a H/L function
INPUTS : 1) The function name
2) Caller's buffer for first class
3) Caller's buffer for second class
RETURNS : True if both found, false otherwise
SIDE EFFECTS : Caller's buffers set
NOTES : Assumes exactly 2 arguments
******************************************************/
static bool CheckTwoClasses(
UDFContext *context,
const char *func,
Defclass **c1,
Defclass **c2)
{
UDFValue theArg;
Environment *theEnv = context->environment;
if (! UDFFirstArgument(context,SYMBOL_BIT,&theArg))
{ return false; }
*c1 = LookupDefclassByMdlOrScope(theEnv,theArg.lexemeValue->contents);
if (*c1 == NULL)
{
ClassExistError(theEnv,func,theArg.lexemeValue->contents);
return false;
}
if (! UDFNextArgument(context,SYMBOL_BIT,&theArg))
{ return false; }
*c2 = LookupDefclassByMdlOrScope(theEnv,theArg.lexemeValue->contents);
if (*c2 == NULL)
{
ClassExistError(theEnv,func,theArg.lexemeValue->contents);
return false;
}
return true;
}
/****************************************************************
NAME : BrowseClassesCommand
DESCRIPTION : Displays a "graph" of the class hierarchy
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : None
NOTES : Syntax : (browse-classes [<class>])
****************************************************************/
void BrowseClassesCommand(
Environment *theEnv,
UDFContext *context,
UDFValue *returnValue)
{
Defclass *cls;
if (UDFArgumentCount(context) == 0)
/* ================================================
Find the OBJECT root class (has no superclasses)
================================================ */
cls = LookupDefclassByMdlOrScope(theEnv,OBJECT_TYPE_NAME);
else
{
UDFValue theArg;
if (! UDFFirstArgument(context,SYMBOL_BIT,&theArg))
return;
cls = LookupDefclassByMdlOrScope(theEnv,theArg.lexemeValue->contents);
if (cls == NULL)
{
ClassExistError(theEnv,"browse-classes",theArg.lexemeValue->contents);
return;
}
}
BrowseClasses(cls,STDOUT);
}
/******************************************************
NAME : CheckTwoClasses
DESCRIPTION : Checks for exactly two class arguments
for a H/L function
INPUTS : 1) The function name
2) Caller's buffer for first class
3) Caller's buffer for second class
RETURNS : TRUE if both found, FALSE otherwise
SIDE EFFECTS : Caller's buffers set
NOTES : Assumes exactly 2 arguments
******************************************************/
static int CheckTwoClasses(
void *theEnv,
char *func,
DEFCLASS **c1,
DEFCLASS **c2)
{
DATA_OBJECT temp;
if (EnvArgTypeCheck(theEnv,func,1,SYMBOL,&temp) == FALSE)
return(FALSE);
*c1 = LookupDefclassByMdlOrScope(theEnv,DOToString(temp));
if (*c1 == NULL)
{
ClassExistError(theEnv,func,ValueToString(temp.value));
return(FALSE);
}
if (EnvArgTypeCheck(theEnv,func,2,SYMBOL,&temp) == FALSE)
return(FALSE);
*c2 = LookupDefclassByMdlOrScope(theEnv,DOToString(temp));
if (*c2 == NULL)
{
ClassExistError(theEnv,func,ValueToString(temp.value));
return(FALSE);
}
return(TRUE);
}
/************************************************************************************
NAME : MessageHandlerExistPCommand
DESCRIPTION : Determines if a message-handler is present in a class
INPUTS : None
RETURNS : TRUE if the message header is present, FALSE otherwise
SIDE EFFECTS : None
NOTES : H/L Syntax : (message-handler-existp <class> <hnd> [<type>])
************************************************************************************/
globle int MessageHandlerExistPCommand(
void *theEnv)
{
DEFCLASS *cls;
SYMBOL_HN *mname;
DATA_OBJECT temp;
unsigned mtype = MPRIMARY;
if (EnvArgTypeCheck(theEnv,"message-handler-existp",1,SYMBOL,&temp) == FALSE)
return(FALSE);
cls = LookupDefclassByMdlOrScope(theEnv,DOToString(temp));
if (cls == NULL)
{
ClassExistError(theEnv,"message-handler-existp",DOToString(temp));
return(FALSE);
}
if (EnvArgTypeCheck(theEnv,"message-handler-existp",2,SYMBOL,&temp) == FALSE)
return(FALSE);
mname = (SYMBOL_HN *) GetValue(temp);
if (EnvRtnArgCount(theEnv) == 3)
{
if (EnvArgTypeCheck(theEnv,"message-handler-existp",3,SYMBOL,&temp) == FALSE)
return(FALSE);
mtype = HandlerType(theEnv,"message-handler-existp",DOToString(temp));
if (mtype == MERROR)
{
SetEvaluationError(theEnv,TRUE);
return(FALSE);
}
}
if (FindHandlerByAddress(cls,mname,mtype) != NULL)
return(TRUE);
return(FALSE);
}
/***************************************************
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
CHANGES : It's now possible to create an instance of a
class that's not in scope if the module name
is specified.
***************************************************/
static intBool ReplaceClassNameWithReference(
void *theEnv,
EXPRESSION *theExp)
{
const char *theClassName;
void *theDefclass;
if (theExp->type == SYMBOL)
{
theClassName = ValueToString(theExp->value);
//theDefclass = (void *) LookupDefclassInScope(theEnv,theClassName);
theDefclass = (void *) LookupDefclassByMdlOrScope(theEnv,theClassName); // Module or scope is now allowed
if (theDefclass == NULL)
{
CantFindItemErrorMessage(theEnv,"class",theClassName);
return(FALSE);
}
if (EnvClassAbstractP(theEnv,theDefclass))
{
PrintErrorID(theEnv,"INSMNGR",3,FALSE);
EnvPrintRouter(theEnv,WERROR,"Cannot create instances of abstract class ");
EnvPrintRouter(theEnv,WERROR,theClassName);
EnvPrintRouter(theEnv,WERROR,".\n");
return(FALSE);
}
theExp->type = DEFCLASS_PTR;
theExp->value = theDefclass;
#if (! RUN_TIME) && (! BLOAD_ONLY)
if (! ConstructData(theEnv)->ParsingConstruct)
{ ConstructData(theEnv)->DanglingConstructs++; }
#endif
}
return(TRUE);
}
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 : ClassExistPCommand
DESCRIPTION : Determines if a class exists
INPUTS : None
RETURNS : TRUE if class exists, FALSE otherwise
SIDE EFFECTS : None
NOTES : H/L Syntax : (class-existp <arg>)
********************************************************/
globle intBool ClassExistPCommand(
void *theEnv)
{
DATA_OBJECT temp;
if (EnvArgTypeCheck(theEnv,"class-existp",1,SYMBOL,&temp) == FALSE)
return(FALSE);
return((LookupDefclassByMdlOrScope(theEnv,DOToString(temp)) != NULL) ? TRUE : FALSE);
}
/********************************************************
NAME : ClassExistPCommand
DESCRIPTION : Determines if a class exists
INPUTS : None
RETURNS : True if class exists, false otherwise
SIDE EFFECTS : None
NOTES : H/L Syntax : (class-existp <arg>)
********************************************************/
void ClassExistPCommand(
Environment *theEnv,
UDFContext *context,
UDFValue *returnValue)
{
UDFValue theArg;
if (! UDFFirstArgument(context,SYMBOL_BIT,&theArg))
{ return; }
returnValue->lexemeValue = CreateBoolean(theEnv,((LookupDefclassByMdlOrScope(theEnv,theArg.lexemeValue->contents) != NULL) ? true : false));
}
/*****************************************************
NAME : CheckClass
DESCRIPTION : Used for to check class name for
class accessor functions such
as ppdefclass and undefclass
INPUTS : 1) The name of the H/L function
2) Name of the class
RETURNS : The class address,
or NULL if ther was an error
SIDE EFFECTS : None
NOTES : None
******************************************************/
static Defclass *CheckClass(
Environment *theEnv,
const char *func,
const char *cname)
{
Defclass *cls;
cls = LookupDefclassByMdlOrScope(theEnv,cname);
if (cls == NULL)
ClassExistError(theEnv,func,cname);
return(cls);
}
/*****************************************************
NAME : CheckClass
DESCRIPTION : Used for to check class name for
class accessor functions such
as ppdefclass and undefclass
INPUTS : 1) The name of the H/L function
2) Name of the class
RETURNS : The class address,
or NULL if ther was an error
SIDE EFFECTS : None
NOTES : None
******************************************************/
static DEFCLASS *CheckClass(
void *theEnv,
char *func,
char *cname)
{
DEFCLASS *cls;
cls = LookupDefclassByMdlOrScope(theEnv,cname);
if (cls == NULL)
ClassExistError(theEnv,func,cname);
return(cls);
}
/*******************************************************************************
NAME : PPDefmessageHandlerCommand
DESCRIPTION : Displays the pretty-print form (if any) for a handler
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : None
NOTES : H/L Syntax: (ppdefmessage-handler <class> <message> [<type>])
*******************************************************************************/
globle void PPDefmessageHandlerCommand(
void *theEnv)
{
DATA_OBJECT temp;
SYMBOL_HN *csym,*msym;
const char *tname;
DEFCLASS *cls = NULL;
unsigned mtype;
HANDLER *hnd;
if (EnvArgTypeCheck(theEnv,"ppdefmessage-handler",1,SYMBOL,&temp) == FALSE)
return;
csym = FindSymbolHN(theEnv,DOToString(temp));
if (EnvArgTypeCheck(theEnv,"ppdefmessage-handler",2,SYMBOL,&temp) == FALSE)
return;
msym = FindSymbolHN(theEnv,DOToString(temp));
if (EnvRtnArgCount(theEnv) == 3)
{
if (EnvArgTypeCheck(theEnv,"ppdefmessage-handler",3,SYMBOL,&temp) == FALSE)
return;
tname = DOToString(temp);
}
else
tname = MessageHandlerData(theEnv)->hndquals[MPRIMARY];
mtype = HandlerType(theEnv,"ppdefmessage-handler",tname);
if (mtype == MERROR)
{
EnvSetEvaluationError(theEnv,TRUE);
return;
}
if (csym != NULL)
cls = LookupDefclassByMdlOrScope(theEnv,ValueToString(csym));
if (((cls == NULL) || (msym == NULL)) ? TRUE :
((hnd = FindHandlerByAddress(cls,msym,(unsigned) mtype)) == NULL))
{
PrintErrorID(theEnv,"MSGCOM",2,FALSE);
EnvPrintRouter(theEnv,WERROR,"Unable to find message-handler ");
EnvPrintRouter(theEnv,WERROR,ValueToString(msym));
EnvPrintRouter(theEnv,WERROR," ");
EnvPrintRouter(theEnv,WERROR,tname);
EnvPrintRouter(theEnv,WERROR," for class ");
EnvPrintRouter(theEnv,WERROR,ValueToString(csym));
EnvPrintRouter(theEnv,WERROR," in function ppdefmessage-handler.\n");
EnvSetEvaluationError(theEnv,TRUE);
return;
}
if (hnd->ppForm != NULL)
PrintInChunks(theEnv,WDISPLAY,hnd->ppForm);
}
/*********************************************************************
NAME : ClassAbstractPCommand
DESCRIPTION : Determines if direct instances of a class can be made
INPUTS : None
RETURNS : TRUE (1) if class is abstract, FALSE (0) if concrete
SIDE EFFECTS : None
NOTES : Syntax: (class-abstractp <class>)
*********************************************************************/
globle int ClassAbstractPCommand()
{
DATA_OBJECT tmp;
DEFCLASS *cls;
if (ArgTypeCheck("class-abstractp",1,SYMBOL,&tmp) == FALSE)
return(FALSE);
cls = LookupDefclassByMdlOrScope(DOToString(tmp));
if (cls == NULL)
{
ClassExistError("class-abstractp",ValueToString(tmp.value));
return(FALSE);
}
return(ClassAbstractP((void *) cls));
}
/*****************************************************************
NAME : ClassReactivePCommand
DESCRIPTION : Determines if instances of a class can match rule
patterns
INPUTS : None
RETURNS : TRUE (1) if class is reactive, FALSE (0)
if non-reactive
SIDE EFFECTS : None
NOTES : Syntax: (class-reactivep <class>)
*****************************************************************/
globle int ClassReactivePCommand(
void *theEnv)
{
DATA_OBJECT tmp;
DEFCLASS *cls;
if (EnvArgTypeCheck(theEnv,"class-reactivep",1,SYMBOL,&tmp) == FALSE)
return(FALSE);
cls = LookupDefclassByMdlOrScope(theEnv,DOToString(tmp));
if (cls == NULL)
{
ClassExistError(theEnv,"class-reactivep",ValueToString(tmp.value));
return(FALSE);
}
return(EnvClassReactiveP(theEnv,(void *) cls));
}
/******************************************************************************
NAME : UndefmessageHandlerCommand
DESCRIPTION : Deletes a handler from a class
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : Handler deleted if possible
NOTES : H/L Syntax: (undefmessage-handler <class> <handler> [<type>])
******************************************************************************/
globle void UndefmessageHandlerCommand(
void *theEnv)
{
#if RUN_TIME || BLOAD_ONLY
PrintErrorID(theEnv,"MSGCOM",3,FALSE);
EnvPrintRouter(theEnv,WERROR,"Unable to delete message-handlers.\n");
#else
SYMBOL_HN *mname;
const char *tname;
DATA_OBJECT tmp;
DEFCLASS *cls;
#if BLOAD || BLOAD_AND_BSAVE
if (Bloaded(theEnv))
{
PrintErrorID(theEnv,"MSGCOM",3,FALSE);
EnvPrintRouter(theEnv,WERROR,"Unable to delete message-handlers.\n");
return;
}
#endif
if (EnvArgTypeCheck(theEnv,"undefmessage-handler",1,SYMBOL,&tmp) == FALSE)
return;
cls = LookupDefclassByMdlOrScope(theEnv,DOToString(tmp));
if ((cls == NULL) ? (strcmp(DOToString(tmp),"*") != 0) : FALSE)
{
ClassExistError(theEnv,"undefmessage-handler",DOToString(tmp));
return;
}
if (EnvArgTypeCheck(theEnv,"undefmessage-handler",2,SYMBOL,&tmp) == FALSE)
return;
mname = (SYMBOL_HN *) tmp.value;
if (EnvRtnArgCount(theEnv) == 3)
{
if (EnvArgTypeCheck(theEnv,"undefmessage-handler",3,SYMBOL,&tmp) == FALSE)
return;
tname = DOToString(tmp);
if (strcmp(tname,"*") == 0)
tname = NULL;
}
else
tname = MessageHandlerData(theEnv)->hndquals[MPRIMARY];
WildDeleteHandler(theEnv,cls,mname,tname);
#endif
}
/************************************************************************************
NAME : MessageHandlerExistPCommand
DESCRIPTION : Determines if a message-handler is present in a class
INPUTS : None
RETURNS : True if the message header is present, false otherwise
SIDE EFFECTS : None
NOTES : H/L Syntax : (message-handler-existp <class> <hnd> [<type>])
************************************************************************************/
void MessageHandlerExistPCommand(
Environment *theEnv,
UDFContext *context,
UDFValue *returnValue)
{
Defclass *cls;
CLIPSLexeme *mname;
UDFValue theArg;
unsigned mtype = MPRIMARY;
if (! UDFFirstArgument(context,SYMBOL_BIT,&theArg))
{ return; }
cls = LookupDefclassByMdlOrScope(theEnv,theArg.lexemeValue->contents);
if (cls == NULL)
{
ClassExistError(theEnv,"message-handler-existp",theArg.lexemeValue->contents);
returnValue->lexemeValue = FalseSymbol(theEnv);
return;
}
if (! UDFNextArgument(context,SYMBOL_BIT,&theArg))
{ return; }
mname = theArg.lexemeValue;
if (UDFHasNextArgument(context))
{
if (! UDFNextArgument(context,SYMBOL_BIT,&theArg))
{ return; }
mtype = HandlerType(theEnv,"message-handler-existp",true,theArg.lexemeValue->contents);
if (mtype == MERROR)
{
SetEvaluationError(theEnv,true);
returnValue->lexemeValue = FalseSymbol(theEnv);
return;
}
}
if (FindHandlerByAddress(cls,mname,mtype) != NULL)
{ returnValue->lexemeValue = TrueSymbol(theEnv); }
else
{ returnValue->lexemeValue = FalseSymbol(theEnv); }
}
/********************************************************************
NAME : CheckClassAndSlot
DESCRIPTION : Checks class and slot argument for various functions
INPUTS : 1) Name of the calling function
2) Buffer for class address
RETURNS : Slot symbol, NULL on errors
SIDE EFFECTS : None
NOTES : None
********************************************************************/
globle SYMBOL_HN *CheckClassAndSlot(
void *theEnv,
const char *func,
DEFCLASS **cls)
{
DATA_OBJECT temp;
if (EnvArgTypeCheck(theEnv,func,1,SYMBOL,&temp) == FALSE)
return(NULL);
*cls = LookupDefclassByMdlOrScope(theEnv,DOToString(temp));
if (*cls == NULL)
{
ClassExistError(theEnv,func,DOToString(temp));
return(NULL);
}
if (EnvArgTypeCheck(theEnv,func,2,SYMBOL,&temp) == FALSE)
return(NULL);
return((SYMBOL_HN *) GetValue(temp));
}
/********************************************************************
NAME : PreviewSendCommand
DESCRIPTION : Displays a list of the core for a message describing
shadows,etc.
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : Temporary core created and destroyed
NOTES : H/L Syntax: (preview-send <class> <msg>)
********************************************************************/
globle void PreviewSendCommand()
{
DEFCLASS *cls;
DATA_OBJECT temp;
/* =============================
Get the class for the message
============================= */
if (ArgTypeCheck("preview-send",1,SYMBOL,&temp) == FALSE)
return;
cls = LookupDefclassByMdlOrScope(DOToString(temp));
if (cls == NULL)
{
ClassExistError("preview-send",ValueToString(temp.value));
return;
}
if (ArgTypeCheck("preview-send",2,SYMBOL,&temp) == FALSE)
return;
PreviewSend(WDISPLAY,(void *) cls,DOToString(temp));
}
/***************************************************
NAME : ReplaceClassNameWithReference
DESCRIPTION : In parsing an instance-set query,
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 and imported
modules for reference
***************************************************/
static BOOLEAN ReplaceClassNameWithReference(
void *theEnv,
EXPRESSION *theExp)
{
char *theClassName;
void *theDefclass;
if (theExp->type == SYMBOL)
{
theClassName = ValueToString(theExp->value);
theDefclass = (void *) LookupDefclassByMdlOrScope(theEnv,theClassName);
if (theDefclass == NULL)
{
CantFindItemErrorMessage(theEnv,"class",theClassName);
return(FALSE);
}
theExp->type = DEFCLASS_PTR;
theExp->value = theDefclass;
}
return(TRUE);
}
/***********************************************************
NAME : ClassInfoFnxArgs
DESCRIPTION : Examines arguments for:
class-slots, get-defmessage-handler-list,
class-superclasses and class-subclasses
INPUTS : 1) Name of function
2) A buffer to hold a flag indicating if
the inherit keyword was specified
RETURNS : Pointer to the class on success,
NULL on errors
SIDE EFFECTS : inhp flag set
error flag set
NOTES : None
***********************************************************/
globle void *ClassInfoFnxArgs(
void *theEnv,
const char *fnx,
int *inhp)
{
void *clsptr;
DATA_OBJECT tmp;
*inhp = 0;
if (EnvRtnArgCount(theEnv) == 0)
{
ExpectedCountError(theEnv,fnx,AT_LEAST,1);
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
if (EnvArgTypeCheck(theEnv,fnx,1,SYMBOL,&tmp) == FALSE)
return(NULL);
clsptr = (void *) LookupDefclassByMdlOrScope(theEnv,DOToString(tmp));
if (clsptr == NULL)
{
ClassExistError(theEnv,fnx,ValueToString(tmp.value));
return(NULL);
}
if (EnvRtnArgCount(theEnv) == 2)
{
if (EnvArgTypeCheck(theEnv,fnx,2,SYMBOL,&tmp) == FALSE)
return(NULL);
if (strcmp(ValueToString(tmp.value),"inherit") == 0)
*inhp = 1;
else
{
SyntaxErrorMessage(theEnv,fnx);
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
}
return(clsptr);
}
globle intBool CheckAllowedClassesConstraint(
void *theEnv,
int type,
void *vPtr,
CONSTRAINT_RECORD *constraints)
{
#if OBJECT_SYSTEM
struct expr *tmpPtr;
INSTANCE_TYPE *ins;
DEFCLASS *insClass, *cmpClass;
/*=========================================*/
/* If the constraint record is NULL, there */
/* is no allowed-classes restriction. */
/*=========================================*/
if (constraints == NULL) return(TRUE);
/*======================================*/
/* The constraint is satisfied if there */
/* aren't any class restrictions. */
/*======================================*/
if (constraints->classList == NULL)
{ return(TRUE); }
/*==================================*/
/* Class restrictions only apply to */
/* instances and instance names. */
/*==================================*/
if ((type != INSTANCE_ADDRESS) && (type != INSTANCE_NAME))
{ return(TRUE); }
/*=============================================*/
/* If an instance name is specified, determine */
/* whether the instance exists. */
/*=============================================*/
if (type == INSTANCE_ADDRESS)
{ ins = (INSTANCE_TYPE *) vPtr; }
else
{ ins = FindInstanceBySymbol(theEnv,(SYMBOL_HN *) vPtr); }
if (ins == NULL)
{ return(FALSE); }
/*======================================================*/
/* Search through the class list to see if the instance */
/* belongs to one of the allowed classes in the list. */
/*======================================================*/
insClass = (DEFCLASS *) EnvGetInstanceClass(theEnv,ins);
for (tmpPtr = constraints->classList;
tmpPtr != NULL;
tmpPtr = tmpPtr->nextArg)
{
//cmpClass = (DEFCLASS *) EnvFindDefclass(theEnv,ValueToString(tmpPtr->value));
cmpClass = (DEFCLASS *) LookupDefclassByMdlOrScope(theEnv,ValueToString(tmpPtr->value));
if (cmpClass == NULL) continue;
if (cmpClass == insClass) return(TRUE);
if (EnvSubclassP(theEnv,insClass,cmpClass)) return(TRUE);
}
/*=========================================================*/
/* If a parent class wasn't found in the list, then return */
/* FALSE because the constraint has been violated. */
/*=========================================================*/
return(FALSE);
#else
#if MAC_XCD
#pragma unused(theEnv)
#pragma unused(type)
#pragma unused(vPtr)
#pragma unused(constraints)
#endif
return(TRUE);
#endif
}
/*******************************************************
NAME : DefmessageHandlerWatchSupport
DESCRIPTION : Sets or displays handlers specified
INPUTS : 1) The calling function name
2) The logical output name for displays
(can be NULL)
4) The new set state (can be -1)
5) The print function (can be NULL)
6) The trace function (can be NULL)
7) The handlers expression list
RETURNS : TRUE if all OK,
FALSE otherwise
SIDE EFFECTS : Handler trace flags set or displayed
NOTES : None
*******************************************************/
static unsigned DefmessageHandlerWatchSupport(
void *theEnv,
const char *funcName,
const char *logName,
int newState,
void (*printFunc)(void *,const char *,void *,int),
void (*traceFunc)(void *,int,void *,int),
EXPRESSION *argExprs)
{
struct defmodule *theModule;
void *theClass;
const char *theHandlerStr;
int theType;
int argIndex = 2;
DATA_OBJECT tmpData;
/* ===============================
If no handlers are specified,
show the trace for all handlers
in all handlers
=============================== */
if (argExprs == NULL)
{
SaveCurrentModule(theEnv);
theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,NULL);
while (theModule != NULL)
{
EnvSetCurrentModule(theEnv,(void *) theModule);
if (traceFunc == NULL)
{
EnvPrintRouter(theEnv,logName,EnvGetDefmoduleName(theEnv,(void *) theModule));
EnvPrintRouter(theEnv,logName,":\n");
}
theClass = EnvGetNextDefclass(theEnv,NULL);
while (theClass != NULL)
{
if (WatchClassHandlers(theEnv,theClass,NULL,-1,logName,newState,
TRUE,printFunc,traceFunc) == FALSE)
return(FALSE);
theClass = EnvGetNextDefclass(theEnv,theClass);
}
theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,(void *) theModule);
}
RestoreCurrentModule(theEnv);
return(TRUE);
}
/* ================================================
Set or show the traces for the specified handler
================================================ */
while (argExprs != NULL)
{
if (EvaluateExpression(theEnv,argExprs,&tmpData))
return(FALSE);
if (tmpData.type != SYMBOL)
{
ExpectedTypeError1(theEnv,funcName,argIndex,"class name");
return(FALSE);
}
theClass = (void *) LookupDefclassByMdlOrScope(theEnv,DOToString(tmpData));
if (theClass == NULL)
{
ExpectedTypeError1(theEnv,funcName,argIndex,"class name");
return(FALSE);
}
if (GetNextArgument(argExprs) != NULL)
{
argExprs = GetNextArgument(argExprs);
argIndex++;
if (EvaluateExpression(theEnv,argExprs,&tmpData))
return(FALSE);
if (tmpData.type != SYMBOL)
{
ExpectedTypeError1(theEnv,funcName,argIndex,"handler name");
return(FALSE);
}
theHandlerStr = DOToString(tmpData);
if (GetNextArgument(argExprs) != NULL)
{
argExprs = GetNextArgument(argExprs);
argIndex++;
if (EvaluateExpression(theEnv,argExprs,&tmpData))
return(FALSE);
if (tmpData.type != SYMBOL)
{
ExpectedTypeError1(theEnv,funcName,argIndex,"handler type");
return(FALSE);
}
if ((theType = (int) HandlerType(theEnv,funcName,DOToString(tmpData))) == MERROR)
return(FALSE);
}
else
theType = -1;
}
else
{
theHandlerStr = NULL;
theType = -1;
}
if (WatchClassHandlers(theEnv,theClass,theHandlerStr,theType,logName,
newState,FALSE,printFunc,traceFunc) == FALSE)
{
ExpectedTypeError1(theEnv,funcName,argIndex,"handler");
return(FALSE);
}
argIndex++;
argExprs = GetNextArgument(argExprs);
}
return(TRUE);
}
/***************************************************
NAME : ObjectsRunTimeInitialize
DESCRIPTION : Initializes objects system lists
in a run-time module
INPUTS : 1) Pointer to new class hash table
2) Pointer to new slot name table
RETURNS : Nothing useful
SIDE EFFECTS : Global pointers set
NOTES : None
***************************************************/
globle void ObjectsRunTimeInitialize(
void *theEnv,
DEFCLASS *ctable[],
SLOT_NAME *sntable[],
DEFCLASS **cidmap,
unsigned mid)
{
DEFCLASS *cls;
void *tmpexp;
register unsigned int i,j;
if (DefclassData(theEnv)->ClassTable != NULL)
{
for (j = 0 ; j < CLASS_TABLE_HASH_SIZE ; j++)
for (cls = DefclassData(theEnv)->ClassTable[j] ; cls != NULL ; cls = cls->nxtHash)
{
for (i = 0 ; i < cls->slotCount ; i++)
{
/* =====================================================================
For static default values, the data object value needs to deinstalled
and deallocated, and the expression needs to be restored (which was
temporarily stored in the supplementalInfo field of the data object)
===================================================================== */
if ((cls->slots[i].defaultValue != NULL) && (cls->slots[i].dynamicDefault == 0))
{
tmpexp = ((DATA_OBJECT *) cls->slots[i].defaultValue)->supplementalInfo;
ValueDeinstall(theEnv,(DATA_OBJECT *) cls->slots[i].defaultValue);
rtn_struct(theEnv,dataObject,cls->slots[i].defaultValue);
cls->slots[i].defaultValue = tmpexp;
}
}
}
}
InstanceQueryData(theEnv)->QUERY_DELIMETER_SYMBOL = FindSymbolHN(theEnv,QUERY_DELIMETER_STRING);
MessageHandlerData(theEnv)->INIT_SYMBOL = FindSymbolHN(theEnv,INIT_STRING);
MessageHandlerData(theEnv)->DELETE_SYMBOL = FindSymbolHN(theEnv,DELETE_STRING);
MessageHandlerData(theEnv)->CREATE_SYMBOL = FindSymbolHN(theEnv,CREATE_STRING);
DefclassData(theEnv)->ISA_SYMBOL = FindSymbolHN(theEnv,SUPERCLASS_RLN);
DefclassData(theEnv)->NAME_SYMBOL = FindSymbolHN(theEnv,NAME_RLN);
#if DEFRULE_CONSTRUCT
DefclassData(theEnv)->INITIAL_OBJECT_SYMBOL = FindSymbolHN(theEnv,INITIAL_OBJECT_NAME);
#endif
DefclassData(theEnv)->ClassTable = (DEFCLASS **) ctable;
DefclassData(theEnv)->SlotNameTable = (SLOT_NAME **) sntable;
DefclassData(theEnv)->ClassIDMap = (DEFCLASS **) cidmap;
DefclassData(theEnv)->MaxClassID = (unsigned short) mid;
DefclassData(theEnv)->PrimitiveClassMap[FLOAT] =
LookupDefclassByMdlOrScope(theEnv,FLOAT_TYPE_NAME);
DefclassData(theEnv)->PrimitiveClassMap[INTEGER] =
LookupDefclassByMdlOrScope(theEnv,INTEGER_TYPE_NAME);
DefclassData(theEnv)->PrimitiveClassMap[STRING] =
LookupDefclassByMdlOrScope(theEnv,STRING_TYPE_NAME);
DefclassData(theEnv)->PrimitiveClassMap[SYMBOL] =
LookupDefclassByMdlOrScope(theEnv,SYMBOL_TYPE_NAME);
DefclassData(theEnv)->PrimitiveClassMap[MULTIFIELD] =
LookupDefclassByMdlOrScope(theEnv,MULTIFIELD_TYPE_NAME);
DefclassData(theEnv)->PrimitiveClassMap[EXTERNAL_ADDRESS] =
LookupDefclassByMdlOrScope(theEnv,EXTERNAL_ADDRESS_TYPE_NAME);
DefclassData(theEnv)->PrimitiveClassMap[FACT_ADDRESS] =
LookupDefclassByMdlOrScope(theEnv,FACT_ADDRESS_TYPE_NAME);
DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME] =
LookupDefclassByMdlOrScope(theEnv,INSTANCE_NAME_TYPE_NAME);
DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_ADDRESS] =
LookupDefclassByMdlOrScope(theEnv,INSTANCE_ADDRESS_TYPE_NAME);
for (j = 0 ; j < CLASS_TABLE_HASH_SIZE ; j++)
for (cls = DefclassData(theEnv)->ClassTable[j] ; cls != NULL ; cls = cls->nxtHash)
{
for (i = 0 ; i < cls->slotCount ; i++)
{
if ((cls->slots[i].defaultValue != NULL) && (cls->slots[i].dynamicDefault == 0))
{
tmpexp = cls->slots[i].defaultValue;
cls->slots[i].defaultValue = (void *) get_struct(theEnv,dataObject);
EvaluateAndStoreInDataObject(theEnv,(int) cls->slots[i].multiple,(EXPRESSION *) tmpexp,
(DATA_OBJECT *) cls->slots[i].defaultValue,TRUE);
ValueInstall(theEnv,(DATA_OBJECT *) cls->slots[i].defaultValue);
((DATA_OBJECT *) cls->slots[i].defaultValue)->supplementalInfo = tmpexp;
}
}
}
SearchForHashedPatternNodes(theEnv,ObjectReteData(theEnv)->ObjectPatternNetworkPointer);
}
/*************************************************************
NAME : FormChain
DESCRIPTION : Builds a list of classes to be used in
instance queries - uses parse form.
INPUTS : 1) Name of calling function for error msgs
2) Data object - must be a symbol or a
multifield value containing all symbols
The symbols must be names of existing classes
RETURNS : The query chain, or NULL on errors
SIDE EFFECTS : Memory allocated for chain
Busy count incremented for all classes
NOTES : None
*************************************************************/
static QUERY_CLASS *FormChain(
void *theEnv,
EXEC_STATUS,
char *func,
DATA_OBJECT *val)
{
DEFCLASS *cls;
QUERY_CLASS *head,*bot,*tmp;
register long i,end; /* 6.04 Bug Fix */
char *className;
struct defmodule *currentModule;
currentModule = ((struct defmodule *) EnvGetCurrentModule(theEnv,execStatus));
if (val->type == DEFCLASS_PTR)
{
IncrementDefclassBusyCount(theEnv,execStatus,(void *) val->value);
head = get_struct(theEnv,execStatus,query_class);
head->cls = (DEFCLASS *) val->value;
if (DefclassInScope(theEnv,execStatus,head->cls,currentModule))
head->theModule = currentModule;
else
head->theModule = head->cls->header.whichModule->theModule;
head->chain = NULL;
head->nxt = NULL;
return(head);
}
if (val->type == SYMBOL)
{
/* ===============================================
Allow instance-set query restrictions to have a
module specifier as part of the class name,
but search imported defclasses too if a
module specifier is not given
=============================================== */
cls = LookupDefclassByMdlOrScope(theEnv,execStatus,DOPToString(val));
if (cls == NULL)
{
ClassExistError(theEnv,execStatus,func,DOPToString(val));
return(NULL);
}
IncrementDefclassBusyCount(theEnv,execStatus,(void *) cls);
head = get_struct(theEnv,execStatus,query_class);
head->cls = cls;
if (DefclassInScope(theEnv,execStatus,head->cls,currentModule))
head->theModule = currentModule;
else
head->theModule = head->cls->header.whichModule->theModule;
head->chain = NULL;
head->nxt = NULL;
return(head);
}
if (val->type == MULTIFIELD)
{
head = bot = NULL;
end = GetpDOEnd(val);
for (i = GetpDOBegin(val) ; i <= end ; i++)
{
if (GetMFType(val->value,i) == SYMBOL)
{
className = ValueToString(GetMFValue(val->value,i));
cls = LookupDefclassByMdlOrScope(theEnv,execStatus,className);
if (cls == NULL)
{
ClassExistError(theEnv,execStatus,func,className);
DeleteQueryClasses(theEnv,execStatus,head);
return(NULL);
}
}
else
{
DeleteQueryClasses(theEnv,execStatus,head);
return(NULL);
}
IncrementDefclassBusyCount(theEnv,execStatus,(void *) cls);
tmp = get_struct(theEnv,execStatus,query_class);
tmp->cls = cls;
if (DefclassInScope(theEnv,execStatus,tmp->cls,currentModule))
tmp->theModule = currentModule;
else
tmp->theModule = tmp->cls->header.whichModule->theModule;
tmp->chain = NULL;
tmp->nxt = NULL;
if (head == NULL)
head = tmp;
else
bot->chain = tmp;
bot = tmp;
}
return(head);
}
return(NULL);
}
/***********************************************************************
NAME : ParseDefmessageHandler
DESCRIPTION : Parses a message-handler for a class of objects
INPUTS : The logical name of the input source
RETURNS : FALSE if successful parse, TRUE otherwise
SIDE EFFECTS : Handler allocated and inserted into class
NOTES : H/L Syntax:
(defmessage-handler <class> <name> [<type>] [<comment>]
(<params>)
<action>*)
<params> ::= <var>* | <var>* $?<name>
***********************************************************************/
globle int ParseDefmessageHandler(
void *theEnv,
char *readSource)
{
DEFCLASS *cls;
SYMBOL_HN *cname,*mname,*wildcard;
unsigned mtype = MPRIMARY;
int min,max,error,lvars;
EXPRESSION *hndParams,*actions;
HANDLER *hnd;
SetPPBufferStatus(theEnv,ON);
FlushPPBuffer(theEnv);
SetIndentDepth(theEnv,3);
SavePPBuffer(theEnv,"(defmessage-handler ");
#if BLOAD || BLOAD_AND_BSAVE
if ((Bloaded(theEnv)) && (! ConstructData(theEnv)->CheckSyntaxMode))
{
CannotLoadWithBloadMessage(theEnv,"defmessage-handler");
return(TRUE);
}
#endif
cname = GetConstructNameAndComment(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken,"defmessage-handler",
NULL,NULL,"~",TRUE,FALSE,DEFMODULE_CONSTRUCT);
if (cname == NULL)
return(TRUE);
cls = LookupDefclassByMdlOrScope(theEnv,ValueToString(cname));
if (cls == NULL)
{
PrintErrorID(theEnv,"MSGPSR",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"A class must be defined before its message-handlers.\n");
return(TRUE);
}
if ((cls == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME]) ||
(cls == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_ADDRESS]) ||
(cls == DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME]->directSuperclasses.classArray[0]))
{
PrintErrorID(theEnv,"MSGPSR",8,FALSE);
EnvPrintRouter(theEnv,WERROR,"Message-handlers cannot be attached to the class ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefclassName(theEnv,(void *) cls));
EnvPrintRouter(theEnv,WERROR,".\n");
return(TRUE);
}
if (HandlersExecuting(cls))
{
PrintErrorID(theEnv,"MSGPSR",2,FALSE);
EnvPrintRouter(theEnv,WERROR,"Cannot (re)define message-handlers during execution of \n");
EnvPrintRouter(theEnv,WERROR," other message-handlers for the same class.\n");
return(TRUE);
}
if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL)
{
SyntaxErrorMessage(theEnv,"defmessage-handler");
return(TRUE);
}
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv," ");
SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm);
SavePPBuffer(theEnv," ");
mname = (SYMBOL_HN *) GetValue(DefclassData(theEnv)->ObjectParseToken);
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
if (GetType(DefclassData(theEnv)->ObjectParseToken) != LPAREN)
{
SavePPBuffer(theEnv," ");
if (GetType(DefclassData(theEnv)->ObjectParseToken) != STRING)
{
if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL)
{
SyntaxErrorMessage(theEnv,"defmessage-handler");
return(TRUE);
}
mtype = HandlerType(theEnv,"defmessage-handler",DOToString(DefclassData(theEnv)->ObjectParseToken));
if (mtype == MERROR)
return(TRUE);
#if ! IMPERATIVE_MESSAGE_HANDLERS
if (mtype == MAROUND)
return(TRUE);
#endif
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
if (GetType(DefclassData(theEnv)->ObjectParseToken) == STRING)
{
SavePPBuffer(theEnv," ");
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
}
}
else
{
SavePPBuffer(theEnv," ");
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
}
}
PPBackup(theEnv);
PPBackup(theEnv);
PPCRAndIndent(theEnv);
SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm);
hnd = FindHandlerByAddress(cls,mname,mtype);
if (GetPrintWhileLoading(theEnv) && GetCompilationsWatch(theEnv))
{
EnvPrintRouter(theEnv,WDIALOG," Handler ");
EnvPrintRouter(theEnv,WDIALOG,ValueToString(mname));
EnvPrintRouter(theEnv,WDIALOG," ");
EnvPrintRouter(theEnv,WDIALOG,MessageHandlerData(theEnv)->hndquals[mtype]);
EnvPrintRouter(theEnv,WDIALOG,(char *) ((hnd == NULL) ? " defined.\n" : " redefined.\n"));
}
if ((hnd != NULL) ? hnd->system : FALSE)
{
PrintErrorID(theEnv,"MSGPSR",3,FALSE);
EnvPrintRouter(theEnv,WERROR,"System message-handlers may not be modified.\n");
return(TRUE);
}
hndParams = GenConstant(theEnv,SYMBOL,(void *) MessageHandlerData(theEnv)->SELF_SYMBOL);
hndParams = ParseProcParameters(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken,hndParams,
&wildcard,&min,&max,&error,IsParameterSlotReference);
if (error)
return(TRUE);
PPCRAndIndent(theEnv);
ExpressionData(theEnv)->ReturnContext = TRUE;
actions = ParseProcActions(theEnv,"message-handler",readSource,
&DefclassData(theEnv)->ObjectParseToken,hndParams,wildcard,
SlotReferenceVar,BindSlotReference,&lvars,
(void *) cls);
if (actions == NULL)
{
ReturnExpression(theEnv,hndParams);
return(TRUE);
}
if (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN)
{
SyntaxErrorMessage(theEnv,"defmessage-handler");
ReturnExpression(theEnv,hndParams);
ReturnPackedExpression(theEnv,actions);
return(TRUE);
}
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm);
SavePPBuffer(theEnv,"\n");
/* ===================================================
If we're only checking syntax, don't add the
successfully parsed defmessage-handler to the KB.
=================================================== */
if (ConstructData(theEnv)->CheckSyntaxMode)
{
ReturnExpression(theEnv,hndParams);
ReturnPackedExpression(theEnv,actions);
return(FALSE);
}
if (hnd != NULL)
{
ExpressionDeinstall(theEnv,hnd->actions);
ReturnPackedExpression(theEnv,hnd->actions);
if (hnd->ppForm != NULL)
rm(theEnv,(void *) hnd->ppForm,
(sizeof(char) * (strlen(hnd->ppForm)+1)));
}
else
{
hnd = InsertHandlerHeader(theEnv,cls,mname,(int) mtype);
IncrementSymbolCount(hnd->name);
}
ReturnExpression(theEnv,hndParams);
hnd->minParams = min;
hnd->maxParams = max;
hnd->localVarCount = lvars;
hnd->actions = actions;
ExpressionInstall(theEnv,hnd->actions);
#if DEBUGGING_FUNCTIONS
/* ===================================================
Old handler trace status is automatically preserved
=================================================== */
if (EnvGetConserveMemory(theEnv) == FALSE)
hnd->ppForm = CopyPPBuffer(theEnv);
else
#endif
hnd->ppForm = NULL;
return(FALSE);
}
