inscom.c

clips源代码

                   instances in all modules
  INPUTS       : None
  RETURNS      : The instance count
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
globle unsigned long GetGlobalNumberOfInstances(
  void *theEnv)
  {
   return(InstanceData(theEnv)->GlobalNumberOfInstances);
  }

/***************************************************
  NAME         : EnvGetNextInstance
  DESCRIPTION  : Returns next instance in list
                 (or first instance in list)
  INPUTS       : Pointer to previous instance
                 (or NULL to get first instance)
  RETURNS      : The next instance or first instance
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
globle void *EnvGetNextInstance(
  void *theEnv,
  void *iptr)
  {
   if (iptr == NULL)
     return((void *) InstanceData(theEnv)->InstanceList);
   if (((INSTANCE_TYPE *) iptr)->garbage == 1)
     return(NULL);
   return((void *) ((INSTANCE_TYPE *) iptr)->nxtList);
  }

/***************************************************
  NAME         : GetNextInstanceInScope
  DESCRIPTION  : Returns next instance in list
                 (or first instance in list)
                 which class is in scope
  INPUTS       : Pointer to previous instance
                 (or NULL to get first instance)
  RETURNS      : The next instance or first instance
                 which class is in scope of the
                 current module
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
globle void *GetNextInstanceInScope(
  void *theEnv,
  void *iptr)
  {
   INSTANCE_TYPE *ins = (INSTANCE_TYPE *) iptr;

   if (ins == NULL)
     ins = InstanceData(theEnv)->InstanceList;
   else if (ins->garbage)
     return(NULL);
   else
     ins = ins->nxtList;
   while (ins != NULL)
     {
      if (DefclassInScope(theEnv,ins->cls,NULL))
        return((void *) ins);
      ins = ins->nxtList;
     }
   return(NULL);
  }

/***************************************************
  NAME         : EnvGetNextInstanceInClass
  DESCRIPTION  : Finds next instance of class
                 (or first instance of class)
  INPUTS       : 1) Class address
                 2) Instance address
                    (NULL to get first instance)
  RETURNS      : The next or first class instance
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
#if IBM_TBC
#pragma argsused
#endif
globle void *EnvGetNextInstanceInClass(
  void *theEnv,
  void *cptr,
  void *iptr)
  {
#if MAC_MCW || IBM_MCW || MAC_XCD
#pragma unused(theEnv)
#endif

   if (iptr == NULL)
     return((void *) ((DEFCLASS *) cptr)->instanceList);
   if (((INSTANCE_TYPE *) iptr)->garbage == 1)
     return(NULL);
   return((void *) ((INSTANCE_TYPE *) iptr)->nxtClass);
  }

/***************************************************
  NAME         : EnvGetNextInstanceInClassAndSubclasses
  DESCRIPTION  : Finds next instance of class
                 (or first instance of class) and
                 all of its subclasses
  INPUTS       : 1) Class address
                 2) Instance address
                    (NULL to get first instance)
  RETURNS      : The next or first class instance
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
globle void *EnvGetNextInstanceInClassAndSubclasses(
  void *theEnv,
  void **cptr,
  void *iptr,
  DATA_OBJECT *iterationInfo)
  {
   INSTANCE_TYPE *nextInstance;
   DEFCLASS *theClass;
   
   theClass = (DEFCLASS *) *cptr;
   
   if (iptr == NULL)
     {
      ClassSubclassAddresses(theEnv,theClass,iterationInfo,TRUE);
      nextInstance = theClass->instanceList;
     }
   else if (((INSTANCE_TYPE *) iptr)->garbage == 1)
     { nextInstance = NULL; }
   else
     { nextInstance = ((INSTANCE_TYPE *) iptr)->nxtClass; }
     
   while ((nextInstance == NULL) && 
          (GetpDOBegin(iterationInfo) <= GetpDOEnd(iterationInfo)))
     {
      theClass = (struct defclass *) GetMFValue(DOPToPointer(iterationInfo),
                                                GetpDOBegin(iterationInfo));
      *cptr = theClass;
      SetpDOBegin(iterationInfo,GetpDOBegin(iterationInfo) + 1);
      nextInstance = theClass->instanceList;
     }
          
   return(nextInstance);
  }
  
/***************************************************
  NAME         : EnvGetInstancePPForm
  DESCRIPTION  : Writes slot names and values to
                  caller's buffer
  INPUTS       : 1) Caller's buffer
                 2) Size of buffer (not including
                    space for terminating '\0')
                 3) Instance address
  RETURNS      : Nothing useful
  SIDE EFFECTS : Caller's buffer written
  NOTES        : None
 ***************************************************/
globle void EnvGetInstancePPForm(
  void *theEnv,
  char *buf,
  unsigned buflen,
  void *iptr)
  {
   char *pbuf = "***InstancePPForm***";

   if (((INSTANCE_TYPE *) iptr)->garbage == 1)
     return;
   if (OpenStringDestination(theEnv,pbuf,buf,buflen+1) == 0)
     return;
   PrintInstance(theEnv,pbuf,(INSTANCE_TYPE *) iptr," ");
   CloseStringDestination(theEnv,pbuf);
  }

/*********************************************************
  NAME         : ClassCommand
  DESCRIPTION  : Returns the class of an instance
  INPUTS       : Caller's result buffer
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : H/L Syntax : (class <object>)
                 Can also be called by (type <object>)
                   if you have generic functions installed
 *********************************************************/
globle void ClassCommand(
  void *theEnv,
  DATA_OBJECT *result)
  {
   INSTANCE_TYPE *ins;
   char *func;
   DATA_OBJECT temp;

   func = ValueToString(((struct FunctionDefinition *)
                       EvaluationData(theEnv)->CurrentExpression->value)->callFunctionName);
   result->type = SYMBOL;
   result->value = EnvFalseSymbol(theEnv);
   EvaluateExpression(theEnv,GetFirstArgument(),&temp);
   if (temp.type == INSTANCE_ADDRESS)
     {
      ins = (INSTANCE_TYPE *) temp.value;
      if (ins->garbage == 1)
        {
         StaleInstanceAddress(theEnv,func,0);
         SetEvaluationError(theEnv,TRUE);
         return;
        }
      result->value = (void *) GetDefclassNamePointer((void *) ins->cls);
     }
   else if (temp.type == INSTANCE_NAME)
     {
      ins = FindInstanceBySymbol(theEnv,(SYMBOL_HN *) temp.value);
      if (ins == NULL)
        {
         NoInstanceError(theEnv,ValueToString(temp.value),func);
         return;
        }
      result->value = (void *) GetDefclassNamePointer((void *) ins->cls);
     }
   else
     {
      switch (temp.type)
        {
         case INTEGER          :
         case FLOAT            :
         case SYMBOL           :
         case STRING           :
         case MULTIFIELD       :
         case EXTERNAL_ADDRESS :
         case FACT_ADDRESS     :
                          result->value = (void *)
                                           GetDefclassNamePointer((void *)
                                            DefclassData(theEnv)->PrimitiveClassMap[temp.type]);
                         return;
         default       : PrintErrorID(theEnv,"INSCOM",1,FALSE);
                         EnvPrintRouter(theEnv,WERROR,"Undefined type in function ");
                         EnvPrintRouter(theEnv,WERROR,func);
                         EnvPrintRouter(theEnv,WERROR,".\n");
                         SetEvaluationError(theEnv,TRUE);
        }
     }
  }
  
/******************************************************
  NAME         : CreateInstanceHandler
  DESCRIPTION  : Message handler called after instance creation
  INPUTS       : None
  RETURNS      : TRUE if successful,
                 FALSE otherwise
  SIDE EFFECTS : None
  NOTES        : Does nothing. Provided so it can be overridden.
 ******************************************************/
#if IBM_TBC
#pragma argsused
#endif
globle intBool CreateInstanceHandler(
  void *theEnv)
  {
#if MAC_MCW || IBM_MCW || MAC_XCD
#pragma unused(theEnv)
#endif

   return(TRUE);
  }

/******************************************************
  NAME         : DeleteInstanceCommand
  DESCRIPTION  : Removes a named instance from the
                   hash table and its class's
                   instance list
  INPUTS       : None
  RETURNS      : TRUE if successful,
                 FALSE otherwise
  SIDE EFFECTS : Instance is deallocated
  NOTES        : This is an internal function that
                   only be called by a handler
 ******************************************************/
globle intBool DeleteInstanceCommand(
  void *theEnv)
  {
   if (CheckCurrentMessage(theEnv,"delete-instance",TRUE))
     return(QuashInstance(theEnv,GetActiveInstance(theEnv)));
   return(FALSE);
  }

/********************************************************************
  NAME         : UnmakeInstanceCommand
  DESCRIPTION  : Uses message-passing to delete the
                   specified instance
  INPUTS       : None
  RETURNS      : TRUE if successful, FALSE otherwise
  SIDE EFFECTS : Instance is deallocated
  NOTES        : Syntax: (unmake-instance <instance-expression>+ | *)
 ********************************************************************/
globle intBool UnmakeInstanceCommand(
  void *theEnv)
  {
   EXPRESSION *theArgument;
   DATA_OBJECT theResult;
   INSTANCE_TYPE *ins;
   int argNumber = 1,rtn = TRUE;

   theArgument = GetFirstArgument();
   while (theArgument != NULL)
     {
      EvaluateExpression(theEnv,theArgument,&theResult);
      if ((theResult.type == INSTANCE_NAME) || (theResult.type == SYMBOL))
        {
         ins = FindInstanceBySymbol(theEnv,(SYMBOL_HN *) theResult.value);
         if ((ins == NULL) ? (strcmp(DOToString(theResult),"*") != 0) : FALSE)
           {
            NoInstanceError(theEnv,DOToString(theResult),"unmake-instance");
            return(FALSE);
           }
         }
      else if (theResult.type == INSTANCE_ADDRESS)
        {
         ins = (INSTANCE_TYPE *) theResult.value;
         if (ins->garbage)
           {
            StaleInstanceAddress(theEnv,"unmake-instance",0);
            SetEvaluationError(theEnv,TRUE);
            return(FALSE);
           }
        }
      else
        {
         ExpectedTypeError1(theEnv,"unmake-instance",argNumber,"instance-address, instance-name, or the symbol *");
         SetEvaluationError(theEnv,TRUE);
         return(FALSE);
        }
      if (EnvUnmakeInstance(theEnv,ins) == FALSE)
        rtn = FALSE;
      if (ins == NULL)
        return(rtn);
      argNumber++;
      theArgument = GetNextArgument(theArgument);
     }
   return(rtn);
  }

/*****************************************************************
  NAME         : SymbolToInstanceName
  DESCRIPTION  : Converts a symbol from type SYMBOL
                   to type INSTANCE_NAME
  INPUTS       : The address of the value buffer
  RETURNS      : The new INSTANCE_NAME symbol
  SIDE EFFECTS : None
  NOTES        : H/L Syntax : (symbol-to-instance-name <symbol>)
 *****************************************************************/
globle void SymbolToInstanceName(
  void *theEnv,
  DATA_OBJECT *result)
  {
   if (EnvArgTypeCheck(theEnv,"symbol-to-instance-name",1,SYMBOL,result) == FALSE)
     {
      SetpType(result,SYMBOL);
      SetpValue(result,EnvFalseSymbol(theEnv));
      return;
     }
   SetpType(result,INSTANCE_NAME);
  }

/*****************************************************************
  NAME         : InstanceNameToSymbol
  DESCRIPTION  : Converts a symbol from type INSTANCE_NAME
                   to type SYMBOL
  INPUTS       : None
  RETURNS      : Symbol FALSE on errors - or converted instance name
  SIDE EFFECTS : None
  NOTES        : H/L Syntax : (instance-name-to-symbol <iname>)
 *****************************************************************/
globle void *InstanceNameToSymbol(
  void *theEnv)
  {
   DATA_OBJECT result;

   if (EnvArgTypeCheck(theEnv,"instance-name-to-symbol",1,INSTANCE_NAME,&result) == FALSE)
     return((SYMBOL_HN *) EnvFalseSymbol(theEnv));
   return((SYMBOL_HN *) result.value);
  }

/*********************************************************************************
  NAME         : InstanceAddressCommand
  DESCRIPTION  : Returns the address of an instance
  INPUTS       : The address of the value buffer
  RETURNS      : Nothing useful
  SIDE EFFECTS : Stores instance address in caller's buffer
  NOTES        : H/L Syntax : (instance-address [<module-name>] <instance-name>)
 *********************************************************************************/
globle void InstanceAddressCommand(
  void *theEnv,
  DATA_OBJECT *result)
  {
   INSTANCE_TYPE *ins;
   DATA_OBJECT temp;
   struct defmodule *theModule;
   unsigned searchImports;

   result->type = SYMBOL;
   result->value = EnvFalseSymbol(theEnv);
   if (EnvRtnArgCount(theEnv) > 1)
     {
      if (EnvArgTypeCheck(theEnv,"instance-address",1,SYMBOL,&temp) == FALSE)