globle void ShowFactPatternNetwork(
void *theEnv)
{
struct factPatternNode *patternPtr;
struct deftemplate *theDeftemplate;
char *theName;
int depth = 0, i;
theName = GetConstructName(theEnv,(char*)"show-fpn",(char*)"template name");
if (theName == NULL) return;
theDeftemplate = (struct deftemplate *) EnvFindDeftemplate(theEnv,theName);
if (theDeftemplate == NULL) return;
patternPtr = theDeftemplate->patternNetwork;
while (patternPtr != NULL)
{
for (i = 0; i < depth; i++) EnvPrintRouter(theEnv,WDISPLAY,(char*)" ");
if (patternPtr->header.singlefieldNode) EnvPrintRouter(theEnv,WDISPLAY,(char*)"SF ");
else if (patternPtr->header.multifieldNode)
{
EnvPrintRouter(theEnv,WDISPLAY,(char*)"MF");
if (patternPtr->header.endSlot) EnvPrintRouter(theEnv,WDISPLAY,(char*)")");
else EnvPrintRouter(theEnv,WDISPLAY,(char*)"*");
PrintLongInteger(theEnv,WDISPLAY,(long long) patternPtr->leaveFields);
EnvPrintRouter(theEnv,WDISPLAY,(char*)" ");
}
EnvPrintRouter(theEnv,WDISPLAY,(char*)"Slot: ");
PrintLongInteger(theEnv,WDISPLAY,(long long) patternPtr->whichSlot);
EnvPrintRouter(theEnv,WDISPLAY,(char*)" Field: ");
PrintLongInteger(theEnv,WDISPLAY,(long long) patternPtr->whichField);
EnvPrintRouter(theEnv,WDISPLAY,(char*)" Expression: ");
if (patternPtr->networkTest == NULL) EnvPrintRouter(theEnv,WDISPLAY,(char*)"None");
else PrintExpression(theEnv,WDISPLAY,patternPtr->networkTest);
EnvPrintRouter(theEnv,WDISPLAY,(char*)" RightHash: ");
if (patternPtr->header.rightHash == NULL) EnvPrintRouter(theEnv,WDISPLAY,(char*)"None");
else PrintExpression(theEnv,WDISPLAY,patternPtr->header.rightHash);
EnvPrintRouter(theEnv,WDISPLAY,(char*)"\n");
if (patternPtr->nextLevel == NULL)
{
while (patternPtr->rightNode == NULL)
{
patternPtr = patternPtr->lastLevel;
depth--;
if (patternPtr == NULL) return;
}
patternPtr = patternPtr->rightNode;
}
else
{
patternPtr = patternPtr->nextLevel;
depth++;
}
}
}
/*********************************************************
NAME : DisplaySlotConstraintInfo
DESCRIPTION : Displays a table summary of type-checking
facets for the slots of a class
including:
type
allowed-symbols
allowed-integers
allowed-floats
allowed-values
allowed-instance-names
range
min-number-of-elements
max-number-of-elements
The function also displays the source
class(es) for the facets
INPUTS : 1) A format string for use in sprintf
2) A buffer to store the display in
3) Maximum buffer size
4) A pointer to the class
RETURNS : Nothing useful
SIDE EFFECTS : Buffer written to and displayed
NOTES : None
*********************************************************/
static void DisplaySlotConstraintInfo(
void *theEnv,
char *logicalName,
char *slotNamePrintFormat,
char *buf,
unsigned maxlen,
DEFCLASS *cls)
{
long i;
CONSTRAINT_RECORD *cr;
char *strdest = "***describe-class***";
gensprintf(buf,slotNamePrintFormat,"SLOTS");
genstrcat(buf,"SYM STR INN INA EXA FTA INT FLT\n");
EnvPrintRouter(theEnv,logicalName,buf);
for (i = 0 ; i < cls->instanceSlotCount ; i++)
{
cr = cls->instanceTemplate[i]->constraint;
gensprintf(buf,slotNamePrintFormat,ValueToString(cls->instanceTemplate[i]->slotName->name));
if (cr != NULL)
{
genstrcat(buf,ConstraintCode(cr,(unsigned) cr->symbolsAllowed,
(unsigned) cr->symbolRestriction));
genstrcat(buf,ConstraintCode(cr,(unsigned) cr->stringsAllowed,
(unsigned) cr->stringRestriction));
genstrcat(buf,ConstraintCode(cr,(unsigned) cr->instanceNamesAllowed,
(unsigned) (cr->instanceNameRestriction || cr->classRestriction)));
genstrcat(buf,ConstraintCode(cr,(unsigned) cr->instanceAddressesAllowed,
(unsigned) cr->classRestriction));
genstrcat(buf,ConstraintCode(cr,(unsigned) cr->externalAddressesAllowed,0));
genstrcat(buf,ConstraintCode(cr,(unsigned) cr->factAddressesAllowed,0));
genstrcat(buf,ConstraintCode(cr,(unsigned) cr->integersAllowed,
(unsigned) cr->integerRestriction));
genstrcat(buf,ConstraintCode(cr,(unsigned) cr->floatsAllowed,
(unsigned) cr->floatRestriction));
OpenStringDestination(theEnv,strdest,buf + strlen(buf),(maxlen - strlen(buf) - 1));
if (cr->integersAllowed || cr->floatsAllowed || cr->anyAllowed)
{
EnvPrintRouter(theEnv,strdest,"RNG:[");
PrintExpression(theEnv,strdest,cr->minValue);
EnvPrintRouter(theEnv,strdest,"..");
PrintExpression(theEnv,strdest,cr->maxValue);
EnvPrintRouter(theEnv,strdest,"] ");
}
if (cls->instanceTemplate[i]->multiple)
{
EnvPrintRouter(theEnv,strdest,"CRD:[");
PrintExpression(theEnv,strdest,cr->minFields);
EnvPrintRouter(theEnv,strdest,"..");
PrintExpression(theEnv,strdest,cr->maxFields);
EnvPrintRouter(theEnv,strdest,"]");
}
}
else
{
OpenStringDestination(theEnv,strdest,buf,maxlen);
EnvPrintRouter(theEnv,strdest," + + + + + + + + RNG:[-oo..+oo]");
if (cls->instanceTemplate[i]->multiple)
EnvPrintRouter(theEnv,strdest," CRD:[0..+oo]");
}
EnvPrintRouter(theEnv,strdest,"\n");
CloseStringDestination(theEnv,strdest);
EnvPrintRouter(theEnv,logicalName,buf);
}
}
globle void RerouteStdin(
void *theEnv,
int argc,
char *argv[])
{
int i;
int theSwitch = NO_SWITCH;
/*======================================*/
/* If there aren't enough arguments for */
/* the -f argument, then return. */
/*======================================*/
if (argc < 3)
{ return; }
/*=====================================*/
/* If argv was not passed then return. */
/*=====================================*/
if (argv == NULL) return;
/*=============================================*/
/* Process each of the command line arguments. */
/*=============================================*/
for (i = 1 ; i < argc ; i++)
{
if (strcmp(argv[i],"-f") == 0) theSwitch = BATCH_SWITCH;
#if ! RUN_TIME
else if (strcmp(argv[i],"-f2") == 0) theSwitch = BATCH_STAR_SWITCH;
else if (strcmp(argv[i],"-l") == 0) theSwitch = LOAD_SWITCH;
#endif
else if (theSwitch == NO_SWITCH)
{
PrintErrorID(theEnv,"SYSDEP",2,FALSE);
EnvPrintRouter(theEnv,WERROR,"Invalid option\n");
}
if (i > (argc-1))
{
PrintErrorID(theEnv,"SYSDEP",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"No file found for ");
switch(theSwitch)
{
case BATCH_SWITCH:
EnvPrintRouter(theEnv,WERROR,"-f");
break;
case BATCH_STAR_SWITCH:
EnvPrintRouter(theEnv,WERROR,"-f2");
break;
case LOAD_SWITCH:
EnvPrintRouter(theEnv,WERROR,"-l");
}
EnvPrintRouter(theEnv,WERROR," option\n");
return;
}
switch(theSwitch)
{
case BATCH_SWITCH:
OpenBatch(theEnv,argv[++i],TRUE);
break;
#if (! RUN_TIME) && (! BLOAD_ONLY)
case BATCH_STAR_SWITCH:
EnvBatchStar(theEnv,argv[++i]);
break;
case LOAD_SWITCH:
EnvLoad(theEnv,argv[++i]);
break;
#endif
}
}
}
globle int CheckSyntax(
void *theEnv,
const char *theString,
DATA_OBJECT_PTR returnValue)
{
const char *name;
struct token theToken;
struct expr *top;
short rv;
/*==============================*/
/* Set the default return value */
/* (TRUE for problems found). */
/*==============================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvTrueSymbol(theEnv));
/*===========================================*/
/* Create a string source router so that the */
/* string can be used as an input source. */
/*===========================================*/
if (OpenStringSource(theEnv,"check-syntax",theString,0) == 0)
{ return(TRUE); }
/*=================================*/
/* Only expressions and constructs */
/* can have their syntax checked. */
/*=================================*/
GetToken(theEnv,"check-syntax",&theToken);
if (theToken.type != LPAREN)
{
CloseStringSource(theEnv,"check-syntax");
SetpValue(returnValue,EnvAddSymbol(theEnv,"MISSING-LEFT-PARENTHESIS"));
return(TRUE);
}
/*========================================*/
/* The next token should be the construct */
/* type or function name. */
/*========================================*/
GetToken(theEnv,"check-syntax",&theToken);
if (theToken.type != SYMBOL)
{
CloseStringSource(theEnv,"check-syntax");
SetpValue(returnValue,EnvAddSymbol(theEnv,"EXPECTED-SYMBOL-AFTER-LEFT-PARENTHESIS"));
return(TRUE);
}
name = ValueToString(theToken.value);
/*==============================================*/
/* Set up a router to capture the error output. */
/*==============================================*/
EnvAddRouter(theEnv,"error-capture",40,
FindErrorCapture, PrintErrorCapture,
NULL, NULL, NULL);
/*================================*/
/* Determine if it's a construct. */
/*================================*/
if (FindConstruct(theEnv,name))
{
ConstructData(theEnv)->CheckSyntaxMode = TRUE;
rv = (short) ParseConstruct(theEnv,name,"check-syntax");
GetToken(theEnv,"check-syntax",&theToken);
ConstructData(theEnv)->CheckSyntaxMode = FALSE;
if (rv)
{
EnvPrintRouter(theEnv,WERROR,"\nERROR:\n");
PrintInChunks(theEnv,WERROR,GetPPBuffer(theEnv));
EnvPrintRouter(theEnv,WERROR,"\n");
}
DestroyPPBuffer(theEnv);
CloseStringSource(theEnv,"check-syntax");
if ((rv != FALSE) || (ParseFunctionData(theEnv)->WarningString != NULL))
{
SetErrorCaptureValues(theEnv,returnValue);
DeactivateErrorCapture(theEnv);
return(TRUE);
}
if (theToken.type != STOP)
{
SetpValue(returnValue,EnvAddSymbol(theEnv,"EXTRANEOUS-INPUT-AFTER-LAST-PARENTHESIS"));
DeactivateErrorCapture(theEnv);
return(TRUE);
}
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
DeactivateErrorCapture(theEnv);
return(FALSE);
}
/*=======================*/
/* Parse the expression. */
/*=======================*/
top = Function2Parse(theEnv,"check-syntax",name);
GetToken(theEnv,"check-syntax",&theToken);
ClearParsedBindNames(theEnv);
CloseStringSource(theEnv,"check-syntax");
if (top == NULL)
{
SetErrorCaptureValues(theEnv,returnValue);
DeactivateErrorCapture(theEnv);
return(TRUE);
}
if (theToken.type != STOP)
{
SetpValue(returnValue,EnvAddSymbol(theEnv,"EXTRANEOUS-INPUT-AFTER-LAST-PARENTHESIS"));
DeactivateErrorCapture(theEnv);
ReturnExpression(theEnv,top);
return(TRUE);
}
DeactivateErrorCapture(theEnv);
ReturnExpression(theEnv,top);
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
return(FALSE);
}
globle void PrintAtom(
void *theEnv,
const char *logicalName,
int type,
void *value)
{
struct externalAddressHashNode *theAddress;
char buffer[20];
switch (type)
{
case FLOAT:
PrintFloat(theEnv,logicalName,ValueToDouble(value));
break;
case INTEGER:
PrintLongInteger(theEnv,logicalName,ValueToLong(value));
break;
case SYMBOL:
EnvPrintRouter(theEnv,logicalName,ValueToString(value));
break;
case STRING:
if (PrintUtilityData(theEnv)->PreserveEscapedCharacters)
{ EnvPrintRouter(theEnv,logicalName,StringPrintForm(theEnv,ValueToString(value))); }
else
{
EnvPrintRouter(theEnv,logicalName,"\"");
EnvPrintRouter(theEnv,logicalName,ValueToString(value));
EnvPrintRouter(theEnv,logicalName,"\"");
}
break;
case DATA_OBJECT_ARRAY:
if (PrintUtilityData(theEnv)->AddressesToStrings) EnvPrintRouter(theEnv,logicalName,"\"");
EnvPrintRouter(theEnv,logicalName,"<Pointer-");
gensprintf(buffer,"%p",value);
EnvPrintRouter(theEnv,logicalName,buffer);
EnvPrintRouter(theEnv,logicalName,">");
if (PrintUtilityData(theEnv)->AddressesToStrings) EnvPrintRouter(theEnv,logicalName,"\"");
break;
case EXTERNAL_ADDRESS:
theAddress = (struct externalAddressHashNode *) value;
if (PrintUtilityData(theEnv)->AddressesToStrings) EnvPrintRouter(theEnv,logicalName,"\"");
if ((EvaluationData(theEnv)->ExternalAddressTypes[theAddress->type] != NULL) &&
(EvaluationData(theEnv)->ExternalAddressTypes[theAddress->type]->longPrintFunction != NULL))
{ (*EvaluationData(theEnv)->ExternalAddressTypes[theAddress->type]->longPrintFunction)(theEnv,logicalName,value); }
else
{
EnvPrintRouter(theEnv,logicalName,"<Pointer-");
gensprintf(buffer,"%d-",theAddress->type);
EnvPrintRouter(theEnv,logicalName,buffer);
gensprintf(buffer,"%p",ValueToExternalAddress(value));
EnvPrintRouter(theEnv,logicalName,buffer);
EnvPrintRouter(theEnv,logicalName,">");
}
if (PrintUtilityData(theEnv)->AddressesToStrings) EnvPrintRouter(theEnv,logicalName,"\"");
break;
#if OBJECT_SYSTEM
case INSTANCE_NAME:
EnvPrintRouter(theEnv,logicalName,"[");
EnvPrintRouter(theEnv,logicalName,ValueToString(value));
EnvPrintRouter(theEnv,logicalName,"]");
break;
#endif
case RVOID:
break;
default:
if (EvaluationData(theEnv)->PrimitivesArray[type] == NULL) break;
if (EvaluationData(theEnv)->PrimitivesArray[type]->longPrintFunction == NULL)
{
EnvPrintRouter(theEnv,logicalName,"<unknown atom type>");
break;
}
(*EvaluationData(theEnv)->PrimitivesArray[type]->longPrintFunction)(theEnv,logicalName,value);
break;
}
}
static void VariableReferenceErrorMessage(
void *theEnv,
struct symbolHashNode *theVariable,
struct lhsParseNode *theExpression,
int whichCE,
struct symbolHashNode *slotName,
int theField)
{
struct expr *temprv;
/*=============================*/
/* Print the error message ID. */
/*=============================*/
PrintErrorID(theEnv,"ANALYSIS",4,TRUE);
/*=================================*/
/* Print the name of the variable. */
/*=================================*/
EnvPrintRouter(theEnv,WERROR,"Variable ?");
EnvPrintRouter(theEnv,WERROR,ValueToString(theVariable));
EnvPrintRouter(theEnv,WERROR," ");
/*=================================================*/
/* If the variable was found inside an expression, */
/* then print the expression. */
/*=================================================*/
if (theExpression != NULL)
{
whichCE = theExpression->whichCE;
temprv = LHSParseNodesToExpression(theEnv,theExpression);
ReturnExpression(theEnv,temprv->nextArg);
temprv->nextArg = NULL;
EnvPrintRouter(theEnv,WERROR,"found in the expression ");
PrintExpression(theEnv,WERROR,temprv);
EnvPrintRouter(theEnv,WERROR,"\n");
ReturnExpression(theEnv,temprv);
}
/*====================================================*/
/* Print the CE in which the variable was referenced. */
/*====================================================*/
EnvPrintRouter(theEnv,WERROR,"was referenced in CE #");
PrintLongInteger(theEnv,WERROR,(long int) whichCE);
/*=====================================*/
/* Identify the slot or field in which */
/* the variable was found. */
/*=====================================*/
if (slotName == NULL)
{
if (theField > 0)
{
EnvPrintRouter(theEnv,WERROR," field #");
PrintLongInteger(theEnv,WERROR,(long int) theField);
}
}
else
{
EnvPrintRouter(theEnv,WERROR," slot ");
EnvPrintRouter(theEnv,WERROR,ValueToString(slotName));
}
EnvPrintRouter(theEnv,WERROR," before being defined.\n");
}
globle struct expr *ParseDefault(
void *theEnv,
char *readSource,
int multifield,
int dynamic,
int evalStatic,
int *noneSpecified,
int *deriveSpecified,
int *error)
{
struct expr *defaultList = NULL, *lastDefault = NULL;
struct expr *newItem, *tmpItem;
struct token theToken;
DATA_OBJECT theValue;
CONSTRAINT_RECORD *rv;
int specialVarCode;
*noneSpecified = FALSE;
*deriveSpecified = FALSE;
SavePPBuffer(theEnv,(char*)" ");
GetToken(theEnv,readSource,&theToken);
/*===================================================*/
/* Read the items contained in the default attribute */
/* until a closing right parenthesis is encountered. */
/*===================================================*/
while (theToken.type != RPAREN)
{
/*========================================*/
/* Get the next item in the default list. */
/*========================================*/
newItem = ParseAtomOrExpression(theEnv,readSource,&theToken);
if (newItem == NULL)
{
ReturnExpression(theEnv,defaultList);
*error = TRUE;
return(NULL);
}
/*===========================================================*/
/* Check for invalid variable usage. With the expection of */
/* ?NONE for the default attribute, local variables may not */
/* be used within the default or default-dynamic attributes. */
/*===========================================================*/
if ((newItem->type == SF_VARIABLE) || (newItem->type == MF_VARIABLE))
{
if (strcmp(ValueToString(newItem->value),"NONE") == 0)
{ specialVarCode = 0; }
else if (strcmp(ValueToString(newItem->value),"DERIVE") == 0)
{ specialVarCode = 1; }
else
{ specialVarCode = -1; }
if ((dynamic) ||
(newItem->type == MF_VARIABLE) ||
(specialVarCode == -1) ||
((specialVarCode != -1) && (defaultList != NULL)))
{
if (dynamic) SyntaxErrorMessage(theEnv,(char*)"default-dynamic attribute");
else SyntaxErrorMessage(theEnv,(char*)"default attribute");
ReturnExpression(theEnv,newItem);
ReturnExpression(theEnv,defaultList);
*error = TRUE;
return(NULL);
}
ReturnExpression(theEnv,newItem);
/*============================================*/
/* Check for the closing right parenthesis of */
/* the default or default dynamic attribute. */
/*============================================*/
GetToken(theEnv,readSource,&theToken);
if (theToken.type != RPAREN)
{
if (dynamic) SyntaxErrorMessage(theEnv,(char*)"default-dynamic attribute");
else SyntaxErrorMessage(theEnv,(char*)"default attribute");
PPBackup(theEnv);
SavePPBuffer(theEnv,(char*)" ");
SavePPBuffer(theEnv,theToken.printForm);
*error = TRUE;
}
if (specialVarCode == 0)
*noneSpecified = TRUE;
else
*deriveSpecified = TRUE;
return(NULL);
}
/*====================================================*/
/* Look to see if any variables have been used within */
/* expressions contained within the default list. */
/*====================================================*/
if (ExpressionContainsVariables(newItem,FALSE) == TRUE)
{
ReturnExpression(theEnv,defaultList);
ReturnExpression(theEnv,newItem);
*error = TRUE;
if (dynamic) SyntaxErrorMessage(theEnv,(char*)"default-dynamic attribute");
else SyntaxErrorMessage(theEnv,(char*)"default attribute");
return(NULL);
}
/*============================================*/
/* Add the default value to the default list. */
/*============================================*/
if (lastDefault == NULL)
{ defaultList = newItem; }
else
{ lastDefault->nextArg = newItem; }
lastDefault = newItem;
/*=======================================*/
/* Begin parsing the next default value. */
/*=======================================*/
SavePPBuffer(theEnv,(char*)" ");
GetToken(theEnv,readSource,&theToken);
}
/*=====================================*/
/* Fix up pretty print representation. */
/*=====================================*/
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,(char*)")");
/*=========================================*/
/* A single field slot's default attribute */
/* must contain a single value. */
/*=========================================*/
if (multifield == FALSE)
{
if (defaultList == NULL)
{ *error = TRUE; }
else if (defaultList->nextArg != NULL)
{ *error = TRUE; }
else
{
rv = ExpressionToConstraintRecord(theEnv,defaultList);
rv->multifieldsAllowed = FALSE;
if (UnmatchableConstraint(rv)) *error = TRUE;
RemoveConstraint(theEnv,rv);
}
if (*error)
{
PrintErrorID(theEnv,(char*)"DEFAULT",1,TRUE);
EnvPrintRouter(theEnv,WERROR,(char*)"The default value for a single field slot must be a single field value\n");
ReturnExpression(theEnv,defaultList);
return(NULL);
}
}
/*=======================================================*/
/* If the dynamic-default attribute is not being parsed, */
/* evaluate the expressions to make the default value. */
/*=======================================================*/
if (dynamic || (! evalStatic) || (defaultList == NULL)) return(defaultList);
tmpItem = defaultList;
newItem = defaultList;
defaultList = NULL;
while (newItem != NULL)
{
SetEvaluationError(theEnv,FALSE);
if (EvaluateExpression(theEnv,newItem,&theValue)) *error = TRUE;
if ((theValue.type == MULTIFIELD) &&
(multifield == FALSE) &&
(*error == FALSE))
{
PrintErrorID(theEnv,(char*)"DEFAULT",1,TRUE);
EnvPrintRouter(theEnv,WERROR,(char*)"The default value for a single field slot must be a single field value\n");
*error = TRUE;
}
if (*error)
{
ReturnExpression(theEnv,tmpItem);
ReturnExpression(theEnv,defaultList);
*error = TRUE;
return(NULL);
}
lastDefault = ConvertValueToExpression(theEnv,&theValue);
defaultList = AppendExpressions(defaultList,lastDefault);
newItem = newItem->nextArg;
}
ReturnExpression(theEnv,tmpItem);
/*==========================*/
/* Return the default list. */
/*==========================*/
return(defaultList);
}
globle void PrintFactJNGetVar3(
void *theEnv,
const char *logicalName,
void *theValue)
{
#if DEVELOPER
struct factGetVarJN3Call *hack;
hack = (struct factGetVarJN3Call *) ValueToBitMap(theValue);
EnvPrintRouter(theEnv,logicalName,"(fact-jn-getvar-3 ");
if (hack->fromBeginning) EnvPrintRouter(theEnv,logicalName,"t ");
else EnvPrintRouter(theEnv,logicalName,"f ");
if (hack->fromEnd) EnvPrintRouter(theEnv,logicalName,"t ");
else EnvPrintRouter(theEnv,logicalName,"f ");
PrintLongInteger(theEnv,logicalName,(long long) hack->beginOffset);
EnvPrintRouter(theEnv,logicalName," ");
PrintLongInteger(theEnv,logicalName,(long long) hack->endOffset);
EnvPrintRouter(theEnv,logicalName," ");
PrintLongInteger(theEnv,logicalName,(long long) hack->whichSlot);
EnvPrintRouter(theEnv,logicalName," p");
PrintLongInteger(theEnv,logicalName,(long long) hack->whichPattern + 1);
if (hack->lhs)
{ EnvPrintRouter(theEnv,logicalName," L"); }
else if (hack->rhs)
{ EnvPrintRouter(theEnv,logicalName," R"); }
EnvPrintRouter(theEnv,logicalName,")");
#else
#endif
}
globle void PrintFactJNCompVars2(
void *theEnv,
const char *logicalName,
void *theValue)
{
#if DEVELOPER
struct factCompVarsJN2Call *hack;
hack = (struct factCompVarsJN2Call *) ValueToBitMap(theValue);
EnvPrintRouter(theEnv,logicalName,"(fact-jn-cmp-vars2 ");
if (hack->pass) EnvPrintRouter(theEnv,logicalName,"= ");
else EnvPrintRouter(theEnv,logicalName,"<> ");
EnvPrintRouter(theEnv,logicalName,"p");
PrintLongInteger(theEnv,logicalName,(long long) hack->pattern1 + 1);
if (hack->p1lhs)
{ EnvPrintRouter(theEnv,logicalName," L"); }
else if (hack->p1rhs)
{ EnvPrintRouter(theEnv,logicalName," R"); }
EnvPrintRouter(theEnv,logicalName," s");
PrintLongInteger(theEnv,logicalName,(long long) hack->slot1);
if (hack->fromBeginning1) EnvPrintRouter(theEnv,logicalName, " b");
else EnvPrintRouter(theEnv,logicalName," e");
EnvPrintRouter(theEnv,logicalName," f");
PrintLongInteger(theEnv,logicalName,(long long) hack->offset1);
EnvPrintRouter(theEnv,logicalName," p");
PrintLongInteger(theEnv,logicalName,(long long) hack->pattern2 + 1);
if (hack->p2lhs)
{ EnvPrintRouter(theEnv,logicalName," L"); }
else if (hack->p2rhs)
{ EnvPrintRouter(theEnv,logicalName," R"); }
EnvPrintRouter(theEnv,logicalName," s");
PrintLongInteger(theEnv,logicalName,(long long) hack->slot2);
if (hack->fromBeginning2) EnvPrintRouter(theEnv,logicalName," b");
else EnvPrintRouter(theEnv,logicalName," e");
EnvPrintRouter(theEnv,logicalName," f");
PrintLongInteger(theEnv,logicalName,(long long) hack->offset2);
EnvPrintRouter(theEnv,logicalName,")");
#else
#endif
}
static int LogicalAnalysis(
void *theEnv,
struct lhsParseNode *patternList)
{
int firstLogical, logicalsFound = FALSE, logicalJoin = 0;
int gap = FALSE;
firstLogical = patternList->logical;
/*===================================================*/
/* Loop through each pattern in the LHS of the rule. */
/*===================================================*/
for (;
patternList != NULL;
patternList = patternList->bottom)
{
/*=======================================*/
/* Skip anything that isn't a pattern CE */
/* or is embedded within a not/and CE. */
/*=======================================*/
if ((patternList->type != PATTERN_CE) || (patternList->endNandDepth != 1))
{ continue; }
/*=====================================================*/
/* If the pattern CE is not contained within a logical */
/* CE, then set the gap flag to TRUE indicating that */
/* any subsequent pattern CE found within a logical CE */
/* represents a gap between logical CEs which is an */
/* error. */
/*=====================================================*/
if (patternList->logical == FALSE)
{
gap = TRUE;
continue;
}
/*=================================================*/
/* If a logical CE is encountered and the first CE */
/* of the rule isn't a logical CE, then indicate */
/* that the first CE must be a logical CE. */
/*=================================================*/
if (! firstLogical)
{
PrintErrorID(theEnv,"RULEPSR",1,TRUE);
EnvPrintRouter(theEnv,WERROR,"Logical CEs must be placed first in a rule\n");
return(-1);
}
/*===================================================*/
/* If a break within the logical CEs was found and a */
/* new logical CE is encountered, then indicate that */
/* there can't be any gaps between logical CEs. */
/*===================================================*/
if (gap)
{
PrintErrorID(theEnv,"RULEPSR",2,TRUE);
EnvPrintRouter(theEnv,WERROR,"Gaps may not exist between logical CEs\n");
return(-1);
}
/*===========================================*/
/* Increment the count of logical CEs found. */
/*===========================================*/
logicalJoin++;
logicalsFound = TRUE;
}
/*============================================*/
/* If logical CEs were found, then return the */
/* join number where the logical information */
/* will be stored in the join network. */
/*============================================*/
if (logicalsFound) return(logicalJoin);
/*=============================*/
/* Return zero indicating that */
/* no logical CE was found. */
/*=============================*/
return(0);
}
globle void PrintFactJNGetVar1(
void *theEnv,
const char *logicalName,
void *theValue)
{
#if DEVELOPER
struct factGetVarJN1Call *hack;
hack = (struct factGetVarJN1Call *) ValueToBitMap(theValue);
EnvPrintRouter(theEnv,logicalName,"(fact-jn-getvar-1 ");
if (hack->factAddress) EnvPrintRouter(theEnv,logicalName,"t ");
else EnvPrintRouter(theEnv,logicalName,"f ");
if (hack->allFields) EnvPrintRouter(theEnv,logicalName,"t ");
else EnvPrintRouter(theEnv,logicalName,"f ");
EnvPrintRouter(theEnv,logicalName,"p");
PrintLongInteger(theEnv,logicalName,(long long) hack->whichPattern + 1);
EnvPrintRouter(theEnv,logicalName," ");
PrintLongInteger(theEnv,logicalName,(long long) hack->whichField);
EnvPrintRouter(theEnv,logicalName," s");
PrintLongInteger(theEnv,logicalName,(long long) hack->whichSlot);
if (hack->lhs)
{ EnvPrintRouter(theEnv,logicalName," L"); }
else if (hack->rhs)
{ EnvPrintRouter(theEnv,logicalName," R"); }
EnvPrintRouter(theEnv,logicalName,")");
#else
#endif
}
globle void QSetDefglobalValue(
void *theEnv,
struct defglobal *theGlobal,
DATA_OBJECT_PTR vPtr,
int resetVar)
{
/*====================================================*/
/* If the new value passed for the defglobal is NULL, */
/* then reset the defglobal to the initial value it */
/* had when it was defined. */
/*====================================================*/
if (resetVar)
{
EvaluateExpression(theEnv,theGlobal->initial,vPtr);
if (EvaluationData(theEnv)->EvaluationError)
{
vPtr->type = SYMBOL;
vPtr->value = EnvFalseSymbol(theEnv);
}
}
/*==========================================*/
/* If globals are being watch, then display */
/* the change to the global variable. */
/*==========================================*/
#if DEBUGGING_FUNCTIONS
if (theGlobal->watch)
{
EnvPrintRouter(theEnv,WTRACE,":== ?*");
EnvPrintRouter(theEnv,WTRACE,ValueToString(theGlobal->header.name));
EnvPrintRouter(theEnv,WTRACE,"* ==> ");
PrintDataObject(theEnv,WTRACE,vPtr);
EnvPrintRouter(theEnv,WTRACE," <== ");
PrintDataObject(theEnv,WTRACE,&theGlobal->current);
EnvPrintRouter(theEnv,WTRACE,"\n");
}
#endif
/*==============================================*/
/* Remove the old value of the global variable. */
/*==============================================*/
ValueDeinstall(theEnv,&theGlobal->current);
if (theGlobal->current.type == MULTIFIELD)
{ ReturnMultifield(theEnv,(struct multifield *) theGlobal->current.value); }
/*===========================================*/
/* Set the new value of the global variable. */
/*===========================================*/
theGlobal->current.type = vPtr->type;
if (vPtr->type != MULTIFIELD) theGlobal->current.value = vPtr->value;
else DuplicateMultifield(theEnv,&theGlobal->current,vPtr);
ValueInstall(theEnv,&theGlobal->current);
/*===========================================*/
/* Set the variable indicating that a change */
/* has been made to a global variable. */
/*===========================================*/
DefglobalData(theEnv)->ChangeToGlobals = TRUE;
if ((EvaluationData(theEnv)->CurrentEvaluationDepth == 0) && (! CommandLineData(theEnv)->EvaluatingTopLevelCommand) &&
(EvaluationData(theEnv)->CurrentExpression == NULL))
{ PeriodicCleanup(theEnv,TRUE,FALSE); }
}
globle void ValidateBetaMemories(
void *theEnv) {
EnvPrintRouter(theEnv, WCLIPS, "ValidateBetaMemories");
DoForAllConstructs(theEnv,ValidateRuleBetaMemoriesAction,DefruleData(theEnv)->DefruleModuleIndex,FALSE,NULL);
}
/**********************************************************
NAME : PrintOPNLevel
DESCRIPTION : Recursivley prints object pattern network
INPUTS : 1) The current object pattern network node
2) A buffer holding preceding indentation
text showing the level in the tree
3) The length of the indentation text
RETURNS : Nothing useful
SIDE EFFECTS : Pattern nodes recursively printed
NOTES : None
**********************************************************/
static void PrintOPNLevel(
void *theEnv,
OBJECT_PATTERN_NODE *pptr,
char *indentbuf,
int ilen)
{
CLASS_BITMAP *cbmp;
SLOT_BITMAP *sbmp;
register unsigned i;
OBJECT_PATTERN_NODE *uptr;
OBJECT_ALPHA_NODE *alphaPtr;
while (pptr != NULL)
{
EnvPrintRouter(theEnv,WDISPLAY,indentbuf);
if (pptr->alphaNode != NULL)
EnvPrintRouter(theEnv,WDISPLAY,(char*)"+");
EnvPrintRouter(theEnv,WDISPLAY,ValueToString(FindIDSlotName(theEnv,pptr->slotNameID)));
EnvPrintRouter(theEnv,WDISPLAY,(char*)" (");
PrintLongInteger(theEnv,WDISPLAY,(long long) pptr->slotNameID);
EnvPrintRouter(theEnv,WDISPLAY,(char*)") ");
EnvPrintRouter(theEnv,WDISPLAY,pptr->endSlot ? (char*)"EPF#" : (char*)"PF#");
PrintLongInteger(theEnv,WDISPLAY,(long long) pptr->whichField);
EnvPrintRouter(theEnv,WDISPLAY,(char*)" ");
EnvPrintRouter(theEnv,WDISPLAY,pptr->multifieldNode ? (char*)"$? " : (char*) "? ");
if (pptr->networkTest != NULL)
PrintExpression(theEnv,WDISPLAY,pptr->networkTest);
EnvPrintRouter(theEnv,WDISPLAY,(char*)"\n");
alphaPtr = pptr->alphaNode;
while (alphaPtr != NULL)
{
EnvPrintRouter(theEnv,WDISPLAY,indentbuf);
EnvPrintRouter(theEnv,WDISPLAY,(char*)" Classes:");
cbmp = (CLASS_BITMAP *) ValueToBitMap(alphaPtr->classbmp);
for (i = 0 ; i <= cbmp->maxid ; i++)
if (TestBitMap(cbmp->map,i))
{
EnvPrintRouter(theEnv,WDISPLAY,(char*)" ");
EnvPrintRouter(theEnv,WDISPLAY,EnvGetDefclassName(theEnv,(void *) DefclassData(theEnv)->ClassIDMap[i]));
}
if (alphaPtr->slotbmp != NULL)
{
sbmp = (SLOT_BITMAP *) ValueToBitMap(pptr->alphaNode->slotbmp);
EnvPrintRouter(theEnv,WDISPLAY,(char*)" *** Slots:");
for (i = NAME_ID ; i <= sbmp->maxid ; i++)
if (TestBitMap(sbmp->map,i))
{
for (uptr = pptr ; uptr != NULL ; uptr = uptr->lastLevel)
if ((unsigned)(uptr->slotNameID) == i)
break;
if (uptr == NULL)
{
EnvPrintRouter(theEnv,WDISPLAY,(char*)" ");
EnvPrintRouter(theEnv,WDISPLAY,ValueToString(FindIDSlotName(theEnv,i)));
}
}
}
if (alphaPtr->header.rightHash != NULL)
{
EnvPrintRouter(theEnv,WDISPLAY,(char*)" RH: ");
PrintExpression(theEnv,WDISPLAY,alphaPtr->header.rightHash);
}
EnvPrintRouter(theEnv,WDISPLAY,(char*)"\n");
alphaPtr = alphaPtr->nxtInGroup;
}
indentbuf[ilen++] = (char) ((pptr->rightNode != NULL) ? '|' : ' ');
indentbuf[ilen++] = ' ';
indentbuf[ilen++] = ' ';
indentbuf[ilen] = '\0';
PrintOPNLevel(theEnv,pptr->nextLevel,indentbuf,ilen);
ilen -= 3;
indentbuf[ilen] = '\0';
pptr = pptr->rightNode;
}
}
globle SYMBOL_HN *GetConstructNameAndComment(
void *theEnv,
char *readSource,
struct token *inputToken,
char *constructName,
void *(*findFunction)(void *,char *),
int (*deleteFunction)(void *,void *),
char *constructSymbol,
int fullMessageCR,
int getComment,
int moduleNameAllowed)
{
#if (MAC_MCW || IBM_MCW || MAC_XCD) && (! DEBUGGING_FUNCTIONS)
#pragma unused(fullMessageCR)
#endif
SYMBOL_HN *name, *moduleName;
int redefining = FALSE;
void *theConstruct;
unsigned separatorPosition;
struct defmodule *theModule;
/*==========================*/
/* Next token should be the */
/* name of the construct. */
/*==========================*/
GetToken(theEnv,readSource,inputToken);
if (inputToken->type != SYMBOL)
{
PrintErrorID(theEnv,"CSTRCPSR",2,TRUE);
EnvPrintRouter(theEnv,WERROR,"Missing name for ");
EnvPrintRouter(theEnv,WERROR,constructName);
EnvPrintRouter(theEnv,WERROR," construct\n");
return(NULL);
}
name = (SYMBOL_HN *) inputToken->value;
/*===============================*/
/* Determine the current module. */
/*===============================*/
separatorPosition = FindModuleSeparator(ValueToString(name));
if (separatorPosition)
{
if (moduleNameAllowed == FALSE)
{
SyntaxErrorMessage(theEnv,"module specifier");
return(NULL);
}
moduleName = ExtractModuleName(theEnv,separatorPosition,ValueToString(name));
if (moduleName == NULL)
{
SyntaxErrorMessage(theEnv,"construct name");
return(NULL);
}
theModule = (struct defmodule *) EnvFindDefmodule(theEnv,ValueToString(moduleName));
if (theModule == NULL)
{
CantFindItemErrorMessage(theEnv,"defmodule",ValueToString(moduleName));
return(NULL);
}
EnvSetCurrentModule(theEnv,(void *) theModule);
name = ExtractConstructName(theEnv,separatorPosition,ValueToString(name));
if (name == NULL)
{
SyntaxErrorMessage(theEnv,"construct name");
return(NULL);
}
}
/*=====================================================*/
/* If the module was not specified, record the current */
/* module name as part of the pretty-print form. */
/*=====================================================*/
else
{
theModule = ((struct defmodule *) EnvGetCurrentModule(theEnv));
if (moduleNameAllowed)
{
PPBackup(theEnv);
SavePPBuffer(theEnv,EnvGetDefmoduleName(theEnv,theModule));
SavePPBuffer(theEnv,"::");
SavePPBuffer(theEnv,ValueToString(name));
}
}
/*==================================================================*/
/* Check for import/export conflicts from the construct definition. */
/*==================================================================*/
#if DEFMODULE_CONSTRUCT
if (FindImportExportConflict(theEnv,constructName,theModule,ValueToString(name)))
{
ImportExportConflictMessage(theEnv,constructName,ValueToString(name),NULL,NULL);
return(NULL);
}
#endif
/*========================================================*/
/* Remove the construct if it is already in the knowledge */
/* base and we're not just checking syntax. */
/*========================================================*/
if ((findFunction != NULL) && (! ConstructData(theEnv)->CheckSyntaxMode))
{
theConstruct = (*findFunction)(theEnv,ValueToString(name));
if (theConstruct != NULL)
{
redefining = TRUE;
if (deleteFunction != NULL)
{
if ((*deleteFunction)(theEnv,theConstruct) == FALSE)
{
PrintErrorID(theEnv,"CSTRCPSR",4,TRUE);
EnvPrintRouter(theEnv,WERROR,"Cannot redefine ");
EnvPrintRouter(theEnv,WERROR,constructName);
EnvPrintRouter(theEnv,WERROR," ");
EnvPrintRouter(theEnv,WERROR,ValueToString(name));
EnvPrintRouter(theEnv,WERROR," while it is in use.\n");
return(NULL);
}
}
}
}
/*=============================================*/
/* If compilations are being watched, indicate */
/* that a construct is being compiled. */
/*=============================================*/
#if DEBUGGING_FUNCTIONS
if ((EnvGetWatchItem(theEnv,"compilations") == TRUE) &&
GetPrintWhileLoading(theEnv) && (! ConstructData(theEnv)->CheckSyntaxMode))
{
if (redefining)
{
PrintWarningID(theEnv,"CSTRCPSR",1,TRUE);
EnvPrintRouter(theEnv,WDIALOG,"Redefining ");
}
else EnvPrintRouter(theEnv,WDIALOG,"Defining ");
EnvPrintRouter(theEnv,WDIALOG,constructName);
EnvPrintRouter(theEnv,WDIALOG,": ");
EnvPrintRouter(theEnv,WDIALOG,ValueToString(name));
if (fullMessageCR) EnvPrintRouter(theEnv,WDIALOG,"\n");
else EnvPrintRouter(theEnv,WDIALOG," ");
}
else
#endif
{
if (GetPrintWhileLoading(theEnv) && (! ConstructData(theEnv)->CheckSyntaxMode))
{ EnvPrintRouter(theEnv,WDIALOG,constructSymbol); }
}
/*===============================*/
/* Get the comment if it exists. */
/*===============================*/
GetToken(theEnv,readSource,inputToken);
if ((inputToken->type == STRING) && getComment)
{
PPBackup(theEnv);
SavePPBuffer(theEnv," ");
SavePPBuffer(theEnv,inputToken->printForm);
GetToken(theEnv,readSource,inputToken);
if (inputToken->type != RPAREN)
{
PPBackup(theEnv);
SavePPBuffer(theEnv,"\n ");
SavePPBuffer(theEnv,inputToken->printForm);
}
}
else if (inputToken->type != RPAREN)
{
PPBackup(theEnv);
SavePPBuffer(theEnv,"\n ");
SavePPBuffer(theEnv,inputToken->printForm);
}
/*===================================*/
/* Return the name of the construct. */
/*===================================*/
return(name);
}
static struct expr *LoopForCountParse(
void *theEnv,
struct expr *parse,
const 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(theEnv," ");
GetToken(theEnv,infile,&theToken);
/* ==========================================
Simple form: loop-for-count <end> [do] ...
========================================== */
if (theToken.type != LPAREN)
{
parse->argList = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,1LL));
parse->argList->nextArg = ParseAtomOrExpression(theEnv,infile,&theToken);
if (parse->argList->nextArg == NULL)
{
ReturnExpression(theEnv,parse);
return(NULL);
}
}
else
{
GetToken(theEnv,infile,&theToken);
if (theToken.type != SF_VARIABLE)
{
if (theToken.type != SYMBOL)
goto LoopForCountParseError;
parse->argList = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,1LL));
parse->argList->nextArg = Function2Parse(theEnv,infile,ValueToString(theToken.value));
if (parse->argList->nextArg == NULL)
{
ReturnExpression(theEnv,parse);
return(NULL);
}
}
/* =============================================================
Complex form: loop-for-count (<var> [<start>] <end>) [do] ...
============================================================= */
else
{
loopVar = (SYMBOL_HN *) theToken.value;
SavePPBuffer(theEnv," ");
parse->argList = ParseAtomOrExpression(theEnv,infile,NULL);
if (parse->argList == NULL)
{
ReturnExpression(theEnv,parse);
return(NULL);
}
if (CheckArgumentAgainstRestriction(theEnv,parse->argList,(int) 'i'))
goto LoopForCountParseError;
SavePPBuffer(theEnv," ");
GetToken(theEnv,infile,&theToken);
if (theToken.type == RPAREN)
{
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,theToken.printForm);
tmpexp = GenConstant(theEnv,INTEGER,EnvAddLong(theEnv,1LL));
tmpexp->nextArg = parse->argList;
parse->argList = tmpexp;
}
else
{
parse->argList->nextArg = ParseAtomOrExpression(theEnv,infile,&theToken);
if (parse->argList->nextArg == NULL)
{
ReturnExpression(theEnv,parse);
return(NULL);
}
GetToken(theEnv,infile,&theToken);
if (theToken.type != RPAREN)
goto LoopForCountParseError;
}
SavePPBuffer(theEnv," ");
}
}
if (CheckArgumentAgainstRestriction(theEnv,parse->argList->nextArg,(int) 'i'))
goto LoopForCountParseError;
/*====================================*/
/* Process the do keyword if present. */
/*====================================*/
GetToken(theEnv,infile,&theToken);
if ((theToken.type == SYMBOL) && (strcmp(ValueToString(theToken.value),"do") == 0))
{
read_first_paren = TRUE;
PPBackup(theEnv);
SavePPBuffer(theEnv," ");
SavePPBuffer(theEnv,theToken.printForm);
IncrementIndentDepth(theEnv,3);
PPCRAndIndent(theEnv);
}
else if (theToken.type == LPAREN)
{
read_first_paren = FALSE;
PPBackup(theEnv);
IncrementIndentDepth(theEnv,3);
PPCRAndIndent(theEnv);
SavePPBuffer(theEnv,theToken.printForm);
}
else
goto LoopForCountParseError;
/*=====================================*/
/* Process the loop-for-count actions. */
/*=====================================*/
if (ExpressionData(theEnv)->svContexts->rtn == TRUE)
ExpressionData(theEnv)->ReturnContext = TRUE;
ExpressionData(theEnv)->BreakContext = TRUE;
oldBindList = GetParsedBindNames(theEnv);
SetParsedBindNames(theEnv,NULL);
parse->argList->nextArg->nextArg =
GroupActions(theEnv,infile,&theToken,read_first_paren,NULL,FALSE);
if (parse->argList->nextArg->nextArg == NULL)
{
SetParsedBindNames(theEnv,oldBindList);
ReturnExpression(theEnv,parse);
return(NULL);
}
newBindList = GetParsedBindNames(theEnv);
prev = NULL;
while (newBindList != NULL)
{
if ((loopVar == NULL) ? FALSE :
(strcmp(ValueToString(newBindList->name),ValueToString(loopVar)) == 0))
{
ClearParsedBindNames(theEnv);
SetParsedBindNames(theEnv,oldBindList);
PrintErrorID(theEnv,"PRCDRPSR",1,TRUE);
EnvPrintRouter(theEnv,WERROR,"Cannot rebind loop variable in function loop-for-count.\n");
ReturnExpression(theEnv,parse);
return(NULL);
}
prev = newBindList;
newBindList = newBindList->next;
}
if (prev == NULL)
SetParsedBindNames(theEnv,oldBindList);
else
prev->next = oldBindList;
if (loopVar != NULL)
ReplaceLoopCountVars(theEnv,loopVar,parse->argList->nextArg->nextArg,0);
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,theToken.printForm);
/*================================================================*/
/* Check for the closing right parenthesis of the loop-for-count. */
/*================================================================*/
if (theToken.type != RPAREN)
{
SyntaxErrorMessage(theEnv,"loop-for-count function");
ReturnExpression(theEnv,parse);
return(NULL);
}
DecrementIndentDepth(theEnv,3);
return(parse);
LoopForCountParseError:
SyntaxErrorMessage(theEnv,"loop-for-count function");
ReturnExpression(theEnv,parse);
return(NULL);
}
globle void ImportExportConflictMessage(
void *theEnv,
char *constructName,
char *itemName,
char *causedByConstruct,
char *causedByName)
{
PrintErrorID(theEnv,"CSTRCPSR",3,TRUE);
EnvPrintRouter(theEnv,WERROR,"Cannot define ");
EnvPrintRouter(theEnv,WERROR,constructName);
EnvPrintRouter(theEnv,WERROR," ");
EnvPrintRouter(theEnv,WERROR,itemName);
EnvPrintRouter(theEnv,WERROR," because of an import/export conflict");
if (causedByConstruct == NULL) EnvPrintRouter(theEnv,WERROR,".\n");
else
{
EnvPrintRouter(theEnv,WERROR," caused by the ");
EnvPrintRouter(theEnv,WERROR,causedByConstruct);
EnvPrintRouter(theEnv,WERROR," ");
EnvPrintRouter(theEnv,WERROR,causedByName);
EnvPrintRouter(theEnv,WERROR,".\n");
}
}
static struct expr *SwitchParse(
void *theEnv,
struct expr *top,
const char *infile)
{
struct token theToken;
EXPRESSION *theExp,*chk;
int default_count = 0;
/*============================*/
/* Process the switch value */
/*============================*/
IncrementIndentDepth(theEnv,3);
SavePPBuffer(theEnv," ");
top->argList = theExp = ParseAtomOrExpression(theEnv,infile,NULL);
if (theExp == NULL)
goto SwitchParseError;
/*========================*/
/* Parse case statements. */
/*========================*/
GetToken(theEnv,infile,&theToken);
while (theToken.type != RPAREN)
{
PPBackup(theEnv);
PPCRAndIndent(theEnv);
SavePPBuffer(theEnv,theToken.printForm);
if (theToken.type != LPAREN)
goto SwitchParseErrorAndMessage;
GetToken(theEnv,infile,&theToken);
SavePPBuffer(theEnv," ");
if ((theToken.type == SYMBOL) &&
(strcmp(ValueToString(theToken.value),"case") == 0))
{
if (default_count != 0)
goto SwitchParseErrorAndMessage;
theExp->nextArg = ParseAtomOrExpression(theEnv,infile,NULL);
SavePPBuffer(theEnv," ");
if (theExp->nextArg == NULL)
goto SwitchParseError;
for (chk = top->argList->nextArg ; chk != theExp->nextArg ; chk = chk->nextArg)
{
if ((chk->type == theExp->nextArg->type) &&
(chk->value == theExp->nextArg->value) &&
IdenticalExpression(chk->argList,theExp->nextArg->argList))
{
PrintErrorID(theEnv,"PRCDRPSR",3,TRUE);
EnvPrintRouter(theEnv,WERROR,"Duplicate case found in switch function.\n");
goto SwitchParseError;
}
}
GetToken(theEnv,infile,&theToken);
if ((theToken.type != SYMBOL) ? TRUE :
(strcmp(ValueToString(theToken.value),"then") != 0))
goto SwitchParseErrorAndMessage;
}
else if ((theToken.type == SYMBOL) &&
(strcmp(ValueToString(theToken.value),"default") == 0))
{
if (default_count)
goto SwitchParseErrorAndMessage;
theExp->nextArg = GenConstant(theEnv,RVOID,NULL);
default_count = 1;
}
else
goto SwitchParseErrorAndMessage;
theExp = theExp->nextArg;
if (ExpressionData(theEnv)->svContexts->rtn == TRUE)
ExpressionData(theEnv)->ReturnContext = TRUE;
if (ExpressionData(theEnv)->svContexts->brk == TRUE)
ExpressionData(theEnv)->BreakContext = TRUE;
IncrementIndentDepth(theEnv,3);
PPCRAndIndent(theEnv);
theExp->nextArg = GroupActions(theEnv,infile,&theToken,TRUE,NULL,FALSE);
DecrementIndentDepth(theEnv,3);
ExpressionData(theEnv)->ReturnContext = FALSE;
ExpressionData(theEnv)->BreakContext = FALSE;
if (theExp->nextArg == NULL)
goto SwitchParseError;
theExp = theExp->nextArg;
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,theToken.printForm);
GetToken(theEnv,infile,&theToken);
}
DecrementIndentDepth(theEnv,3);
return(top);
SwitchParseErrorAndMessage:
SyntaxErrorMessage(theEnv,"switch function");
SwitchParseError:
ReturnExpression(theEnv,top);
DecrementIndentDepth(theEnv,3);
return(NULL);
}
globle int VariableAnalysis(
void *theEnv,
struct lhsParseNode *patternPtr)
{
int errorFlag = FALSE;
struct nandFrame *theNandFrames = NULL, *tempNandPtr;
int currentDepth = 1;
/*======================================================*/
/* Loop through all of the CEs in the rule to determine */
/* which variables refer to other variables and whether */
/* any semantic errors exist when refering to variables */
/* (such as referring to a variable that was not */
/* previously bound). */
/*======================================================*/
while (patternPtr != NULL)
{
/*==================================*/
/* If the nand depth is increasing, */
/* create a new nand frame. */
/*==================================*/
while (patternPtr->beginNandDepth > currentDepth)
{
tempNandPtr = get_struct(theEnv,nandFrame);
tempNandPtr->nandCE = patternPtr;
tempNandPtr->depth = currentDepth;
tempNandPtr->next = theNandFrames;
theNandFrames = tempNandPtr;
currentDepth++;
}
/*=========================================================*/
/* If a pattern CE is encountered, propagate any variables */
/* found in the pattern and note any illegal references to */
/* other variables. */
/*=========================================================*/
if (patternPtr->type == PATTERN_CE)
{
/*====================================================*/
/* Determine if the fact address associated with this */
/* pattern illegally refers to other variables. */
/*====================================================*/
if ((patternPtr->value != NULL) &&
(patternPtr->referringNode != NULL))
{
errorFlag = TRUE;
if (patternPtr->referringNode->index == -1)
{
PrintErrorID(theEnv,"ANALYSIS",1,TRUE);
EnvPrintRouter(theEnv,WERROR,"Duplicate pattern-address ?");
EnvPrintRouter(theEnv,WERROR,ValueToString(patternPtr->value));
EnvPrintRouter(theEnv,WERROR," found in CE #");
PrintLongInteger(theEnv,WERROR,(long) patternPtr->whichCE);
EnvPrintRouter(theEnv,WERROR,".\n");
}
else
{
PrintErrorID(theEnv,"ANALYSIS",2,TRUE);
EnvPrintRouter(theEnv,WERROR,"Pattern-address ?");
EnvPrintRouter(theEnv,WERROR,ValueToString(patternPtr->value));
EnvPrintRouter(theEnv,WERROR," used in CE #");
PrintLongInteger(theEnv,WERROR,(long) patternPtr->whichCE);
EnvPrintRouter(theEnv,WERROR," was previously bound within a pattern CE.\n");
}
}
/*====================================================*/
/* Propagate the pattern and field location of bound */
/* variables found in this pattern to other variables */
/* in the same semantic scope as the bound variable. */
/*====================================================*/
if (GetVariables(theEnv,patternPtr,PATTERN_CE,theNandFrames))
{
ReleaseNandFrames(theEnv,theNandFrames);
return(TRUE);
}
/*==========================================================*/
/* Analyze any test CE that's been attached to the pattern. */
/*==========================================================*/
if (TestCEAnalysis(theEnv,patternPtr,patternPtr->expression,FALSE,&errorFlag,theNandFrames) == TRUE)
{
ReleaseNandFrames(theEnv,theNandFrames);
return TRUE;
}
if (TestCEAnalysis(theEnv,patternPtr,patternPtr->secondaryExpression,TRUE,&errorFlag,theNandFrames) == TRUE)
{
ReleaseNandFrames(theEnv,theNandFrames);
return TRUE;
}
}
/*==============================================================*/
/* If a test CE is encountered, make sure that all references */
/* to variables have been previously bound. If they are bound */
/* then replace the references to variables with function calls */
/* to retrieve the variables. */
/*==============================================================*/
else if (patternPtr->type == TEST_CE)
{
if (TestCEAnalysis(theEnv,patternPtr,patternPtr->expression,FALSE,&errorFlag,theNandFrames) == TRUE)
{
ReleaseNandFrames(theEnv,theNandFrames);
return TRUE;
}
}
/*==================================*/
/* If the nand depth is decreasing, */
/* release the nand frames. */
/*==================================*/
while (patternPtr->endNandDepth < currentDepth)
{
tempNandPtr = theNandFrames->next;
rtn_struct(theEnv,nandFrame,theNandFrames);
theNandFrames = tempNandPtr;
currentDepth--;
}
/*=====================================================*/
/* Move on to the next pattern in the LHS of the rule. */
/*=====================================================*/
patternPtr = patternPtr->bottom;
}
/*==========================================*/
/* Return the error status of the analysis. */
/*==========================================*/
return(errorFlag);
}
/*********************************************************************
NAME : CheckMultifieldSlotModify
DESCRIPTION : For the functions slot-replace$, insert, & delete
as well as direct-slot-replace$, insert, & delete
this function gets the slot, index, and optional
field-value for these functions
INPUTS : 1) A code indicating the type of operation
INSERT (0) : Requires one index
REPLACE (1) : Requires two indices
DELETE_OP (2) : Requires two indices
2) Function name-string
3) Instance address
4) Argument expression chain
5) Caller's buffer for index (or beginning of range)
6) Caller's buffer for end of range
(can be NULL for INSERT)
7) Caller's new-field value buffer
(can be NULL for DELETE_OP)
RETURNS : The address of the instance-slot,
NULL on errors
SIDE EFFECTS : Caller's index buffer set
Caller's new-field value buffer set (if not NULL)
Will allocate an ephemeral segment to store more
than 1 new field value
EvaluationError set on errors
NOTES : Assume the argument chain is at least 2
expressions deep - slot, index, and optional values
*********************************************************************/
static INSTANCE_SLOT *CheckMultifieldSlotModify(
void *theEnv,
int code,
char *func,
INSTANCE_TYPE *ins,
EXPRESSION *args,
int *rb,
int *re,
DATA_OBJECT *newval)
{
DATA_OBJECT temp;
INSTANCE_SLOT *sp;
int start;
start = (args == GetFirstArgument()) ? 1 : 2;
EvaluationData(theEnv)->EvaluationError = FALSE;
EvaluateExpression(theEnv,args,&temp);
if (temp.type != SYMBOL)
{
ExpectedTypeError1(theEnv,func,start,"symbol");
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
sp = FindInstanceSlot(theEnv,ins,(SYMBOL_HN *) temp.value);
if (sp == NULL)
{
SlotExistError(theEnv,ValueToString(temp.value),func);
return(NULL);
}
if (sp->desc->multiple == 0)
{
PrintErrorID(theEnv,"INSMULT",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function ");
EnvPrintRouter(theEnv,WERROR,func);
EnvPrintRouter(theEnv,WERROR," cannot be used on single-field slot ");
EnvPrintRouter(theEnv,WERROR,ValueToString(sp->desc->slotName->name));
EnvPrintRouter(theEnv,WERROR," in instance ");
EnvPrintRouter(theEnv,WERROR,ValueToString(ins->name));
EnvPrintRouter(theEnv,WERROR,".\n");
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
EvaluateExpression(theEnv,args->nextArg,&temp);
if (temp.type != INTEGER)
{
ExpectedTypeError1(theEnv,func,start+1,"integer");
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
args = args->nextArg->nextArg;
*rb = ValueToInteger(temp.value);
if ((code == REPLACE) || (code == DELETE_OP))
{
EvaluateExpression(theEnv,args,&temp);
if (temp.type != INTEGER)
{
ExpectedTypeError1(theEnv,func,start+2,"integer");
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
*re = ValueToInteger(temp.value);
args = args->nextArg;
}
if ((code == INSERT) || (code == REPLACE))
{
if (EvaluateAndStoreInDataObject(theEnv,1,args,newval) == FALSE)
return(NULL);
}
return(sp);
}
/*******************************************************
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 unsigned DefmessageHandlerWatchSupport(
void *theEnv,
char *funcName,
char *logName,
int newState,
void (*printFunc)(void *,char *,void *,unsigned),
void (*traceFunc)(void *,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(theEnv);
theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,NULL);
while (theModule != NULL)
{
EnvSetCurrentModule(theEnv,(void *) theModule);
if (traceFunc == NULL)
{
EnvPrintRouter(theEnv,logName,EnvGetDefmoduleName(theEnv,(void *) theModule));
EnvPrintRouter(theEnv,logName,":\n");
}
theClass = EnvGetNextDefclass(theEnv,NULL);
while (theClass != NULL)
{
if (WatchClassHandlers(theEnv,theClass,NULL,-1,logName,newState,
TRUE,printFunc,traceFunc) == FALSE)
return(FALSE);
theClass = EnvGetNextDefclass(theEnv,theClass);
}
theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,(void *) theModule);
}
RestoreCurrentModule(theEnv);
return(TRUE);
}
/* ================================================
Set or show the traces for the specified handler
================================================ */
while (argExprs != NULL)
{
if (EvaluateExpression(theEnv,argExprs,&tmpData))
return(FALSE);
if (tmpData.type != SYMBOL)
{
ExpectedTypeError1(theEnv,funcName,argIndex,"class name");
return(FALSE);
}
theClass = (void *) LookupDefclassByMdlOrScope(theEnv,DOToString(tmpData));
if (theClass == NULL)
{
ExpectedTypeError1(theEnv,funcName,argIndex,"class name");
return(FALSE);
}
if (GetNextArgument(argExprs) != NULL)
{
argExprs = GetNextArgument(argExprs);
argIndex++;
if (EvaluateExpression(theEnv,argExprs,&tmpData))
return(FALSE);
if (tmpData.type != SYMBOL)
{
ExpectedTypeError1(theEnv,funcName,argIndex,"handler name");
return(FALSE);
}
theHandlerStr = DOToString(tmpData);
if (GetNextArgument(argExprs) != NULL)
{
argExprs = GetNextArgument(argExprs);
argIndex++;
if (EvaluateExpression(theEnv,argExprs,&tmpData))
return(FALSE);
if (tmpData.type != SYMBOL)
{
ExpectedTypeError1(theEnv,funcName,argIndex,"handler type");
return(FALSE);
}
if ((theType = (int) HandlerType(theEnv,funcName,DOToString(tmpData))) == MERROR)
return(FALSE);
}
else
theType = -1;
}
else
{
theHandlerStr = NULL;
theType = -1;
}
if (WatchClassHandlers(theEnv,theClass,theHandlerStr,theType,logName,
newState,FALSE,printFunc,traceFunc) == FALSE)
{
ExpectedTypeError1(theEnv,funcName,argIndex,"handler");
return(FALSE);
}
argIndex++;
argExprs = GetNextArgument(argExprs);
}
return(TRUE);
}
globle void EnvFacts(
void *theEnv,
char *logicalName,
void *vTheModule,
long long start,
long long end,
long long max)
{
struct fact *factPtr;
long count = 0;
struct defmodule *oldModule, *theModule = (struct defmodule *) vTheModule;
int allModules = FALSE;
/*==========================*/
/* Save the current module. */
/*==========================*/
oldModule = ((struct defmodule *) EnvGetCurrentModule(theEnv));
/*=========================================================*/
/* Determine if facts from all modules are to be displayed */
/* or just facts from the current module. */
/*=========================================================*/
if (theModule == NULL) allModules = TRUE;
else EnvSetCurrentModule(theEnv,(void *) theModule);
/*=====================================*/
/* Get the first fact to be displayed. */
/*=====================================*/
if (allModules) factPtr = (struct fact *) EnvGetNextFact(theEnv,NULL);
else factPtr = (struct fact *) GetNextFactInScope(theEnv,NULL);
/*===============================*/
/* Display facts until there are */
/* no more facts to display. */
/*===============================*/
while (factPtr != NULL)
{
/*==================================================*/
/* Abort the display of facts if the Halt Execution */
/* flag has been set (normally by user action). */
/*==================================================*/
if (GetHaltExecution(theEnv) == TRUE)
{
EnvSetCurrentModule(theEnv,(void *) oldModule);
return;
}
/*===============================================*/
/* If the maximum fact index of facts to display */
/* has been reached, then stop displaying facts. */
/*===============================================*/
if ((factPtr->factIndex > end) && (end != UNSPECIFIED))
{
PrintTally(theEnv,logicalName,count,"fact","facts");
EnvSetCurrentModule(theEnv,(void *) oldModule);
return;
}
/*================================================*/
/* If the maximum number of facts to be displayed */
/* has been reached, then stop displaying facts. */
/*================================================*/
if (max == 0)
{
PrintTally(theEnv,logicalName,count,"fact","facts");
EnvSetCurrentModule(theEnv,(void *) oldModule);
return;
}
/*======================================================*/
/* If the index of the fact is greater than the minimum */
/* starting fact index, then display the fact. */
/*======================================================*/
if (factPtr->factIndex >= start)
{
PrintFactWithIdentifier(theEnv,logicalName,factPtr);
EnvPrintRouter(theEnv,logicalName,"\n");
count++;
if (max > 0) max--;
}
/*========================================*/
/* Proceed to the next fact to be listed. */
/*========================================*/
if (allModules) factPtr = (struct fact *) EnvGetNextFact(theEnv,factPtr);
else factPtr = (struct fact *) GetNextFactInScope(theEnv,factPtr);
}
/*===================================================*/
/* Print the total of the number of facts displayed. */
/*===================================================*/
PrintTally(theEnv,logicalName,count,"fact","facts");
/*=============================*/
/* Restore the current module. */
/*=============================*/
EnvSetCurrentModule(theEnv,(void *) oldModule);
}
static struct expr *GetSlotAssertValues(
void *theEnv,
EXEC_STATUS,
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(theEnv,execStatus,"TMPLTRHS",1,TRUE);
EnvPrintRouter(theEnv,execStatus,WERROR,"Slot ");
EnvPrintRouter(theEnv,execStatus,WERROR,slotPtr->slotName->contents);
EnvPrintRouter(theEnv,execStatus,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(theEnv,execStatus,slotPtr->constraints,&theDefault,
(int) slotPtr->multislot,TRUE);
newArg = ConvertValueToExpression(theEnv,execStatus,&theDefault);
}
/*=========================================*/
/* Otherwise, use the expression contained */
/* in the default attribute. */
/*=========================================*/
else
{ newArg = CopyExpression(theEnv,execStatus,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(theEnv,execStatus,FACT_STORE_MULTIFIELD,EnvAddBitMap(theEnv,execStatus,(void *) nullBitMap,1));
tempArg->argList = newArg;
newArg = tempArg;
}
/*==============================================*/
/* Return the value to be asserted in the slot. */
/*==============================================*/
return(newArg);
}
globle intBool EnvSaveFacts(
void *theEnv,
char *fileName,
int saveCode,
struct expr *theList)
{
int tempValue1, tempValue2, tempValue3;
struct fact *theFact;
FILE *filePtr;
struct defmodule *theModule;
DATA_OBJECT_PTR theDOArray;
int count, i, printFact, error;
/*======================================================*/
/* Open the file. Use either "fast save" or I/O Router. */
/*======================================================*/
if ((filePtr = GenOpen(theEnv,fileName,"w")) == NULL)
{
OpenErrorMessage(theEnv,"save-facts",fileName);
return(FALSE);
}
SetFastSave(theEnv,filePtr);
/*===========================================*/
/* Set the print flags so that addresses and */
/* strings are printed properly to the file. */
/*===========================================*/
tempValue1 = PrintUtilityData(theEnv)->PreserveEscapedCharacters;
PrintUtilityData(theEnv)->PreserveEscapedCharacters = TRUE;
tempValue2 = PrintUtilityData(theEnv)->AddressesToStrings;
PrintUtilityData(theEnv)->AddressesToStrings = TRUE;
tempValue3 = PrintUtilityData(theEnv)->InstanceAddressesToNames;
PrintUtilityData(theEnv)->InstanceAddressesToNames = TRUE;
/*===================================================*/
/* Determine the list of specific facts to be saved. */
/*===================================================*/
theDOArray = GetSaveFactsDeftemplateNames(theEnv,theList,saveCode,&count,&error);
if (error)
{
PrintUtilityData(theEnv)->PreserveEscapedCharacters = tempValue1;
PrintUtilityData(theEnv)->AddressesToStrings = tempValue2;
PrintUtilityData(theEnv)->InstanceAddressesToNames = tempValue3;
GenClose(theEnv,filePtr);
SetFastSave(theEnv,NULL);
return(FALSE);
}
/*=================*/
/* Save the facts. */
/*=================*/
theModule = ((struct defmodule *) EnvGetCurrentModule(theEnv));
for (theFact = (struct fact *) GetNextFactInScope(theEnv,NULL);
theFact != NULL;
theFact = (struct fact *) GetNextFactInScope(theEnv,theFact))
{
/*===========================================================*/
/* If we're doing a local save and the facts's corresponding */
/* deftemplate isn't in the current module, then don't save */
/* the fact. */
/*===========================================================*/
if ((saveCode == LOCAL_SAVE) &&
(theFact->whichDeftemplate->header.whichModule->theModule != theModule))
{ printFact = FALSE; }
/*=====================================================*/
/* Otherwise, if the list of facts to be printed isn't */
/* restricted, then set the print flag to TRUE. */
/*=====================================================*/
else if (theList == NULL)
{ printFact = TRUE; }
/*=======================================================*/
/* Otherwise see if the fact's corresponding deftemplate */
/* is in the list of deftemplates whose facts are to be */
/* saved. If it's in the list, then set the print flag */
/* to TRUE, otherwise set it to FALSE. */
/*=======================================================*/
else
{
printFact = FALSE;
for (i = 0; i < count; i++)
{
if (theDOArray[i].value == (void *) theFact->whichDeftemplate)
{
printFact = TRUE;
break;
}
}
}
/*===================================*/
/* If the print flag is set to TRUE, */
/* then save the fact to the file. */
/*===================================*/
if (printFact)
{
PrintFact(theEnv,(char *) filePtr,theFact,FALSE,FALSE);
EnvPrintRouter(theEnv,(char *) filePtr,"\n");
}
}
/*==========================*/
/* Restore the print flags. */
/*==========================*/
PrintUtilityData(theEnv)->PreserveEscapedCharacters = tempValue1;
PrintUtilityData(theEnv)->AddressesToStrings = tempValue2;
PrintUtilityData(theEnv)->InstanceAddressesToNames = tempValue3;
/*=================*/
/* Close the file. */
/*=================*/
GenClose(theEnv,filePtr);
SetFastSave(theEnv,NULL);
/*==================================*/
/* Free the deftemplate name array. */
/*==================================*/
if (theList != NULL) rm3(theEnv,theDOArray,(long) sizeof(DATA_OBJECT) * count);
/*===================================*/
/* Return TRUE to indicate no errors */
/* occurred while saving the facts. */
/*===================================*/
return(TRUE);
}
globle void SalienceNonIntegerError(
void *theEnv)
{
PrintErrorID(theEnv,"PRNTUTIL",10,TRUE);
EnvPrintRouter(theEnv,WERROR,"Salience value must be an integer value.\n");
}
globle int LoadConstructsFromLogicalName(
void *theEnv,
char *readSource)
{
int constructFlag;
struct token theToken;
int noErrors = TRUE;
int foundConstruct;
/*=========================================*/
/* Reset the halt execution and evaluation */
/* error flags in preparation for parsing. */
/*=========================================*/
if (EvaluationData(theEnv)->CurrentEvaluationDepth == 0) SetHaltExecution(theEnv,FALSE);
SetEvaluationError(theEnv,FALSE);
/*========================================================*/
/* Find the beginning of the first construct in the file. */
/*========================================================*/
EvaluationData(theEnv)->CurrentEvaluationDepth++;
GetToken(theEnv,readSource,&theToken);
foundConstruct = FindConstructBeginning(theEnv,readSource,&theToken,FALSE,&noErrors);
/*==================================================*/
/* Parse the file until the end of file is reached. */
/*==================================================*/
while ((foundConstruct == TRUE) && (GetHaltExecution(theEnv) == FALSE))
{
/*===========================================================*/
/* Clear the pretty print buffer in preparation for parsing. */
/*===========================================================*/
FlushPPBuffer(theEnv);
/*======================*/
/* Parse the construct. */
/*======================*/
constructFlag = ParseConstruct(theEnv,ValueToString(theToken.value),readSource);
/*==============================================================*/
/* If an error occurred while parsing, then find the beginning */
/* of the next construct (but don't generate any more error */
/* messages--in effect, skip everything until another construct */
/* is found). */
/*==============================================================*/
if (constructFlag == 1)
{
EnvPrintRouter(theEnv,WERROR,"\nERROR:\n");
PrintInChunks(theEnv,WERROR,GetPPBuffer(theEnv));
EnvPrintRouter(theEnv,WERROR,"\n");
noErrors = FALSE;
GetToken(theEnv,readSource,&theToken);
foundConstruct = FindConstructBeginning(theEnv,readSource,&theToken,TRUE,&noErrors);
}
/*======================================================*/
/* Otherwise, find the beginning of the next construct. */
/*======================================================*/
else
{
GetToken(theEnv,readSource,&theToken);
foundConstruct = FindConstructBeginning(theEnv,readSource,&theToken,FALSE,&noErrors);
}
/*=====================================================*/
/* Yield time if necessary to foreground applications. */
/*=====================================================*/
if (foundConstruct)
{ IncrementSymbolCount(theToken.value); }
EvaluationData(theEnv)->CurrentEvaluationDepth--;
PeriodicCleanup(theEnv,FALSE,TRUE);
YieldTime(theEnv);
EvaluationData(theEnv)->CurrentEvaluationDepth++;
if (foundConstruct)
{ DecrementSymbolCount(theEnv,(SYMBOL_HN *) theToken.value); }
}
EvaluationData(theEnv)->CurrentEvaluationDepth--;
/*========================================================*/
/* Print a carriage return if a single character is being */
/* printed to indicate constructs are being processed. */
/*========================================================*/
#if DEBUGGING_FUNCTIONS
if ((EnvGetWatchItem(theEnv,"compilations") != TRUE) && GetPrintWhileLoading(theEnv))
#else
if (GetPrintWhileLoading(theEnv))
#endif
{ EnvPrintRouter(theEnv,WDIALOG,"\n"); }
/*=============================================================*/
/* Once the load is complete, destroy the pretty print buffer. */
/* This frees up any memory that was used to create the pretty */
/* print forms for constructs during parsing. Thus calls to */
/* the mem-used function will accurately reflect the amount of */
/* memory being used after a load command. */
/*=============================================================*/
DestroyPPBuffer(theEnv);
/*==========================================================*/
/* Return a boolean flag which indicates whether any errors */
/* were encountered while loading the constructs. */
/*==========================================================*/
return(noErrors);
}
/******************************************************
NAME : EnvDescribeClass
DESCRIPTION : Displays direct superclasses and
subclasses and the entire precedence
list for a class
INPUTS : 1) The logical name of the output
2) Class pointer
RETURNS : Nothing useful
SIDE EFFECTS : None
NOTES : None
******************************************************/
globle void EnvDescribeClass(
void *theEnv,
char *logicalName,
void *clsptr)
{
DEFCLASS *cls;
char buf[83],
slotNamePrintFormat[12],
overrideMessagePrintFormat[12];
int messageBanner;
long i;
size_t slotNameLength, maxSlotNameLength;
size_t overrideMessageLength, maxOverrideMessageLength;
cls = (DEFCLASS *) clsptr;
DisplaySeparator(theEnv,logicalName,buf,82,'=');
DisplaySeparator(theEnv,logicalName,buf,82,'*');
if (cls->abstract)
EnvPrintRouter(theEnv,logicalName,"Abstract: direct instances of this class cannot be created.\n\n");
else
{
EnvPrintRouter(theEnv,logicalName,"Concrete: direct instances of this class can be created.\n");
#if DEFRULE_CONSTRUCT
if (cls->reactive)
EnvPrintRouter(theEnv,logicalName,"Reactive: direct instances of this class can match defrule patterns.\n\n");
else
EnvPrintRouter(theEnv,logicalName,"Non-reactive: direct instances of this class cannot match defrule patterns.\n\n");
#else
EnvPrintRouter(theEnv,logicalName,"\n");
#endif
}
PrintPackedClassLinks(theEnv,logicalName,"Direct Superclasses:",&cls->directSuperclasses);
PrintPackedClassLinks(theEnv,logicalName,"Inheritance Precedence:",&cls->allSuperclasses);
PrintPackedClassLinks(theEnv,logicalName,"Direct Subclasses:",&cls->directSubclasses);
if (cls->instanceTemplate != NULL)
{
DisplaySeparator(theEnv,logicalName,buf,82,'-');
maxSlotNameLength = 5;
maxOverrideMessageLength = 8;
for (i = 0 ; i < cls->instanceSlotCount ; i++)
{
slotNameLength = strlen(ValueToString(cls->instanceTemplate[i]->slotName->name));
if (slotNameLength > maxSlotNameLength)
maxSlotNameLength = slotNameLength;
if (cls->instanceTemplate[i]->noWrite == 0)
{
overrideMessageLength =
strlen(ValueToString(cls->instanceTemplate[i]->overrideMessage));
if (overrideMessageLength > maxOverrideMessageLength)
maxOverrideMessageLength = overrideMessageLength;
}
}
if (maxSlotNameLength > 16)
maxSlotNameLength = 16;
if (maxOverrideMessageLength > 12)
maxOverrideMessageLength = 12;
#if WIN_MVC || WIN_BTC
gensprintf(slotNamePrintFormat,"%%-%Id.%Ids : ",maxSlotNameLength,maxSlotNameLength);
gensprintf(overrideMessagePrintFormat,"%%-%Id.%Ids ",maxOverrideMessageLength,
maxOverrideMessageLength);
#elif WIN_GCC
gensprintf(slotNamePrintFormat,"%%-%ld.%lds : ",(long) maxSlotNameLength,(long) maxSlotNameLength);
gensprintf(overrideMessagePrintFormat,"%%-%ld.%lds ",(long) maxOverrideMessageLength,
(long) maxOverrideMessageLength);
#else
gensprintf(slotNamePrintFormat,"%%-%zd.%zds : ",maxSlotNameLength,maxSlotNameLength);
gensprintf(overrideMessagePrintFormat,"%%-%zd.%zds ",maxOverrideMessageLength,
maxOverrideMessageLength);
#endif
DisplaySlotBasicInfo(theEnv,logicalName,slotNamePrintFormat,overrideMessagePrintFormat,buf,cls);
EnvPrintRouter(theEnv,logicalName,"\nConstraint information for slots:\n\n");
DisplaySlotConstraintInfo(theEnv,logicalName,slotNamePrintFormat,buf,82,cls);
}
if (cls->handlerCount > 0)
messageBanner = TRUE;
else
{
messageBanner = FALSE;
for (i = 1 ; i < cls->allSuperclasses.classCount ; i++)
if (cls->allSuperclasses.classArray[i]->handlerCount > 0)
{
messageBanner = TRUE;
break;
}
}
if (messageBanner)
{
DisplaySeparator(theEnv,logicalName,buf,82,'-');
EnvPrintRouter(theEnv,logicalName,"Recognized message-handlers:\n");
DisplayHandlersInLinks(theEnv,logicalName,&cls->allSuperclasses,0);
}
DisplaySeparator(theEnv,logicalName,buf,82,'*');
DisplaySeparator(theEnv,logicalName,buf,82,'=');
}
static int FindConstructBeginning(
void *theEnv,
char *readSource,
struct token *theToken,
int errorCorrection,
int *noErrors)
{
int leftParenthesisFound = FALSE;
int firstAttempt = TRUE;
/*===================================================*/
/* Process tokens until the beginning of a construct */
/* is found or there are no more tokens. */
/*===================================================*/
while (theToken->type != STOP)
{
/*=====================================================*/
/* Constructs begin with a left parenthesis. Make note */
/* that the opening parenthesis has been found. */
/*=====================================================*/
if (theToken->type == LPAREN)
{ leftParenthesisFound = TRUE; }
/*=================================================================*/
/* The name of the construct follows the opening left parenthesis. */
/* If it is the name of a valid construct, then return TRUE. */
/* Otherwise, reset the flags to look for the beginning of a */
/* construct. If error correction is being performed (i.e. the */
/* last construct parsed had an error in it), then don't bother to */
/* print an error message, otherwise, print an error message. */
/*=================================================================*/
else if ((theToken->type == SYMBOL) && (leftParenthesisFound == TRUE))
{
/*===========================================================*/
/* Is this a valid construct name (e.g., defrule, deffacts). */
/*===========================================================*/
if (FindConstruct(theEnv,ValueToString(theToken->value)) != NULL) return(TRUE);
/*===============================================*/
/* The construct name is invalid. Print an error */
/* message if one hasn't already been printed. */
/*===============================================*/
if (firstAttempt && (! errorCorrection))
{
errorCorrection = TRUE;
*noErrors = FALSE;
PrintErrorID(theEnv,"CSTRCPSR",1,TRUE);
EnvPrintRouter(theEnv,WERROR,"Expected the beginning of a construct.\n");
}
/*======================================================*/
/* Indicate that an error has been found and that we're */
/* looking for a left parenthesis again. */
/*======================================================*/
firstAttempt = FALSE;
leftParenthesisFound = FALSE;
}
/*====================================================================*/
/* Any token encountered other than a left parenthesis or a construct */
/* name following a left parenthesis is illegal. Again, if error */
/* correction is in progress, no error message is printed, otherwise, */
/* an error message is printed. */
/*====================================================================*/
else
{
if (firstAttempt && (! errorCorrection))
{
errorCorrection = TRUE;
*noErrors = FALSE;
PrintErrorID(theEnv,"CSTRCPSR",1,TRUE);
EnvPrintRouter(theEnv,WERROR,"Expected the beginning of a construct.\n");
}
firstAttempt = FALSE;
leftParenthesisFound = FALSE;
}
/*============================================*/
/* Move on to the next token to be processed. */
/*============================================*/
GetToken(theEnv,readSource,theToken);
}
/*===================================================================*/
/* Couldn't find the beginning of a construct, so FALSE is returned. */
/*===================================================================*/
return(FALSE);
}
globle void gensystem(
void *theEnv)
{
char *commandBuffer = NULL;
size_t bufferPosition = 0;
size_t bufferMaximum = 0;
int numa, i;
DATA_OBJECT tempValue;
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_BTC || WIN_MCW || 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;
}
globle void PrimitiveTablesUsage(
void *theEnv)
{
unsigned long i;
int symbolCounts[COUNT_SIZE], floatCounts[COUNT_SIZE];
SYMBOL_HN **symbolArray, *symbolPtr;
FLOAT_HN **floatArray, *floatPtr;
unsigned long int symbolCount, totalSymbolCount = 0;
unsigned long int floatCount, totalFloatCount = 0;
EnvArgCountCheck(theEnv,(char*)"primitives-usage",EXACTLY,0);
for (i = 0; i < 21; i++)
{
symbolCounts[i] = 0;
floatCounts[i] = 0;
}
/*====================================*/
/* Count entries in the symbol table. */
/*====================================*/
symbolArray = GetSymbolTable(theEnv);
for (i = 0; i < SYMBOL_HASH_SIZE; i++)
{
symbolCount = 0;
for (symbolPtr = symbolArray[i]; symbolPtr != NULL; symbolPtr = symbolPtr->next)
{
symbolCount++;
totalSymbolCount++;
}
if (symbolCount < (COUNT_SIZE - 1))
{ symbolCounts[symbolCount]++; }
else
{ symbolCounts[COUNT_SIZE - 1]++; }
}
/*===================================*/
/* Count entries in the float table. */
/*===================================*/
floatArray = GetFloatTable(theEnv);
for (i = 0; i < FLOAT_HASH_SIZE; i++)
{
floatCount = 0;
for (floatPtr = floatArray[i]; floatPtr != NULL; floatPtr = floatPtr->next)
{
floatCount++;
totalFloatCount++;
}
if (floatCount < (COUNT_SIZE - 1))
{ floatCounts[floatCount]++; }
else
{ floatCounts[COUNT_SIZE - 1]++; }
}
/*========================*/
/* Print the information. */
/*========================*/
EnvPrintRouter(theEnv,WDISPLAY,(char*)"Total Symbols: ");
PrintLongInteger(theEnv,WDISPLAY,(long long) totalSymbolCount);
EnvPrintRouter(theEnv,WDISPLAY,(char*)"\n");
for (i = 0; i < COUNT_SIZE; i++)
{
PrintLongInteger(theEnv,WDISPLAY,(long long) i);
EnvPrintRouter(theEnv,WDISPLAY,(char*)" ");
PrintLongInteger(theEnv,WDISPLAY,(long long) symbolCounts[i]);
EnvPrintRouter(theEnv,WDISPLAY,(char*)"\n");
}
EnvPrintRouter(theEnv,WDISPLAY,(char*)"\nTotal Floats: ");
PrintLongInteger(theEnv,WDISPLAY,(long long) totalFloatCount);
EnvPrintRouter(theEnv,WDISPLAY,(char*)"\n");
for (i = 0; i < COUNT_SIZE; i++)
{
PrintLongInteger(theEnv,WDISPLAY,(long long) i);
EnvPrintRouter(theEnv,WDISPLAY,(char*)" ");
PrintLongInteger(theEnv,WDISPLAY,(long long) floatCounts[i]);
EnvPrintRouter(theEnv,WDISPLAY,(char*)"\n");
}
}