globle void CheckSyntaxFunction(
void *theEnv,
DATA_OBJECT *returnValue)
{
DATA_OBJECT theArg;
/*===============================*/
/* Set up a default return value */
/* (TRUE for problems found). */
/*===============================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvTrueSymbol(theEnv));
/*=====================================================*/
/* Function check-syntax expects exactly one argument. */
/*=====================================================*/
if (EnvArgCountCheck(theEnv,"check-syntax",EXACTLY,1) == -1) return;
/*========================================*/
/* The argument should be of type STRING. */
/*========================================*/
if (EnvArgTypeCheck(theEnv,"check-syntax",1,STRING,&theArg) == FALSE)
{ return; }
/*===================*/
/* Check the syntax. */
/*===================*/
CheckSyntax(theEnv,DOToString(theArg),returnValue);
}
globle int FactPNCompVars1(
void *theEnv,
void *theValue,
DATA_OBJECT *theResult)
{
int rv;
struct field *fieldPtr1, *fieldPtr2;
struct factCompVarsPN1Call *hack;
/*========================================*/
/* Extract the arguments to the function. */
/*========================================*/
hack = (struct factCompVarsPN1Call *) ValueToBitMap(theValue);
fieldPtr1 = &FactData(theEnv)->CurrentPatternFact->theProposition.theFields[hack->field1];
fieldPtr2 = &FactData(theEnv)->CurrentPatternFact->theProposition.theFields[hack->field2];
/*=====================*/
/* Compare the values. */
/*=====================*/
if (fieldPtr1->type != fieldPtr2->type) rv = (int) hack->fail;
else if (fieldPtr1->value != fieldPtr2->value) rv = (int) hack->fail;
else rv = (int) hack->pass;
theResult->type = SYMBOL;
if (rv) theResult->value = EnvTrueSymbol(theEnv);
else theResult->value = EnvFalseSymbol(theEnv);
return(rv);
}
static intBool JNSimpleCompareFunction3(
void *theEnv,
void *theValue,
DATA_OBJECT *theResult)
{
INSTANCE_TYPE *ins1,*ins2;
struct multifieldMarker *theMarks;
struct ObjectCmpJoinSingleSlotVars3 *hack;
int rv;
FIELD f1,f2;
hack = (struct ObjectCmpJoinSingleSlotVars3 *) ValueToBitMap(theValue);
GetPatternObjectAndMarks(theEnv,((int) hack->firstPattern),hack->firstPatternLHS,hack->firstPatternRHS,&ins1,&theMarks);
GetInsMultiSlotField(&f1,ins1,(unsigned) hack->firstSlot,
(unsigned) hack->firstFromBeginning,
(unsigned) hack->firstOffset);
GetPatternObjectAndMarks(theEnv,((int) hack->secondPattern),hack->secondPatternLHS,hack->secondPatternRHS,&ins2,&theMarks);
GetInsMultiSlotField(&f2,ins2,(unsigned) hack->secondSlot,
(unsigned) hack->secondFromBeginning,
(unsigned) hack->secondOffset);
if (f1.type != f2.type)
rv = hack->fail;
else if (f1.value != f2.value)
rv = hack->fail;
else
rv = hack->pass;
theResult->type = SYMBOL;
theResult->value = rv ? EnvTrueSymbol(theEnv) : EnvFalseSymbol(theEnv);
return(rv);
}
globle intBool FactSlotLength(
void *theEnv,
void *theValue,
DATA_OBJECT_PTR returnValue)
{
struct factCheckLengthPNCall *hack;
struct multifield *segmentPtr;
long extraOffset = 0;
struct multifieldMarker *tempMark;
returnValue->type = SYMBOL;
returnValue->value = EnvFalseSymbol(theEnv);
hack = (struct factCheckLengthPNCall *) ValueToBitMap(theValue);
for (tempMark = FactData(theEnv)->CurrentPatternMarks;
tempMark != NULL;
tempMark = tempMark->next)
{
if (tempMark->where.whichSlotNumber != hack->whichSlot) continue;
extraOffset += ((tempMark->endPosition - tempMark->startPosition) + 1);
}
segmentPtr = (struct multifield *) FactData(theEnv)->CurrentPatternFact->theProposition.theFields[hack->whichSlot].value;
if (segmentPtr->multifieldLength < (hack->minLength + extraOffset))
{ return(FALSE); }
if (hack->exactly && (segmentPtr->multifieldLength > (hack->minLength + extraOffset)))
{ return(FALSE); }
returnValue->value = EnvTrueSymbol(theEnv);
return(TRUE);
}
static CLIPS_BOOLEAN JNSimpleCompareFunction2(
void *theEnv,
void *theValue,
DATA_OBJECT *theResult)
{
INSTANCE_TYPE *ins1,*ins2;
struct multifieldMarker *theMarks;
struct ObjectCmpJoinSingleSlotVars2 *hack;
int rv;
FIELD f1;
INSTANCE_SLOT *is2;
hack = (struct ObjectCmpJoinSingleSlotVars2 *) ValueToBitMap(theValue);
GetPatternObjectAndMarks(theEnv,((int) hack->firstPattern) - 1,&ins1,&theMarks);
GetInsMultiSlotField(&f1,ins1,(unsigned) hack->firstSlot,
(unsigned) hack->fromBeginning,(unsigned) hack->offset);
GetPatternObjectAndMarks(theEnv,((int) hack->secondPattern) - 1,&ins2,&theMarks);
is2 = GetInsSlot(ins2,hack->secondSlot);
if (f1.type != is2->type)
rv = hack->fail;
else if (f1.value != is2->value)
rv = hack->fail;
else
rv = hack->pass;
theResult->type = SYMBOL;
theResult->value = rv ? EnvTrueSymbol(theEnv) : EnvFalseSymbol(theEnv);
return(rv);
}
static intBool JNSimpleCompareFunction1(
void *theEnv,
void *theValue,
DATA_OBJECT *theResult)
{
INSTANCE_TYPE *ins1,*ins2;
struct multifieldMarker *theMarks;
struct ObjectCmpJoinSingleSlotVars1 *hack;
int rv;
INSTANCE_SLOT *is1,*is2;
hack = (struct ObjectCmpJoinSingleSlotVars1 *) ValueToBitMap(theValue);
GetPatternObjectAndMarks(theEnv,((int) hack->firstPattern),hack->firstPatternLHS,hack->firstPatternRHS,&ins1,&theMarks);
is1 = GetInsSlot(ins1,hack->firstSlot);
GetPatternObjectAndMarks(theEnv,((int) hack->secondPattern),hack->secondPatternLHS,hack->secondPatternRHS,&ins2,&theMarks);
is2 = GetInsSlot(ins2,hack->secondSlot);
if (is1->type != is2->type)
rv = hack->fail;
else if (is1->value != is2->value)
rv = hack->fail;
else
rv = hack->pass;
theResult->type = SYMBOL;
theResult->value = rv ? EnvTrueSymbol(theEnv) : EnvFalseSymbol(theEnv);
return(rv);
}
globle void CheckSyntaxFunction(
void *theEnv,
DATA_OBJECT *returnValue)
{
PrintErrorID(theEnv,"PARSEFUN",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function check-syntax does not work in run time modules.\n");
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvTrueSymbol(theEnv));
}
globle int CheckSyntax(
void *theEnv,
const char *theString,
DATA_OBJECT_PTR returnValue)
{
PrintErrorID(theEnv,"PARSEFUN",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function check-syntax does not work in run time modules.\n");
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvTrueSymbol(theEnv));
return(TRUE);
}
/*****************************************************
NAME : ObjectCmpConstantFunction
DESCRIPTION : Used to compare object slot values
against a constant
INPUTS : 1) The constant test bitmap
2) Data object buffer to hold result
RETURNS : TRUE if test successful,
FALSE otherwise
SIDE EFFECTS : Buffer set to symbol TRUE if test
successful, FALSE otherwise
NOTES : Called directly by
EvaluatePatternExpression()
*****************************************************/
globle intBool ObjectCmpConstantFunction(
void *theEnv,
void *theValue,
DATA_OBJECT *theResult)
{
struct ObjectCmpPNConstant *hack;
DATA_OBJECT theVar;
EXPRESSION *constantExp;
int rv;
SEGMENT *theSegment;
hack = (struct ObjectCmpPNConstant *) ValueToBitMap(theValue);
if (hack->general)
{
EvaluateExpression(theEnv,GetFirstArgument(),&theVar);
constantExp = GetFirstArgument()->nextArg;
}
else
{
constantExp = GetFirstArgument();
if (ObjectReteData(theEnv)->CurrentPatternObjectSlot->type == MULTIFIELD)
{
theSegment = (struct multifield *) ObjectReteData(theEnv)->CurrentPatternObjectSlot->value;
if (hack->fromBeginning)
{
theVar.type = theSegment->theFields[hack->offset].type;
theVar.value = theSegment->theFields[hack->offset].value;
}
else
{
theVar.type = theSegment->theFields[theSegment->multifieldLength -
(hack->offset + 1)].type;
theVar.value = theSegment->theFields[theSegment->multifieldLength -
(hack->offset + 1)].value;
}
}
else
{
theVar.type = (unsigned short) ObjectReteData(theEnv)->CurrentPatternObjectSlot->type;
theVar.value = ObjectReteData(theEnv)->CurrentPatternObjectSlot->value;
}
}
if (theVar.type != constantExp->type)
rv = hack->fail;
else if (theVar.value != constantExp->value)
rv = hack->fail;
else
rv = hack->pass;
theResult->type = SYMBOL;
theResult->value = rv ? EnvTrueSymbol(theEnv) : EnvFalseSymbol(theEnv);
return(rv);
}
globle int CheckSyntax(
void *theEnv,
char *theString,
DATA_OBJECT_PTR returnValue)
{
#if (MAC_MCW || IBM_MCW) && (RUN_TIME || BLOAD_ONLY)
#pragma unused(theString)
#pragma unused(returnValue)
#endif
PrintErrorID(theEnv,"PARSEFUN",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function check-syntax does not work in run time modules.\n");
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvTrueSymbol(theEnv));
return(TRUE);
}
/********************************************************************************
NAME : ParseSlotOverrides
DESCRIPTION : Forms expressions for slot-overrides
INPUTS : 1) The logical name of the input
2) Caller's buffer for error flkag
RETURNS : Address override expressions, NULL
if none or error.
SIDE EFFECTS : Slot-expression built
Caller's error flag set
NOTES : <slot-override> ::= (<slot-name> <value>*)*
goes to
<slot-name> --> <dummy-node> --> <slot-name> --> <dummy-node>...
|
V
<value-expression> --> <value-expression> --> ...
Assumes first token has already been scanned
********************************************************************************/
globle EXPRESSION *ParseSlotOverrides(
void *theEnv,
const char *readSource,
int *error)
{
EXPRESSION *top = NULL,*bot = NULL,*theExp;
EXPRESSION *theExpNext;
while (GetType(DefclassData(theEnv)->ObjectParseToken) == LPAREN)
{
*error = FALSE;
theExp = ArgumentParse(theEnv,readSource,error);
if (*error == TRUE)
{
ReturnExpression(theEnv,top);
return(NULL);
}
else if (theExp == NULL)
{
SyntaxErrorMessage(theEnv,"slot-override");
*error = TRUE;
ReturnExpression(theEnv,top);
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
theExpNext = GenConstant(theEnv,SYMBOL,EnvTrueSymbol(theEnv));
if (CollectArguments(theEnv,theExpNext,readSource) == NULL)
{
*error = TRUE;
ReturnExpression(theEnv,top);
ReturnExpression(theEnv,theExp);
return(NULL);
}
theExp->nextArg = theExpNext;
if (top == NULL)
top = theExp;
else
bot->nextArg = theExp;
bot = theExp->nextArg;
PPCRAndIndent(theEnv);
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
}
PPBackup(theEnv);
PPBackup(theEnv);
SavePPBuffer(theEnv,DefclassData(theEnv)->ObjectParseToken.printForm);
return(top);
}
static intBool SlotLengthTestFunction(
void *theEnv,
void *theValue,
DATA_OBJECT *theResult)
{
struct ObjectMatchLength *hack;
theResult->type = SYMBOL;
theResult->value = EnvFalseSymbol(theEnv);
hack = (struct ObjectMatchLength *) ValueToBitMap(theValue);
if (ObjectReteData(theEnv)->CurrentObjectSlotLength < hack->minLength)
return(FALSE);
if (hack->exactly && (ObjectReteData(theEnv)->CurrentObjectSlotLength > hack->minLength))
return(FALSE);
theResult->value = EnvTrueSymbol(theEnv);
return(TRUE);
}
static intBool PNSimpleCompareFunction1(
void *theEnv,
void *theValue,
DATA_OBJECT *theResult)
{
struct ObjectCmpPNSingleSlotVars1 *hack;
INSTANCE_SLOT *is1,*is2;
int rv;
hack = (struct ObjectCmpPNSingleSlotVars1 *) ValueToBitMap(theValue);
is1 = GetInsSlot(ObjectReteData(theEnv)->CurrentPatternObject,hack->firstSlot);
is2 = GetInsSlot(ObjectReteData(theEnv)->CurrentPatternObject,hack->secondSlot);
if (is1->type != is2->type)
rv = hack->fail;
else if (is1->value != is2->value)
rv = hack->fail;
else
rv = hack->pass;
theResult->type = SYMBOL;
theResult->value = rv ? EnvTrueSymbol(theEnv) : EnvFalseSymbol(theEnv);
return(rv);
}
static intBool PNSimpleCompareFunction3(
void *theEnv,
void *theValue,
DATA_OBJECT *theResult)
{
struct ObjectCmpPNSingleSlotVars3 *hack;
int rv;
FIELD f1,f2;
hack = (struct ObjectCmpPNSingleSlotVars3 *) ValueToBitMap(theValue);
GetInsMultiSlotField(&f1,ObjectReteData(theEnv)->CurrentPatternObject,(unsigned) hack->firstSlot,
(unsigned) hack->firstFromBeginning,(unsigned) hack->firstOffset);
GetInsMultiSlotField(&f2,ObjectReteData(theEnv)->CurrentPatternObject,(unsigned) hack->secondSlot,
(unsigned) hack->secondFromBeginning,(unsigned) hack->secondOffset);
if (f1.type != f2.type)
rv = hack->fail;
else if (f1.value != f2.value)
rv = hack->fail;
else
rv = hack->pass;
theResult->type = SYMBOL;
theResult->value = rv ? EnvTrueSymbol(theEnv) : EnvFalseSymbol(theEnv);
return(rv);
}
static CLIPS_BOOLEAN PNSimpleCompareFunction2(
void *theEnv,
void *theValue,
DATA_OBJECT *theResult)
{
struct ObjectCmpPNSingleSlotVars2 *hack;
int rv;
FIELD f1;
INSTANCE_SLOT *is2;
hack = (struct ObjectCmpPNSingleSlotVars2 *) ValueToBitMap(theValue);
GetInsMultiSlotField(&f1,ObjectReteData(theEnv)->CurrentPatternObject,(unsigned) hack->firstSlot,
(unsigned) hack->fromBeginning,(unsigned) hack->offset);
is2 = GetInsSlot(ObjectReteData(theEnv)->CurrentPatternObject,hack->secondSlot);
if (f1.type != is2->type)
rv = hack->fail;
else if (f1.value != is2->value)
rv = hack->fail;
else
rv = hack->pass;
theResult->type = SYMBOL;
theResult->value = rv ? EnvTrueSymbol(theEnv) : EnvFalseSymbol(theEnv);
return(rv);
}
globle int EvaluateExpression(
void *theEnv,
struct expr *problem,
DATA_OBJECT_PTR returnValue)
{
struct expr *oldArgument;
void *oldContext;
struct FunctionDefinition *fptr;
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
if (problem == NULL)
{
returnValue->type = SYMBOL;
returnValue->value = EnvFalseSymbol(theEnv);
return(EvaluationData(theEnv)->EvaluationError);
}
switch (problem->type)
{
case STRING:
case SYMBOL:
case FLOAT:
case INTEGER:
#if OBJECT_SYSTEM
case INSTANCE_NAME:
case INSTANCE_ADDRESS:
#endif
case EXTERNAL_ADDRESS:
returnValue->type = problem->type;
returnValue->value = problem->value;
break;
case DATA_OBJECT_ARRAY: /* TBD Remove with AddPrimitive */
returnValue->type = problem->type;
returnValue->value = problem->value;
break;
case FCALL:
{
fptr = (struct FunctionDefinition *) problem->value;
oldContext = SetEnvironmentFunctionContext(theEnv,fptr->context);
#if PROFILING_FUNCTIONS
StartProfile(theEnv,&profileFrame,
&fptr->usrData,
ProfileFunctionData(theEnv)->ProfileUserFunctions);
#endif
oldArgument = EvaluationData(theEnv)->CurrentExpression;
EvaluationData(theEnv)->CurrentExpression = problem;
switch(fptr->returnValueType)
{
case 'v' :
if (fptr->environmentAware)
{ (* (void (*)(void *)) fptr->functionPointer)(theEnv); }
else
{ (* (void (*)(void)) fptr->functionPointer)(); }
returnValue->type = RVOID;
returnValue->value = EnvFalseSymbol(theEnv);
break;
case 'b' :
returnValue->type = SYMBOL;
if (fptr->environmentAware)
{
if ((* (int (*)(void *)) fptr->functionPointer)(theEnv))
returnValue->value = EnvTrueSymbol(theEnv);
else
returnValue->value = EnvFalseSymbol(theEnv);
}
else
{
if ((* (int (*)(void)) fptr->functionPointer)())
returnValue->value = EnvTrueSymbol(theEnv);
else
returnValue->value = EnvFalseSymbol(theEnv);
}
break;
case 'a' :
returnValue->type = EXTERNAL_ADDRESS;
if (fptr->environmentAware)
{
returnValue->value =
(* (void *(*)(void *)) fptr->functionPointer)(theEnv);
}
else
{
returnValue->value =
(* (void *(*)(void)) fptr->functionPointer)();
}
break;
case 'g' :
returnValue->type = INTEGER;
if (fptr->environmentAware)
{
returnValue->value = (void *)
EnvAddLong(theEnv,(* (long long (*)(void *)) fptr->functionPointer)(theEnv));
}
else
{
returnValue->value = (void *)
EnvAddLong(theEnv,(* (long long (*)(void)) fptr->functionPointer)());
}
break;
case 'i' :
returnValue->type = INTEGER;
if (fptr->environmentAware)
{
returnValue->value = (void *)
EnvAddLong(theEnv,(long long) (* (int (*)(void *)) fptr->functionPointer)(theEnv));
}
else
{
returnValue->value = (void *)
EnvAddLong(theEnv,(long long) (* (int (*)(void)) fptr->functionPointer)());
}
break;
case 'l' :
returnValue->type = INTEGER;
if (fptr->environmentAware)
{
returnValue->value = (void *)
EnvAddLong(theEnv,(long long) (* (long int (*)(void *)) fptr->functionPointer)(theEnv));
}
else
{
returnValue->value = (void *)
EnvAddLong(theEnv,(long long) (* (long int (*)(void)) fptr->functionPointer)());
}
break;
case 'f' :
returnValue->type = FLOAT;
if (fptr->environmentAware)
{
returnValue->value = (void *)
EnvAddDouble(theEnv,(double) (* (float (*)(void *)) fptr->functionPointer)(theEnv));
}
else
{
returnValue->value = (void *)
EnvAddDouble(theEnv,(double) (* (float (*)(void)) fptr->functionPointer)());
}
break;
case 'd' :
returnValue->type = FLOAT;
if (fptr->environmentAware)
{
returnValue->value = (void *)
EnvAddDouble(theEnv,(* (double (*)(void *)) fptr->functionPointer)(theEnv));
}
else
{
returnValue->value = (void *)
EnvAddDouble(theEnv,(* (double (*)(void)) fptr->functionPointer)());
}
break;
case 's' :
returnValue->type = STRING;
if (fptr->environmentAware)
{
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void *)) fptr->functionPointer)(theEnv);
}
else
{
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
}
break;
case 'w' :
returnValue->type = SYMBOL;
if (fptr->environmentAware)
{
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void *)) fptr->functionPointer)(theEnv);
}
else
{
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
}
break;
#if OBJECT_SYSTEM
case 'x' :
returnValue->type = INSTANCE_ADDRESS;
if (fptr->environmentAware)
{
returnValue->value =
(* (void *(*)(void *)) fptr->functionPointer)(theEnv);
}
else
{
returnValue->value =
(* (void *(*)(void)) fptr->functionPointer)();
}
break;
case 'o' :
returnValue->type = INSTANCE_NAME;
if (fptr->environmentAware)
{
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void *)) fptr->functionPointer)(theEnv);
}
else
{
returnValue->value = (void *)
(* (SYMBOL_HN *(*)(void)) fptr->functionPointer)();
}
break;
#endif
case 'c' :
{
char cbuff[2];
if (fptr->environmentAware)
{
cbuff[0] = (* (char (*)(void *)) fptr->functionPointer)(theEnv);
}
else
{
cbuff[0] = (* (char (*)(void)) fptr->functionPointer)();
}
cbuff[1] = EOS;
returnValue->type = SYMBOL;
returnValue->value = (void *) EnvAddSymbol(theEnv,cbuff);
break;
}
case 'j' :
case 'k' :
case 'm' :
case 'n' :
case 'u' :
if (fptr->environmentAware)
{
(* (void (*)(void *,DATA_OBJECT_PTR)) fptr->functionPointer)(theEnv,returnValue);
}
else
{
(* (void (*)(DATA_OBJECT_PTR)) fptr->functionPointer)(returnValue);
}
break;
default :
SystemError(theEnv,"EVALUATN",2);
EnvExitRouter(theEnv,EXIT_FAILURE);
break;
}
#if PROFILING_FUNCTIONS
EndProfile(theEnv,&profileFrame);
#endif
SetEnvironmentFunctionContext(theEnv,oldContext);
EvaluationData(theEnv)->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(theEnv,returnValue,(SYMBOL_HN *) problem->value) == FALSE)
{
PrintErrorID(theEnv,"EVALUATN",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Variable ");
EnvPrintRouter(theEnv,WERROR,ValueToString(problem->value));
EnvPrintRouter(theEnv,WERROR," is unbound\n");
returnValue->type = SYMBOL;
returnValue->value = EnvFalseSymbol(theEnv);
SetEvaluationError(theEnv,TRUE);
}
break;
default:
if (EvaluationData(theEnv)->PrimitivesArray[problem->type] == NULL)
{
SystemError(theEnv,"EVALUATN",3);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
if (EvaluationData(theEnv)->PrimitivesArray[problem->type]->copyToEvaluate)
{
returnValue->type = problem->type;
returnValue->value = problem->value;
break;
}
if (EvaluationData(theEnv)->PrimitivesArray[problem->type]->evaluateFunction == NULL)
{
SystemError(theEnv,"EVALUATN",4);
EnvExitRouter(theEnv,EXIT_FAILURE);
}
oldArgument = EvaluationData(theEnv)->CurrentExpression;
EvaluationData(theEnv)->CurrentExpression = problem;
#if PROFILING_FUNCTIONS
StartProfile(theEnv,&profileFrame,
&EvaluationData(theEnv)->PrimitivesArray[problem->type]->usrData,
ProfileFunctionData(theEnv)->ProfileUserFunctions);
#endif
(*EvaluationData(theEnv)->PrimitivesArray[problem->type]->evaluateFunction)(theEnv,problem->value,returnValue);
#if PROFILING_FUNCTIONS
EndProfile(theEnv,&profileFrame);
#endif
EvaluationData(theEnv)->CurrentExpression = oldArgument;
break;
}
return(EvaluationData(theEnv)->EvaluationError);
}
globle int CheckSyntax(
void *theEnv,
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,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);
}
/****************************************************************************
NAME : ParseSimpleInstance
DESCRIPTION : Parses instances from file for load-instances
into an EXPRESSION forms that
can later be evaluated with EvaluateExpression(theEnv,)
INPUTS : 1) The address of the top node of the expression
containing the make-instance function call
2) The logical name of the input source
RETURNS : The address of the modified expression, or NULL
if there is an error
SIDE EFFECTS : The expression is enhanced to include all
aspects of the make-instance call
(slot-overrides etc.)
The "top" expression is deleted on errors.
NOTES : The name, class, values etc. must be constants.
This function parses a make-instance call into
an expression of the following form :
(make-instance <instance> of <class> <slot-override>*)
where <slot-override> ::= (<slot-name> <expression>+)
goes to -->
make-instance
|
V
<instance-name>-><class-name>-><slot-name>-><dummy-node>...
|
V
<value-expression>...
****************************************************************************/
globle EXPRESSION *ParseSimpleInstance(
void *theEnv,
EXPRESSION *top,
const char *readSource)
{
EXPRESSION *theExp,*vals = NULL,*vbot,*tval;
unsigned short type;
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
if ((GetType(DefclassData(theEnv)->ObjectParseToken) != INSTANCE_NAME) &&
(GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL))
goto MakeInstanceError;
if ((GetType(DefclassData(theEnv)->ObjectParseToken) == SYMBOL) &&
(strcmp(CLASS_RLN,DOToString(DefclassData(theEnv)->ObjectParseToken)) == 0))
{
top->argList = GenConstant(theEnv,FCALL,
(void *) FindFunction(theEnv,"gensym*"));
}
else
{
top->argList = GenConstant(theEnv,INSTANCE_NAME,
(void *) GetValue(DefclassData(theEnv)->ObjectParseToken));
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
if ((GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL) ? TRUE :
(strcmp(CLASS_RLN,DOToString(DefclassData(theEnv)->ObjectParseToken)) != 0))
goto MakeInstanceError;
}
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL)
goto MakeInstanceError;
top->argList->nextArg =
GenConstant(theEnv,SYMBOL,(void *) GetValue(DefclassData(theEnv)->ObjectParseToken));
theExp = top->argList->nextArg;
if (ReplaceClassNameWithReference(theEnv,theExp) == FALSE)
goto MakeInstanceError;
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
while (GetType(DefclassData(theEnv)->ObjectParseToken) == LPAREN)
{
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL)
goto SlotOverrideError;
theExp->nextArg = GenConstant(theEnv,SYMBOL,(void *) GetValue(DefclassData(theEnv)->ObjectParseToken));
theExp->nextArg->nextArg = GenConstant(theEnv,SYMBOL,EnvTrueSymbol(theEnv));
theExp = theExp->nextArg->nextArg;
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
vbot = NULL;
while (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN)
{
type = GetType(DefclassData(theEnv)->ObjectParseToken);
if (type == LPAREN)
{
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
if ((GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL) ? TRUE :
(strcmp(ValueToString(DefclassData(theEnv)->ObjectParseToken.value),"create$") != 0))
goto SlotOverrideError;
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
if (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN)
goto SlotOverrideError;
tval = GenConstant(theEnv,FCALL,(void *) FindFunction(theEnv,"create$"));
}
else
{
if ((type != SYMBOL) && (type != STRING) &&
(type != FLOAT) && (type != INTEGER) && (type != INSTANCE_NAME))
goto SlotOverrideError;
tval = GenConstant(theEnv,type,(void *) GetValue(DefclassData(theEnv)->ObjectParseToken));
}
if (vals == NULL)
vals = tval;
else
vbot->nextArg = tval;
vbot = tval;
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
}
theExp->argList = vals;
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
vals = NULL;
}
if (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN)
goto SlotOverrideError;
return(top);
MakeInstanceError:
SyntaxErrorMessage(theEnv,"make-instance");
SetEvaluationError(theEnv,TRUE);
ReturnExpression(theEnv,top);
return(NULL);
SlotOverrideError:
SyntaxErrorMessage(theEnv,"slot-override");
SetEvaluationError(theEnv,TRUE);
ReturnExpression(theEnv,top);
ReturnExpression(theEnv,vals);
return(NULL);
}
