globle void CommandLoop(
void *theEnv)
{
int inchar;
EnvPrintRouter(theEnv,WPROMPT,CommandLineData(theEnv)->BannerString);
SetHaltExecution(theEnv,FALSE);
SetEvaluationError(theEnv,FALSE);
PeriodicCleanup(theEnv,TRUE,FALSE);
PrintPrompt(theEnv);
RouterData(theEnv)->CommandBufferInputCount = 0;
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 (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 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 char *EnvRtnLexeme(
void *theEnv,
int argumentPosition)
{
int count = 1;
DATA_OBJECT result;
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,"RtnLexeme",
ValueToString(ExpressionFunctionCallName(EvaluationData(theEnv)->CurrentExpression)),
argumentPosition);
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
/*============================================*/
/* Return the value of the nth argument if it */
/* is a symbol, string, or instance name. */
/*============================================*/
EvaluateExpression(theEnv,argPtr,&result);
if ((result.type == SYMBOL) ||
#if OBJECT_SYSTEM
(result.type == INSTANCE_NAME) ||
#endif
(result.type == STRING))
{ return(ValueToString(result.value));}
/*======================================================*/
/* Generate an error if the argument is the wrong type. */
/*======================================================*/
ExpectedTypeError3(theEnv,"RtnLexeme",
ValueToString(ExpressionFunctionCallName(EvaluationData(theEnv)->CurrentExpression)),
argumentPosition,"symbol, string, or instance name");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
globle long EnvRtnLong(
void *theEnv,
int argumentPosition)
{
int count = 1;
DATA_OBJECT result;
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,"RtnLong",
ValueToString(ExpressionFunctionCallName(EvaluationData(theEnv)->CurrentExpression)),
argumentPosition);
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(1L);
}
/*======================================*/
/* Return the value of the nth argument */
/* if it is a float or integer. */
/*======================================*/
EvaluateExpression(theEnv,argPtr,&result);
if (result.type == FLOAT)
{ return((long) ValueToDouble(result.value)); }
else if (result.type == INTEGER)
{ return(ValueToLong(result.value)); }
/*======================================================*/
/* Generate an error if the argument is the wrong type. */
/*======================================================*/
ExpectedTypeError3(theEnv,"RtnLong",
ValueToString(ExpressionFunctionCallName(EvaluationData(theEnv)->CurrentExpression)),
argumentPosition,"number");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(1L);
}
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);
}
static void _cdecl CatchCtrlC()
{
#if ALLOW_ENVIRONMENT_GLOBALS
SetHaltExecution(GetCurrentEnvironment(),TRUE);
CloseAllBatchSources(GetCurrentEnvironment());
#endif
}
globle int FunctionCall2(
FUNCTION_REFERENCE *theReference,
char *args,
DATA_OBJECT *result)
{
EXPRESSION *argexps;
int error = FALSE;
/*=============================================*/
/* Force periodic cleanup if the function call */
/* was executed from an embedded application. */
/*=============================================*/
if ((CurrentEvaluationDepth == 0) && (! EvaluatingTopLevelCommand) &&
(CurrentExpression == NULL))
{ PeriodicCleanup(TRUE,FALSE); }
/*========================*/
/* Reset the error state. */
/*========================*/
if (CurrentEvaluationDepth == 0) SetHaltExecution(FALSE);
EvaluationError = FALSE;
/*======================================*/
/* Initialize the default return value. */
/*======================================*/
result->type = SYMBOL;
result->value = FalseSymbol;
/*============================*/
/* Parse the argument string. */
/*============================*/
argexps = ParseConstantArguments(args,&error);
if (error == TRUE) return(TRUE);
/*====================*/
/* Call the function. */
/*====================*/
theReference->argList = argexps;
error = EvaluateExpression(theReference,result);
/*========================*/
/* Return the expression. */
/*========================*/
ReturnExpression(argexps);
theReference->argList = NULL;
/*==========================*/
/* Return the error status. */
/*==========================*/
return(error);
}
static void CatchCtrlC(
int sgnl)
{
#if ALLOW_ENVIRONMENT_GLOBALS
SetHaltExecution(GetCurrentEnvironment(),TRUE);
CloseAllBatchSources(GetCurrentEnvironment());
#endif
signal(SIGINT,CatchCtrlC);
}
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 CommandLoopBatch(
void *theEnv)
{
SetHaltExecution(theEnv,FALSE);
SetEvaluationError(theEnv,FALSE);
PeriodicCleanup(theEnv,TRUE,FALSE);
PrintPrompt(theEnv);
RouterData(theEnv)->CommandBufferInputCount = 0;
CommandLoopBatchDriver(theEnv);
}
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 CatchCtrlC()
{
#if ALLOW_ENVIRONMENT_GLOBALS
_XSTACK *sf; /* Real-mode interrupt handler stack frame. */
sf = (_XSTACK *) _get_stk_frame(); /* Get pointer to V86 _XSTACK frame. */
SetHaltExecution(GetCurrentEnvironment(),TRUE); /* Terminate execution and */
CloseAllBatchSources(GetCurrentEnvironment()); /* return to the command prompt. */
sf->opts |= _STK_NOINT; /* Set _ST_NOINT to prevent V86 call. */
#endif
}
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 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 PrintDataObject(
void *theEnv,
const char *fileid,
DATA_OBJECT_PTR argPtr)
{
switch(argPtr->type)
{
case RVOID:
case SYMBOL:
case STRING:
case INTEGER:
case FLOAT:
case EXTERNAL_ADDRESS:
case DATA_OBJECT_ARRAY: // TBD Remove with AddPrimitive
case FACT_ADDRESS:
#if OBJECT_SYSTEM
case INSTANCE_NAME:
case INSTANCE_ADDRESS:
#endif
PrintAtom(theEnv,fileid,argPtr->type,argPtr->value);
break;
case MULTIFIELD:
PrintMultifield(theEnv,fileid,(struct multifield *) argPtr->value,
argPtr->begin,argPtr->end,TRUE);
break;
default:
if (EvaluationData(theEnv)->PrimitivesArray[argPtr->type] != NULL)
{
if (EvaluationData(theEnv)->PrimitivesArray[argPtr->type]->longPrintFunction)
{
(*EvaluationData(theEnv)->PrimitivesArray[argPtr->type]->longPrintFunction)(theEnv,fileid,argPtr->value);
break;
}
else if (EvaluationData(theEnv)->PrimitivesArray[argPtr->type]->shortPrintFunction)
{
(*EvaluationData(theEnv)->PrimitivesArray[argPtr->type]->shortPrintFunction)(theEnv,fileid,argPtr->value);
break;
}
}
EnvPrintRouter(theEnv,fileid,"<UnknownPrintType");
PrintLongInteger(theEnv,fileid,(long int) argPtr->type);
EnvPrintRouter(theEnv,fileid,">");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
break;
}
}
globle void PrintDataObject(
char *fileid,
DATA_OBJECT_PTR argPtr)
{
switch(argPtr->type)
{
case RVOID:
case SYMBOL:
case STRING:
case INTEGER:
case FLOAT:
case EXTERNAL_ADDRESS:
case FACT_ADDRESS:
#if OBJECT_SYSTEM
case INSTANCE_NAME:
case INSTANCE_ADDRESS:
#endif
#if FUZZY_DEFTEMPLATES
case FUZZY_VALUE:
#endif
PrintAtom(fileid,argPtr->type,argPtr->value);
break;
case MULTIFIELD:
PrintMultifield(fileid,(struct multifield *) argPtr->value,
argPtr->begin,argPtr->end,TRUE);
break;
default:
if (PrimitivesArray[argPtr->type] != NULL)
{
if (PrimitivesArray[argPtr->type]->longPrintFunction)
{
(*PrimitivesArray[argPtr->type]->longPrintFunction)(fileid,argPtr->value);
break;
}
else if (PrimitivesArray[argPtr->type]->shortPrintFunction)
{
(*PrimitivesArray[argPtr->type]->shortPrintFunction)(fileid,argPtr->value);
break;
}
}
PrintRouter(fileid,"<UnknownPrintType");
PrintLongInteger(fileid,(long int) argPtr->type);
PrintRouter(fileid,">");
SetHaltExecution(TRUE);
SetEvaluationError(TRUE);
break;
}
}
globle intBool ExecuteIfCommandComplete(
void *theEnv)
{
if ((CompleteCommand(CommandLineData(theEnv)->CommandString) == 0) ||
(RouterData(theEnv)->CommandBufferInputCount <= 0))
{ return FALSE; }
FlushPPBuffer(theEnv);
SetPPBufferStatus(theEnv,OFF);
RouterData(theEnv)->CommandBufferInputCount = -1;
RouteCommand(theEnv,CommandLineData(theEnv)->CommandString,TRUE);
FlushPPBuffer(theEnv);
SetHaltExecution(theEnv,FALSE);
SetEvaluationError(theEnv,FALSE);
FlushCommandString(theEnv);
FlushBindList(theEnv);
PeriodicCleanup(theEnv,TRUE,FALSE);
PrintPrompt(theEnv);
return TRUE;
}
globle int EnvArgCountCheck(
void *theEnv,
char *functionName,
int countRelation,
int expectedNumber)
{
int numberOfArguments;
/*==============================================*/
/* Get the number of arguments for the function */
/* currently being evaluated. */
/*==============================================*/
numberOfArguments = EnvRtnArgCount(theEnv);
/*=========================================================*/
/* If the function satisfies expected number of arguments, */
/* constraint, then return the number of arguments found. */
/*=========================================================*/
if (countRelation == EXACTLY)
{ if (numberOfArguments == expectedNumber) return(numberOfArguments); }
else if (countRelation == AT_LEAST)
{ if (numberOfArguments >= expectedNumber) return(numberOfArguments); }
else if (countRelation == NO_MORE_THAN)
{ if (numberOfArguments <= expectedNumber) return(numberOfArguments); }
/*================================================*/
/* The correct number of arguments was not found. */
/* Generate an error message and return -1. */
/*================================================*/
ExpectedCountError(theEnv,functionName,countRelation,expectedNumber);
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(-1);
}
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,"**");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(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,(char*)"facts",whichOne,INTEGER,&theValue) == FALSE) return(INVALID);
factIndex = DOToLong(theValue);
if (factIndex < 0)
{
ExpectedTypeError1(theEnv,(char*)"facts",whichOne,(char*)"positive number");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(INVALID);
}
return(factIndex);
}
globle int EnvArgTypeCheck(
void *theEnv,
char *functionName,
int argumentPosition,
int expectedType,
DATA_OBJECT_PTR returnValue)
{
/*========================*/
/* Retrieve the argument. */
/*========================*/
EnvRtnUnknown(theEnv,argumentPosition,returnValue);
if (EvaluationData(theEnv)->EvaluationError) return(FALSE);
/*========================================*/
/* If the argument's type exactly matches */
/* the expected type, then return TRUE. */
/*========================================*/
if (returnValue->type == expectedType) return (TRUE);
/*=============================================================*/
/* Some expected types encompass more than one primitive type. */
/* If the argument's type matches one of the primitive types */
/* encompassed by the expected type, then return TRUE. */
/*=============================================================*/
if ((expectedType == INTEGER_OR_FLOAT) &&
((returnValue->type == INTEGER) || (returnValue->type == FLOAT)))
{ return(TRUE); }
if ((expectedType == SYMBOL_OR_STRING) &&
((returnValue->type == SYMBOL) || (returnValue->type == STRING)))
{ return(TRUE); }
#if OBJECT_SYSTEM
if (((expectedType == SYMBOL_OR_STRING) || (expectedType == SYMBOL)) &&
(returnValue->type == INSTANCE_NAME))
{ return(TRUE); }
if ((expectedType == INSTANCE_NAME) &&
((returnValue->type == INSTANCE_NAME) || (returnValue->type == SYMBOL)))
{ return(TRUE); }
if ((expectedType == INSTANCE_OR_INSTANCE_NAME) &&
((returnValue->type == INSTANCE_ADDRESS) ||
(returnValue->type == INSTANCE_NAME) ||
(returnValue->type == SYMBOL)))
{ return(TRUE); }
#endif
/*===========================================================*/
/* If the expected type is float and the argument's type is */
/* integer (or vice versa), then convert the argument's type */
/* to match the expected type and then return TRUE. */
/*===========================================================*/
if ((returnValue->type == INTEGER) && (expectedType == FLOAT))
{
returnValue->type = FLOAT;
returnValue->value = (void *) EnvAddDouble(theEnv,(double) ValueToLong(returnValue->value));
return(TRUE);
}
if ((returnValue->type == FLOAT) && (expectedType == INTEGER))
{
returnValue->type = INTEGER;
returnValue->value = (void *) EnvAddLong(theEnv,(long) ValueToDouble(returnValue->value));
return(TRUE);
}
/*=====================================================*/
/* The argument's type didn't match the expected type. */
/* Print an error message and return FALSE. */
/*=====================================================*/
if (expectedType == FLOAT) ExpectedTypeError1(theEnv,functionName,argumentPosition,"float");
else if (expectedType == INTEGER) ExpectedTypeError1(theEnv,functionName,argumentPosition,"integer");
else if (expectedType == SYMBOL) ExpectedTypeError1(theEnv,functionName,argumentPosition,"symbol");
else if (expectedType == STRING) ExpectedTypeError1(theEnv,functionName,argumentPosition,"string");
else if (expectedType == MULTIFIELD) ExpectedTypeError1(theEnv,functionName,argumentPosition,"multifield");
else if (expectedType == INTEGER_OR_FLOAT) ExpectedTypeError1(theEnv,functionName,argumentPosition,"integer or float");
else if (expectedType == SYMBOL_OR_STRING) ExpectedTypeError1(theEnv,functionName,argumentPosition,"symbol or string");
#if OBJECT_SYSTEM
else if (expectedType == INSTANCE_NAME) ExpectedTypeError1(theEnv,functionName,argumentPosition,"instance name");
else if (expectedType == INSTANCE_ADDRESS) ExpectedTypeError1(theEnv,functionName,argumentPosition,"instance address");
else if (expectedType == INSTANCE_OR_INSTANCE_NAME) ExpectedTypeError1(theEnv,functionName,argumentPosition,"instance address or instance name");
#endif
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(FALSE);
}
globle void DivisionFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
double ftotal = 1.0;
long ltotal = 1L;
intBool useFloatTotal;
EXPRESSION *theExpression;
DATA_OBJECT theArgument;
int pos = 1;
useFloatTotal = BasicMathFunctionData(theEnv)->AutoFloatDividend;
/*===================================================*/
/* 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. */
/*===================================================*/
theExpression = GetFirstArgument();
if (theExpression != NULL)
{
if (! GetNumericArgument(theEnv,theExpression,"/",&theArgument,useFloatTotal,pos)) theExpression = NULL;
else theExpression = GetNextArgument(theExpression);
if (theArgument.type == INTEGER)
{ ltotal = ValueToLong(theArgument.value); }
else
{
ftotal = ValueToDouble(theArgument.value);
useFloatTotal = TRUE;
}
pos++;
}
/*====================================================*/
/* 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 (theExpression != NULL)
{
if (! GetNumericArgument(theEnv,theExpression,"/",&theArgument,useFloatTotal,pos)) theExpression = NULL;
else theExpression = GetNextArgument(theExpression);
if ((theArgument.type == INTEGER) ? (ValueToLong(theArgument.value) == 0L) :
((theArgument.type == FLOAT) ? ValueToDouble(theArgument.value) == 0.0 : FALSE))
{
DivideByZeroErrorMessage(theEnv,"/");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
returnValue->type = FLOAT;
returnValue->value = (void *) EnvAddDouble(theEnv,1.0);
return;
}
if (useFloatTotal)
{ ftotal /= ValueToDouble(theArgument.value); }
else
{
if (theArgument.type == INTEGER)
{ ltotal /= ValueToLong(theArgument.value); }
else
{
ftotal = (double) ltotal / ValueToDouble(theArgument.value);
useFloatTotal = TRUE;
}
}
pos++;
}
/*======================================================*/
/* If a floating point number was in the argument list, */
/* then return a float, otherwise return an integer. */
/*======================================================*/
if (useFloatTotal)
{
returnValue->type = FLOAT;
returnValue->value = (void *) EnvAddDouble(theEnv,ftotal);
}
else
{
returnValue->type = INTEGER;
returnValue->value = (void *) EnvAddLong(theEnv,ltotal);
}
}
globle void FactsCommand(
void *theEnv)
{
int argumentCount;
long long start = UNSPECIFIED, end = UNSPECIFIED, max = UNSPECIFIED;
struct defmodule *theModule;
DATA_OBJECT theValue;
int argOffset;
/*=========================================================*/
/* Determine the number of arguments to the facts command. */
/*=========================================================*/
if ((argumentCount = EnvArgCountCheck(theEnv,(char*)"facts",NO_MORE_THAN,4)) == -1) return;
/*==================================*/
/* The default module for the facts */
/* command is the current module. */
/*==================================*/
theModule = ((struct defmodule *) EnvGetCurrentModule(theEnv));
/*==========================================*/
/* If no arguments were specified, then use */
/* the default values to list the facts. */
/*==========================================*/
if (argumentCount == 0)
{
EnvFacts(theEnv,WDISPLAY,theModule,start,end,max);
return;
}
/*========================================================*/
/* Since there are one or more arguments, see if a module */
/* or start index was specified as the first argument. */
/*========================================================*/
EnvRtnUnknown(theEnv,1,&theValue);
/*===============================================*/
/* If the first argument is a symbol, then check */
/* to see that a valid module was specified. */
/*===============================================*/
if (theValue.type == SYMBOL)
{
theModule = (struct defmodule *) EnvFindDefmodule(theEnv,ValueToString(theValue.value));
if ((theModule == NULL) && (strcmp(ValueToString(theValue.value),"*") != 0))
{
SetEvaluationError(theEnv,TRUE);
CantFindItemErrorMessage(theEnv,(char*)"defmodule",ValueToString(theValue.value));
return;
}
if ((start = GetFactsArgument(theEnv,2,argumentCount)) == INVALID) return;
argOffset = 1;
}
/*================================================*/
/* Otherwise if the first argument is an integer, */
/* check to see that a valid index was specified. */
/*================================================*/
else if (theValue.type == INTEGER)
{
start = DOToLong(theValue);
if (start < 0)
{
ExpectedTypeError1(theEnv,(char*)"facts",1,(char*)"symbol or positive number");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return;
}
argOffset = 0;
}
/*==========================================*/
/* Otherwise the first argument is invalid. */
/*==========================================*/
else
{
ExpectedTypeError1(theEnv,(char*)"facts",1,(char*)"symbol or positive number");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return;
}
/*==========================*/
/* Get the other arguments. */
/*==========================*/
if ((end = GetFactsArgument(theEnv,2 + argOffset,argumentCount)) == INVALID) return;
if ((max = GetFactsArgument(theEnv,3 + argOffset,argumentCount)) == INVALID) return;
/*=================*/
/* List the facts. */
/*=================*/
EnvFacts(theEnv,WDISPLAY,theModule,start,end,max);
}
globle void CheckTemplateFact(
struct fact *theFact)
{
struct field *sublist;
int i;
struct deftemplate *theDeftemplate;
struct templateSlot *slotPtr;
DATA_OBJECT theData;
char thePlace[20];
int rv;
if (! GetDynamicConstraintChecking()) return;
sublist = theFact->theProposition.theFields;
/*========================================================*/
/* If the deftemplate corresponding to the first field of */
/* of the fact cannot be found, then the fact cannot be */
/* checked against the deftemplate format. */
/*========================================================*/
theDeftemplate = theFact->whichDeftemplate;
if (theDeftemplate == NULL) return;
if (theDeftemplate->implied) return;
/*=============================================*/
/* Check each of the slots of the deftemplate. */
/*=============================================*/
i = 0;
for (slotPtr = theDeftemplate->slotList;
slotPtr != NULL;
slotPtr = slotPtr->next)
{
/*================================================*/
/* Store the slot value in the appropriate format */
/* for a call to the constraint checking routine. */
/*================================================*/
if (slotPtr->multislot == FALSE)
{
theData.type = sublist[i].type;
theData.value = sublist[i].value;
i++;
}
else
{
theData.type = MULTIFIELD;
theData.value = (void *) sublist[i].value;
theData.begin = 0;
theData.end = ((struct multifield *) sublist[i].value)->multifieldLength-1;
i++;
}
/*=============================================*/
/* Call the constraint checking routine to see */
/* if a constraint violation occurred. */
/*=============================================*/
rv = ConstraintCheckDataObject(&theData,slotPtr->constraints);
if (rv != NO_VIOLATION)
{
sprintf(thePlace,"fact f-%-5ld ",theFact->factIndex);
PrintErrorID("CSTRNCHK",1,TRUE);
PrintRouter(WERROR,"Slot value ");
PrintDataObject(WERROR,&theData);
PrintRouter(WERROR," ");
ConstraintViolationErrorMessage(NULL,thePlace,FALSE,0,slotPtr->slotName,
0,rv,slotPtr->constraints,TRUE);
SetHaltExecution(TRUE);
return;
}
}
return;
}
globle void Reset()
{
struct callFunctionItem *resetPtr;
/*=====================================*/
/* The reset command can't be executed */
/* while a reset is in progress. */
/*=====================================*/
if (ResetInProgress) return;
ResetInProgress = TRUE;
ResetReadyInProgress = TRUE;
/*================================================*/
/* If the reset is performed from the top level */
/* command prompt, reset the halt execution flag. */
/*================================================*/
if (CurrentEvaluationDepth == 0) SetHaltExecution(FALSE);
/*=======================================================*/
/* Call the before reset function to determine if the */
/* reset should continue. [Used by the some of the */
/* windowed interfaces to query the user whether a */
/* reset should proceed with activations on the agenda.] */
/*=======================================================*/
if ((BeforeResetFunction != NULL) ? ((*BeforeResetFunction)() == FALSE) :
FALSE)
{
ResetReadyInProgress = FALSE;
ResetInProgress = FALSE;
return;
}
ResetReadyInProgress = FALSE;
/*===========================*/
/* Call each reset function. */
/*===========================*/
for (resetPtr = ListOfResetFunctions;
(resetPtr != NULL) && (GetHaltExecution() == FALSE);
resetPtr = resetPtr->next)
{ (*resetPtr->func)(); }
/*============================================*/
/* Set the current module to the MAIN module. */
/*============================================*/
SetCurrentModule((void *) FindDefmodule("MAIN"));
/*===========================================*/
/* Perform periodic cleanup if the reset was */
/* issued from an embedded controller. */
/*===========================================*/
if ((CurrentEvaluationDepth == 0) && (! EvaluatingTopLevelCommand) &&
(CurrentExpression == NULL))
{ PeriodicCleanup(TRUE,FALSE); }
/*===================================*/
/* A reset is no longer in progress. */
/*===================================*/
ResetInProgress = FALSE;
}
bool BatchStar(
Environment *theEnv,
const char *fileName)
{
int inchar;
bool done = false;
FILE *theFile;
char *theString = NULL;
size_t position = 0;
size_t maxChars = 0;
#if (! RUN_TIME) && (! BLOAD_ONLY)
char *oldParsingFileName;
long oldLineCountValue;
#endif
/*======================*/
/* Open the batch file. */
/*======================*/
theFile = GenOpen(theEnv,fileName,"r");
if (theFile == NULL)
{
OpenErrorMessage(theEnv,"batch",fileName);
return false;
}
/*======================================*/
/* Setup for capturing errors/warnings. */
/*======================================*/
#if (! RUN_TIME) && (! BLOAD_ONLY)
oldParsingFileName = CopyString(theEnv,GetParsingFileName(theEnv));
SetParsingFileName(theEnv,fileName);
CreateErrorCaptureRouter(theEnv);
oldLineCountValue = SetLineCount(theEnv,1);
#endif
/*=====================================*/
/* If embedded, clear the error flags. */
/*=====================================*/
if (EvaluationData(theEnv)->CurrentExpression == NULL)
{ ResetErrorFlags(theEnv); }
/*=============================================*/
/* Evaluate commands from the file one by one. */
/*=============================================*/
while (! done)
{
inchar = getc(theFile);
if (inchar == EOF)
{
inchar = '\n';
done = true;
}
theString = ExpandStringWithChar(theEnv,inchar,theString,&position,
&maxChars,maxChars+80);
if (CompleteCommand(theString) != 0)
{
FlushPPBuffer(theEnv);
SetPPBufferStatus(theEnv,false);
RouteCommand(theEnv,theString,false);
FlushPPBuffer(theEnv);
SetHaltExecution(theEnv,false);
SetEvaluationError(theEnv,false);
FlushBindList(theEnv,NULL);
genfree(theEnv,theString,maxChars);
theString = NULL;
maxChars = 0;
position = 0;
#if (! RUN_TIME) && (! BLOAD_ONLY)
FlushParsingMessages(theEnv);
#endif
}
if ((inchar == '\r') || (inchar == '\n'))
{ IncrementLineCount(theEnv); }
}
if (theString != NULL)
{ genfree(theEnv,theString,maxChars); }
/*=======================*/
/* Close the batch file. */
/*=======================*/
GenClose(theEnv,theFile);
/*========================================*/
/* Cleanup for capturing errors/warnings. */
/*========================================*/
#if (! RUN_TIME) && (! BLOAD_ONLY)
FlushParsingMessages(theEnv);
DeleteErrorCaptureRouter(theEnv);
SetLineCount(theEnv,oldLineCountValue);
SetParsingFileName(theEnv,oldParsingFileName);
DeleteString(theEnv,oldParsingFileName);
#endif
return true;
}
globle long DivFunction(
void *theEnv)
{
long total = 1L;
EXPRESSION *theExpression;
DATA_OBJECT theArgument;
int pos = 1;
long theNumber;
/*===================================================*/
/* Get the first argument. This number which will be */
/* the starting product from which all subsequent */
/* arguments will divide. */
/*===================================================*/
theExpression = GetFirstArgument();
if (theExpression != NULL)
{
if (! GetNumericArgument(theEnv,theExpression,"div",&theArgument,FALSE,pos)) theExpression = NULL;
else theExpression = GetNextArgument(theExpression);
if (theArgument.type == INTEGER)
{ total = ValueToLong(theArgument.value); }
else
{ total = (long) ValueToDouble(theArgument.value); }
pos++;
}
/*=====================================================*/
/* 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 (theExpression != NULL)
{
if (! GetNumericArgument(theEnv,theExpression,"div",&theArgument,FALSE,pos)) theExpression = NULL;
else theExpression = GetNextArgument(theExpression);
if (theArgument.type == INTEGER) theNumber = ValueToLong(theArgument.value);
else if (theArgument.type == FLOAT) theNumber = (long) ValueToDouble(theArgument.value);
else theNumber = 1;
if (theNumber == 0L)
{
DivideByZeroErrorMessage(theEnv,"div");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(1L);
}
if (theArgument.type == INTEGER)
{ total /= ValueToLong(theArgument.value); }
else
{ total = total / (long) ValueToDouble(theArgument.value); }
pos++;
}
/*======================================================*/
/* The result of the div function is always an integer. */
/*======================================================*/
return(total);
}
globle void EnvReset(
void *theEnv)
{
struct callFunctionItem *resetPtr;
/*=====================================*/
/* The reset command can't be executed */
/* while a reset is in progress. */
/*=====================================*/
if (ConstructData(theEnv)->ResetInProgress) return;
ConstructData(theEnv)->ResetInProgress = TRUE;
ConstructData(theEnv)->ResetReadyInProgress = TRUE;
/*================================================*/
/* If the reset is performed from the top level */
/* command prompt, reset the halt execution flag. */
/*================================================*/
if (UtilityData(theEnv)->CurrentGarbageFrame->topLevel) SetHaltExecution(theEnv,FALSE);
/*=======================================================*/
/* Call the before reset function to determine if the */
/* reset should continue. [Used by the some of the */
/* windowed interfaces to query the user whether a */
/* reset should proceed with activations on the agenda.] */
/*=======================================================*/
if ((ConstructData(theEnv)->BeforeResetFunction != NULL) ?
((*ConstructData(theEnv)->BeforeResetFunction)(theEnv) == FALSE) :
FALSE)
{
ConstructData(theEnv)->ResetReadyInProgress = FALSE;
ConstructData(theEnv)->ResetInProgress = FALSE;
return;
}
ConstructData(theEnv)->ResetReadyInProgress = FALSE;
/*===========================*/
/* Call each reset function. */
/*===========================*/
for (resetPtr = ConstructData(theEnv)->ListOfResetFunctions;
(resetPtr != NULL) && (GetHaltExecution(theEnv) == FALSE);
resetPtr = resetPtr->next)
{
if (resetPtr->environmentAware)
{ (*resetPtr->func)(theEnv); }
else
{ (* (void (*)(void)) resetPtr->func)(); }
}
/*============================================*/
/* Set the current module to the MAIN module. */
/*============================================*/
EnvSetCurrentModule(theEnv,(void *) EnvFindDefmodule(theEnv,"MAIN"));
/*===========================================*/
/* Perform periodic cleanup if the reset was */
/* issued from an embedded controller. */
/*===========================================*/
if ((UtilityData(theEnv)->CurrentGarbageFrame->topLevel) && (! CommandLineData(theEnv)->EvaluatingTopLevelCommand) &&
(EvaluationData(theEnv)->CurrentExpression == NULL) && (UtilityData(theEnv)->GarbageCollectionLocks == 0))
{
CleanCurrentGarbageFrame(theEnv,NULL);
CallPeriodicTasks(theEnv);
}
/*===================================*/
/* A reset is no longer in progress. */
/*===================================*/
ConstructData(theEnv)->ResetInProgress = FALSE;
}
globle intBool GetNumericArgument(
void *theEnv,
struct expr *theArgument,
char *functionName,
DATA_OBJECT *result,
intBool convertToFloat,
int whichArgument)
{
unsigned short theType;
void *theValue;
/*==================================================================*/
/* Evaluate the expression (don't bother calling EvaluateExpression */
/* if the type is float or integer). */
/*==================================================================*/
switch(theArgument->type)
{
case FLOAT:
case INTEGER:
theType = theArgument->type;
theValue = theArgument->value;
break;
default:
EvaluateExpression(theEnv,theArgument,result);
theType = result->type;
theValue = result->value;
break;
}
/*==========================================*/
/* If the argument is not float or integer, */
/* print an error message and return FALSE. */
/*==========================================*/
if ((theType != FLOAT) && (theType != INTEGER))
{
ExpectedTypeError1(theEnv,functionName,whichArgument,"integer or float");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,0L);
return(FALSE);
}
/*==========================================================*/
/* If the argument is an integer and the "convert to float" */
/* flag is TRUE, then convert the integer to a float. */
/*==========================================================*/
if ((convertToFloat) && (theType == INTEGER))
{
theType = FLOAT;
theValue = (void *) EnvAddDouble(theEnv,(double) ValueToLong(theValue));
}
/*============================================================*/
/* The numeric argument was successfully retrieved. Store the */
/* argument in the user supplied DATA_OBJECT and return TRUE. */
/*============================================================*/
result->type = theType;
result->value = theValue;
return(TRUE);
}
