   /*******************************************************/
   /*      "C" Language Integrated Production System      */
   /*                                                     */
   /*             CLIPS Version 6.31  05/09/19            */
   /*                                                     */
   /*                                                     */
   /*******************************************************/

/*************************************************************/
/* Purpose: Generic Functions Interface Routines             */
/*                                                           */
/* Principal Programmer(s):                                  */
/*      Brian L. Dantes                                      */
/*                                                           */
/* Contributing Programmer(s):                               */
/*                                                           */
/* Revision History:                                         */
/*      6.23: Correction for FalseSymbol/TrueSymbol. DR0859  */
/*                                                           */
/*            Corrected compilation errors for files         */
/*            generated by constructs-to-c. DR0861           */
/*                                                           */
/*            Changed name of variable log to logName        */
/*            because of Unix compiler warnings of shadowed  */
/*            definitions.                                   */
/*                                                           */
/*      6.24: Removed IMPERATIVE_METHODS compilation flag.   */
/*                                                           */
/*            Renamed BOOLEAN macro type to intBool.         */
/*                                                           */
/*            Corrected code to remove run-time program      */
/*            compiler warning.                              */
/*                                                           */
/*      6.30: Removed conditional code for unsupported       */
/*            compilers/operating systems (IBM_MCW,          */
/*            MAC_MCW, and IBM_TBC).                         */
/*                                                           */
/*            Changed integer type/precision.                */
/*                                                           */
/*            Added const qualifiers to remove C++           */
/*            deprecation warnings.                          */
/*                                                           */
/*            Converted API macros to function calls.        */
/*                                                           */
/*            Fixed linkage issue when DEBUGGING_FUNCTIONS   */
/*            is set to 0 and PROFILING_FUNCTIONS is set to  */
/*            1.                                             */
/*                                                           */
/*            Changed find construct functionality so that   */
/*            imported modules are search when locating a    */
/*            named construct.                               */
/*                                                           */
/*            Added code to keep track of pointers to        */
/*            constructs that are contained externally to    */
/*            to constructs, DanglingConstructs.             */
/*                                                           */
/*************************************************************/

/* =========================================
   *****************************************
               EXTERNAL DEFINITIONS
   =========================================
   ***************************************** */
#include "setup.h"

#if DEFGENERIC_CONSTRUCT

#include <string.h>

#if DEFRULE_CONSTRUCT
#include "network.h"
#endif

#if BLOAD || BLOAD_AND_BSAVE
#include "bload.h"
#endif

#if BLOAD || BLOAD_ONLY || BLOAD_AND_BSAVE
#include "genrcbin.h"
#endif

#if CONSTRUCT_COMPILER
#include "genrccmp.h"
#endif

#if (! BLOAD_ONLY) && (! RUN_TIME)
#include "constrct.h"
#include "genrcpsr.h"
#endif

#if OBJECT_SYSTEM
#include "classcom.h"
#include "inscom.h"
#endif

#if DEBUGGING_FUNCTIONS
#include "watch.h"
#endif

#include "argacces.h"
#include "cstrcpsr.h"
#include "envrnmnt.h"
#include "extnfunc.h"
#include "genrcexe.h"
#include "memalloc.h"
#include "modulpsr.h"
#include "multifld.h"
#include "router.h"

#define _GENRCCOM_SOURCE_
#include "genrccom.h"

/* =========================================
   *****************************************
      INTERNALLY VISIBLE FUNCTION HEADERS
   =========================================
   ***************************************** */

static void PrintGenericCall(void *,const char *,void *);
static intBool EvaluateGenericCall(void *,void *,DATA_OBJECT *);
static void DecrementGenericBusyCount(void *,void *);
static void IncrementGenericBusyCount(void *,void *);
static void DeallocateDefgenericData(void *);
#if ! RUN_TIME
static void DestroyDefgenericAction(void *,struct constructHeader *,void *);
#endif

#if (! BLOAD_ONLY) && (! RUN_TIME)

static void SaveDefgenerics(void *,void *,const char *);
static void SaveDefmethods(void *,void *,const char *);
static void SaveDefmethodsForDefgeneric(void *,struct constructHeader *,void *);
static void RemoveDefgenericMethod(void *,DEFGENERIC *,long);

#endif

#if DEBUGGING_FUNCTIONS
static long ListMethodsForGeneric(void *,const char *,DEFGENERIC *);
static unsigned DefgenericWatchAccess(void *,int,unsigned,EXPRESSION *);
static unsigned DefgenericWatchPrint(void *,const char *,int,EXPRESSION *);
static unsigned DefmethodWatchAccess(void *,int,unsigned,EXPRESSION *);
static unsigned DefmethodWatchPrint(void *,const char *,int,EXPRESSION *);
static unsigned DefmethodWatchSupport(void *,const char *,const char *,unsigned,
                                     void (*)(void *,const char *,void *,long),
                                     void (*)(void *,unsigned,void *,long),
                                     EXPRESSION *);
static void PrintMethodWatchFlag(void *,const char *,void *,long);
#endif

/* =========================================
   *****************************************
          EXTERNALLY VISIBLE FUNCTIONS
   =========================================
   ***************************************** */

/***********************************************************
  NAME         : SetupGenericFunctions
  DESCRIPTION  : Initializes all generic function
                   data structures, constructs and functions
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : Generic function H/L functions set up
  NOTES        : None
 ***********************************************************/
globle void SetupGenericFunctions(
  void *theEnv)
  {
   ENTITY_RECORD genericEntityRecord =
                     { "GCALL", GCALL,0,0,1,
                       PrintGenericCall,PrintGenericCall,
                       NULL,EvaluateGenericCall,NULL,
                       DecrementGenericBusyCount,IncrementGenericBusyCount,
                       NULL,NULL,NULL,NULL,NULL };
   
   AllocateEnvironmentData(theEnv,DEFGENERIC_DATA,sizeof(struct defgenericData),DeallocateDefgenericData);
   memcpy(&DefgenericData(theEnv)->GenericEntityRecord,&genericEntityRecord,sizeof(struct entityRecord));   

   InstallPrimitive(theEnv,&DefgenericData(theEnv)->GenericEntityRecord,GCALL);

   DefgenericData(theEnv)->DefgenericModuleIndex =
                RegisterModuleItem(theEnv,"defgeneric",
#if (! RUN_TIME)
                                    AllocateDefgenericModule,FreeDefgenericModule,
#else
                                    NULL,NULL,
#endif
#if BLOAD_AND_BSAVE || BLOAD || BLOAD_ONLY
                                    BloadDefgenericModuleReference,
#else
                                    NULL,
#endif
#if CONSTRUCT_COMPILER && (! RUN_TIME)
                                    DefgenericCModuleReference,
#else
                                    NULL,
#endif
                                    EnvFindDefgenericInModule);

   DefgenericData(theEnv)->DefgenericConstruct =  AddConstruct(theEnv,"defgeneric","defgenerics",
#if (! BLOAD_ONLY) && (! RUN_TIME)
                                       ParseDefgeneric,
#else
                                       NULL,
#endif
                                       EnvFindDefgeneric,
                                       GetConstructNamePointer,GetConstructPPForm,
                                       GetConstructModuleItem,EnvGetNextDefgeneric,
                                       SetNextConstruct,EnvIsDefgenericDeletable,
                                       EnvUndefgeneric,
#if (! BLOAD_ONLY) && (! RUN_TIME)
                                       RemoveDefgeneric
#else
                                       NULL
#endif
                                       );

#if ! RUN_TIME
   AddClearReadyFunction(theEnv,"defgeneric",ClearDefgenericsReady,0);

#if BLOAD || BLOAD_ONLY || BLOAD_AND_BSAVE
   SetupGenericsBload(theEnv);
#endif

#if CONSTRUCT_COMPILER
   SetupGenericsCompiler(theEnv);
#endif

#if ! BLOAD_ONLY
#if DEFMODULE_CONSTRUCT
   AddPortConstructItem(theEnv,"defgeneric",SYMBOL);
#endif
   AddConstruct(theEnv,"defmethod","defmethods",ParseDefmethod,
                NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL);

  /* ================================================================
     Make sure defmethods are cleared last, for other constructs may
       be using them and need to be cleared first

     Need to be cleared in two stages so that mutually dependent
       constructs (like classes) can be cleared
     ================================================================ */
   AddSaveFunction(theEnv,"defgeneric",SaveDefgenerics,1000);
   AddSaveFunction(theEnv,"defmethod",SaveDefmethods,-1000);
   EnvDefineFunction2(theEnv,"undefgeneric",'v',PTIEF UndefgenericCommand,"UndefgenericCommand","11w");
   EnvDefineFunction2(theEnv,"undefmethod",'v',PTIEF UndefmethodCommand,"UndefmethodCommand","22*wg");
#endif

   EnvDefineFunction2(theEnv,"call-next-method",'u',PTIEF CallNextMethod,"CallNextMethod","00");
   FuncSeqOvlFlags(theEnv,"call-next-method",TRUE,FALSE);
   EnvDefineFunction2(theEnv,"call-specific-method",'u',PTIEF CallSpecificMethod,
                   "CallSpecificMethod","2**wi");
   FuncSeqOvlFlags(theEnv,"call-specific-method",TRUE,FALSE);
   EnvDefineFunction2(theEnv,"override-next-method",'u',PTIEF OverrideNextMethod,
                   "OverrideNextMethod",NULL);
   FuncSeqOvlFlags(theEnv,"override-next-method",TRUE,FALSE);
   EnvDefineFunction2(theEnv,"next-methodp",'b',PTIEF NextMethodP,"NextMethodP","00");
   FuncSeqOvlFlags(theEnv,"next-methodp",TRUE,FALSE);

   EnvDefineFunction2(theEnv,"(gnrc-current-arg)",'u',PTIEF GetGenericCurrentArgument,
                   "GetGenericCurrentArgument",NULL);

#if DEBUGGING_FUNCTIONS
   EnvDefineFunction2(theEnv,"ppdefgeneric",'v',PTIEF PPDefgenericCommand,"PPDefgenericCommand","11w");
   EnvDefineFunction2(theEnv,"list-defgenerics",'v',PTIEF ListDefgenericsCommand,"ListDefgenericsCommand","01");
   EnvDefineFunction2(theEnv,"ppdefmethod",'v',PTIEF PPDefmethodCommand,"PPDefmethodCommand","22*wi");
   EnvDefineFunction2(theEnv,"list-defmethods",'v',PTIEF ListDefmethodsCommand,"ListDefmethodsCommand","01w");
   EnvDefineFunction2(theEnv,"preview-generic",'v',PTIEF PreviewGeneric,"PreviewGeneric","1**w");
#endif

   EnvDefineFunction2(theEnv,"get-defgeneric-list",'m',PTIEF GetDefgenericListFunction,
                   "GetDefgenericListFunction","01");
   EnvDefineFunction2(theEnv,"get-defmethod-list",'m',PTIEF GetDefmethodListCommand,
                   "GetDefmethodListCommand","01w");
   EnvDefineFunction2(theEnv,"get-method-restrictions",'m',PTIEF GetMethodRestrictionsCommand,
                   "GetMethodRestrictionsCommand","22iw");
   EnvDefineFunction2(theEnv,"defgeneric-module",'w',PTIEF GetDefgenericModuleCommand,
                   "GetDefgenericModuleCommand","11w");

#if OBJECT_SYSTEM
   EnvDefineFunction2(theEnv,"type",'u',PTIEF ClassCommand,"ClassCommand","11u");
#else
   EnvDefineFunction2(theEnv,"type",'u',PTIEF TypeCommand,"TypeCommand","11u");
#endif

#endif

#if DEBUGGING_FUNCTIONS
   AddWatchItem(theEnv,"generic-functions",0,&DefgenericData(theEnv)->WatchGenerics,34,
                DefgenericWatchAccess,DefgenericWatchPrint);
   AddWatchItem(theEnv,"methods",0,&DefgenericData(theEnv)->WatchMethods,33,
                DefmethodWatchAccess,DefmethodWatchPrint);
#endif
  }
  
/*****************************************************/
/* DeallocateDefgenericData: Deallocates environment */
/*    data for the defgeneric construct.             */
/*****************************************************/
static void DeallocateDefgenericData(
  void *theEnv)
  {
#if ! RUN_TIME
   struct defgenericModule *theModuleItem;
   void *theModule;

#if BLOAD || BLOAD_AND_BSAVE
   if (Bloaded(theEnv)) return;
#endif

   DoForAllConstructs(theEnv,DestroyDefgenericAction,DefgenericData(theEnv)->DefgenericModuleIndex,FALSE,NULL); 

   for (theModule = EnvGetNextDefmodule(theEnv,NULL);
        theModule != NULL;
        theModule = EnvGetNextDefmodule(theEnv,theModule))
     {
      theModuleItem = (struct defgenericModule *)
                      GetModuleItem(theEnv,(struct defmodule *) theModule,
                                    DefgenericData(theEnv)->DefgenericModuleIndex);

      rtn_struct(theEnv,defgenericModule,theModuleItem);
     }
#else
#if MAC_XCD
#pragma unused(theEnv)
#endif
#endif
  }
  
#if ! RUN_TIME
/****************************************************/
/* DestroyDefgenericAction: Action used to remove   */
/*   defgenerics as a result of DestroyEnvironment. */
/****************************************************/
static void DestroyDefgenericAction(
  void *theEnv,
  struct constructHeader *theConstruct,
  void *buffer)
  {
#if MAC_XCD
#pragma unused(buffer)
#endif
#if (! BLOAD_ONLY) && (! RUN_TIME)
   struct defgeneric *theDefgeneric = (struct defgeneric *) theConstruct;
   long i;
   
   if (theDefgeneric == NULL) return;

   for (i = 0 ; i < theDefgeneric->mcnt ; i++)
     { DestroyMethodInfo(theEnv,theDefgeneric,&theDefgeneric->methods[i]); }

   if (theDefgeneric->mcnt != 0)
     rm(theEnv,(void *) theDefgeneric->methods,(sizeof(DEFMETHOD) * theDefgeneric->mcnt));

   DestroyConstructHeader(theEnv,&theDefgeneric->header);

   rtn_struct(theEnv,defgeneric,theDefgeneric);
#else
#if MAC_XCD
#pragma unused(theEnv,theConstruct)
#endif
#endif
  }
#endif

/***************************************************
  NAME         : EnvFindDefgeneric
  DESCRIPTION  : Searches for a generic
  INPUTS       : The name of the generic
                 (possibly including a module name)
  RETURNS      : Pointer to the generic if
                 found, otherwise NULL
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
globle void *EnvFindDefgeneric(
  void *theEnv,
  const char *genericModuleAndName)
  {
   return(FindNamedConstructInModuleOrImports(theEnv,genericModuleAndName,DefgenericData(theEnv)->DefgenericConstruct));
  }

/***************************************************
  NAME         : EnvFindDefgenericInModule
  DESCRIPTION  : Searches for a generic
  INPUTS       : The name of the generic
                 (possibly including a module name)
  RETURNS      : Pointer to the generic if
                 found, otherwise NULL
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
globle void *EnvFindDefgenericInModule(
  void *theEnv,
  const char *genericModuleAndName)
  {
   return(FindNamedConstructInModule(theEnv,genericModuleAndName,DefgenericData(theEnv)->DefgenericConstruct));
  }

/***************************************************
  NAME         : LookupDefgenericByMdlOrScope
  DESCRIPTION  : Finds a defgeneric anywhere (if
                 module is specified) or in current
                 or imported modules
  INPUTS       : The defgeneric name
  RETURNS      : The defgeneric (NULL if not found)
  SIDE EFFECTS : Error message printed on
                  ambiguous references
  NOTES        : None
 ***************************************************/
globle DEFGENERIC *LookupDefgenericByMdlOrScope(
  void *theEnv,
  const char *defgenericName)
  {
   return((DEFGENERIC *) LookupConstruct(theEnv,DefgenericData(theEnv)->DefgenericConstruct,defgenericName,TRUE));
  }

/***************************************************
  NAME         : LookupDefgenericInScope
  DESCRIPTION  : Finds a defgeneric in current or
                   imported modules (module
                   specifier is not allowed)
  INPUTS       : The defgeneric name
  RETURNS      : The defgeneric (NULL if not found)
  SIDE EFFECTS : Error message printed on
                  ambiguous references
  NOTES        : None
 ***************************************************/
globle DEFGENERIC *LookupDefgenericInScope(
  void *theEnv,
  const char *defgenericName)
  {
   return((DEFGENERIC *) LookupConstruct(theEnv,DefgenericData(theEnv)->DefgenericConstruct,defgenericName,FALSE));
  }

/***********************************************************
  NAME         : EnvGetNextDefgeneric
  DESCRIPTION  : Finds first or next generic function
  INPUTS       : The address of the current generic function
  RETURNS      : The address of the next generic function
                   (NULL if none)
  SIDE EFFECTS : None
  NOTES        : If ptr == NULL, the first generic function
                    is returned.
 ***********************************************************/
globle void *EnvGetNextDefgeneric(
  void *theEnv,
  void *ptr)
  {
   return((void *) GetNextConstructItem(theEnv,(struct constructHeader *) ptr,DefgenericData(theEnv)->DefgenericModuleIndex));
  }

/***********************************************************
  NAME         : EnvGetNextDefmethod
  DESCRIPTION  : Find the next method for a generic function
  INPUTS       : 1) The generic function address
                 2) The index of the current method
  RETURNS      : The index of the next method
                    (0 if none)
  SIDE EFFECTS : None
  NOTES        : If index == 0, the index of the first
                   method is returned
 ***********************************************************/
globle long EnvGetNextDefmethod(
  void *theEnv,
  void *ptr,
  long theIndex)
  {
   DEFGENERIC *gfunc;
   long mi;
#if MAC_XCD
#pragma unused(theEnv)
#endif

   gfunc = (DEFGENERIC *) ptr;
   if (theIndex == 0)
     {
      if (gfunc->methods != NULL)
        return(gfunc->methods[0].index);
      return(0);
     }
   mi = FindMethodByIndex(gfunc,theIndex);
   if ((mi+1) == gfunc->mcnt)
     return(0);
   return(gfunc->methods[mi+1].index);
  }

/*****************************************************
  NAME         : GetDefmethodPointer
  DESCRIPTION  : Returns a pointer to a method
  INPUTS       : 1) Pointer to a defgeneric
                 2) Array index of method in generic's
                    method array (+1)
  RETURNS      : Pointer to the method.
  SIDE EFFECTS : None
  NOTES        : None
 *****************************************************/
globle DEFMETHOD *GetDefmethodPointer(
  void *ptr,
  long theIndex)
  {
   return(&((DEFGENERIC *) ptr)->methods[theIndex-1]);
  }

/***************************************************
  NAME         : EnvIsDefgenericDeletable
  DESCRIPTION  : Determines if a generic function
                   can be deleted
  INPUTS       : Address of the generic function
  RETURNS      : TRUE if deletable, FALSE otherwise
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
globle int EnvIsDefgenericDeletable(
  void *theEnv,
  void *ptr)
  {
   if (! ConstructsDeletable(theEnv))
     { return FALSE; }

   return ((((DEFGENERIC *) ptr)->busy == 0) ? TRUE : FALSE);
  }

/***************************************************
  NAME         : EnvIsDefmethodDeletable
  DESCRIPTION  : Determines if a generic function
                   method can be deleted
  INPUTS       : 1) Address of the generic function
                 2) Index of the method
  RETURNS      : TRUE if deletable, FALSE otherwise
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
globle int EnvIsDefmethodDeletable(
  void *theEnv,
  void *ptr,
  long theIndex)
  {
   if (! ConstructsDeletable(theEnv))
     { return FALSE; }

   if (((DEFGENERIC *) ptr)->methods[FindMethodByIndex((DEFGENERIC *) ptr,theIndex)].system)
     return(FALSE);
   
#if (! BLOAD_ONLY) && (! RUN_TIME)
   return((MethodsExecuting((DEFGENERIC *) ptr) == FALSE) ? TRUE : FALSE);
#else
   return FALSE;
#endif
  }

/**********************************************************
  NAME         : UndefgenericCommand
  DESCRIPTION  : Deletes all methods for a generic function
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : methods deallocated
  NOTES        : H/L Syntax: (undefgeneric <name> | *)
 **********************************************************/
globle void UndefgenericCommand(
  void *theEnv)
  {
   UndefconstructCommand(theEnv,"undefgeneric",DefgenericData(theEnv)->DefgenericConstruct);
  }

/****************************************************************
  NAME         : GetDefgenericModuleCommand
  DESCRIPTION  : Determines to which module a defgeneric belongs
  INPUTS       : None
  RETURNS      : The symbolic name of the module
  SIDE EFFECTS : None
  NOTES        : H/L Syntax: (defgeneric-module <generic-name>)
 ****************************************************************/
globle void *GetDefgenericModuleCommand(
  void *theEnv)
  {
   return(GetConstructModuleCommand(theEnv,"defgeneric-module",DefgenericData(theEnv)->DefgenericConstruct));
  }

/**************************************************************
  NAME         : UndefmethodCommand
  DESCRIPTION  : Deletes one method for a generic function
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : methods deallocated
  NOTES        : H/L Syntax: (undefmethod <name> <index> | *)
 **************************************************************/
globle void UndefmethodCommand(
  void *theEnv)
  {
   DATA_OBJECT temp;
   DEFGENERIC *gfunc;
   long mi;

   if (EnvArgTypeCheck(theEnv,"undefmethod",1,SYMBOL,&temp) == FALSE)
     return;
   gfunc = LookupDefgenericByMdlOrScope(theEnv,DOToString(temp));
   if ((gfunc == NULL) ? (strcmp(DOToString(temp),"*") != 0) : FALSE)
     {
      PrintErrorID(theEnv,"GENRCCOM",1,FALSE);
      EnvPrintRouter(theEnv,WERROR,"No such generic function ");
      EnvPrintRouter(theEnv,WERROR,DOToString(temp));
      EnvPrintRouter(theEnv,WERROR," in function undefmethod.\n");
      return;
     }
   EnvRtnUnknown(theEnv,2,&temp);
   if (temp.type == SYMBOL)
     {
      if (strcmp(DOToString(temp),"*") != 0)
        {
         PrintErrorID(theEnv,"GENRCCOM",2,FALSE);
         EnvPrintRouter(theEnv,WERROR,"Expected a valid method index in function undefmethod.\n");
         return;
        }
      mi = 0;
     }
   else if (temp.type == INTEGER)
     {
      mi = (long) DOToLong(temp);
      if (mi == 0)
        {
         PrintErrorID(theEnv,"GENRCCOM",2,FALSE);
         EnvPrintRouter(theEnv,WERROR,"Expected a valid method index in function undefmethod.\n");
         return;
        }
     }
   else
     {
      PrintErrorID(theEnv,"GENRCCOM",2,FALSE);
      EnvPrintRouter(theEnv,WERROR,"Expected a valid method index in function undefmethod.\n");
      return;
     }
   EnvUndefmethod(theEnv,(void *) gfunc,mi);
  }

/**************************************************************
  NAME         : EnvUndefgeneric
  DESCRIPTION  : Deletes all methods for a generic function
  INPUTS       : The generic-function address (NULL for all)
  RETURNS      : TRUE if generic successfully deleted,
                 FALSE otherwise
  SIDE EFFECTS : methods deallocated
  NOTES        : None
 **************************************************************/
globle intBool EnvUndefgeneric(
  void *theEnv,
  void *vptr)
  {
#if RUN_TIME || BLOAD_ONLY
   return(FALSE);
#else
   DEFGENERIC *gfunc;
   int success = TRUE;

   gfunc = (DEFGENERIC *) vptr;
   if (gfunc == NULL)
     {
      if (ClearDefmethods(theEnv) == FALSE)
        success = FALSE;
      if (ClearDefgenerics(theEnv) == FALSE)
        success = FALSE;
      return(success);
     }
   if (EnvIsDefgenericDeletable(theEnv,vptr) == FALSE)
     return(FALSE);
   RemoveConstructFromModule(theEnv,(struct constructHeader *) vptr);
   RemoveDefgeneric(theEnv,gfunc);
   return(TRUE);
#endif
  }

/**************************************************************
  NAME         : EnvUndefmethod
  DESCRIPTION  : Deletes one method for a generic function
  INPUTS       : 1) Address of generic function (can be NULL)
                 2) Method index (0 for all)
  RETURNS      : TRUE if method deleted successfully,
                 FALSE otherwise
  SIDE EFFECTS : methods deallocated
  NOTES        : None
 **************************************************************/
globle intBool EnvUndefmethod(
  void *theEnv,
  void *vptr,
  long mi)
  {
   DEFGENERIC *gfunc;

#if RUN_TIME || BLOAD_ONLY
   gfunc = (DEFGENERIC *) vptr;
   PrintErrorID(theEnv,"PRNTUTIL",4,FALSE);
   EnvPrintRouter(theEnv,WERROR,"Unable to delete method ");
   if (gfunc != NULL)
     {
      PrintGenericName(theEnv,WERROR,gfunc);
      EnvPrintRouter(theEnv,WERROR," #");
      PrintLongInteger(theEnv,WERROR,(long long) mi);
     }
   else
     EnvPrintRouter(theEnv,WERROR,"*");
   EnvPrintRouter(theEnv,WERROR,".\n");
   return(FALSE);
#else
   long nmi;

   gfunc = (DEFGENERIC *) vptr;
#if BLOAD || BLOAD_AND_BSAVE
   if (Bloaded(theEnv) == TRUE)
     {
      PrintErrorID(theEnv,"PRNTUTIL",4,FALSE);
      EnvPrintRouter(theEnv,WERROR,"Unable to delete method ");
      if (gfunc != NULL)
        {
         EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) gfunc));
         EnvPrintRouter(theEnv,WERROR," #");
         PrintLongInteger(theEnv,WERROR,(long long) mi);
        }
      else
        EnvPrintRouter(theEnv,WERROR,"*");
      EnvPrintRouter(theEnv,WERROR,".\n");
      return(FALSE);
     }
#endif
   if (gfunc == NULL)
     {
      if (mi != 0)
        {
         PrintErrorID(theEnv,"GENRCCOM",3,FALSE);
         EnvPrintRouter(theEnv,WERROR,"Incomplete method specification for deletion.\n");
         return(FALSE);
        }
      return(ClearDefmethods(theEnv));
     }
   if (MethodsExecuting(gfunc))
     {
      MethodAlterError(theEnv,gfunc);
      return(FALSE);
     }
   if (mi == 0)
     RemoveAllExplicitMethods(theEnv,gfunc);
   else
     {
      nmi = CheckMethodExists(theEnv,"undefmethod",gfunc,mi);
      if (nmi == -1)
        return(FALSE);
      RemoveDefgenericMethod(theEnv,gfunc,nmi);
     }
   return(TRUE);
#endif
  }

#if DEBUGGING_FUNCTIONS || PROFILING_FUNCTIONS

/*****************************************************
  NAME         : EnvGetDefmethodDescription
  DESCRIPTION  : Prints a synopsis of method parameter
                   restrictions into caller's buffer
  INPUTS       : 1) Caller's buffer
                 2) Buffer size (not including space
                    for terminating '\0')
                 3) Address of generic function
                 4) Index of method
  RETURNS      : Nothing useful
  SIDE EFFECTS : Caller's buffer written
  NOTES        : Terminating '\n' not written
 *****************************************************/
globle void EnvGetDefmethodDescription(
  void *theEnv,
  char *buf,
  size_t buflen,
  void *ptr,
  long theIndex)
  {
   DEFGENERIC *gfunc;
   long mi;
#if MAC_XCD
#pragma unused(theEnv)
#endif

   gfunc = (DEFGENERIC *) ptr;
   mi = FindMethodByIndex(gfunc,theIndex);
   PrintMethod(theEnv,buf,buflen,&gfunc->methods[mi]);
  }
#endif /* DEBUGGING_FUNCTIONS || PROFILING_FUNCTIONS */

#if DEBUGGING_FUNCTIONS

/*********************************************************
  NAME         : EnvGetDefgenericWatch
  DESCRIPTION  : Determines if trace messages are
                 gnerated when executing generic function
  INPUTS       : A pointer to the generic
  RETURNS      : TRUE if a trace is active,
                 FALSE otherwise
  SIDE EFFECTS : None
  NOTES        : None
 *********************************************************/
globle unsigned EnvGetDefgenericWatch(
  void *theEnv,
  void *theGeneric)
  {
#if MAC_XCD
#pragma unused(theEnv)
#endif

   return(((DEFGENERIC *) theGeneric)->trace);
  }

/*********************************************************
  NAME         : EnvSetDefgenericWatch
  DESCRIPTION  : Sets the trace to ON/OFF for the
                 generic function
  INPUTS       : 1) TRUE to set the trace on,
                    FALSE to set it off
                 2) A pointer to the generic
  RETURNS      : Nothing useful
  SIDE EFFECTS : Watch flag for the generic set
  NOTES        : None
 *********************************************************/
globle void EnvSetDefgenericWatch(
  void *theEnv,
  unsigned newState,
  void *theGeneric)
  {
#if MAC_XCD
#pragma unused(theEnv)
#endif

   ((DEFGENERIC *) theGeneric)->trace = newState;
  }

/*********************************************************
  NAME         : EnvGetDefmethodWatch
  DESCRIPTION  : Determines if trace messages for calls
                 to this method will be generated or not
  INPUTS       : 1) A pointer to the generic
                 2) The index of the method
  RETURNS      : TRUE if a trace is active,
                 FALSE otherwise
  SIDE EFFECTS : None
  NOTES        : None
 *********************************************************/
globle unsigned EnvGetDefmethodWatch(
  void *theEnv,
  void *theGeneric,
  long theIndex)
  {
   DEFGENERIC *gfunc;
   long mi;
#if MAC_XCD
#pragma unused(theEnv)
#endif

   gfunc = (DEFGENERIC *) theGeneric;
   mi = FindMethodByIndex(gfunc,theIndex);
   return(gfunc->methods[mi].trace);
  }

/*********************************************************
  NAME         : EnvSetDefmethodWatch
  DESCRIPTION  : Sets the trace to ON/OFF for the
                 calling of the method
  INPUTS       : 1) TRUE to set the trace on,
                    FALSE to set it off
                 2) A pointer to the generic
                 3) The index of the method
  RETURNS      : Nothing useful
  SIDE EFFECTS : Watch flag for the method set
  NOTES        : None
 *********************************************************/
globle void EnvSetDefmethodWatch(
  void *theEnv,
  unsigned newState,
  void *theGeneric,
  long theIndex)
  {
   DEFGENERIC *gfunc;
   long mi;
#if MAC_XCD
#pragma unused(theEnv)
#endif

   gfunc = (DEFGENERIC *) theGeneric;
   mi = FindMethodByIndex(gfunc,theIndex);
   gfunc->methods[mi].trace = newState;
  }


/********************************************************
  NAME         : PPDefgenericCommand
  DESCRIPTION  : Displays the pretty-print form of
                  a generic function header
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : H/L Syntax: (ppdefgeneric <name>)
 ********************************************************/
globle void PPDefgenericCommand(
  void *theEnv)
  {
   PPConstructCommand(theEnv,"ppdefgeneric",DefgenericData(theEnv)->DefgenericConstruct);
  }

/**********************************************************
  NAME         : PPDefmethodCommand
  DESCRIPTION  : Displays the pretty-print form of
                  a method
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : H/L Syntax: (ppdefmethod <name> <index>)
 **********************************************************/
globle void PPDefmethodCommand(
  void *theEnv)
  {
   DATA_OBJECT temp;
   const char *gname;
   DEFGENERIC *gfunc;
   int gi;
   
   if (EnvArgTypeCheck(theEnv,"ppdefmethod",1,SYMBOL,&temp) == FALSE)
     return;
   gname = DOToString(temp);
   if (EnvArgTypeCheck(theEnv,"ppdefmethod",2,INTEGER,&temp) == FALSE)
     return;
   gfunc = CheckGenericExists(theEnv,"ppdefmethod",gname);
   if (gfunc == NULL)
     return;
   gi = CheckMethodExists(theEnv,"ppdefmethod",gfunc,(long) DOToLong(temp));
   if (gi == -1)
     return;
   if (gfunc->methods[gi].ppForm != NULL)
     PrintInChunks(theEnv,WDISPLAY,gfunc->methods[gi].ppForm);
  }

/******************************************************
  NAME         : ListDefmethodsCommand
  DESCRIPTION  : Lists a brief description of methods
                   for a particular generic function
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : H/L Syntax: (list-defmethods <name>)
 ******************************************************/
globle void ListDefmethodsCommand(
  void *theEnv)
  {
   DATA_OBJECT temp;
   DEFGENERIC *gfunc;
   
   if (EnvRtnArgCount(theEnv) == 0)
     EnvListDefmethods(theEnv,WDISPLAY,NULL);
   else
     {
      if (EnvArgTypeCheck(theEnv,"list-defmethods",1,SYMBOL,&temp) == FALSE)
        return;
      gfunc = CheckGenericExists(theEnv,"list-defmethods",DOToString(temp));
      if (gfunc != NULL)
        EnvListDefmethods(theEnv,WDISPLAY,(void *) gfunc);
     }
  }

/***************************************************************
  NAME         : EnvGetDefmethodPPForm
  DESCRIPTION  : Getsa generic function method pretty print form
  INPUTS       : 1) Address of the generic function
                 2) Index of the method
  RETURNS      : Method ppform
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************************/
globle const char *EnvGetDefmethodPPForm(
  void *theEnv,
  void *ptr,
  long theIndex)
  {
   DEFGENERIC *gfunc;
   int mi;
#if MAC_XCD
#pragma unused(theEnv)
#endif

   gfunc = (DEFGENERIC *) ptr;
   mi = FindMethodByIndex(gfunc,theIndex);
   return(gfunc->methods[mi].ppForm);
  }

/***************************************************
  NAME         : ListDefgenericsCommand
  DESCRIPTION  : Displays all defgeneric names
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : Defgeneric names printed
  NOTES        : H/L Interface
 ***************************************************/
globle void ListDefgenericsCommand(
  void *theEnv)
  {
   ListConstructCommand(theEnv,"list-defgenerics",DefgenericData(theEnv)->DefgenericConstruct);
  }

/***************************************************
  NAME         : EnvListDefgenerics
  DESCRIPTION  : Displays all defgeneric names
  INPUTS       : 1) The logical name of the output
                 2) The module
  RETURNS      : Nothing useful
  SIDE EFFECTS : Defgeneric names printed
  NOTES        : C Interface
 ***************************************************/
globle void EnvListDefgenerics(
  void *theEnv,
  const char *logicalName,
  struct defmodule *theModule)
  {
   ListConstruct(theEnv,DefgenericData(theEnv)->DefgenericConstruct,logicalName,theModule);
  }

/******************************************************
  NAME         : EnvListDefmethods
  DESCRIPTION  : Lists a brief description of methods
                   for a particular generic function
  INPUTS       : 1) The logical name of the output
                 2) Generic function to list methods for
                    (NULL means list all methods)
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : None
 ******************************************************/
globle void EnvListDefmethods(
  void *theEnv,
  const char *logicalName,
  void *vptr)
  {
   DEFGENERIC *gfunc;
   long count;
   if (vptr != NULL)
     count = ListMethodsForGeneric(theEnv,logicalName,(DEFGENERIC *) vptr);
   else
     {
      count = 0L;
      for (gfunc = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,NULL) ;
           gfunc != NULL ;
           gfunc = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,(void *) gfunc))
        {
         count += ListMethodsForGeneric(theEnv,logicalName,gfunc);
         if (EnvGetNextDefgeneric(theEnv,(void *) gfunc) != NULL)
           EnvPrintRouter(theEnv,logicalName,"\n");
        }
     }
   PrintTally(theEnv,logicalName,count,"method","methods");
  }

#endif /* DEBUGGING_FUNCTIONS */

/***************************************************************
  NAME         : GetDefgenericListFunction
  DESCRIPTION  : Groups all defgeneric names into
                 a multifield list
  INPUTS       : A data object buffer to hold
                 the multifield result
  RETURNS      : Nothing useful
  SIDE EFFECTS : Multifield allocated and filled
  NOTES        : H/L Syntax: (get-defgeneric-list [<module>])
 ***************************************************************/
globle void GetDefgenericListFunction(
  void *theEnv,
  DATA_OBJECT*returnValue)
  {
   GetConstructListFunction(theEnv,"get-defgeneric-list",returnValue,DefgenericData(theEnv)->DefgenericConstruct);
  }

/***************************************************************
  NAME         : EnvGetDefgenericList
  DESCRIPTION  : Groups all defgeneric names into
                 a multifield list
  INPUTS       : 1) A data object buffer to hold
                    the multifield result
                 2) The module from which to obtain defgenerics
  RETURNS      : Nothing useful
  SIDE EFFECTS : Multifield allocated and filled
  NOTES        : External C access
 ***************************************************************/
globle void EnvGetDefgenericList(
  void *theEnv,
  DATA_OBJECT *returnValue,
  struct defmodule *theModule)
  {
   GetConstructList(theEnv,returnValue,DefgenericData(theEnv)->DefgenericConstruct,theModule);
  }

/***********************************************************
  NAME         : GetDefmethodListCommand
  DESCRIPTION  : Groups indices of all methdos for a generic
                 function into a multifield variable
                 (NULL means get methods for all generics)
  INPUTS       : A data object buffer
  RETURNS      : Nothing useful
  SIDE EFFECTS : Multifield set to list of method indices
  NOTES        : None
 ***********************************************************/
globle void GetDefmethodListCommand(
  void *theEnv,
  DATA_OBJECT_PTR returnValue)
  {
   DATA_OBJECT temp;
   DEFGENERIC *gfunc;
   
   if (EnvRtnArgCount(theEnv) == 0)
     EnvGetDefmethodList(theEnv,NULL,returnValue);
   else
     {
      if (EnvArgTypeCheck(theEnv,"get-defmethod-list",1,SYMBOL,&temp) == FALSE)
        {
         EnvSetMultifieldErrorValue(theEnv,returnValue);
         return;
        }
      gfunc = CheckGenericExists(theEnv,"get-defmethod-list",DOToString(temp));
      if (gfunc != NULL)
        EnvGetDefmethodList(theEnv,(void *) gfunc,returnValue);
      else
        EnvSetMultifieldErrorValue(theEnv,returnValue);
     }
  }

/***********************************************************
  NAME         : EnvGetDefmethodList
  DESCRIPTION  : Groups indices of all methdos for a generic
                 function into a multifield variable
                 (NULL means get methods for all generics)
  INPUTS       : 1) A pointer to a generic function
                 2) A data object buffer
  RETURNS      : Nothing useful
  SIDE EFFECTS : Multifield set to list of method indices
  NOTES        : None
 ***********************************************************/
globle void EnvGetDefmethodList(
  void *theEnv,
  void *vgfunc,
  DATA_OBJECT_PTR returnValue)
  {
   DEFGENERIC *gfunc,*svg,*svnxt;
   long i,j;
   unsigned long count;
   MULTIFIELD_PTR theList;

   if (vgfunc != NULL)
     {
      gfunc = (DEFGENERIC *) vgfunc;
      svnxt = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,vgfunc);
      SetNextDefgeneric(vgfunc,NULL);
     }
   else
     {
      gfunc = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,NULL);
      svnxt = (gfunc != NULL) ? (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,(void *) gfunc) : NULL;
     }
   count = 0;
   for (svg = gfunc ;
        gfunc != NULL ;
        gfunc = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,(void *) gfunc))
     count += (unsigned long) gfunc->mcnt;
   count *= 2;
   SetpType(returnValue,MULTIFIELD);
   SetpDOBegin(returnValue,1);
   SetpDOEnd(returnValue,count);
   theList = (MULTIFIELD_PTR) EnvCreateMultifield(theEnv,count);
   SetpValue(returnValue,theList);
   for (gfunc = svg , i = 1 ;
        gfunc != NULL ;
        gfunc = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,(void *) gfunc))
     {
      for (j = 0 ; j < gfunc->mcnt ; j++)
        {
         SetMFType(theList,i,SYMBOL);
         SetMFValue(theList,i++,GetDefgenericNamePointer((void *) gfunc));
         SetMFType(theList,i,INTEGER);
         SetMFValue(theList,i++,EnvAddLong(theEnv,(long long) gfunc->methods[j].index));
        }
     }
   if (svg != NULL)
     SetNextDefgeneric((void *) svg,(void *) svnxt);
  }

/***********************************************************************************
  NAME         : GetMethodRestrictionsCommand
  DESCRIPTION  : Stores restrictions of a method in multifield
  INPUTS       : A data object buffer to hold a multifield
  RETURNS      : Nothing useful
  SIDE EFFECTS : Multifield created (length zero on errors)
  NOTES        : Syntax: (get-method-restrictions <generic-function> <method-index>)
 ***********************************************************************************/
globle void GetMethodRestrictionsCommand(
  void *theEnv,
  DATA_OBJECT *result)
  {
   DATA_OBJECT temp;
   DEFGENERIC *gfunc;

   if (EnvArgTypeCheck(theEnv,"get-method-restrictions",1,SYMBOL,&temp) == FALSE)
     {
      EnvSetMultifieldErrorValue(theEnv,result);
      return;
     }
   gfunc = CheckGenericExists(theEnv,"get-method-restrictions",DOToString(temp));
   if (gfunc == NULL)
     {
      EnvSetMultifieldErrorValue(theEnv,result);
      return;
     }
   if (EnvArgTypeCheck(theEnv,"get-method-restrictions",2,INTEGER,&temp) == FALSE)
     {
      EnvSetMultifieldErrorValue(theEnv,result);
      return;
     }
   if (CheckMethodExists(theEnv,"get-method-restrictions",gfunc,(long) DOToLong(temp)) == -1)
     {
      EnvSetMultifieldErrorValue(theEnv,result);
      return;
     }
   EnvGetMethodRestrictions(theEnv,(void *) gfunc,(unsigned) DOToLong(temp),result);
  }

/***********************************************************************
  NAME         : EnvGetMethodRestrictions
  DESCRIPTION  : Stores restrictions of a method in multifield
  INPUTS       : 1) Pointer to the generic function
                 2) The method index
                 3) A data object buffer to hold a multifield
  RETURNS      : Nothing useful
  SIDE EFFECTS : Multifield created (length zero on errors)
  NOTES        : The restrictions are stored in the multifield
                 in the following format:

                 <min-number-of-arguments>
                 <max-number-of-arguments> (-1 if wildcard allowed)
                 <restriction-count>
                 <index of 1st restriction>
                       .
                       .
                 <index of nth restriction>
                 <restriction 1>
                     <query TRUE/FALSE>
                     <number-of-classes>
                     <class 1>
                        .
                        .
                     <class n>
                    .
                    .
                    .
                  <restriction n>

                  Thus, for the method
                  (defmethod foo ((?a NUMBER SYMBOL) (?b (= 1 1)) $?c))
                  (get-method-restrictions foo 1) would yield

                  (2 -1 3 7 11 13 FALSE 2 NUMBER SYMBOL TRUE 0 FALSE 0)
 ***********************************************************************/
globle void EnvGetMethodRestrictions(
  void *theEnv,
  void *vgfunc,
  long mi,
  DATA_OBJECT *result)
  {
   short i,j;
   DEFMETHOD *meth;
   RESTRICTION *rptr;
   long count;
   int roffset,rstrctIndex;
   MULTIFIELD_PTR theList;

   meth = ((DEFGENERIC *) vgfunc)->methods + FindMethodByIndex((DEFGENERIC *) vgfunc,mi);
   count = 3;
   for (i = 0 ; i < meth->restrictionCount ; i++)
     count += meth->restrictions[i].tcnt + 3;
   theList = (MULTIFIELD_PTR) EnvCreateMultifield(theEnv,count);
   SetpType(result,MULTIFIELD);
   SetpValue(result,theList);
   SetpDOBegin(result,1);
   SetpDOEnd(result,count);
   SetMFType(theList,1,INTEGER);
   SetMFValue(theList,1,EnvAddLong(theEnv,(long long) meth->minRestrictions));
   SetMFType(theList,2,INTEGER);
   SetMFValue(theList,2,EnvAddLong(theEnv,(long long) meth->maxRestrictions));
   SetMFType(theList,3,INTEGER);
   SetMFValue(theList,3,EnvAddLong(theEnv,(long long) meth->restrictionCount));
   roffset = 3 + meth->restrictionCount + 1;
   rstrctIndex = 4;
   for (i = 0 ; i < meth->restrictionCount ; i++)
     {
      rptr = meth->restrictions + i;
      SetMFType(theList,rstrctIndex,INTEGER);
      SetMFValue(theList,rstrctIndex++,EnvAddLong(theEnv,(long long) roffset));
      SetMFType(theList,roffset,SYMBOL);
      SetMFValue(theList,roffset++,(rptr->query != NULL) ? EnvTrueSymbol(theEnv) : EnvFalseSymbol(theEnv));
      SetMFType(theList,roffset,INTEGER);
      SetMFValue(theList,roffset++,EnvAddLong(theEnv,(long long) rptr->tcnt));
      for (j = 0 ; j < rptr->tcnt ; j++)
        {
         SetMFType(theList,roffset,SYMBOL);
#if OBJECT_SYSTEM
         SetMFValue(theList,roffset++,EnvAddSymbol(theEnv,EnvGetDefclassName(theEnv,rptr->types[j])));
#else
         SetMFValue(theList,roffset++,EnvAddSymbol(theEnv,TypeName(theEnv,ValueToInteger(rptr->types[j]))));
#endif
        }
     }
  }

/* =========================================
   *****************************************
          INTERNALLY VISIBLE FUNCTIONS
   =========================================
   ***************************************** */

/***************************************************
  NAME         : PrintGenericCall
  DESCRIPTION  : PrintExpression() support function
                 for generic function calls
  INPUTS       : 1) The output logical name
                 2) The generic function
  RETURNS      : Nothing useful
  SIDE EFFECTS : Call expression printed
  NOTES        : None
 ***************************************************/
static void PrintGenericCall(
  void *theEnv,
  const char *logName,
  void *value)
  {
#if DEVELOPER

   EnvPrintRouter(theEnv,logName,"(");
   EnvPrintRouter(theEnv,logName,EnvGetDefgenericName(theEnv,value));
   if (GetFirstArgument() != NULL)
     {
      EnvPrintRouter(theEnv,logName," ");
      PrintExpression(theEnv,logName,GetFirstArgument());
     }
   EnvPrintRouter(theEnv,logName,")");
#else
#if MAC_XCD
#pragma unused(theEnv)
#pragma unused(logName)
#pragma unused(value)
#endif
#endif
  }

/*******************************************************
  NAME         : EvaluateGenericCall
  DESCRIPTION  : Primitive support function for
                 calling a generic function
  INPUTS       : 1) The generic function
                 2) A data object buffer to hold
                    the evaluation result
  RETURNS      : FALSE if the generic function
                 returns the symbol FALSE,
                 TRUE otherwise
  SIDE EFFECTS : Data obejct buffer set and any
                 side-effects of calling the generic
  NOTES        : None
 *******************************************************/
static intBool EvaluateGenericCall(
  void *theEnv,
  void *value,
  DATA_OBJECT *result)
  {
   GenericDispatch(theEnv,(DEFGENERIC *) value,NULL,NULL,GetFirstArgument(),result);
   if ((GetpType(result) == SYMBOL) &&
       (GetpValue(result) == EnvFalseSymbol(theEnv)))
     return(FALSE);
   return(TRUE);
  }

/***************************************************
  NAME         : DecrementGenericBusyCount
  DESCRIPTION  : Lowers the busy count of a
                 generic function construct
  INPUTS       : The generic function
  RETURNS      : Nothing useful
  SIDE EFFECTS : Busy count decremented if a clear
                 is not in progress (see comment)
  NOTES        : None
 ***************************************************/
static void DecrementGenericBusyCount(
  void *theEnv,
  void *value)
  {
   /* ==============================================
      The generics to which expressions in other
      constructs may refer may already have been
      deleted - thus, it is important not to modify
      the busy flag during a clear.
      ============================================== */
   if (! ConstructData(theEnv)->ClearInProgress)
     ((DEFGENERIC *) value)->busy--;
  }

/***************************************************
  NAME         : IncrementGenericBusyCount
  DESCRIPTION  : Raises the busy count of a
                 generic function construct
  INPUTS       : The generic function
  RETURNS      : Nothing useful
  SIDE EFFECTS : Busy count incremented
  NOTES        : None
 ***************************************************/
static void IncrementGenericBusyCount(
  void *theEnv,
  void *value)
  {
#if MAC_XCD
#pragma unused(theEnv)
#endif
#if (! RUN_TIME) && (! BLOAD_ONLY)
   if (! ConstructData(theEnv)->ParsingConstruct)
     { ConstructData(theEnv)->DanglingConstructs++; }
#endif

   ((DEFGENERIC *) value)->busy++;
  }

#if (! BLOAD_ONLY) && (! RUN_TIME)

/**********************************************************************
  NAME         : SaveDefgenerics
  DESCRIPTION  : Outputs pretty-print forms of generic function headers
  INPUTS       : The logical name of the output
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : None
 **********************************************************************/
static void SaveDefgenerics(
  void *theEnv,
  void *theModule,
  const char *logName)
  {
   SaveConstruct(theEnv,theModule,logName,DefgenericData(theEnv)->DefgenericConstruct);
  }

/**********************************************************************
  NAME         : SaveDefmethods
  DESCRIPTION  : Outputs pretty-print forms of generic function methods
  INPUTS       : The logical name of the output
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : None
 **********************************************************************/
static void SaveDefmethods(
  void *theEnv,
  void *theModule,
  const char *logName)
  {
   DoForAllConstructsInModule(theEnv,theModule,SaveDefmethodsForDefgeneric,
                              DefgenericData(theEnv)->DefgenericModuleIndex,
                              FALSE,(void *) logName);
  }

/***************************************************
  NAME         : SaveDefmethodsForDefgeneric
  DESCRIPTION  : Save the pretty-print forms of
                 all methods for a generic function
                 to a file
  INPUTS       : 1) The defgeneric
                 2) The logical name of the output
  RETURNS      : Nothing useful
  SIDE EFFECTS : Methods written
  NOTES        : None
 ***************************************************/
static void SaveDefmethodsForDefgeneric(
  void *theEnv,
  struct constructHeader *theDefgeneric,
  void *userBuffer)
  {
   DEFGENERIC *gfunc = (DEFGENERIC *) theDefgeneric;
   const char *logName = (const char *) userBuffer;
   long i;

   for (i = 0 ; i < gfunc->mcnt ; i++)
     {
      if (gfunc->methods[i].ppForm != NULL)
        {
         PrintInChunks(theEnv,logName,gfunc->methods[i].ppForm);
         EnvPrintRouter(theEnv,logName,"\n");
        }
     }
  }

/****************************************************
  NAME         : RemoveDefgenericMethod
  DESCRIPTION  : Removes a generic function method
                   from the array and removes the
                   generic too if its the last method
  INPUTS       : 1) The generic function
                 2) The array index of the method
  RETURNS      : Nothing useful
  SIDE EFFECTS : List adjusted
                 Nodes deallocated
  NOTES        : Assumes deletion is safe
 ****************************************************/
static void RemoveDefgenericMethod(
  void *theEnv,
  DEFGENERIC *gfunc,
  long gi)
  {
   DEFMETHOD *narr;
   long b,e;

   if (gfunc->methods[gi].system)
     {
      SetEvaluationError(theEnv,TRUE);
      PrintErrorID(theEnv,"GENRCCOM",4,FALSE);
      EnvPrintRouter(theEnv,WERROR,"Cannot remove implicit system function method for generic function ");
      EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) gfunc));
      EnvPrintRouter(theEnv,WERROR,".\n");
      return;
     }
   DeleteMethodInfo(theEnv,gfunc,&gfunc->methods[gi]);
   if (gfunc->mcnt == 1)
     {
      rm(theEnv,(void *) gfunc->methods,(int) sizeof(DEFMETHOD));
      gfunc->mcnt = 0;
      gfunc->methods = NULL;
     }
   else
     {
      gfunc->mcnt--;
      narr = (DEFMETHOD *) gm2(theEnv,(sizeof(DEFMETHOD) * gfunc->mcnt));
      for (b = e = 0 ; b < gfunc->mcnt ; b++ , e++)
        {
         if (((int) b) == gi)
           e++;
         GenCopyMemory(DEFMETHOD,1,&narr[b],&gfunc->methods[e]);
        }
      rm(theEnv,(void *) gfunc->methods,(sizeof(DEFMETHOD) * (gfunc->mcnt+1)));
      gfunc->methods = narr;
     }
  }

#endif

#if DEBUGGING_FUNCTIONS

/******************************************************
  NAME         : ListMethodsForGeneric
  DESCRIPTION  : Lists a brief description of methods
                   for a particular generic function
  INPUTS       : 1) The logical name of the output
                 2) Generic function to list methods for
  RETURNS      : The number of methods printed
  SIDE EFFECTS : None
  NOTES        : None
 ******************************************************/
static long ListMethodsForGeneric(
  void *theEnv,
  const char *logicalName,
  DEFGENERIC *gfunc)
  {
   long gi;
   char buf[256];

   for (gi = 0 ; gi < gfunc->mcnt ; gi++)
     {
      EnvPrintRouter(theEnv,logicalName,EnvGetDefgenericName(theEnv,(void *) gfunc));
      EnvPrintRouter(theEnv,logicalName," #");
      PrintMethod(theEnv,buf,255,&gfunc->methods[gi]);
      EnvPrintRouter(theEnv,logicalName,buf);
      EnvPrintRouter(theEnv,logicalName,"\n");
     }
   return((long) gfunc->mcnt);
  }

/******************************************************************
  NAME         : DefgenericWatchAccess
  DESCRIPTION  : Parses a list of generic names passed by
                 AddWatchItem() and sets the traces accordingly
  INPUTS       : 1) A code indicating which trace flag is to be set
                    Ignored
                 2) The value to which to set the trace flags
                 3) A list of expressions containing the names
                    of the generics for which to set traces
  RETURNS      : TRUE if all OK, FALSE otherwise
  SIDE EFFECTS : Watch flags set in specified generics
  NOTES        : Accessory function for AddWatchItem()
 ******************************************************************/
static unsigned DefgenericWatchAccess(
  void *theEnv,
  int code,
  unsigned newState,
  EXPRESSION *argExprs)
  {
#if MAC_XCD
#pragma unused(code)
#endif

   return(ConstructSetWatchAccess(theEnv,DefgenericData(theEnv)->DefgenericConstruct,newState,argExprs,
                                    EnvGetDefgenericWatch,EnvSetDefgenericWatch));
  }

/***********************************************************************
  NAME         : DefgenericWatchPrint
  DESCRIPTION  : Parses a list of generic names passed by
                 AddWatchItem() and displays the traces accordingly
  INPUTS       : 1) The logical name of the output
                 2) A code indicating which trace flag is to be examined
                    Ignored
                 3) A list of expressions containing the names
                    of the generics for which to examine traces
  RETURNS      : TRUE if all OK, FALSE otherwise
  SIDE EFFECTS : Watch flags displayed for specified generics
  NOTES        : Accessory function for AddWatchItem()
 ***********************************************************************/
static unsigned DefgenericWatchPrint(
  void *theEnv,
  const char *logName,
  int code,
  EXPRESSION *argExprs)
  {
#if MAC_XCD
#pragma unused(code)
#endif

   return(ConstructPrintWatchAccess(theEnv,DefgenericData(theEnv)->DefgenericConstruct,logName,argExprs,
                                    EnvGetDefgenericWatch,EnvSetDefgenericWatch));
  }

/******************************************************************
  NAME         : DefmethodWatchAccess
  DESCRIPTION  : Parses a list of methods passed by
                 AddWatchItem() and sets the traces accordingly
  INPUTS       : 1) A code indicating which trace flag is to be set
                    Ignored
                 2) The value to which to set the trace flags
                 3) A list of expressions containing the methods
                   for which to set traces
  RETURNS      : TRUE if all OK, FALSE otherwise
  SIDE EFFECTS : Watch flags set in specified methods
  NOTES        : Accessory function for AddWatchItem()
 ******************************************************************/
static unsigned DefmethodWatchAccess(
  void *theEnv,
  int code,
  unsigned newState,
  EXPRESSION *argExprs)
  {
#if MAC_XCD
#pragma unused(code)
#endif
   if (newState)
     return(DefmethodWatchSupport(theEnv,"watch",NULL,newState,NULL,EnvSetDefmethodWatch,argExprs));
   else
     return(DefmethodWatchSupport(theEnv,"unwatch",NULL,newState,NULL,EnvSetDefmethodWatch,argExprs));
  }

/***********************************************************************
  NAME         : DefmethodWatchPrint
  DESCRIPTION  : Parses a list of methods passed by
                 AddWatchItem() and displays the traces accordingly
  INPUTS       : 1) The logical name of the output
                 2) A code indicating which trace flag is to be examined
                    Ignored
                 3) A list of expressions containing the methods for
                    which to examine traces
  RETURNS      : TRUE if all OK, FALSE otherwise
  SIDE EFFECTS : Watch flags displayed for specified methods
  NOTES        : Accessory function for AddWatchItem()
 ***********************************************************************/
static unsigned DefmethodWatchPrint(
  void *theEnv,
  const char *logName,
  int code,
  EXPRESSION *argExprs)
  {
#if MAC_XCD
#pragma unused(code)
#endif
   return(DefmethodWatchSupport(theEnv,"list-watch-items",logName,0,
                                PrintMethodWatchFlag,NULL,argExprs));
  }

/*******************************************************
  NAME         : DefmethodWatchSupport
  DESCRIPTION  : Sets or displays methods specified
  INPUTS       : 1) The calling function name
                 2) The logical output name for displays
                    (can be NULL)
                 3) The new set state
                 4) The print function (can be NULL)
                 5) The trace function (can be NULL)
                 6) The methods expression list
  RETURNS      : TRUE if all OK,
                 FALSE otherwise
  SIDE EFFECTS : Method trace flags set or displayed
  NOTES        : None
 *******************************************************/
static unsigned DefmethodWatchSupport(
  void *theEnv,
  const char *funcName,
  const char *logName,
  unsigned newState,
  void (*printFunc)(void *,const char *,void *,long),
  void (*traceFunc)(void *,unsigned,void *,long),
  EXPRESSION *argExprs)
  {
   void *theGeneric;
   unsigned long theMethod = 0;
   int argIndex = 2;
   DATA_OBJECT genericName,methodIndex;
   struct defmodule *theModule;

   /* ==============================
      If no methods are specified,
      show the trace for all methods
      in all generics
      ============================== */
   if (argExprs == NULL)
     {
      SaveCurrentModule(theEnv);
      theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,NULL);
      while (theModule != NULL)
        {
         EnvSetCurrentModule(theEnv,(void *) theModule);
         if (traceFunc == NULL)
           {
            EnvPrintRouter(theEnv,logName,EnvGetDefmoduleName(theEnv,(void *) theModule));
            EnvPrintRouter(theEnv,logName,":\n");
           }
         theGeneric = EnvGetNextDefgeneric(theEnv,NULL);
         while (theGeneric != NULL)
            {
             theMethod = EnvGetNextDefmethod(theEnv,theGeneric,0);
             while (theMethod != 0)
               {
                if (traceFunc != NULL)
                  (*traceFunc)(theEnv,newState,theGeneric,theMethod);
                else
                  {
                   EnvPrintRouter(theEnv,logName,"   ");
                   (*printFunc)(theEnv,logName,theGeneric,theMethod);
                  }
                theMethod = EnvGetNextDefmethod(theEnv,theGeneric,theMethod);
               }
             theGeneric = EnvGetNextDefgeneric(theEnv,theGeneric);
            }
         theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,(void *) theModule);
        }
      RestoreCurrentModule(theEnv);
      return(TRUE);
     }

   /* =========================================
      Set the traces for every method specified
      ========================================= */
   while (argExprs != NULL)
     {
      if (EvaluateExpression(theEnv,argExprs,&genericName))
        return(FALSE);
      if ((genericName.type != SYMBOL) ? TRUE :
          ((theGeneric = (void *)
              LookupDefgenericByMdlOrScope(theEnv,DOToString(genericName))) == NULL))
        {
         ExpectedTypeError1(theEnv,funcName,argIndex,"generic function name");
         return(FALSE);
        }
      if (GetNextArgument(argExprs) == NULL)
        theMethod = 0;
      else
        {
         argExprs = GetNextArgument(argExprs);
         argIndex++;
         if (EvaluateExpression(theEnv,argExprs,&methodIndex))
           return(FALSE);
         if ((methodIndex.type != INTEGER) ? FALSE :
             ((DOToLong(methodIndex) <= 0) ? FALSE :
              (FindMethodByIndex((DEFGENERIC *) theGeneric,theMethod) != -1)))
           theMethod = (long) DOToLong(methodIndex);
         else
           {
            ExpectedTypeError1(theEnv,funcName,argIndex,"method index");
            return(FALSE);
           }
        }
      if (theMethod == 0)
        {
         theMethod = EnvGetNextDefmethod(theEnv,theGeneric,0);
         while (theMethod != 0)
           {
            if (traceFunc != NULL)
              (*traceFunc)(theEnv,newState,theGeneric,theMethod);
            else
              (*printFunc)(theEnv,logName,theGeneric,theMethod);
            theMethod = EnvGetNextDefmethod(theEnv,theGeneric,theMethod);
           }
        }
      else
        {
         if (traceFunc != NULL)
           (*traceFunc)(theEnv,newState,theGeneric,theMethod);
         else
           (*printFunc)(theEnv,logName,theGeneric,theMethod);
        }
      argExprs = GetNextArgument(argExprs);
      argIndex++;
     }
   return(TRUE);
  }

/***************************************************
  NAME         : PrintMethodWatchFlag
  DESCRIPTION  : Displays trace value for method
  INPUTS       : 1) The logical name of the output
                 2) The generic function
                 3) The method index
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
static void PrintMethodWatchFlag(
  void *theEnv,
  const char *logName,
  void *theGeneric,
  long theMethod)
  {
   char buf[60];

   EnvPrintRouter(theEnv,logName,EnvGetDefgenericName(theEnv,theGeneric));
   EnvPrintRouter(theEnv,logName," ");
   EnvGetDefmethodDescription(theEnv,buf,59,theGeneric,theMethod);
   EnvPrintRouter(theEnv,logName,buf);
   if (EnvGetDefmethodWatch(theEnv,theGeneric,theMethod))
     EnvPrintRouter(theEnv,logName," = on\n");
   else
     EnvPrintRouter(theEnv,logName," = off\n");
  }

#endif

#if ! OBJECT_SYSTEM

/***************************************************
  NAME         : TypeCommand
  DESCRIPTION  : Works like "class" in COOL
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : H/L Syntax: (type <primitive>)
 ***************************************************/
globle void TypeCommand(
  void *theEnv,
  DATA_OBJECT *result)
  {
   EvaluateExpression(theEnv,GetFirstArgument(),result);
   result->value = (void *) EnvAddSymbol(theEnv,TypeName(theEnv,result->type));
   result->type = SYMBOL;
  }

#endif

/*#############################*/
/* Additional Access Functions */
/*#############################*/

globle SYMBOL_HN *GetDefgenericNamePointer(
  void *theDefgeneric)
  {
   return GetConstructNamePointer((struct constructHeader *) theDefgeneric);
  }

globle void SetNextDefgeneric(
  void *theDefgeneric,
  void *targetDefgeneric)
  {
   SetNextConstruct((struct constructHeader *) theDefgeneric,
                    (struct constructHeader *) targetDefgeneric);
  }

/*##################################*/
/* Additional Environment Functions */
/*##################################*/

globle const char *EnvDefgenericModule(
  void *theEnv,
  void *theDefgeneric)
  {
   return GetConstructModuleName((struct constructHeader *) theDefgeneric);
  }

globle const char *EnvGetDefgenericName(
  void *theEnv,
  void *theDefgeneric)
  {
   return GetConstructNameString((struct constructHeader *) theDefgeneric);
  }

globle const char *EnvGetDefgenericPPForm(
  void *theEnv,
  void *theDefgeneric)
  {
   return GetConstructPPForm(theEnv,(struct constructHeader *) theDefgeneric);
  }

globle SYMBOL_HN *EnvGetDefgenericNamePointer(
  void *theEnv,
  void *theDefgeneric)
  {
   return GetConstructNamePointer((struct constructHeader *) theDefgeneric);
  }

globle void EnvSetDefgenericPPForm(
  void *theEnv,
  void *theDefgeneric,
  const char *thePPForm)
  {
   SetConstructPPForm(theEnv,(struct constructHeader *) theDefgeneric,thePPForm);
  }

/*#####################################*/
/* ALLOW_ENVIRONMENT_GLOBALS Functions */
/*#####################################*/

#if ALLOW_ENVIRONMENT_GLOBALS

globle void SetDefgenericPPForm(
  void *theDefgeneric,
  const char *thePPForm)
  {
   EnvSetDefgenericPPForm(GetCurrentEnvironment(),theDefgeneric,thePPForm);
  }

globle const char *DefgenericModule(
  void *theDefgeneric)
  {
   return EnvDefgenericModule(GetCurrentEnvironment(),theDefgeneric);
  }

globle void *FindDefgeneric(
  const char *genericModuleAndName)
  {
   return EnvFindDefgeneric(GetCurrentEnvironment(),genericModuleAndName);
  }

globle void GetDefgenericList(
  DATA_OBJECT *returnValue,
  struct defmodule *theModule)
  {
   EnvGetDefgenericList(GetCurrentEnvironment(),returnValue,theModule);
  }

globle const char *GetDefgenericName(
  void *theDefgeneric)
  {
   return EnvGetDefgenericName(GetCurrentEnvironment(),theDefgeneric);
  }

globle const char *GetDefgenericPPForm(
  void *theDefgeneric)
  {
   return EnvGetDefgenericPPForm(GetCurrentEnvironment(),theDefgeneric);
  }

globle void *GetNextDefgeneric(
  void *ptr)
  {
   return EnvGetNextDefgeneric(GetCurrentEnvironment(),ptr);
  }

globle int IsDefgenericDeletable(
  void *ptr)
  {
   return EnvIsDefgenericDeletable(GetCurrentEnvironment(),ptr);
  }

globle intBool Undefgeneric(
  void *vptr)
  {
   return EnvUndefgeneric(GetCurrentEnvironment(),vptr);
  }

globle void GetDefmethodList(
  void *vgfunc,
  DATA_OBJECT_PTR returnValue)
  {
   EnvGetDefmethodList(GetCurrentEnvironment(),vgfunc,returnValue);
  }

globle void GetMethodRestrictions(
  void *vgfunc,
  long mi,
  DATA_OBJECT *result)
  {
   EnvGetMethodRestrictions(GetCurrentEnvironment(),vgfunc,mi,result);
  }

globle long GetNextDefmethod(
  void *ptr,
  long theIndex)
  {
   return EnvGetNextDefmethod(GetCurrentEnvironment(),ptr,theIndex);
  }

globle int IsDefmethodDeletable(
  void *ptr,
  long theIndex)
  {
   return EnvIsDefmethodDeletable(GetCurrentEnvironment(),ptr,theIndex);
  }

globle intBool Undefmethod(
  void *vptr,
  long mi)
  {
  return EnvUndefmethod(GetCurrentEnvironment(),vptr,mi);
  }

#if DEBUGGING_FUNCTIONS

globle unsigned GetDefgenericWatch(
  void *theGeneric)
  {
   return EnvGetDefgenericWatch(GetCurrentEnvironment(),theGeneric);
  }

globle void ListDefgenerics(
  const char *logicalName,
  struct defmodule *theModule)
  {
   EnvListDefgenerics(GetCurrentEnvironment(),logicalName,theModule);
  }

globle void SetDefgenericWatch(
  unsigned newState,
  void *theGeneric)
  {
   EnvSetDefgenericWatch(GetCurrentEnvironment(),newState,theGeneric);
  }

globle const char *GetDefmethodPPForm(
  void *ptr,
  long theIndex)
  {
   return EnvGetDefmethodPPForm(GetCurrentEnvironment(),ptr,theIndex);
  }

globle unsigned GetDefmethodWatch(
  void *theGeneric,
  long theIndex)
  {
   return EnvGetDefmethodWatch(GetCurrentEnvironment(),theGeneric,theIndex);
  }

globle void ListDefmethods(
  const char *logicalName,
  void *vptr)
  {
   EnvListDefmethods(GetCurrentEnvironment(),logicalName,vptr);
  }

globle void SetDefmethodWatch(
  unsigned newState,
  void *theGeneric,
  long theIndex)
  {
   EnvSetDefmethodWatch(GetCurrentEnvironment(),newState,theGeneric,theIndex);
  }

#endif /* DEBUGGING_FUNCTIONS */

#if DEBUGGING_FUNCTIONS || PROFILING_FUNCTIONS

globle void GetDefmethodDescription(
  char *buf,
  int buflen,
  void *ptr,
  long theIndex)
  {
   EnvGetDefmethodDescription(GetCurrentEnvironment(),buf,buflen,ptr,theIndex);
  }

#endif /* DEBUGGING_FUNCTIONS || PROFILING_FUNCTIONS */

#endif /* ALLOW_ENVIRONMENT_GLOBALS */

#endif /* DEFGENERIC_CONSTRUCT */

