Ejemplo n.º 1
0
/***************************************************
  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);
  }
Ejemplo n.º 2
0
/***************************************************
  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);
  }
Ejemplo n.º 3
0
/**********************************************************************
  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);
  }
Ejemplo n.º 4
0
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     
  }
Ejemplo n.º 5
0
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);
  }
Ejemplo n.º 6
0
/*****************************************************
  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;
     }
  }
Ejemplo n.º 7
0
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;
  }