clips-sys 0.4.0

   /*******************************************************/
   /*      "C" Language Integrated Production System      */
   /*                                                     */
   /*            CLIPS Version 6.40  11/01/16             */
   /*                                                     */
   /*                                                     */
   /*******************************************************/

/*************************************************************/
/* Purpose: Generic Functions Parsing Routines               */
/*                                                           */
/* Principal Programmer(s):                                  */
/*      Brian L. Dantes                                      */
/*                                                           */
/* Contributing Programmer(s):                               */
/*                                                           */
/* Revision History:                                         */
/*                                                           */
/*      6.24: Renamed BOOLEAN macro type to intBool.         */
/*                                                           */
/*            If the last construct in a loaded file is a    */
/*            deffunction or defmethod with no closing right */
/*            parenthesis, an error should be issued, but is */
/*            not. DR0872                                    */
/*                                                           */
/*      6.30: Changed integer type/precision.                */
/*                                                           */
/*            GetConstructNameAndComment API change.         */
/*                                                           */
/*            Support for long long integers.                */
/*                                                           */
/*            Used gensprintf instead of sprintf.            */
/*                                                           */
/*            Added const qualifiers to remove C++           */
/*            deprecation warnings.                          */
/*                                                           */
/*            Converted API macros to function calls.        */
/*                                                           */
/*            Fixed linkage issue when BLOAD_AND_SAVE        */
/*            compiler flag is set to 0.                     */
/*                                                           */
/*            Fixed typing issue when OBJECT_SYSTEM          */
/*            compiler flag is set to 0.                     */
/*                                                           */
/*            Changed find construct functionality so that   */
/*            imported modules are search when locating a    */
/*            named construct.                               */
/*                                                           */
/*      6.40: Pragma once and other inclusion changes.       */
/*                                                           */
/*            Added support for booleans with <stdbool.h>.   */
/*                                                           */
/*            Removed use of void pointers for specific      */
/*            data structures.                               */
/*                                                           */
/*************************************************************/

/* =========================================
   *****************************************
               EXTERNAL DEFINITIONS
   =========================================
   ***************************************** */

#include "setup.h"

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

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

#if DEFFUNCTION_CONSTRUCT
#include "dffnxfun.h"
#endif

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

#include "cstrccom.h"
#include "cstrcpsr.h"
#include "envrnmnt.h"
#include "exprnpsr.h"
#include "genrccom.h"
#include "immthpsr.h"
#include "memalloc.h"
#include "modulutl.h"
#include "pprint.h"
#include "prcdrpsr.h"
#include "prccode.h"
#include "prntutil.h"
#include "router.h"
#include "scanner.h"
#include "sysdep.h"

#include "genrcpsr.h"

/* =========================================
   *****************************************
                   CONSTANTS
   =========================================
   ***************************************** */
#define HIGHER_PRECEDENCE -1
#define IDENTICAL          0
#define LOWER_PRECEDENCE   1

#define CURR_ARG_VAR "current-argument"

#define PARAMETER_ERROR USHRT_MAX

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

   static bool                    ValidGenericName(Environment *,const char *);
   static CLIPSLexeme            *ParseMethodNameAndIndex(Environment *,const char *,unsigned short *,struct token *);

#if DEBUGGING_FUNCTIONS
   static void                    CreateDefaultGenericPPForm(Environment *,Defgeneric *);
#endif

   static unsigned short          ParseMethodParameters(Environment *,const char *,Expression **,CLIPSLexeme **,struct token *);
   static RESTRICTION            *ParseRestriction(Environment *,const char *);
   static void                    ReplaceCurrentArgRefs(Environment *,Expression *);
   static bool                    DuplicateParameters(Environment *,Expression *,Expression **,CLIPSLexeme *);
   static Expression             *AddParameter(Environment *,Expression *,Expression *,CLIPSLexeme *,RESTRICTION *);
   static Expression             *ValidType(Environment *,CLIPSLexeme *);
   static bool                    RedundantClasses(Environment *,void *,void *);
   static Defgeneric             *AddGeneric(Environment *,CLIPSLexeme *,bool *);
   static Defmethod              *AddGenericMethod(Environment *,Defgeneric *,int,unsigned short);
   static int                     RestrictionsCompare(Expression *,int,int,int,Defmethod *);
   static int                     TypeListCompare(RESTRICTION *,RESTRICTION *);
   static Defgeneric             *NewGeneric(Environment *,CLIPSLexeme *);

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

/***************************************************************************
  NAME         : ParseDefgeneric
  DESCRIPTION  : Parses the defgeneric construct
  INPUTS       : The input logical name
  RETURNS      : False if successful parse, true otherwise
  SIDE EFFECTS : Inserts valid generic function defn into generic entry
  NOTES        : H/L Syntax :
                 (defgeneric <name> [<comment>])
 ***************************************************************************/
bool ParseDefgeneric(
  Environment *theEnv,
  const char *readSource)
  {
   CLIPSLexeme *gname;
   Defgeneric *gfunc;
   bool newGeneric;
   struct token genericInputToken;

   SetPPBufferStatus(theEnv,true);
   FlushPPBuffer(theEnv);
   SavePPBuffer(theEnv,"(defgeneric ");
   SetIndentDepth(theEnv,3);

#if BLOAD || BLOAD_AND_BSAVE
   if ((Bloaded(theEnv) == true) && (! ConstructData(theEnv)->CheckSyntaxMode))
     {
      CannotLoadWithBloadMessage(theEnv,"defgeneric");
      return true;
     }
#endif

   gname = GetConstructNameAndComment(theEnv,readSource,&genericInputToken,"defgeneric",
                                      (FindConstructFunction *) FindDefgenericInModule,
                                      NULL,"^",true,true,true,false);
   if (gname == NULL)
     return true;

   if (ValidGenericName(theEnv,gname->contents) == false)
     return true;

   if (genericInputToken.tknType != RIGHT_PARENTHESIS_TOKEN)
     {
      PrintErrorID(theEnv,"GENRCPSR",1,false);
      WriteString(theEnv,STDERR,"Expected ')' to complete defgeneric.\n");
      return true;
     }
   SavePPBuffer(theEnv,"\n");

   /* ========================================================
      If we're only checking syntax, don't add the
      successfully parsed deffacts to the KB.
      ======================================================== */

   if (ConstructData(theEnv)->CheckSyntaxMode)
     { return false; }

   gfunc = AddGeneric(theEnv,gname,&newGeneric);

#if DEBUGGING_FUNCTIONS
   SetDefgenericPPForm(theEnv,gfunc,GetConserveMemory(theEnv) ? NULL : CopyPPBuffer(theEnv));
#endif
   return false;
  }

/***************************************************************************
  NAME         : ParseDefmethod
  DESCRIPTION  : Parses the defmethod construct
  INPUTS       : The input logical name
  RETURNS      : False if successful parse, true otherwise
  SIDE EFFECTS : Inserts valid method definition into generic entry
  NOTES        : H/L Syntax :
                 (defmethod <name> [<index>] [<comment>]
                    (<restriction>* [<wildcard>])
                    <action>*)
                 <restriction> :== ?<name> |
                                   (?<name> <type>* [<restriction-query>])
                 <wildcard>    :== $?<name> |
                                   ($?<name> <type>* [<restriction-query>])
 ***************************************************************************/
bool ParseDefmethod(
  Environment *theEnv,
  const char *readSource)
  {
   CLIPSLexeme *gname;
   unsigned short rcnt;
   int mposn;
   unsigned short mi;
   unsigned short lvars;
   bool newMethod;
   bool mnew = false;
   bool error;
   Expression *params,*actions,*tmp;
   CLIPSLexeme *wildcard;
   Defmethod *meth;
   Defgeneric *gfunc;
   unsigned short theIndex;
   struct token genericInputToken;

   SetPPBufferStatus(theEnv,true);
   FlushPPBuffer(theEnv);
   SetIndentDepth(theEnv,3);
   SavePPBuffer(theEnv,"(defmethod ");

#if BLOAD || BLOAD_AND_BSAVE
   if ((Bloaded(theEnv) == true) && (! ConstructData(theEnv)->CheckSyntaxMode))
     {
      CannotLoadWithBloadMessage(theEnv,"defmethod");
      return true;
     }
#endif

   gname = ParseMethodNameAndIndex(theEnv,readSource,&theIndex,&genericInputToken);
   if (gname == NULL)
     return true;

   if (ValidGenericName(theEnv,gname->contents) == false)
     return true;

   /* ========================================================
      Go ahead and add the header so that the generic function
      can be called recursively
      ======================================================== */
   gfunc = AddGeneric(theEnv,gname,&newMethod);

#if DEBUGGING_FUNCTIONS
   if (newMethod && (! ConstructData(theEnv)->CheckSyntaxMode))
      CreateDefaultGenericPPForm(theEnv,gfunc);
#endif

   IncrementIndentDepth(theEnv,1);
   rcnt = ParseMethodParameters(theEnv,readSource,&params,&wildcard,&genericInputToken);
   DecrementIndentDepth(theEnv,1);
   if (rcnt == PARAMETER_ERROR)
     goto DefmethodParseError;
   PPCRAndIndent(theEnv);
   for (tmp = params ; tmp != NULL ; tmp = tmp->nextArg)
     {
      ReplaceCurrentArgRefs(theEnv,((RESTRICTION *) tmp->argList)->query);
      if (ReplaceProcVars(theEnv,"method",((RESTRICTION *) tmp->argList)->query,
                                  params,wildcard,NULL,NULL))
        {
         DeleteTempRestricts(theEnv,params);
         goto DefmethodParseError;
        }
     }
   meth = FindMethodByRestrictions(gfunc,params,rcnt,wildcard,&mposn);
   error = false;
   if (meth != NULL)
     {
      if (meth->system)
        {
         PrintErrorID(theEnv,"GENRCPSR",17,false);
         WriteString(theEnv,STDERR,"Cannot replace the implicit system method #");
         PrintUnsignedInteger(theEnv,STDERR,meth->index);
         WriteString(theEnv,STDERR,".\n");
         error = true;
        }
      else if ((theIndex != 0) && (theIndex != meth->index))
        {
         PrintErrorID(theEnv,"GENRCPSR",2,false);
         WriteString(theEnv,STDERR,"New method #");
         PrintUnsignedInteger(theEnv,STDERR,theIndex);
         WriteString(theEnv,STDERR," would be indistinguishable from method #");
         PrintUnsignedInteger(theEnv,STDERR,meth->index);
         WriteString(theEnv,STDERR,".\n");
         error = true;
        }
     }
   else if (theIndex != 0)
     {
      mi = FindMethodByIndex(gfunc,theIndex);
      if (mi == METHOD_NOT_FOUND)
        mnew = true;
      else if (gfunc->methods[mi].system)
        {
         PrintErrorID(theEnv,"GENRCPSR",17,false);
         WriteString(theEnv,STDERR,"Cannot replace the implicit system method #");
         PrintUnsignedInteger(theEnv,STDERR,theIndex);
         WriteString(theEnv,STDERR,".\n");
         error = true;
        }
     }
   else
     mnew = true;
   if (error)
     {
      DeleteTempRestricts(theEnv,params);
      goto DefmethodParseError;
     }
   ExpressionData(theEnv)->ReturnContext = true;
   actions = ParseProcActions(theEnv,"method",readSource,
                              &genericInputToken,params,wildcard,
                              NULL,NULL,&lvars,NULL);

   /*===========================================================*/
   /* Check for the closing right parenthesis of the defmethod. */
   /*===========================================================*/

   if ((genericInputToken.tknType != RIGHT_PARENTHESIS_TOKEN) &&  /* DR0872 */
       (actions != NULL))
     {
      SyntaxErrorMessage(theEnv,"defmethod");
      DeleteTempRestricts(theEnv,params);
      ReturnPackedExpression(theEnv,actions);
      goto DefmethodParseError;
     }

   if (actions == NULL)
     {
      DeleteTempRestricts(theEnv,params);
      goto DefmethodParseError;
     }

   /*==============================================*/
   /* If we're only checking syntax, don't add the */
   /* successfully parsed deffunction to the KB.   */
   /*==============================================*/

   if (ConstructData(theEnv)->CheckSyntaxMode)
     {
      DeleteTempRestricts(theEnv,params);
      ReturnPackedExpression(theEnv,actions);
      if (newMethod)
        {
         RemoveConstructFromModule(theEnv,&gfunc->header);
         RemoveDefgeneric(theEnv,gfunc);
        }
      return false;
     }

   PPBackup(theEnv);
   PPBackup(theEnv);
   SavePPBuffer(theEnv,genericInputToken.printForm);
   SavePPBuffer(theEnv,"\n");

#if DEBUGGING_FUNCTIONS
   meth = AddMethod(theEnv,gfunc,meth,mposn,theIndex,params,rcnt,lvars,wildcard,actions,
             GetConserveMemory(theEnv) ? NULL : CopyPPBuffer(theEnv),false);
#else
   meth = AddMethod(theEnv,gfunc,meth,mposn,theIndex,params,rcnt,lvars,wildcard,actions,NULL,false);
#endif
   DeleteTempRestricts(theEnv,params);
   if (GetPrintWhileLoading(theEnv) && GetCompilationsWatch(theEnv) &&
       (! ConstructData(theEnv)->CheckSyntaxMode))
     {
      const char *outRouter = STDOUT;

      if (mnew)
        {
         WriteString(theEnv,outRouter,"   Method #");
         PrintUnsignedInteger(theEnv,outRouter,meth->index);
         WriteString(theEnv,outRouter," defined.\n");
        }
      else
        {
         outRouter = STDWRN;
         PrintWarningID(theEnv,"CSTRCPSR",1,true);
         WriteString(theEnv,outRouter,"Method #");
         PrintUnsignedInteger(theEnv,outRouter,meth->index);
         WriteString(theEnv,outRouter," redefined.\n");
        }
     }
   return false;

DefmethodParseError:
   if (newMethod)
     {
      RemoveConstructFromModule(theEnv,&gfunc->header);
      RemoveDefgeneric(theEnv,gfunc);
     }
   return true;
  }

/************************************************************************
  NAME         : AddMethod
  DESCRIPTION  : (Re)defines a new method for a generic
                 If method already exists, deletes old information
                    before proceeding.
  INPUTS       : 1) The generic address
                 2) The old method address (can be NULL)
                 3) The old method array position (can be -1)
                 4) The method index to assign (0 if don't care)
                 5) The parameter expression-list
                    (restrictions attached to argList pointers)
                 6) The number of restrictions
                 7) The number of locals vars reqd
                 8) The wildcard symbol (NULL if none)
                 9) Method actions
                 10) Method pretty-print form
                 11) A flag indicating whether to copy the
                     restriction types or just use the pointers
  RETURNS      : The new (old) method address
  SIDE EFFECTS : Method added to (or changed in) method array for generic
                 Restrictions repacked into new method
                 Actions and pretty-print form attached
  NOTES        : Assumes if a method is being redefined, its busy
                   count is 0!!
                 IMPORTANT: Expects that FindMethodByRestrictions() has
                   previously been called to determine if this method
                   is already present or not.  Arguments #1 and #2
                   should be the values obtained from FindMethod...().
 ************************************************************************/
Defmethod *AddMethod(
  Environment *theEnv,
  Defgeneric *gfunc,
  Defmethod *meth,
  int mposn,
  unsigned short mi,
  Expression *params,
  unsigned short rcnt,
  unsigned short lvars,
  CLIPSLexeme *wildcard,
  Expression *actions,
  char *ppForm,
  bool copyRestricts)
  {
   RESTRICTION *rptr, *rtmp;
   int i,j;
   unsigned short mai;

   SaveBusyCount(gfunc);
   if (meth == NULL)
     {
      mai = (mi != 0) ? FindMethodByIndex(gfunc,mi) : METHOD_NOT_FOUND;
      if (mai == METHOD_NOT_FOUND)
        meth = AddGenericMethod(theEnv,gfunc,mposn,mi);
      else
        {
         DeleteMethodInfo(theEnv,gfunc,&gfunc->methods[mai]);
         if (mai < mposn)
           {
            mposn--;
            for (i = mai+1 ; i <= mposn ; i++)
              GenCopyMemory(Defmethod,1,&gfunc->methods[i-1],&gfunc->methods[i]);
           }
         else
           {
            for (i = mai-1 ; i >= mposn ; i--)
              GenCopyMemory(Defmethod,1,&gfunc->methods[i+1],&gfunc->methods[i]);
           }
         meth = &gfunc->methods[mposn];
         meth->index = mi;
        }
     }
   else
     {
      /* ================================
         The old trace state is preserved
         ================================ */
      ExpressionDeinstall(theEnv,meth->actions);
      ReturnPackedExpression(theEnv,meth->actions);
      if (meth->header.ppForm != NULL)
        rm(theEnv,(void *) meth->header.ppForm,(sizeof(char) * (strlen(meth->header.ppForm)+1)));
     }
   meth->system = 0;
   meth->actions = actions;
   ExpressionInstall(theEnv,meth->actions);
   meth->header.ppForm = ppForm;
   if (mposn == -1)
     {
      RestoreBusyCount(gfunc);
      return(meth);
     }

   meth->localVarCount = lvars;
   meth->restrictionCount = rcnt;
      
   if (wildcard != NULL)
     {
      if (rcnt == 0)
        { meth->minRestrictions = RESTRICTIONS_UNBOUNDED; }
      else
        { meth->minRestrictions = rcnt - 1; }
      meth->maxRestrictions = RESTRICTIONS_UNBOUNDED;
     }
   else
     meth->minRestrictions = meth->maxRestrictions = rcnt;
   if (rcnt != 0)
     meth->restrictions = (RESTRICTION *)
                          gm2(theEnv,(sizeof(RESTRICTION) * rcnt));
   else
     meth->restrictions = NULL;
   for (i = 0 ; i < rcnt ; i++)
     {
      rptr = &meth->restrictions[i];
      rtmp = (RESTRICTION *) params->argList;
      rptr->query = PackExpression(theEnv,rtmp->query);
      rptr->tcnt = rtmp->tcnt;
      if (copyRestricts)
        {
         if (rtmp->types != NULL)
           {
            rptr->types = (void **) gm2(theEnv,(rptr->tcnt * sizeof(void *)));
            GenCopyMemory(void *,rptr->tcnt,rptr->types,rtmp->types);
           }
         else
           rptr->types = NULL;
        }
      else
        {
         rptr->types = rtmp->types;

         /* =====================================================
            Make sure the types-array is not deallocated when the
              temporary restriction nodes are
            ===================================================== */
         rtmp->tcnt = 0;
         rtmp->types = NULL;
        }
      ExpressionInstall(theEnv,rptr->query);
      for (j = 0 ; j < rptr->tcnt ; j++)
#if OBJECT_SYSTEM
        IncrementDefclassBusyCount(theEnv,(Defclass *) rptr->types[j]);
#else
        IncrementIntegerCount((CLIPSInteger *) rptr->types[j]);
#endif
      params = params->nextArg;
     }
   RestoreBusyCount(gfunc);
   return(meth);
  }

/*****************************************************
  NAME         : PackRestrictionTypes
  DESCRIPTION  : Takes the restriction type list
                   and packs it into a contiguous
                   array of void *.
  INPUTS       : 1) The restriction structure
                 2) The types expression list
  RETURNS      : Nothing useful
  SIDE EFFECTS : Array allocated & expressions freed
  NOTES        : None
 *****************************************************/
void PackRestrictionTypes(
  Environment *theEnv,
  RESTRICTION *rptr,
  Expression *types)
  {
   Expression *tmp;
   long i;

   rptr->tcnt = 0;
   for (tmp = types ; tmp != NULL ; tmp = tmp->nextArg)
     rptr->tcnt++;
   if (rptr->tcnt != 0)
     rptr->types = (void **) gm2(theEnv,(sizeof(void *) * rptr->tcnt));
   else
     rptr->types = NULL;
   for (i = 0 , tmp = types ; i < rptr->tcnt ; i++ , tmp = tmp->nextArg)
     rptr->types[i] = tmp->value;
   ReturnExpression(theEnv,types);
  }

/***************************************************
  NAME         : DeleteTempRestricts
  DESCRIPTION  : Deallocates the method
                   temporary parameter list
  INPUTS       : The head of the list
  RETURNS      : Nothing useful
  SIDE EFFECTS : List deallocated
  NOTES        : None
 ***************************************************/
void DeleteTempRestricts(
  Environment *theEnv,
  Expression *phead)
  {
   Expression *ptmp;
   RESTRICTION *rtmp;

   while (phead != NULL)
     {
      ptmp = phead;
      phead = phead->nextArg;
      rtmp = (RESTRICTION *) ptmp->argList;
      rtn_struct(theEnv,expr,ptmp);
      ReturnExpression(theEnv,rtmp->query);
      if (rtmp->tcnt != 0)
        rm(theEnv,rtmp->types,(sizeof(void *) * rtmp->tcnt));
      rtn_struct(theEnv,restriction,rtmp);
     }
  }

/**********************************************************
  NAME         : FindMethodByRestrictions
  DESCRIPTION  : See if a method for the specified
                   generic satsifies the given restrictions
  INPUTS       : 1) Generic function
                 2) Parameter/restriction expression list
                 3) Number of restrictions
                 4) Wildcard symbol (can be NULL)
                 5) Caller's buffer for holding array posn
                      of where to add new generic method
                      (-1 if method already present)
  RETURNS      : The address of the found method, NULL if
                    not found
  SIDE EFFECTS : Sets the caller's buffer to the index of
                   where to place the new method, -1 if
                   already present
  NOTES        : None
 **********************************************************/
Defmethod *FindMethodByRestrictions(
  Defgeneric *gfunc,
  Expression *params,
  int rcnt,
  CLIPSLexeme *wildcard,
  int *posn)
  {
   int i,cmp;
   int min,max;

   if (wildcard != NULL)
     {
      min = rcnt-1;
      max = -1;
     }
   else
     min = max = rcnt;
   for (i = 0 ; i < gfunc->mcnt ; i++)
     {
      cmp = RestrictionsCompare(params,rcnt,min,max,&gfunc->methods[i]);
      if (cmp == IDENTICAL)
        {
         *posn = -1;
         return(&gfunc->methods[i]);
        }
      else if (cmp == HIGHER_PRECEDENCE)
        {
         *posn = i;
         return NULL;
        }
     }
   *posn = i;
   return NULL;
  }

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

/***********************************************************
  NAME         : ValidGenericName
  DESCRIPTION  : Determines if a particular function name
                    can be overloaded
  INPUTS       : The name
  RETURNS      : True if OK, false otherwise
  SIDE EFFECTS : Error message printed
  NOTES        : GetConstructNameAndComment() (called before
                 this function) ensures that the defgeneric
                 name does not conflict with one from
                 another module
 ***********************************************************/
static bool ValidGenericName(
  Environment *theEnv,
  const char *theDefgenericName)
  {
   Defgeneric *theDefgeneric;
#if DEFFUNCTION_CONSTRUCT
   Defmodule *theModule;
   Deffunction *theDeffunction;
#endif
   struct functionDefinition *systemFunction;

   /*==============================================*/
   /* A defgeneric cannot be named the same as a   */
   /* construct type, e.g, defclass, defrule, etc. */
   /*==============================================*/

   if (FindConstruct(theEnv,theDefgenericName) != NULL)
     {
      PrintErrorID(theEnv,"GENRCPSR",3,false);
      WriteString(theEnv,STDERR,"Defgenerics are not allowed to replace constructs.\n");
      return false;
     }

#if DEFFUNCTION_CONSTRUCT
   /* ========================================
      A defgeneric cannot be named the same as
      a defffunction (either in this module or
      imported from another)
      ======================================== */
   theDeffunction = LookupDeffunctionInScope(theEnv,theDefgenericName);
   if (theDeffunction != NULL)
     {
      theModule = GetConstructModuleItem(&theDeffunction->header)->theModule;
      if (theModule != GetCurrentModule(theEnv))
        {
         PrintErrorID(theEnv,"GENRCPSR",4,false);
         WriteString(theEnv,STDERR,"Deffunction '");
         WriteString(theEnv,STDERR,DeffunctionName(theDeffunction));
         WriteString(theEnv,STDERR,"' imported from module '");
         WriteString(theEnv,STDERR,DefmoduleName(theModule));
         WriteString(theEnv,STDERR,"' conflicts with this defgeneric.\n");
         return false;
        }
      else
        {
         PrintErrorID(theEnv,"GENRCPSR",5,false);
         WriteString(theEnv,STDERR,"Defgenerics are not allowed to replace deffunctions.\n");
        }
      return false;
     }
#endif

   /*===========================================*/
   /* See if the defgeneric already exists in   */
   /* this module (or is imported from another) */
   /*===========================================*/

   theDefgeneric = FindDefgenericInModule(theEnv,theDefgenericName);
   if (theDefgeneric != NULL)
     {
      /* ===========================================
         And the redefinition of a defgeneric in
         the current module is only valid if none
         of its methods are executing
         =========================================== */
      if (MethodsExecuting(theDefgeneric))
        {
         MethodAlterError(theEnv,theDefgeneric);
         return false;
        }
     }

   /* =======================================
      Only certain specific system functions
      may be overloaded by generic functions
      ======================================= */
   systemFunction = FindFunction(theEnv,theDefgenericName);
   if ((systemFunction != NULL) ?
       (systemFunction->overloadable == false) : false)
     {
      PrintErrorID(theEnv,"GENRCPSR",16,false);
      WriteString(theEnv,STDERR,"The system function '");
      WriteString(theEnv,STDERR,theDefgenericName);
      WriteString(theEnv,STDERR,"' cannot be overloaded.\n");
      return false;
     }
   return true;
  }

#if DEBUGGING_FUNCTIONS

/***************************************************
  NAME         : CreateDefaultGenericPPForm
  DESCRIPTION  : Adds a default pretty-print form
                 for a gneric function when it is
                 impliciylt created by the defn
                 of its first method
  INPUTS       : The generic function
  RETURNS      : Nothing useful
  SIDE EFFECTS : Pretty-print form created and
                 attached.
  NOTES        : None
 ***************************************************/
static void CreateDefaultGenericPPForm(
  Environment *theEnv,
  Defgeneric *gfunc)
  {
   const char *moduleName, *genericName;
   char *buf;

   moduleName = DefmoduleName(GetCurrentModule(theEnv));
   genericName = DefgenericName(gfunc);
   buf = (char *) gm2(theEnv,(sizeof(char) * (strlen(moduleName) + strlen(genericName) + 17)));
   gensprintf(buf,"(defgeneric %s::%s)\n",moduleName,genericName);
   SetDefgenericPPForm(theEnv,gfunc,buf);
  }

#endif

/*******************************************************
  NAME         : ParseMethodNameAndIndex
  DESCRIPTION  : Parses the name of the method and
                   optional method index
  INPUTS       : 1) The logical name of the input source
                 2) Caller's buffer for method index
                    (0 if not specified)
  RETURNS      : The symbolic name of the method
  SIDE EFFECTS : None
  NOTES        : Assumes "(defmethod " already parsed
 *******************************************************/
static CLIPSLexeme *ParseMethodNameAndIndex(
  Environment *theEnv,
  const char *readSource,
  unsigned short *theIndex,
  struct token *genericInputToken)
  {
   CLIPSLexeme *gname;

   *theIndex = 0;
   gname = GetConstructNameAndComment(theEnv,readSource,genericInputToken,"defgeneric",
                                      (FindConstructFunction *) FindDefgenericInModule,
                                      NULL,"&",true,false,true,true);
   if (gname == NULL)
     return NULL;
   if (genericInputToken->tknType == INTEGER_TOKEN)
     {
      unsigned short tmp;

      PPBackup(theEnv);
      PPBackup(theEnv);
      SavePPBuffer(theEnv," ");
      SavePPBuffer(theEnv,genericInputToken->printForm);
      tmp = (unsigned short) genericInputToken->integerValue->contents;
      if (tmp < 1)
        {
         PrintErrorID(theEnv,"GENRCPSR",6,false);
         WriteString(theEnv,STDERR,"Method index out of range.\n");
         return NULL;
        }
      *theIndex = tmp;
      PPCRAndIndent(theEnv);
      GetToken(theEnv,readSource,genericInputToken);
     }
   if (genericInputToken->tknType == STRING_TOKEN)
     {
      PPBackup(theEnv);
      PPBackup(theEnv);
      SavePPBuffer(theEnv," ");
      SavePPBuffer(theEnv,genericInputToken->printForm);
      PPCRAndIndent(theEnv);
      GetToken(theEnv,readSource,genericInputToken);
     }
   return(gname);
  }

/************************************************************************
  NAME         : ParseMethodParameters
  DESCRIPTION  : Parses method restrictions
                   (parameter names with class and expression specifiers)
  INPUTS       : 1) The logical name of the input source
                 2) Caller's buffer for the parameter name list
                    (Restriction structures are attached to
                     argList pointers of parameter nodes)
                 3) Caller's buffer for wildcard symbol (if any)
  RETURNS      : The number of parameters, or -1 on errors
  SIDE EFFECTS : Memory allocated for parameters and restrictions
                 Parameter names stored in expression list
                 Parameter restrictions stored in contiguous array
  NOTES        : Any memory allocated is freed on errors
                 Assumes first opening parenthesis has been scanned
 ************************************************************************/
static unsigned short ParseMethodParameters(
  Environment *theEnv,
  const char *readSource,
  Expression **params,
  CLIPSLexeme **wildcard,
  struct token *genericInputToken)
  {
   Expression *phead = NULL,*pprv;
   CLIPSLexeme *pname;
   RESTRICTION *rtmp;
   unsigned short rcnt = 0;

   *wildcard = NULL;
   *params = NULL;
   if (genericInputToken->tknType != LEFT_PARENTHESIS_TOKEN)
     {
      PrintErrorID(theEnv,"GENRCPSR",7,false);
      WriteString(theEnv,STDERR,"Expected a '(' to begin method parameter restrictions.\n");
      return PARAMETER_ERROR;
     }
   GetToken(theEnv,readSource,genericInputToken);
   while (genericInputToken->tknType != RIGHT_PARENTHESIS_TOKEN)
     {
      if (*wildcard != NULL)
        {
         DeleteTempRestricts(theEnv,phead);
         PrintErrorID(theEnv,"PRCCODE",8,false);
         WriteString(theEnv,STDERR,"No parameters allowed after wildcard parameter.\n");
         return PARAMETER_ERROR;
        }
      if ((genericInputToken->tknType == SF_VARIABLE_TOKEN) ||
          (genericInputToken->tknType == MF_VARIABLE_TOKEN))
        {
         pname = genericInputToken->lexemeValue;
         if (DuplicateParameters(theEnv,phead,&pprv,pname))
           {
            DeleteTempRestricts(theEnv,phead);
            return PARAMETER_ERROR;
           }
         if (genericInputToken->tknType == MF_VARIABLE_TOKEN)
           *wildcard = pname;
         rtmp = get_struct(theEnv,restriction);
         PackRestrictionTypes(theEnv,rtmp,NULL);
         rtmp->query = NULL;
         phead = AddParameter(theEnv,phead,pprv,pname,rtmp);
         rcnt++;
        }
      else if (genericInputToken->tknType == LEFT_PARENTHESIS_TOKEN)
        {
         GetToken(theEnv,readSource,genericInputToken);
         if ((genericInputToken->tknType != SF_VARIABLE_TOKEN) &&
             (genericInputToken->tknType != MF_VARIABLE_TOKEN))
           {
            DeleteTempRestricts(theEnv,phead);
            PrintErrorID(theEnv,"GENRCPSR",8,false);
            WriteString(theEnv,STDERR,"Expected a variable for parameter specification.\n");
            return PARAMETER_ERROR;
           }
         pname = genericInputToken->lexemeValue;
         if (DuplicateParameters(theEnv,phead,&pprv,pname))
           {
            DeleteTempRestricts(theEnv,phead);
            return PARAMETER_ERROR;
           }
         if (genericInputToken->tknType == MF_VARIABLE_TOKEN)
           *wildcard = pname;
         SavePPBuffer(theEnv," ");
         rtmp = ParseRestriction(theEnv,readSource);
         if (rtmp == NULL)
           {
            DeleteTempRestricts(theEnv,phead);
            return PARAMETER_ERROR;
           }
         phead = AddParameter(theEnv,phead,pprv,pname,rtmp);
         rcnt++;
        }
      else
        {
         DeleteTempRestricts(theEnv,phead);
         PrintErrorID(theEnv,"GENRCPSR",9,false);
         WriteString(theEnv,STDERR,"Expected a variable or '(' for parameter specification.\n");
         return PARAMETER_ERROR;
        }
      PPCRAndIndent(theEnv);
      GetToken(theEnv,readSource,genericInputToken);
     }
   if (rcnt != 0)
     {
      PPBackup(theEnv);
      PPBackup(theEnv);
      SavePPBuffer(theEnv,")");
     }
   *params = phead;
   return(rcnt);
  }

/************************************************************
  NAME         : ParseRestriction
  DESCRIPTION  : Parses the restriction for a parameter of a
                   method
                 This restriction is comprised of:
                   1) A list of classes (or types) that are
                      allowed for the parameter (None
                      if no type restriction)
                   2) And an optional restriction-query
                      expression
  INPUTS       : The logical name of the input source
  RETURNS      : The address of a RESTRICTION node, NULL on
                   errors
  SIDE EFFECTS : RESTRICTION node allocated
                   Types are in a contiguous array of void *
                   Query is an expression
  NOTES        : Assumes "(?<var> " has already been parsed
                 H/L Syntax: <type>* [<query>])
 ************************************************************/
static RESTRICTION *ParseRestriction(
  Environment *theEnv,
  const char *readSource)
  {
   Expression *types = NULL,*new_types,
              *typesbot,*tmp,*tmp2,
              *query = NULL;
   RESTRICTION *rptr;
   struct token genericInputToken;

   GetToken(theEnv,readSource,&genericInputToken);
   while (genericInputToken.tknType != RIGHT_PARENTHESIS_TOKEN)
     {
      if (query != NULL)
        {
         PrintErrorID(theEnv,"GENRCPSR",10,false);
         WriteString(theEnv,STDERR,"Query must be last in parameter restriction.\n");
         ReturnExpression(theEnv,query);
         ReturnExpression(theEnv,types);
         return NULL;
        }
      if (genericInputToken.tknType == SYMBOL_TOKEN)
        {
         new_types = ValidType(theEnv,genericInputToken.lexemeValue);
         if (new_types == NULL)
           {
            ReturnExpression(theEnv,types);
            ReturnExpression(theEnv,query);
            return NULL;
           }
         if (types == NULL)
           types = new_types;
         else
           {
            for (typesbot = tmp = types ; tmp != NULL ; tmp = tmp->nextArg)
              {
               for (tmp2 = new_types ; tmp2 != NULL ; tmp2 = tmp2->nextArg)
                 {
                  if (tmp->value == tmp2->value)
                    {
                     PrintErrorID(theEnv,"GENRCPSR",11,false);
#if OBJECT_SYSTEM
                     WriteString(theEnv,STDERR,"Duplicate classes not allowed in parameter restriction.\n");
#else
                     WriteString(theEnv,STDERR,"Duplicate types not allowed in parameter restriction.\n");
#endif
                     ReturnExpression(theEnv,query);
                     ReturnExpression(theEnv,types);
                     ReturnExpression(theEnv,new_types);
                     return NULL;
                    }
                  if (RedundantClasses(theEnv,tmp->value,tmp2->value))
                    {
                     ReturnExpression(theEnv,query);
                     ReturnExpression(theEnv,types);
                     ReturnExpression(theEnv,new_types);
                     return NULL;
                    }
                 }
               typesbot = tmp;
              }
            typesbot->nextArg = new_types;
           }
        }
      else if (genericInputToken.tknType == LEFT_PARENTHESIS_TOKEN)
        {
         query = Function1Parse(theEnv,readSource);
         if (query == NULL)
           {
            ReturnExpression(theEnv,types);
            return NULL;
           }
         if (GetParsedBindNames(theEnv) != NULL)
           {
            PrintErrorID(theEnv,"GENRCPSR",12,false);
            WriteString(theEnv,STDERR,"Binds are not allowed in query expressions.\n");
            ReturnExpression(theEnv,query);
            ReturnExpression(theEnv,types);
            return NULL;
           }
        }
#if DEFGLOBAL_CONSTRUCT
      else if (genericInputToken.tknType == GBL_VARIABLE_TOKEN)
        query = GenConstant(theEnv,GBL_VARIABLE,genericInputToken.value);
#endif
      else
        {
         PrintErrorID(theEnv,"GENRCPSR",13,false);
#if OBJECT_SYSTEM
         WriteString(theEnv,STDERR,"Expected a valid class name or query.\n");
#else
         WriteString(theEnv,STDERR,"Expected a valid type name or query.\n");
#endif
         ReturnExpression(theEnv,query);
         ReturnExpression(theEnv,types);
         return NULL;
        }
      SavePPBuffer(theEnv," ");
      GetToken(theEnv,readSource,&genericInputToken);
     }
   PPBackup(theEnv);
   PPBackup(theEnv);
   SavePPBuffer(theEnv,")");
   if ((types == NULL) && (query == NULL))
     {
      PrintErrorID(theEnv,"GENRCPSR",13,false);
#if OBJECT_SYSTEM
      WriteString(theEnv,STDERR,"Expected a valid class name or query.\n");
#else
      WriteString(theEnv,STDERR,"Expected a valid type name or query.\n");
#endif
      return NULL;
     }
   rptr = get_struct(theEnv,restriction);
   rptr->query = query;
   PackRestrictionTypes(theEnv,rptr,types);
   return(rptr);
  }

/*****************************************************************
  NAME         : ReplaceCurrentArgRefs
  DESCRIPTION  : Replaces all references to ?current-argument in
                  method parameter queries with special calls
                  to (gnrc-current-arg)
  INPUTS       : The query expression
  RETURNS      : Nothing useful
  SIDE EFFECTS : Variable references to ?current-argument replaced
  NOTES        : None
 *****************************************************************/
static void ReplaceCurrentArgRefs(
  Environment *theEnv,
  Expression *query)
  {
   while (query != NULL)
     {
      if ((query->type != SF_VARIABLE) ? false :
          (strcmp(query->lexemeValue->contents,CURR_ARG_VAR) == 0))
        {
         query->type = FCALL;
         query->value = FindFunction(theEnv,"(gnrc-current-arg)");
        }
      if (query->argList != NULL)
        ReplaceCurrentArgRefs(theEnv,query->argList);
      query = query->nextArg;
     }
  }

/**********************************************************
  NAME         : DuplicateParameters
  DESCRIPTION  : Examines the parameter expression
                   chain for a method looking duplicates.
  INPUTS       : 1) The parameter chain (can be NULL)
                 2) Caller's buffer for address of
                    last node searched (can be used to
                    later attach new parameter)
                 3) The name of the parameter being checked
  RETURNS      : True if duplicates found, false otherwise
  SIDE EFFECTS : Caller's prv address set
  NOTES        : Assumes all parameter list nodes are WORDS
 **********************************************************/
static bool DuplicateParameters(
  Environment *theEnv,
  Expression *head,
  Expression **prv,
  CLIPSLexeme *name)
  {
   *prv = NULL;
   while (head != NULL)
     {
      if (head->value == (void *) name)
        {
         PrintErrorID(theEnv,"PRCCODE",7,false);
         WriteString(theEnv,STDERR,"Duplicate parameter names not allowed.\n");
         return true;
        }
      *prv = head;
      head = head->nextArg;
     }
   return false;
  }

/*****************************************************************
  NAME         : AddParameter
  DESCRIPTION  : Shoves a new paramter with its restriction
                   onto the list for a method
                 The parameter list is a list of expressions
                   linked by neext_arg pointers, and the
                   argList pointers are used for the restrictions
  INPUTS       : 1) The head of the list
                 2) The bottom of the list
                 3) The parameter name
                 4) The parameter restriction
  RETURNS      : The (new) head of the list
  SIDE EFFECTS : New parameter expression node allocated, set,
                   and attached
  NOTES        : None
 *****************************************************************/
static Expression *AddParameter(
  Environment *theEnv,
  Expression *phead,
  Expression *pprv,
  CLIPSLexeme *pname,
  RESTRICTION *rptr)
  {
   Expression *ptmp;

   ptmp = GenConstant(theEnv,SYMBOL_TYPE,pname);
   if (phead == NULL)
     phead = ptmp;
   else
     pprv->nextArg = ptmp;
   ptmp->argList = (Expression *) rptr;
   return(phead);
  }

/**************************************************************
  NAME         : ValidType
  DESCRIPTION  : Examines the name of a restriction type and
                   forms a list of integer-code expressions
                   corresponding to the primitive types
                 (or a Class address if COOL is installed)
  INPUTS       : The type name
  RETURNS      : The expression chain (NULL on errors)
  SIDE EFFECTS : Expression type chain allocated
                   one or more nodes holding codes for types
                   (or class addresses)
  NOTES        : None
 *************************************************************/
static Expression *ValidType(
  Environment *theEnv,
  CLIPSLexeme *tname)
  {
#if OBJECT_SYSTEM
   Defclass *cls;

   if (FindModuleSeparator(tname->contents))
     IllegalModuleSpecifierMessage(theEnv);
   else
     {
      cls = LookupDefclassInScope(theEnv,tname->contents);
      if (cls == NULL)
        {
         PrintErrorID(theEnv,"GENRCPSR",14,false);
         WriteString(theEnv,STDERR,"Unknown class in method.\n");
         return NULL;
        }
      return(GenConstant(theEnv,DEFCLASS_PTR,cls));
     }
#else
   if (strcmp(tname->contents,INTEGER_TYPE_NAME) == 0)
     return(GenConstant(theEnv,INTEGER_TYPE,CreateInteger(theEnv,INTEGER_TYPE)));
   if (strcmp(tname->contents,FLOAT_TYPE_NAME) == 0)
     return(GenConstant(theEnv,INTEGER_TYPE,CreateInteger(theEnv,FLOAT_TYPE)));
   if (strcmp(tname->contents,SYMBOL_TYPE_NAME) == 0)
     return(GenConstant(theEnv,INTEGER_TYPE,CreateInteger(theEnv,SYMBOL_TYPE)));
   if (strcmp(tname->contents,STRING_TYPE_NAME) == 0)
     return(GenConstant(theEnv,INTEGER_TYPE,CreateInteger(theEnv,STRING_TYPE)));
   if (strcmp(tname->contents,MULTIFIELD_TYPE_NAME) == 0)
     return(GenConstant(theEnv,INTEGER_TYPE,CreateInteger(theEnv,MULTIFIELD_TYPE)));
   if (strcmp(tname->contents,EXTERNAL_ADDRESS_TYPE_NAME) == 0)
     return(GenConstant(theEnv,INTEGER_TYPE,CreateInteger(theEnv,EXTERNAL_ADDRESS_TYPE)));
   if (strcmp(tname->contents,FACT_ADDRESS_TYPE_NAME) == 0)
     return(GenConstant(theEnv,INTEGER_TYPE,CreateInteger(theEnv,FACT_ADDRESS_TYPE)));
   if (strcmp(tname->contents,NUMBER_TYPE_NAME) == 0)
     return(GenConstant(theEnv,INTEGER_TYPE,CreateInteger(theEnv,NUMBER_TYPE_CODE)));
   if (strcmp(tname->contents,LEXEME_TYPE_NAME) == 0)
     return(GenConstant(theEnv,INTEGER_TYPE,CreateInteger(theEnv,LEXEME_TYPE_CODE)));
   if (strcmp(tname->contents,ADDRESS_TYPE_NAME) == 0)
     return(GenConstant(theEnv,INTEGER_TYPE,CreateInteger(theEnv,ADDRESS_TYPE_CODE)));
   if (strcmp(tname->contents,PRIMITIVE_TYPE_NAME) == 0)
     return(GenConstant(theEnv,INTEGER_TYPE,CreateInteger(theEnv,PRIMITIVE_TYPE_CODE)));
   if (strcmp(tname->contents,OBJECT_TYPE_NAME) == 0)
     return(GenConstant(theEnv,INTEGER_TYPE,CreateInteger(theEnv,OBJECT_TYPE_CODE)));
   if (strcmp(tname->contents,INSTANCE_TYPE_NAME) == 0)
     return(GenConstant(theEnv,INTEGER_TYPE,CreateInteger(theEnv,INSTANCE_TYPE_CODE)));
   if (strcmp(tname->contents,INSTANCE_NAME_TYPE_NAME) == 0)
     return(GenConstant(theEnv,INTEGER_TYPE,CreateInteger(theEnv,INSTANCE_NAME_TYPE)));
   if (strcmp(tname->contents,INSTANCE_ADDRESS_TYPE_NAME) == 0)
     return(GenConstant(theEnv,INTEGER_TYPE,CreateInteger(theEnv,INSTANCE_ADDRESS_TYPE)));

   PrintErrorID(theEnv,"GENRCPSR",14,false);
   WriteString(theEnv,STDERR,"Unknown type in method.\n");
#endif
   return NULL;
  }

/*************************************************************
  NAME         : RedundantClasses
  DESCRIPTION  : Determines if one class (type) is
                 subsumes (or is subsumed by) another.
  INPUTS       : Two void pointers which are class pointers
                 if COOL is installed or integer hash nodes
                 for type codes otherwise.
  RETURNS      : True if there is subsumption, false otherwise
  SIDE EFFECTS : An error message is printed, if appropriate.
  NOTES        : None
 *************************************************************/
static bool RedundantClasses(
  Environment *theEnv,
  void *c1,
  void *c2)
  {
   const char *tname;

#if OBJECT_SYSTEM
   if (HasSuperclass((Defclass *) c1,(Defclass *) c2))
     tname = DefclassName((Defclass *) c1);
   else if (HasSuperclass((Defclass *) c2,(Defclass *) c1))
     tname = DefclassName((Defclass *) c2);
#else
   if (SubsumeType(((CLIPSInteger *) c1)->contents,((CLIPSInteger *) c2)->contents))
     tname = TypeName(theEnv,((CLIPSInteger *) c1)->contents);
   else if (SubsumeType(((CLIPSInteger *) c2)->contents,((CLIPSInteger *) c1)->contents))
     tname = TypeName(theEnv,((CLIPSInteger *) c2)->contents);
#endif
   else
     return false;
   PrintErrorID(theEnv,"GENRCPSR",15,false);
   WriteString(theEnv,STDERR,"Class '");
   WriteString(theEnv,STDERR,tname);
   WriteString(theEnv,STDERR,"' is redundant.\n");
   return true;
  }

/*********************************************************
  NAME         : AddGeneric
  DESCRIPTION  : Inserts a new generic function
                   header into the generic list
  INPUTS       : 1) Symbolic name of the new generic
                 2) Caller's input buffer for flag
                      if added generic is new or not
  RETURNS      : The address of the new node, or
                   address of old node if already present
  SIDE EFFECTS : Generic header inserted
                 If the node is already present, it is
                   moved to the end of the list, otherwise
                   the new node is inserted at the end
  NOTES        : None
 *********************************************************/
static Defgeneric *AddGeneric(
  Environment *theEnv,
  CLIPSLexeme *name,
  bool *newGeneric)
  {
   Defgeneric *gfunc;

   gfunc = FindDefgenericInModule(theEnv,name->contents);
   if (gfunc != NULL)
     {
      *newGeneric = false;

      if (ConstructData(theEnv)->CheckSyntaxMode)
        { return(gfunc); }

      /* ================================
         The old trace state is preserved
         ================================ */
      RemoveConstructFromModule(theEnv,&gfunc->header);
     }
   else
     {
      *newGeneric = true;
      gfunc = NewGeneric(theEnv,name);
      IncrementLexemeCount(name);
      AddImplicitMethods(theEnv,gfunc);
     }
   AddConstructToModule(&gfunc->header);
   return(gfunc);
  }

/**********************************************************************
  NAME         : AddGenericMethod
  DESCRIPTION  : Inserts a blank method (with the method-index set)
                   into the specified position of the generic
                   method array
  INPUTS       : 1) The generic function
                 2) The index where to add the method in the array
                 3) The method user-index (0 if don't care)
  RETURNS      : The address of the new method
  SIDE EFFECTS : Fields initialized (index set) and new method inserted
                 Generic function new method-index set to specified
                   by user-index if > current new method-index
  NOTES        : None
 **********************************************************************/
static Defmethod *AddGenericMethod(
  Environment *theEnv,
  Defgeneric *gfunc,
  int mposn,
  unsigned short mi)
  {
   Defmethod *narr;
   long b, e;

   narr = (Defmethod *) gm2(theEnv,(sizeof(Defmethod) * (gfunc->mcnt+1)));
   for (b = e = 0 ; b < gfunc->mcnt ; b++ , e++)
     {
      if (b == mposn)
        e++;
      GenCopyMemory(Defmethod,1,&narr[e],&gfunc->methods[b]);
     }
   if (mi == 0)
     narr[mposn].index = gfunc->new_index++;
   else
     {
      narr[mposn].index = mi;
      if (mi >= gfunc->new_index)
        gfunc->new_index = mi + 1;
     }
   narr[mposn].busy = 0;
#if DEBUGGING_FUNCTIONS
   narr[mposn].trace = DefgenericData(theEnv)->WatchMethods;
#endif
   narr[mposn].minRestrictions = 0;
   narr[mposn].maxRestrictions = 0;
   narr[mposn].restrictionCount = 0;
   narr[mposn].localVarCount = 0;
   narr[mposn].system = 0;
   narr[mposn].restrictions = NULL;
   narr[mposn].actions = NULL;
   narr[mposn].header.name = NULL;
   narr[mposn].header.next = NULL;
   narr[mposn].header.constructType = DEFMETHOD;
   narr[mposn].header.env = theEnv;
   narr[mposn].header.whichModule = gfunc->header.whichModule;
   narr[mposn].header.ppForm = NULL;
   narr[mposn].header.usrData = NULL;

   if (gfunc->mcnt != 0)
     rm(theEnv,gfunc->methods,(sizeof(Defmethod) * gfunc->mcnt));
   gfunc->mcnt++;
   gfunc->methods = narr;
   return(&narr[mposn]);
  }

/****************************************************************
  NAME         : RestrictionsCompare
  DESCRIPTION  : Compares the restriction-expression list
                   with an existing methods restrictions to
                   determine an ordering
  INPUTS       : 1) The parameter/restriction expression list
                 2) The total number of restrictions
                 3) The number of minimum restrictions
                 4) The number of maximum restrictions (-1
                    if unlimited)
                 5) The method with which to compare restrictions
  RETURNS      : A code representing how the method restrictions
                   -1 : New restrictions have higher precedence
                    0 : New restrictions are identical
                    1 : New restrictions have lower precedence
  SIDE EFFECTS : None
  NOTES        : The new restrictions are stored in the argList
                   pointers of the parameter expressions
 ****************************************************************/
static int RestrictionsCompare(
  Expression *params,
  int rcnt,
  int min,
  int max,
  Defmethod *meth)
  {
   int i;
   RESTRICTION *r1,*r2;
   bool diff = false;
   int rtn;

   for (i = 0 ; (i < rcnt) && (i < meth->restrictionCount) ; i++)
     {
      /* =============================================================
         A wildcard parameter always has lower precedence than
         a regular parameter, regardless of the class restriction list
         ============================================================= */
      if ((i == rcnt-1) && (max == -1) &&
          (meth->maxRestrictions != RESTRICTIONS_UNBOUNDED))
        return LOWER_PRECEDENCE;
      if ((i == meth->restrictionCount-1) && (max != -1) &&
          (meth->maxRestrictions == RESTRICTIONS_UNBOUNDED))
        return HIGHER_PRECEDENCE;

      /* =============================================================
         The parameter with the most specific type list has precedence
         ============================================================= */
      r1 = (RESTRICTION *) params->argList;
      r2 = &meth->restrictions[i];
      rtn = TypeListCompare(r1,r2);
      if (rtn != IDENTICAL)
        return rtn;

      /* =====================================================
         The parameter with a query restriction has precedence
         ===================================================== */
      if ((r1->query == NULL) && (r2->query != NULL))
        return LOWER_PRECEDENCE;
      if ((r1->query != NULL) && (r2->query == NULL))
        return HIGHER_PRECEDENCE;

      /* ==========================================================
         Remember if the method restrictions differ at all - query
         expressions must be identical as well for the restrictions
         to be the same
         ========================================================== */
      if (IdenticalExpression(r1->query,r2->query) == false)
        diff = true;
      params = params->nextArg;
     }

   /* =============================================================
      If the methods have the same number of parameters here, they
      are either the same restrictions, or they differ only in
      the query restrictions
      ============================================================= */
   if (rcnt == meth->restrictionCount)
     return(diff ? LOWER_PRECEDENCE : IDENTICAL);

   /* =============================================
      The method with the greater number of regular
      parameters has precedence

      If they require the smae # of reg params,
      then one without a wildcard has precedence
      ============================================= */
   if (min > meth->minRestrictions)
     return HIGHER_PRECEDENCE;
   if (meth->minRestrictions < min)
     return LOWER_PRECEDENCE;
   return((max == - 1) ? LOWER_PRECEDENCE : HIGHER_PRECEDENCE);
  }

/*****************************************************
  NAME         : TypeListCompare
  DESCRIPTION  : Determines the precedence between
                   the class lists on two restrictions
  INPUTS       : 1) Restriction address #1
                 2) Restriction address #2
  RETURNS      : -1 : r1 precedes r2
                  0 : Identical classes
                  1 : r2 precedes r1
  SIDE EFFECTS : None
  NOTES        : None
 *****************************************************/
static int TypeListCompare(
  RESTRICTION *r1,
  RESTRICTION *r2)
  {
   long i;
   bool diff = false;

   if ((r1->tcnt == 0) && (r2->tcnt == 0))
     return(IDENTICAL);
   if (r1->tcnt == 0)
     return(LOWER_PRECEDENCE);
   if (r2->tcnt == 0)
     return(HIGHER_PRECEDENCE);
   for (i = 0 ; (i < r1->tcnt) && (i < r2->tcnt) ; i++)
     {
      if (r1->types[i] != r2->types[i])
        {
         diff = true;
#if OBJECT_SYSTEM
         if (HasSuperclass((Defclass *) r1->types[i],(Defclass *) r2->types[i]))
           return(HIGHER_PRECEDENCE);
         if (HasSuperclass((Defclass *) r2->types[i],(Defclass *) r1->types[i]))
           return(LOWER_PRECEDENCE);
#else
         if (SubsumeType(((CLIPSInteger *) r1->types[i])->contents,((CLIPSInteger *) r2->types[i])->contents))
           return(HIGHER_PRECEDENCE);
         if (SubsumeType(((CLIPSInteger *) r2->types[i])->contents,((CLIPSInteger *) r1->types[i])->contents))
           return(LOWER_PRECEDENCE);
#endif
        }
     }
   if (r1->tcnt < r2->tcnt)
     return(HIGHER_PRECEDENCE);
   if (r1->tcnt > r2->tcnt)
     return(LOWER_PRECEDENCE);
   if (diff)
     return(LOWER_PRECEDENCE);
   return(IDENTICAL);
  }

/***************************************************
  NAME         : NewGeneric
  DESCRIPTION  : Allocates and initializes a new
                   generic function header
  INPUTS       : The name of the new generic
  RETURNS      : The address of the new generic
  SIDE EFFECTS : Generic function  header created
  NOTES        : None
 ***************************************************/
static Defgeneric *NewGeneric(
  Environment *theEnv,
  CLIPSLexeme *gname)
  {
   Defgeneric *ngen;

   ngen = get_struct(theEnv,defgeneric);
   InitializeConstructHeader(theEnv,"defgeneric",DEFGENERIC,&ngen->header,gname);
   ngen->busy = 0;
   ngen->new_index = 1;
   ngen->methods = NULL;
   ngen->mcnt = 0;
#if DEBUGGING_FUNCTIONS
   ngen->trace = DefgenericData(theEnv)->WatchGenerics;
#endif
   return(ngen);
  }

#endif /* DEFGENERIC_CONSTRUCT && (! BLOAD_ONLY) && (! RUN_TIME) */

/***************************************************
  NAME         :
  DESCRIPTION  :
  INPUTS       :
  RETURNS      :
  SIDE EFFECTS :
  NOTES        :
 ***************************************************/