/*********************************************************
NAME : SlotInfoSlot
DESCRIPTION : Runtime support routine for slot-sources,
slot-facets, et. al. which looks up
a slot
INPUTS : 1) Data object buffer
2) Class pointer
3) Name-string of slot to find
4) The name of the calling function
RETURNS : Nothing useful
SIDE EFFECTS : Support function called and data object
buffer initialized
NOTES : None
*********************************************************/
static SLOT_DESC *SlotInfoSlot(
void *theEnv,
DATA_OBJECT *result,
DEFCLASS *cls,
const char *sname,
const char *fnxname)
{
SYMBOL_HN *ssym;
int i;
if ((ssym = FindSymbolHN(theEnv,sname)) == NULL)
{
SetEvaluationError(theEnv,TRUE);
EnvSetMultifieldErrorValue(theEnv,result);
return(NULL);
}
i = FindInstanceTemplateSlot(theEnv,cls,ssym);
if (i == -1)
{
SlotExistError(theEnv,sname,fnxname);
SetEvaluationError(theEnv,TRUE);
EnvSetMultifieldErrorValue(theEnv,result);
return(NULL);
}
result->type = MULTIFIELD;
result->begin = 0;
return(cls->instanceTemplate[i]);
}
globle void GetFactListFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
struct defmodule *theModule;
DATA_OBJECT result;
int numArgs;
/*===========================================*/
/* Determine if a module name was specified. */
/*===========================================*/
if ((numArgs = EnvArgCountCheck(theEnv,"get-fact-list",NO_MORE_THAN,1)) == -1)
{
EnvSetMultifieldErrorValue(theEnv,returnValue);
return;
}
if (numArgs == 1)
{
EnvRtnUnknown(theEnv,1,&result);
if (GetType(result) != SYMBOL)
{
EnvSetMultifieldErrorValue(theEnv,returnValue);
ExpectedTypeError1(theEnv,"get-fact-list",1,"defmodule name");
return;
}
if ((theModule = (struct defmodule *) EnvFindDefmodule(theEnv,DOToString(result))) == NULL)
{
if (strcmp("*",DOToString(result)) != 0)
{
EnvSetMultifieldErrorValue(theEnv,returnValue);
ExpectedTypeError1(theEnv,"get-fact-list",1,"defmodule name");
return;
}
theModule = NULL;
}
}
else
{ theModule = ((struct defmodule *) EnvGetCurrentModule(theEnv)); }
/*=====================*/
/* Get the constructs. */
/*=====================*/
EnvGetFactList(theEnv,returnValue,theModule);
}
globle void EnvSlotCardinality(
void *theEnv,
void *clsptr,
const char *sname,
DATA_OBJECT *result)
{
register SLOT_DESC *sp;
if ((sp = SlotInfoSlot(theEnv,result,(DEFCLASS *) clsptr,sname,"slot-cardinality")) == NULL)
return;
if (sp->multiple == 0)
{
EnvSetMultifieldErrorValue(theEnv,result);
return;
}
result->end = 1;
result->value = EnvCreateMultifield(theEnv,2L);
if (sp->constraint != NULL)
{
SetMFType(result->value,1,sp->constraint->minFields->type);
SetMFValue(result->value,1,sp->constraint->minFields->value);
SetMFType(result->value,2,sp->constraint->maxFields->type);
SetMFValue(result->value,2,sp->constraint->maxFields->value);
}
else
{
SetMFType(result->value,1,INTEGER);
SetMFValue(result->value,1,SymbolData(theEnv)->Zero);
SetMFType(result->value,2,SYMBOL);
SetMFValue(result->value,2,SymbolData(theEnv)->PositiveInfinity);
}
}
globle void GetFunctionListFunction(
void *theEnv,
DATA_OBJECT *returnValue)
{
struct FunctionDefinition *theFunction;
struct multifield *theList;
unsigned long functionCount = 0;
if (EnvArgCountCheck(theEnv,"get-function-list",EXACTLY,0) == -1)
{
EnvSetMultifieldErrorValue(theEnv,returnValue);
return;
}
for (theFunction = GetFunctionList(theEnv);
theFunction != NULL;
theFunction = theFunction->next)
{
functionCount++;
}
SetpType(returnValue,MULTIFIELD);
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,functionCount);
theList = (struct multifield *) EnvCreateMultifield(theEnv,functionCount);
SetpValue(returnValue,(void *) theList);
for (theFunction = GetFunctionList(theEnv), functionCount = 1;
theFunction != NULL;
theFunction = theFunction->next, functionCount++)
{
SetMFType(theList,functionCount,SYMBOL);
SetMFValue(theList,functionCount,theFunction->callFunctionName);
}
}
void AssignErrorValue(
UDFContext *context)
{
if (context->theFunction->unknownReturnValueType & BOOLEAN_TYPE)
{ mCVSetBoolean(context->returnValue,false); }
else if (context->theFunction->unknownReturnValueType & STRING_TYPE)
{ mCVSetString(context->returnValue,""); }
else if (context->theFunction->unknownReturnValueType & SYMBOL_TYPE)
{ mCVSetSymbol(context->returnValue,"nil"); }
else if (context->theFunction->unknownReturnValueType & INTEGER_TYPE)
{ mCVSetInteger(context->returnValue,0); }
else if (context->theFunction->unknownReturnValueType & FLOAT_TYPE)
{ mCVSetFloat(context->returnValue,0.0); }
else if (context->theFunction->unknownReturnValueType & MULTIFIELD_TYPE)
{ EnvSetMultifieldErrorValue(context->environment,context->returnValue); }
else if (context->theFunction->unknownReturnValueType & INSTANCE_NAME_TYPE)
{ mCVSetInstanceName(context->returnValue,"nil"); }
else if (context->theFunction->unknownReturnValueType & FACT_ADDRESS_TYPE)
{ mCVSetFactAddress(context->returnValue,&FactData(context->environment)->DummyFact); }
else if (context->theFunction->unknownReturnValueType & INSTANCE_ADDRESS_TYPE)
{ mCVSetInstanceAddress(context->returnValue,&InstanceData(context->environment)->DummyInstance); }
else if (context->theFunction->unknownReturnValueType & EXTERNAL_ADDRESS_TYPE)
{ CVSetExternalAddress(context->returnValue,NULL,0); }
else
{ mCVSetVoid(context->returnValue); }
}
globle void OldGetConstructList(
void *theEnv,
EXEC_STATUS,
DATA_OBJECT_PTR returnValue,
void *(*nextFunction)(void *,EXEC_STATUS,void *),
char *(*nameFunction)(void *,EXEC_STATUS,void *))
{
void *theConstruct;
unsigned long count = 0;
struct multifield *theList;
/*====================================*/
/* Determine the number of constructs */
/* of the specified type. */
/*====================================*/
for (theConstruct = (*nextFunction)(theEnv,execStatus,NULL);
theConstruct != NULL;
theConstruct = (*nextFunction)(theEnv,execStatus,theConstruct))
{ count++; }
/*===========================*/
/* Create a multifield large */
/* enough to store the list. */
/*===========================*/
SetpType(returnValue,MULTIFIELD);
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,(long) count);
theList = (struct multifield *) EnvCreateMultifield(theEnv,execStatus,count);
SetpValue(returnValue,(void *) theList);
/*====================================*/
/* Store the names in the multifield. */
/*====================================*/
for (theConstruct = (*nextFunction)(theEnv,execStatus,NULL), count = 1;
theConstruct != NULL;
theConstruct = (*nextFunction)(theEnv,execStatus,theConstruct), count++)
{
if (execStatus->HaltExecution == TRUE)
{
EnvSetMultifieldErrorValue(theEnv,execStatus,returnValue);
return;
}
SetMFType(theList,count,SYMBOL);
SetMFValue(theList,count,EnvAddSymbol(theEnv,execStatus,(*nameFunction)(theEnv,execStatus,theConstruct)));
}
}
/************************************************************************
NAME : ClassSubclassesCommand
DESCRIPTION : Groups subclasses for a class into a multifield value
for dynamic perusal
INPUTS : Data object buffer to hold the subclasses of the class
RETURNS : Nothing useful
SIDE EFFECTS : Creates a multifield storing the names of
the subclasses of the class
NOTES : Syntax: (class-subclasses <class> [inherit])
************************************************************************/
globle void ClassSubclassesCommand(
void *theEnv,
DATA_OBJECT *result)
{
int inhp;
void *clsptr;
clsptr = ClassInfoFnxArgs(theEnv,"class-subclasses",&inhp);
if (clsptr == NULL)
{
EnvSetMultifieldErrorValue(theEnv,result);
return;
}
EnvClassSubclasses(theEnv,clsptr,result,inhp);
}
/*****************************************************
NAME : SlotInfoSupportFunction
DESCRIPTION : Support routine for slot-sources,
slot-facets, et. al.
INPUTS : 1) Data object buffer
2) Name of the H/L caller
3) Pointer to support function to call
RETURNS : Nothing useful
SIDE EFFECTS : Support function called and data
object buffer set
NOTES : None
*****************************************************/
static void SlotInfoSupportFunction(
void *theEnv,
DATA_OBJECT *result,
const char *fnxname,
void (*fnx)(void *,void *,const char *,DATA_OBJECT *))
{
SYMBOL_HN *ssym;
DEFCLASS *cls;
ssym = CheckClassAndSlot(theEnv,fnxname,&cls);
if (ssym == NULL)
{
EnvSetMultifieldErrorValue(theEnv,result);
return;
}
(*fnx)(theEnv,(void *) cls,ValueToString(ssym),result);
}
void EnvGetDefmoduleList(
void *theEnv,
CLIPSValue *returnValue)
{
void *theConstruct;
unsigned long count = 0;
struct multifield *theList;
/*====================================*/
/* Determine the number of constructs */
/* of the specified type. */
/*====================================*/
for (theConstruct = EnvGetNextDefmodule(theEnv,NULL);
theConstruct != NULL;
theConstruct = EnvGetNextDefmodule(theEnv,theConstruct))
{ count++; }
/*===========================*/
/* Create a multifield large */
/* enough to store the list. */
/*===========================*/
SetpType(returnValue,MULTIFIELD);
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,(long) count);
theList = (struct multifield *) EnvCreateMultifield(theEnv,count);
SetpValue(returnValue,(void *) theList);
/*====================================*/
/* Store the names in the multifield. */
/*====================================*/
for (theConstruct = EnvGetNextDefmodule(theEnv,NULL), count = 1;
theConstruct != NULL;
theConstruct = EnvGetNextDefmodule(theEnv,theConstruct), count++)
{
if (EvaluationData(theEnv)->HaltExecution == true)
{
EnvSetMultifieldErrorValue(theEnv,returnValue);
return;
}
SetMFType(theList,count,SYMBOL);
SetMFValue(theList,count,EnvAddSymbol(theEnv,EnvGetDefmoduleName(theEnv,theConstruct)));
}
}
/***********************************************************************
NAME : GetDefmessageHandlersListCmd
DESCRIPTION : Groups message-handlers for a class into a multifield
value for dynamic perusal
INPUTS : Data object buffer to hold the handlers of the class
RETURNS : Nothing useful
SIDE EFFECTS : Creates a multifield storing the names of
the message-handlers of the class
NOTES : Syntax: (get-defmessage-handler-list <class> [inherit])
***********************************************************************/
globle void GetDefmessageHandlersListCmd(
void *theEnv,
DATA_OBJECT *result)
{
int inhp;
void *clsptr;
if (EnvRtnArgCount(theEnv) == 0)
EnvGetDefmessageHandlerList(theEnv,NULL,result,0);
else
{
clsptr = ClassInfoFnxArgs(theEnv,"get-defmessage-handler-list",&inhp);
if (clsptr == NULL)
{
EnvSetMultifieldErrorValue(theEnv,result);
return;
}
EnvGetDefmessageHandlerList(theEnv,clsptr,result,inhp);
}
}
globle void SortFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
long argumentCount, i, j, k = 0;
DATA_OBJECT *theArguments, *theArguments2;
DATA_OBJECT theArg;
struct multifield *theMultifield, *tempMultifield;
char *functionName;
struct expr *functionReference;
int argumentSize = 0;
struct FunctionDefinition *fptr;
#if DEFFUNCTION_CONSTRUCT
DEFFUNCTION *dptr;
#endif
/*==================================*/
/* Set up the default return value. */
/*==================================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
/*=============================================*/
/* The function expects at least one argument. */
/*=============================================*/
if ((argumentCount = EnvArgCountCheck(theEnv,"sort",AT_LEAST,1)) == -1)
{ return; }
/*=============================================*/
/* Verify that the comparison function exists. */
/*=============================================*/
if (EnvArgTypeCheck(theEnv,"sort",1,SYMBOL,&theArg) == FALSE)
{ return; }
functionName = DOToString(theArg);
functionReference = FunctionReferenceExpression(theEnv,functionName);
if (functionReference == NULL)
{
ExpectedTypeError1(theEnv,"sort",1,"function name, deffunction name, or defgeneric name");
return;
}
/*======================================*/
/* For an external function, verify the */
/* correct number of arguments. */
/*======================================*/
if (functionReference->type == FCALL)
{
fptr = (struct FunctionDefinition *) functionReference->value;
if ((GetMinimumArgs(fptr) > 2) ||
(GetMaximumArgs(fptr) == 0) ||
(GetMaximumArgs(fptr) == 1))
{
ExpectedTypeError1(theEnv,"sort",1,"function name expecting two arguments");
ReturnExpression(theEnv,functionReference);
return;
}
}
/*=======================================*/
/* For a deffunction, verify the correct */
/* number of arguments. */
/*=======================================*/
#if DEFFUNCTION_CONSTRUCT
if (functionReference->type == PCALL)
{
dptr = (DEFFUNCTION *) functionReference->value;
if ((dptr->minNumberOfParameters > 2) ||
(dptr->maxNumberOfParameters == 0) ||
(dptr->maxNumberOfParameters == 1))
{
ExpectedTypeError1(theEnv,"sort",1,"deffunction name expecting two arguments");
ReturnExpression(theEnv,functionReference);
return;
}
}
#endif
/*=====================================*/
/* If there are no items to be sorted, */
/* then return an empty multifield. */
/*=====================================*/
if (argumentCount == 1)
{
EnvSetMultifieldErrorValue(theEnv,returnValue);
ReturnExpression(theEnv,functionReference);
return;
}
/*=====================================*/
/* Retrieve the arguments to be sorted */
/* and determine how many there are. */
/*=====================================*/
theArguments = (DATA_OBJECT *) genalloc(theEnv,(argumentCount - 1) * sizeof(DATA_OBJECT));
for (i = 2; i <= argumentCount; i++)
{
EnvRtnUnknown(theEnv,i,&theArguments[i-2]);
if (GetType(theArguments[i-2]) == MULTIFIELD)
{ argumentSize += GetpDOLength(&theArguments[i-2]); }
else
{ argumentSize++; }
}
if (argumentSize == 0)
{
genfree(theEnv,theArguments,(argumentCount - 1) * sizeof(DATA_OBJECT)); /* Bug Fix */
EnvSetMultifieldErrorValue(theEnv,returnValue);
ReturnExpression(theEnv,functionReference);
return;
}
/*====================================*/
/* Pack all of the items to be sorted */
/* into a data object array. */
/*====================================*/
theArguments2 = (DATA_OBJECT *) genalloc(theEnv,argumentSize * sizeof(DATA_OBJECT));
for (i = 2; i <= argumentCount; i++)
{
if (GetType(theArguments[i-2]) == MULTIFIELD)
{
tempMultifield = (struct multifield *) GetValue(theArguments[i-2]);
for (j = GetDOBegin(theArguments[i-2]); j <= GetDOEnd(theArguments[i-2]); j++, k++)
{
SetType(theArguments2[k],GetMFType(tempMultifield,j));
SetValue(theArguments2[k],GetMFValue(tempMultifield,j));
}
}
else
{
SetType(theArguments2[k],GetType(theArguments[i-2]));
SetValue(theArguments2[k],GetValue(theArguments[i-2]));
k++;
}
}
genfree(theEnv,theArguments,(argumentCount - 1) * sizeof(DATA_OBJECT));
functionReference->nextArg = SortFunctionData(theEnv)->SortComparisonFunction;
SortFunctionData(theEnv)->SortComparisonFunction = functionReference;
for (i = 0; i < argumentSize; i++)
{ ValueInstall(theEnv,&theArguments2[i]); }
MergeSort(theEnv,(unsigned long) argumentSize,theArguments2,DefaultCompareSwapFunction);
for (i = 0; i < argumentSize; i++)
{ ValueDeinstall(theEnv,&theArguments2[i]); }
SortFunctionData(theEnv)->SortComparisonFunction = SortFunctionData(theEnv)->SortComparisonFunction->nextArg;
functionReference->nextArg = NULL;
ReturnExpression(theEnv,functionReference);
theMultifield = (struct multifield *) EnvCreateMultifield(theEnv,(unsigned long) argumentSize);
for (i = 0; i < argumentSize; i++)
{
SetMFType(theMultifield,i+1,GetType(theArguments2[i]));
SetMFValue(theMultifield,i+1,GetValue(theArguments2[i]));
}
genfree(theEnv,theArguments2,argumentSize * sizeof(DATA_OBJECT));
SetpType(returnValue,MULTIFIELD);
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,argumentSize);
SetpValue(returnValue,(void *) theMultifield);
}
