/***************************************************************************
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(
DATA_OBJECT *result)
{
INSTANCE_TYPE *ins;
INSTANCE_SLOT *sp;
DATA_OBJECT temp;
QUERY_CORE *core;
result->type = SYMBOL;
result->value = FalseSymbol;
core = FindQueryCore(DOPToInteger(GetFirstArgument()));
ins = core->solns[DOPToInteger(GetFirstArgument()->nextArg)];
EvaluateExpression(GetFirstArgument()->nextArg->nextArg,&temp);
if (temp.type != SYMBOL)
{
ExpectedTypeError1("get",1,"symbol");
SetEvaluationError(TRUE);
return;
}
sp = FindInstanceSlot(ins,(SYMBOL_HN *) temp.value);
if (sp == NULL)
{
SlotExistError(ValueToString(temp.value),"instance-set query");
return;
}
result->type = sp->type;
result->value = sp->value;
if (sp->type == MULTIFIELD)
{
result->begin = 0;
result->end = GetInstanceSlotLength(sp) - 1;
}
}
void MultiIntoSingleFieldSlotError(
Environment *theEnv,
struct templateSlot *theSlot,
Deftemplate *theDeftemplate)
{
PrintErrorID(theEnv,"TMPLTFUN",1,true);
WriteString(theEnv,STDERR,"Attempted to assert a multifield value ");
WriteString(theEnv,STDERR,"into the single field slot ");
if (theSlot != NULL)
{
WriteString(theEnv,STDERR,"'");
WriteString(theEnv,STDERR,theSlot->slotName->contents);
WriteString(theEnv,STDERR,"'");
}
else
{ WriteString(theEnv,STDERR,"<<unknown>>"); }
WriteString(theEnv,STDERR," of deftemplate ");
if (theDeftemplate != NULL)
{
WriteString(theEnv,STDERR,"'");
WriteString(theEnv,STDERR,theDeftemplate->header.name->contents);
WriteString(theEnv,STDERR,"'");
}
else
{ WriteString(theEnv,STDERR,"<<unknown>>"); }
WriteString(theEnv,STDERR,".\n");
SetEvaluationError(theEnv,true);
}
/************************************************************************************
NAME : MessageHandlerExistPCommand
DESCRIPTION : Determines if a message-handler is present in a class
INPUTS : None
RETURNS : TRUE if the message header is present, FALSE otherwise
SIDE EFFECTS : None
NOTES : H/L Syntax : (message-handler-existp <class> <hnd> [<type>])
************************************************************************************/
globle int MessageHandlerExistPCommand(
void *theEnv)
{
DEFCLASS *cls;
SYMBOL_HN *mname;
DATA_OBJECT temp;
unsigned mtype = MPRIMARY;
if (EnvArgTypeCheck(theEnv,"message-handler-existp",1,SYMBOL,&temp) == FALSE)
return(FALSE);
cls = LookupDefclassByMdlOrScope(theEnv,DOToString(temp));
if (cls == NULL)
{
ClassExistError(theEnv,"message-handler-existp",DOToString(temp));
return(FALSE);
}
if (EnvArgTypeCheck(theEnv,"message-handler-existp",2,SYMBOL,&temp) == FALSE)
return(FALSE);
mname = (SYMBOL_HN *) GetValue(temp);
if (EnvRtnArgCount(theEnv) == 3)
{
if (EnvArgTypeCheck(theEnv,"message-handler-existp",3,SYMBOL,&temp) == FALSE)
return(FALSE);
mtype = HandlerType(theEnv,"message-handler-existp",DOToString(temp));
if (mtype == MERROR)
{
SetEvaluationError(theEnv,TRUE);
return(FALSE);
}
}
if (FindHandlerByAddress(cls,mname,mtype) != NULL)
return(TRUE);
return(FALSE);
}
/*********************************************************************
NAME : 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\"");
SetEvaluationError(theEnv,TRUE);
return(FALSE);
}
inheritFlag = TRUE;
}
return((sd->cls == cls) ? TRUE : inheritFlag);
}
/*********************************************************************
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])
*********************************************************************/
void SlotExistPCommand(
Environment *theEnv,
UDFContext *context,
UDFValue *returnValue)
{
Defclass *cls;
SlotDescriptor *sd;
bool inheritFlag = false;
UDFValue theArg;
sd = CheckSlotExists(context,"slot-existp",&cls,false,true);
if (sd == NULL)
{
returnValue->lexemeValue = FalseSymbol(theEnv);
return;
}
if (UDFHasNextArgument(context))
{
if (! UDFNextArgument(context,SYMBOL_BIT,&theArg))
{ return; }
if (strcmp(theArg.lexemeValue->contents,"inherit") != 0)
{
UDFInvalidArgumentMessage(context,"keyword \"inherit\"");
SetEvaluationError(theEnv,true);
returnValue->lexemeValue = FalseSymbol(theEnv);
return;
}
inheritFlag = true;
}
returnValue->lexemeValue = CreateBoolean(theEnv,((sd->cls == cls) ? true : inheritFlag));
}
/*******************************************************
NAME : TypeName
DESCRIPTION : Given an integer type code, this
function returns the string name of
the type
INPUTS : The type code
RETURNS : The name-string of the type, or
"<???UNKNOWN-TYPE???>" for unrecognized
types
SIDE EFFECTS : EvaluationError set and error message
printed for unrecognized types
NOTES : Used only when COOL is not present
*******************************************************/
globle char *TypeName(
int tcode)
{
switch (tcode)
{
case INTEGER : return(INTEGER_TYPE_NAME);
case FLOAT : return(FLOAT_TYPE_NAME);
case SYMBOL : return(SYMBOL_TYPE_NAME);
case STRING : return(STRING_TYPE_NAME);
case MULTIFIELD : return(MULTIFIELD_TYPE_NAME);
case EXTERNAL_ADDRESS : return(EXTERNAL_ADDRESS_TYPE_NAME);
case FACT_ADDRESS : return(FACT_ADDRESS_TYPE_NAME);
case INSTANCE_ADDRESS : return(INSTANCE_ADDRESS_TYPE_NAME);
case INSTANCE_NAME : return(INSTANCE_NAME_TYPE_NAME);
#if FUZZY_DEFTEMPLATES
case FUZZY_VALUE : return(FUZZY_VALUE_NAME);
#endif
case OBJECT_TYPE_CODE : return(OBJECT_TYPE_NAME);
case PRIMITIVE_TYPE_CODE : return(PRIMITIVE_TYPE_NAME);
case NUMBER_TYPE_CODE : return(NUMBER_TYPE_NAME);
case LEXEME_TYPE_CODE : return(LEXEME_TYPE_NAME);
case ADDRESS_TYPE_CODE : return(ADDRESS_TYPE_NAME);
case INSTANCE_TYPE_CODE : return(INSTANCE_TYPE_NAME);
default : PrintErrorID("INSCOM",1,FALSE);
PrintRouter(WERROR,"Undefined type in function type.\n");
SetEvaluationError(TRUE);
return("<UNKNOWN-TYPE>");
}
}
static struct expr *StandardLoadFact(
void *theEnv,
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");
SetEvaluationError(theEnv,TRUE);
ReturnExpression(theEnv,temp);
return(NULL);
}
if (ExpressionContainsVariables(temp,TRUE))
{
ReturnExpression(theEnv,temp);
return(NULL);
}
return(temp);
}
globle int EnvArgRangeCheck(
void *theEnv,
char *functionName,
int min,
int max)
{
int numberOfArguments;
numberOfArguments = EnvRtnArgCount(theEnv);
if ((numberOfArguments < min) || (numberOfArguments > max))
{
PrintErrorID(theEnv,"ARGACCES",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function ");
EnvPrintRouter(theEnv,WERROR,functionName);
EnvPrintRouter(theEnv,WERROR," expected at least ");
PrintLongInteger(theEnv,WERROR,(long) min);
EnvPrintRouter(theEnv,WERROR," and no more than ");
PrintLongInteger(theEnv,WERROR,(long) max);
EnvPrintRouter(theEnv,WERROR," arguments.\n");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(-1);
}
return(numberOfArguments);
}
globle DATA_OBJECT_PTR EnvRtnUnknown(
void *theEnv,
int argumentPosition,
DATA_OBJECT_PTR returnValue)
{
int count = 1;
struct expr *argPtr;
/*=====================================================*/
/* Find the appropriate argument in the argument list. */
/*=====================================================*/
for (argPtr = EvaluationData(theEnv)->CurrentExpression->argList;
(argPtr != NULL) && (count < argumentPosition);
argPtr = argPtr->nextArg)
{ count++; }
if (argPtr == NULL)
{
NonexistantError(theEnv,"RtnUnknown",
ValueToString(ExpressionFunctionCallName(EvaluationData(theEnv)->CurrentExpression)),
argumentPosition);
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
/*=======================================*/
/* Return the value of the nth argument. */
/*=======================================*/
EvaluateExpression(theEnv,argPtr,returnValue);
return(returnValue);
}
void GetWatchItemCommand(
Environment *theEnv,
UDFContext *context,
UDFValue *returnValue)
{
UDFValue theValue;
const char *argument;
bool recognized;
/*========================================*/
/* Determine which item is to be watched. */
/*========================================*/
if (! UDFFirstArgument(context,SYMBOL_BIT,&theValue))
{ return; }
argument = theValue.lexemeValue->contents;
ValidWatchItem(theEnv,argument,&recognized);
if (recognized == false)
{
SetEvaluationError(theEnv,true);
ExpectedTypeError1(theEnv,"get-watch-item",1,"'watchable symbol'");
returnValue->lexemeValue = FalseSymbol(theEnv);
return;
}
/*===========================*/
/* Get the watch item value. */
/*===========================*/
if (GetWatchItem(theEnv,argument) == 1)
{ returnValue->lexemeValue = TrueSymbol(theEnv); }
else
{ returnValue->lexemeValue = FalseSymbol(theEnv); }
}
/*******************************************************
NAME : TypeName
DESCRIPTION : Given an integer type code, this
function returns the string name of
the type
INPUTS : The type code
RETURNS : The name-string of the type, or
"<???UNKNOWN-TYPE???>" for unrecognized
types
SIDE EFFECTS : EvaluationError set and error message
printed for unrecognized types
NOTES : Used only when COOL is not present
*******************************************************/
globle char *TypeName(
void *theEnv,
EXEC_STATUS,
int tcode)
{
switch (tcode)
{
case INTEGER : return(INTEGER_TYPE_NAME);
case FLOAT : return(FLOAT_TYPE_NAME);
case SYMBOL : return(SYMBOL_TYPE_NAME);
case STRING : return(STRING_TYPE_NAME);
case MULTIFIELD : return(MULTIFIELD_TYPE_NAME);
case EXTERNAL_ADDRESS : return(EXTERNAL_ADDRESS_TYPE_NAME);
case FACT_ADDRESS : return(FACT_ADDRESS_TYPE_NAME);
case INSTANCE_ADDRESS : return(INSTANCE_ADDRESS_TYPE_NAME);
case INSTANCE_NAME : return(INSTANCE_NAME_TYPE_NAME);
case OBJECT_TYPE_CODE : return(OBJECT_TYPE_NAME);
case PRIMITIVE_TYPE_CODE : return(PRIMITIVE_TYPE_NAME);
case NUMBER_TYPE_CODE : return(NUMBER_TYPE_NAME);
case LEXEME_TYPE_CODE : return(LEXEME_TYPE_NAME);
case ADDRESS_TYPE_CODE : return(ADDRESS_TYPE_NAME);
case INSTANCE_TYPE_CODE : return(INSTANCE_TYPE_NAME);
default : PrintErrorID(theEnv,execStatus,"INSCOM",1,FALSE);
EnvPrintRouter(theEnv,execStatus,WERROR,"Undefined type in function type.\n");
SetEvaluationError(theEnv,execStatus,TRUE);
return("<UNKNOWN-TYPE>");
}
}
/**********************************************************
NAME : DetermineQueryTemplates
DESCRIPTION : Builds a list of templates to be used in
fact queries - uses parse form.
INPUTS : 1) The parse template 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 templates
NOTES : Each restriction is linked by nxt pointer,
multiple templates in a restriction are
linked by the chain pointer.
Rcnt caller's buffer is set to reflect the
total number of chains
Assumes templateExp is not NULL and that each
restriction chain is terminated with
the QUERY_DELIMITER_SYMBOL "(QDS)"
**********************************************************/
static QUERY_TEMPLATE *DetermineQueryTemplates(
Environment *theEnv,
Expression *templateExp,
const char *func,
unsigned *rcnt)
{
QUERY_TEMPLATE *clist = NULL, *cnxt = NULL, *cchain = NULL, *tmp;
bool new_list = false;
UDFValue temp;
Deftemplate *theDeftemplate;
*rcnt = 0;
while (templateExp != NULL)
{
theDeftemplate = NULL;
if (templateExp->type == DEFTEMPLATE_PTR)
{ theDeftemplate = (Deftemplate *) templateExp->value; }
else if (EvaluateExpression(theEnv,templateExp,&temp))
{
DeleteQueryTemplates(theEnv,clist);
return NULL;
}
if ((theDeftemplate == NULL) &&
(temp.value == (void *) FactQueryData(theEnv)->QUERY_DELIMITER_SYMBOL))
{
new_list = true;
(*rcnt)++;
}
else if ((tmp = FormChain(theEnv,func,theDeftemplate,&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,"fact-set query class restrictions");
DeleteQueryTemplates(theEnv,clist);
SetEvaluationError(theEnv,true);
return NULL;
}
templateExp = templateExp->nextArg;
}
return clist;
}
globle int SetIncrementalResetCommand(
void *theEnv,
EXEC_STATUS)
{
int oldValue;
DATA_OBJECT argPtr;
struct defmodule *theModule;
oldValue = EnvGetIncrementalReset(theEnv,execStatus);
/*============================================*/
/* Check for the correct number of arguments. */
/*============================================*/
if (EnvArgCountCheck(theEnv,execStatus,"set-incremental-reset",EXACTLY,1) == -1)
{ return(oldValue); }
/*=========================================*/
/* The incremental reset behavior can't be */
/* changed when rules are loaded. */
/*=========================================*/
SaveCurrentModule(theEnv,execStatus);
for (theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,execStatus,NULL);
theModule != NULL;
theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,execStatus,theModule))
{
EnvSetCurrentModule(theEnv,execStatus,(void *) theModule);
if (EnvGetNextDefrule(theEnv,execStatus,NULL) != NULL)
{
RestoreCurrentModule(theEnv,execStatus);
PrintErrorID(theEnv,execStatus,"INCRRSET",1,FALSE);
EnvPrintRouter(theEnv,execStatus,WERROR,"The incremental reset behavior cannot be changed with rules loaded.\n");
SetEvaluationError(theEnv,execStatus,TRUE);
return(oldValue);
}
}
RestoreCurrentModule(theEnv,execStatus);
/*==================================================*/
/* The symbol FALSE disables incremental reset. Any */
/* other value enables incremental reset. */
/*==================================================*/
EnvRtnUnknown(theEnv,execStatus,1,&argPtr);
if ((argPtr.value == EnvFalseSymbol(theEnv,execStatus)) && (argPtr.type == SYMBOL))
{ EnvSetIncrementalReset(theEnv,execStatus,FALSE); }
else
{ EnvSetIncrementalReset(theEnv,execStatus,TRUE); }
/*=======================*/
/* Return the old value. */
/*=======================*/
return(oldValue);
}
void UnwatchCommand(
Environment *theEnv,
UDFContext *context,
UDFValue *returnValue)
{
UDFValue theValue;
const char *argument;
bool recognized;
WatchItemRecord *wPtr;
/*==========================================*/
/* Determine which item is to be unwatched. */
/*==========================================*/
if (! UDFFirstArgument(context,SYMBOL_BIT,&theValue)) return;
argument = theValue.lexemeValue->contents;
wPtr = ValidWatchItem(theEnv,argument,&recognized);
if (recognized == false)
{
SetEvaluationError(theEnv,true);
UDFInvalidArgumentMessage(context,"watchable symbol");
return;
}
/*=================================================*/
/* Check to make sure extra arguments are allowed. */
/*=================================================*/
if (GetNextArgument(GetFirstArgument()) != NULL)
{
if ((wPtr == NULL) ? true : (wPtr->accessFunc == NULL))
{
SetEvaluationError(theEnv,true);
ExpectedCountError(theEnv,"unwatch",EXACTLY,1);
return;
}
}
/*=====================*/
/* Set the watch item. */
/*=====================*/
SetWatchItem(theEnv,argument,false,GetNextArgument(GetFirstArgument()));
}
/********************************************************************
NAME : ExpandFuncCall
DESCRIPTION : This function is a wrap-around for a normal
function call. It preexamines the argument
expression list and expands any references to the
sequence operator. It builds a copy of the
function call expression with these new arguments
inserted and evaluates the function call.
INPUTS : A data object buffer
RETURNS : Nothing useful
SIDE EFFECTS : Expressions alloctaed/deallocated
Function called and arguments evaluated
EvaluationError set on errors
NOTES : None
*******************************************************************/
globle void ExpandFuncCall(
void *theEnv,
DATA_OBJECT *result)
{
EXPRESSION *newargexp,*fcallexp;
struct FunctionDefinition *func;
/* ======================================================================
Copy the original function call's argument expression list.
Look for expand$ function callsexpressions and replace those
with the equivalent expressions of the expansions of evaluations
of the arguments.
====================================================================== */
newargexp = CopyExpression(theEnv,GetFirstArgument()->argList);
ExpandFuncMultifield(theEnv,result,newargexp,&newargexp,
(void *) FindFunction(theEnv,"expand$"));
/* ===================================================================
Build the new function call expression with the expanded arguments.
Check the number of arguments, if necessary, and call the thing.
=================================================================== */
fcallexp = get_struct(theEnv,expr);
fcallexp->type = GetFirstArgument()->type;
fcallexp->value = GetFirstArgument()->value;
fcallexp->nextArg = NULL;
fcallexp->argList = newargexp;
if (fcallexp->type == FCALL)
{
func = (struct FunctionDefinition *) fcallexp->value;
if (CheckFunctionArgCount(theEnv,ValueToString(func->callFunctionName),
func->restrictions,CountArguments(newargexp)) == FALSE)
{
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
ReturnExpression(theEnv,fcallexp);
return;
}
}
#if DEFFUNCTION_CONSTRUCT
else if (fcallexp->type == PCALL)
{
if (CheckDeffunctionCall(theEnv,fcallexp->value,
CountArguments(fcallexp->argList)) == FALSE)
{
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
ReturnExpression(theEnv,fcallexp);
SetEvaluationError(theEnv,TRUE);
return;
}
}
#endif
EvaluateExpression(theEnv,fcallexp,result);
ReturnExpression(theEnv,fcallexp);
}
/***********************************************************************
NAME : DummyExpandFuncMultifield
DESCRIPTION : The expansion of multifield arguments is valid only
when done for a function call. All these expansions
are handled by the H/L wrap-around function
(expansion-call) - see ExpandFuncCall. If the H/L
function, epand-multifield is ever called directly,
it is an error.
INPUTS : Data object buffer
RETURNS : Nothing useful
SIDE EFFECTS : EvaluationError set
NOTES : None
**********************************************************************/
globle void DummyExpandFuncMultifield(
void *theEnv,
DATA_OBJECT *result)
{
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
SetEvaluationError(theEnv,TRUE);
PrintErrorID(theEnv,"MISCFUN",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"expand$ must be used in the argument list of a function call.\n");
}
globle int ParseConstruct(
void *theEnv,
char *name,
char *logicalName)
{
struct construct *currentPtr;
int rv, ov;
/*=================================*/
/* Look for a valid construct name */
/* (e.g. defrule, deffacts). */
/*=================================*/
currentPtr = FindConstruct(theEnv,name);
if (currentPtr == NULL) return(-1);
/*==================================*/
/* Prepare the parsing environment. */
/*==================================*/
ov = GetHaltExecution(theEnv);
SetEvaluationError(theEnv,FALSE);
SetHaltExecution(theEnv,FALSE);
ClearParsedBindNames(theEnv);
PushRtnBrkContexts(theEnv);
ExpressionData(theEnv)->ReturnContext = FALSE;
ExpressionData(theEnv)->BreakContext = FALSE;
EvaluationData(theEnv)->CurrentEvaluationDepth++;
/*=======================================*/
/* Call the construct's parsing routine. */
/*=======================================*/
ConstructData(theEnv)->ParsingConstruct = TRUE;
rv = (*currentPtr->parseFunction)(theEnv,logicalName);
ConstructData(theEnv)->ParsingConstruct = FALSE;
/*===============================*/
/* Restore environment settings. */
/*===============================*/
EvaluationData(theEnv)->CurrentEvaluationDepth--;
PopRtnBrkContexts(theEnv);
ClearParsedBindNames(theEnv);
SetPPBufferStatus(theEnv,OFF);
SetHaltExecution(theEnv,ov);
/*==============================*/
/* Return the status of parsing */
/* the construct. */
/*==============================*/
return(rv);
}
globle 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 (GetHaltExecution(theEnv) == TRUE)
{
SetHaltExecution(theEnv,FALSE);
SetEvaluationError(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 UnwatchCommand(
void *theEnv)
{
DATA_OBJECT theValue;
char *argument;
int recognized;
struct watchItem *wPtr;
/*==========================================*/
/* Determine which item is to be unwatched. */
/*==========================================*/
if (EnvArgTypeCheck(theEnv,"unwatch",1,SYMBOL,&theValue) == FALSE) return;
argument = DOToString(theValue);
wPtr = ValidWatchItem(theEnv,argument,&recognized);
if (recognized == FALSE)
{
SetEvaluationError(theEnv,TRUE);
ExpectedTypeError1(theEnv,"unwatch",1,"watchable symbol");
return;
}
/*=================================================*/
/* Check to make sure extra arguments are allowed. */
/*=================================================*/
if (GetNextArgument(GetFirstArgument()) != NULL)
{
if ((wPtr == NULL) ? TRUE : (wPtr->accessFunc == NULL))
{
SetEvaluationError(theEnv,TRUE);
ExpectedCountError(theEnv,"unwatch",EXACTLY,1);
return;
}
}
/*=====================*/
/* Set the watch item. */
/*=====================*/
EnvSetWatchItem(theEnv,argument,OFF,GetNextArgument(GetFirstArgument()));
}
globle void FactSlotValue(
void *theEnv,
void *vTheFact,
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)
{
SetEvaluationError(theEnv,TRUE);
InvalidDeftemplateSlotMessage(theEnv,theSlotName,
ValueToString(theFact->whichDeftemplate->header.name));
return;
}
}
else if (FindSlot(theFact->whichDeftemplate,(SYMBOL_HN *) EnvAddSymbol(theEnv,theSlotName),&position) == NULL)
{
SetEvaluationError(theEnv,TRUE);
InvalidDeftemplateSlotMessage(theEnv,theSlotName,
ValueToString(theFact->whichDeftemplate->header.name));
return;
}
/*==========================*/
/* Return the slot's value. */
/*==========================*/
if (theFact->whichDeftemplate->implied)
{ EnvGetFactSlot(theEnv,theFact,NULL,returnValue); }
else
{ EnvGetFactSlot(theEnv,theFact,theSlotName,returnValue); }
}
/***************************************************
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 SlotDescriptor *CheckSlotExists(
UDFContext *context,
const char *func,
Defclass **classBuffer,
bool existsErrorFlag,
bool inheritFlag)
{
CLIPSLexeme *ssym;
int slotIndex;
SlotDescriptor *sd;
Environment *theEnv = context->environment;
ssym = CheckClassAndSlot(context,func,classBuffer);
if (ssym == NULL)
return NULL;
slotIndex = FindInstanceTemplateSlot(theEnv,*classBuffer,ssym);
if (slotIndex == -1)
{
if (existsErrorFlag)
{
SlotExistError(theEnv,ssym->contents,func);
SetEvaluationError(theEnv,true);
}
return NULL;
}
sd = (*classBuffer)->instanceTemplate[slotIndex];
if ((sd->cls == *classBuffer) || inheritFlag)
{ return sd; }
PrintErrorID(theEnv,"CLASSEXM",1,false);
WriteString(theEnv,STDERR,"Inherited slot '");
WriteString(theEnv,STDERR,ssym->contents);
WriteString(theEnv,STDERR,"' from class ");
PrintClassName(theEnv,STDERR,sd->cls,true,false);
WriteString(theEnv,STDERR," is not valid for function '");
WriteString(theEnv,STDERR,func);
WriteString(theEnv,STDERR,"'.\n");
SetEvaluationError(theEnv,true);
return NULL;
}
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");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(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");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
}
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");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(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");
SetEvaluationError(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);
}
}
globle void CommandLoopBatch(
void *theEnv)
{
SetHaltExecution(theEnv,FALSE);
SetEvaluationError(theEnv,FALSE);
PeriodicCleanup(theEnv,TRUE,FALSE);
PrintPrompt(theEnv);
RouterData(theEnv)->CommandBufferInputCount = 0;
CommandLoopBatchDriver(theEnv);
}
/***************************************************************
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
***************************************************************/
globle void ClassExistError(
char *func,
char *cname)
{
PrintErrorID("CLASSFUN",1,FALSE);
PrintRouter(WERROR,"Unable to find class ");
PrintRouter(WERROR,cname);
PrintRouter(WERROR," in function ");
PrintRouter(WERROR,func);
PrintRouter(WERROR,".\n");
SetEvaluationError(TRUE);
}
/*****************************************************
NAME : DynamicHandlerGetSlot
DESCRIPTION : Directly references a slot's value
(uses dynamic binding to lookup slot)
INPUTS : The caller's result buffer
RETURNS : Nothing useful
SIDE EFFECTS : Caller's result buffer set
NOTES : H/L Syntax: (get <slot>)
*****************************************************/
globle void DynamicHandlerGetSlot(
DATA_OBJECT *result)
{
INSTANCE_SLOT *sp;
INSTANCE_TYPE *ins;
DATA_OBJECT temp;
result->type = SYMBOL;
result->value = FalseSymbol;
if (CheckCurrentMessage("dynamic-get",TRUE) == FALSE)
return;
EvaluateExpression(GetFirstArgument(),&temp);
if (temp.type != SYMBOL)
{
ExpectedTypeError1("dynamic-get",1,"symbol");
SetEvaluationError(TRUE);
return;
}
ins = GetActiveInstance();
sp = FindInstanceSlot(ins,(SYMBOL_HN *) temp.value);
if (sp == NULL)
{
SlotExistError(ValueToString(temp.value),"dynamic-get");
return;
}
if ((sp->desc->publicVisibility == 0) &&
(CurrentCore->hnd->cls != sp->desc->cls))
{
SlotVisibilityViolationError(sp->desc,CurrentCore->hnd->cls);
SetEvaluationError(TRUE);
return;
}
result->type = sp->type;
result->value = sp->value;
if (sp->type == MULTIFIELD)
{
result->begin = 0;
result->end = GetInstanceSlotLength(sp) - 1;
}
}
/***************************************************************************
NAME : GetQueryFactSlot
DESCRIPTION : Internal function for referring to slots of fact in
fact array on fact-queries
INPUTS : The caller's result buffer
RETURNS : Nothing useful
SIDE EFFECTS : Caller's result buffer set appropriately
NOTES : H/L Syntax : ((query-fact-slot) <index> <slot-name>)
**************************************************************************/
globle void GetQueryFactSlot(
void *theEnv,
DATA_OBJECT *result)
{
struct fact *theFact;
DATA_OBJECT temp;
QUERY_CORE *core;
short position;
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
core = FindQueryCore(theEnv,ValueToInteger(GetpValue(GetFirstArgument())));
theFact = core->solns[ValueToInteger(GetpValue(GetFirstArgument()->nextArg))];
EvaluateExpression(theEnv,GetFirstArgument()->nextArg->nextArg,&temp);
if (temp.type != SYMBOL)
{
ExpectedTypeError1(theEnv,"get",1,"symbol");
SetEvaluationError(theEnv,TRUE);
return;
}
/*==================================================*/
/* Make sure the slot exists (the symbol implied is */
/* used for the implied slot of an ordered fact). */
/*==================================================*/
if (theFact->whichDeftemplate->implied)
{
if (strcmp(ValueToString(temp.value),"implied") != 0)
{
SlotExistError(theEnv,ValueToString(temp.value),"fact-set query");
return;
}
position = 1;
}
else if (FindSlot((struct deftemplate *) theFact->whichDeftemplate,
(struct symbolHashNode *) temp.value,&position) == NULL)
{
SlotExistError(theEnv,ValueToString(temp.value),"fact-set query");
return;
}
result->type = theFact->theProposition.theFields[position-1].type;
result->value = theFact->theProposition.theFields[position-1].value;
if (result->type == MULTIFIELD)
{
SetpDOBegin(result,1);
SetpDOEnd(result,((struct multifield *) result->value)->multifieldLength);
}
}
globle void SlotExistError(
void *theEnv,
char *sname,
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");
SetEvaluationError(theEnv,TRUE);
}