/******************************************************
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 : 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 : 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 : 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 : 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 : 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 : 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 : 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 : 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 : 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 : 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 : 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);
}
/*************************************************************
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);
}
