clipsruby 0.0.2

data/ext/clipsruby/inscom.c

@@ -0,0 +1,2076 @@
+   /*******************************************************/
+   /*      "C" Language Integrated Production System      */
+   /*                                                     */
+   /*            CLIPS Version 6.41  07/12/21             */
+   /*                                                     */
+   /*               INSTANCE COMMAND MODULE               */
+   /*******************************************************/
+
+/*************************************************************/
+/* Purpose:  Kernel Interface Commands for Instances         */
+/*                                                           */
+/* Principal Programmer(s):                                  */
+/*      Brian L. Dantes                                      */
+/*                                                           */
+/* Contributing Programmer(s):                               */
+/*      Gary D. Riley                                        */
+/*                                                           */
+/* Revision History:                                         */
+/*                                                           */
+/*      6.23: Correction for FalseSymbol/TrueSymbol. DR0859  */
+/*                                                           */
+/*            Corrected compilation errors for files         */
+/*            generated by constructs-to-c. DR0861           */
+/*                                                           */
+/*      6.24: Loading a binary instance file from a run-time */
+/*            program caused a bus error. DR0866             */
+/*                                                           */
+/*            Removed LOGICAL_DEPENDENCIES compilation flag. */
+/*                                                           */
+/*            Converted INSTANCE_PATTERN_MATCHING to         */
+/*            DEFRULE_CONSTRUCT.                             */
+/*                                                           */
+/*            Renamed BOOLEAN macro type to intBool.         */
+/*                                                           */
+/*      6.30: Removed conditional code for unsupported       */
+/*            compilers/operating systems (IBM_MCW,          */
+/*            MAC_MCW, and IBM_TBC).                         */
+/*                                                           */
+/*            Changed integer type/precision.                */
+/*                                                           */
+/*            Changed garbage collection algorithm.          */
+/*                                                           */
+/*            Added const qualifiers to remove C++           */
+/*            deprecation warnings.                          */
+/*                                                           */
+/*            Converted API macros to function calls.        */
+/*                                                           */
+/*      6.31: Fast router used for MakeInstance.             */
+/*                                                           */
+/*            Added code to keep track of pointers to        */
+/*            constructs that are contained externally to    */
+/*            to constructs, DanglingConstructs.             */
+/*                                                           */
+/*      6.32: Fixed embedded reset of error flags.           */
+/*                                                           */
+/*            Fixed instance redefinition crash with rules   */      
+/*            in JNSimpleCompareFunction1 when deleted       */
+/*            instance slots are referenced.                 */
+/*                                                           */
+/*      6.40: Added Env prefix to GetEvaluationError and     */
+/*            SetEvaluationError functions.                  */
+/*                                                           */
+/*            Added Env prefix to GetHaltExecution and       */
+/*            SetHaltExecution functions.                    */
+/*                                                           */
+/*            Pragma once and other inclusion changes.       */
+/*                                                           */
+/*            Added support for booleans with <stdbool.h>.   */
+/*                                                           */
+/*            Removed use of void pointers for specific      */
+/*            data structures.                               */
+/*                                                           */
+/*            ALLOW_ENVIRONMENT_GLOBALS no longer supported. */
+/*                                                           */
+/*            UDF redesign.                                  */
+/*                                                           */
+/*            Eval support for run time and bload only.      */
+/*                                                           */
+/*************************************************************/
+
+/* =========================================
+   *****************************************
+               EXTERNAL DEFINITIONS
+   =========================================
+   ***************************************** */
+#include "setup.h"
+
+#if OBJECT_SYSTEM
+
+#include "argacces.h"
+#include "classcom.h"
+#include "classfun.h"
+#include "classinf.h"
+#include "commline.h"
+#include "envrnmnt.h"
+#include "exprnpsr.h"
+#include "evaluatn.h"
+#include "insfile.h"
+#include "insfun.h"
+#include "insmngr.h"
+#include "insmoddp.h"
+#include "insmult.h"
+#include "inspsr.h"
+#include "lgcldpnd.h"
+#include "memalloc.h"
+#include "msgcom.h"
+#include "msgfun.h"
+#include "prntutil.h"
+#include "router.h"
+#include "strngrtr.h"
+#include "sysdep.h"
+#include "utility.h"
+
+#include "inscom.h"
+
+/* =========================================
+   *****************************************
+                   CONSTANTS
+   =========================================
+   ***************************************** */
+#define ALL_QUALIFIER      "inherit"
+
+/***************************************/
+/* LOCAL INTERNAL FUNCTION DEFINITIONS */
+/***************************************/
+
+#if DEBUGGING_FUNCTIONS
+   static unsigned long           ListInstancesInModule(Environment *,int,const char *,const char *,bool,bool);
+   static unsigned long           TabulateInstances(Environment *,int,const char *,Defclass *,bool,bool);
+#endif
+
+   static void                    PrintInstance(Environment *,const char *,Instance *,const char *);
+   static InstanceSlot           *FindISlotByName(Environment *,Instance *,const char *);
+   static void                    DeallocateInstanceData(Environment *);
+
+/* =========================================
+   *****************************************
+          EXTERNALLY VISIBLE FUNCTIONS
+   =========================================
+   ***************************************** */
+
+/*********************************************************
+  NAME         : SetupInstances
+  DESCRIPTION  : Initializes instance Hash Table,
+                   Function Parsers, and Data Structures
+  INPUTS       : None
+  RETURNS      : Nothing useful
+  SIDE EFFECTS : None
+  NOTES        : None
+ *********************************************************/
+void SetupInstances(
+  Environment *theEnv)
+  {
+   struct patternEntityRecord instanceInfo = { { "INSTANCE_ADDRESS_TYPE",
+                                                     INSTANCE_ADDRESS_TYPE,0,0,0,
+                                                     (EntityPrintFunction *) PrintInstanceName,
+                                                     (EntityPrintFunction *) PrintInstanceLongForm,
+                                                     (bool (*)(void *,Environment *)) UnmakeInstanceCallback,
+                                                     NULL,
+                                                     (void *(*)(void *,void *)) GetNextInstance,
+                                                     (EntityBusyCountFunction *) DecrementInstanceCallback,
+                                                     (EntityBusyCountFunction *) IncrementInstanceCallback,
+                                                     NULL,NULL,NULL,NULL,NULL
+                                                   },
+#if DEFRULE_CONSTRUCT && OBJECT_SYSTEM
+                                                  (void (*)(Environment *,void *)) DecrementObjectBasisCount,
+                                                  (void (*)(Environment *,void *)) IncrementObjectBasisCount,
+                                                  (void (*)(Environment *,void *)) MatchObjectFunction,
+                                                  (bool (*)(Environment *,void *)) NetworkSynchronized,
+                                                  (bool (*)(Environment *,void *)) InstanceIsDeleted
+#else
+                                                  NULL,NULL,NULL,NULL,NULL
+#endif
+                                         };
+
+   Instance dummyInstance = { { { { INSTANCE_ADDRESS_TYPE } , NULL, NULL, 0, 0L } },
+                              NULL, NULL, 0, 1, 0, 0, 0, 0,
+                              NULL,  0, 0, NULL, NULL, NULL, NULL,
+                              NULL, NULL, NULL, NULL, NULL };
+
+   AllocateEnvironmentData(theEnv,INSTANCE_DATA,sizeof(struct instanceData),DeallocateInstanceData);
+
+   InstanceData(theEnv)->MkInsMsgPass = true;
+   memcpy(&InstanceData(theEnv)->InstanceInfo,&instanceInfo,sizeof(struct patternEntityRecord));
+   dummyInstance.patternHeader.theInfo = &InstanceData(theEnv)->InstanceInfo;
+   memcpy(&InstanceData(theEnv)->DummyInstance,&dummyInstance,sizeof(Instance));
+
+   InitializeInstanceTable(theEnv);
+   InstallPrimitive(theEnv,(struct entityRecord *) &InstanceData(theEnv)->InstanceInfo,INSTANCE_ADDRESS_TYPE);
+
+#if ! RUN_TIME
+
+#if DEFRULE_CONSTRUCT && OBJECT_SYSTEM
+   AddUDF(theEnv,"initialize-instance","bn",0,UNBOUNDED,NULL,InactiveInitializeInstance,"InactiveInitializeInstance",NULL);
+   AddUDF(theEnv,"active-initialize-instance","bn",0,UNBOUNDED,NULL,InitializeInstanceCommand,"InitializeInstanceCommand",NULL);
+
+   AddUDF(theEnv,"make-instance","bn",0,UNBOUNDED,NULL,InactiveMakeInstance,"InactiveMakeInstance",NULL);
+   AddUDF(theEnv,"active-make-instance","bn",0,UNBOUNDED,NULL,MakeInstanceCommand,"MakeInstanceCommand",NULL);
+
+#else
+   AddUDF(theEnv,"initialize-instance","bn",0,UNBOUNDED,NULL,InitializeInstanceCommand,"InitializeInstanceCommand",NULL);
+   AddUDF(theEnv,"make-instance","bn",0,UNBOUNDED,NULL,MakeInstanceCommand,"MakeInstanceCommand",NULL);
+#endif
+
+   AddUDF(theEnv,"init-slots","*",0,0,NULL,InitSlotsCommand,"InitSlotsCommand",NULL);
+
+   AddUDF(theEnv,"delete-instance","b",0,0,NULL,DeleteInstanceCommand,"DeleteInstanceCommand",NULL);
+   AddUDF(theEnv,"(create-instance)","b",0,0,NULL,CreateInstanceHandler,"CreateInstanceHandler",NULL);
+   AddUDF(theEnv,"unmake-instance","b",1,UNBOUNDED,"iny",UnmakeInstanceCommand,"UnmakeInstanceCommand",NULL);
+
+#if DEBUGGING_FUNCTIONS
+   AddUDF(theEnv,"instances","v",0,3,"y",InstancesCommand,"InstancesCommand",NULL);
+   AddUDF(theEnv,"ppinstance","v",0,0,NULL,PPInstanceCommand,"PPInstanceCommand",NULL);
+#endif
+
+   AddUDF(theEnv,"symbol-to-instance-name","*",1,1,"y",SymbolToInstanceNameFunction,"SymbolToInstanceNameFunction",NULL);
+   AddUDF(theEnv,"instance-name-to-symbol","y",1,1,"ny",InstanceNameToSymbolFunction,"InstanceNameToSymbolFunction",NULL);
+   AddUDF(theEnv,"instance-address","bi",1,2,";iyn;yn",InstanceAddressCommand,"InstanceAddressCommand",NULL);
+   AddUDF(theEnv,"instance-addressp","b",1,1,NULL,InstanceAddressPCommand,"InstanceAddressPCommand",NULL);
+   AddUDF(theEnv,"instance-namep","b",1,1,NULL,InstanceNamePCommand,"InstanceNamePCommand",NULL);
+   AddUDF(theEnv,"instance-name","bn",1,1,"yin",InstanceNameCommand,"InstanceNameCommand",NULL);
+   AddUDF(theEnv,"instancep","b",1,1,NULL,InstancePCommand,"InstancePCommand",NULL);
+   AddUDF(theEnv,"instance-existp","b",1,1,"niy",InstanceExistPCommand,"InstanceExistPCommand",NULL);
+   AddUDF(theEnv,"class","*",1,1,NULL,ClassCommand,"ClassCommand",NULL);
+
+#endif
+
+#if DEFRULE_CONSTRUCT && OBJECT_SYSTEM
+   AddFunctionParser(theEnv,"active-initialize-instance",ParseInitializeInstance);
+   AddFunctionParser(theEnv,"active-make-instance",ParseInitializeInstance);
+#endif
+   AddFunctionParser(theEnv,"initialize-instance",ParseInitializeInstance);
+   AddFunctionParser(theEnv,"make-instance",ParseInitializeInstance);
+
+   SetupInstanceModDupCommands(theEnv);
+   /* SetupInstanceFileCommands(theEnv); DR0866 */
+   SetupInstanceMultifieldCommands(theEnv);
+
+   SetupInstanceFileCommands(theEnv); /* DR0866 */
+
+   AddCleanupFunction(theEnv,"instances",CleanupInstances,0,NULL);
+   AddResetFunction(theEnv,"instances",DestroyAllInstances,60,NULL);
+  }
+
+/***************************************/
+/* DeallocateInstanceData: Deallocates */
+/*    environment data for instances.  */
+/***************************************/
+static void DeallocateInstanceData(
+  Environment *theEnv)
+  {
+   Instance *tmpIPtr, *nextIPtr;
+   long i;
+   InstanceSlot *sp;
+   IGARBAGE *tmpGPtr, *nextGPtr;
+   struct patternMatch *theMatch, *tmpMatch;
+
+   /*=================================*/
+   /* Remove the instance hash table. */
+   /*=================================*/
+
+   rm(theEnv,InstanceData(theEnv)->InstanceTable,
+      (sizeof(Instance *) * INSTANCE_TABLE_HASH_SIZE));
+
+   /*=======================*/
+   /* Return all instances. */
+   /*=======================*/
+
+   tmpIPtr = InstanceData(theEnv)->InstanceList;
+   while (tmpIPtr != NULL)
+     {
+      nextIPtr = tmpIPtr->nxtList;
+
+      theMatch = (struct patternMatch *) tmpIPtr->partialMatchList;
+      while (theMatch != NULL)
+        {
+         tmpMatch = theMatch->next;
+         rtn_struct(theEnv,patternMatch,theMatch);
+         theMatch = tmpMatch;
+        }
+
+#if DEFRULE_CONSTRUCT
+      ReturnEntityDependencies(theEnv,(struct patternEntity *) tmpIPtr);
+#endif
+
+      for (i = 0 ; i < tmpIPtr->cls->instanceSlotCount ; i++)
+        {
+         sp = tmpIPtr->slotAddresses[i];
+         if ((sp == &sp->desc->sharedValue) ?
+             (--sp->desc->sharedCount == 0) : true)
+           {
+            if (sp->desc->multiple)
+              { ReturnMultifield(theEnv,sp->multifieldValue); }
+           }
+        }
+
+      if (tmpIPtr->cls->instanceSlotCount != 0)
+        {
+         rm(theEnv,tmpIPtr->slotAddresses,
+            (tmpIPtr->cls->instanceSlotCount * sizeof(InstanceSlot *)));
+         if (tmpIPtr->cls->localInstanceSlotCount != 0)
+           {
+            rm(theEnv,tmpIPtr->slots,
+               (tmpIPtr->cls->localInstanceSlotCount * sizeof(InstanceSlot)));
+           }
+        }
+
+      rtn_struct(theEnv,instance,tmpIPtr);
+
+      tmpIPtr = nextIPtr;
+     }
+
+   /*===============================*/
+   /* Get rid of garbage instances. */
+   /*===============================*/
+
+   tmpGPtr = InstanceData(theEnv)->InstanceGarbageList;
+   while (tmpGPtr != NULL)
+     {
+      nextGPtr = tmpGPtr->nxt;
+      rtn_struct(theEnv,instance,tmpGPtr->ins);
+      rtn_struct(theEnv,igarbage,tmpGPtr);
+      tmpGPtr = nextGPtr;
+     }
+  }
+
+/*******************************************************************
+  NAME         : DeleteInstance
+  DESCRIPTION  : DIRECTLY removes a named instance from the
+                   hash table and its class's
+                   instance list
+  INPUTS       : The instance address
+  RETURNS      : True if successful, false otherwise
+  SIDE EFFECTS : Instance is deallocated
+  NOTES        : C interface for deleting instances
+ *******************************************************************/
+UnmakeInstanceError DeleteInstance(
+  Instance *theInstance)
+  {
+   GCBlock gcb;
+   UnmakeInstanceError success;
+
+   if (theInstance != NULL)
+     {
+      Environment *theEnv = theInstance->cls->header.env;
+      
+      /*=====================================*/
+      /* If embedded, clear the error flags. */
+      /*=====================================*/
+   
+      if (EvaluationData(theEnv)->CurrentExpression == NULL)
+        { ResetErrorFlags(theEnv); }
+
+      GCBlockStart(theEnv,&gcb);
+      success = QuashInstance(theEnv,theInstance);
+      GCBlockEnd(theEnv,&gcb);
+      
+      return success;
+     }
+     
+   return UIE_NULL_POINTER_ERROR;
+  }
+
+/*******************************************************************
+  NAME         : DeleteAllInstances
+  DESCRIPTION  : DIRECTLY removes all instances from the
+                 hash table and its class's instance list
+  INPUTS       : The environment
+  RETURNS      : True if successful, false otherwise
+  SIDE EFFECTS : Instance is deallocated
+  NOTES        : C interface for deleting instances
+ *******************************************************************/
+UnmakeInstanceError DeleteAllInstances(
+  Environment *theEnv)
+  {
+   Instance *ins, *itmp;
+   GCBlock gcb;
+   UnmakeInstanceError success = UIE_NO_ERROR, rv;
+   
+   /*=====================================*/
+   /* If embedded, clear the error flags. */
+   /*=====================================*/
+   
+   if (EvaluationData(theEnv)->CurrentExpression == NULL)
+     { ResetErrorFlags(theEnv); }
+
+   GCBlockStart(theEnv,&gcb);
+
+   ins = InstanceData(theEnv)->InstanceList;
+   while (ins != NULL)
+     {
+      itmp = ins;
+      ins = ins->nxtList;
+      if ((rv = QuashInstance(theEnv,itmp)) != UIE_NO_ERROR)
+        { success = rv; }
+     }
+
+   GCBlockEnd(theEnv,&gcb);
+
+   InstanceData(theEnv)->unmakeInstanceError = success;
+   return success;
+  }
+
+/**************************/
+/* UnmakeInstanceCallback */
+/**************************/
+bool UnmakeInstanceCallback(
+  Instance *theInstance,
+  Environment *theEnv)
+  {
+   return (UnmakeInstance(theInstance) == UIE_NO_ERROR);
+  }
+
+/*******************************************************************
+  NAME         : UnmakeAllInstances
+  DESCRIPTION  : Removes all instances from the environment
+  INPUTS       : The environment
+  RETURNS      : 1 if successful, 0 otherwise
+  SIDE EFFECTS : Instance is deallocated
+  NOTES        : C interface for deleting instances
+ *******************************************************************/
+UnmakeInstanceError UnmakeAllInstances(
+  Environment *theEnv)
+  {
+   UnmakeInstanceError success = UIE_NO_ERROR;
+   bool svmaintain;
+   GCBlock gcb;
+   Instance *theInstance;
+   
+   /*=====================================*/
+   /* If embedded, clear the error flags. */
+   /*=====================================*/
+   
+   if (EvaluationData(theEnv)->CurrentExpression == NULL)
+     { ResetErrorFlags(theEnv); }
+
+   GCBlockStart(theEnv,&gcb);
+   
+   svmaintain = InstanceData(theEnv)->MaintainGarbageInstances;
+   InstanceData(theEnv)->MaintainGarbageInstances = true;
+
+   theInstance = InstanceData(theEnv)->InstanceList;
+   while (theInstance != NULL)
+     {
+      DirectMessage(theEnv,MessageHandlerData(theEnv)->DELETE_SYMBOL,theInstance,NULL,NULL);
+
+      if (theInstance->garbage == 0)
+        { success = UIE_DELETED_ERROR; }
+
+      theInstance = theInstance->nxtList;
+      while ((theInstance != NULL) ? theInstance->garbage : false)
+        theInstance = theInstance->nxtList;
+     }
+
+   InstanceData(theEnv)->MaintainGarbageInstances = svmaintain;
+   CleanupInstances(theEnv,NULL);
+
+   GCBlockEnd(theEnv,&gcb);
+
+   InstanceData(theEnv)->unmakeInstanceError = success;
+   return success;
+  }
+
+/*******************************************************************
+  NAME         : UnmakeInstance
+  DESCRIPTION  : Removes a named instance via message-passing
+  INPUTS       : The instance address
+  RETURNS      : Error code (UIE_NO_ERROR if successful)
+  SIDE EFFECTS : Instance is deallocated
+  NOTES        : C interface for deleting instances
+ *******************************************************************/
+UnmakeInstanceError UnmakeInstance(
+  Instance *theInstance)
+  {
+   UnmakeInstanceError success = UIE_NO_ERROR;
+   bool svmaintain;
+   GCBlock gcb;
+   Environment *theEnv = theInstance->cls->header.env;
+   
+   if (theInstance == NULL)
+     {
+      InstanceData(theEnv)->unmakeInstanceError = UIE_NULL_POINTER_ERROR;
+      return UIE_NULL_POINTER_ERROR;
+     }
+     
+   /*=====================================*/
+   /* If embedded, clear the error flags. */
+   /*=====================================*/
+   
+   if (EvaluationData(theEnv)->CurrentExpression == NULL)
+     { ResetErrorFlags(theEnv); }
+
+   GCBlockStart(theEnv,&gcb);
+  
+   svmaintain = InstanceData(theEnv)->MaintainGarbageInstances;
+   InstanceData(theEnv)->MaintainGarbageInstances = true;
+
+   if (theInstance->garbage)
+     { success = UIE_DELETED_ERROR; }
+   else
+     {
+      DirectMessage(theEnv,MessageHandlerData(theEnv)->DELETE_SYMBOL,theInstance,NULL,NULL);
+      if (theInstance->garbage == 0)
+        { success = UIE_COULD_NOT_DELETE_ERROR; }
+     }
+
+   InstanceData(theEnv)->MaintainGarbageInstances = svmaintain;
+   CleanupInstances(theEnv,NULL);
+
+   GCBlockEnd(theEnv,&gcb);
+
+   if (EvaluationData(theEnv)->EvaluationError)
+     { success = UIE_RULE_NETWORK_ERROR; }
+   
+   InstanceData(theEnv)->unmakeInstanceError = success;
+   return success;
+  }
+
+#if DEBUGGING_FUNCTIONS
+
+/*******************************************************************
+  NAME         : InstancesCommand
+  DESCRIPTION  : Lists all instances associated
+                   with a particular class
+  INPUTS       : None
+  RETURNS      : Nothing useful
+  SIDE EFFECTS : None
+  NOTES        : H/L Syntax : (instances [<class-name> [inherit]])
+ *******************************************************************/
+void InstancesCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   bool inheritFlag = false;
+   Defmodule *theDefmodule;
+   const char *className = NULL;
+   UDFValue theArg;
+
+   theDefmodule = GetCurrentModule(theEnv);
+
+   if (UDFHasNextArgument(context))
+     {
+      if (! UDFFirstArgument(context,SYMBOL_BIT,&theArg)) return;
+
+      theDefmodule = FindDefmodule(theEnv,theArg.lexemeValue->contents);
+      if ((theDefmodule != NULL) ? false :
+          (strcmp(theArg.lexemeValue->contents,"*") != 0))
+        {
+         SetEvaluationError(theEnv,true);
+         ExpectedTypeError1(theEnv,"instances",1,"'defmodule name'");
+         return;
+        }
+      if (UDFHasNextArgument(context))
+        {
+         if (! UDFNextArgument(context,SYMBOL_BIT,&theArg)) return;
+         className = theArg.lexemeValue->contents;
+         if (LookupDefclassAnywhere(theEnv,theDefmodule,className) == NULL)
+           {
+            if (strcmp(className,"*") == 0)
+              className = NULL;
+            else
+              {
+               ClassExistError(theEnv,"instances",className);
+                 return;
+              }
+           }
+         if (UDFHasNextArgument(context))
+           {
+            if (! UDFNextArgument(context,SYMBOL_BIT,&theArg)) return;
+
+            if (strcmp(theArg.lexemeValue->contents,ALL_QUALIFIER) != 0)
+              {
+               SetEvaluationError(theEnv,true);
+               ExpectedTypeError1(theEnv,"instances",3,"keyword \"inherit\"");
+               return;
+              }
+            inheritFlag = true;
+           }
+        }
+     }
+   Instances(theEnv,STDOUT,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>)
+ ********************************************************/
+void PPInstanceCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   Instance *ins;
+
+   if (CheckCurrentMessage(theEnv,"ppinstance",true) == false)
+     return;
+   ins = GetActiveInstance(theEnv);
+   if (ins->garbage == 1)
+     return;
+   PrintInstance(theEnv,STDOUT,ins,"\n");
+   WriteString(theEnv,STDOUT,"\n");
+  }
+
+/***************************************************************
+  NAME         : Instances
+  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
+ **************************************************************/
+void Instances(
+  Environment *theEnv,
+  const char *logicalName,
+  Defmodule *theModule,
+  const char *className,
+  bool inheritFlag)
+  {
+   int id;
+   unsigned long count = 0L;
+   
+   /*=====================================*/
+   /* If embedded, clear the error flags. */
+   /*=====================================*/
+   
+   if (EvaluationData(theEnv)->CurrentExpression == NULL)
+     { ResetErrorFlags(theEnv); }
+     
+   /*==============================================*/
+   /* 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 (theModule == NULL)
+     {
+      theModule = GetNextDefmodule(theEnv,NULL);
+      while (theModule != NULL)
+        {
+         if (GetHaltExecution(theEnv) == true)
+           {
+            RestoreCurrentModule(theEnv);
+            ReleaseTraversalID(theEnv);
+            return;
+           }
+
+         WriteString(theEnv,logicalName,DefmoduleName(theModule));
+         WriteString(theEnv,logicalName,":\n");
+         SetCurrentModule(theEnv,theModule);
+         count += ListInstancesInModule(theEnv,id,logicalName,className,inheritFlag,true);
+         theModule = GetNextDefmodule(theEnv,theModule);
+        }
+     }
+
+   /*=======================================*/
+   /* For the specified module, print out   */
+   /* instances of the specified class(es). */
+   /*=======================================*/
+
+   else
+     {
+      SetCurrentModule(theEnv,theModule);
+      count = ListInstancesInModule(theEnv,id,logicalName,className,inheritFlag,false);
+     }
+
+   RestoreCurrentModule(theEnv);
+   ReleaseTraversalID(theEnv);
+   if (EvaluationData(theEnv)->HaltExecution == false)
+     { PrintTally(theEnv,logicalName,count,"instance","instances"); }
+  }
+
+#endif /* DEBUGGING_FUNCTIONS */
+
+/*********************************************************
+  NAME         : MakeInstance
+  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
+ *********************************************************/
+Instance *MakeInstance(
+  Environment *theEnv,
+  const char *mkstr)
+  {
+   const char *router = "***MKINS***";
+   GCBlock gcb;
+   struct token tkn;
+   Expression *top;
+   UDFValue returnValue;
+   Instance *rv;
+   const char *oldRouter;
+   const char *oldString;
+   long oldIndex;
+   int danglingConstructs;
+   
+   InstanceData(theEnv)->makeInstanceError = MIE_NO_ERROR;
+   
+   if (mkstr == NULL)
+     {
+      InstanceData(theEnv)->makeInstanceError = MIE_NULL_POINTER_ERROR;
+      return NULL;
+     }
+
+   /*=====================================*/
+   /* If embedded, clear the error flags. */
+   /*=====================================*/
+   
+   if (EvaluationData(theEnv)->CurrentExpression == NULL)
+     { ResetErrorFlags(theEnv); }
+
+   returnValue.value = FalseSymbol(theEnv);
+   
+   /*=============================*/
+   /* Use the fast router bypass. */
+   /*=============================*/
+
+   oldRouter = RouterData(theEnv)->FastCharGetRouter;
+   oldString = RouterData(theEnv)->FastCharGetString;
+   oldIndex  = RouterData(theEnv)->FastCharGetIndex;
+
+   RouterData(theEnv)->FastCharGetRouter = router;
+   RouterData(theEnv)->FastCharGetString = mkstr;
+   RouterData(theEnv)->FastCharGetIndex  = 0;
+     
+   GCBlockStart(theEnv,&gcb);
+   
+   GetToken(theEnv,router,&tkn);
+   if (tkn.tknType == LEFT_PARENTHESIS_TOKEN)
+     {
+      danglingConstructs = ConstructData(theEnv)->DanglingConstructs;
+
+      top = GenConstant(theEnv,FCALL,FindFunction(theEnv,"make-instance"));    
+      if (ParseSimpleInstance(theEnv,top,router) != NULL)
+        {
+         GetToken(theEnv,router,&tkn);
+         if (tkn.tknType == STOP_TOKEN)
+           {
+            ExpressionInstall(theEnv,top);
+            EvaluateExpression(theEnv,top,&returnValue);
+            ExpressionDeinstall(theEnv,top);
+           }
+         else
+           {
+            InstanceData(theEnv)->makeInstanceError = MIE_PARSING_ERROR;
+            SyntaxErrorMessage(theEnv,"instance definition");
+           }
+         ReturnExpression(theEnv,top);
+        }
+      else
+        { InstanceData(theEnv)->makeInstanceError = MIE_PARSING_ERROR; }
+      
+      if (EvaluationData(theEnv)->CurrentExpression == NULL)
+        { ConstructData(theEnv)->DanglingConstructs = danglingConstructs; }
+     }
+   else
+     {
+      InstanceData(theEnv)->makeInstanceError = MIE_PARSING_ERROR;
+      SyntaxErrorMessage(theEnv,"instance definition");
+     }
+     
+   /*===========================================*/
+   /* Restore the old state of the fast router. */
+   /*===========================================*/
+
+   RouterData(theEnv)->FastCharGetRouter = oldRouter;
+   RouterData(theEnv)->FastCharGetString = oldString;
+   RouterData(theEnv)->FastCharGetIndex  = oldIndex;
+
+   if (returnValue.value == FalseSymbol(theEnv))
+     { rv = NULL; }
+   else
+     { rv = FindInstanceBySymbol(theEnv,returnValue.lexemeValue); }
+
+   GCBlockEnd(theEnv,&gcb);
+   
+   return rv;
+  }
+
+/************************/
+/* GetMakeInstanceError */
+/************************/
+MakeInstanceError GetMakeInstanceError(
+  Environment *theEnv)
+  {
+   return InstanceData(theEnv)->makeInstanceError;
+  }
+
+/***************************************************************
+  NAME         : CreateRawInstance
+  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
+ ***************************************************************/
+Instance *CreateRawInstance(
+  Environment *theEnv,
+  Defclass *theDefclass,
+  const char *instanceName)
+  {
+   return BuildInstance(theEnv,CreateInstanceName(theEnv,instanceName),theDefclass,false);
+  }
+
+/***************************************************************************
+  NAME         : FindInstance
+  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
+ ***************************************************************************/
+Instance *FindInstance(
+  Environment *theEnv,
+  Defmodule *theModule,
+  const char *iname,
+  bool searchImports)
+  {
+   CLIPSLexeme *isym;
+
+   isym = FindSymbolHN(theEnv,iname,LEXEME_BITS | INSTANCE_NAME_BIT);
+
+   if (isym == NULL)
+     { return NULL; }
+
+   if (theModule == NULL)
+     { theModule = GetCurrentModule(theEnv); }
+
+   return FindInstanceInModule(theEnv,isym,theModule,GetCurrentModule(theEnv),searchImports);
+  }
+
+/***************************************************************************
+  NAME         : ValidInstanceAddress
+  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
+ ***************************************************************************/
+bool ValidInstanceAddress(
+  Instance *theInstance)
+  {
+   return (theInstance->garbage == 0) ? true : false;
+  }
+
+/***************************************************
+  NAME         : DirectGetSlot
+  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
+ ***************************************************/
+GetSlotError DirectGetSlot(
+  Instance *theInstance,
+  const char *sname,
+  CLIPSValue *returnValue)
+  {
+   InstanceSlot *sp;
+   Environment *theEnv = theInstance->cls->header.env;
+   
+   if ((theInstance == NULL) || (sname == NULL) || (returnValue == NULL))
+     { return GSE_NULL_POINTER_ERROR; }
+     
+   /*=====================================*/
+   /* If embedded, clear the error flags. */
+   /*=====================================*/
+   
+   if (EvaluationData(theEnv)->CurrentExpression == NULL)
+     { ResetErrorFlags(theEnv); }
+
+   if (theInstance->garbage == 1)
+     {
+      SetEvaluationError(theEnv,true);
+      returnValue->value = FalseSymbol(theEnv);
+      return GSE_INVALID_TARGET_ERROR;
+     }
+     
+   sp = FindISlotByName(theEnv,theInstance,sname);
+   if (sp == NULL)
+     {
+      SetEvaluationError(theEnv,true);
+      returnValue->value = FalseSymbol(theEnv);
+      return GSE_SLOT_NOT_FOUND_ERROR;
+     }
+
+   returnValue->value = sp->value;
+     
+   return GSE_NO_ERROR;
+  }
+
+/*********************************************************
+  NAME         : DirectPutSlot
+  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
+ *********************************************************/
+PutSlotError DirectPutSlot(
+  Instance *theInstance,
+  const char *sname,
+  CLIPSValue *val)
+  {
+   InstanceSlot *sp;
+   UDFValue junk, temp;
+   GCBlock gcb;
+   PutSlotError rv;
+   Environment *theEnv;
+   
+   if (theInstance == NULL)
+     { return PSE_NULL_POINTER_ERROR; }
+
+   theEnv = theInstance->cls->header.env;
+   
+   if ((sname == NULL) || (val == NULL))
+     {
+      SetEvaluationError(theEnv,true);
+      return PSE_NULL_POINTER_ERROR;
+     }
+     
+   if (theInstance->garbage == 1)
+     {
+      SetEvaluationError(theEnv,true);
+      return PSE_INVALID_TARGET_ERROR;
+     }
+     
+   sp = FindISlotByName(theEnv,theInstance,sname);
+   if (sp == NULL)
+     {
+      SetEvaluationError(theEnv,true);
+      return PSE_SLOT_NOT_FOUND_ERROR;
+     }
+
+   GCBlockStart(theEnv,&gcb);
+   CLIPSToUDFValue(val,&temp);
+   rv = PutSlotValue(theEnv,theInstance,sp,&temp,&junk,"external put");
+   GCBlockEnd(theEnv,&gcb);
+   
+   return rv;
+  }
+
+/*************************/
+/* DirectPutSlotInteger: */
+/*************************/
+PutSlotError DirectPutSlotInteger(
+  Instance *theInstance,
+  const char *sname,
+  long long val)
+  {
+   CLIPSValue cv;
+   
+   if (theInstance == NULL)
+     { return PSE_NULL_POINTER_ERROR; }
+     
+   cv.integerValue = CreateInteger(theInstance->cls->header.env,val);
+   
+   return DirectPutSlot(theInstance,sname,&cv);
+  }
+
+/***********************/
+/* DirectPutSlotFloat: */
+/***********************/
+PutSlotError DirectPutSlotFloat(
+  Instance *theInstance,
+  const char *sname,
+  double val)
+  {
+   CLIPSValue cv;
+   
+   if (theInstance == NULL)
+     { return PSE_NULL_POINTER_ERROR; }
+     
+   cv.floatValue = CreateFloat(theInstance->cls->header.env,val);
+   
+   return DirectPutSlot(theInstance,sname,&cv);
+  }
+
+/************************/
+/* DirectPutSlotSymbol: */
+/************************/
+PutSlotError DirectPutSlotSymbol(
+  Instance *theInstance,
+  const char *sname,
+  const char *val)
+  {
+   CLIPSValue cv;
+   
+   if (theInstance == NULL)
+     { return PSE_NULL_POINTER_ERROR; }
+     
+   cv.lexemeValue = CreateSymbol(theInstance->cls->header.env,val);
+   
+   return DirectPutSlot(theInstance,sname,&cv);
+  }
+
+/************************/
+/* DirectPutSlotString: */
+/************************/
+PutSlotError DirectPutSlotString(
+  Instance *theInstance,
+  const char *sname,
+  const char *val)
+  {
+   CLIPSValue cv;
+   
+   if (theInstance == NULL)
+     { return PSE_NULL_POINTER_ERROR; }
+     
+   cv.lexemeValue = CreateString(theInstance->cls->header.env,val);
+   
+   return DirectPutSlot(theInstance,sname,&cv);
+  }
+
+/******************************/
+/* DirectPutSlotInstanceName: */
+/******************************/
+PutSlotError DirectPutSlotInstanceName(
+  Instance *theInstance,
+  const char *sname,
+  const char *val)
+  {
+   CLIPSValue cv;
+   
+   if (theInstance == NULL)
+     { return PSE_NULL_POINTER_ERROR; }
+     
+   cv.lexemeValue = CreateInstanceName(theInstance->cls->header.env,val);
+   
+   return DirectPutSlot(theInstance,sname,&cv);
+  }
+
+/******************************/
+/* DirectPutSlotCLIPSInteger: */
+/******************************/
+PutSlotError DirectPutSlotCLIPSInteger(
+  Instance *theInstance,
+  const char *sname,
+  CLIPSInteger *val)
+  {
+   CLIPSValue cv;
+   
+   if (theInstance == NULL)
+     { return PSE_NULL_POINTER_ERROR; }
+     
+   cv.integerValue = val;
+   
+   return DirectPutSlot(theInstance,sname,&cv);
+  }
+
+/****************************/
+/* DirectPutSlotCLIPSFloat: */
+/****************************/
+PutSlotError DirectPutSlotCLIPSFloat(
+  Instance *theInstance,
+  const char *sname,
+  CLIPSFloat *val)
+  {
+   CLIPSValue cv;
+   
+   if (theInstance == NULL)
+     { return PSE_NULL_POINTER_ERROR; }
+     
+   cv.floatValue = val;
+   
+   return DirectPutSlot(theInstance,sname,&cv);
+  }
+
+/*****************************/
+/* DirectPutSlotCLIPSLexeme: */
+/*****************************/
+PutSlotError DirectPutSlotCLIPSLexeme(
+  Instance *theInstance,
+  const char *sname,
+  CLIPSLexeme *val)
+  {
+   CLIPSValue cv;
+   
+   if (theInstance == NULL)
+     { return PSE_NULL_POINTER_ERROR; }
+     
+   cv.lexemeValue = val;
+   
+   return DirectPutSlot(theInstance,sname,&cv);
+  }
+
+/**********************/
+/* DirectPutSlotFact: */
+/**********************/
+PutSlotError DirectPutSlotFact(
+  Instance *theInstance,
+  const char *sname,
+  Fact *val)
+  {
+   CLIPSValue cv;
+   
+   if (theInstance == NULL)
+     { return PSE_NULL_POINTER_ERROR; }
+     
+   cv.factValue = val;
+   
+   return DirectPutSlot(theInstance,sname,&cv);
+  }
+
+/**************************/
+/* DirectPutSlotInstance: */
+/**************************/
+PutSlotError DirectPutSlotInstance(
+  Instance *theInstance,
+  const char *sname,
+  Instance *val)
+  {
+   CLIPSValue cv;
+   
+   if (theInstance == NULL)
+     { return PSE_NULL_POINTER_ERROR; }
+     
+   cv.instanceValue = val;
+   
+   return DirectPutSlot(theInstance,sname,&cv);
+  }
+
+/****************************/
+/* DirectPutSlotMultifield: */
+/****************************/
+PutSlotError DirectPutSlotMultifield(
+  Instance *theInstance,
+  const char *sname,
+  Multifield *val)
+  {
+   CLIPSValue cv;
+   
+   if (theInstance == NULL)
+     { return PSE_NULL_POINTER_ERROR; }
+     
+   cv.multifieldValue = val;
+   
+   return DirectPutSlot(theInstance,sname,&cv);
+  }
+
+/**************************************/
+/* DirectPutSlotCLIPSExternalAddress: */
+/**************************************/
+PutSlotError DirectPutSlotCLIPSExternalAddress(
+  Instance *theInstance,
+  const char *sname,
+  CLIPSExternalAddress *val)
+  {
+   CLIPSValue cv;
+   
+   if (theInstance == NULL)
+     { return PSE_NULL_POINTER_ERROR; }
+     
+   cv.externalAddressValue = val;
+   
+   return DirectPutSlot(theInstance,sname,&cv);
+  }
+
+/***************************************************
+  NAME         : InstanceName
+  DESCRIPTION  : Returns name of instance
+  INPUTS       : Pointer to instance
+  RETURNS      : Name of instance
+  SIDE EFFECTS : None
+  NOTES        : None
+ ***************************************************/
+const char *InstanceName(
+  Instance *theInstance)
+  {
+   if (theInstance->garbage == 1)
+     { return NULL; }
+
+   return theInstance->name->contents;
+  }
+
+/***************************************************
+  NAME         : InstanceClass
+  DESCRIPTION  : Returns class of instance
+  INPUTS       : Pointer to instance
+  RETURNS      : Pointer to class of instance
+  SIDE EFFECTS : None
+  NOTES        : None
+ ***************************************************/
+Defclass *InstanceClass(
+  Instance *theInstance)
+  {
+   if (theInstance->garbage == 1)
+     { return NULL; }
+
+   return theInstance->cls;
+  }
+
+/***************************************************
+  NAME         : GetGlobalNumberOfInstances
+  DESCRIPTION  : Returns the total number of
+                   instances in all modules
+  INPUTS       : None
+  RETURNS      : The instance count
+  SIDE EFFECTS : None
+  NOTES        : None
+ ***************************************************/
+unsigned long GetGlobalNumberOfInstances(
+  Environment *theEnv)
+  {
+   return(InstanceData(theEnv)->GlobalNumberOfInstances);
+  }
+
+/***************************************************
+  NAME         : GetNextInstance
+  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
+ ***************************************************/
+Instance *GetNextInstance(
+  Environment *theEnv,
+  Instance *theInstance)
+  {
+   if (theInstance == NULL)
+     { return InstanceData(theEnv)->InstanceList; }
+
+   if (theInstance->garbage == 1)
+     { return NULL; }
+
+   return theInstance->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
+ ***************************************************/
+Instance *GetNextInstanceInScope(
+  Environment *theEnv,
+  Instance *theInstance)
+  {
+   if (theInstance == NULL)
+     { theInstance = InstanceData(theEnv)->InstanceList; }
+   else if (theInstance->garbage)
+     { return NULL; }
+   else
+     { theInstance = theInstance->nxtList; }
+
+   while (theInstance != NULL)
+     {
+      if (DefclassInScope(theEnv,theInstance->cls,NULL))
+        { return theInstance; }
+
+      theInstance = theInstance->nxtList;
+     }
+
+   return NULL;
+  }
+
+/***************************************************
+  NAME         : GetNextInstanceInClass
+  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
+ ***************************************************/
+Instance *GetNextInstanceInClass(
+  Defclass *theDefclass,
+  Instance *theInstance)
+  {
+   if (theInstance == NULL)
+     { return theDefclass->instanceList; }
+
+   if (theInstance->garbage == 1)
+     { return NULL; }
+
+   return theInstance->nxtClass;
+  }
+
+/***************************************************
+  NAME         : GetNextInstanceInClassAndSubclasses
+  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
+ ***************************************************/
+Instance *GetNextInstanceInClassAndSubclasses(
+  Defclass **cptr,
+  Instance *theInstance,
+  UDFValue *iterationInfo)
+  {
+   Instance *nextInstance;
+   Defclass *theClass;
+   Environment *theEnv;
+
+   theClass = *cptr;
+   theEnv = theClass->header.env;
+
+   if (theInstance == NULL)
+     {
+      ClassSubclassAddresses(theEnv,theClass,iterationInfo,true);
+      nextInstance = theClass->instanceList;
+     }
+   else if (theInstance->garbage == 1)
+     { nextInstance = NULL; }
+   else
+     { nextInstance = theInstance->nxtClass; }
+
+   while ((nextInstance == NULL) &&
+          (iterationInfo->begin < iterationInfo->range))
+     {
+      theClass = (Defclass *) iterationInfo->multifieldValue->contents[iterationInfo->begin].value;
+      *cptr = theClass;
+      iterationInfo->begin = iterationInfo->begin + 1;
+      nextInstance = theClass->instanceList;
+     }
+
+   return nextInstance;
+  }
+
+/***************************************************
+  NAME         : InstancePPForm
+  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
+ ***************************************************/
+void InstancePPForm(
+  Instance *theInstance,
+  StringBuilder *theSB)
+  {
+   const char *pbuf = "***InstancePPForm***";
+   Environment *theEnv;
+
+   if (theInstance->garbage == 1)
+     { return; }
+
+   theEnv = theInstance->cls->header.env;
+
+   if (OpenStringBuilderDestination(theEnv,pbuf,theSB) == 0)
+     { return; }
+   
+   PrintInstance(theEnv,pbuf,theInstance," ");
+
+   CloseStringBuilderDestination(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
+ *********************************************************/
+void ClassCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   Instance *ins;
+   const char *func;
+   UDFValue temp;
+
+   func = EvaluationData(theEnv)->CurrentExpression->functionValue->callFunctionName->contents;
+
+   returnValue->lexemeValue = FalseSymbol(theEnv);
+
+   EvaluateExpression(theEnv,GetFirstArgument(),&temp);
+   if (temp.header->type == INSTANCE_ADDRESS_TYPE)
+     {
+      ins = temp.instanceValue;
+      if (ins->garbage == 1)
+        {
+         StaleInstanceAddress(theEnv,func,0);
+         SetEvaluationError(theEnv,true);
+         return;
+        }
+      returnValue->value = GetDefclassNamePointer(ins->cls);
+     }
+   else if (temp.header->type == INSTANCE_NAME_TYPE)
+     {
+      ins = FindInstanceBySymbol(theEnv,temp.lexemeValue);
+      if (ins == NULL)
+        {
+         NoInstanceError(theEnv,temp.lexemeValue->contents,func);
+         return;
+        }
+      returnValue->value = GetDefclassNamePointer(ins->cls);
+     }
+   else
+     {
+      switch (temp.header->type)
+        {
+         case INTEGER_TYPE          :
+         case FLOAT_TYPE            :
+         case SYMBOL_TYPE           :
+         case STRING_TYPE           :
+         case MULTIFIELD_TYPE       :
+         case EXTERNAL_ADDRESS_TYPE :
+         case FACT_ADDRESS_TYPE     :
+                          returnValue->value = GetDefclassNamePointer(
+                                                 DefclassData(theEnv)->PrimitiveClassMap[temp.header->type]);
+                         return;
+
+         default       : PrintErrorID(theEnv,"INSCOM",1,false);
+                         WriteString(theEnv,STDERR,"Undefined type in function '");
+                         WriteString(theEnv,STDERR,func);
+                         WriteString(theEnv,STDERR,"'.\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.
+ ******************************************************/
+void CreateInstanceHandler(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+#if MAC_XCD
+#pragma unused(theEnv,context)
+#endif
+
+   returnValue->lexemeValue = TrueSymbol(theEnv);
+  }
+
+/******************************************************
+  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
+ ******************************************************/
+void DeleteInstanceCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   if (CheckCurrentMessage(theEnv,"delete-instance",true))
+     {
+      UnmakeInstanceError rv = QuashInstance(theEnv,GetActiveInstance(theEnv));
+      returnValue->lexemeValue = CreateBoolean(theEnv,(rv == UIE_NO_ERROR));
+     }
+   else
+     { returnValue->lexemeValue = FalseSymbol(theEnv); }
+  }
+
+/********************************************************************
+  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>+ | *)
+ ********************************************************************/
+void UnmakeInstanceCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   UDFValue theArg;
+   Instance *ins;
+   unsigned int argNumber = 1;
+   bool rtn = true;
+
+   while (UDFHasNextArgument(context))
+     {
+      if (! UDFNextArgument(context,INSTANCE_BITS | SYMBOL_BIT,&theArg))
+        { return; }
+
+      if (CVIsType(&theArg,INSTANCE_NAME_BIT | SYMBOL_BIT))
+        {
+         ins = FindInstanceBySymbol(theEnv,theArg.lexemeValue);
+         if ((ins == NULL) ? (strcmp(theArg.lexemeValue->contents,"*") != 0) : false)
+           {
+            NoInstanceError(theEnv,theArg.lexemeValue->contents,"unmake-instance");
+            returnValue->lexemeValue = FalseSymbol(theEnv);
+            return;
+           }
+         }
+      else if (CVIsType(&theArg,INSTANCE_ADDRESS_BIT))
+        {
+         ins = theArg.instanceValue;
+         if (ins->garbage)
+           {
+            StaleInstanceAddress(theEnv,"unmake-instance",0);
+            SetEvaluationError(theEnv,true);
+            returnValue->lexemeValue = FalseSymbol(theEnv);
+            return;
+           }
+        }
+      else
+        {
+         ExpectedTypeError1(theEnv,"unmake-instance",argNumber,"instance-address, instance-name, or the symbol *");
+         SetEvaluationError(theEnv,true);
+         returnValue->lexemeValue = FalseSymbol(theEnv);
+         return;
+        }
+        
+      if (ins != NULL)
+        {
+         if (UnmakeInstance(ins) != UIE_NO_ERROR)
+           rtn = false;
+        }
+       else
+         {
+          if (UnmakeAllInstances(theEnv) != UIE_NO_ERROR)
+            rtn = false;
+          returnValue->lexemeValue = CreateBoolean(theEnv,rtn);
+          return;
+         }
+
+      argNumber++;
+     }
+
+   returnValue->lexemeValue = CreateBoolean(theEnv,rtn);
+  }
+
+/*****************************************************************
+  NAME         : SymbolToInstanceNameFunction
+  DESCRIPTION  : Converts a symbol from type SYMBOL_TYPE
+                   to type INSTANCE_NAME_TYPE
+  INPUTS       : The address of the value buffer
+  RETURNS      : The new INSTANCE_NAME_TYPE symbol
+  SIDE EFFECTS : None
+  NOTES        : H/L Syntax : (symbol-to-instance-name <symbol>)
+ *****************************************************************/
+void SymbolToInstanceNameFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   if (! UDFFirstArgument(context,SYMBOL_BIT,returnValue))
+     { return; }
+
+   returnValue->value = CreateInstanceName(theEnv,returnValue->lexemeValue->contents);
+  }
+
+/*****************************************************************
+  NAME         : InstanceNameToSymbolFunction
+  DESCRIPTION  : Converts a symbol from type INSTANCE_NAME_TYPE
+                   to type SYMBOL_TYPE
+  INPUTS       : None
+  RETURNS      : Symbol FALSE on errors - or converted instance name
+  SIDE EFFECTS : None
+  NOTES        : H/L Syntax : (instance-name-to-symbol <iname>)
+ *****************************************************************/
+void InstanceNameToSymbolFunction(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   if (! UDFFirstArgument(context,INSTANCE_NAME_BIT | SYMBOL_BIT,returnValue))
+     { return; }
+
+   returnValue->value = CreateSymbol(theEnv,returnValue->lexemeValue->contents);
+  }
+
+/*********************************************************************************
+  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>)
+ *********************************************************************************/
+void InstanceAddressCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   Instance *ins;
+   UDFValue temp;
+   Defmodule *theModule;
+   bool searchImports;
+
+   returnValue->lexemeValue = FalseSymbol(theEnv);
+   if (UDFArgumentCount(context) > 1)
+     {
+      if (! UDFFirstArgument(context,SYMBOL_BIT,&temp))
+        {
+         returnValue->lexemeValue = FalseSymbol(theEnv);
+         return;
+        }
+      theModule = FindDefmodule(theEnv,temp.lexemeValue->contents);
+      if ((theModule == NULL) ? (strcmp(temp.lexemeValue->contents,"*") != 0) : false)
+        {
+         ExpectedTypeError1(theEnv,"instance-address",1,"'module name'");
+         SetEvaluationError(theEnv,true);
+         return;
+        }
+      if (theModule == NULL)
+        {
+         searchImports = true;
+         theModule = GetCurrentModule(theEnv);
+        }
+      else
+        searchImports = false;
+
+      if (! UDFNextArgument(context,INSTANCE_NAME_BIT | SYMBOL_BIT,&temp))
+        {
+         returnValue->lexemeValue = FalseSymbol(theEnv);
+         return;
+        }
+      ins = FindInstanceInModule(theEnv,temp.lexemeValue,theModule,
+                                 GetCurrentModule(theEnv),searchImports);
+      if (ins != NULL)
+        { returnValue->instanceValue = ins; }
+      else
+        NoInstanceError(theEnv,temp.lexemeValue->contents,"instance-address");
+     }
+   else if (UDFFirstArgument(context,INSTANCE_BITS | SYMBOL_BIT,&temp))
+     {
+      if (temp.header->type == INSTANCE_ADDRESS_TYPE)
+        {
+         ins = temp.instanceValue;
+         if (ins->garbage == 0)
+           { returnValue->instanceValue = temp.instanceValue; }
+         else
+           {
+            StaleInstanceAddress(theEnv,"instance-address",0);
+            SetEvaluationError(theEnv,true);
+           }
+        }
+      else
+        {
+         ins = FindInstanceBySymbol(theEnv,temp.lexemeValue);
+         if (ins != NULL)
+           { returnValue->instanceValue = ins; }
+         else
+           NoInstanceError(theEnv,temp.lexemeValue->contents,"instance-address");
+        }
+     }
+   else
+     { returnValue->lexemeValue = FalseSymbol(theEnv); }
+  }
+
+/***************************************************************
+  NAME         : InstanceNameCommand
+  DESCRIPTION  : Gets the name of an INSTANCE
+  INPUTS       : The address of the value buffer
+  RETURNS      : The INSTANCE_NAME_TYPE symbol
+  SIDE EFFECTS : None
+  NOTES        : H/L Syntax : (instance-name <instance>)
+ ***************************************************************/
+void InstanceNameCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   Instance *ins;
+   UDFValue theArg;
+
+   returnValue->lexemeValue = FalseSymbol(theEnv);
+   if (! UDFFirstArgument(context,INSTANCE_BITS | SYMBOL_BIT,&theArg))
+     { return; }
+
+   if (CVIsType(&theArg,INSTANCE_ADDRESS_BIT))
+     {
+      ins = theArg.instanceValue;
+      if (ins->garbage == 1)
+        {
+         StaleInstanceAddress(theEnv,"instance-name",0);
+         SetEvaluationError(theEnv,true);
+         return;
+        }
+     }
+   else
+     {
+      ins = FindInstanceBySymbol(theEnv,theArg.lexemeValue);
+      if (ins == NULL)
+        {
+         NoInstanceError(theEnv,theArg.lexemeValue->contents,"instance-name");
+         return;
+        }
+     }
+
+   returnValue->value = ins->name;
+  }
+
+/**************************************************************
+  NAME         : InstanceAddressPCommand
+  DESCRIPTION  : Determines if a value is of type INSTANCE
+  INPUTS       : None
+  RETURNS      : True if type INSTANCE_ADDRESS_TYPE, false otherwise
+  SIDE EFFECTS : None
+  NOTES        : H/L Syntax : (instance-addressp <arg>)
+ **************************************************************/
+void InstanceAddressPCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   UDFValue theArg;
+
+   if (! UDFFirstArgument(context,ANY_TYPE_BITS,&theArg))
+     { return; }
+
+   if (theArg.header->type == INSTANCE_ADDRESS_TYPE)
+     { returnValue->value = TrueSymbol(theEnv); }
+   else
+     { returnValue->value = FalseSymbol(theEnv); }
+  }
+
+/**************************************************************
+  NAME         : InstanceNamePCommand
+  DESCRIPTION  : Determines if a value is of type INSTANCE_NAME_TYPE
+  INPUTS       : None
+  RETURNS      : True if type INSTANCE_NAME_TYPE, false otherwise
+  SIDE EFFECTS : None
+  NOTES        : H/L Syntax : (instance-namep <arg>)
+ **************************************************************/
+void InstanceNamePCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   UDFValue theArg;
+
+   if (! UDFFirstArgument(context,ANY_TYPE_BITS,&theArg))
+     { return; }
+
+   returnValue->lexemeValue = CreateBoolean(theEnv,CVIsType(&theArg,INSTANCE_NAME_BIT));
+  }
+
+/*****************************************************************
+  NAME         : InstancePCommand
+  DESCRIPTION  : Determines if a value is of type INSTANCE_ADDRESS_TYPE
+                   or INSTANCE_NAME_TYPE
+  INPUTS       : None
+  RETURNS      : True if type INSTANCE_NAME_TYPE or INSTANCE_ADDRESS_TYPE,
+                     false otherwise
+  SIDE EFFECTS : None
+  NOTES        : H/L Syntax : (instancep <arg>)
+ *****************************************************************/
+void InstancePCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   UDFValue theArg;
+
+   if (! UDFFirstArgument(context,ANY_TYPE_BITS,&theArg))
+     { return; }
+
+   returnValue->lexemeValue = CreateBoolean(theEnv,CVIsType(&theArg,INSTANCE_ADDRESS_BIT | INSTANCE_NAME_BIT));
+  }
+
+/********************************************************
+  NAME         : InstanceExistPCommand
+  DESCRIPTION  : Determines if an instance exists
+  INPUTS       : None
+  RETURNS      : True if instance exists, false otherwise
+  SIDE EFFECTS : None
+  NOTES        : H/L Syntax : (instance-existp <arg>)
+ ********************************************************/
+void InstanceExistPCommand(
+  Environment *theEnv,
+  UDFContext *context,
+  UDFValue *returnValue)
+  {
+   UDFValue theArg;
+
+   if (! UDFFirstArgument(context,ANY_TYPE_BITS,&theArg))
+     { return; }
+
+   if (CVIsType(&theArg,INSTANCE_ADDRESS_BIT))
+     {
+      returnValue->lexemeValue = CreateBoolean(theEnv,(theArg.instanceValue->garbage == 0) ? true : false);
+      return;
+     }
+
+   if (CVIsType(&theArg,INSTANCE_NAME_BIT | SYMBOL_BIT))
+     {
+      returnValue->lexemeValue = CreateBoolean(theEnv,((FindInstanceBySymbol(theEnv,theArg.lexemeValue) != NULL) ?
+              true : false));
+      return;
+     }
+   ExpectedTypeError1(theEnv,"instance-existp",1,"instance name, instance address or symbol");
+   SetEvaluationError(theEnv,true);
+   returnValue->lexemeValue = FalseSymbol(theEnv);
+  }
+
+/* =========================================
+   *****************************************
+          INTERNALLY VISIBLE FUNCTIONS
+   =========================================
+   ***************************************** */
+
+#if DEBUGGING_FUNCTIONS
+
+/***************************************************
+  NAME         : ListInstancesInModule
+  DESCRIPTION  : List instances of specified
+                 class(es) in a module
+  INPUTS       : 1) Traversal id to avoid multiple
+                    passes over same class
+                 2) Logical name of output
+                 3) The name of the class
+                    (NULL for all classes)
+                 4) Flag indicating whether to
+                    include instances of subclasses
+                 5) A flag indicating whether to
+                    indent because of module name
+  RETURNS      : The number of instances listed
+  SIDE EFFECTS : Instances listed to logical output
+  NOTES        : Assumes defclass scope flags
+                 are up to date
+ ***************************************************/
+static unsigned long ListInstancesInModule(
+  Environment *theEnv,
+  int id,
+  const char *logicalName,
+  const char *className,
+  bool inheritFlag,
+  bool allModulesFlag)
+  {
+   Defclass *theDefclass;
+   Instance *theInstance;
+   unsigned long count = 0L;
+
+   /* ===================================
+      For the specified module, print out
+      instances of all the classes
+      =================================== */
+   if (className == NULL)
+     {
+      /* ==============================================
+         If instances are being listed for all modules,
+         only list the instances of classes in this
+         module (to avoid listing instances twice)
+         ============================================== */
+      if (allModulesFlag)
+        {
+         for (theDefclass = GetNextDefclass(theEnv,NULL) ;
+              theDefclass != NULL ;
+              theDefclass = GetNextDefclass(theEnv,theDefclass))
+           count += TabulateInstances(theEnv,id,logicalName,
+                                      theDefclass,false,allModulesFlag);
+        }
+
+      /* ===================================================
+         If instances are only be listed for one module,
+         list all instances visible to the module (including
+         ones belonging to classes in other modules)
+         =================================================== */
+      else
+        {
+         theInstance = GetNextInstanceInScope(theEnv,NULL);
+         while (theInstance != NULL)
+           {
+            if (GetHaltExecution(theEnv) == true)
+              { return(count); }
+
+            count++;
+            PrintInstanceNameAndClass(theEnv,logicalName,theInstance,true);
+            theInstance = GetNextInstanceInScope(theEnv,theInstance);
+           }
+        }
+     }
+
+   /* ===================================
+      For the specified module, print out
+      instances of the specified class
+      =================================== */
+   else
+     {
+      theDefclass = LookupDefclassAnywhere(theEnv,GetCurrentModule(theEnv),className);
+      if (theDefclass != NULL)
+        {
+         count += TabulateInstances(theEnv,id,logicalName,
+                                    theDefclass,inheritFlag,allModulesFlag);
+        }
+      else if (! allModulesFlag)
+        ClassExistError(theEnv,"instances",className);
+     }
+   return(count);
+  }
+
+/******************************************************
+  NAME         : TabulateInstances
+  DESCRIPTION  : Displays all instances for a class
+  INPUTS       : 1) The traversal id for the classes
+                 2) The logical name of the output
+                 3) The class address
+                 4) A flag indicating whether to
+                    print out instances of subclasses
+                    or not.
+                 5) A flag indicating whether to
+                    indent because of module name
+  RETURNS      : The number of instances (including
+                    subclasses' instances)
+  SIDE EFFECTS : None
+  NOTES        : None
+ ******************************************************/
+static unsigned long TabulateInstances(
+  Environment *theEnv,
+  int id,
+  const char *logicalName,
+  Defclass *cls,
+  bool inheritFlag,
+  bool allModulesFlag)
+  {
+   Instance *ins;
+   unsigned long i;
+   unsigned long count = 0;
+
+   if (TestTraversalID(cls->traversalRecord,id))
+     return 0L;
+     
+   SetTraversalID(cls->traversalRecord,id);
+   for (ins = cls->instanceList ; ins != NULL ; ins = ins->nxtClass)
+     {
+      if (EvaluationData(theEnv)->HaltExecution)
+        return count;
+      if (allModulesFlag)
+        WriteString(theEnv,logicalName,"   ");
+      PrintInstanceNameAndClass(theEnv,logicalName,ins,true);
+      count++;
+     }
+     
+   if (inheritFlag)
+     {
+      for (i = 0 ; i < cls->directSubclasses.classCount ; i++)
+        {
+         if (EvaluationData(theEnv)->HaltExecution)
+           return count;
+         count += TabulateInstances(theEnv,id,logicalName,
+                     cls->directSubclasses.classArray[i],inheritFlag,allModulesFlag);
+        }
+     }
+    
+   return count;
+  }
+
+#endif
+
+/***************************************************
+  NAME         : PrintInstance
+  DESCRIPTION  : Displays an instance's slots
+  INPUTS       : 1) Logical name for output
+                 2) Instance address
+                 3) String used to separate
+                    slot printouts
+  RETURNS      : Nothing useful
+  SIDE EFFECTS : None
+  NOTES        : Assumes instance is valid
+ ***************************************************/
+static void PrintInstance(
+  Environment *theEnv,
+  const char *logicalName,
+  Instance *ins,
+  const char *separator)
+  {
+   long i;
+   InstanceSlot *sp;
+
+   PrintInstanceNameAndClass(theEnv,logicalName,ins,false);
+   for (i = 0 ; i < ins->cls->instanceSlotCount ; i++)
+     {
+      WriteString(theEnv,logicalName,separator);
+      sp = ins->slotAddresses[i];
+      WriteString(theEnv,logicalName,"(");
+      WriteString(theEnv,logicalName,sp->desc->slotName->name->contents);
+      if (sp->type != MULTIFIELD_TYPE)
+        {
+         WriteString(theEnv,logicalName," ");
+         PrintAtom(theEnv,logicalName,sp->type,sp->value);
+        }
+      else if (sp->multifieldValue->length != 0)
+        {
+         WriteString(theEnv,logicalName," ");
+         PrintMultifieldDriver(theEnv,logicalName,sp->multifieldValue,0,
+                               sp->multifieldValue->length,false);
+        }
+      WriteString(theEnv,logicalName,")");
+     }
+  }
+
+/***************************************************
+  NAME         : FindISlotByName
+  DESCRIPTION  : Looks up an instance slot by
+                   instance name and slot name
+  INPUTS       : 1) Instance address
+                 2) Instance name-string
+  RETURNS      : The instance slot address, NULL if
+                   does not exist
+  SIDE EFFECTS : None
+  NOTES        : None
+ ***************************************************/
+static InstanceSlot *FindISlotByName(
+  Environment *theEnv,
+  Instance *theInstance,
+  const char *sname)
+  {
+   CLIPSLexeme *ssym;
+
+   ssym = FindSymbolHN(theEnv,sname,SYMBOL_BIT);
+
+   if (ssym == NULL)
+     { return NULL; }
+
+   return FindInstanceSlot(theEnv,theInstance,ssym);
+  }
+
+#endif /* OBJECT_SYSTEM */
+