/***********************************************************************************
NAME : MVSlotReplaceCommand
DESCRIPTION : Allows user to replace a specified field of a multi-value slot
The slot is directly read (w/o a get- message) and the new
slot-value is placed via a put- message.
This function is not valid for single-value slots.
INPUTS : Caller's result buffer
RETURNS : TRUE if multi-value slot successfully modified,
FALSE otherwise
SIDE EFFECTS : Put messsage sent for slot
NOTES : H/L Syntax : (slot-replace$ <instance> <slot>
<range-begin> <range-end> <value>)
***********************************************************************************/
globle void MVSlotReplaceCommand(
void *theEnv,
DATA_OBJECT *result)
{
DATA_OBJECT newval,newseg,oldseg;
INSTANCE_TYPE *ins;
INSTANCE_SLOT *sp;
int rb,re;
EXPRESSION arg;
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
ins = CheckMultifieldSlotInstance(theEnv,"slot-replace$");
if (ins == NULL)
return;
sp = CheckMultifieldSlotModify(theEnv,REPLACE,"slot-replace$",ins,
GetFirstArgument()->nextArg,&rb,&re,&newval);
if (sp == NULL)
return;
AssignSlotToDataObject(&oldseg,sp);
if (ReplaceMultiValueField(theEnv,&newseg,&oldseg,rb,re,&newval,"slot-replace$") == FALSE)
return;
arg.type = MULTIFIELD;
arg.value = (void *) &newseg;
arg.nextArg = NULL;
arg.argList = NULL;
DirectMessage(theEnv,sp->desc->overrideMessage,ins,result,&arg);
}
/***********************************************************************************
NAME : MVSlotInsertCommand
DESCRIPTION : Allows user to insert a specified field of a multi-value slot
The slot is directly read (w/o a get- message) and the new
slot-value is placed via a put- message.
This function is not valid for single-value slots.
INPUTS : Caller's result buffer
RETURNS : TRUE if multi-value slot successfully modified, FALSE otherwise
SIDE EFFECTS : Put messsage sent for slot
NOTES : H/L Syntax : (slot-insert$ <instance> <slot> <index> <value>)
***********************************************************************************/
globle void MVSlotInsertCommand(
void *theEnv,
DATA_OBJECT *result)
{
DATA_OBJECT newval,newseg,oldseg;
INSTANCE_TYPE *ins;
INSTANCE_SLOT *sp;
long theIndex;
EXPRESSION arg;
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
ins = CheckMultifieldSlotInstance(theEnv,(char*)"slot-insert$");
if (ins == NULL)
return;
sp = CheckMultifieldSlotModify(theEnv,INSERT,(char*)"slot-insert$",ins,
GetFirstArgument()->nextArg,&theIndex,NULL,&newval);
if (sp == NULL)
return;
AssignSlotToDataObject(&oldseg,sp);
if (InsertMultiValueField(theEnv,&newseg,&oldseg,theIndex,&newval,(char*)"slot-insert$") == FALSE)
return;
arg.type = MULTIFIELD;
arg.value = (void *) &newseg;
arg.nextArg = NULL;
arg.argList = NULL;
DirectMessage(theEnv,sp->desc->overrideMessage,ins,result,&arg);
}
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);
}
globle void EvalFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
PrintErrorID(theEnv,"STRNGFUN",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function eval does not work in run time modules.\n");
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
}
globle void *GetFocusFunction(
void *theEnv)
{
struct defmodule *rv;
EnvArgCountCheck(theEnv,"get-focus",EXACTLY,0);
rv = (struct defmodule *) EnvGetFocus(theEnv);
if (rv == NULL) return((SYMBOL_HN *) EnvFalseSymbol(theEnv));
return(rv->name);
}
/***********************************************************************
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");
}
/*******************************************************
NAME : EvaluateDeffunctionCall
DESCRIPTION : Primitive support function for
calling a deffunction
INPUTS : 1) The deffunction
2) A data object buffer to hold
the evaluation result
RETURNS : FALSE if the deffunction
returns the symbol FALSE,
TRUE otherwise
SIDE EFFECTS : Data obejct buffer set and any
side-effects of calling the deffunction
NOTES : None
*******************************************************/
static intBool EvaluateDeffunctionCall(
void *theEnv,
void *value,
DATA_OBJECT *result)
{
CallDeffunction(theEnv,(DEFFUNCTION *) value,GetFirstArgument(),result);
if ((GetpType(result) == SYMBOL) &&
(GetpValue(result) == EnvFalseSymbol(theEnv)))
return(FALSE);
return(TRUE);
}
globle void *PopFocusFunction(
void *theEnv)
{
struct defmodule *theModule;
EnvArgCountCheck(theEnv,"pop-focus",EXACTLY,0);
theModule = (struct defmodule *) EnvPopFocus(theEnv);
if (theModule == NULL) return((SYMBOL_HN *) EnvFalseSymbol(theEnv));
return(theModule->name);
}
/*****************************************************
NAME : ObjectCmpConstantFunction
DESCRIPTION : Used to compare object slot values
against a constant
INPUTS : 1) The constant test bitmap
2) Data object buffer to hold result
RETURNS : TRUE if test successful,
FALSE otherwise
SIDE EFFECTS : Buffer set to symbol TRUE if test
successful, FALSE otherwise
NOTES : Called directly by
EvaluatePatternExpression()
*****************************************************/
globle intBool ObjectCmpConstantFunction(
void *theEnv,
void *theValue,
DATA_OBJECT *theResult)
{
struct ObjectCmpPNConstant *hack;
DATA_OBJECT theVar;
EXPRESSION *constantExp;
int rv;
SEGMENT *theSegment;
hack = (struct ObjectCmpPNConstant *) ValueToBitMap(theValue);
if (hack->general)
{
EvaluateExpression(theEnv,GetFirstArgument(),&theVar);
constantExp = GetFirstArgument()->nextArg;
}
else
{
constantExp = GetFirstArgument();
if (ObjectReteData(theEnv)->CurrentPatternObjectSlot->type == MULTIFIELD)
{
theSegment = (struct multifield *) ObjectReteData(theEnv)->CurrentPatternObjectSlot->value;
if (hack->fromBeginning)
{
theVar.type = theSegment->theFields[hack->offset].type;
theVar.value = theSegment->theFields[hack->offset].value;
}
else
{
theVar.type = theSegment->theFields[theSegment->multifieldLength -
(hack->offset + 1)].type;
theVar.value = theSegment->theFields[theSegment->multifieldLength -
(hack->offset + 1)].value;
}
}
else
{
theVar.type = (unsigned short) ObjectReteData(theEnv)->CurrentPatternObjectSlot->type;
theVar.value = ObjectReteData(theEnv)->CurrentPatternObjectSlot->value;
}
}
if (theVar.type != constantExp->type)
rv = hack->fail;
else if (theVar.value != constantExp->value)
rv = hack->fail;
else
rv = hack->pass;
theResult->type = SYMBOL;
theResult->value = rv ? EnvTrueSymbol(theEnv) : EnvFalseSymbol(theEnv);
return(rv);
}
/***************************************************************************
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 *GetCurrentModuleCommand(
void *theEnv)
{
struct defmodule *theModule;
EnvArgCountCheck(theEnv,"get-current-module",EXACTLY,0);
theModule = (struct defmodule *) EnvGetCurrentModule(theEnv);
if (theModule == NULL) return((SYMBOL_HN *) EnvFalseSymbol(theEnv));
return((SYMBOL_HN *) EnvAddSymbol(theEnv,ValueToString(theModule->name)));
}
globle void ReturnFunction(
void *theEnv,
DATA_OBJECT_PTR result)
{
if (EnvRtnArgCount(theEnv) == 0)
{
result->type = RVOID;
result->value = EnvFalseSymbol(theEnv);
}
else
EnvRtnUnknown(theEnv,1,result);
ProcedureFunctionData(theEnv)->ReturnFlag = TRUE;
}
globle void StrIndexFunction(
void *theEnv,
DATA_OBJECT_PTR result)
{
DATA_OBJECT theArgument1, theArgument2;
char *strg1, *strg2;
int i, j;
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
/*===================================*/
/* Check and retrieve the arguments. */
/*===================================*/
if (EnvArgCountCheck(theEnv,"str-index",EXACTLY,2) == -1) return;
if (EnvArgTypeCheck(theEnv,"str-index",1,SYMBOL_OR_STRING,&theArgument1) == FALSE) return;
if (EnvArgTypeCheck(theEnv,"str-index",2,SYMBOL_OR_STRING,&theArgument2) == FALSE) return;
strg1 = DOToString(theArgument1);
strg2 = DOToString(theArgument2);
/*=================================*/
/* Find the position in string2 of */
/* string1 (counting from 1). */
/*=================================*/
if (strlen(strg1) == 0)
{
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,(long) strlen(strg2) + 1L);
return;
}
for (i=1; *strg2; i++, strg2++)
{
for (j=0; *(strg1+j) && *(strg1+j) == *(strg2+j); j++)
{ /* Do Nothing */ }
if (*(strg1+j) == '\0')
{
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,(long) i);
return;
}
}
return;
}
/****************************************************************
NAME : SetSORCommand
DESCRIPTION : Toggles SequenceOpMode - if TRUE, multifield
references are replaced with sequence
expansion operators
INPUTS : None
RETURNS : The old value of SequenceOpMode
SIDE EFFECTS : SequenceOpMode toggled
NOTES : None
****************************************************************/
globle BOOLEAN SetSORCommand(
void *theEnv)
{
#if (! RUN_TIME) && (! BLOAD_ONLY)
DATA_OBJECT arg;
if (EnvArgTypeCheck(theEnv,"set-sequence-operator-recognition",1,SYMBOL,&arg) == FALSE)
return(ExpressionData(theEnv)->SequenceOpMode);
return(EnvSetSequenceOperatorRecognition(theEnv,(arg.value == EnvFalseSymbol(theEnv)) ?
FALSE : TRUE));
#else
return(ExpressionData(theEnv)->SequenceOpMode);
#endif
}
/******************************************************************************
NAME : DelayedQueryDoForAllInstances
DESCRIPTION : Finds all sets of instances which satisfy the query and
and exceutes a user-action for each set
This function differs from QueryDoForAllInstances() in
that it forms the complete list of query satisfactions
BEFORE executing any actions.
INPUTS : Caller's result buffer
RETURNS : Nothing useful
SIDE EFFECTS : The query class-expressions are evaluated once,
and the query boolean-expression is evaluated
once for every instance set. The action is executed
for evry query satisfaction.
Caller's result buffer holds result of last action executed.
NOTES : H/L Syntax : See ParseQueryNoAction()
******************************************************************************/
globle void DelayedQueryDoForAllInstances(
void *theEnv,
EXEC_STATUS,
DATA_OBJECT *result)
{
QUERY_CLASS *qclasses;
unsigned rcnt;
register unsigned i;
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv,execStatus);
qclasses = DetermineQueryClasses(theEnv,execStatus,GetFirstArgument()->nextArg->nextArg,
"delayed-do-for-all-instances",&rcnt);
if (qclasses == NULL)
return;
PushQueryCore(theEnv,execStatus);
InstanceQueryData(theEnv,execStatus)->QueryCore = get_struct(theEnv,execStatus,query_core);
InstanceQueryData(theEnv,execStatus)->QueryCore->solns = (INSTANCE_TYPE **) gm2(theEnv,execStatus,(sizeof(INSTANCE_TYPE *) * rcnt));
InstanceQueryData(theEnv,execStatus)->QueryCore->query = GetFirstArgument();
InstanceQueryData(theEnv,execStatus)->QueryCore->action = NULL;
InstanceQueryData(theEnv,execStatus)->QueryCore->soln_set = NULL;
InstanceQueryData(theEnv,execStatus)->QueryCore->soln_size = rcnt;
InstanceQueryData(theEnv,execStatus)->QueryCore->soln_cnt = 0;
TestEntireChain(theEnv,execStatus,qclasses,0);
InstanceQueryData(theEnv,execStatus)->AbortQuery = FALSE;
InstanceQueryData(theEnv,execStatus)->QueryCore->action = GetFirstArgument()->nextArg;
while (InstanceQueryData(theEnv,execStatus)->QueryCore->soln_set != NULL)
{
for (i = 0 ; i < rcnt ; i++)
InstanceQueryData(theEnv,execStatus)->QueryCore->solns[i] = InstanceQueryData(theEnv,execStatus)->QueryCore->soln_set->soln[i];
PopQuerySoln(theEnv,execStatus);
execStatus->CurrentEvaluationDepth++;
EvaluateExpression(theEnv,execStatus,InstanceQueryData(theEnv,execStatus)->QueryCore->action,result);
execStatus->CurrentEvaluationDepth--;
if (ProcedureFunctionData(theEnv,execStatus)->ReturnFlag == TRUE)
{ PropagateReturnValue(theEnv,execStatus,result); }
PeriodicCleanup(theEnv,execStatus,FALSE,TRUE);
if (execStatus->HaltExecution || ProcedureFunctionData(theEnv,execStatus)->BreakFlag || ProcedureFunctionData(theEnv,execStatus)->ReturnFlag)
{
while (InstanceQueryData(theEnv,execStatus)->QueryCore->soln_set != NULL)
PopQuerySoln(theEnv,execStatus);
break;
}
}
ProcedureFunctionData(theEnv,execStatus)->BreakFlag = FALSE;
rm(theEnv,execStatus,(void *) InstanceQueryData(theEnv,execStatus)->QueryCore->solns,(sizeof(INSTANCE_TYPE *) * rcnt));
rtn_struct(theEnv,execStatus,query_core,InstanceQueryData(theEnv,execStatus)->QueryCore);
PopQueryCore(theEnv,execStatus);
DeleteQueryClasses(theEnv,execStatus,qclasses);
}
/*****************************************************************
NAME : TestForFirstFactInTemplate
DESCRIPTION : Processes all facts in a template
INPUTS : 1) Visitation traversal id
2) The template
3) The current template restriction chain
4) The index of the current restriction
RETURNS : TRUE if query succeeds, FALSE otherwise
SIDE EFFECTS : Fact variable values set
NOTES : None
*****************************************************************/
static int TestForFirstFactInTemplate(
void *theEnv,
struct deftemplate *templatePtr,
QUERY_TEMPLATE *qchain,
int indx)
{
struct fact *theFact;
DATA_OBJECT temp;
theFact = templatePtr->factList;
while (theFact != NULL)
{
FactQueryData(theEnv)->QueryCore->solns[indx] = theFact;
if (qchain->nxt != NULL)
{
theFact->factHeader.busyCount++;
if (TestForFirstInChain(theEnv,qchain->nxt,indx+1) == TRUE)
{
theFact->factHeader.busyCount--;
break;
}
theFact->factHeader.busyCount--;
if ((EvaluationData(theEnv)->HaltExecution == TRUE) || (FactQueryData(theEnv)->AbortQuery == TRUE))
break;
}
else
{
theFact->factHeader.busyCount++;
EvaluationData(theEnv)->CurrentEvaluationDepth++;
EvaluateExpression(theEnv,FactQueryData(theEnv)->QueryCore->query,&temp);
EvaluationData(theEnv)->CurrentEvaluationDepth--;
PeriodicCleanup(theEnv,FALSE,TRUE);
theFact->factHeader.busyCount--;
if (EvaluationData(theEnv)->HaltExecution == TRUE)
break;
if ((temp.type != SYMBOL) ? TRUE :
(temp.value != EnvFalseSymbol(theEnv)))
break;
}
theFact = theFact->nextTemplateFact;
while ((theFact != NULL) ? (theFact->garbage == 1) : FALSE)
theFact = theFact->nextTemplateFact;
}
if (theFact != NULL)
return(((EvaluationData(theEnv)->HaltExecution == TRUE) || (FactQueryData(theEnv)->AbortQuery == TRUE))
? FALSE : TRUE);
return(FALSE);
}
/******************************************************************************
NAME : DelayedQueryDoForAllFacts
DESCRIPTION : Finds all sets of facts which satisfy the query and
and exceutes a user-action for each set
This function differs from QueryDoForAllFacts() in
that it forms the complete list of query satisfactions
BEFORE executing any actions.
INPUTS : Caller's result buffer
RETURNS : Nothing useful
SIDE EFFECTS : The query template-expressions are evaluated once,
and the query boolean-expression is evaluated
once for every fact set. The action is executed
for evry query satisfaction.
Caller's result buffer holds result of last action executed.
NOTES : H/L Syntax : See FactParseQueryNoAction()
******************************************************************************/
globle void DelayedQueryDoForAllFacts(
void *theEnv,
DATA_OBJECT *result)
{
QUERY_TEMPLATE *qtemplates;
unsigned rcnt;
register unsigned i;
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
qtemplates = DetermineQueryTemplates(theEnv,GetFirstArgument()->nextArg->nextArg,
"delayed-do-for-all-facts",&rcnt);
if (qtemplates == NULL)
return;
PushQueryCore(theEnv);
FactQueryData(theEnv)->QueryCore = get_struct(theEnv,query_core);
FactQueryData(theEnv)->QueryCore->solns = (struct fact **) gm2(theEnv,(sizeof(struct fact *) * rcnt));
FactQueryData(theEnv)->QueryCore->query = GetFirstArgument();
FactQueryData(theEnv)->QueryCore->action = NULL;
FactQueryData(theEnv)->QueryCore->soln_set = NULL;
FactQueryData(theEnv)->QueryCore->soln_size = rcnt;
FactQueryData(theEnv)->QueryCore->soln_cnt = 0;
TestEntireChain(theEnv,qtemplates,0);
FactQueryData(theEnv)->AbortQuery = FALSE;
FactQueryData(theEnv)->QueryCore->action = GetFirstArgument()->nextArg;
while (FactQueryData(theEnv)->QueryCore->soln_set != NULL)
{
for (i = 0 ; i < rcnt ; i++)
FactQueryData(theEnv)->QueryCore->solns[i] = FactQueryData(theEnv)->QueryCore->soln_set->soln[i];
PopQuerySoln(theEnv);
EvaluationData(theEnv)->CurrentEvaluationDepth++;
EvaluateExpression(theEnv,FactQueryData(theEnv)->QueryCore->action,result);
EvaluationData(theEnv)->CurrentEvaluationDepth--;
if (ProcedureFunctionData(theEnv)->ReturnFlag == TRUE)
{ PropagateReturnValue(theEnv,result); }
PeriodicCleanup(theEnv,FALSE,TRUE);
if (EvaluationData(theEnv)->HaltExecution || ProcedureFunctionData(theEnv)->BreakFlag || ProcedureFunctionData(theEnv)->ReturnFlag)
{
while (FactQueryData(theEnv)->QueryCore->soln_set != NULL)
PopQuerySoln(theEnv);
break;
}
}
ProcedureFunctionData(theEnv)->BreakFlag = FALSE;
rm(theEnv,(void *) FactQueryData(theEnv)->QueryCore->solns,(sizeof(struct fact *) * rcnt));
rtn_struct(theEnv,query_core,FactQueryData(theEnv)->QueryCore);
PopQueryCore(theEnv);
DeleteQueryTemplates(theEnv,qtemplates);
}
globle int EnvEval(
void *theEnv,
char *theString,
DATA_OBJECT_PTR returnValue)
{
#if (MAC_MCW || IBM_MCW) && (RUN_TIME || BLOAD_ONLY)
#pragma unused(theString)
#endif
PrintErrorID(theEnv,"STRNGFUN",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function eval does not work in run time modules.\n");
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
return(FALSE);
}
globle intBool NotFunction(
void *theEnv)
{
EXPRESSION *theArgument;
DATA_OBJECT result;
theArgument = GetFirstArgument();
if (theArgument == NULL) { return(FALSE); }
if (EvaluateExpression(theEnv,theArgument,&result)) return(FALSE);
if ((result.value == EnvFalseSymbol(theEnv)) && (result.type == SYMBOL))
{ return(TRUE); }
return(FALSE);
}
globle int SetFactDuplicationCommand(
void *theEnv)
{
int oldValue;
DATA_OBJECT theValue;
/*=====================================================*/
/* Get the old value of the fact duplication behavior. */
/*=====================================================*/
oldValue = EnvGetFactDuplication(theEnv);
/*============================================*/
/* Check for the correct number of arguments. */
/*============================================*/
if (EnvArgCountCheck(theEnv,"set-fact-duplication",EXACTLY,1) == -1)
{
return(oldValue);
}
/*========================*/
/* Evaluate the argument. */
/*========================*/
EnvRtnUnknown(theEnv,1,&theValue);
/*===============================================================*/
/* If the argument evaluated to FALSE, then the fact duplication */
/* behavior is disabled, otherwise it is enabled. */
/*===============================================================*/
if ((theValue.value == EnvFalseSymbol(theEnv)) && (theValue.type == SYMBOL))
{
EnvSetFactDuplication(theEnv,FALSE);
}
else
{
EnvSetFactDuplication(theEnv,TRUE);
}
/*========================================================*/
/* Return the old value of the fact duplication behavior. */
/*========================================================*/
return(oldValue);
}
globle int SetIncrementalResetCommand(
void *theEnv)
{
int oldValue;
DATA_OBJECT argPtr;
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. */
/*=========================================*/
if (EnvGetNextDefrule(theEnv,NULL) != NULL)
{
PrintErrorID(theEnv,"INCRRSET",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"The incremental reset behavior cannot be changed with rules loaded.\n");
SetEvaluationError(theEnv,TRUE);
return(oldValue);
}
/*==================================================*/
/* 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);
}
static intBool SlotLengthTestFunction(
void *theEnv,
void *theValue,
DATA_OBJECT *theResult)
{
struct ObjectMatchLength *hack;
theResult->type = SYMBOL;
theResult->value = EnvFalseSymbol(theEnv);
hack = (struct ObjectMatchLength *) ValueToBitMap(theValue);
if (ObjectReteData(theEnv)->CurrentObjectSlotLength < hack->minLength)
return(FALSE);
if (hack->exactly && (ObjectReteData(theEnv)->CurrentObjectSlotLength > hack->minLength))
return(FALSE);
theResult->value = EnvTrueSymbol(theEnv);
return(TRUE);
}
globle void *SetCurrentModuleCommand(
void *theEnv)
{
DATA_OBJECT argPtr;
char *argument;
struct defmodule *theModule;
SYMBOL_HN *defaultReturn;
/*=====================================================*/
/* Check for the correct number and type of arguments. */
/*=====================================================*/
theModule = ((struct defmodule *) EnvGetCurrentModule(theEnv));
if (theModule == NULL) return((SYMBOL_HN *) EnvFalseSymbol(theEnv));
defaultReturn = (SYMBOL_HN *) EnvAddSymbol(theEnv,ValueToString(((struct defmodule *) EnvGetCurrentModule(theEnv))->name));
if (EnvArgCountCheck(theEnv,"set-current-module",EXACTLY,1) == -1)
{ return(defaultReturn); }
if (EnvArgTypeCheck(theEnv,"set-current-module",1,SYMBOL,&argPtr) == FALSE)
{ return(defaultReturn); }
argument = DOToString(argPtr);
/*================================================*/
/* Set the current module to the specified value. */
/*================================================*/
theModule = (struct defmodule *) EnvFindDefmodule(theEnv,argument);
if (theModule == NULL)
{
CantFindItemErrorMessage(theEnv,"defmodule",argument);
return(defaultReturn);
}
EnvSetCurrentModule(theEnv,(void *) theModule);
/*================================*/
/* Return the new current module. */
/*================================*/
return((SYMBOL_HN *) defaultReturn);
}
globle intBool AndFunction(
void *theEnv,
EXEC_STATUS)
{
EXPRESSION *theArgument;
DATA_OBJECT result;
for (theArgument = GetFirstArgument();
theArgument != NULL;
theArgument = GetNextArgument(theArgument))
{
if (EvaluateExpression(theEnv,execStatus,theArgument,&result)) return(FALSE);
if ((result.value == EnvFalseSymbol(theEnv,execStatus)) && (result.type == SYMBOL))
{ return(FALSE); }
}
return(TRUE);
}
globle intBool OrFunction(
void *theEnv)
{
EXPRESSION *theArgument;
DATA_OBJECT result;
for (theArgument = GetFirstArgument();
theArgument != NULL;
theArgument = GetNextArgument(theArgument))
{
if (EvaluateExpression(theEnv,theArgument,&result)) return(FALSE);
if ((result.value != EnvFalseSymbol(theEnv)) || (result.type != SYMBOL))
{ return(TRUE); }
}
return(FALSE);
}
globle void SwitchFunction(
void *theEnv,
DATA_OBJECT_PTR result)
{
DATA_OBJECT switch_val,case_val;
EXPRESSION *theExp;
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
/* ==========================
Get the value to switch on
========================== */
EvaluateExpression(theEnv,GetFirstArgument(),&switch_val);
if (EvaluationData(theEnv)->EvaluationError)
return;
for (theExp = GetFirstArgument()->nextArg ; theExp != NULL ; theExp = theExp->nextArg->nextArg)
{
/* =================================================
RVOID is the default case (if any) for the switch
================================================= */
if (theExp->type == RVOID)
{
EvaluateExpression(theEnv,theExp->nextArg,result);
return;
}
/* ====================================================
If the case matches, evaluate the actions and return
==================================================== */
EvaluateExpression(theEnv,theExp,&case_val);
if (EvaluationData(theEnv)->EvaluationError)
return;
if (switch_val.type == case_val.type)
{
if ((case_val.type == MULTIFIELD) ? MultifieldDOsEqual(&switch_val,&case_val) :
(switch_val.value == case_val.value))
{
EvaluateExpression(theEnv,theExp->nextArg,result);
return;
}
}
}
}
static void ResetDefglobalAction(
void *theEnv,
struct constructHeader *theConstruct,
void *buffer)
{
#if MAC_XCD
#pragma unused(buffer)
#endif
struct defglobal *theDefglobal = (struct defglobal *) theConstruct;
DATA_OBJECT assignValue;
if (EvaluateExpression(theEnv,theDefglobal->initial,&assignValue))
{
assignValue.type = SYMBOL;
assignValue.value = EnvFalseSymbol(theEnv);
}
QSetDefglobalValue(theEnv,theDefglobal,&assignValue,FALSE);
}
globle int SSCCommand(
void *theEnv)
{
int oldValue;
DATA_OBJECT arg_ptr;
oldValue = EnvGetStaticConstraintChecking(theEnv);
if (EnvArgCountCheck(theEnv,"set-static-constraint-checking",EXACTLY,1) == -1)
{ return(oldValue); }
EnvRtnUnknown(theEnv,1,&arg_ptr);
if ((arg_ptr.value == EnvFalseSymbol(theEnv)) && (arg_ptr.type == SYMBOL))
{ EnvSetStaticConstraintChecking(theEnv,FALSE); }
else
{ EnvSetStaticConstraintChecking(theEnv,TRUE); }
return(oldValue);
}
static int DefaultCompareSwapFunction(
void *theEnv,
DATA_OBJECT *item1,
DATA_OBJECT *item2)
{
DATA_OBJECT returnValue;
SortFunctionData(theEnv)->SortComparisonFunction->argList = GenConstant(theEnv,item1->type,item1->value);
SortFunctionData(theEnv)->SortComparisonFunction->argList->nextArg = GenConstant(theEnv,item2->type,item2->value);
ExpressionInstall(theEnv,SortFunctionData(theEnv)->SortComparisonFunction);
EvaluateExpression(theEnv,SortFunctionData(theEnv)->SortComparisonFunction,&returnValue);
ExpressionDeinstall(theEnv,SortFunctionData(theEnv)->SortComparisonFunction);
ReturnExpression(theEnv,SortFunctionData(theEnv)->SortComparisonFunction->argList);
SortFunctionData(theEnv)->SortComparisonFunction->argList = NULL;
if ((GetType(returnValue) == SYMBOL) &&
(GetValue(returnValue) == EnvFalseSymbol(theEnv)))
{ return(FALSE); }
return(TRUE);
}
globle void FactSlotValueFunction(
void *theEnv,
DATA_OBJECT *returnValue)
{
struct fact *theFact;
DATA_OBJECT theValue;
/*=============================================*/
/* Set up the default return value for errors. */
/*=============================================*/
returnValue->type = SYMBOL;
returnValue->value = EnvFalseSymbol(theEnv);
/*============================================*/
/* Check for the correct number of arguments. */
/*============================================*/
if (EnvArgCountCheck(theEnv,"fact-slot-value",EXACTLY,2) == -1) return;
/*================================*/
/* Get the reference to the fact. */
/*================================*/
theFact = GetFactAddressOrIndexArgument(theEnv,"fact-slot-value",1,TRUE);
if (theFact == NULL) return;
/*===========================*/
/* Get the name of the slot. */
/*===========================*/
if (EnvArgTypeCheck(theEnv,"fact-slot-value",2,SYMBOL,&theValue) == FALSE)
{ return; }
/*=======================*/
/* Get the slot's value. */
/*=======================*/
FactSlotValue(theEnv,theFact,DOToString(theValue),returnValue);
}
