/**************************************************************************
NAME : CallSpecificMethod
DESCRIPTION : Allows a specific method to be called without regards to
higher precedence methods which might also be applicable
However, shadowed methods can still be called.
INPUTS : A data object buffer to hold the method evaluation result
RETURNS : Nothing useful
SIDE EFFECTS : Side-effects of method applicability tests and the
evaluation of methods
NOTES : H/L Syntax: (call-specific-method
<generic-function> <method-index> <args>)
**************************************************************************/
void CallSpecificMethod(
Environment *theEnv,
UDFContext *context,
UDFValue *returnValue)
{
UDFValue theArg;
Defgeneric *gfunc;
int mi;
returnValue->lexemeValue = FalseSymbol(theEnv);
if (! UDFFirstArgument(context,SYMBOL_BIT,&theArg)) return;
gfunc = CheckGenericExists(theEnv,"call-specific-method",theArg.lexemeValue->contents);
if (gfunc == NULL) return;
if (! UDFNextArgument(context,INTEGER_BIT,&theArg)) return;
mi = CheckMethodExists(theEnv,"call-specific-method",gfunc,(unsigned short) theArg.integerValue->contents);
if (mi == METHOD_NOT_FOUND)
return;
gfunc->methods[mi].busy++;
GenericDispatch(theEnv,gfunc,NULL,&gfunc->methods[mi],
GetFirstArgument()->nextArg->nextArg,returnValue);
gfunc->methods[mi].busy--;
}
void GetWatchItemCommand(
Environment *theEnv,
UDFContext *context,
UDFValue *returnValue)
{
UDFValue theValue;
const char *argument;
bool recognized;
/*========================================*/
/* Determine which item is to be watched. */
/*========================================*/
if (! UDFFirstArgument(context,SYMBOL_BIT,&theValue))
{ return; }
argument = theValue.lexemeValue->contents;
ValidWatchItem(theEnv,argument,&recognized);
if (recognized == false)
{
SetEvaluationError(theEnv,true);
ExpectedTypeError1(theEnv,"get-watch-item",1,"'watchable symbol'");
returnValue->lexemeValue = FalseSymbol(theEnv);
return;
}
/*===========================*/
/* Get the watch item value. */
/*===========================*/
if (GetWatchItem(theEnv,argument) == 1)
{ returnValue->lexemeValue = TrueSymbol(theEnv); }
else
{ returnValue->lexemeValue = FalseSymbol(theEnv); }
}
/**************************************************************************
NAME : CallSpecificMethod
DESCRIPTION : Allows a specific method to be called without regards to
higher precedence methods which might also be applicable
However, shadowed methods can still be called.
INPUTS : A data object buffer to hold the method evaluation result
RETURNS : Nothing useful
SIDE EFFECTS : Side-effects of method applicability tests and the
evaluation of methods
NOTES : H/L Syntax: (call-specific-method
<generic-function> <method-index> <args>)
**************************************************************************/
void CallSpecificMethod(
UDFContext *context,
CLIPSValue *returnValue)
{
CLIPSValue theArg;
DEFGENERIC *gfunc;
int mi;
Environment *theEnv = UDFContextEnvironment(context);
mCVSetBoolean(returnValue,false);
if (! UDFFirstArgument(context,SYMBOL_TYPE,&theArg)) return;
gfunc = CheckGenericExists(theEnv,"call-specific-method",mCVToString(&theArg));
if (gfunc == NULL) return;
if (! UDFNextArgument(context,INTEGER_TYPE,&theArg)) return;
mi = CheckMethodExists(theEnv,"call-specific-method",gfunc,(long) mCVToInteger(&theArg));
if (mi == -1)
return;
gfunc->methods[mi].busy++;
GenericDispatch(theEnv,gfunc,NULL,&gfunc->methods[mi],
GetFirstArgument()->nextArg->nextArg,returnValue);
gfunc->methods[mi].busy--;
}
/******************************************************
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 : GetClassNameArgument
DESCRIPTION : Gets a class name-string
INPUTS : Calling function name
RETURNS : Class name (NULL on errors)
SIDE EFFECTS : None
NOTES : Assumes only 1 argument
*********************************************************/
static const char *GetClassNameArgument(
UDFContext *context)
{
UDFValue theArg;
if (! UDFFirstArgument(context,SYMBOL_BIT,&theArg))
{ return NULL; }
return theArg.lexemeValue->contents;
}
void DivisionFunction(
UDFContext *context,
CLIPSValue *returnValue)
{
CLIPSFloat ftotal = 1.0;
CLIPSFloat theNumber;
CLIPSValue theArg;
Environment *theEnv = UDFContextEnvironment(context);
/*===================================================*/
/* Get the first argument. This number which will be */
/* the starting product from which all subsequent */
/* arguments will divide. If the auto float dividend */
/* feature is enable, then this number is converted */
/* to a float if it is an integer. */
/*===================================================*/
if (! UDFFirstArgument(context,NUMBER_TYPES,&theArg))
{ return; }
ftotal = mCVToFloat(&theArg);
/*====================================================*/
/* Loop through each of the arguments dividing it */
/* into a running product. If a floating point number */
/* is encountered, then do all subsequent operations */
/* using floating point values. Each argument is */
/* checked to prevent a divide by zero error. */
/*====================================================*/
while (UDFHasNextArgument(context))
{
if (! UDFNextArgument(context,NUMBER_TYPES,&theArg))
{ return; }
theNumber = mCVToFloat(&theArg);
if (theNumber == 0.0)
{
DivideByZeroErrorMessage(theEnv,"/");
EnvSetEvaluationError(theEnv,true);
mCVSetFloat(returnValue,1.0);
return;
}
ftotal /= theNumber;
}
/*======================================================*/
/* If a floating point number was in the argument list, */
/* then return a float, otherwise return an integer. */
/*======================================================*/
mCVSetFloat(returnValue,ftotal);
}
/********************************************************
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));
}
void DivFunction(
UDFContext *context,
CLIPSValue *returnValue)
{
CLIPSInteger total = 1LL;
DATA_OBJECT theArg;
CLIPSInteger theNumber;
void *theEnv = UDFContextEnvironment(context);
/*===================================================*/
/* Get the first argument. This number which will be */
/* the starting product from which all subsequent */
/* arguments will divide. */
/*===================================================*/
if (! UDFFirstArgument(context,NUMBER_TYPES,&theArg))
{ return; }
total = mCVToInteger(&theArg);
/*=====================================================*/
/* Loop through each of the arguments dividing it into */
/* a running product. Floats are converted to integers */
/* and each argument is checked to prevent a divide by */
/* zero error. */
/*=====================================================*/
while (UDFHasNextArgument(context))
{
if (! UDFNextArgument(context,NUMBER_TYPES,&theArg))
{ return; }
theNumber = mCVToInteger(&theArg);
if (theNumber == 0LL)
{
DivideByZeroErrorMessage(theEnv,"div");
EnvSetEvaluationError(theEnv,true);
mCVSetInteger(returnValue,1L);
return;
}
total /= theNumber;
}
/*======================================================*/
/* The result of the div function is always an integer. */
/*======================================================*/
mCVSetInteger(returnValue,total);
}
void SDCCommand(
Environment *theEnv,
UDFContext *context,
UDFValue *returnValue)
{
UDFValue theArg;
returnValue->lexemeValue = CreateBoolean(theEnv,GetDynamicConstraintChecking(theEnv));
if (! UDFFirstArgument(context,ANY_TYPE_BITS,&theArg))
{ return; }
SetDynamicConstraintChecking(theEnv,theArg.value != FalseSymbol(theEnv));
}
void SetCurrentModuleCommand(
Environment *theEnv,
UDFContext *context,
UDFValue *returnValue)
{
UDFValue theArg;
const char *argument;
Defmodule *theModule;
CLIPSLexeme *oldModuleName;
/*=======================*/
/* Set the return value. */
/*=======================*/
theModule = GetCurrentModule(theEnv);
if (theModule == NULL)
{
returnValue->lexemeValue = FalseSymbol(theEnv);
return;
}
oldModuleName = theModule->header.name;
returnValue->value = oldModuleName;
/*=====================================================*/
/* Check for the correct number and type of arguments. */
/*=====================================================*/
if (! UDFFirstArgument(context,SYMBOL_BIT,&theArg))
{ return; }
argument = theArg.lexemeValue->contents;
/*================================================*/
/* Set the current module to the specified value. */
/*================================================*/
theModule = FindDefmodule(theEnv,argument);
if (theModule == NULL)
{
CantFindItemErrorMessage(theEnv,"defmodule",argument,true);
return;
}
SetCurrentModule(theEnv,theModule);
}
void UnwatchCommand(
Environment *theEnv,
UDFContext *context,
UDFValue *returnValue)
{
UDFValue theValue;
const char *argument;
bool recognized;
WatchItemRecord *wPtr;
/*==========================================*/
/* Determine which item is to be unwatched. */
/*==========================================*/
if (! UDFFirstArgument(context,SYMBOL_BIT,&theValue)) return;
argument = theValue.lexemeValue->contents;
wPtr = ValidWatchItem(theEnv,argument,&recognized);
if (recognized == false)
{
SetEvaluationError(theEnv,true);
UDFInvalidArgumentMessage(context,"watchable symbol");
return;
}
/*=================================================*/
/* Check to make sure extra arguments are allowed. */
/*=================================================*/
if (GetNextArgument(GetFirstArgument()) != NULL)
{
if ((wPtr == NULL) ? true : (wPtr->accessFunc == NULL))
{
SetEvaluationError(theEnv,true);
ExpectedCountError(theEnv,"unwatch",EXACTLY,1);
return;
}
}
/*=====================*/
/* Set the watch item. */
/*=====================*/
SetWatchItem(theEnv,argument,false,GetNextArgument(GetFirstArgument()));
}
const char *GetConstructName(
UDFContext *context,
const char *functionName,
const char *constructType)
{
UDFValue returnValue;
if (! UDFFirstArgument(context,ANY_TYPE_BITS,&returnValue))
{ return NULL; }
if (! CVIsType(&returnValue,SYMBOL_BIT))
{
UDFInvalidArgumentMessage(context,constructType);
return NULL;
}
return(returnValue.lexemeValue->contents);
}
/************************************************************************************
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); }
}
void ProfileCommand(
Environment *theEnv,
UDFContext *context,
UDFValue *returnValue)
{
const char *argument;
UDFValue theValue;
if (! UDFFirstArgument(context,SYMBOL_BIT,&theValue)) return;
argument = theValue.lexemeValue->contents;
if (! Profile(theEnv,argument))
{
UDFInvalidArgumentMessage(context,"symbol with value constructs, user-functions, or off");
return;
}
return;
}
void MaxFunction(
UDFContext *context,
CLIPSValue *returnValue)
{
CLIPSValue nextPossible;
/*============================================*/
/* Check that the first argument is a number. */
/*============================================*/
if (! UDFFirstArgument(context,NUMBER_TYPES,returnValue))
{ return; }
/*===========================================================*/
/* Loop through the remaining arguments, first checking each */
/* argument to see that it is a number, and then determining */
/* if the argument is greater than the previous arguments */
/* and is thus the maximum value. */
/*===========================================================*/
while (UDFHasNextArgument(context))
{
if (! UDFNextArgument(context,NUMBER_TYPES,&nextPossible))
{ return; }
/*=============================================*/
/* If either argument is a float, convert both */
/* to floats. Otherwise compare two integers. */
/*=============================================*/
if (mCVIsType(returnValue,FLOAT_TYPE) || mCVIsType(&nextPossible,FLOAT_TYPE))
{
if (mCVToFloat(returnValue) < mCVToFloat(&nextPossible))
{ CVSetCLIPSValue(returnValue,&nextPossible); }
}
else
{
if (mCVToInteger(returnValue) < mCVToInteger(&nextPossible))
{ CVSetCLIPSValue(returnValue,&nextPossible); }
}
}
}
void SetProfilePercentThresholdCommand(
Environment *theEnv,
UDFContext *context,
UDFValue *returnValue)
{
UDFValue theValue;
double newThreshold;
if (! UDFFirstArgument(context,NUMBER_BITS,&theValue))
{ return; }
newThreshold = CVCoerceToFloat(&theValue);
if ((newThreshold < 0.0) || (newThreshold > 100.0))
{
UDFInvalidArgumentMessage(context,"number in the range 0 to 100");
returnValue->floatValue = CreateFloat(theEnv,-1.0);
}
else
{ returnValue->floatValue = CreateFloat(theEnv,SetProfilePercentThreshold(theEnv,newThreshold)); }
}
void ExitCommand(
UDFContext *context,
CLIPSValue *returnValue)
{
int argCnt;
int status;
CLIPSValue value;
Environment *theEnv = UDFContextEnvironment(context);
argCnt = UDFArgumentCount(context);
if (argCnt == 0)
{ EnvExitRouter(theEnv,EXIT_SUCCESS); }
else
{
if (! UDFFirstArgument(context,INTEGER_TYPE,&value))
{ EnvExitRouter(theEnv,EXIT_SUCCESS); }
status = (int) mCVToInteger(&value);
if (EnvGetEvaluationError(theEnv)) return;
EnvExitRouter(theEnv,status);
}
return;
}
void SubtractionFunction(
UDFContext *context,
CLIPSValue *returnValue)
{
CLIPSFloat ftotal = 0.0;
CLIPSInteger ltotal = 0LL;
bool useFloatTotal = false;
CLIPSValue theArg;
/*=================================================*/
/* Get the first argument. This number which will */
/* be the starting total from which all subsequent */
/* arguments will subtracted. */
/*=================================================*/
if (! UDFFirstArgument(context,NUMBER_TYPES,&theArg))
{ return; }
if (mCVIsType(&theArg,INTEGER_TYPE))
{ ltotal = mCVToInteger(&theArg); }
else
{
ftotal = mCVToFloat(&theArg);
useFloatTotal = true;
}
/*===================================================*/
/* Loop through each of the arguments subtracting it */
/* from a running total. If a floating point number */
/* is encountered, then do all subsequent operations */
/* using floating point values. */
/*===================================================*/
while (UDFHasNextArgument(context))
{
if (! UDFNextArgument(context,NUMBER_TYPES,&theArg))
{ return; }
if (useFloatTotal)
{ ftotal -= mCVToFloat(&theArg); }
else
{
if (mCVIsType(&theArg,INTEGER_TYPE))
{ ltotal -= mCVToInteger(&theArg); }
else
{
ftotal = ((CLIPSFloat) ltotal) - mCVToFloat(&theArg);
useFloatTotal = true;
}
}
}
/*======================================================*/
/* If a floating point number was in the argument list, */
/* then return a float, otherwise return an integer. */
/*======================================================*/
if (useFloatTotal)
{ mCVSetFloat(returnValue,ftotal); }
else
{ mCVSetInteger(returnValue,ltotal); }
}
void ListWatchItemsCommand(
Environment *theEnv,
UDFContext *context,
UDFValue *returnValue)
{
WatchItemRecord *wPtr;
UDFValue theValue;
bool recognized;
/*=======================*/
/* List the watch items. */
/*=======================*/
if (GetFirstArgument() == NULL)
{
for (wPtr = WatchData(theEnv)->ListOfWatchItems; wPtr != NULL; wPtr = wPtr->next)
{
WriteString(theEnv,STDOUT,wPtr->name);
if (*(wPtr->flag)) WriteString(theEnv,STDOUT," = on\n");
else WriteString(theEnv,STDOUT," = off\n");
}
return;
}
/*=======================================*/
/* Determine which item is to be listed. */
/*=======================================*/
if (! UDFFirstArgument(context,SYMBOL_BIT,&theValue)) return;
wPtr = ValidWatchItem(theEnv,theValue.lexemeValue->contents,&recognized);
if ((recognized == false) || (wPtr == NULL))
{
SetEvaluationError(theEnv,true);
ExpectedTypeError1(theEnv,"list-watch-items",1,"'watchable symbol'");
return;
}
/*=================================================*/
/* Check to make sure extra arguments are allowed. */
/*=================================================*/
if ((wPtr->printFunc == NULL) &&
(GetNextArgument(GetFirstArgument()) != NULL))
{
SetEvaluationError(theEnv,true);
ExpectedCountError(theEnv,"list-watch-items",EXACTLY,1);
return;
}
/*====================================*/
/* List the status of the watch item. */
/*====================================*/
WriteString(theEnv,STDOUT,wPtr->name);
if (*(wPtr->flag)) WriteString(theEnv,STDOUT," = on\n");
else WriteString(theEnv,STDOUT," = off\n");
/*============================================*/
/* List the status of individual watch items. */
/*============================================*/
if (wPtr->printFunc != NULL)
{
if ((*wPtr->printFunc)(theEnv,STDOUT,wPtr->code,
GetNextArgument(GetFirstArgument())) == false)
{ SetEvaluationError(theEnv,true); }
}
}