inscom.c

clips源代码

   if (argno > 0)
     {
      if (EnvArgTypeCheck(theEnv,"instances",1,SYMBOL,&temp) == FALSE)
        return;
      theDefmodule = EnvFindDefmodule(theEnv,DOToString(temp));
      if ((theDefmodule != NULL) ? FALSE :
          (strcmp(DOToString(temp),"*") != 0))
        {
         SetEvaluationError(theEnv,TRUE);
         ExpectedTypeError1(theEnv,"instances",1,"defmodule name");
         return;
        }
      if (argno > 1)
        {
         if (EnvArgTypeCheck(theEnv,"instances",2,SYMBOL,&temp) == FALSE)
           return;
         className = DOToString(temp);
         if (LookupDefclassAnywhere(theEnv,(struct defmodule *) theDefmodule,className) == NULL)
           {
            if (strcmp(className,"*") == 0)
              className = NULL;
            else
              {
               ClassExistError(theEnv,"instances",className);
                 return;
              }
           }
         if (argno > 2)
           {
            if (EnvArgTypeCheck(theEnv,"instances",3,SYMBOL,&temp) == FALSE)
              return;
            if (strcmp(DOToString(temp),ALL_QUALIFIER) != 0)
              {
               SetEvaluationError(theEnv,TRUE);
               ExpectedTypeError1(theEnv,"instances",3,"keyword \"inherit\"");
               return;
              }
            inheritFlag = TRUE;
           }
        }
     }
   EnvInstances(theEnv,WDISPLAY,theDefmodule,className,inheritFlag);
  }

/********************************************************
  NAME         : PPInstanceCommand
  DESCRIPTION  : Displays the current slot-values
                   of an instance
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : H/L Syntax : (ppinstance <instance>)
 ********************************************************/
globle void PPInstanceCommand(
  void *theEnv)
  {
   INSTANCE_TYPE *ins;

   if (CheckCurrentMessage(theEnv,"ppinstance",TRUE) == FALSE)
     return;
   ins = GetActiveInstance(theEnv);
   if (ins->garbage == 1)
     return;
   PrintInstance(theEnv,WDISPLAY,ins,"\n");
   EnvPrintRouter(theEnv,WDISPLAY,"\n");
  }

/***************************************************************
  NAME         : EnvInstances
  DESCRIPTION  : Lists instances of classes
  INPUTS       : 1) The logical name for the output
                 2) Address of the module (NULL for all classes)
                 3) Name of the class
                    (NULL for all classes in specified module)
                 4) A flag indicating whether to print instances
                    of subclasses or not
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : None
 **************************************************************/
globle void EnvInstances(
  void *theEnv,
  char *logicalName,
  void *theVModule,
  char *className,
  int inheritFlag)
  {
   int id;
   struct defmodule *theModule;
   long count = 0L;

   /* ===========================================
      Grab a traversal id to avoid printing out
      instances twice due to multiple inheritance
      =========================================== */
  if ((id = GetTraversalID(theEnv)) == -1)
    return;
  SaveCurrentModule(theEnv);

   /* ====================================
      For all modules, print out instances
      of specified class(es)
      ==================================== */
   if (theVModule == NULL)
     {
      theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,NULL);
      while (theModule != NULL)
        {
         if (GetHaltExecution(theEnv) == TRUE)
           {
            RestoreCurrentModule(theEnv);
            ReleaseTraversalID(theEnv);
            return;
           }

         EnvPrintRouter(theEnv,logicalName,EnvGetDefmoduleName(theEnv,(void *) theModule));
         EnvPrintRouter(theEnv,logicalName,":\n");
         EnvSetCurrentModule(theEnv,(void *) theModule);
         count += ListInstancesInModule(theEnv,id,logicalName,className,inheritFlag,TRUE);
         theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,(void *) theModule);
        }
     }

   /* ====================================
      For the specified module, print out
      instances of the specified class(es)
      ==================================== */
   else
     {
      EnvSetCurrentModule(theEnv,(void *) theVModule);
      count = ListInstancesInModule(theEnv,id,logicalName,className,inheritFlag,FALSE);
     }

   RestoreCurrentModule(theEnv);
   ReleaseTraversalID(theEnv);
   if (EvaluationData(theEnv)->HaltExecution == FALSE)
     PrintTally(theEnv,logicalName,count,"instance","instances");
  }

#endif

/*********************************************************
  NAME         : EnvMakeInstance
  DESCRIPTION  : C Interface for creating and
                   initializing a class instance
  INPUTS       : The make-instance call string,
                    e.g. "([bill] of man (age 34))"
  RETURNS      : The instance address if instance created,
                    NULL otherwise
  SIDE EFFECTS : Creates the instance and returns
                    the result in caller's buffer
  NOTES        : None
 *********************************************************/
globle void *EnvMakeInstance(
  void *theEnv,
  char *mkstr)
  {
   char *router = "***MKINS***";
   struct token tkn;
   EXPRESSION *top;
   DATA_OBJECT result;

   result.type = SYMBOL;
   result.value = EnvFalseSymbol(theEnv);
   if (OpenStringSource(theEnv,router,mkstr,0) == 0)
     return(NULL);
   GetToken(theEnv,router,&tkn);
   if (tkn.type == LPAREN)
     {
      top = GenConstant(theEnv,FCALL,(void *) FindFunction(theEnv,"make-instance"));
      if (ParseSimpleInstance(theEnv,top,router) != NULL)
        {
         GetToken(theEnv,router,&tkn);
         if (tkn.type == STOP)
           {
            ExpressionInstall(theEnv,top);
            EvaluateExpression(theEnv,top,&result);
            ExpressionDeinstall(theEnv,top);
           }
         else
           SyntaxErrorMessage(theEnv,"instance definition");
         ReturnExpression(theEnv,top);
        }
     }
   else
     SyntaxErrorMessage(theEnv,"instance definition");
   CloseStringSource(theEnv,router);

   if ((EvaluationData(theEnv)->CurrentEvaluationDepth == 0) && (! CommandLineData(theEnv)->EvaluatingTopLevelCommand) &&
       (EvaluationData(theEnv)->CurrentExpression == NULL))
     { PeriodicCleanup(theEnv,TRUE,FALSE); }

   if ((result.type == SYMBOL) && (result.value == EnvFalseSymbol(theEnv)))
     return(NULL);

   return((void *) FindInstanceBySymbol(theEnv,(SYMBOL_HN *) result.value));
  }

/***************************************************************
  NAME         : EnvCreateRawInstance
  DESCRIPTION  : Creates an empty of instance of the specified
                   class.  No slot-overrides or class defaults
                   are applied.
  INPUTS       : 1) Address of class
                 2) Name of the new instance
  RETURNS      : The instance address if instance created,
                    NULL otherwise
  SIDE EFFECTS : Old instance of same name deleted (if possible)
  NOTES        : None
 ***************************************************************/
globle void *EnvCreateRawInstance(
  void *theEnv,
  void *cptr,
  char *iname)
  {
   return((void *) BuildInstance(theEnv,(SYMBOL_HN *) EnvAddSymbol(theEnv,iname),(DEFCLASS *) cptr,FALSE));
  }

/***************************************************************************
  NAME         : EnvFindInstance
  DESCRIPTION  : Looks up a specified instance in the instance hash table
  INPUTS       : Name-string of the instance
  RETURNS      : The address of the found instance, NULL otherwise
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************************************/
globle void *EnvFindInstance(
  void *theEnv,
  void *theModule,
  char *iname,
  unsigned searchImports)
  {
   SYMBOL_HN *isym;

   isym = FindSymbolHN(theEnv,iname);
   if (isym == NULL)
     return(NULL);
   if (theModule == NULL)
     theModule = (void *) EnvGetCurrentModule(theEnv);
   return((void *) FindInstanceInModule(theEnv,isym,(struct defmodule *) theModule,
                                        ((struct defmodule *) EnvGetCurrentModule(theEnv)),searchImports));
  }

/***************************************************************************
  NAME         : EnvValidInstanceAddress
  DESCRIPTION  : Determines if an instance address is still valid
  INPUTS       : Instance address
  RETURNS      : 1 if the address is still valid, 0 otherwise
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************************************/
#if IBM_TBC
#pragma argsused
#endif
globle int EnvValidInstanceAddress(
  void *theEnv,
  void *iptr)
  {
#if MAC_MCW || IBM_MCW || MAC_XCD
#pragma unused(theEnv)
#endif

   return((((INSTANCE_TYPE *) iptr)->garbage == 0) ? 1 : 0);
  }

/***************************************************
  NAME         : EnvDirectGetSlot
  DESCRIPTION  : Gets a slot value
  INPUTS       : 1) Instance address
                 2) Slot name
                 3) Caller's result buffer
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
globle void EnvDirectGetSlot(
  void *theEnv,
  void *ins,
  char *sname,
  DATA_OBJECT *result)
  {
   INSTANCE_SLOT *sp;

   if (((INSTANCE_TYPE *) ins)->garbage == 1)
     {
      SetEvaluationError(theEnv,TRUE);
      result->type = SYMBOL;
      result->value = EnvFalseSymbol(theEnv);
      return;
     }
   sp = FindISlotByName(theEnv,(INSTANCE_TYPE *) ins,sname);
   if (sp == NULL)
     {
      SetEvaluationError(theEnv,TRUE);
      result->type = SYMBOL;
      result->value = EnvFalseSymbol(theEnv);
      return;
     }
   result->type = (unsigned short) sp->type;
   result->value = sp->value;
   if (sp->type == MULTIFIELD)
     {
      result->begin = 0;
      SetpDOEnd(result,GetInstanceSlotLength(sp));
     }
   PropagateReturnValue(theEnv,result);
  }

/*********************************************************
  NAME         : EnvDirectPutSlot
  DESCRIPTION  : Gets a slot value
  INPUTS       : 1) Instance address
                 2) Slot name
                 3) Caller's new value buffer
  RETURNS      : TRUE if put successful, FALSE otherwise
  SIDE EFFECTS : None
  NOTES        : None
 *********************************************************/
globle int EnvDirectPutSlot(
  void *theEnv,
  void *ins,
  char *sname,
  DATA_OBJECT *val)
  {
   INSTANCE_SLOT *sp;
   DATA_OBJECT junk;

   if ((((INSTANCE_TYPE *) ins)->garbage == 1) || (val == NULL))
     {
      SetEvaluationError(theEnv,TRUE);
      return(FALSE);
     }
   sp = FindISlotByName(theEnv,(INSTANCE_TYPE *) ins,sname);
   if (sp == NULL)
     {
      SetEvaluationError(theEnv,TRUE);
      return(FALSE);
     }

   if (PutSlotValue(theEnv,(INSTANCE_TYPE *) ins,sp,val,&junk,"external put"))
     {
      if ((EvaluationData(theEnv)->CurrentEvaluationDepth == 0) && (! CommandLineData(theEnv)->EvaluatingTopLevelCommand) &&
          (EvaluationData(theEnv)->CurrentExpression == NULL))
        { PeriodicCleanup(theEnv,TRUE,FALSE); }
      return(TRUE);
     }
   return(FALSE);
  }

/***************************************************
  NAME         : GetInstanceName
  DESCRIPTION  : Returns name of instance
  INPUTS       : Pointer to instance
  RETURNS      : Name of instance
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
#if IBM_TBC
#pragma argsused
#endif
globle char *EnvGetInstanceName(
  void *theEnv,
  void *iptr)
  {
#if MAC_MCW || IBM_MCW || MAC_XCD
#pragma unused(theEnv)
#endif

   if (((INSTANCE_TYPE *) iptr)->garbage == 1)
     return(NULL);
   return(ValueToString(((INSTANCE_TYPE *) iptr)->name));
  }

/***************************************************
  NAME         : EnvGetInstanceClass
  DESCRIPTION  : Returns class of instance
  INPUTS       : Pointer to instance
  RETURNS      : Pointer to class of instance
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
#if IBM_TBC
#pragma argsused
#endif
globle void *EnvGetInstanceClass(
  void *theEnv,
  void *iptr)
  {
#if MAC_MCW || IBM_MCW || MAC_XCD
#pragma unused(theEnv)
#endif

   if (((INSTANCE_TYPE *) iptr)->garbage == 1)
     return(NULL);
   return((void *) ((INSTANCE_TYPE *) iptr)->cls);
  }

/***************************************************
  NAME         : GetGlobalNumberOfInstances
  DESCRIPTION  : Returns the total number of