globle int Eval(
char *theString,
DATA_OBJECT_PTR returnValue)
{
struct expr *top;
int ov;
static int depth = 0;
char logicalNameBuffer[20];
struct BindInfo *oldBinds;
/*======================================================*/
/* Evaluate the string. Create a different logical name */
/* for use each time the eval function is called. */
/*======================================================*/
depth++;
sprintf(logicalNameBuffer,"Eval-%d",depth);
if (OpenStringSource(logicalNameBuffer,theString,0) == 0)
{
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,FalseSymbol);
depth--;
return(FALSE);
}
/*================================================*/
/* Save the current parsing state before routines */
/* are called to parse the eval string. */
/*================================================*/
ov = GetPPBufferStatus();
SetPPBufferStatus(FALSE);
oldBinds = GetParsedBindNames();
SetParsedBindNames(NULL);
/*========================================================*/
/* Parse the string argument passed to the eval function. */
/*========================================================*/
top = ParseAtomOrExpression(logicalNameBuffer,NULL);
/*============================*/
/* Restore the parsing state. */
/*============================*/
SetPPBufferStatus(ov);
ClearParsedBindNames();
SetParsedBindNames(oldBinds);
/*===========================================*/
/* Return if an error occured while parsing. */
/*===========================================*/
if (top == NULL)
{
SetEvaluationError(TRUE);
CloseStringSource(logicalNameBuffer);
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,FalseSymbol);
depth--;
return(FALSE);
}
/*==============================================*/
/* The sequence expansion operator must be used */
/* within the argument list of a function call. */
/*==============================================*/
if ((top->type == MF_GBL_VARIABLE) || (top->type == MF_VARIABLE))
{
PrintErrorID("MISCFUN",1,FALSE);
PrintRouter(WERROR,"expand$ must be used in the argument list of a function call.\n");
SetEvaluationError(TRUE);
CloseStringSource(logicalNameBuffer);
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,FalseSymbol);
ReturnExpression(top);
depth--;
return(FALSE);
}
/*=======================================*/
/* The expression to be evaluated cannot */
/* contain any local variables. */
/*=======================================*/
if (ExpressionContainsVariables(top,FALSE))
{
PrintErrorID("STRNGFUN",2,FALSE);
PrintRouter(WERROR,"Some variables could not be accessed by the eval function.\n");
SetEvaluationError(TRUE);
CloseStringSource(logicalNameBuffer);
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,FalseSymbol);
ReturnExpression(top);
depth--;
return(FALSE);
}
/*====================================*/
/* Evaluate the expression and return */
/* the memory used to parse it. */
/*====================================*/
ExpressionInstall(top);
EvaluateExpression(top,returnValue);
ExpressionDeinstall(top);
depth--;
ReturnExpression(top);
CloseStringSource(logicalNameBuffer);
if (GetEvaluationError()) return(FALSE);
return(TRUE);
}
globle void PrintAtom(
char *logicalName,
int type,
void *value)
{
char buffer[20];
switch (type)
{
case FLOAT:
PrintFloat(logicalName,ValueToDouble(value));
break;
case INTEGER:
PrintLongInteger(logicalName,ValueToLong(value));
break;
case SYMBOL:
PrintRouter(logicalName,ValueToString(value));
break;
case STRING:
if (PreserveEscapedCharacters)
{ PrintRouter(logicalName,StringPrintForm(ValueToString(value))); }
else
{
PrintRouter(logicalName,"\"");
PrintRouter(logicalName,ValueToString(value));
PrintRouter(logicalName,"\"");
}
break;
case EXTERNAL_ADDRESS:
if (AddressesToStrings) PrintRouter(logicalName,"\"");
PrintRouter(logicalName,"<Pointer-");
sprintf(buffer,"%p",value);
PrintRouter(logicalName,buffer);
PrintRouter(logicalName,">");
if (AddressesToStrings) PrintRouter(logicalName,"\"");
break;
#if OBJECT_SYSTEM
case INSTANCE_NAME:
PrintRouter(logicalName,"[");
PrintRouter(logicalName,ValueToString(value));
PrintRouter(logicalName,"]");
break;
#endif
#if FUZZY_DEFTEMPLATES
case FUZZY_VALUE:
PrintFuzzyValue(logicalName,ValueToFuzzyValue(value));
break;
#endif
case RVOID:
break;
default:
if (PrimitivesArray[type] == NULL) break;
if (PrimitivesArray[type]->longPrintFunction == NULL)
{
PrintRouter(logicalName,"<unknown atom type>");
break;
}
(*PrimitivesArray[type]->longPrintFunction)(logicalName,value);
break;
}
}
static int CheckForVariableMixing(
struct lhsParseNode *theRestriction)
{
struct lhsParseNode *tempRestriction;
CONSTRAINT_RECORD *theConstraint;
int multifield = FALSE;
int singlefield = FALSE;
int constant = FALSE;
int singleReturnValue = FALSE;
int multiReturnValue = FALSE;
/*================================================*/
/* If the constraint contains a binding variable, */
/* determine whether it is a single field or */
/* multifield variable. */
/*================================================*/
if (theRestriction->type == SF_VARIABLE) singlefield = TRUE;
else if (theRestriction->type == MF_VARIABLE) multifield = TRUE;
/*===========================================*/
/* Loop through each of the or (|) connected */
/* constraints within the constraint. */
/*===========================================*/
for (theRestriction = theRestriction->bottom;
theRestriction != NULL;
theRestriction = theRestriction->bottom)
{
/*============================================*/
/* Loop through each of the and (&) connected */
/* constraints within the or (|) constraint. */
/*============================================*/
for (tempRestriction = theRestriction;
tempRestriction != NULL;
tempRestriction = tempRestriction->right)
{
/*=====================================================*/
/* Determine if the constraint contains a single field */
/* variable, multifield variable, constant (a single */
/* field), a return value constraint of a function */
/* returning a single field value, or a return value */
/* constraint of a function returning a multifield */
/* value. */
/*=====================================================*/
if (tempRestriction->type == SF_VARIABLE) singlefield = TRUE;
else if (tempRestriction->type == MF_VARIABLE) multifield = TRUE;
else if (ConstantType(tempRestriction->type)) constant = TRUE;
else if (tempRestriction->type == RETURN_VALUE_CONSTRAINT)
{
theConstraint = FunctionCallToConstraintRecord(tempRestriction->expression->value);
if (theConstraint->anyAllowed) { /* Do nothing. */ }
else if (theConstraint->multifieldsAllowed) multiReturnValue = TRUE;
else singleReturnValue = TRUE;
RemoveConstraint(theConstraint);
}
}
}
/*================================================================*/
/* Using a single field value (a single field variable, constant, */
/* or function returning a single field value) together with a */
/* multifield value (a multifield variable or function returning */
/* a multifield value) is illegal. Return TRUE if this occurs. */
/*================================================================*/
if ((singlefield || constant || singleReturnValue) &&
(multifield || multiReturnValue))
{
PrintErrorID("PATTERN",2,TRUE);
PrintRouter(WERROR,"Single and multifield constraints cannot be mixed in a field constraint\n");
return(TRUE);
}
/*=======================================*/
/* Otherwise return FALSE to indicate no */
/* illegal variable mixing was detected. */
/*=======================================*/
return(FALSE);
}
globle int CheckSyntax(
char *theString,
DATA_OBJECT_PTR returnValue)
{
char *name;
struct token theToken;
struct expr *top;
short rv;
/*==============================*/
/* Set the default return value */
/* (TRUE for problems found). */
/*==============================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,TrueSymbol);
/*===========================================*/
/* Create a string source router so that the */
/* string can be used as an input source. */
/*===========================================*/
if (OpenStringSource("check-syntax",theString,0) == 0)
{ return(TRUE); }
/*=================================*/
/* Only expressions and constructs */
/* can have their syntax checked. */
/*=================================*/
GetToken("check-syntax",&theToken);
if (theToken.type != LPAREN)
{
CloseStringSource("check-syntax");
SetpValue(returnValue,AddSymbol("MISSING-LEFT-PARENTHESIS"));
return(TRUE);
}
/*========================================*/
/* The next token should be the construct */
/* type or function name. */
/*========================================*/
GetToken("check-syntax",&theToken);
if (theToken.type != SYMBOL)
{
CloseStringSource("check-syntax");
SetpValue(returnValue,AddSymbol("EXPECTED-SYMBOL-AFTER-LEFT-PARENTHESIS"));
return(TRUE);
}
name = ValueToString(theToken.value);
/*==============================================*/
/* Set up a router to capture the error output. */
/*==============================================*/
AddRouter("error-capture",40,
FindErrorCapture, PrintErrorCapture,
NULL, NULL, NULL);
/*================================*/
/* Determine if it's a construct. */
/*================================*/
if (FindConstruct(name))
{
CheckSyntaxMode = TRUE;
rv = (short) ParseConstruct(name,"check-syntax");
GetToken("check-syntax",&theToken);
CheckSyntaxMode = FALSE;
if (rv)
{
PrintRouter(WERROR,"\nERROR:\n");
PrintInChunks(WERROR,GetPPBuffer());
PrintRouter(WERROR,"\n");
}
DestroyPPBuffer();
CloseStringSource("check-syntax");
if ((rv != FALSE) || (WarningString != NULL))
{
SetErrorCaptureValues(returnValue);
DeactivateErrorCapture();
return(TRUE);
}
if (theToken.type != STOP)
{
SetpValue(returnValue,AddSymbol("EXTRANEOUS-INPUT-AFTER-LAST-PARENTHESIS"));
DeactivateErrorCapture();
return(TRUE);
}
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,FalseSymbol);
DeactivateErrorCapture();
return(FALSE);
}
/*=======================*/
/* Parse the expression. */
/*=======================*/
top = Function2Parse("check-syntax",name);
GetToken("check-syntax",&theToken);
ClearParsedBindNames();
CloseStringSource("check-syntax");
if (top == NULL)
{
SetErrorCaptureValues(returnValue);
DeactivateErrorCapture();
return(TRUE);
}
if (theToken.type != STOP)
{
SetpValue(returnValue,AddSymbol("EXTRANEOUS-INPUT-AFTER-LAST-PARENTHESIS"));
DeactivateErrorCapture();
ReturnExpression(top);
return(TRUE);
}
DeactivateErrorCapture();
ReturnExpression(top);
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,FalseSymbol);
return(FALSE);
}
/*******************************************************************************
Name: IntSave
Description: Eexecutes CLIPS' bsave, save-facts, or save functions
Arguments: w - Dialog Widget
client_data - Not Used
call_data - Not Used
Returns: None
*******************************************************************************/
void IntSave(
Widget w,
XtPointer client_data,
XtPointer call_data)
{
char *filename = XawDialogGetValueString(XtParent(w));
switch(file_item)
{
case SAVEBINARY:
PrintRouter("wclips", "(bsave ");
SetCommandString("(bsave");
AppendCommandString("\"");
PrintRouter("wclips", "\"");
AppendCommandString(filename);
PrintRouter("wclips", filename);
AppendCommandString("\"");
PrintRouter("wclips", "\"");
AppendCommandString(")\n");
PrintRouter("wclips", ")\n");
quit_get_event = True;
break;
case SAVEFACTS:
PrintRouter("wclips", "(save-facts ");
SetCommandString("(save-facts");
AppendCommandString("\"");
PrintRouter("wclips", "\"");
AppendCommandString(filename);
PrintRouter("wclips", filename);
AppendCommandString("\"");
PrintRouter("wclips", "\"");
AppendCommandString(")\n");
PrintRouter("wclips", ")\n");
quit_get_event = True;
break;
case SAVERULES:
PrintRouter("wclips", "(save ");
SetCommandString("(save");
AppendCommandString("\"");
PrintRouter("wclips", "\"");
AppendCommandString(filename);
PrintRouter("wclips", filename);
AppendCommandString("\"");
PrintRouter("wclips", "\"");
AppendCommandString(")\n");
PrintRouter("wclips", ")\n");
quit_get_event = True;
break;
}
XtDestroyWidget(XtParent(XtParent(w)));
}
globle void ConstraintReferenceErrorMessage(
struct symbolHashNode *theVariable,
struct lhsParseNode *theExpression,
int whichArgument,
int whichCE,
struct symbolHashNode *slotName,
int theField)
{
struct expr *temprv;
PrintErrorID("RULECSTR",2,TRUE);
/*==========================*/
/* Print the variable name. */
/*==========================*/
PrintRouter(WERROR,"Previous variable bindings of ?");
PrintRouter(WERROR,ValueToString(theVariable));
PrintRouter(WERROR," caused the type restrictions");
/*============================*/
/* Print the argument number. */
/*============================*/
PrintRouter(WERROR,"\nfor argument #");
PrintLongInteger(WERROR,(long int) whichArgument);
/*=======================*/
/* Print the expression. */
/*=======================*/
PrintRouter(WERROR," of the expression ");
temprv = LHSParseNodesToExpression(theExpression);
ReturnExpression(temprv->nextArg);
temprv->nextArg = NULL;
PrintExpression(WERROR,temprv);
PrintRouter(WERROR,"\n");
ReturnExpression(temprv);
/*========================================*/
/* Print out the index of the conditional */
/* element and the slot name or field */
/* index where the violation occured. */
/*========================================*/
PrintRouter(WERROR,"found in CE #");
PrintLongInteger(WERROR,(long int) whichCE);
if (slotName == NULL)
{
if (theField > 0)
{
PrintRouter(WERROR," field #");
PrintLongInteger(WERROR,(long int) theField);
}
}
else
{
PrintRouter(WERROR," slot ");
PrintRouter(WERROR,ValueToString(slotName));
}
PrintRouter(WERROR," to be violated.\n");
}
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 ConstructsToCCommand()
{
char *fileName;
DATA_OBJECT theArg;
int argCount;
int id, max;
#if VAX_VMS || IBM_MSC || IBM_TBC || IBM_ICB || IBM_ZTC || IBM_SC
int i;
#endif
/*============================================*/
/* Check for appropriate number of arguments. */
/*============================================*/
if ((argCount = ArgRangeCheck("constructs-to-c",2,3)) == -1) return;
/*====================================================*/
/* Get the name of the file in which to place C code. */
/*====================================================*/
if (ArgTypeCheck("constructs-to-c",1,SYMBOL_OR_STRING,&theArg) == FALSE)
{ return; }
fileName = DOToString(theArg);
/*================================*/
/* File names for the VAX and IBM */
/* PCs can't contain a period. */
/*================================*/
#if VAX_VMS || IBM_MSC || IBM_TBC || IBM_ICB || IBM_ZTC || IBM_SC
for (i = 0 ; *(fileName+i) ; i++)
{
if (*(fileName+i) == '.')
{
PrintErrorID("CONSCOMP",1,FALSE);
PrintRouter(WERROR,"Invalid file name ");
PrintRouter(WERROR,fileName);
PrintRouter(WERROR," contains \'.\'\n");
return;
}
}
#endif
/*===========================================*/
/* If the base file name is greater than 3 */
/* characters, issue a warning that the file */
/* name lengths may exceed what is allowed */
/* under some operating systems. */
/*===========================================*/
if (((int) strlen(fileName)) > 3)
{
PrintWarningID("CONSCOMP",1,FALSE);
PrintRouter(WWARNING,"Base file name exceeds 3 characters.\n");
PrintRouter(WWARNING," This may cause files to be overwritten if file name length\n");
PrintRouter(WWARNING," is limited on your platform.\n");
}
/*====================================*/
/* Get the runtime image ID argument. */
/*====================================*/
if (ArgTypeCheck("constructs-to-c",2,INTEGER,&theArg) == FALSE)
{ return; }
id = DOToInteger(theArg);
if (id < 0)
{
ExpectedTypeError1("constructs-to-c",2,"positive integer");
return;
}
/*===========================================*/
/* Get the maximum number of data structures */
/* to store per file argument (if supplied). */
/*===========================================*/
if (argCount == 3)
{
if (ArgTypeCheck("constructs-to-c",3,INTEGER,&theArg) == FALSE)
{ return; }
max = DOToInteger(theArg);
if (max < 0)
{
ExpectedTypeError1("constructs-to-c",3,"positive integer");
return;
}
}
else
{ max = 10000; }
/*============================*/
/* Call the driver routine to */
/* generate the C code. */
/*============================*/
ConstructsToC(fileName,id,max);
}
static struct expr *GetSlotAssertValues(
struct templateSlot *slotPtr,
struct expr *firstSlot,
int *error)
{
struct expr *slotItem;
struct expr *newArg, *tempArg;
DATA_OBJECT theDefault;
char *nullBitMap = "\0";
/*==================================================*/
/* Determine if the slot is assigned in the assert. */
/*==================================================*/
slotItem = FindAssertSlotItem(slotPtr,firstSlot);
/*==========================================*/
/* If the slot is assigned, use that value. */
/*==========================================*/
if (slotItem != NULL)
{
newArg = slotItem->argList;
slotItem->argList = NULL;
}
/*=================================*/
/* Otherwise, use a default value. */
/*=================================*/
else
{
/*================================================*/
/* If the (default ?NONE) attribute was specified */
/* for the slot, then a value must be supplied. */
/*================================================*/
if (slotPtr->noDefault)
{
PrintErrorID("TMPLTRHS",1,TRUE);
PrintRouter(WERROR,"Slot ");
PrintRouter(WERROR,slotPtr->slotName->contents);
PrintRouter(WERROR," requires a value because of its (default ?NONE) attribute.\n");
*error = TRUE;
return(NULL);
}
/*===================================================*/
/* If the (default ?DERIVE) attribute was specified */
/* (the default), then derive the default value from */
/* the slot's constraints. */
/*===================================================*/
else if ((slotPtr->defaultPresent == FALSE) &&
(slotPtr->defaultDynamic == FALSE))
{
DeriveDefaultFromConstraints(slotPtr->constraints,&theDefault,
(int) slotPtr->multislot);
newArg = ConvertValueToExpression(&theDefault);
}
/*=========================================*/
/* Otherwise, use the expression contained */
/* in the default attribute. */
/*=========================================*/
else
{ newArg = CopyExpression(slotPtr->defaultList); }
}
/*=======================================================*/
/* Since a multifield slot default can contain a list of */
/* values, the values need to have a store-multifield */
/* function called wrapped around it to group all of the */
/* values into a single multifield value. */
/*=======================================================*/
if (slotPtr->multislot)
{
tempArg = GenConstant(FACT_STORE_MULTIFIELD,AddBitMap((void *) nullBitMap,1));
tempArg->argList = newArg;
newArg = tempArg;
}
/*==============================================*/
/* Return the value to be asserted in the slot. */
/*==============================================*/
return(newArg);
}
/*******************************************************
NAME : DefmessageHandlerWatchSupport
DESCRIPTION : Sets or displays handlers specified
INPUTS : 1) The calling function name
2) The logical output name for displays
(can be NULL)
4) The new set state (can be -1)
5) The print function (can be NULL)
6) The trace function (can be NULL)
7) The handlers expression list
RETURNS : TRUE if all OK,
FALSE otherwise
SIDE EFFECTS : Handler trace flags set or displayed
NOTES : None
*******************************************************/
static BOOLEAN DefmessageHandlerWatchSupport(
char *funcName,
char *log,
int newState,
void (*printFunc)(char *,void *,unsigned),
void (*traceFunc)(int,void *,unsigned),
EXPRESSION *argExprs)
{
struct defmodule *theModule;
void *theClass;
char *theHandlerStr;
int theType;
int argIndex = 2;
DATA_OBJECT tmpData;
/* ===============================
If no handlers are specified,
show the trace for all handlers
in all handlers
=============================== */
if (argExprs == NULL)
{
SaveCurrentModule();
theModule = (struct defmodule *) GetNextDefmodule(NULL);
while (theModule != NULL)
{
SetCurrentModule((void *) theModule);
if (traceFunc == NULL)
{
PrintRouter(log,GetDefmoduleName((void *) theModule));
PrintRouter(log,":\n");
}
theClass = GetNextDefclass(NULL);
while (theClass != NULL)
{
if (WatchClassHandlers(theClass,NULL,-1,log,newState,
TRUE,printFunc,traceFunc) == FALSE)
return(FALSE);
theClass = GetNextDefclass(theClass);
}
theModule = (struct defmodule *) GetNextDefmodule((void *) theModule);
}
RestoreCurrentModule();
return(TRUE);
}
/* ================================================
Set or show the traces for the specified handler
================================================ */
while (argExprs != NULL)
{
if (EvaluateExpression(argExprs,&tmpData))
return(FALSE);
if (tmpData.type != SYMBOL)
{
ExpectedTypeError1(funcName,argIndex,"class name");
return(FALSE);
}
theClass = (void *) LookupDefclassByMdlOrScope(DOToString(tmpData));
if (theClass == NULL)
{
ExpectedTypeError1(funcName,argIndex,"class name");
return(FALSE);
}
if (GetNextArgument(argExprs) != NULL)
{
argExprs = GetNextArgument(argExprs);
argIndex++;
if (EvaluateExpression(argExprs,&tmpData))
return(FALSE);
if (tmpData.type != SYMBOL)
{
ExpectedTypeError1(funcName,argIndex,"handler name");
return(FALSE);
}
theHandlerStr = DOToString(tmpData);
if (GetNextArgument(argExprs) != NULL)
{
argExprs = GetNextArgument(argExprs);
argIndex++;
if (EvaluateExpression(argExprs,&tmpData))
return(FALSE);
if (tmpData.type != SYMBOL)
{
ExpectedTypeError1(funcName,argIndex,"handler type");
return(FALSE);
}
if ((theType = HandlerType(funcName,DOToString(tmpData))) == MERROR)
return(FALSE);
}
else
theType = -1;
}
else
{
theHandlerStr = NULL;
theType = -1;
}
if (WatchClassHandlers(theClass,theHandlerStr,theType,log,
newState,FALSE,printFunc,traceFunc) == FALSE)
{
ExpectedTypeError1(funcName,argIndex,"handler");
return(FALSE);
}
argIndex++;
argExprs = GetNextArgument(argExprs);
}
return(TRUE);
}
globle FILE *OpenFileIfNeeded(
FILE *theFile,
char *fileName,
int fileID,
int imageID,
int *fileCount,
int arrayVersion,
FILE *headerFP,
char *structureName,
char *structPrefix,
int reopenOldFile,
struct CodeGeneratorFile *codeFile)
{
char arrayName[80];
char *newName;
int newID, newVersion;
/*===========================================*/
/* If a file is being reopened, use the same */
/* version number, name, and ID as before. */
/*===========================================*/
if (reopenOldFile)
{
if (codeFile == NULL)
{
SystemError("CONSCOMP",5);
ExitRouter(EXIT_FAILURE);
}
newName = codeFile->filePrefix;
newID = codeFile->id;
newVersion = codeFile->version;
}
/*=====================================================*/
/* Otherwise, use the specified version number, name, */
/* and ID. If the appropriate argument is supplied, */
/* remember these values for later reopening the file. */
/*=====================================================*/
else
{
newName = fileName;
newVersion = *fileCount;
newID = fileID;
if (codeFile != NULL)
{
codeFile->version = newVersion;
codeFile->filePrefix = newName;
codeFile->id = newID;
}
}
/*=========================================*/
/* If the file is already open, return it. */
/*=========================================*/
if (theFile != NULL)
{
fprintf(theFile,",\n");
return(theFile);
}
/*================*/
/* Open the file. */
/*================*/
if ((theFile = NewCFile(newName,newID,newVersion,reopenOldFile)) == NULL)
{ return(NULL); }
/*=========================================*/
/* If this is the first time the file has */
/* been opened, write out the beginning of */
/* the array variable definition. */
/*=========================================*/
if (reopenOldFile == FALSE)
{
(*fileCount)++;
sprintf(arrayName,"%s%d_%d",structPrefix,imageID,arrayVersion);
#if SHORT_LINK_NAMES
if (strlen(arrayName) > 6)
{
PrintWarningID("CONSCOMP",2,FALSE);
PrintRouter(WWARNING,"Array name ");
PrintRouter(WWARNING,arrayName);
PrintRouter(WWARNING,"exceeds 6 characters in length.\n");
PrintRouter(WWARNING," This variable may be indistinguishable from another by the linker.\n");
}
#endif
fprintf(theFile,"%s %s[] = {\n",structureName,arrayName);
fprintf(headerFP,"extern %s %s[];\n",structureName,arrayName);
}
else
{ fprintf(theFile,",\n"); }
/*==================*/
/* Return the file. */
/*==================*/
return(theFile);
}
/************************************************************
NAME : ValidDeffunctionName
DESCRIPTION : Determines if a new deffunction of the given
name can be defined in the current module
INPUTS : The new deffunction name
RETURNS : TRUE if OK, FALSE otherwise
SIDE EFFECTS : Error message printed if not OK
NOTES : GetConstructNameAndComment() (called before
this function) ensures that the deffunction
name does not conflict with one from
another module
************************************************************/
static BOOLEAN ValidDeffunctionName(
char *theDeffunctionName)
{
struct constructHeader *theDeffunction;
#if DEFGENERIC_CONSTRUCT
struct defmodule *theModule;
struct constructHeader *theDefgeneric;
#endif
/* ============================================
A deffunction cannot be named the same as a
construct type, e.g, defclass, defrule, etc.
============================================ */
if (FindConstruct(theDeffunctionName) != NULL)
{
PrintErrorID("DFFNXPSR",1,FALSE);
PrintRouter(WERROR,"Deffunctions are not allowed to replace constructs.\n");
return(FALSE);
}
/* ============================================
A deffunction cannot be named the same as a
pre-defined system function, e.g, watch,
list-defrules, etc.
============================================ */
if (FindFunction(theDeffunctionName) != NULL)
{
PrintErrorID("DFFNXPSR",2,FALSE);
PrintRouter(WERROR,"Deffunctions are not allowed to replace external functions.\n");
return(FALSE);
}
#if DEFGENERIC_CONSTRUCT
/* ============================================
A deffunction cannot be named the same as a
generic function (either in this module or
imported from another)
============================================ */
theDefgeneric =
(struct constructHeader *) LookupDefgenericInScope(theDeffunctionName);
if (theDefgeneric != NULL)
{
theModule = GetConstructModuleItem(theDefgeneric)->theModule;
if (theModule != ((struct defmodule *) GetCurrentModule()))
{
PrintErrorID("DFFNXPSR",5,FALSE);
PrintRouter(WERROR,"Defgeneric ");
PrintRouter(WERROR,GetDefgenericName((void *) theDefgeneric));
PrintRouter(WERROR," imported from module ");
PrintRouter(WERROR,GetDefmoduleName((void *) theModule));
PrintRouter(WERROR," conflicts with this deffunction.\n");
return(FALSE);
}
else
{
PrintErrorID("DFFNXPSR",3,FALSE);
PrintRouter(WERROR,"Deffunctions are not allowed to replace generic functions.\n");
}
return(FALSE);
}
#endif
theDeffunction = (struct constructHeader *) FindDeffunction(theDeffunctionName);
if (theDeffunction != NULL)
{
/* ===========================================
And a deffunction in the current module can
only be redefined if it is not executing.
=========================================== */
if (((DEFFUNCTION *) theDeffunction)->executing)
{
PrintErrorID("DFNXPSR",4,FALSE);
PrintRouter(WERROR,"Deffunction ");
PrintRouter(WERROR,GetDeffunctionName((void *) theDeffunction));
PrintRouter(WERROR," may not be redefined while it is executing.\n");
return(FALSE);
}
}
return(TRUE);
}
globle int BuildFunction()
{
PrintErrorID("STRNGFUN",1,FALSE);
PrintRouter(WERROR,"Function build does not work in run time modules.\n");
return(FALSE);
}
globle int Build(
char *theString)
{
char *constructType;
struct token theToken;
int errorFlag;
/*====================================================*/
/* No additions during defrule join network activity. */
/*====================================================*/
#if DEFRULE_CONSTRUCT
if (JoinOperationInProgress) return(FALSE);
#endif
/*===========================================*/
/* Create a string source router so that the */
/* string can be used as an input source. */
/*===========================================*/
if (OpenStringSource("build",theString,0) == 0)
{ return(FALSE); }
/*================================*/
/* The first token of a construct */
/* must be a left parenthesis. */
/*================================*/
GetToken("build",&theToken);
if (theToken.type != LPAREN)
{
CloseStringSource("build");
return(FALSE);
}
/*==============================================*/
/* The next token should be the construct type. */
/*==============================================*/
GetToken("build",&theToken);
if (theToken.type != SYMBOL)
{
CloseStringSource("build");
return(FALSE);
}
constructType = ValueToString(theToken.value);
/*======================*/
/* Parse the construct. */
/*======================*/
errorFlag = ParseConstruct(constructType,"build");
/*=================================*/
/* Close the string source router. */
/*=================================*/
CloseStringSource("build");
/*=========================================*/
/* If an error occured while parsing the */
/* construct, then print an error message. */
/*=========================================*/
if (errorFlag == 1)
{
PrintRouter(WERROR,"\nERROR:\n");
PrintInChunks(WERROR,GetPPBuffer());
PrintRouter(WERROR,"\n");
}
DestroyPPBuffer();
/*===============================================*/
/* Return TRUE if the construct was successfully */
/* parsed, otherwise return FALSE. */
/*===============================================*/
if (errorFlag == 0) return(TRUE);
return(FALSE);
}
static struct expr *SwitchParse(
struct expr *top,
char *infile)
{
struct token theToken;
EXPRESSION *exp,*chk;
int case_count = 0,default_count = 0;
/*============================*/
/* Process the switch value */
/*============================*/
IncrementIndentDepth(3);
SavePPBuffer(" ");
top->argList = exp = ParseAtomOrExpression(infile,NULL);
if (exp == NULL)
goto SwitchParseError;
/*========================*/
/* Parse case statements. */
/*========================*/
GetToken(infile,&theToken);
while (theToken.type != RPAREN)
{
PPBackup();
PPCRAndIndent();
SavePPBuffer(theToken.printForm);
if (theToken.type != LPAREN)
goto SwitchParseErrorAndMessage;
GetToken(infile,&theToken);
SavePPBuffer(" ");
if ((theToken.type == SYMBOL) &&
(strcmp(ValueToString(theToken.value),"case") == 0))
{
if (default_count != 0)
goto SwitchParseErrorAndMessage;
exp->nextArg = ParseAtomOrExpression(infile,NULL);
SavePPBuffer(" ");
if (exp->nextArg == NULL)
goto SwitchParseError;
for (chk = top->argList->nextArg ; chk != exp->nextArg ; chk = chk->nextArg)
{
if ((chk->type == exp->nextArg->type) &&
(chk->value == exp->nextArg->value) &&
IdenticalExpression(chk->argList,exp->nextArg->argList))
{
PrintErrorID("PRCDRPSR",3,TRUE);
PrintRouter(WERROR,"Duplicate case found in switch function.\n");
goto SwitchParseError;
}
}
GetToken(infile,&theToken);
if ((theToken.type != SYMBOL) ? TRUE :
(strcmp(ValueToString(theToken.value),"then") != 0))
goto SwitchParseErrorAndMessage;
case_count++;
}
else if ((theToken.type == SYMBOL) &&
(strcmp(ValueToString(theToken.value),"default") == 0))
{
if ((case_count < 2) || default_count)
goto SwitchParseErrorAndMessage;
exp->nextArg = GenConstant(RVOID,NULL);
default_count = 1;
}
else
goto SwitchParseErrorAndMessage;
exp = exp->nextArg;
if (svContexts->rtn == TRUE)
ReturnContext = TRUE;
if (svContexts->brk == TRUE)
BreakContext = TRUE;
IncrementIndentDepth(3);
PPCRAndIndent();
exp->nextArg = GroupActions(infile,&theToken,TRUE,NULL,FALSE);
DecrementIndentDepth(3);
ReturnContext = FALSE;
BreakContext = FALSE;
if (exp->nextArg == NULL)
goto SwitchParseError;
exp = exp->nextArg;
PPBackup();
PPBackup();
SavePPBuffer(theToken.printForm);
GetToken(infile,&theToken);
}
if (case_count >= 2)
{
DecrementIndentDepth(3);
return(top);
}
SwitchParseErrorAndMessage:
SyntaxErrorMessage("switch function");
SwitchParseError:
ReturnExpression(top);
DecrementIndentDepth(3);
return(NULL);
}
/********************************************************
NAME : CallNextHandler
DESCRIPTION : This function allows around-handlers
to execute the rest of the core frame.
It also allows primary handlers
to execute shadowed primaries.
The original handler arguments are
left intact.
INPUTS : The caller's result-value buffer
RETURNS : Nothing useful
SIDE EFFECTS : The core frame is called and any
appropriate changes are made when
used in an around handler
See CallHandlers()
But when call-next-handler is called
from a primary, the same shadowed
primary is called over and over
again for repeated calls to
call-next-handler.
NOTES : H/L Syntax: (call-next-handler) OR
(override-next-handler <arg> ...)
********************************************************/
globle void CallNextHandler(
DATA_OBJECT *result)
{
EXPRESSION args;
int overridep;
HANDLER_LINK *oldNext,*oldCurrent;
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
SetpType(result,SYMBOL);
SetpValue(result,FalseSymbol);
EvaluationError = FALSE;
if (HaltExecution)
return;
if (NextHandlerAvailable() == FALSE)
{
PrintErrorID("MSGPASS",1,FALSE);
PrintRouter(WERROR,"Shadowed message-handlers not applicable in current context.\n");
SetEvaluationError(TRUE);
return;
}
if (CurrentExpression->value == (void *) FindFunction("override-next-handler"))
{
overridep = 1;
args.type = (short) ProcParamArray[0].type;
if (args.type != MULTIFIELD)
args.value = (void *) ProcParamArray[0].value;
else
args.value = (void *) &ProcParamArray[0];
args.nextArg = GetFirstArgument();
args.argList = NULL;
PushProcParameters(&args,CountArguments(&args),
ValueToString(CurrentMessageName),"message",
UnboundHandlerErr);
if (EvaluationError)
{
ReturnFlag = FALSE;
return;
}
}
else
overridep = 0;
oldNext = NextInCore;
oldCurrent = CurrentCore;
if (CurrentCore->hnd->type == MAROUND)
{
if (NextInCore->hnd->type == MAROUND)
{
CurrentCore = NextInCore;
NextInCore = NextInCore->nxt;
#if DEBUGGING_FUNCTIONS
if (CurrentCore->hnd->trace)
WatchHandler(WTRACE,CurrentCore,BEGIN_TRACE);
#endif
if (CheckHandlerArgCount())
{
#if PROFILING_FUNCTIONS
StartProfile(&profileFrame,
&CurrentCore->hnd->usrData,
ProfileConstructs);
#endif
EvaluateProcActions(CurrentCore->hnd->cls->header.whichModule->theModule,
CurrentCore->hnd->actions,
CurrentCore->hnd->localVarCount,
result,UnboundHandlerErr);
#if PROFILING_FUNCTIONS
EndProfile(&profileFrame);
#endif
}
#if DEBUGGING_FUNCTIONS
if (CurrentCore->hnd->trace)
WatchHandler(WTRACE,CurrentCore,END_TRACE);
#endif
}
else
CallHandlers(result);
}
else
{
CurrentCore = NextInCore;
NextInCore = NextInCore->nxt;
#if DEBUGGING_FUNCTIONS
if (CurrentCore->hnd->trace)
WatchHandler(WTRACE,CurrentCore,BEGIN_TRACE);
#endif
if (CheckHandlerArgCount())
{
#if PROFILING_FUNCTIONS
StartProfile(&profileFrame,
&CurrentCore->hnd->usrData,
ProfileConstructs);
#endif
EvaluateProcActions(CurrentCore->hnd->cls->header.whichModule->theModule,
CurrentCore->hnd->actions,
CurrentCore->hnd->localVarCount,
result,UnboundHandlerErr);
#if PROFILING_FUNCTIONS
EndProfile(&profileFrame);
#endif
}
#if DEBUGGING_FUNCTIONS
if (CurrentCore->hnd->trace)
WatchHandler(WTRACE,CurrentCore,END_TRACE);
#endif
}
NextInCore = oldNext;
CurrentCore = oldCurrent;
if (overridep)
PopProcParameters();
ReturnFlag = FALSE;
}
globle void Clear()
{
struct callFunctionItem *theFunction;
/*==========================================*/
/* Activate the watch router which captures */
/* trace output so that it is not displayed */
/* during a clear. */
/*==========================================*/
#if DEBUGGING_FUNCTIONS
ActivateRouter(WTRACE);
#endif
/*===================================*/
/* Determine if a clear is possible. */
/*===================================*/
ClearReadyInProgress = TRUE;
if (ClearReady() == FALSE)
{
PrintErrorID("CONSTRCT",1,FALSE);
PrintRouter(WERROR,"Some constructs are still in use. Clear cannot continue.\n");
#if DEBUGGING_FUNCTIONS
DeactivateRouter(WTRACE);
#endif
ClearReadyInProgress = FALSE;
return;
}
ClearReadyInProgress = FALSE;
/*===========================*/
/* Call all clear functions. */
/*===========================*/
ClearInProgress = TRUE;
for (theFunction = ListOfClearFunctions;
theFunction != NULL;
theFunction = theFunction->next)
{ (*theFunction->func)(); }
/*=============================*/
/* Deactivate the watch router */
/* for capturing output. */
/*=============================*/
#if DEBUGGING_FUNCTIONS
DeactivateRouter(WTRACE);
#endif
/*===========================================*/
/* Perform periodic cleanup if the clear was */
/* issued from an embedded controller. */
/*===========================================*/
if ((CurrentEvaluationDepth == 0) && (! EvaluatingTopLevelCommand) &&
(CurrentExpression == NULL))
{ PeriodicCleanup(TRUE,FALSE); }
/*===========================*/
/* Clear has been completed. */
/*===========================*/
ClearInProgress = FALSE;
}
/*****************************************************
NAME : PerformMessage
DESCRIPTION : Calls core framework for a message
INPUTS : 1) Caller's result buffer
2) Message argument expressions
(including implicit object)
3) Message name
RETURNS : Nothing useful
SIDE EFFECTS : Any side-effects of message execution
and caller's result buffer set
NOTES : None
*****************************************************/
static void PerformMessage(
DATA_OBJECT *result,
EXPRESSION *args,
SYMBOL_HN *mname)
{
int oldce;
HANDLER_LINK *oldCore;
DEFCLASS *cls = NULL;
INSTANCE_TYPE *ins = NULL;
SYMBOL_HN *oldName;
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
result->type = SYMBOL;
result->value = FalseSymbol;
EvaluationError = FALSE;
if (HaltExecution)
return;
oldce = ExecutingConstruct();
SetExecutingConstruct(TRUE);
oldName = CurrentMessageName;
CurrentMessageName = mname;
CurrentEvaluationDepth++;
PushProcParameters(args,CountArguments(args),
ValueToString(CurrentMessageName),"message",
UnboundHandlerErr);
if (EvaluationError)
{
CurrentEvaluationDepth--;
CurrentMessageName = oldName;
PeriodicCleanup(FALSE,TRUE);
SetExecutingConstruct(oldce);
return;
}
if (ProcParamArray->type == INSTANCE_ADDRESS)
{
ins = (INSTANCE_TYPE *) ProcParamArray->value;
if (ins->garbage == 1)
{
StaleInstanceAddress("send",0);
SetEvaluationError(TRUE);
}
else if (DefclassInScope(ins->cls,(struct defmodule *) GetCurrentModule()) == FALSE)
NoInstanceError(ValueToString(ins->name),"send");
else
{
cls = ins->cls;
ins->busy++;
}
}
else if (ProcParamArray->type == INSTANCE_NAME)
{
ins = FindInstanceBySymbol((SYMBOL_HN *) ProcParamArray->value);
if (ins == NULL)
{
PrintErrorID("MSGPASS",2,FALSE);
PrintRouter(WERROR,"No such instance ");
PrintRouter(WERROR,ValueToString((SYMBOL_HN *) ProcParamArray->value));
PrintRouter(WERROR," in function send.\n");
SetEvaluationError(TRUE);
}
else
{
ProcParamArray->value = (void *) ins;
ProcParamArray->type = INSTANCE_ADDRESS;
cls = ins->cls;
ins->busy++;
}
}
else if ((cls = PrimitiveClassMap[ProcParamArray->type]) == NULL)
{
SystemError("MSGPASS",1);
ExitRouter(EXIT_FAILURE);
}
if (EvaluationError)
{
PopProcParameters();
CurrentEvaluationDepth--;
CurrentMessageName = oldName;
PeriodicCleanup(FALSE,TRUE);
SetExecutingConstruct(oldce);
return;
}
oldCore = TopOfCore;
TopOfCore = FindApplicableHandlers(cls,mname);
if (TopOfCore != NULL)
{
HANDLER_LINK *oldCurrent,*oldNext;
oldCurrent = CurrentCore;
oldNext = NextInCore;
#if IMPERATIVE_MESSAGE_HANDLERS
if (TopOfCore->hnd->type == MAROUND)
{
CurrentCore = TopOfCore;
NextInCore = TopOfCore->nxt;
#if DEBUGGING_FUNCTIONS
if (WatchMessages)
WatchMessage(WTRACE,BEGIN_TRACE);
if (CurrentCore->hnd->trace)
WatchHandler(WTRACE,CurrentCore,BEGIN_TRACE);
#endif
if (CheckHandlerArgCount())
{
#if PROFILING_FUNCTIONS
StartProfile(&profileFrame,
&CurrentCore->hnd->usrData,
ProfileConstructs);
#endif
EvaluateProcActions(CurrentCore->hnd->cls->header.whichModule->theModule,
CurrentCore->hnd->actions,
CurrentCore->hnd->localVarCount,
result,UnboundHandlerErr);
#if PROFILING_FUNCTIONS
EndProfile(&profileFrame);
#endif
}
#if DEBUGGING_FUNCTIONS
if (CurrentCore->hnd->trace)
WatchHandler(WTRACE,CurrentCore,END_TRACE);
if (WatchMessages)
WatchMessage(WTRACE,END_TRACE);
#endif
}
else
#endif /* IMPERATIVE_MESSAGE_HANDLERS */
{
CurrentCore = NULL;
NextInCore = TopOfCore;
#if DEBUGGING_FUNCTIONS
if (WatchMessages)
WatchMessage(WTRACE,BEGIN_TRACE);
#endif
CallHandlers(result);
#if DEBUGGING_FUNCTIONS
if (WatchMessages)
WatchMessage(WTRACE,END_TRACE);
#endif
}
DestroyHandlerLinks(TopOfCore);
CurrentCore = oldCurrent;
NextInCore = oldNext;
}
TopOfCore = oldCore;
ReturnFlag = FALSE;
if (ins != NULL)
ins->busy--;
/* ==================================
Restore the original calling frame
================================== */
PopProcParameters();
CurrentEvaluationDepth--;
CurrentMessageName = oldName;
PropagateReturnValue(result);
PeriodicCleanup(FALSE,TRUE);
SetExecutingConstruct(oldce);
if (EvaluationError)
{
result->type = SYMBOL;
result->value = FalseSymbol;
}
}
static BOOLEAN CheckArgumentForConstraintError(
struct expr *expressionList,
struct expr *lastOne,
int i,
struct FunctionDefinition *theFunction,
struct lhsParseNode *theLHS)
{
int theRestriction;
CONSTRAINT_RECORD *constraint1, *constraint2, *constraint3, *constraint4;
struct lhsParseNode *theVariable;
struct expr *tmpPtr;
int rv = FALSE;
/*=============================================================*/
/* Skip anything that isn't a variable or isn't an argument to */
/* a user defined function (i.e. deffunctions and generic have */
/* no constraint information so they aren't checked). */
/*=============================================================*/
if ((expressionList->type != SF_VARIABLE) || (theFunction == NULL))
{ return (rv); }
/*===========================================*/
/* Get the restrictions for the argument and */
/* convert them to a constraint record. */
/*===========================================*/
theRestriction = GetNthRestriction(theFunction,i);
constraint1 = ArgumentTypeToConstraintRecord(theRestriction);
/*================================================*/
/* Look for the constraint record associated with */
/* binding the variable in the LHS of the rule. */
/*================================================*/
theVariable = FindVariable((SYMBOL_HN *) expressionList->value,theLHS);
if (theVariable != NULL)
{
if (theVariable->type == MF_VARIABLE)
{
constraint2 = GetConstraintRecord();
SetConstraintType(MULTIFIELD,constraint2);
}
else if (theVariable->constraints == NULL)
{ constraint2 = GetConstraintRecord(); }
else
{ constraint2 = CopyConstraintRecord(theVariable->constraints); }
}
else
{ constraint2 = NULL; }
/*================================================*/
/* Look for the constraint record associated with */
/* binding the variable on the RHS of the rule. */
/*================================================*/
constraint3 = FindBindConstraints((SYMBOL_HN *) expressionList->value);
/*====================================================*/
/* Union the LHS and RHS variable binding constraints */
/* (the variable must satisfy one or the other). */
/*====================================================*/
constraint3 = UnionConstraints(constraint3,constraint2);
/*====================================================*/
/* Intersect the LHS/RHS variable binding constraints */
/* with the function argument restriction constraints */
/* (the variable must satisfy both). */
/*====================================================*/
constraint4 = IntersectConstraints(constraint3,constraint1);
/*====================================*/
/* Check for unmatchable constraints. */
/*====================================*/
if (UnmatchableConstraint(constraint4) && GetStaticConstraintChecking())
{
PrintErrorID("RULECSTR",3,TRUE);
PrintRouter(WERROR,"Previous variable bindings of ?");
PrintRouter(WERROR,ValueToString((SYMBOL_HN *) expressionList->value));
PrintRouter(WERROR," caused the type restrictions");
PrintRouter(WERROR,"\nfor argument #");
PrintLongInteger(WERROR,(long int) i);
PrintRouter(WERROR," of the expression ");
tmpPtr = lastOne->nextArg;
lastOne->nextArg = NULL;
PrintExpression(WERROR,lastOne);
lastOne->nextArg = tmpPtr;
PrintRouter(WERROR,"\nfound in the rule's RHS to be violated.\n");
rv = TRUE;
}
/*===========================================*/
/* Free the temporarily created constraints. */
/*===========================================*/
RemoveConstraint(constraint1);
RemoveConstraint(constraint2);
RemoveConstraint(constraint3);
RemoveConstraint(constraint4);
/*========================================*/
/* Return TRUE if unmatchable constraints */
/* were detected, otherwise FALSE. */
/*========================================*/
return(rv);
}
globle BOOLEAN Retract(
void *vTheFact)
{
struct fact *theFact = (struct fact *) vTheFact;
/*===========================================*/
/* A fact can not be retracted while another */
/* fact is being asserted or retracted. */
/*===========================================*/
if (JoinOperationInProgress)
{
PrintErrorID("FACTMNGR",1,TRUE);
PrintRouter(WERROR,"Facts may not be retracted during pattern-matching\n");
return(FALSE);
}
/*====================================*/
/* A NULL fact pointer indicates that */
/* all facts should be retracted. */
/*====================================*/
if (theFact == NULL)
{
RemoveAllFacts();
return(TRUE);
}
/*======================================================*/
/* Check to see if the fact has already been retracted. */
/*======================================================*/
if (theFact->garbage) return(FALSE);
/*============================*/
/* Print retraction output if */
/* facts are being watched. */
/*============================*/
#if DEBUGGING_FUNCTIONS
if (theFact->whichDeftemplate->watch)
{
PrintRouter(WTRACE,"<== ");
PrintFactWithIdentifier(WTRACE,theFact);
PrintRouter(WTRACE,"\n");
}
#endif
/*==================================*/
/* Set the change flag to indicate */
/* the fact-list has been modified. */
/*==================================*/
ChangeToFactList = TRUE;
/*===============================================*/
/* Remove any links between the fact and partial */
/* matches in the join network. These links are */
/* used to keep track of logical dependencies. */
/*===============================================*/
#if LOGICAL_DEPENDENCIES
RemoveEntityDependencies((struct patternEntity *) theFact);
#endif
/*===========================================*/
/* Remove the fact from the fact hash table. */
/*===========================================*/
RemoveHashedFact(theFact);
/*=====================================*/
/* Remove the fact from the fact list. */
/*=====================================*/
if (theFact == LastFact)
{ LastFact = theFact->previousFact; }
if (theFact->previousFact == NULL)
{
FactList = FactList->nextFact;
if (FactList != NULL)
{ FactList->previousFact = NULL; }
}
else
{
theFact->previousFact->nextFact = theFact->nextFact;
if (theFact->nextFact != NULL)
{ theFact->nextFact->previousFact = theFact->previousFact; }
}
/*==================================*/
/* Update busy counts and ephemeral */
/* garbage information. */
/*==================================*/
FactDeinstall(theFact);
EphemeralItemCount++;
EphemeralItemSize += sizeof(struct fact) + (sizeof(struct field) * theFact->theProposition.multifieldLength);
/*========================================*/
/* Add the fact to the fact garbage list. */
/*========================================*/
theFact->nextFact = GarbageFacts;
GarbageFacts = theFact;
theFact->garbage = TRUE;
/*===================================================*/
/* Reset the evaluation error flag since expressions */
/* will be evaluated as part of the retract. */
/*===================================================*/
SetEvaluationError(FALSE);
/*===========================================*/
/* Loop through the list of all the patterns */
/* that matched the fact and process the */
/* retract operation for each one. */
/*===========================================*/
JoinOperationInProgress = TRUE;
NetworkRetract((struct patternMatch *) theFact->list);
JoinOperationInProgress = FALSE;
/*=========================================*/
/* Free partial matches that were released */
/* by the retraction of the fact. */
/*=========================================*/
if (ExecutingRule == NULL)
{ FlushGarbagePartialMatches(); }
/*=========================================*/
/* Retract other facts that were logically */
/* dependent on the fact just retracted. */
/*=========================================*/
#if LOGICAL_DEPENDENCIES
ForceLogicalRetractions();
#endif
/*===========================================*/
/* Force periodic cleanup if the retract was */
/* executed from an embedded application. */
/*===========================================*/
if ((CurrentEvaluationDepth == 0) && (! EvaluatingTopLevelCommand) &&
(CurrentExpression == NULL))
{ PeriodicCleanup(TRUE,FALSE); }
/*==================================*/
/* Return TRUE to indicate the fact */
/* was successfully retracted. */
/*==================================*/
return(TRUE);
}
globle void PrintTemplateFact(
char *logicalName,
struct fact *theFact)
{
struct field *sublist;
int i;
struct deftemplate *theDeftemplate;
struct templateSlot *slotPtr;
/*==============================*/
/* Initialize some information. */
/*==============================*/
theDeftemplate = theFact->whichDeftemplate;
sublist = theFact->theProposition.theFields;
/*=============================================*/
/* Print the relation name of the deftemplate. */
/*=============================================*/
PrintRouter(logicalName,"(");
PrintRouter(logicalName,theDeftemplate->header.name->contents);
#if FUZZY_DEFTEMPLATES
if (theDeftemplate->fuzzyTemplate != NULL) /* fuzzy template */
{
PrintFuzzyTemplateFact(logicalName,
(struct fuzzy_value *)ValueToFuzzyValue((sublist[0].value))
#if CERTAINTY_FACTORS
,theFact->factCF
#endif
);
return;
}
#endif
if (theDeftemplate->slotList != NULL) PrintRouter(logicalName," ");
/*===================================================*/
/* Print each of the field slots of the deftemplate. */
/*===================================================*/
slotPtr = theDeftemplate->slotList;
i = 0;
while (slotPtr != NULL)
{
/*===========================================*/
/* Print the closing parenthesis of the slot */
/* and the slot name. */
/*===========================================*/
PrintRouter(logicalName,"(");
PrintRouter(logicalName,slotPtr->slotName->contents);
/*======================================================*/
/* Print the value of the slot for a single field slot. */
/*======================================================*/
if (slotPtr->multislot == FALSE)
{
PrintRouter(logicalName," ");
#if FUZZY_DEFTEMPLATES
/* for a fuzzy value printed during a fact save
we need to look for the 'xxx' linguistic value --
if it is xxx then print the set as singletons
*/
if (saveFactsInProgress &&
sublist[i].type == FUZZY_VALUE
)
{ struct fuzzy_value *fv;
fv = ValueToFuzzyValue(sublist[i].value);
if (strcmp("???", fv->name) == 0)
PrintFuzzySet(logicalName, fv);
else
PrintRouter(logicalName, fv->name);
}
else
#endif
PrintAtom(logicalName,sublist[i].type,sublist[i].value);
}
/*==========================================================*/
/* Else print the value of the slot for a multi field slot. */
/*==========================================================*/
else
{
struct multifield *theSegment;
theSegment = (struct multifield *) sublist[i].value;
if (theSegment->multifieldLength > 0)
{
PrintRouter(logicalName," ");
PrintMultifield(logicalName,(struct multifield *) sublist[i].value,
0,theSegment->multifieldLength-1,FALSE);
}
}
/*============================================*/
/* Print the closing parenthesis of the slot. */
/*============================================*/
i++;
PrintRouter(logicalName,")");
slotPtr = slotPtr->next;
if (slotPtr != NULL) PrintRouter(logicalName," ");
}
PrintRouter(logicalName,")");
#if CERTAINTY_FACTORS
printCF(logicalName,theFact->factCF);
#endif
#if FUZZY_DEFTEMPLATES
/* There may be some fuzzy value slots in the fact -- if so just
print out the fuzzy sets for them on next lines
... UNLESS we are doing a fact save operation!
*/
if (!saveFactsInProgress)
for (i=0; i<(unsigned int)theDeftemplate->numberOfSlots; i++)
{
if (sublist[i].type == FUZZY_VALUE)
{
PrintRouter(logicalName,"\n\t( ");
PrintFuzzySet(logicalName, ValueToFuzzyValue(sublist[i].value));
PrintRouter(logicalName," )");
}
}
#endif
}
globle void *Assert(
void *vTheFact)
{
int hashValue;
int length, i;
struct field *theField;
struct fact *theFact = (struct fact *) vTheFact;
/*==========================================*/
/* A fact can not be asserted while another */
/* fact is being asserted or retracted. */
/*==========================================*/
if (JoinOperationInProgress)
{
ReturnFact(theFact);
PrintErrorID("FACTMNGR",2,TRUE);
PrintRouter(WERROR,"Facts may not be asserted during pattern-matching\n");
return(NULL);
}
/*=============================================================*/
/* Replace invalid data types in the fact with the symbol nil. */
/*=============================================================*/
length = theFact->theProposition.multifieldLength;
theField = theFact->theProposition.theFields;
for (i = 0; i < length; i++)
{
if (theField[i].type == RVOID)
{
theField[i].type = SYMBOL;
theField[i].value = (void *) AddSymbol("nil");
}
}
/*========================================================*/
/* If fact assertions are being checked for duplications, */
/* then search the fact list for a duplicate fact. */
/*========================================================*/
hashValue = HandleFactDuplication(theFact);
if (hashValue < 0) return(NULL);
/*==========================================================*/
/* If necessary, add logical dependency links between the */
/* fact and the partial match which is its logical support. */
/*==========================================================*/
#if LOGICAL_DEPENDENCIES
if (AddLogicalDependencies((struct patternEntity *) theFact,FALSE) == FALSE)
{
ReturnFact(theFact);
return(NULL);
}
#endif
/*======================================*/
/* Add the fact to the fact hash table. */
/*======================================*/
AddHashedFact(theFact,hashValue);
/*================================*/
/* Add the fact to the fact list. */
/*================================*/
theFact->nextFact = NULL;
theFact->list = NULL;
theFact->previousFact = LastFact;
if (LastFact == NULL)
{ FactList = theFact; }
else
{ LastFact->nextFact = theFact; }
LastFact = theFact;
/*==================================*/
/* Set the fact index and time tag. */
/*==================================*/
theFact->factIndex = NextFactIndex++;
theFact->factHeader.timeTag = CurrentEntityTimeTag++;
/*=====================*/
/* Update busy counts. */
/*=====================*/
FactInstall(theFact);
/*==========================*/
/* Print assert output if */
/* facts are being watched. */
/*==========================*/
#if DEBUGGING_FUNCTIONS
if (theFact->whichDeftemplate->watch)
{
PrintRouter(WTRACE,"==> ");
PrintFactWithIdentifier(WTRACE,theFact);
PrintRouter(WTRACE,"\n");
}
#endif
/*==================================*/
/* Set the change flag to indicate */
/* the fact-list has been modified. */
/*==================================*/
ChangeToFactList = TRUE;
/*==========================================*/
/* Check for constraint errors in the fact. */
/*==========================================*/
CheckTemplateFact(theFact);
/*===================================================*/
/* Reset the evaluation error flag since expressions */
/* will be evaluated as part of the assert . */
/*===================================================*/
SetEvaluationError(FALSE);
/*=============================================*/
/* Pattern match the fact using the associated */
/* deftemplate's pattern network. */
/*=============================================*/
JoinOperationInProgress = TRUE;
FactPatternMatch(theFact,theFact->whichDeftemplate->patternNetwork,0,NULL,NULL);
JoinOperationInProgress = FALSE;
/*===================================================*/
/* Retract other facts that were logically dependent */
/* on the non-existence of the fact just asserted. */
/*===================================================*/
#if LOGICAL_DEPENDENCIES
ForceLogicalRetractions();
#endif
/*=========================================*/
/* Free partial matches that were released */
/* by the assertion of the fact. */
/*=========================================*/
if (ExecutingRule == NULL) FlushGarbagePartialMatches();
/*==========================================*/
/* Force periodic cleanup if the assert was */
/* executed from an embedded application. */
/*==========================================*/
if ((CurrentEvaluationDepth == 0) && (! EvaluatingTopLevelCommand) &&
(CurrentExpression == NULL))
{ PeriodicCleanup(TRUE,FALSE); }
/*===============================*/
/* Return a pointer to the fact. */
/*===============================*/
return((void *) theFact);
}
/*******************************************************************************
Name: CompletionDialogCallback
Description: Called when Completion is selected form File menu
Arguments: w - menu item that was selected
client_data - dialog window or edit window
call_data - not used
Returns: None
*******************************************************************************/
void CompletionDialogCallback(
Widget w,
XtPointer client_data,
XtPointer call_data)
{
int NumberOfMatches,i,length;
Boolean tempFlag;
struct symbolMatch *matches;
XKeyboardControl value;
char *commandString;
/* ================================================== */
/* Free the memory of completionString before assign */
/* it to the new string. */
/* ================================================== */
if(completionString != NULL)
{
free(completionString);
completionString = NULL;
}
/* =========================================================== */
/* Get the the uncompleted command string; if there is none */
/* sound the bell and exit, else determine if the last token */
/* of the string can be complete */
/* =========================================================== */
commandString = GetCommandString();
if(commandString != NULL)
{
length = strlen(commandString);
commandString = GetCommandCompletionString(commandString,length);
}
if(commandString == NULL)
{
XBell(XtDisplay(toplevel),100);
return;
}
/* ============================================================ */
/* Copy the command string to a global variable for later use. */
/* Global completionString has to be used here due to the */
/* limitation of the number of arguments could be passed in the */
/* call back function of in X window system. */
/* ============================================================ */
completionString = (char*)malloc(strlen(commandString) + 1);
strcpy(completionString,commandString);
/* ============================================================ */
/* Find the match(es). If there is none, sound the bell and */
/* exit; else if there is one match complete the command; else */
/* if there are more than one display them */
/* ============================================================ */
matches = FindSymbolMatches(completionString,&NumberOfMatches,NULL);
if(NumberOfMatches == 0)
{
XBell(XtDisplay(toplevel),100);
return;
}
else if (NumberOfMatches == 1)
{
length = strlen(completionString);
AppendCommandString(&(matches->match->contents[length]));
PrintRouter("stdin",&(matches->match->contents[length]));
}
else
{
DisplayMatchedList(dialog_text,matches);
}
}
globle int EvaluateExpression(
struct expr *problem,
DATA_OBJECT_PTR returnValue)
{
struct expr *oldArgument;
struct FunctionDefinition *fptr;
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
if (problem == NULL)
{
returnValue->type = SYMBOL;
returnValue->value = FalseSymbol;
return(EvaluationError);
}
switch (problem->type)
{
case STRING:
case SYMBOL:
case FLOAT:
case INTEGER:
#if OBJECT_SYSTEM
case INSTANCE_NAME:
case INSTANCE_ADDRESS:
#endif
#if FUZZY_DEFTEMPLATES
case FUZZY_VALUE:
#endif
case EXTERNAL_ADDRESS:
returnValue->type = problem->type;
returnValue->value = problem->value;
break;
#if FUZZY_DEFTEMPLATES
case S_FUNCTION:
case PI_FUNCTION:
case Z_FUNCTION:
case SINGLETON_EXPRESSION:
/* At some time it may be worthwhile making this into an FCALL
but only when we allow user's to create functions that return
fuzzy values -- this may not happen
*/
{
struct fuzzy_value *fvptr;
fvptr = getConstantFuzzyValue(problem, &EvaluationError);
returnValue->type = FUZZY_VALUE;
if (fvptr != NULL)
{
returnValue->value = (VOID *)AddFuzzyValue(fvptr);
/* AddFuzzyValue makes a copy of the fuzzy value -- so remove this one */
rtnFuzzyValue(fvptr);
}
else
{
returnValue->type = RVOID;
returnValue->value = CLIPSFalseSymbol;
SetEvaluationError(TRUE);
}
}
break;
#endif
case FCALL:
{
fptr = (struct FunctionDefinition *) problem->value;
#if PROFILING_FUNCTIONS
StartProfile(&profileFrame,
&fptr->usrData,
ProfileUserFunctions);
#endif
oldArgument = CurrentExpression;
CurrentExpression = problem;
switch(fptr->returnValueType)
{
case 'v' :
(* (void (*)(void)) fptr->functionPointer)();
returnValue->type = RVOID;
returnValue->value = FalseSymbol;
break;
case 'b' :
returnValue->type = SYMBOL;
if ((* (int (*)(void)) fptr->functionPointer)())
returnValue->value = TrueSymbol;
else
returnValue->value = FalseSymbol;
break;
case 'a' :
returnValue->type = EXTERNAL_ADDRESS;
returnValue->value =
(* (void *(*)(void)) fptr->functionPointer)();
break;
case 'i' :
returnValue->type = INTEGER;
returnValue->value = (void *)
AddLong((long) (* (int (*)(void)) fptr->functionPointer)());
break;
case 'l' :
returnValue->type = INTEGER;
returnValue->value = (void *)
AddLong((* (long int (*)(void)) fptr->functionPointer)());
break;
#if FUZZY_DEFTEMPLATES
case 'F' :
{
struct fuzzy_value *fvPtr;
fvPtr = (* (struct fuzzy_value * (*)(VOID_ARG)) fptr->functionPointer)();
if (fvPtr != NULL)
{
returnValue->type = FUZZY_VALUE;
returnValue->value = (VOID *)AddFuzzyValue( fvPtr );
/* AddFuzzyValue makes a copy of fv .. so return it */
rtnFuzzyValue( fvPtr );
}
else
{
returnValue->type = RVOID;
returnValue->value = CLIPSFalseSymbol;
}
}
break;
#endif
case 'f' :
returnValue->type = FLOAT;
returnValue->value = (void *)
AddDouble((double) (* (float (*)(void)) fptr->functionPointer)());
break;
case 'd' :
returnValue->type = FLOAT;
returnValue->value = (void *)
AddDouble((* (double (*)(void)) fptr->functionPointer)());
break;
case 's' :
returnValue->type = STRING;
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
break;
case 'w' :
returnValue->type = SYMBOL;
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
break;
#if OBJECT_SYSTEM
case 'x' :
returnValue->type = INSTANCE_ADDRESS;
returnValue->value =
(* (void *(*)(void)) fptr->functionPointer)();
break;
case 'o' :
returnValue->type = INSTANCE_NAME;
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
break;
#endif
case 'c' :
{
char cbuff[2];
cbuff[0] = (* (char (*)(void)) fptr->functionPointer)();
cbuff[1] = EOS;
returnValue->type = SYMBOL;
returnValue->value = (void *) AddSymbol(cbuff);
break;
}
case 'j' :
case 'k' :
case 'm' :
case 'n' :
case 'u' :
(* (void (*)(DATA_OBJECT_PTR)) fptr->functionPointer)(returnValue);
break;
default :
SystemError("EVALUATN",2);
ExitRouter(EXIT_FAILURE);
break;
}
#if PROFILING_FUNCTIONS
EndProfile(&profileFrame);
#endif
CurrentExpression = oldArgument;
break;
}
case MULTIFIELD:
returnValue->type = MULTIFIELD;
returnValue->value = ((DATA_OBJECT_PTR) (problem->value))->value;
returnValue->begin = ((DATA_OBJECT_PTR) (problem->value))->begin;
returnValue->end = ((DATA_OBJECT_PTR) (problem->value))->end;
break;
case MF_VARIABLE:
case SF_VARIABLE:
if (GetBoundVariable(returnValue,(SYMBOL_HN *) problem->value) == FALSE)
{
PrintErrorID("EVALUATN",1,FALSE);
PrintRouter(WERROR,"Variable ");
PrintRouter(WERROR,ValueToString(problem->value));
PrintRouter(WERROR," is unbound\n");
returnValue->type = SYMBOL;
returnValue->value = FalseSymbol;
SetEvaluationError(TRUE);
}
break;
default:
if (PrimitivesArray[problem->type] == NULL)
{
SystemError("EVALUATN",3);
ExitRouter(EXIT_FAILURE);
}
if (PrimitivesArray[problem->type]->copyToEvaluate)
{
returnValue->type = problem->type;
returnValue->value = problem->value;
break;
}
if (PrimitivesArray[problem->type]->evaluateFunction == NULL)
{
SystemError("EVALUATN",4);
ExitRouter(EXIT_FAILURE);
}
oldArgument = CurrentExpression;
CurrentExpression = problem;
#if PROFILING_FUNCTIONS
StartProfile(&profileFrame,
&PrimitivesArray[problem->type]->usrData,
ProfileUserFunctions);
#endif
(*PrimitivesArray[problem->type]->evaluateFunction)(problem->value,returnValue);
#if PROFILING_FUNCTIONS
EndProfile(&profileFrame);
#endif
CurrentExpression = oldArgument;
break;
}
PropagateReturnValue(returnValue);
return(EvaluationError);
}
globle VOID PrintFuzzyValue(
char *fileid,
struct fuzzy_value *fv)
{
PrintRouter(fileid,fv->name);
}
int main( int argc, char* argv[] ) {
Router *r1, *r2, *r3;
Sessao *s1, *s2, *s3;
Disciplina *disc;
pq FilaEventos;
/* Inicializar o simulador. */
FilaEventos = IniciaFila( PQ_SIZE );
r3 = NovoRouter( 2, 2000000, 0.000, NULL );
r2 = NovoRouter( 1, 500000, 0.010, r3 );
r1 = NovoRouter( 0, 2000000, 0.010, r2 );
/* Primeira Experiencia. */
if( argv[1][0] == '1' ) {
#if AJUSTE
MAX_TIME = 110;
#else
MAX_TIME = 90;
#endif
s1 = NovaSessao( 0, 3, "Exp_1_Sessao_1.txt", 8000*AJUSTE_PACOTE_S1,
"exp1ses1deb.txt",
"exp1ses1filas.txt" );
s2 = NovaSessao( 1, 2, "Exp_1_Sessao_2.txt", 6400*AJUSTE_PACOTE_S2,
"exp1ses2deb.txt",
"exp1ses2filas.txt" );
s3 = NovaSessao( 2, 1, "Exp_1_Sessao_3.txt", 4800*AJUSTE_PACOTE_S3,
"exp1ses3deb.txt",
"exp1ses3filas.txt" );
}
else if( argv[1][0] == '2' ) {
#if AJUSTE
MAX_TIME = 12;
#else
MAX_TIME = 10;
#endif
s1 = NovaSessao( 0, 3, "Exp_2_Sessao_1.txt", 800*AJUSTE_PACOTE_S1,
"exp2ses1deb.txt",
"exp2ses1filas.txt" );
s2 = NovaSessao( 1, 2, "Exp_2_Sessao_2.txt", 640*AJUSTE_PACOTE_S2,
"exp2ses2deb.txt",
"exp2ses2filas.txt" );
s3 = NovaSessao( 2, 1, "Exp_2_Sessao_3.txt", 480*AJUSTE_PACOTE_S3,
"exp2ses3deb.txt",
"exp2ses3filas.txt" );
}
/* Coloca META EVENTOS na fila de eventos. */
ColocaNaFila( FilaEventos, (void*)NovoEvento( 0, RECARREGA, s1, r1 ) );
ColocaNaFila( FilaEventos, (void*)NovoEvento( 0, RECARREGA, s2, r1 ) );
ColocaNaFila( FilaEventos, (void*)NovoEvento( 0, RECARREGA, s3, r1 ) );
ColocaNaFila( FilaEventos, (void*)NovoEvento( 0, DEBITO, s1, NULL ) );
ColocaNaFila( FilaEventos, (void*)NovoEvento( 0, DEBITO, s2, NULL ) );
ColocaNaFila( FilaEventos, (void*)NovoEvento( 0, DEBITO, s3, NULL ) );
ColocaNaFila( FilaEventos, (void*)NovoEvento( 0, OCUPACAO_FILAS, s1, NULL ) );
ColocaNaFila( FilaEventos, (void*)NovoEvento( 0, OCUPACAO_FILAS, s2, NULL ) );
ColocaNaFila( FilaEventos, (void*)NovoEvento( 0, OCUPACAO_FILAS, s3, NULL ) );
/* Define a disciplina a utilizar. */
disc = NovaDisciplina( atoi( argv[2] ) );
/* Ciclo de simulacao. */
while( ExecutaEvento( FilaEventos,
disc -> ProcessaChegada ,
disc -> ProcessaPartida ) );
/* Apresentacao das estatisticas. */
PrintRouter( NULL, r1 );
PrintRouter( NULL, r2 );
PrintRouter( NULL, r3 );
PrintSessao( NULL, s1 );
PrintSessao( NULL, s2 );
PrintSessao( NULL, s3 );
/* Limpeza do simulador. */
ApagaFila( FilaEventos );
ApagaRouter( r1 );
ApagaRouter( r2 );
ApagaRouter( r3 );
ApagaSessao( s1 );
ApagaSessao( s2 );
ApagaSessao( s3 );
ApagaDisciplina( disc );
exit( 0 );
}
globle void SalienceNonIntegerError()
{
PrintErrorID("PRNTUTIL",10,TRUE);
PrintRouter(WERROR,"Salience value must be an integer value.\n");
}
static struct expr *LoopForCountParse(
struct expr *parse,
char *infile)
{
struct token theToken;
SYMBOL_HN *loopVar = NULL;
EXPRESSION *tmpexp;
int read_first_paren;
struct BindInfo *oldBindList,*newBindList,*prev;
/*======================================*/
/* Process the loop counter expression. */
/*======================================*/
SavePPBuffer(" ");
GetToken(infile,&theToken);
/* ==========================================
Simple form: loop-for-count <end> [do] ...
========================================== */
if (theToken.type != LPAREN)
{
parse->argList = GenConstant(INTEGER,AddLong(1L));
parse->argList->nextArg = ParseAtomOrExpression(infile,&theToken);
if (parse->argList->nextArg == NULL)
{
ReturnExpression(parse);
return(NULL);
}
}
else
{
GetToken(infile,&theToken);
if (theToken.type != SF_VARIABLE)
{
if (theToken.type != SYMBOL)
goto LoopForCountParseError;
parse->argList = GenConstant(INTEGER,AddLong(1L));
parse->argList->nextArg = Function2Parse(infile,ValueToString(theToken.value));
if (parse->argList->nextArg == NULL)
{
ReturnExpression(parse);
return(NULL);
}
}
/* =============================================================
Complex form: loop-for-count (<var> [<start>] <end>) [do] ...
============================================================= */
else
{
loopVar = (SYMBOL_HN *) theToken.value;
SavePPBuffer(" ");
parse->argList = ParseAtomOrExpression(infile,NULL);
if (parse->argList == NULL)
{
ReturnExpression(parse);
return(NULL);
}
if (CheckArgumentAgainstRestriction(parse->argList,(int) 'i'))
goto LoopForCountParseError;
SavePPBuffer(" ");
GetToken(infile,&theToken);
if (theToken.type == RPAREN)
{
PPBackup();
PPBackup();
SavePPBuffer(theToken.printForm);
tmpexp = GenConstant(INTEGER,AddLong(1L));
tmpexp->nextArg = parse->argList;
parse->argList = tmpexp;
}
else
{
parse->argList->nextArg = ParseAtomOrExpression(infile,&theToken);
if (parse->argList->nextArg == NULL)
{
ReturnExpression(parse);
return(NULL);
}
GetToken(infile,&theToken);
if (theToken.type != RPAREN)
goto LoopForCountParseError;
}
SavePPBuffer(" ");
}
}
if (CheckArgumentAgainstRestriction(parse->argList->nextArg,(int) 'i'))
goto LoopForCountParseError;
/*====================================*/
/* Process the do keyword if present. */
/*====================================*/
GetToken(infile,&theToken);
if ((theToken.type == SYMBOL) && (strcmp(ValueToString(theToken.value),"do") == 0))
{
read_first_paren = TRUE;
PPBackup();
SavePPBuffer(" ");
SavePPBuffer(theToken.printForm);
IncrementIndentDepth(3);
PPCRAndIndent();
}
else if (theToken.type == LPAREN)
{
read_first_paren = FALSE;
PPBackup();
IncrementIndentDepth(3);
PPCRAndIndent();
SavePPBuffer(theToken.printForm);
}
else
goto LoopForCountParseError;
/*=====================================*/
/* Process the loop-for-count actions. */
/*=====================================*/
if (svContexts->rtn == TRUE)
ReturnContext = TRUE;
BreakContext = TRUE;
oldBindList = GetParsedBindNames();
SetParsedBindNames(NULL);
parse->argList->nextArg->nextArg =
GroupActions(infile,&theToken,read_first_paren,NULL,FALSE);
if (parse->argList->nextArg->nextArg == NULL)
{
SetParsedBindNames(oldBindList);
ReturnExpression(parse);
return(NULL);
}
newBindList = GetParsedBindNames();
prev = NULL;
while (newBindList != NULL)
{
if ((loopVar == NULL) ? FALSE :
(strcmp(ValueToString(newBindList->name),ValueToString(loopVar)) == 0))
{
ClearParsedBindNames();
SetParsedBindNames(oldBindList);
PrintErrorID("PRCDRPSR",1,TRUE);
PrintRouter(WERROR,"Cannot rebind loop variable in function loop-for-count.\n");
ReturnExpression(parse);
return(NULL);
}
prev = newBindList;
newBindList = newBindList->next;
}
if (prev == NULL)
SetParsedBindNames(oldBindList);
else
prev->next = oldBindList;
if (loopVar != NULL)
ReplaceLoopCountVars(loopVar,parse->argList->nextArg->nextArg,0);
PPBackup();
PPBackup();
SavePPBuffer(theToken.printForm);
/*================================================================*/
/* Check for the closing right parenthesis of the loop-for-count. */
/*================================================================*/
if (theToken.type != RPAREN)
{
SyntaxErrorMessage("loop-for-count function");
ReturnExpression(parse);
return(NULL);
}
DecrementIndentDepth(3);
return(parse);
LoopForCountParseError:
SyntaxErrorMessage("loop-for-count function");
ReturnExpression(parse);
return(NULL);
}
globle void ListWatchItemsCommand()
{
struct watchItem *wPtr;
DATA_OBJECT theValue;
int recognized;
/*=======================*/
/* List the watch items. */
/*=======================*/
if (GetFirstArgument() == NULL)
{
for (wPtr = ListOfWatchItems; wPtr != NULL; wPtr = wPtr->next)
{
PrintRouter(WDISPLAY,wPtr->name);
if (*(wPtr->flag)) PrintRouter(WDISPLAY," = on\n");
else PrintRouter(WDISPLAY," = off\n");
}
return;
}
/*=======================================*/
/* Determine which item is to be listed. */
/*=======================================*/
if (ArgTypeCheck("list-watch-items",1,SYMBOL,&theValue) == FALSE) return;
wPtr = ValidWatchItem(DOToString(theValue),&recognized);
if ((recognized == FALSE) || (wPtr == NULL))
{
SetEvaluationError(TRUE);
ExpectedTypeError1("list-watch-items",1,"watchable symbol");
return;
}
/*=================================================*/
/* Check to make sure extra arguments are allowed. */
/*=================================================*/
if ((wPtr->printFunc == NULL) &&
(GetNextArgument(GetFirstArgument()) != NULL))
{
SetEvaluationError(TRUE);
ExpectedCountError("list-watch-items",EXACTLY,1);
return;
}
/*====================================*/
/* List the status of the watch item. */
/*====================================*/
PrintRouter(WDISPLAY,wPtr->name);
if (*(wPtr->flag)) PrintRouter(WDISPLAY," = on\n");
else PrintRouter(WDISPLAY," = off\n");
/*============================================*/
/* List the status of individual watch items. */
/*============================================*/
if (wPtr->printFunc != NULL)
{
if ((*wPtr->printFunc)(WDISPLAY,wPtr->code,
GetNextArgument(GetFirstArgument())) == FALSE)
{ SetEvaluationError(TRUE); }
}
}
globle void PrimitiveTablesInfo()
{
int i;
SYMBOL_HN **symbolArray, *symbolPtr;
FLOAT_HN **floatArray, *floatPtr;
INTEGER_HN **integerArray, *integerPtr;
BITMAP_HN **bitMapArray, *bitMapPtr;
unsigned long int symbolCount = 0, integerCount = 0;
unsigned long int floatCount = 0, bitMapCount = 0;
ArgCountCheck("primitives-info",EXACTLY,0);
/*====================================*/
/* Count entries in the symbol table. */
/*====================================*/
symbolArray = GetSymbolTable();
for (i = 0; i < SYMBOL_HASH_SIZE; i++)
{
for (symbolPtr = symbolArray[i]; symbolPtr != NULL; symbolPtr = symbolPtr->next)
{ symbolCount++; }
}
/*====================================*/
/* Count entries in the integer table. */
/*====================================*/
integerArray = GetIntegerTable();
for (i = 0; i < INTEGER_HASH_SIZE; i++)
{
for (integerPtr = integerArray[i]; integerPtr != NULL; integerPtr = integerPtr->next)
{ integerCount++; }
}
/*====================================*/
/* Count entries in the float table. */
/*====================================*/
floatArray = GetFloatTable();
for (i = 0; i < FLOAT_HASH_SIZE; i++)
{
for (floatPtr = floatArray[i]; floatPtr != NULL; floatPtr = floatPtr->next)
{ floatCount++; }
}
/*====================================*/
/* Count entries in the bitmap table. */
/*====================================*/
bitMapArray = GetBitMapTable();
for (i = 0; i < BITMAP_HASH_SIZE; i++)
{
for (bitMapPtr = bitMapArray[i]; bitMapPtr != NULL; bitMapPtr = bitMapPtr->next)
{ bitMapCount++; }
}
/*========================*/
/* Print the information. */
/*========================*/
PrintRouter(WDISPLAY,"Symbols: ");
PrintLongInteger(WDISPLAY,(long) symbolCount);
PrintRouter(WDISPLAY,"\n");
PrintRouter(WDISPLAY,"Integers: ");
PrintLongInteger(WDISPLAY,(long) integerCount);
PrintRouter(WDISPLAY,"\n");
PrintRouter(WDISPLAY,"Floats: ");
PrintLongInteger(WDISPLAY,(long) floatCount);
PrintRouter(WDISPLAY,"\n");
PrintRouter(WDISPLAY,"BitMaps: ");
PrintLongInteger(WDISPLAY,(long) bitMapCount);
PrintRouter(WDISPLAY,"\n");
}
