globle long long FactIndexFunction(
void *theEnv)
{
DATA_OBJECT item;
/*============================================*/
/* Check for the correct number of arguments. */
/*============================================*/
if (EnvArgCountCheck(theEnv,"fact-index",EXACTLY,1) == -1) return(-1LL);
/*========================*/
/* Evaluate the argument. */
/*========================*/
EnvRtnUnknown(theEnv,1,&item);
/*======================================*/
/* The argument must be a fact address. */
/*======================================*/
if (GetType(item) != FACT_ADDRESS)
{
ExpectedTypeError1(theEnv,"fact-index",1,"fact-address");
return(-1L);
}
/*================================================*/
/* Return the fact index associated with the fact */
/* address. If the fact has been retracted, then */
/* return -1 for the fact index. */
/*================================================*/
if (((struct fact *) GetValue(item))->garbage) return(-1LL);
return (EnvFactIndex(theEnv,GetValue(item)));
}
/***************************************************************************
NAME : GetQueryInstanceSlot
DESCRIPTION : Internal function for referring to slots of instances in
instance array on instance-queries
INPUTS : The caller's result buffer
RETURNS : Nothing useful
SIDE EFFECTS : Caller's result buffer set appropriately
NOTES : H/L Syntax : ((query-instance-slot) <index> <slot-name>)
**************************************************************************/
globle void GetQueryInstanceSlot(
void *theEnv,
EXEC_STATUS,
DATA_OBJECT *result)
{
INSTANCE_TYPE *ins;
INSTANCE_SLOT *sp;
DATA_OBJECT temp;
QUERY_CORE *core;
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv,execStatus);
core = FindQueryCore(theEnv,execStatus,ValueToInteger(GetpValue(GetFirstArgument())));
ins = core->solns[ValueToInteger(GetpValue(GetFirstArgument()->nextArg))];
EvaluateExpression(theEnv,execStatus,GetFirstArgument()->nextArg->nextArg,&temp);
if (temp.type != SYMBOL)
{
ExpectedTypeError1(theEnv,execStatus,"get",1,"symbol");
SetEvaluationError(theEnv,execStatus,TRUE);
return;
}
sp = FindInstanceSlot(theEnv,execStatus,ins,(SYMBOL_HN *) temp.value);
if (sp == NULL)
{
SlotExistError(theEnv,execStatus,ValueToString(temp.value),"instance-set query");
return;
}
result->type = (unsigned short) sp->type;
result->value = sp->value;
if (sp->type == MULTIFIELD)
{
result->begin = 0;
SetpDOEnd(result,GetInstanceSlotLength(sp));
}
}
static long long GetFactsArgument(
void *theEnv,
int whichOne,
int argumentCount)
{
long long factIndex;
DATA_OBJECT theValue;
if (whichOne > argumentCount) return(UNSPECIFIED);
if (EnvArgTypeCheck(theEnv,(char*)"facts",whichOne,INTEGER,&theValue) == FALSE) return(INVALID);
factIndex = DOToLong(theValue);
if (factIndex < 0)
{
ExpectedTypeError1(theEnv,(char*)"facts",whichOne,(char*)"positive number");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(INVALID);
}
return(factIndex);
}
globle void FactsCommand(
void *theEnv)
{
int argumentCount;
long long start = UNSPECIFIED, end = UNSPECIFIED, max = UNSPECIFIED;
struct defmodule *theModule;
DATA_OBJECT theValue;
int argOffset;
/*=========================================================*/
/* Determine the number of arguments to the facts command. */
/*=========================================================*/
if ((argumentCount = EnvArgCountCheck(theEnv,(char*)"facts",NO_MORE_THAN,4)) == -1) return;
/*==================================*/
/* The default module for the facts */
/* command is the current module. */
/*==================================*/
theModule = ((struct defmodule *) EnvGetCurrentModule(theEnv));
/*==========================================*/
/* If no arguments were specified, then use */
/* the default values to list the facts. */
/*==========================================*/
if (argumentCount == 0)
{
EnvFacts(theEnv,WDISPLAY,theModule,start,end,max);
return;
}
/*========================================================*/
/* Since there are one or more arguments, see if a module */
/* or start index was specified as the first argument. */
/*========================================================*/
EnvRtnUnknown(theEnv,1,&theValue);
/*===============================================*/
/* If the first argument is a symbol, then check */
/* to see that a valid module was specified. */
/*===============================================*/
if (theValue.type == SYMBOL)
{
theModule = (struct defmodule *) EnvFindDefmodule(theEnv,ValueToString(theValue.value));
if ((theModule == NULL) && (strcmp(ValueToString(theValue.value),"*") != 0))
{
SetEvaluationError(theEnv,TRUE);
CantFindItemErrorMessage(theEnv,(char*)"defmodule",ValueToString(theValue.value));
return;
}
if ((start = GetFactsArgument(theEnv,2,argumentCount)) == INVALID) return;
argOffset = 1;
}
/*================================================*/
/* Otherwise if the first argument is an integer, */
/* check to see that a valid index was specified. */
/*================================================*/
else if (theValue.type == INTEGER)
{
start = DOToLong(theValue);
if (start < 0)
{
ExpectedTypeError1(theEnv,(char*)"facts",1,(char*)"symbol or positive number");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return;
}
argOffset = 0;
}
/*==========================================*/
/* Otherwise the first argument is invalid. */
/*==========================================*/
else
{
ExpectedTypeError1(theEnv,(char*)"facts",1,(char*)"symbol or positive number");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return;
}
/*==========================*/
/* Get the other arguments. */
/*==========================*/
if ((end = GetFactsArgument(theEnv,2 + argOffset,argumentCount)) == INVALID) return;
if ((max = GetFactsArgument(theEnv,3 + argOffset,argumentCount)) == INVALID) return;
/*=================*/
/* List the facts. */
/*=================*/
EnvFacts(theEnv,WDISPLAY,theModule,start,end,max);
}
globle void RetractCommand(
void *theEnv)
{
long long factIndex;
struct fact *ptr;
struct expr *theArgument;
DATA_OBJECT theResult;
int argNumber;
/*================================*/
/* Iterate through each argument. */
/*================================*/
for (theArgument = GetFirstArgument(), argNumber = 1;
theArgument != NULL;
theArgument = GetNextArgument(theArgument), argNumber++)
{
/*========================*/
/* Evaluate the argument. */
/*========================*/
EvaluateExpression(theEnv,theArgument,&theResult);
/*===============================================*/
/* If the argument evaluates to an integer, then */
/* it's assumed to be the fact index of the fact */
/* to be retracted. */
/*===============================================*/
if (theResult.type == INTEGER)
{
/*==========================================*/
/* A fact index must be a positive integer. */
/*==========================================*/
factIndex = ValueToLong(theResult.value);
if (factIndex < 0)
{
ExpectedTypeError1(theEnv,(char*)"retract",argNumber,(char*)"fact-address, fact-index, or the symbol *");
return;
}
/*================================================*/
/* See if a fact with the specified index exists. */
/*================================================*/
ptr = FindIndexedFact(theEnv,factIndex);
/*=====================================*/
/* If the fact exists then retract it, */
/* otherwise print an error message. */
/*=====================================*/
if (ptr != NULL)
{ EnvRetract(theEnv,(void *) ptr); }
else
{
char tempBuffer[20];
gensprintf(tempBuffer,"f-%lld",factIndex);
CantFindItemErrorMessage(theEnv,(char*)"fact",tempBuffer);
}
}
/*===============================================*/
/* Otherwise if the argument evaluates to a fact */
/* address, we can directly retract it. */
/*===============================================*/
else if (theResult.type == FACT_ADDRESS)
{ EnvRetract(theEnv,theResult.value); }
/*============================================*/
/* Otherwise if the argument evaluates to the */
/* symbol *, then all facts are retracted. */
/*============================================*/
else if ((theResult.type == SYMBOL) ?
(strcmp(ValueToString(theResult.value),"*") == 0) : FALSE)
{
RemoveAllFacts(theEnv);
return;
}
/*============================================*/
/* Otherwise the argument has evaluated to an */
/* illegal value for the retract command. */
/*============================================*/
else
{
ExpectedTypeError1(theEnv,(char*)"retract",argNumber,(char*)"fact-address, fact-index, or the symbol *");
SetEvaluationError(theEnv,TRUE);
}
}
}
static DATA_OBJECT_PTR GetSaveFactsDeftemplateNames(
void *theEnv,
struct expr *theList,
int saveCode,
int *count,
int *error)
{
struct expr *tempList;
DATA_OBJECT_PTR theDOArray;
int i, tempCount;
struct deftemplate *theDeftemplate = NULL;
/*=============================*/
/* Initialize the error state. */
/*=============================*/
*error = FALSE;
/*=====================================================*/
/* If no deftemplate names were specified as arguments */
/* then the deftemplate name list is empty. */
/*=====================================================*/
if (theList == NULL)
{
*count = 0;
return(NULL);
}
/*======================================*/
/* Determine the number of deftemplate */
/* names to be stored in the name list. */
/*======================================*/
for (tempList = theList, *count = 0;
tempList != NULL;
tempList = tempList->nextArg, (*count)++)
{ /* Do Nothing */ }
/*=========================================*/
/* Allocate the storage for the name list. */
/*=========================================*/
theDOArray = (DATA_OBJECT_PTR) gm3(theEnv,(long) sizeof(DATA_OBJECT) * *count);
/*=====================================*/
/* Loop through each of the arguments. */
/*=====================================*/
for (tempList = theList, i = 0;
i < *count;
tempList = tempList->nextArg, i++)
{
/*========================*/
/* Evaluate the argument. */
/*========================*/
EvaluateExpression(theEnv,tempList,&theDOArray[i]);
if (EvaluationData(theEnv)->EvaluationError)
{
*error = TRUE;
rm3(theEnv,theDOArray,(long) sizeof(DATA_OBJECT) * *count);
return(NULL);
}
/*======================================*/
/* A deftemplate name must be a symbol. */
/*======================================*/
if (theDOArray[i].type != SYMBOL)
{
*error = TRUE;
ExpectedTypeError1(theEnv,(char*)"save-facts",3+i,(char*)"symbol");
rm3(theEnv,theDOArray,(long) sizeof(DATA_OBJECT) * *count);
return(NULL);
}
/*===================================================*/
/* Find the deftemplate. For a local save, look only */
/* in the current module. For a visible save, look */
/* in all visible modules. */
/*===================================================*/
if (saveCode == LOCAL_SAVE)
{
theDeftemplate = (struct deftemplate *)
EnvFindDeftemplate(theEnv,ValueToString(theDOArray[i].value));
if (theDeftemplate == NULL)
{
*error = TRUE;
ExpectedTypeError1(theEnv,(char*)"save-facts",3+i,(char*)"local deftemplate name");
rm3(theEnv,theDOArray,(long) sizeof(DATA_OBJECT) * *count);
return(NULL);
}
}
else if (saveCode == VISIBLE_SAVE)
{
theDeftemplate = (struct deftemplate *)
FindImportedConstruct(theEnv,(char*)"deftemplate",NULL,
ValueToString(theDOArray[i].value),
&tempCount,TRUE,NULL);
if (theDeftemplate == NULL)
{
*error = TRUE;
ExpectedTypeError1(theEnv,(char*)"save-facts",3+i,(char*)"visible deftemplate name");
rm3(theEnv,theDOArray,(long) sizeof(DATA_OBJECT) * *count);
return(NULL);
}
}
/*==================================*/
/* Add a pointer to the deftemplate */
/* to the array being created. */
/*==================================*/
theDOArray[i].type = DEFTEMPLATE_PTR;
theDOArray[i].value = (void *) theDeftemplate;
}
/*===================================*/
/* Return the array of deftemplates. */
/*===================================*/
return(theDOArray);
}
globle intBool GetNumericArgument(
void *theEnv,
struct expr *theArgument,
char *functionName,
DATA_OBJECT *result,
intBool convertToFloat,
int whichArgument)
{
unsigned short theType;
void *theValue;
/*==================================================================*/
/* Evaluate the expression (don't bother calling EvaluateExpression */
/* if the type is float or integer). */
/*==================================================================*/
switch(theArgument->type)
{
case FLOAT:
case INTEGER:
theType = theArgument->type;
theValue = theArgument->value;
break;
default:
EvaluateExpression(theEnv,theArgument,result);
theType = result->type;
theValue = result->value;
break;
}
/*==========================================*/
/* If the argument is not float or integer, */
/* print an error message and return FALSE. */
/*==========================================*/
if ((theType != FLOAT) && (theType != INTEGER))
{
ExpectedTypeError1(theEnv,functionName,whichArgument,"integer or float");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,0L);
return(FALSE);
}
/*==========================================================*/
/* If the argument is an integer and the "convert to float" */
/* flag is TRUE, then convert the integer to a float. */
/*==========================================================*/
if ((convertToFloat) && (theType == INTEGER))
{
theType = FLOAT;
theValue = (void *) EnvAddDouble(theEnv,(double) ValueToLong(theValue));
}
/*============================================================*/
/* The numeric argument was successfully retrieved. Store the */
/* argument in the user supplied DATA_OBJECT and return TRUE. */
/*============================================================*/
result->type = theType;
result->value = theValue;
return(TRUE);
}
globle int EnvArgTypeCheck(
void *theEnv,
char *functionName,
int argumentPosition,
int expectedType,
DATA_OBJECT_PTR returnValue)
{
/*========================*/
/* Retrieve the argument. */
/*========================*/
EnvRtnUnknown(theEnv,argumentPosition,returnValue);
if (EvaluationData(theEnv)->EvaluationError) return(FALSE);
/*========================================*/
/* If the argument's type exactly matches */
/* the expected type, then return TRUE. */
/*========================================*/
if (returnValue->type == expectedType) return (TRUE);
/*=============================================================*/
/* Some expected types encompass more than one primitive type. */
/* If the argument's type matches one of the primitive types */
/* encompassed by the expected type, then return TRUE. */
/*=============================================================*/
if ((expectedType == INTEGER_OR_FLOAT) &&
((returnValue->type == INTEGER) || (returnValue->type == FLOAT)))
{ return(TRUE); }
if ((expectedType == SYMBOL_OR_STRING) &&
((returnValue->type == SYMBOL) || (returnValue->type == STRING)))
{ return(TRUE); }
#if OBJECT_SYSTEM
if (((expectedType == SYMBOL_OR_STRING) || (expectedType == SYMBOL)) &&
(returnValue->type == INSTANCE_NAME))
{ return(TRUE); }
if ((expectedType == INSTANCE_NAME) &&
((returnValue->type == INSTANCE_NAME) || (returnValue->type == SYMBOL)))
{ return(TRUE); }
if ((expectedType == INSTANCE_OR_INSTANCE_NAME) &&
((returnValue->type == INSTANCE_ADDRESS) ||
(returnValue->type == INSTANCE_NAME) ||
(returnValue->type == SYMBOL)))
{ return(TRUE); }
#endif
/*===========================================================*/
/* If the expected type is float and the argument's type is */
/* integer (or vice versa), then convert the argument's type */
/* to match the expected type and then return TRUE. */
/*===========================================================*/
if ((returnValue->type == INTEGER) && (expectedType == FLOAT))
{
returnValue->type = FLOAT;
returnValue->value = (void *) EnvAddDouble(theEnv,(double) ValueToLong(returnValue->value));
return(TRUE);
}
if ((returnValue->type == FLOAT) && (expectedType == INTEGER))
{
returnValue->type = INTEGER;
returnValue->value = (void *) EnvAddLong(theEnv,(long) ValueToDouble(returnValue->value));
return(TRUE);
}
/*=====================================================*/
/* The argument's type didn't match the expected type. */
/* Print an error message and return FALSE. */
/*=====================================================*/
if (expectedType == FLOAT) ExpectedTypeError1(theEnv,functionName,argumentPosition,"float");
else if (expectedType == INTEGER) ExpectedTypeError1(theEnv,functionName,argumentPosition,"integer");
else if (expectedType == SYMBOL) ExpectedTypeError1(theEnv,functionName,argumentPosition,"symbol");
else if (expectedType == STRING) ExpectedTypeError1(theEnv,functionName,argumentPosition,"string");
else if (expectedType == MULTIFIELD) ExpectedTypeError1(theEnv,functionName,argumentPosition,"multifield");
else if (expectedType == INTEGER_OR_FLOAT) ExpectedTypeError1(theEnv,functionName,argumentPosition,"integer or float");
else if (expectedType == SYMBOL_OR_STRING) ExpectedTypeError1(theEnv,functionName,argumentPosition,"symbol or string");
#if OBJECT_SYSTEM
else if (expectedType == INSTANCE_NAME) ExpectedTypeError1(theEnv,functionName,argumentPosition,"instance name");
else if (expectedType == INSTANCE_ADDRESS) ExpectedTypeError1(theEnv,functionName,argumentPosition,"instance address");
else if (expectedType == INSTANCE_OR_INSTANCE_NAME) ExpectedTypeError1(theEnv,functionName,argumentPosition,"instance address or instance name");
#endif
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(FALSE);
}
/*******************************************************
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);
}
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); }
}
}
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);
}
globle void ConstructsToCCommand()
{
char *fileName;
DATA_OBJECT theArg;
int argCount;
int id, max;
#if VAX_VMS || IBM_MSC || IBM_TBC || IBM_ICB || IBM_ZTC || IBM_SC
int i;
#endif
/*============================================*/
/* Check for appropriate number of arguments. */
/*============================================*/
if ((argCount = ArgRangeCheck("constructs-to-c",2,3)) == -1) return;
/*====================================================*/
/* Get the name of the file in which to place C code. */
/*====================================================*/
if (ArgTypeCheck("constructs-to-c",1,SYMBOL_OR_STRING,&theArg) == FALSE)
{ return; }
fileName = DOToString(theArg);
/*================================*/
/* File names for the VAX and IBM */
/* PCs can't contain a period. */
/*================================*/
#if VAX_VMS || IBM_MSC || IBM_TBC || IBM_ICB || IBM_ZTC || IBM_SC
for (i = 0 ; *(fileName+i) ; i++)
{
if (*(fileName+i) == '.')
{
PrintErrorID("CONSCOMP",1,FALSE);
PrintRouter(WERROR,"Invalid file name ");
PrintRouter(WERROR,fileName);
PrintRouter(WERROR," contains \'.\'\n");
return;
}
}
#endif
/*===========================================*/
/* If the base file name is greater than 3 */
/* characters, issue a warning that the file */
/* name lengths may exceed what is allowed */
/* under some operating systems. */
/*===========================================*/
if (((int) strlen(fileName)) > 3)
{
PrintWarningID("CONSCOMP",1,FALSE);
PrintRouter(WWARNING,"Base file name exceeds 3 characters.\n");
PrintRouter(WWARNING," This may cause files to be overwritten if file name length\n");
PrintRouter(WWARNING," is limited on your platform.\n");
}
/*====================================*/
/* Get the runtime image ID argument. */
/*====================================*/
if (ArgTypeCheck("constructs-to-c",2,INTEGER,&theArg) == FALSE)
{ return; }
id = DOToInteger(theArg);
if (id < 0)
{
ExpectedTypeError1("constructs-to-c",2,"positive integer");
return;
}
/*===========================================*/
/* Get the maximum number of data structures */
/* to store per file argument (if supplied). */
/*===========================================*/
if (argCount == 3)
{
if (ArgTypeCheck("constructs-to-c",3,INTEGER,&theArg) == FALSE)
{ return; }
max = DOToInteger(theArg);
if (max < 0)
{
ExpectedTypeError1("constructs-to-c",3,"positive integer");
return;
}
}
else
{ max = 10000; }
/*============================*/
/* Call the driver routine to */
/* generate the C code. */
/*============================*/
ConstructsToC(fileName,id,max);
}
globle int CheckExpressionAgainstRestrictions(
void *theEnv,
struct expr *theExpression,
char *restrictions,
char *functionName)
{
char theChar[2];
int i = 0, j = 1;
int number1, number2;
int argCount;
char defaultRestriction, argRestriction;
struct expr *argPtr;
int theRestriction;
theChar[0] = '0';
theChar[1] = '\0';
/*============================================*/
/* If there are no restrictions, then there's */
/* no need to check the function. */
/*============================================*/
if (restrictions == NULL) return(FALSE);
/*=========================================*/
/* Count the number of function arguments. */
/*=========================================*/
argCount = CountArguments(theExpression->argList);
/*======================================*/
/* Get the minimum number of arguments. */
/*======================================*/
theChar[0] = restrictions[i++];
if (isdigit(theChar[0]))
{ number1 = atoi(theChar); }
else if (theChar[0] == '*')
{ number1 = -1; }
else
{ return(FALSE); }
/*======================================*/
/* Get the maximum number of arguments. */
/*======================================*/
theChar[0] = restrictions[i++];
if (isdigit(theChar[0]))
{ number2 = atoi(theChar); }
else if (theChar[0] == '*')
{ number2 = 10000; }
else
{ return(FALSE); }
/*============================================*/
/* Check for the correct number of arguments. */
/*============================================*/
if (number1 == number2)
{
if (argCount != number1)
{
ExpectedCountError(theEnv,functionName,EXACTLY,number1);
return(TRUE);
}
}
else if (argCount < number1)
{
ExpectedCountError(theEnv,functionName,AT_LEAST,number1);
return(TRUE);
}
else if (argCount > number2)
{
ExpectedCountError(theEnv,functionName,NO_MORE_THAN,number2);
return(TRUE);
}
/*=======================================*/
/* Check for the default argument types. */
/*=======================================*/
defaultRestriction = restrictions[i];
if (defaultRestriction == '\0')
{ defaultRestriction = 'u'; }
else if (defaultRestriction == '*')
{
defaultRestriction = 'u';
i++;
}
else
{ i++; }
/*======================*/
/* Check each argument. */
/*======================*/
for (argPtr = theExpression->argList;
argPtr != NULL;
argPtr = argPtr->nextArg)
{
argRestriction = restrictions[i];
if (argRestriction == '\0')
{ argRestriction = defaultRestriction; }
else
{ i++; }
if (argRestriction != '*')
{ theRestriction = (int) argRestriction; }
else
{ theRestriction = (int) defaultRestriction; }
if (CheckArgumentAgainstRestriction(theEnv,argPtr,theRestriction))
{
ExpectedTypeError1(theEnv,functionName,j,GetArgumentTypeName(theRestriction));
return(TRUE);
}
j++;
}
return(FALSE);
}
globle void FuncallFunction(
void *theEnv,
DATA_OBJECT *returnValue)
{
int argCount, i, j;
DATA_OBJECT theValue;
FUNCTION_REFERENCE theReference;
char *name;
struct multifield *theMultifield;
struct expr *lastAdd = NULL, *nextAdd, *multiAdd;
/*==================================*/
/* Set up the default return value. */
/*==================================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
/*=================================================*/
/* The funcall function has at least one argument: */
/* the name of the function being called. */
/*=================================================*/
if ((argCount = EnvArgCountCheck(theEnv,"funcall",AT_LEAST,1)) == -1) return;
/*============================================*/
/* Get the name of the function to be called. */
/*============================================*/
if (EnvArgTypeCheck(theEnv,"funcall",1,SYMBOL_OR_STRING,&theValue) == FALSE)
{
return;
}
/*====================*/
/* Find the function. */
/*====================*/
name = DOToString(theValue);
if (! GetFunctionReference(theEnv,name,&theReference))
{
ExpectedTypeError1(theEnv,"funcall",1,"function, deffunction, or generic function name");
return;
}
ExpressionInstall(theEnv,&theReference);
/*======================================*/
/* Add the arguments to the expression. */
/*======================================*/
for (i = 2; i <= argCount; i++)
{
EnvRtnUnknown(theEnv,i,&theValue);
if (GetEvaluationError(theEnv))
{
ExpressionDeinstall(theEnv,&theReference);
return;
}
switch(GetType(theValue))
{
case MULTIFIELD:
nextAdd = GenConstant(theEnv,FCALL,(void *) FindFunction(theEnv,"create$"));
if (lastAdd == NULL)
{
theReference.argList = nextAdd;
}
else
{
lastAdd->nextArg = nextAdd;
}
lastAdd = nextAdd;
multiAdd = NULL;
theMultifield = (struct multifield *) GetValue(theValue);
for (j = GetDOBegin(theValue); j <= GetDOEnd(theValue); j++)
{
nextAdd = GenConstant(theEnv,GetMFType(theMultifield,j),GetMFValue(theMultifield,j));
if (multiAdd == NULL)
{
lastAdd->argList = nextAdd;
}
else
{
multiAdd->nextArg = nextAdd;
}
multiAdd = nextAdd;
}
ExpressionInstall(theEnv,lastAdd);
break;
default:
nextAdd = GenConstant(theEnv,GetType(theValue),GetValue(theValue));
if (lastAdd == NULL)
{
theReference.argList = nextAdd;
}
else
{
lastAdd->nextArg = nextAdd;
}
lastAdd = nextAdd;
ExpressionInstall(theEnv,lastAdd);
break;
}
}
/*===========================================================*/
/* Verify a deffunction has the correct number of arguments. */
/*===========================================================*/
#if DEFFUNCTION_CONSTRUCT
if (theReference.type == PCALL)
{
if (CheckDeffunctionCall(theEnv,theReference.value,CountArguments(theReference.argList)) == FALSE)
{
PrintErrorID(theEnv,"MISCFUN",4,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function funcall called with the wrong number of arguments for deffunction ");
EnvPrintRouter(theEnv,WERROR,EnvGetDeffunctionName(theEnv,theReference.value));
EnvPrintRouter(theEnv,WERROR,"\n");
ExpressionDeinstall(theEnv,&theReference);
ReturnExpression(theEnv,theReference.argList);
return;
}
}
#endif
/*======================*/
/* Call the expression. */
/*======================*/
EvaluateExpression(theEnv,&theReference,returnValue);
/*========================================*/
/* Return the expression data structures. */
/*========================================*/
ExpressionDeinstall(theEnv,&theReference);
ReturnExpression(theEnv,theReference.argList);
}
//madianyi End
globle void UpdateCommand(
void *theEnv,
DATA_OBJECT_PTR rv)
{
long long factIndex;
struct fact *oldFact, *newFact, *theFact;
struct defrule *ExecutingRule = NULL;
struct expr *testPtr;
DATA_OBJECT computeResult;
/*===================================================*/
/* Set the default return value to the symbol FALSE. */
/*===================================================*/
SetpType(rv,SYMBOL);
SetpValue(rv,EnvFalseSymbol(theEnv));
/*==================================================*/
/* Evaluate the first argument which is used to get */
/* a pointer to the fact to be updated. */
/*==================================================*/
testPtr = GetFirstArgument();
EnvIncrementClearReadyLocks(theEnv);
EvaluateExpression(theEnv,testPtr,&computeResult);
EnvDecrementClearReadyLocks(theEnv);
/*==============================================================*/
/* If an integer is supplied, then treat it as a fact-index and */
/* search the fact-list for the fact with that fact-index. */
/*==============================================================*/
if (computeResult.type == INTEGER)
{
factIndex = ValueToLong(computeResult.value);
if (factIndex < 0)
{
ExpectedTypeError1(theEnv,"update",1,"fact-address, fact-index, or the symbol *");
return;
}
/*================================================*/
/* See if a fact with the specified index exists. */
/*================================================*/
oldFact = FindIndexedFact(theEnv,factIndex);
if (oldFact == NULL)
{
char tempBuffer[20];
gensprintf(tempBuffer,"f-%lld",factIndex);
CantFindItemErrorMessage(theEnv,"fact",tempBuffer);
return;
}
}
/*==========================================*/
/* Otherwise, if a pointer is supplied then */
/* no lookup is required. */
/*==========================================*/
else if (computeResult.type == FACT_ADDRESS)
{ oldFact = (struct fact *) computeResult.value; }
/*============================================*/
/* Otherwise the argument has evaluated to an */
/* illegal value for the retract command. */
/*============================================*/
else
{
ExpectedTypeError1(theEnv,"update",1,"fact-address, fact-index, or the symbol *");
SetEvaluationError(theEnv,TRUE);
}
/*============================================*/
/* Retract oldFact and Assert newFact */
/*============================================*/
if (oldFact->localFact != NULL)
{
newFact = oldFact->localFact;
//Remove oldFact from localFactList of ExecutingRule
ExecutingRule = EngineData(theEnv)->ExecutingRule;
if (oldFact == ExecutingRule->lastLocalFact)
{ ExecutingRule->lastLocalFact = oldFact->previousLocalFact; }
if (oldFact->previousLocalFact == NULL)
{
ExecutingRule->localFactList = ExecutingRule->localFactList->nextLocalFact;
if (ExecutingRule->localFactList != NULL)
{ ExecutingRule->localFactList->previousLocalFact = NULL; }
}
else
{
oldFact->previousLocalFact->nextLocalFact = oldFact->nextLocalFact;
if (oldFact->nextLocalFact != NULL)
{ oldFact->nextLocalFact->previousLocalFact = oldFact->previousLocalFact; }
}
EnvRetract(theEnv,oldFact);
theFact = (struct fact *) EnvAssert(theEnv,(void *) newFact);
if (theFact != NULL)
{
SetpType(rv,FACT_ADDRESS);
SetpValue(rv,(void *) theFact);
}
return;
}
else
{
ExpectedTypeError1(theEnv,"update",1,"been set before *");
SetEvaluationError(theEnv,TRUE);
}
}
static void StrOrSymCatFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue,
unsigned short returnType)
{
DATA_OBJECT theArg;
int numArgs, i, total, j;
char *theString;
SYMBOL_HN **arrayOfStrings;
SYMBOL_HN *hashPtr;
char *functionName;
/*============================================*/
/* Determine the calling function name. */
/* Store the null string or the symbol nil as */
/* the return value in the event of an error. */
/*============================================*/
SetpType(returnValue,returnType);
if (returnType == STRING)
{
functionName = "str-cat";
SetpValue(returnValue,(void *) EnvAddSymbol(theEnv,""));
}
else
{
functionName = "sym-cat";
SetpValue(returnValue,(void *) EnvAddSymbol(theEnv,"nil"));
}
/*===============================================*/
/* Determine the number of arguments as create a */
/* string array which is large enough to store */
/* the string representation of each argument. */
/*===============================================*/
numArgs = EnvRtnArgCount(theEnv);
arrayOfStrings = (SYMBOL_HN **) gm1(theEnv,(int) sizeof(SYMBOL_HN *) * numArgs);
for (i = 0; i < numArgs; i++)
{ arrayOfStrings[i] = NULL; }
/*=============================================*/
/* Evaluate each argument and store its string */
/* representation in the string array. */
/*=============================================*/
total = 1;
for (i = 1 ; i <= numArgs ; i++)
{
EnvRtnUnknown(theEnv,i,&theArg);
switch(GetType(theArg))
{
case STRING:
#if OBJECT_SYSTEM
case INSTANCE_NAME:
#endif
case SYMBOL:
hashPtr = (SYMBOL_HN *) GetValue(theArg);
arrayOfStrings[i-1] = hashPtr;
IncrementSymbolCount(hashPtr);
break;
case FLOAT:
hashPtr = (SYMBOL_HN *) EnvAddSymbol(theEnv,FloatToString(theEnv,ValueToDouble(GetValue(theArg))));
arrayOfStrings[i-1] = hashPtr;
IncrementSymbolCount(hashPtr);
break;
case INTEGER:
hashPtr = (SYMBOL_HN *) EnvAddSymbol(theEnv,LongIntegerToString(theEnv,ValueToLong(GetValue(theArg))));
arrayOfStrings[i-1] = hashPtr;
IncrementSymbolCount(hashPtr);
break;
default:
ExpectedTypeError1(theEnv,functionName,i,"string, instance name, symbol, float, or integer");
SetEvaluationError(theEnv,TRUE);
break;
}
if (EvaluationData(theEnv)->EvaluationError)
{
for (i = 0; i < numArgs; i++)
{
if (arrayOfStrings[i] != NULL)
{ DecrementSymbolCount(theEnv,arrayOfStrings[i]); }
}
rm(theEnv,arrayOfStrings,sizeof(SYMBOL_HN *) * numArgs);
return;
}
total += (int) strlen(ValueToString(arrayOfStrings[i - 1]));
}
/*=========================================================*/
/* Allocate the memory to store the concatenated string or */
/* symbol, then copy the values in the string array to the */
/* memory just allocated. */
/*=========================================================*/
theString = (char *) gm2(theEnv,(sizeof(char) * total));
j = 0;
for (i = 0 ; i < numArgs ; i++)
{
sprintf(&theString[j],"%s",ValueToString(arrayOfStrings[i]));
j += (int) strlen(ValueToString(arrayOfStrings[i]));
}
/*=========================================*/
/* Return the concatenated value and clean */
/* up the temporary memory used. */
/*=========================================*/
SetpValue(returnValue,(void *) EnvAddSymbol(theEnv,theString));
rm(theEnv,theString,sizeof(char) * total);
for (i = 0; i < numArgs; i++)
{
if (arrayOfStrings[i] != NULL)
{ DecrementSymbolCount(theEnv,arrayOfStrings[i]); }
}
rm(theEnv,arrayOfStrings,sizeof(SYMBOL_HN *) * numArgs);
}
globle int SaveFactsCommand(
void *theEnv)
{
char *fileName;
int numArgs, saveCode = LOCAL_SAVE;
char *argument;
DATA_OBJECT theValue;
struct expr *theList = NULL;
/*============================================*/
/* Check for the correct number of arguments. */
/*============================================*/
if ((numArgs = EnvArgCountCheck(theEnv,(char*)"save-facts",AT_LEAST,1)) == -1) return(FALSE);
/*=================================================*/
/* Get the file name to which facts will be saved. */
/*=================================================*/
if ((fileName = GetFileName(theEnv,(char*)"save-facts",1)) == NULL) return(FALSE);
/*=============================================================*/
/* If specified, the second argument to save-facts indicates */
/* whether just facts local to the current module or all facts */
/* visible to the current module will be saved. */
/*=============================================================*/
if (numArgs > 1)
{
if (EnvArgTypeCheck(theEnv,(char*)"save-facts",2,SYMBOL,&theValue) == FALSE) return(FALSE);
argument = DOToString(theValue);
if (strcmp(argument,"local") == 0)
{ saveCode = LOCAL_SAVE; }
else if (strcmp(argument,"visible") == 0)
{ saveCode = VISIBLE_SAVE; }
else
{
ExpectedTypeError1(theEnv,(char*)"save-facts",2,(char*)"symbol with value local or visible");
return(FALSE);
}
}
/*======================================================*/
/* Subsequent arguments indicate that only those facts */
/* associated with the specified deftemplates should be */
/* saved to the file. */
/*======================================================*/
if (numArgs > 2) theList = GetFirstArgument()->nextArg->nextArg;
/*====================================*/
/* Call the SaveFacts driver routine. */
/*====================================*/
if (EnvSaveFacts(theEnv,fileName,saveCode,theList) == FALSE)
{ return(FALSE); }
return(TRUE);
}
globle void ListWatchItemsCommand(
void *theEnv)
{
struct watchItem *wPtr;
DATA_OBJECT theValue;
int recognized;
/*=======================*/
/* List the watch items. */
/*=======================*/
if (GetFirstArgument() == NULL)
{
for (wPtr = WatchData(theEnv)->ListOfWatchItems; wPtr != NULL; wPtr = wPtr->next)
{
EnvPrintRouter(theEnv,WDISPLAY,wPtr->name);
if (*(wPtr->flag)) EnvPrintRouter(theEnv,WDISPLAY,sym_equalson);
else EnvPrintRouter(theEnv,WDISPLAY,sym_equalsoff);
}
return;
}
/*=======================================*/
/* Determine which item is to be listed. */
/*=======================================*/
if (EnvArgTypeCheck(theEnv,name_listwatchitems,1,SYMBOL,&theValue) == FALSE) return;
wPtr = ValidWatchItem(theEnv,DOToString(theValue),&recognized);
if ((recognized == FALSE) || (wPtr == NULL))
{
SetEvaluationError(theEnv,TRUE);
ExpectedTypeError1(theEnv,name_listwatchitems,1,sym_watchable_symbol);
return;
}
/*=================================================*/
/* Check to make sure extra arguments are allowed. */
/*=================================================*/
if ((wPtr->printFunc == NULL) &&
(GetNextArgument(GetFirstArgument()) != NULL))
{
SetEvaluationError(theEnv,TRUE);
ExpectedCountError(theEnv,name_listwatchitems,EXACTLY,1);
return;
}
/*====================================*/
/* List the status of the watch item. */
/*====================================*/
EnvPrintRouter(theEnv,WDISPLAY,wPtr->name);
if (*(wPtr->flag)) EnvPrintRouter(theEnv,WDISPLAY,sym_equalson);
else EnvPrintRouter(theEnv,WDISPLAY,sym_equalsoff);
/*============================================*/
/* List the status of individual watch items. */
/*============================================*/
if (wPtr->printFunc != NULL)
{
if ((*wPtr->printFunc)(theEnv,WDISPLAY,wPtr->code,
GetNextArgument(GetFirstArgument())) == FALSE)
{ SetEvaluationError(theEnv,TRUE); }
}
}
globle void ListWatchItemsCommand()
{
struct watchItem *wPtr;
DATA_OBJECT theValue;
int recognized;
/*=======================*/
/* List the watch items. */
/*=======================*/
if (GetFirstArgument() == NULL)
{
for (wPtr = ListOfWatchItems; wPtr != NULL; wPtr = wPtr->next)
{
PrintRouter(WDISPLAY,wPtr->name);
if (*(wPtr->flag)) PrintRouter(WDISPLAY," = on\n");
else PrintRouter(WDISPLAY," = off\n");
}
return;
}
/*=======================================*/
/* Determine which item is to be listed. */
/*=======================================*/
if (ArgTypeCheck("list-watch-items",1,SYMBOL,&theValue) == FALSE) return;
wPtr = ValidWatchItem(DOToString(theValue),&recognized);
if ((recognized == FALSE) || (wPtr == NULL))
{
SetEvaluationError(TRUE);
ExpectedTypeError1("list-watch-items",1,"watchable symbol");
return;
}
/*=================================================*/
/* Check to make sure extra arguments are allowed. */
/*=================================================*/
if ((wPtr->printFunc == NULL) &&
(GetNextArgument(GetFirstArgument()) != NULL))
{
SetEvaluationError(TRUE);
ExpectedCountError("list-watch-items",EXACTLY,1);
return;
}
/*====================================*/
/* List the status of the watch item. */
/*====================================*/
PrintRouter(WDISPLAY,wPtr->name);
if (*(wPtr->flag)) PrintRouter(WDISPLAY," = on\n");
else PrintRouter(WDISPLAY," = off\n");
/*============================================*/
/* List the status of individual watch items. */
/*============================================*/
if (wPtr->printFunc != NULL)
{
if ((*wPtr->printFunc)(WDISPLAY,wPtr->code,
GetNextArgument(GetFirstArgument())) == FALSE)
{ SetEvaluationError(TRUE); }
}
}
/*********************************************************************
NAME : CheckMultifieldSlotModify
DESCRIPTION : For the functions slot-replace$, insert, & delete
as well as direct-slot-replace$, insert, & delete
this function gets the slot, index, and optional
field-value for these functions
INPUTS : 1) A code indicating the type of operation
INSERT (0) : Requires one index
REPLACE (1) : Requires two indices
DELETE_OP (2) : Requires two indices
2) Function name-string
3) Instance address
4) Argument expression chain
5) Caller's buffer for index (or beginning of range)
6) Caller's buffer for end of range
(can be NULL for INSERT)
7) Caller's new-field value buffer
(can be NULL for DELETE_OP)
RETURNS : The address of the instance-slot,
NULL on errors
SIDE EFFECTS : Caller's index buffer set
Caller's new-field value buffer set (if not NULL)
Will allocate an ephemeral segment to store more
than 1 new field value
EvaluationError set on errors
NOTES : Assume the argument chain is at least 2
expressions deep - slot, index, and optional values
*********************************************************************/
static INSTANCE_SLOT *CheckMultifieldSlotModify(
void *theEnv,
int code,
char *func,
INSTANCE_TYPE *ins,
EXPRESSION *args,
int *rb,
int *re,
DATA_OBJECT *newval)
{
DATA_OBJECT temp;
INSTANCE_SLOT *sp;
int start;
start = (args == GetFirstArgument()) ? 1 : 2;
EvaluationData(theEnv)->EvaluationError = FALSE;
EvaluateExpression(theEnv,args,&temp);
if (temp.type != SYMBOL)
{
ExpectedTypeError1(theEnv,func,start,"symbol");
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
sp = FindInstanceSlot(theEnv,ins,(SYMBOL_HN *) temp.value);
if (sp == NULL)
{
SlotExistError(theEnv,ValueToString(temp.value),func);
return(NULL);
}
if (sp->desc->multiple == 0)
{
PrintErrorID(theEnv,"INSMULT",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function ");
EnvPrintRouter(theEnv,WERROR,func);
EnvPrintRouter(theEnv,WERROR," cannot be used on single-field slot ");
EnvPrintRouter(theEnv,WERROR,ValueToString(sp->desc->slotName->name));
EnvPrintRouter(theEnv,WERROR," in instance ");
EnvPrintRouter(theEnv,WERROR,ValueToString(ins->name));
EnvPrintRouter(theEnv,WERROR,".\n");
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
EvaluateExpression(theEnv,args->nextArg,&temp);
if (temp.type != INTEGER)
{
ExpectedTypeError1(theEnv,func,start+1,"integer");
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
args = args->nextArg->nextArg;
*rb = ValueToInteger(temp.value);
if ((code == REPLACE) || (code == DELETE_OP))
{
EvaluateExpression(theEnv,args,&temp);
if (temp.type != INTEGER)
{
ExpectedTypeError1(theEnv,func,start+2,"integer");
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
*re = ValueToInteger(temp.value);
args = args->nextArg;
}
if ((code == INSERT) || (code == REPLACE))
{
if (EvaluateAndStoreInDataObject(theEnv,1,args,newval) == FALSE)
return(NULL);
}
return(sp);
}