genrcpsr.c

NASA 开发使用的一个专家系统

globle DEFMETHOD *AddMethod(gfunc,meth,mposn,mi,params,rcnt,lvars,
                         wildcard,actions,ppForm,copyRestricts)
  DEFGENERIC *gfunc;
  SYMBOL_HN *wildcard;
  DEFMETHOD *meth;
  int mposn,rcnt,lvars,copyRestricts;
  unsigned mi;
  EXPRESSION *params,*actions;
  char *ppForm;
  {
   RESTRICTION *rptr,*rtmp;
   register int i,j;
   int mai;
   
   SaveBusyCount(gfunc);
   if (meth == NULL)
     {
      mai = (mi != 0) ? FindMethodByIndex(gfunc,mi) : -1;
      if (mai == -1)
        meth = AddGenericMethod(gfunc,mposn,mi);
      else
        {
         DeleteMethodInfo(gfunc,&gfunc->methods[mai]);
         if (mai < mposn)
           {
            mposn--;
            for (i = mai+1 ; i <= mposn ; i++)
              CopyMemory(DEFMETHOD,1,&gfunc->methods[i-1],&gfunc->methods[i]);
           }
         else
           {
            for (i = mai-1 ; i >= mposn ; i--)
              CopyMemory(DEFMETHOD,1,&gfunc->methods[i+1],&gfunc->methods[i]);
           }
         meth = &gfunc->methods[mposn];
         meth->index = mi;
        }
     }
   else
     {
      /* ================================
         The old trace state is preserved
         ================================ */
      ExpressionDeinstall(meth->actions);
      ReturnPackedExpression(meth->actions);
      if (meth->ppForm != NULL)
        rm((VOID *) meth->ppForm,(int) (sizeof(char) * (strlen(meth->ppForm)+1)));
     }
   meth->system = 0;
   meth->actions = actions;
   ExpressionInstall(meth->actions);
   meth->ppForm = ppForm;
   if (mposn == -1)
     {
      RestoreBusyCount(gfunc);
      return(meth);
     }
   
   meth->localVarCount = lvars;
   meth->restrictionCount = rcnt;
   if (wildcard != NULL)
     {
      meth->minRestrictions = rcnt-1;
      meth->maxRestrictions = -1;
     }
   else
     meth->minRestrictions = meth->maxRestrictions = rcnt;
   if (rcnt != 0)
     meth->restrictions = (RESTRICTION *) 
                          gm2((int) (sizeof(RESTRICTION) * rcnt));
   else
     meth->restrictions = NULL;
   for (i = 0 ; i < rcnt ; i++)
     {
      rptr = &meth->restrictions[i];
      rtmp = (RESTRICTION *) params->argList;
      rptr->query = PackExpression(rtmp->query);
      rptr->tcnt = rtmp->tcnt;
      if (copyRestricts)
        {
         if (rtmp->types != NULL)
           {
            rptr->types = (VOID **) gm2((int) (rptr->tcnt * sizeof(VOID *)));
            CopyMemory(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(rptr->query);
      for (j = 0 ; j < rptr->tcnt ; j++)
#if OBJECT_SYSTEM
        IncrementDefclassBusyCount(rptr->types[j]);
#else
        IncrementIntegerCount((INTEGER_HN *) 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
 *****************************************************/
globle VOID PackRestrictionTypes(rptr,types)
  RESTRICTION *rptr;
  EXPRESSION *types;
  {
   EXPRESSION *tmp;
   register int i;
   
   rptr->tcnt = 0;
   for (tmp = types ; tmp != NULL ; tmp = tmp->nextArg)
     rptr->tcnt++;
   if (rptr->tcnt != 0)
     rptr->types = (VOID **) gm2((int) (sizeof(VOID *) * rptr->tcnt));
   else
     rptr->types = NULL;
   for (i = 0 , tmp = types ; i < rptr->tcnt ; i++ , tmp = tmp->nextArg)
     rptr->types[i] = (VOID *) tmp->value;
   ReturnExpression(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
 ***************************************************/
globle VOID DeleteTempRestricts(phead)
  EXPRESSION *phead;
  {
   EXPRESSION *ptmp;
   RESTRICTION *rtmp;
   
   while (phead != NULL)
     {
      ptmp = phead;
      phead = phead->nextArg;
      rtmp = (RESTRICTION *) ptmp->argList;
      rtn_struct(expr,ptmp);
      ReturnExpression(rtmp->query);
      if (rtmp->tcnt != 0)
        rm((VOID *) rtmp->types,(int) (sizeof(VOID *) * rtmp->tcnt));
      rtn_struct(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
 **********************************************************/
globle DEFMETHOD *FindMethodByRestrictions(gfunc,params,rcnt,wildcard,posn)
  DEFGENERIC *gfunc;
  EXPRESSION *params;
  SYMBOL_HN *wildcard;
  int rcnt,*posn;
  {
   register 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      : CLIPS_TRUE if OK, CLIPS_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 BOOLEAN ValidGenericName(theDefgenericName)
  char *theDefgenericName;
  {
   struct constructHeader *theDefgeneric;
#if DEFFUNCTION_CONSTRUCT
   struct defmodule *theModule;
   struct constructHeader *theDeffunction;
#endif
   struct FunctionDefinition *systemFunction;
   
   /* ============================================
      A defgeneric cannot be named the same as a
      construct type, e.g, defclass, defrule, etc.
      ============================================ */
   if (FindConstruct(theDefgenericName) != NULL)
     {
      PrintErrorID("GENRCPSR",3,CLIPS_FALSE);
      PrintCLIPS(WERROR,"Defgenerics are not allowed to replace constructs.\n");
      return(CLIPS_FALSE);
     }

#if DEFFUNCTION_CONSTRUCT
   /* ========================================
      A defgeneric cannot be named the same as
      a defffunction (either in this module or
      imported from another)
      ======================================== */
   theDeffunction = 
      (struct constructHeader *) LookupDeffunctionInScope(theDefgenericName);
   if (theDeffunction != NULL)
     {
      theModule = GetConstructModuleItem(theDeffunction)->theModule;
      if (theModule != ((struct defmodule *) GetCurrentModule()))
        {      
         PrintErrorID("GENRCPSR",4,CLIPS_FALSE);
         PrintCLIPS(WERROR,"Deffunction ");
         PrintCLIPS(WERROR,GetDeffunctionName((VOID *) theDeffunction));
         PrintCLIPS(WERROR," imported from module ");
         PrintCLIPS(WERROR,GetDefmoduleName((VOID *) theModule));
         PrintCLIPS(WERROR," conflicts with this defgeneric.\n");
         return(CLIPS_FALSE);
        }
      else
        {
         PrintErrorID("GENRCPSR",5,CLIPS_FALSE);
         PrintCLIPS(WERROR,"Defgenerics are not allowed to replace deffunctions.\n");
        }
      return(CLIPS_FALSE);
     }
#endif
      
   /* =========================================
      See if the defgeneric already exists in
      this module (or is imported from another)
      ========================================= */
   theDefgeneric = (struct constructHeader *) FindDefgeneric(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((DEFGENERIC *) theDefgeneric))
        {
         MethodAlterError((DEFGENERIC *) theDefgeneric);
         return(CLIPS_FALSE);
        }
     }
   
   /* =======================================
      Only certain specific system functions
      may be overloaded by generic functions
      ======================================= */
   systemFunction = FindFunction(theDefgenericName);
   if ((systemFunction != NULL) ? 
       (systemFunction->overloadable == CLIPS_FALSE) : CLIPS_FALSE)
     {
      PrintErrorID("GENRCPSR",16,CLIPS_FALSE);
      PrintCLIPS(WERROR,"The system function ");
      PrintCLIPS(WERROR,theDefgenericName);
      PrintCLIPS(WERROR," cannot be overloaded.\n");
      return(CLIPS_FALSE);
     }
   return(CLIPS_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(gfunc)
  DEFGENERIC *gfunc;
  {
   char *moduleName,*genericName,*buf;
   
   moduleName = GetDefmoduleName((VOID *) ((struct defmodule *) GetCurrentModule()));
   genericName = GetDefgenericName((VOID *) gfunc);
   buf = (char *) gm2((int) (sizeof(char) * (strlen(moduleName) + strlen(genericName) + 17)));
   sprintf(buf,"(defgeneric %s::%s)\n",moduleName,genericName);
   SetDefgenericPPForm((VOID *) 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 SYMBOL_HN *ParseMethodNameAndIndex(readSource,index)
  char *readSource;
  unsigned *index;
  {
   SYMBOL_HN *gname;
   
   *index = 0;
   gname = GetConstructNameAndComment(readSource,&GenericInputToken,"defgeneric",
                                      FindDefgeneric,NULL,"&",CLIPS_TRUE,