globle long int LengthFunction(
void *theEnv)
{
DATA_OBJECT item;
/*====================================================*/
/* The length$ function expects exactly one argument. */
/*====================================================*/
if (EnvArgCountCheck(theEnv,"length$",EXACTLY,1) == -1) return(-1L);
EnvRtnUnknown(theEnv,1,&item);
/*====================================================*/
/* If the argument is a string or symbol, then return */
/* the number of characters in the argument. */
/*====================================================*/
if ((GetType(item) == STRING) || (GetType(item) == SYMBOL))
{
return( (long) strlen(DOToString(item)));
}
/*====================================================*/
/* If the argument is a multifield value, then return */
/* the number of fields in the argument. */
/*====================================================*/
if (GetType(item) == MULTIFIELD)
{
return ( (long) GetDOLength(item));
}
/*=============================================*/
/* If the argument wasn't a string, symbol, or */
/* multifield value, then generate an error. */
/*=============================================*/
SetEvaluationError(theEnv,TRUE);
ExpectedTypeError2(theEnv,"length$",1);
return(-1L);
}
void *GetFactOrInstanceArgument(
void *theEnv,
int thePosition,
DATA_OBJECT *item,
char *functionName)
{
#if DEFTEMPLATE_CONSTRUCT || OBJECT_SYSTEM
void *ptr;
#endif
/*==============================*/
/* Retrieve the first argument. */
/*==============================*/
EnvRtnUnknown(theEnv,thePosition,item);
/*==================================================*/
/* Fact and instance addresses are valid arguments. */
/*==================================================*/
if ((GetpType(item) == FACT_ADDRESS) ||
(GetpType(item) == INSTANCE_ADDRESS))
{ return(GetpValue(item)); }
/*==================================================*/
/* An integer is a valid argument if it corresponds */
/* to the fact index of an existing fact. */
/*==================================================*/
#if DEFTEMPLATE_CONSTRUCT
else if (GetpType(item) == INTEGER)
{
if ((ptr = (void *) FindIndexedFact(theEnv,DOPToLong(item))) == NULL)
{
char tempBuffer[20];
sprintf(tempBuffer,"f-%ld",DOPToLong(item));
CantFindItemErrorMessage(theEnv,"fact",tempBuffer);
}
return(ptr);
}
#endif
/*================================================*/
/* Instance names and symbols are valid arguments */
/* if they correspond to an existing instance. */
/*================================================*/
#if OBJECT_SYSTEM
else if ((GetpType(item) == INSTANCE_NAME) || (GetpType(item) == SYMBOL))
{
if ((ptr = (void *) FindInstanceBySymbol(theEnv,(SYMBOL_HN *) GetpValue(item))) == NULL)
{
CantFindItemErrorMessage(theEnv,"instance",ValueToString(GetpValue(item)));
}
return(ptr);
}
#endif
/*========================================*/
/* Any other type is an invalid argument. */
/*========================================*/
ExpectedTypeError2(theEnv,functionName,thePosition);
return(NULL);
}
static struct expr *ModAndDupParse(
void *theEnv,
struct expr *top,
char *logicalName,
char *name)
{
int error = FALSE;
struct token theToken;
struct expr *nextOne, *tempSlot;
struct expr *newField, *firstField, *lastField;
int printError;
short done;
/*==================================================================*/
/* Parse the fact-address or index to the modify/duplicate command. */
/*==================================================================*/
SavePPBuffer(theEnv," ");
GetToken(theEnv,logicalName,&theToken);
if ((theToken.type == SF_VARIABLE) || (theToken.type == GBL_VARIABLE))
{ nextOne = GenConstant(theEnv,theToken.type,theToken.value); }
else if (theToken.type == INTEGER)
{
if (! TopLevelCommand(theEnv))
{
PrintErrorID(theEnv,"TMPLTFUN",1,TRUE);
EnvPrintRouter(theEnv,WERROR,"Fact-indexes can only be used by ");
EnvPrintRouter(theEnv,WERROR,name);
EnvPrintRouter(theEnv,WERROR," as a top level command.\n");
ReturnExpression(theEnv,top);
return(NULL);
}
nextOne = GenConstant(theEnv,INTEGER,theToken.value);
}
else
{
ExpectedTypeError2(theEnv,name,1);
ReturnExpression(theEnv,top);
return(NULL);
}
nextOne->nextArg = NULL;
nextOne->argList = NULL;
top->argList = nextOne;
nextOne = top->argList;
/*=======================================================*/
/* Parse the remaining modify/duplicate slot specifiers. */
/*=======================================================*/
GetToken(theEnv,logicalName,&theToken);
while (theToken.type != RPAREN)
{
PPBackup(theEnv);
SavePPBuffer(theEnv," ");
SavePPBuffer(theEnv,theToken.printForm);
/*=================================================*/
/* Slot definition begins with a left parenthesis. */
/*=================================================*/
if (theToken.type != LPAREN)
{
SyntaxErrorMessage(theEnv,"duplicate/modify function");
ReturnExpression(theEnv,top);
return(NULL);
}
/*=================================*/
/* The slot name must be a symbol. */
/*=================================*/
GetToken(theEnv,logicalName,&theToken);
if (theToken.type != SYMBOL)
{
SyntaxErrorMessage(theEnv,"duplicate/modify function");
ReturnExpression(theEnv,top);
return(NULL);
}
/*=================================*/
/* Check for duplicate slot names. */
/*=================================*/
for (tempSlot = top->argList->nextArg;
tempSlot != NULL;
tempSlot = tempSlot->nextArg)
{
if (tempSlot->value == theToken.value)
{
AlreadyParsedErrorMessage(theEnv,"slot ",ValueToString(theToken.value));
ReturnExpression(theEnv,top);
return(NULL);
}
}
/*=========================================*/
/* Add the slot name to the list of slots. */
/*=========================================*/
nextOne->nextArg = GenConstant(theEnv,SYMBOL,theToken.value);
nextOne = nextOne->nextArg;
/*====================================================*/
/* Get the values to be stored in the specified slot. */
/*====================================================*/
firstField = NULL;
lastField = NULL;
done = FALSE;
while (! done)
{
SavePPBuffer(theEnv," ");
newField = GetAssertArgument(theEnv,logicalName,&theToken,&error,
RPAREN,FALSE,&printError);
if (error)
{
if (printError) SyntaxErrorMessage(theEnv,"deftemplate pattern");
ReturnExpression(theEnv,top);
return(NULL);
}
if (newField == NULL)
{ done = TRUE; }
if (lastField == NULL)
{ firstField = newField; }
else
{ lastField->nextArg = newField; }
lastField = newField;
}
/*================================================*/
/* Slot definition ends with a right parenthesis. */
/*================================================*/
if (theToken.type != RPAREN)
{
SyntaxErrorMessage(theEnv,"duplicate/modify function");
ReturnExpression(theEnv,top);
ReturnExpression(theEnv,firstField);
return(NULL);
}
else
{
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,")");
}
nextOne->argList = firstField;
GetToken(theEnv,logicalName,&theToken);
}
/*================================================*/
/* Return the parsed modify/duplicate expression. */
/*================================================*/
return(top);
}
static void DuplicateModifyCommand(
void *theEnv,
int retractIt,
DATA_OBJECT_PTR returnValue)
{
long int factNum;
struct fact *oldFact, *newFact, *theFact;
struct expr *testPtr;
DATA_OBJECT computeResult;
struct deftemplate *templatePtr;
struct templateSlot *slotPtr;
int i, position, found;
/*===================================================*/
/* Set the default return value to the symbol FALSE. */
/*===================================================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,SymbolData(theEnv)->FalseSymbol);
/*==================================================*/
/* Evaluate the first argument which is used to get */
/* a pointer to the fact to be modified/duplicated. */
/*==================================================*/
testPtr = GetFirstArgument();
EvaluateExpression(theEnv,testPtr,&computeResult);
/*==============================================================*/
/* If an integer is supplied, then treat it as a fact-index and */
/* search the fact-list for the fact with that fact-index. */
/*==============================================================*/
if (computeResult.type == INTEGER)
{
factNum = ValueToLong(computeResult.value);
if (factNum < 0)
{
if (retractIt) ExpectedTypeError2(theEnv,"modify",1);
else ExpectedTypeError2(theEnv,"duplicate",1);
SetEvaluationError(theEnv,TRUE);
return;
}
oldFact = (struct fact *) EnvGetNextFact(theEnv,NULL);
while (oldFact != NULL)
{
if (oldFact->factIndex == factNum)
{ break; }
else
{ oldFact = oldFact->nextFact; }
}
if (oldFact == NULL)
{
char tempBuffer[20];
sprintf(tempBuffer,"f-%ld",factNum);
CantFindItemErrorMessage(theEnv,"fact",tempBuffer);
return;
}
}
/*==========================================*/
/* Otherwise, if a pointer is supplied then */
/* no lookup is required. */
/*==========================================*/
else if (computeResult.type == FACT_ADDRESS)
{ oldFact = (struct fact *) computeResult.value; }
/*===========================================*/
/* Otherwise, the first argument is invalid. */
/*===========================================*/
else
{
if (retractIt) ExpectedTypeError2(theEnv,"modify",1);
else ExpectedTypeError2(theEnv,"duplicate",1);
SetEvaluationError(theEnv,TRUE);
return;
}
/*==================================*/
/* See if it is a deftemplate fact. */
/*==================================*/
templatePtr = oldFact->whichDeftemplate;
if (templatePtr->implied) return;
/*================================================================*/
/* Duplicate the values from the old fact (skipping multifields). */
/*================================================================*/
newFact = (struct fact *) CreateFactBySize(theEnv,oldFact->theProposition.multifieldLength);
newFact->whichDeftemplate = templatePtr;
for (i = 0; i < (int) oldFact->theProposition.multifieldLength; i++)
{
newFact->theProposition.theFields[i].type = oldFact->theProposition.theFields[i].type;
if (newFact->theProposition.theFields[i].type != MULTIFIELD)
{ newFact->theProposition.theFields[i].value = oldFact->theProposition.theFields[i].value; }
else
{ newFact->theProposition.theFields[i].value = NULL; }
}
/*========================*/
/* Start replacing slots. */
/*========================*/
testPtr = testPtr->nextArg;
while (testPtr != NULL)
{
/*============================================================*/
/* If the slot identifier is an integer, then the slot was */
/* previously identified and its position within the template */
/* was stored. Otherwise, the position of the slot within the */
/* deftemplate has to be determined by comparing the name of */
/* the slot against the list of slots for the deftemplate. */
/*============================================================*/
if (testPtr->type == INTEGER)
{ position = (int) ValueToLong(testPtr->value); }
else
{
found = FALSE;
position = 0;
slotPtr = templatePtr->slotList;
while (slotPtr != NULL)
{
if (slotPtr->slotName == (SYMBOL_HN *) testPtr->value)
{
found = TRUE;
slotPtr = NULL;
}
else
{
slotPtr = slotPtr->next;
position++;
}
}
if (! found)
{
InvalidDeftemplateSlotMessage(theEnv,ValueToString(testPtr->value),
ValueToString(templatePtr->header.name));
SetEvaluationError(theEnv,TRUE);
ReturnFact(theEnv,newFact);
return;
}
}
/*===================================================*/
/* If a single field slot is being replaced, then... */
/*===================================================*/
if (newFact->theProposition.theFields[position].type != MULTIFIELD)
{
/*======================================================*/
/* If the list of values to store in the slot is empty */
/* or contains more than one member than an error has */
/* occured because a single field slot can only contain */
/* a single value. */
/*======================================================*/
if ((testPtr->argList == NULL) ? TRUE : (testPtr->argList->nextArg != NULL))
{
MultiIntoSingleFieldSlotError(theEnv,GetNthSlot(templatePtr,position),templatePtr);
ReturnFact(theEnv,newFact);
return;
}
/*===================================================*/
/* Evaluate the expression to be stored in the slot. */
/*===================================================*/
EvaluateExpression(theEnv,testPtr->argList,&computeResult);
SetEvaluationError(theEnv,FALSE);
/*====================================================*/
/* If the expression evaluated to a multifield value, */
/* then an error occured since a multifield value can */
/* not be stored in a single field slot. */
/*====================================================*/
if (computeResult.type == MULTIFIELD)
{
ReturnFact(theEnv,newFact);
MultiIntoSingleFieldSlotError(theEnv,GetNthSlot(templatePtr,position),templatePtr);
return;
}
/*=============================*/
/* Store the value in the slot */
/*=============================*/
newFact->theProposition.theFields[position].type =
computeResult.type;
newFact->theProposition.theFields[position].value =
computeResult.value;
}
/*=================================*/
/* Else replace a multifield slot. */
/*=================================*/
else
{
/*======================================*/
/* Determine the new value of the slot. */
/*======================================*/
StoreInMultifield(theEnv,&computeResult,testPtr->argList,FALSE);
SetEvaluationError(theEnv,FALSE);
/*=============================*/
/* Store the value in the slot */
/*=============================*/
newFact->theProposition.theFields[position].type =
computeResult.type;
newFact->theProposition.theFields[position].value =
computeResult.value;
}
testPtr = testPtr->nextArg;
}
/*=====================================*/
/* Copy the multifield values from the */
/* old fact that were not replaced. */
/*=====================================*/
for (i = 0; i < (int) oldFact->theProposition.multifieldLength; i++)
{
if ((newFact->theProposition.theFields[i].type == MULTIFIELD) &&
(newFact->theProposition.theFields[i].value == NULL))
{
newFact->theProposition.theFields[i].value =
CopyMultifield(theEnv,(struct multifield *) oldFact->theProposition.theFields[i].value);
}
}
/*======================================*/
/* Perform the duplicate/modify action. */
/*======================================*/
if (retractIt) EnvRetract(theEnv,oldFact);
theFact = (struct fact *) EnvAssert(theEnv,newFact);
/*========================================*/
/* The asserted fact is the return value. */
/*========================================*/
if (theFact != NULL)
{
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,theFact->theProposition.multifieldLength);
SetpType(returnValue,FACT_ADDRESS);
SetpValue(returnValue,(void *) theFact);
}
return;
}
/***********************************************************************
NAME : ExpandFuncMultifield
DESCRIPTION : Recursively examines an expression and replaces
PROC_EXPAND_MULTIFIELD expressions with the expanded
evaluation expression of its argument
INPUTS : 1) A data object result buffer
2) The expression to modify
3) The address of the expression, in case it is
deleted entirely
4) The address of the H/L function expand$
RETURNS : Nothing useful
SIDE EFFECTS : Expressions allocated/deallocated as necessary
Evaluations performed
On errors, argument expression set to call a function
which causes an evaluation error when evaluated
a second time by actual caller.
NOTES : THIS ROUTINE MODIFIES EXPRESSIONS AT RUNTIME!! MAKE
SURE THAT THE EXPRESSION PASSED IS SAFE TO CHANGE!!
**********************************************************************/
static void ExpandFuncMultifield(
void *theEnv,
DATA_OBJECT *result,
EXPRESSION *theExp,
EXPRESSION **sto,
void *expmult)
{
EXPRESSION *newexp,*top,*bot;
register long i; /* 6.04 Bug Fix */
while (theExp != NULL)
{
if (theExp->value == expmult)
{
EvaluateExpression(theEnv,theExp->argList,result);
ReturnExpression(theEnv,theExp->argList);
if ((EvaluationData(theEnv)->EvaluationError) || (result->type != MULTIFIELD))
{
theExp->argList = NULL;
if ((EvaluationData(theEnv)->EvaluationError == FALSE) && (result->type != MULTIFIELD))
ExpectedTypeError2(theEnv,"expand$",1);
theExp->value = (void *) FindFunction(theEnv,"(set-evaluation-error)");
EvaluationData(theEnv)->EvaluationError = FALSE;
EvaluationData(theEnv)->HaltExecution = FALSE;
return;
}
top = bot = NULL;
for (i = GetpDOBegin(result) ; i <= GetpDOEnd(result) ; i++)
{
newexp = get_struct(theEnv,expr);
newexp->type = GetMFType(result->value,i);
newexp->value = GetMFValue(result->value,i);
newexp->argList = NULL;
newexp->nextArg = NULL;
if (top == NULL)
top = newexp;
else
bot->nextArg = newexp;
bot = newexp;
}
if (top == NULL)
{
*sto = theExp->nextArg;
rtn_struct(theEnv,expr,theExp);
theExp = *sto;
}
else
{
bot->nextArg = theExp->nextArg;
*sto = top;
rtn_struct(theEnv,expr,theExp);
sto = &bot->nextArg;
theExp = bot->nextArg;
}
}
else
{
if (theExp->argList != NULL)
ExpandFuncMultifield(theEnv,result,theExp->argList,&theExp->argList,expmult);
sto = &theExp->nextArg;
theExp = theExp->nextArg;
}
}
}
globle void gensystem(
void *theEnv)
{
char *commandBuffer = NULL;
size_t bufferPosition = 0;
size_t bufferMaximum = 0;
int numa, i;
DATA_OBJECT tempValue;
const char *theString;
/*===========================================*/
/* Check for the corret number of arguments. */
/*===========================================*/
if ((numa = EnvArgCountCheck(theEnv,"system",AT_LEAST,1)) == -1) return;
/*============================================================*/
/* Concatenate the arguments together to form a single string */
/* containing the command to be sent to the operating system. */
/*============================================================*/
for (i = 1 ; i <= numa; i++)
{
EnvRtnUnknown(theEnv,i,&tempValue);
if ((GetType(tempValue) != STRING) &&
(GetType(tempValue) != SYMBOL))
{
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
ExpectedTypeError2(theEnv,"system",i);
return;
}
theString = DOToString(tempValue);
commandBuffer = AppendToString(theEnv,theString,commandBuffer,&bufferPosition,&bufferMaximum);
}
if (commandBuffer == NULL) return;
/*=======================================*/
/* Execute the operating system command. */
/*=======================================*/
#if VAX_VMS
if (SystemDependentData(theEnv)->PauseEnvFunction != NULL) (*SystemDependentData(theEnv)->PauseEnvFunction)(theEnv);
VMSSystem(commandBuffer);
putchar('\n');
if (SystemDependentData(theEnv)->ContinueEnvFunction != NULL) (*SystemDependentData(theEnv)->ContinueEnvFunction)(theEnv,1);
if (SystemDependentData(theEnv)->RedrawScreenFunction != NULL) (*SystemDependentData(theEnv)->RedrawScreenFunction)(theEnv);
#endif
#if UNIX_7 || UNIX_V || LINUX || DARWIN || WIN_MVC || WIN_GCC || MAC_XCD
if (SystemDependentData(theEnv)->PauseEnvFunction != NULL) (*SystemDependentData(theEnv)->PauseEnvFunction)(theEnv);
system(commandBuffer);
if (SystemDependentData(theEnv)->ContinueEnvFunction != NULL) (*SystemDependentData(theEnv)->ContinueEnvFunction)(theEnv,1);
if (SystemDependentData(theEnv)->RedrawScreenFunction != NULL) (*SystemDependentData(theEnv)->RedrawScreenFunction)(theEnv);
#else
#if ! VAX_VMS
EnvPrintRouter(theEnv,WDIALOG,
"System function not fully defined for this system.\n");
#endif
#endif
/*==================================================*/
/* Return the string buffer containing the command. */
/*==================================================*/
rm(theEnv,commandBuffer,bufferMaximum);
return;
}
void *GetFactOrInstanceArgument(
UDFContext *context,
unsigned int thePosition,
UDFValue *item)
{
Environment *theEnv = context->environment;
#if DEFTEMPLATE_CONSTRUCT || OBJECT_SYSTEM
void *ptr;
#endif
/*==============================*/
/* Retrieve the first argument. */
/*==============================*/
UDFNthArgument(context,thePosition,ANY_TYPE_BITS,item);
/*==================================================*/
/* Fact and instance addresses are valid arguments. */
/*==================================================*/
if (CVIsType(item,FACT_ADDRESS_BIT))
{
if (item->factValue->garbage)
{
FactRetractedErrorMessage(theEnv,item->factValue);
return NULL;
}
return item->value;
}
else if (CVIsType(item,INSTANCE_ADDRESS_BIT))
{
if (item->instanceValue->garbage)
{
CantFindItemErrorMessage(theEnv,"instance",item->instanceValue->name->contents,false);
return NULL;
}
return item->value;
}
/*==================================================*/
/* An integer is a valid argument if it corresponds */
/* to the fact index of an existing fact. */
/*==================================================*/
#if DEFTEMPLATE_CONSTRUCT
else if (item->header->type == INTEGER_TYPE)
{
if ((ptr = (void *) FindIndexedFact(theEnv,item->integerValue->contents)) == NULL)
{
char tempBuffer[20];
gensprintf(tempBuffer,"f-%lld",item->integerValue->contents);
CantFindItemErrorMessage(theEnv,"fact",tempBuffer,false);
}
return ptr;
}
#endif
/*================================================*/
/* Instance names and symbols are valid arguments */
/* if they correspond to an existing instance. */
/*================================================*/
#if OBJECT_SYSTEM
else if (CVIsType(item,INSTANCE_NAME_BIT | SYMBOL_BIT))
{
if ((ptr = (void *) FindInstanceBySymbol(theEnv,item->lexemeValue)) == NULL)
{
CantFindItemErrorMessage(theEnv,"instance",item->lexemeValue->contents,false);
}
return ptr;
}
#endif
/*========================================*/
/* Any other type is an invalid argument. */
/*========================================*/
ExpectedTypeError2(theEnv,UDFContextFunctionName(context),thePosition);
return NULL;
}