void CommandLoop(
void *theEnv)
{
int inchar;
EnvPrintRouter(theEnv,WPROMPT,CommandLineData(theEnv)->BannerString);
EnvSetHaltExecution(theEnv,false);
EnvSetEvaluationError(theEnv,false);
CleanCurrentGarbageFrame(theEnv,NULL);
CallPeriodicTasks(theEnv);
PrintPrompt(theEnv);
RouterData(theEnv)->CommandBufferInputCount = 0;
RouterData(theEnv)->AwaitingInput = true;
while (true)
{
/*===================================================*/
/* If a batch file is active, grab the command input */
/* directly from the batch file, otherwise call the */
/* event function. */
/*===================================================*/
if (BatchActive(theEnv) == true)
{
inchar = LLGetcBatch(theEnv,STDIN,true);
if (inchar == EOF)
{ (*CommandLineData(theEnv)->EventFunction)(theEnv); }
else
{ ExpandCommandString(theEnv,(char) inchar); }
}
else
{ (*CommandLineData(theEnv)->EventFunction)(theEnv); }
/*=================================================*/
/* If execution was halted, then remove everything */
/* from the command buffer. */
/*=================================================*/
if (EnvGetHaltExecution(theEnv) == true)
{
EnvSetHaltExecution(theEnv,false);
EnvSetEvaluationError(theEnv,false);
FlushCommandString(theEnv);
#if ! WINDOW_INTERFACE
fflush(stdin);
#endif
EnvPrintRouter(theEnv,WPROMPT,"\n");
PrintPrompt(theEnv);
}
/*=========================================*/
/* If a complete command is in the command */
/* buffer, then execute it. */
/*=========================================*/
ExecuteIfCommandComplete(theEnv);
}
}
/*******************************************************************************
NAME : PPDefmessageHandlerCommand
DESCRIPTION : Displays the pretty-print form (if any) for a handler
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : None
NOTES : H/L Syntax: (ppdefmessage-handler <class> <message> [<type>])
*******************************************************************************/
globle void PPDefmessageHandlerCommand(
void *theEnv)
{
DATA_OBJECT temp;
SYMBOL_HN *csym,*msym;
const char *tname;
DEFCLASS *cls = NULL;
unsigned mtype;
HANDLER *hnd;
if (EnvArgTypeCheck(theEnv,"ppdefmessage-handler",1,SYMBOL,&temp) == FALSE)
return;
csym = FindSymbolHN(theEnv,DOToString(temp));
if (EnvArgTypeCheck(theEnv,"ppdefmessage-handler",2,SYMBOL,&temp) == FALSE)
return;
msym = FindSymbolHN(theEnv,DOToString(temp));
if (EnvRtnArgCount(theEnv) == 3)
{
if (EnvArgTypeCheck(theEnv,"ppdefmessage-handler",3,SYMBOL,&temp) == FALSE)
return;
tname = DOToString(temp);
}
else
tname = MessageHandlerData(theEnv)->hndquals[MPRIMARY];
mtype = HandlerType(theEnv,"ppdefmessage-handler",tname);
if (mtype == MERROR)
{
EnvSetEvaluationError(theEnv,TRUE);
return;
}
if (csym != NULL)
cls = LookupDefclassByMdlOrScope(theEnv,ValueToString(csym));
if (((cls == NULL) || (msym == NULL)) ? TRUE :
((hnd = FindHandlerByAddress(cls,msym,(unsigned) mtype)) == NULL))
{
PrintErrorID(theEnv,"MSGCOM",2,FALSE);
EnvPrintRouter(theEnv,WERROR,"Unable to find message-handler ");
EnvPrintRouter(theEnv,WERROR,ValueToString(msym));
EnvPrintRouter(theEnv,WERROR," ");
EnvPrintRouter(theEnv,WERROR,tname);
EnvPrintRouter(theEnv,WERROR," for class ");
EnvPrintRouter(theEnv,WERROR,ValueToString(csym));
EnvPrintRouter(theEnv,WERROR," in function ppdefmessage-handler.\n");
EnvSetEvaluationError(theEnv,TRUE);
return;
}
if (hnd->ppForm != NULL)
PrintInChunks(theEnv,WDISPLAY,hnd->ppForm);
}
static struct expr *StandardLoadFact(
void *theEnv,
const char *logicalName,
struct token *theToken)
{
int error = FALSE;
struct expr *temp;
GetToken(theEnv,logicalName,theToken);
if (theToken->type != LPAREN) return(NULL);
temp = GenConstant(theEnv,FCALL,FindFunction(theEnv,"assert"));
temp->argList = GetRHSPattern(theEnv,logicalName,theToken,&error,
TRUE,FALSE,TRUE,RPAREN);
if (error == TRUE)
{
EnvPrintRouter(theEnv,WERROR,"Function load-facts encountered an error\n");
EnvSetEvaluationError(theEnv,TRUE);
ReturnExpression(theEnv,temp);
return(NULL);
}
if (ExpressionContainsVariables(temp,TRUE))
{
ReturnExpression(theEnv,temp);
return(NULL);
}
return(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>])
************************************************************************************/
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)
{
EnvSetEvaluationError(theEnv,TRUE);
return(FALSE);
}
}
if (FindHandlerByAddress(cls,mname,mtype) != NULL)
return(TRUE);
return(FALSE);
}
/*********************************************************************
NAME : SlotExistPCommand
DESCRIPTION : Determines if a slot is present in a class
INPUTS : None
RETURNS : TRUE if the slot exists, FALSE otherwise
SIDE EFFECTS : None
NOTES : H/L Syntax : (slot-existp <class> <slot> [inherit])
*********************************************************************/
globle int SlotExistPCommand(
void *theEnv)
{
DEFCLASS *cls;
SLOT_DESC *sd;
int inheritFlag = FALSE;
DATA_OBJECT dobj;
sd = CheckSlotExists(theEnv,"slot-existp",&cls,FALSE,TRUE);
if (sd == NULL)
return(FALSE);
if (EnvRtnArgCount(theEnv) == 3)
{
if (EnvArgTypeCheck(theEnv,"slot-existp",3,SYMBOL,&dobj) == FALSE)
return(FALSE);
if (strcmp(DOToString(dobj),"inherit") != 0)
{
ExpectedTypeError1(theEnv,"slot-existp",3,"keyword \"inherit\"");
EnvSetEvaluationError(theEnv,TRUE);
return(FALSE);
}
inheritFlag = TRUE;
}
return((sd->cls == cls) ? TRUE : inheritFlag);
}
bool ExecuteIfCommandComplete(
void *theEnv)
{
if ((CompleteCommand(CommandLineData(theEnv)->CommandString) == 0) ||
(RouterData(theEnv)->CommandBufferInputCount == 0) ||
(RouterData(theEnv)->AwaitingInput == false))
{ return false; }
if (CommandLineData(theEnv)->BeforeCommandExecutionFunction != NULL)
{
if (! (*CommandLineData(theEnv)->BeforeCommandExecutionFunction)(theEnv))
{ return false; }
}
FlushPPBuffer(theEnv);
SetPPBufferStatus(theEnv,false);
RouterData(theEnv)->CommandBufferInputCount = 0;
RouterData(theEnv)->AwaitingInput = false;
RouteCommand(theEnv,CommandLineData(theEnv)->CommandString,true);
FlushPPBuffer(theEnv);
FlushParsingMessages(theEnv);
EnvSetHaltExecution(theEnv,false);
EnvSetEvaluationError(theEnv,false);
FlushCommandString(theEnv);
CleanCurrentGarbageFrame(theEnv,NULL);
CallPeriodicTasks(theEnv);
PrintPrompt(theEnv);
return true;
}
/***************************************************
NAME : DetermineRestrictionClass
DESCRIPTION : Finds the class of an argument in
the ProcParamArray
INPUTS : The argument data object
RETURNS : The class address, NULL if error
SIDE EFFECTS : EvaluationError set on errors
NOTES : None
***************************************************/
static DEFCLASS *DetermineRestrictionClass(
void *theEnv,
DATA_OBJECT *dobj)
{
INSTANCE_TYPE *ins;
DEFCLASS *cls;
if (dobj->type == INSTANCE_NAME)
{
ins = FindInstanceBySymbol(theEnv,(SYMBOL_HN *) dobj->value);
cls = (ins != NULL) ? ins->cls : NULL;
}
else if (dobj->type == INSTANCE_ADDRESS)
{
ins = (INSTANCE_TYPE *) dobj->value;
cls = (ins->garbage == 0) ? ins->cls : NULL;
}
else
return(DefclassData(theEnv)->PrimitiveClassMap[dobj->type]);
if (cls == NULL)
{
EnvSetEvaluationError(theEnv,true);
PrintErrorID(theEnv,"GENRCEXE",3,false);
EnvPrintRouter(theEnv,WERROR,"Unable to determine class of ");
PrintDataObject(theEnv,WERROR,dobj);
EnvPrintRouter(theEnv,WERROR," in generic function ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) DefgenericData(theEnv)->CurrentGeneric));
EnvPrintRouter(theEnv,WERROR,".\n");
}
return(cls);
}
/***************************************************************************
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,
DATA_OBJECT *result)
{
INSTANCE_TYPE *ins;
INSTANCE_SLOT *sp;
DATA_OBJECT temp;
QUERY_CORE *core;
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
core = FindQueryCore(theEnv,ValueToInteger(GetpValue(GetFirstArgument())));
ins = core->solns[ValueToInteger(GetpValue(GetFirstArgument()->nextArg))];
EvaluateExpression(theEnv,GetFirstArgument()->nextArg->nextArg,&temp);
if (temp.type != SYMBOL)
{
ExpectedTypeError1(theEnv,"get",1,"symbol");
EnvSetEvaluationError(theEnv,TRUE);
return;
}
sp = FindInstanceSlot(theEnv,ins,(SYMBOL_HN *) temp.value);
if (sp == NULL)
{
SlotExistError(theEnv,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));
}
}
void UDFThrowError(
UDFContext *context)
{
Environment *theEnv = UDFContextEnvironment(context);
EnvSetHaltExecution(theEnv,true);
EnvSetEvaluationError(theEnv,true);
}
globle int SetIncrementalResetCommand(
void *theEnv)
{
int oldValue;
DATA_OBJECT argPtr;
struct defmodule *theModule;
oldValue = EnvGetIncrementalReset(theEnv);
/*============================================*/
/* Check for the correct number of arguments. */
/*============================================*/
if (EnvArgCountCheck(theEnv,"set-incremental-reset",EXACTLY,1) == -1)
{ return(oldValue); }
/*=========================================*/
/* The incremental reset behavior can't be */
/* changed when rules are loaded. */
/*=========================================*/
SaveCurrentModule(theEnv);
for (theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,NULL);
theModule != NULL;
theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,theModule))
{
EnvSetCurrentModule(theEnv,(void *) theModule);
if (EnvGetNextDefrule(theEnv,NULL) != NULL)
{
RestoreCurrentModule(theEnv);
PrintErrorID(theEnv,"INCRRSET",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"The incremental reset behavior cannot be changed with rules loaded.\n");
EnvSetEvaluationError(theEnv,TRUE);
return(oldValue);
}
}
RestoreCurrentModule(theEnv);
/*==================================================*/
/* The symbol FALSE disables incremental reset. Any */
/* other value enables incremental reset. */
/*==================================================*/
EnvRtnUnknown(theEnv,1,&argPtr);
if ((argPtr.value == EnvFalseSymbol(theEnv)) && (argPtr.type == SYMBOL))
{ EnvSetIncrementalReset(theEnv,FALSE); }
else
{ EnvSetIncrementalReset(theEnv,TRUE); }
/*=======================*/
/* Return the old value. */
/*=======================*/
return(oldValue);
}
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);
}
void CommandLoopBatchDriver(
void *theEnv)
{
int inchar;
while (true)
{
if (GetHaltCommandLoopBatch(theEnv) == true)
{
CloseAllBatchSources(theEnv);
SetHaltCommandLoopBatch(theEnv,false);
}
/*===================================================*/
/* If a batch file is active, grab the command input */
/* directly from the batch file, otherwise call the */
/* event function. */
/*===================================================*/
if (BatchActive(theEnv) == true)
{
inchar = LLGetcBatch(theEnv,STDIN,true);
if (inchar == EOF)
{ return; }
else
{ ExpandCommandString(theEnv,(char) inchar); }
}
else
{ return; }
/*=================================================*/
/* If execution was halted, then remove everything */
/* from the command buffer. */
/*=================================================*/
if (EnvGetHaltExecution(theEnv) == true)
{
EnvSetHaltExecution(theEnv,false);
EnvSetEvaluationError(theEnv,false);
FlushCommandString(theEnv);
#if ! WINDOW_INTERFACE
fflush(stdin);
#endif
EnvPrintRouter(theEnv,WPROMPT,"\n");
PrintPrompt(theEnv);
}
/*=========================================*/
/* If a complete command is in the command */
/* buffer, then execute it. */
/*=========================================*/
ExecuteIfCommandComplete(theEnv);
}
}
globle void FactSlotValue(
void *theEnv,
void *vTheFact,
const char *theSlotName,
DATA_OBJECT *returnValue)
{
struct fact *theFact = (struct fact *) vTheFact;
short position;
/*==================================================*/
/* Make sure the slot exists (the symbol implied is */
/* used for the implied slot of an ordered fact). */
/*==================================================*/
if (theFact->whichDeftemplate->implied)
{
if (strcmp(theSlotName,"implied") != 0)
{
EnvSetEvaluationError(theEnv,TRUE);
InvalidDeftemplateSlotMessage(theEnv,theSlotName,
ValueToString(theFact->whichDeftemplate->header.name),FALSE);
return;
}
}
else if (FindSlot(theFact->whichDeftemplate,(SYMBOL_HN *) EnvAddSymbol(theEnv,theSlotName),&position) == NULL)
{
EnvSetEvaluationError(theEnv,TRUE);
InvalidDeftemplateSlotMessage(theEnv,theSlotName,
ValueToString(theFact->whichDeftemplate->header.name),FALSE);
return;
}
/*==========================*/
/* Return the slot's value. */
/*==========================*/
if (theFact->whichDeftemplate->implied)
{ EnvGetFactSlot(theEnv,theFact,NULL,returnValue); }
else
{ EnvGetFactSlot(theEnv,theFact,theSlotName,returnValue); }
}
static void SingularityErrorMessage(
void *theEnv,
const char *functionName)
{
PrintErrorID(theEnv,"EMATHFUN",3,FALSE);
EnvPrintRouter(theEnv,WERROR,"Singularity at asymptote in ");
EnvPrintRouter(theEnv,WERROR,functionName);
EnvPrintRouter(theEnv,WERROR," function.\n");
EnvSetHaltExecution(theEnv,TRUE);
EnvSetEvaluationError(theEnv,TRUE);
}
static void ArgumentOverflowErrorMessage(
void *theEnv,
const char *functionName)
{
PrintErrorID(theEnv,"EMATHFUN",2,FALSE);
EnvPrintRouter(theEnv,WERROR,"Argument overflow for ");
EnvPrintRouter(theEnv,WERROR,functionName);
EnvPrintRouter(theEnv,WERROR," function.\n");
EnvSetHaltExecution(theEnv,TRUE);
EnvSetEvaluationError(theEnv,TRUE);
}
static void DomainErrorMessage(
void *theEnv,
const char *functionName)
{
PrintErrorID(theEnv,"EMATHFUN",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Domain error for ");
EnvPrintRouter(theEnv,WERROR,functionName);
EnvPrintRouter(theEnv,WERROR," function.\n");
EnvSetHaltExecution(theEnv,TRUE);
EnvSetEvaluationError(theEnv,TRUE);
}
globle void ModFunction(
void *theEnv,
DATA_OBJECT_PTR result)
{
DATA_OBJECT item1, item2;
double fnum1, fnum2;
long long lnum1, lnum2;
if (EnvArgCountCheck(theEnv,"mod",EXACTLY,2) == -1)
{
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,0L);
return;
}
if (EnvArgTypeCheck(theEnv,"mod",1,INTEGER_OR_FLOAT,&item1) == FALSE)
{
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,0L);
return;
}
if (EnvArgTypeCheck(theEnv,"mod",2,INTEGER_OR_FLOAT,&item2) == FALSE)
{
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,0L);
return;
}
if (((item2.type == INTEGER) ? (ValueToLong(item2.value) == 0L) : FALSE) ||
((item2.type == FLOAT) ? ValueToDouble(item2.value) == 0.0 : FALSE))
{
DivideByZeroErrorMessage(theEnv,"mod");
EnvSetEvaluationError(theEnv,TRUE);
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,0L);
return;
}
if ((item1.type == FLOAT) || (item2.type == FLOAT))
{
fnum1 = CoerceToDouble(item1.type,item1.value);
fnum2 = CoerceToDouble(item2.type,item2.value);
result->type = FLOAT;
result->value = (void *) EnvAddDouble(theEnv,fnum1 - (dtrunc(fnum1 / fnum2) * fnum2));
}
else
{
lnum1 = DOToLong(item1);
lnum2 = DOToLong(item2);
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,lnum1 - (lnum1 / lnum2) * lnum2);
}
}
/***************************************************************
NAME : ClassExistError
DESCRIPTION : Prints out error message for non-existent class
INPUTS : 1) Name of function having the error
2) The name of the non-existent class
RETURNS : Nothing useful
SIDE EFFECTS : None
NOTES : None
***************************************************************/
void ClassExistError(
void *theEnv,
const char *func,
const char *cname)
{
PrintErrorID(theEnv,"CLASSFUN",1,false);
EnvPrintRouter(theEnv,WERROR,"Unable to find class ");
EnvPrintRouter(theEnv,WERROR,cname);
EnvPrintRouter(theEnv,WERROR," in function ");
EnvPrintRouter(theEnv,WERROR,func);
EnvPrintRouter(theEnv,WERROR,".\n");
EnvSetEvaluationError(theEnv,true);
}
globle void SlotExistError(
void *theEnv,
const char *sname,
const char *func)
{
PrintErrorID(theEnv,"INSFUN",3,FALSE);
EnvPrintRouter(theEnv,WERROR,"No such slot ");
EnvPrintRouter(theEnv,WERROR,sname);
EnvPrintRouter(theEnv,WERROR," in function ");
EnvPrintRouter(theEnv,WERROR,func);
EnvPrintRouter(theEnv,WERROR,".\n");
EnvSetEvaluationError(theEnv,TRUE);
}
/***************************************************
NAME : CheckSlotExists
DESCRIPTION : Checks first two arguments of
a function for a valid class
and (inherited) slot
INPUTS : 1) The name of the function
2) A buffer to hold the found class
3) A flag indicating whether the
non-existence of the slot should
be an error
4) A flag indicating if the slot
can be inherited or not
RETURNS : NULL if slot not found, slot
descriptor otherwise
SIDE EFFECTS : Class buffer set if no errors,
NULL on errors
NOTES : None
***************************************************/
static SLOT_DESC *CheckSlotExists(
void *theEnv,
const char *func,
DEFCLASS **classBuffer,
intBool existsErrorFlag,
intBool inheritFlag)
{
SYMBOL_HN *ssym;
int slotIndex;
SLOT_DESC *sd;
ssym = CheckClassAndSlot(theEnv,func,classBuffer);
if (ssym == NULL)
return(NULL);
slotIndex = FindInstanceTemplateSlot(theEnv,*classBuffer,ssym);
if (slotIndex == -1)
{
if (existsErrorFlag)
{
SlotExistError(theEnv,ValueToString(ssym),func);
EnvSetEvaluationError(theEnv,TRUE);
}
return(NULL);
}
sd = (*classBuffer)->instanceTemplate[slotIndex];
if ((sd->cls == *classBuffer) || inheritFlag)
return(sd);
PrintErrorID(theEnv,"CLASSEXM",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Inherited slot ");
EnvPrintRouter(theEnv,WERROR,ValueToString(ssym));
EnvPrintRouter(theEnv,WERROR," from class ");
PrintClassName(theEnv,WERROR,sd->cls,FALSE);
EnvPrintRouter(theEnv,WERROR," is not valid for function ");
EnvPrintRouter(theEnv,WERROR,func);
EnvPrintRouter(theEnv,WERROR,"\n");
EnvSetEvaluationError(theEnv,TRUE);
return(NULL);
}
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);
}
/**********************************************************
NAME : DetermineQueryClasses
DESCRIPTION : Builds a list of classes to be used in
instance queries - uses parse form.
INPUTS : 1) The parse class expression chain
2) The name of the function being executed
3) Caller's buffer for restriction count
(# of separate lists)
RETURNS : The query list, or NULL on errors
SIDE EFFECTS : Memory allocated for list
Busy count incremented for all classes
NOTES : Each restriction is linked by nxt pointer,
multiple classes in a restriction are
linked by the chain pointer.
Rcnt caller's buffer is set to reflect the
total number of chains
Assumes classExp is not NULL and that each
restriction chain is terminated with
the QUERY_DELIMITER_SYMBOL "(QDS)"
**********************************************************/
static QUERY_CLASS *DetermineQueryClasses(
void *theEnv,
EXPRESSION *classExp,
const char *func,
unsigned *rcnt)
{
QUERY_CLASS *clist = NULL,*cnxt = NULL,*cchain = NULL,*tmp;
int new_list = FALSE;
DATA_OBJECT temp;
*rcnt = 0;
while (classExp != NULL)
{
if (EvaluateExpression(theEnv,classExp,&temp))
{
DeleteQueryClasses(theEnv,clist);
return(NULL);
}
if ((temp.type == SYMBOL) && (temp.value == (void *) InstanceQueryData(theEnv)->QUERY_DELIMETER_SYMBOL))
{
new_list = TRUE;
(*rcnt)++;
}
else if ((tmp = FormChain(theEnv,func,&temp)) != NULL)
{
if (clist == NULL)
clist = cnxt = cchain = tmp;
else if (new_list == TRUE)
{
new_list = FALSE;
cnxt->nxt = tmp;
cnxt = cchain = tmp;
}
else
cchain->chain = tmp;
while (cchain->chain != NULL)
cchain = cchain->chain;
}
else
{
SyntaxErrorMessage(theEnv,"instance-set query class restrictions");
DeleteQueryClasses(theEnv,clist);
EnvSetEvaluationError(theEnv,TRUE);
return(NULL);
}
classExp = classExp->nextArg;
}
return(clist);
}
globle void SyntaxErrorMessage(
void *theEnv,
const char *location)
{
PrintErrorID(theEnv,"PRNTUTIL",2,TRUE);
EnvPrintRouter(theEnv,WERROR,"Syntax Error");
if (location != NULL)
{
EnvPrintRouter(theEnv,WERROR,": Check appropriate syntax for ");
EnvPrintRouter(theEnv,WERROR,location);
}
EnvPrintRouter(theEnv,WERROR,".\n");
EnvSetEvaluationError(theEnv,TRUE);
}
void CommandLoopBatch(
void *theEnv)
{
EnvSetHaltExecution(theEnv,false);
EnvSetEvaluationError(theEnv,false);
CleanCurrentGarbageFrame(theEnv,NULL);
CallPeriodicTasks(theEnv);
PrintPrompt(theEnv);
RouterData(theEnv)->CommandBufferInputCount = 0;
RouterData(theEnv)->AwaitingInput = true;
CommandLoopBatchDriver(theEnv);
}
void MultiIntoSingleFieldSlotError(
void *theEnv,
struct templateSlot *theSlot,
struct deftemplate *theDeftemplate)
{
PrintErrorID(theEnv,"TMPLTFUN",2,true);
EnvPrintRouter(theEnv,WERROR,"Attempted to assert a multifield value \n");
EnvPrintRouter(theEnv,WERROR,"into the single field slot ");
if (theSlot != NULL) EnvPrintRouter(theEnv,WERROR,theSlot->slotName->contents);
else EnvPrintRouter(theEnv,WERROR,"<<unknown>>");
EnvPrintRouter(theEnv,WERROR," of deftemplate ");
if (theDeftemplate != NULL) EnvPrintRouter(theEnv,WERROR,theDeftemplate->header.name->contents);
else EnvPrintRouter(theEnv,WERROR,"<<unknown>>");
EnvPrintRouter(theEnv,WERROR,".\n");
EnvSetEvaluationError(theEnv,true);
}
/***********************************************************************
NAME : OverrideNextMethod
DESCRIPTION : Changes the arguments to shadowed methods, thus the set
of applicable methods to this call may change
INPUTS : A buffer to hold the result of the call
RETURNS : Nothing useful
SIDE EFFECTS : Any of evaluating method restrictions and bodies
NOTES : H/L Syntax: (override-next-method <args>)
***********************************************************************/
void OverrideNextMethod(
UDFContext *context,
CLIPSValue *returnValue)
{
Environment *theEnv = UDFContextEnvironment(context);
mCVSetBoolean(returnValue,false);
if (EvaluationData(theEnv)->HaltExecution)
return;
if (DefgenericData(theEnv)->CurrentMethod == NULL)
{
PrintErrorID(theEnv,"GENRCEXE",2,false);
EnvPrintRouter(theEnv,WERROR,"Shadowed methods not applicable in current context.\n");
EnvSetEvaluationError(theEnv,true);
return;
}
GenericDispatch(theEnv,DefgenericData(theEnv)->CurrentGeneric,DefgenericData(theEnv)->CurrentMethod,NULL,
GetFirstArgument(),returnValue);
}
globle double PowFunction(
void *theEnv)
{
DATA_OBJECT value1, value2;
if (EnvArgCountCheck(theEnv,"**",EXACTLY,2) == -1) return(0.0);
if (EnvArgTypeCheck(theEnv,"**",1,FLOAT,&value1) == FALSE) return(0.0);
if (EnvArgTypeCheck(theEnv,"**",2,FLOAT,&value2) == FALSE) return(0.0);
if (((DOToDouble(value1) == 0.0) &&
(DOToDouble(value2) <= 0.0)) ||
((DOToDouble(value1) < 0.0) &&
(dtrunc((double) DOToDouble(value2)) != DOToDouble(value2))))
{
DomainErrorMessage(theEnv,"**");
EnvSetHaltExecution(theEnv,TRUE);
EnvSetEvaluationError(theEnv,TRUE);
return(0.0);
}
return (pow(DOToDouble(value1),DOToDouble(value2)));
}
static long long GetFactsArgument(
void *theEnv,
int whichOne,
int argumentCount)
{
long long factIndex;
DATA_OBJECT theValue;
if (whichOne > argumentCount) return(UNSPECIFIED);
if (EnvArgTypeCheck(theEnv,"facts",whichOne,INTEGER,&theValue) == FALSE) return(INVALID);
factIndex = DOToLong(theValue);
if (factIndex < 0)
{
ExpectedTypeError1(theEnv,"facts",whichOne,"positive number");
EnvSetHaltExecution(theEnv,TRUE);
EnvSetEvaluationError(theEnv,TRUE);
return(INVALID);
}
return(factIndex);
}
globle void PPFactFunction(
void *theEnv)
{
struct fact *theFact;
int numberOfArguments;
const char *logicalName = NULL; /* Avoids warning */
int ignoreDefaults = FALSE;
DATA_OBJECT theArg;
if ((numberOfArguments = EnvArgRangeCheck(theEnv,"ppfact",1,3)) == -1) return;
theFact = GetFactAddressOrIndexArgument(theEnv,"ppfact",1,TRUE);
if (theFact == NULL) return;
/*===============================================================*/
/* Determine the logical name to which the fact will be printed. */
/*===============================================================*/
if (numberOfArguments == 1)
{ logicalName = STDOUT; }
else
{
logicalName = GetLogicalName(theEnv,2,STDOUT);
if (logicalName == NULL)
{
IllegalLogicalNameMessage(theEnv,"ppfact");
EnvSetHaltExecution(theEnv,TRUE);
EnvSetEvaluationError(theEnv,TRUE);
return;
}
}
/*=========================================*/
/* Should slot values be printed if they */
/* are the same as the default slot value. */
/*=========================================*/
if (numberOfArguments == 3)
{
EnvRtnUnknown(theEnv,3,&theArg);
if ((theArg.value == EnvFalseSymbol(theEnv)) && (theArg.type == SYMBOL))
{ ignoreDefaults = FALSE; }
else
{ ignoreDefaults = TRUE; }
}
/*============================================================*/
/* Determine if any router recognizes the output destination. */
/*============================================================*/
if (strcmp(logicalName,"nil") == 0)
{ return; }
else if (QueryRouters(theEnv,logicalName) == FALSE)
{
UnrecognizedRouterMessage(theEnv,logicalName);
return;
}
EnvPPFact(theEnv,theFact,logicalName,ignoreDefaults);
}
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,"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))
{
EnvSetEvaluationError(theEnv,TRUE);
CantFindItemErrorMessage(theEnv,"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,"facts",1,"symbol or positive number");
EnvSetHaltExecution(theEnv,TRUE);
EnvSetEvaluationError(theEnv,TRUE);
return;
}
argOffset = 0;
}
/*==========================================*/
/* Otherwise the first argument is invalid. */
/*==========================================*/
else
{
ExpectedTypeError1(theEnv,"facts",1,"symbol or positive number");
EnvSetHaltExecution(theEnv,TRUE);
EnvSetEvaluationError(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);
}
