/*************************************************** 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; }