insfun.c

来自「clips源代码」· C语言 代码 · 共 1,328 行 · 第 1/4 页

  SYMBOL_HN *moduleAndInstanceName)
  {
   unsigned modulePosition,searchImports;
   SYMBOL_HN *moduleName,*instanceName;
   struct defmodule *currentModule,*theModule;

   currentModule = ((struct defmodule *) EnvGetCurrentModule(theEnv));

   /* =======================================
      Instance names of the form [<name>] are
      searched for only in the current module
      ======================================= */
   modulePosition = FindModuleSeparator(ValueToString(moduleAndInstanceName));
   if (modulePosition == FALSE)
     {
      theModule = currentModule;
      instanceName = moduleAndInstanceName;
      searchImports = FALSE;
     }

   /* =========================================
      Instance names of the form [::<name>] are
      searched for in the current module and
      imported modules in the definition order
      ========================================= */
   else if (modulePosition == 1)
     {
      theModule = currentModule;
      instanceName = ExtractConstructName(theEnv,modulePosition,ValueToString(moduleAndInstanceName));
      searchImports = TRUE;
     }

   /* =============================================
      Instance names of the form [<module>::<name>]
      are searched for in the specified module
      ============================================= */
   else
     {
      moduleName = ExtractModuleName(theEnv,modulePosition,ValueToString(moduleAndInstanceName));
      theModule = (struct defmodule *) EnvFindDefmodule(theEnv,ValueToString(moduleName));
      instanceName = ExtractConstructName(theEnv,modulePosition,ValueToString(moduleAndInstanceName));
      if (theModule == NULL)
        return(NULL);
      searchImports = FALSE;
     }
   return(FindInstanceInModule(theEnv,instanceName,theModule,currentModule,searchImports));
  }

/***************************************************
  NAME         : FindInstanceInModule
  DESCRIPTION  : Finds an instance of the given name
                 in the given module in scope of
                 the given current module
                 (will also search imported modules
                  if specified)
  INPUTS       : 1) The instance name (no module)
                 2) The module to search
                 3) The currently active module
                 4) A flag indicating whether
                    to search imported modules of
                    given module as well
  RETURNS      : The instance (NULL if none found)
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
globle INSTANCE_TYPE *FindInstanceInModule(
  void *theEnv,
  SYMBOL_HN *instanceName,
  struct defmodule *theModule,
  struct defmodule *currentModule,
  unsigned searchImports)
  {
   INSTANCE_TYPE *startInstance,*ins;

   /* ===============================
      Find the first instance of the
      correct name in the hash chain
      =============================== */
   startInstance = InstanceData(theEnv)->InstanceTable[HashInstance(instanceName)];
   while (startInstance != NULL)
     {
      if (startInstance->name == instanceName)
        break;
      startInstance = startInstance->nxtHash;
     }

   if (startInstance == NULL)
     return(NULL);

   /* ===========================================
      Look for the instance in the specified
      module - if the class of the found instance
      is in scope of the current module, we have
      found the instance
      =========================================== */
   for (ins = startInstance ;
        (ins != NULL) ? (ins->name == startInstance->name) : FALSE ;
        ins = ins->nxtHash)
     if ((ins->cls->header.whichModule->theModule == theModule) &&
          DefclassInScope(theEnv,ins->cls,currentModule))
       return(ins);

   /* ================================
      For ::<name> formats, we need to
      search imported modules too
      ================================ */
   if (searchImports == FALSE)
     return(NULL);
   MarkModulesAsUnvisited(theEnv);
   return(FindImportedInstance(theEnv,theModule,currentModule,startInstance));
  }

/********************************************************************
  NAME         : FindInstanceSlot
  DESCRIPTION  : Finds an instance slot by name
  INPUTS       : 1) The address of the instance
                 2) The symbolic name of the slot
  RETURNS      : The address of the slot, NULL if not found
  SIDE EFFECTS : None
  NOTES        : None
 ********************************************************************/
globle INSTANCE_SLOT *FindInstanceSlot(
  void *theEnv,
  INSTANCE_TYPE *ins,
  SYMBOL_HN *sname)
  {
   register int i;

   i = FindInstanceTemplateSlot(theEnv,ins->cls,sname);
   return((i != -1) ? ins->slotAddresses[i] : NULL);
  }

/********************************************************************
  NAME         : FindInstanceTemplateSlot
  DESCRIPTION  : Performs a search on an class's instance
                   template slot array to find a slot by name
  INPUTS       : 1) The address of the class
                 2) The symbolic name of the slot
  RETURNS      : The index of the slot, -1 if not found
  SIDE EFFECTS : None
  NOTES        : The slot's unique id is used as index into
                 the slot map array.
 ********************************************************************/
globle int FindInstanceTemplateSlot(
  void *theEnv,
  DEFCLASS *cls,
  SYMBOL_HN *sname)
  {
   int sid;

   sid = FindSlotNameID(theEnv,sname);
   if (sid == -1)
     return(-1);
   if (sid > (int) cls->maxSlotNameID)
     return(-1);
   return((int) cls->slotNameMap[sid] - 1);
  }

/*******************************************************
  NAME         : PutSlotValue
  DESCRIPTION  : Evaluates new slot-expression and
                   stores it as a multifield
                   variable for the slot.
  INPUTS       : 1) The address of the instance
                    (NULL if no trace-messages desired)
                 2) The address of the slot
                 3) The address of the value
                 4) DATA_OBJECT_PTR to store the
                    set value
                 5) The command doing the put-
  RETURNS      : FALSE on errors, or TRUE
  SIDE EFFECTS : Old value deleted and new one allocated
                 Old value symbols deinstalled
                 New value symbols installed
  NOTES        : None
 *******************************************************/
globle int PutSlotValue(
  void *theEnv,
  INSTANCE_TYPE *ins,
  INSTANCE_SLOT *sp,
  DATA_OBJECT *val,
  DATA_OBJECT *setVal,
  char *theCommand)
  {
   if (ValidSlotValue(theEnv,val,sp->desc,ins,theCommand) == FALSE)
     {
      SetpType(setVal,SYMBOL);
      SetpValue(setVal,EnvFalseSymbol(theEnv));
      return(FALSE);
     }
   return(DirectPutSlotValue(theEnv,ins,sp,val,setVal));
  }

/*******************************************************
  NAME         : DirectPutSlotValue
  DESCRIPTION  : Evaluates new slot-expression and
                   stores it as a multifield
                   variable for the slot.
  INPUTS       : 1) The address of the instance
                    (NULL if no trace-messages desired)
                 2) The address of the slot
                 3) The address of the value
                 4) DATA_OBJECT_PTR to store the
                    set value
  RETURNS      : FALSE on errors, or TRUE
  SIDE EFFECTS : Old value deleted and new one allocated
                 Old value symbols deinstalled
                 New value symbols installed
  NOTES        : None
 *******************************************************/
globle int DirectPutSlotValue(
  void *theEnv,
  INSTANCE_TYPE *ins,
  INSTANCE_SLOT *sp,
  DATA_OBJECT *val,
  DATA_OBJECT *setVal)
  {
   register long i,j; /* 6.04 Bug Fix */
#if DEFRULE_CONSTRUCT
   int sharedTraversalID;
   INSTANCE_SLOT *bsp,**spaddr;
#endif
   DATA_OBJECT tmpVal;

   SetpType(setVal,SYMBOL);
   SetpValue(setVal,EnvFalseSymbol(theEnv));
   if (val == NULL)
     {
      SystemError(theEnv,"INSFUN",1);
      EnvExitRouter(theEnv,EXIT_FAILURE);
     }
   else if (GetpValue(val) == ProceduralPrimitiveData(theEnv)->NoParamValue)
     {
      if (sp->desc->dynamicDefault)
        {
         val = &tmpVal;
         if (!EvaluateAndStoreInDataObject(theEnv,sp->desc->multiple,
                                           (EXPRESSION *) sp->desc->defaultValue,val,TRUE))
           return(FALSE);
        }
      else
        val = (DATA_OBJECT *) sp->desc->defaultValue;
     }
#if DEFRULE_CONSTRUCT
   if (EngineData(theEnv)->JoinOperationInProgress && sp->desc->reactive &&
       (ins->cls->reactive || sp->desc->shared))
     {
      PrintErrorID(theEnv,"INSFUN",5,FALSE);
      EnvPrintRouter(theEnv,WERROR,"Cannot modify reactive instance slots while\n");
      EnvPrintRouter(theEnv,WERROR,"  pattern-matching is in process.\n");
      SetEvaluationError(theEnv,TRUE);
      return(FALSE);
     }

   /* =============================================
      If we are about to change a slot of an object
      which is a basis for a firing rule, we need
      to make sure that slot is copied first
      ============================================= */
   if (ins->basisSlots != NULL)
     {
      spaddr = &ins->slotAddresses[ins->cls->slotNameMap[sp->desc->slotName->id] - 1];
      bsp = ins->basisSlots + (spaddr - ins->slotAddresses);
      if (bsp->value == NULL)
        {
         bsp->type = sp->type;
         bsp->value = sp->value;
         if (sp->desc->multiple)
           MultifieldInstall(theEnv,(MULTIFIELD_PTR) bsp->value);
         else
           AtomInstall(theEnv,(int) bsp->type,bsp->value);
        }
     }

#endif
   if (sp->desc->multiple == 0)
     {
      AtomDeinstall(theEnv,(int) sp->type,sp->value);

      /* ======================================
         Assumed that multfield already checked
         to be of cardinality 1
         ====================================== */
      if (GetpType(val) == MULTIFIELD)
        {
         sp->type = GetMFType(GetpValue(val),GetpDOBegin(val));
         sp->value = GetMFValue(GetpValue(val),GetpDOBegin(val));
        }
      else
        {
         sp->type = val->type;
         sp->value = val->value;
        }
      AtomInstall(theEnv,(int) sp->type,sp->value);
      SetpType(setVal,sp->type);
      SetpValue(setVal,sp->value);
     }
   else
     {
      MultifieldDeinstall(theEnv,(MULTIFIELD_PTR) sp->value);
      AddToMultifieldList(theEnv,(MULTIFIELD_PTR) sp->value);
      sp->type = MULTIFIELD;
      if (val->type == MULTIFIELD)
        {
         sp->value = CreateMultifield2(theEnv,(unsigned long) GetpDOLength(val));
         for (i = 1 , j = GetpDOBegin(val) ; i <= GetpDOLength(val) ; i++ , j++)
           {
            SetMFType(sp->value,i,GetMFType(val->value,j));
            SetMFValue(sp->value,i,GetMFValue(val->value,j));
           }
        }
      else
        {
         sp->value = CreateMultifield2(theEnv,1L);
         SetMFType(sp->value,1,(short) val->type);
         SetMFValue(sp->value,1,val->value);
        }
      MultifieldInstall(theEnv,(struct multifield *) sp->value);
      SetpType(setVal,MULTIFIELD);
      SetpValue(setVal,sp->value);
      SetpDOBegin(setVal,1);
      SetpDOEnd(setVal,GetMFLength(sp->value));
     }
   /* ==================================================
      6.05 Bug fix - any slot set directly or indirectly
      by a slot override or other side-effect during an
      instance initialization should not have its
      default value set
      ================================================== */

   sp->override = ins->initializeInProgress;