/***************************************************
NAME : DetermineRestrictionClass
DESCRIPTION : Finds the class of an argument in
the ProcParamArray
INPUTS : The argument data object
RETURNS : The class address, NULL if error
SIDE EFFECTS : EvaluationError set on errors
NOTES : None
***************************************************/
static DEFCLASS *DetermineRestrictionClass(
void *theEnv,
DATA_OBJECT *dobj)
{
INSTANCE_TYPE *ins;
DEFCLASS *cls;
if (dobj->type == INSTANCE_NAME)
{
ins = FindInstanceBySymbol(theEnv,(SYMBOL_HN *) dobj->value);
cls = (ins != NULL) ? ins->cls : NULL;
}
else if (dobj->type == INSTANCE_ADDRESS)
{
ins = (INSTANCE_TYPE *) dobj->value;
cls = (ins->garbage == 0) ? ins->cls : NULL;
}
else
return(DefclassData(theEnv)->PrimitiveClassMap[dobj->type]);
if (cls == NULL)
{
EnvSetEvaluationError(theEnv,true);
PrintErrorID(theEnv,"GENRCEXE",3,false);
EnvPrintRouter(theEnv,WERROR,"Unable to determine class of ");
PrintDataObject(theEnv,WERROR,dobj);
EnvPrintRouter(theEnv,WERROR," in generic function ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) DefgenericData(theEnv)->CurrentGeneric));
EnvPrintRouter(theEnv,WERROR,".\n");
}
return(cls);
}
/***************************************************
NAME : DetermineRestrictionClass
DESCRIPTION : Finds the class of an argument in
the ProcParamArray
INPUTS : The argument data object
RETURNS : The class address, NULL if error
SIDE EFFECTS : EvaluationError set on errors
NOTES : None
***************************************************/
static Defclass *DetermineRestrictionClass(
Environment *theEnv,
UDFValue *dobj)
{
Instance *ins;
Defclass *cls;
if (dobj->header->type == INSTANCE_NAME_TYPE)
{
ins = FindInstanceBySymbol(theEnv,dobj->lexemeValue);
cls = (ins != NULL) ? ins->cls : NULL;
}
else if (dobj->header->type == INSTANCE_ADDRESS_TYPE)
{
ins = dobj->instanceValue;
cls = (ins->garbage == 0) ? ins->cls : NULL;
}
else
return(DefclassData(theEnv)->PrimitiveClassMap[dobj->header->type]);
if (cls == NULL)
{
SetEvaluationError(theEnv,true);
PrintErrorID(theEnv,"GENRCEXE",3,false);
WriteString(theEnv,STDERR,"Unable to determine class of ");
WriteUDFValue(theEnv,STDERR,dobj);
WriteString(theEnv,STDERR," in generic function '");
WriteString(theEnv,STDERR,DefgenericName(DefgenericData(theEnv)->CurrentGeneric));
WriteString(theEnv,STDERR,"'.\n");
}
return(cls);
}
/**********************************************************************
NAME : CheckMultifieldSlotInstance
DESCRIPTION : Gets the instance for the functions slot-replace$,
insert and delete
INPUTS : The function name
RETURNS : The instance address, NULL on errors
SIDE EFFECTS : None
NOTES : None
**********************************************************************/
static INSTANCE_TYPE *CheckMultifieldSlotInstance(
void *theEnv,
char *func)
{
INSTANCE_TYPE *ins;
DATA_OBJECT temp;
if (EnvArgTypeCheck(theEnv,func,1,INSTANCE_OR_INSTANCE_NAME,&temp) == FALSE)
{
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
if (temp.type == INSTANCE_ADDRESS)
{
ins = (INSTANCE_TYPE *) temp.value;
if (ins->garbage == 1)
{
StaleInstanceAddress(theEnv,func,0);
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
}
else
{
ins = FindInstanceBySymbol(theEnv,(SYMBOL_HN *) temp.value);
if (ins == NULL)
NoInstanceError(theEnv,ValueToString(temp.value),func);
}
return(ins);
}
globle intBool CheckAllowedClassesConstraint(
void *theEnv,
int type,
void *vPtr,
CONSTRAINT_RECORD *constraints)
{
#if OBJECT_SYSTEM
struct expr *tmpPtr;
INSTANCE_TYPE *ins;
DEFCLASS *insClass, *cmpClass;
/*=========================================*/
/* If the constraint record is NULL, there */
/* is no allowed-classes restriction. */
/*=========================================*/
if (constraints == NULL) return(TRUE);
/*======================================*/
/* The constraint is satisfied if there */
/* aren't any class restrictions. */
/*======================================*/
if (constraints->classList == NULL)
{ return(TRUE); }
/*==================================*/
/* Class restrictions only apply to */
/* instances and instance names. */
/*==================================*/
if ((type != INSTANCE_ADDRESS) && (type != INSTANCE_NAME))
{ return(TRUE); }
/*=============================================*/
/* If an instance name is specified, determine */
/* whether the instance exists. */
/*=============================================*/
if (type == INSTANCE_ADDRESS)
{ ins = (INSTANCE_TYPE *) vPtr; }
else
{ ins = FindInstanceBySymbol(theEnv,(SYMBOL_HN *) vPtr); }
if (ins == NULL)
{ return(FALSE); }
/*======================================================*/
/* Search through the class list to see if the instance */
/* belongs to one of the allowed classes in the list. */
/*======================================================*/
insClass = (DEFCLASS *) EnvGetInstanceClass(theEnv,ins);
for (tmpPtr = constraints->classList;
tmpPtr != NULL;
tmpPtr = tmpPtr->nextArg)
{
cmpClass = (DEFCLASS *) EnvFindDefclass(theEnv,ValueToString(tmpPtr->value));
if (cmpClass == NULL) continue;
if (cmpClass == insClass) return(TRUE);
if (EnvSubclassP(theEnv,insClass,cmpClass)) return(TRUE);
}
/*=========================================================*/
/* If a parent class wasn't found in the list, then return */
/* FALSE because the constraint has been violated. */
/*=========================================================*/
return(FALSE);
#else
#if MAC_XCD
#pragma unused(theEnv)
#pragma unused(type)
#pragma unused(vPtr)
#pragma unused(constraints)
#endif
return(TRUE);
#endif
}
void *GetFactOrInstanceArgument(
void *theEnv,
int thePosition,
DATA_OBJECT *item,
char *functionName)
{
#if DEFTEMPLATE_CONSTRUCT || OBJECT_SYSTEM
void *ptr;
#endif
/*==============================*/
/* Retrieve the first argument. */
/*==============================*/
EnvRtnUnknown(theEnv,thePosition,item);
/*==================================================*/
/* Fact and instance addresses are valid arguments. */
/*==================================================*/
if ((GetpType(item) == FACT_ADDRESS) ||
(GetpType(item) == INSTANCE_ADDRESS))
{ return(GetpValue(item)); }
/*==================================================*/
/* An integer is a valid argument if it corresponds */
/* to the fact index of an existing fact. */
/*==================================================*/
#if DEFTEMPLATE_CONSTRUCT
else if (GetpType(item) == INTEGER)
{
if ((ptr = (void *) FindIndexedFact(theEnv,DOPToLong(item))) == NULL)
{
char tempBuffer[20];
sprintf(tempBuffer,"f-%ld",DOPToLong(item));
CantFindItemErrorMessage(theEnv,"fact",tempBuffer);
}
return(ptr);
}
#endif
/*================================================*/
/* Instance names and symbols are valid arguments */
/* if they correspond to an existing instance. */
/*================================================*/
#if OBJECT_SYSTEM
else if ((GetpType(item) == INSTANCE_NAME) || (GetpType(item) == SYMBOL))
{
if ((ptr = (void *) FindInstanceBySymbol(theEnv,(SYMBOL_HN *) GetpValue(item))) == NULL)
{
CantFindItemErrorMessage(theEnv,"instance",ValueToString(GetpValue(item)));
}
return(ptr);
}
#endif
/*========================================*/
/* Any other type is an invalid argument. */
/*========================================*/
ExpectedTypeError2(theEnv,functionName,thePosition);
return(NULL);
}
/*****************************************************
NAME : PerformMessage
DESCRIPTION : Calls core framework for a message
INPUTS : 1) Caller's result buffer
2) Message argument expressions
(including implicit object)
3) Message name
RETURNS : Nothing useful
SIDE EFFECTS : Any side-effects of message execution
and caller's result buffer set
NOTES : None
*****************************************************/
static void PerformMessage(
DATA_OBJECT *result,
EXPRESSION *args,
SYMBOL_HN *mname)
{
int oldce;
HANDLER_LINK *oldCore;
DEFCLASS *cls = NULL;
INSTANCE_TYPE *ins = NULL;
SYMBOL_HN *oldName;
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
result->type = SYMBOL;
result->value = FalseSymbol;
EvaluationError = FALSE;
if (HaltExecution)
return;
oldce = ExecutingConstruct();
SetExecutingConstruct(TRUE);
oldName = CurrentMessageName;
CurrentMessageName = mname;
CurrentEvaluationDepth++;
PushProcParameters(args,CountArguments(args),
ValueToString(CurrentMessageName),"message",
UnboundHandlerErr);
if (EvaluationError)
{
CurrentEvaluationDepth--;
CurrentMessageName = oldName;
PeriodicCleanup(FALSE,TRUE);
SetExecutingConstruct(oldce);
return;
}
if (ProcParamArray->type == INSTANCE_ADDRESS)
{
ins = (INSTANCE_TYPE *) ProcParamArray->value;
if (ins->garbage == 1)
{
StaleInstanceAddress("send",0);
SetEvaluationError(TRUE);
}
else if (DefclassInScope(ins->cls,(struct defmodule *) GetCurrentModule()) == FALSE)
NoInstanceError(ValueToString(ins->name),"send");
else
{
cls = ins->cls;
ins->busy++;
}
}
else if (ProcParamArray->type == INSTANCE_NAME)
{
ins = FindInstanceBySymbol((SYMBOL_HN *) ProcParamArray->value);
if (ins == NULL)
{
PrintErrorID("MSGPASS",2,FALSE);
PrintRouter(WERROR,"No such instance ");
PrintRouter(WERROR,ValueToString((SYMBOL_HN *) ProcParamArray->value));
PrintRouter(WERROR," in function send.\n");
SetEvaluationError(TRUE);
}
else
{
ProcParamArray->value = (void *) ins;
ProcParamArray->type = INSTANCE_ADDRESS;
cls = ins->cls;
ins->busy++;
}
}
else if ((cls = PrimitiveClassMap[ProcParamArray->type]) == NULL)
{
SystemError("MSGPASS",1);
ExitRouter(EXIT_FAILURE);
}
if (EvaluationError)
{
PopProcParameters();
CurrentEvaluationDepth--;
CurrentMessageName = oldName;
PeriodicCleanup(FALSE,TRUE);
SetExecutingConstruct(oldce);
return;
}
oldCore = TopOfCore;
TopOfCore = FindApplicableHandlers(cls,mname);
if (TopOfCore != NULL)
{
HANDLER_LINK *oldCurrent,*oldNext;
oldCurrent = CurrentCore;
oldNext = NextInCore;
#if IMPERATIVE_MESSAGE_HANDLERS
if (TopOfCore->hnd->type == MAROUND)
{
CurrentCore = TopOfCore;
NextInCore = TopOfCore->nxt;
#if DEBUGGING_FUNCTIONS
if (WatchMessages)
WatchMessage(WTRACE,BEGIN_TRACE);
if (CurrentCore->hnd->trace)
WatchHandler(WTRACE,CurrentCore,BEGIN_TRACE);
#endif
if (CheckHandlerArgCount())
{
#if PROFILING_FUNCTIONS
StartProfile(&profileFrame,
&CurrentCore->hnd->usrData,
ProfileConstructs);
#endif
EvaluateProcActions(CurrentCore->hnd->cls->header.whichModule->theModule,
CurrentCore->hnd->actions,
CurrentCore->hnd->localVarCount,
result,UnboundHandlerErr);
#if PROFILING_FUNCTIONS
EndProfile(&profileFrame);
#endif
}
#if DEBUGGING_FUNCTIONS
if (CurrentCore->hnd->trace)
WatchHandler(WTRACE,CurrentCore,END_TRACE);
if (WatchMessages)
WatchMessage(WTRACE,END_TRACE);
#endif
}
else
#endif /* IMPERATIVE_MESSAGE_HANDLERS */
{
CurrentCore = NULL;
NextInCore = TopOfCore;
#if DEBUGGING_FUNCTIONS
if (WatchMessages)
WatchMessage(WTRACE,BEGIN_TRACE);
#endif
CallHandlers(result);
#if DEBUGGING_FUNCTIONS
if (WatchMessages)
WatchMessage(WTRACE,END_TRACE);
#endif
}
DestroyHandlerLinks(TopOfCore);
CurrentCore = oldCurrent;
NextInCore = oldNext;
}
TopOfCore = oldCore;
ReturnFlag = FALSE;
if (ins != NULL)
ins->busy--;
/* ==================================
Restore the original calling frame
================================== */
PopProcParameters();
CurrentEvaluationDepth--;
CurrentMessageName = oldName;
PropagateReturnValue(result);
PeriodicCleanup(FALSE,TRUE);
SetExecutingConstruct(oldce);
if (EvaluationError)
{
result->type = SYMBOL;
result->value = FalseSymbol;
}
}
void *GetFactOrInstanceArgument(
UDFContext *context,
unsigned int thePosition,
UDFValue *item)
{
Environment *theEnv = context->environment;
#if DEFTEMPLATE_CONSTRUCT || OBJECT_SYSTEM
void *ptr;
#endif
/*==============================*/
/* Retrieve the first argument. */
/*==============================*/
UDFNthArgument(context,thePosition,ANY_TYPE_BITS,item);
/*==================================================*/
/* Fact and instance addresses are valid arguments. */
/*==================================================*/
if (CVIsType(item,FACT_ADDRESS_BIT))
{
if (item->factValue->garbage)
{
FactRetractedErrorMessage(theEnv,item->factValue);
return NULL;
}
return item->value;
}
else if (CVIsType(item,INSTANCE_ADDRESS_BIT))
{
if (item->instanceValue->garbage)
{
CantFindItemErrorMessage(theEnv,"instance",item->instanceValue->name->contents,false);
return NULL;
}
return item->value;
}
/*==================================================*/
/* An integer is a valid argument if it corresponds */
/* to the fact index of an existing fact. */
/*==================================================*/
#if DEFTEMPLATE_CONSTRUCT
else if (item->header->type == INTEGER_TYPE)
{
if ((ptr = (void *) FindIndexedFact(theEnv,item->integerValue->contents)) == NULL)
{
char tempBuffer[20];
gensprintf(tempBuffer,"f-%lld",item->integerValue->contents);
CantFindItemErrorMessage(theEnv,"fact",tempBuffer,false);
}
return ptr;
}
#endif
/*================================================*/
/* Instance names and symbols are valid arguments */
/* if they correspond to an existing instance. */
/*================================================*/
#if OBJECT_SYSTEM
else if (CVIsType(item,INSTANCE_NAME_BIT | SYMBOL_BIT))
{
if ((ptr = (void *) FindInstanceBySymbol(theEnv,item->lexemeValue)) == NULL)
{
CantFindItemErrorMessage(theEnv,"instance",item->lexemeValue->contents,false);
}
return ptr;
}
#endif
/*========================================*/
/* Any other type is an invalid argument. */
/*========================================*/
ExpectedTypeError2(theEnv,UDFContextFunctionName(context),thePosition);
return NULL;
}