genrcfun.c

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

  RETURNS      : CLIPS_TRUE if any methods are executing,
                   CLIPS_FALSE otherwise
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
globle int MethodsExecuting(gfunc)
  DEFGENERIC *gfunc;
  {
   register unsigned i;
   
   for (i = 0 ; i < gfunc->mcnt ; i++)
     if (gfunc->methods[i].busy > 0)
       return(CLIPS_TRUE);
   return(CLIPS_FALSE);
  }
  
#if ! OBJECT_SYSTEM

/**************************************************************
  NAME         : SubsumeType
  DESCRIPTION  : Determines if the second type subsumes
                 the first type
                 (e.g. INTEGER is subsumed by NUMBER_TYPE_CODE)
  INPUTS       : Two type codes
  RETURNS      : CLIPS_TRUE if type 2 subsumes type 1, CLIPS_FALSE
                 otherwise
  SIDE EFFECTS : None
  NOTES        : Used only when COOL is not present
 **************************************************************/
globle BOOLEAN SubsumeType(t1,t2)
  int t1,t2;
  {
   if ((t2 == OBJECT_TYPE_CODE) || (t2 == PRIMITIVE_TYPE_CODE))
     return(CLIPS_TRUE);
   if ((t2 == NUMBER_TYPE_CODE) && ((t1 == INTEGER) || (t1 == FLOAT)))
     return(CLIPS_TRUE);
   if ((t2 == LEXEME_TYPE_CODE) && ((t1 == STRING) || (t1 == SYMBOL)))
     return(CLIPS_TRUE);
   if ((t2 == ADDRESS_TYPE_CODE) && ((t1 == EXTERNAL_ADDRESS) || 
       (t1 == FACT_ADDRESS) || (t1 == INSTANCE_ADDRESS)))
     return(CLIPS_TRUE);
   if ((t2 == LEXEME_TYPE_CODE) &&
       ((t1 == INSTANCE_NAME) || (t1 == INSTANCE_ADDRESS)))
     return(CLIPS_TRUE);
   return(CLIPS_FALSE);
  }

#endif

#endif

/*****************************************************
  NAME         : FindMethodByIndex
  DESCRIPTION  : Finds a generic function method of
                   specified index
  INPUTS       : 1) The generic function
                 2) The index
  RETURNS      : The position of the method in the
                   generic function's method array,
                   -1 if not found
  SIDE EFFECTS : None
  NOTES        : None
 *****************************************************/
globle int FindMethodByIndex(gfunc,index)
  DEFGENERIC *gfunc;
  unsigned index;
  {
   register unsigned i;
   
   for (i = 0 ; i < gfunc->mcnt ; i++)
     if (gfunc->methods[i].index == index)
       return(i);
   return(-1);
  }
  
#if DEBUGGING_FUNCTIONS

/*************************************************************
  NAME         : PreviewGeneric
  DESCRIPTION  : Allows the user to see a printout of all the
                   applicable methods for a particular generic
                   function call
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : Any side-effects of evaluating the generic
                   function arguments
                 and evaluating query-functions to determine
                   the set of applicable methods
  NOTES        : CLIPS Syntax: (preview-generic <func> <args>)
 *************************************************************/
globle VOID PreviewGeneric()
  {
   DEFGENERIC *gfunc;
   DEFGENERIC *previousGeneric;
   int oldce;
   DATA_OBJECT temp;
   
   EvaluationError = CLIPS_FALSE;
   if (ArgTypeCheck("preview-generic",1,SYMBOL,&temp) == CLIPS_FALSE)
     return;
   gfunc = LookupDefgenericByMdlOrScope(DOToString(temp));
   if (gfunc == NULL)
     {
      PrintErrorID("GENRCFUN",3,CLIPS_FALSE);
      PrintCLIPS(WERROR,"Unable to find generic function ");
      PrintCLIPS(WERROR,DOToString(temp));
      PrintCLIPS(WERROR," in function preview-generic.\n");
      return;
     }
   oldce = ExecutingConstruct();
   SetExecutingConstruct(CLIPS_TRUE);
   previousGeneric = CurrentGeneric;
   CurrentGeneric = gfunc;
   CurrentEvaluationDepth++;
   PushProcParameters(GetFirstArgument()->nextArg,
                          CountArguments(GetFirstArgument()->nextArg),
                          GetDefgenericName((VOID *) gfunc),"generic function",
                          UnboundMethodErr);
   if (EvaluationError) 
     {
      PopProcParameters();
      CurrentGeneric = previousGeneric;
      CurrentEvaluationDepth--;
      SetExecutingConstruct(oldce);
      return;
     }
   gfunc->busy++;
   DisplayGenericCore(gfunc);
   gfunc->busy--;
   PopProcParameters();
   CurrentGeneric = previousGeneric;
   CurrentEvaluationDepth--;
   SetExecutingConstruct(oldce);
  }

/******************************************************************
  NAME         : PrintMethod
  DESCRIPTION  : Lists a brief description of methods for a method
  INPUTS       : 1) Buffer for method info
                 2) Size of buffer (not including space for '\0')
                 3) The method address
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : A terminating newline is NOT included
 ******************************************************************/
globle VOID PrintMethod(buf,buflen,meth)
  char *buf;
  int buflen;
  DEFMETHOD *meth;
  {
   register int j,k;
   register RESTRICTION *rptr;
   char numbuf[15];
   
   buf[0] = '\0';
   if (meth->system)
     strncpy(buf,"SYS",(CLIPS_STD_SIZE) buflen);
   sprintf(numbuf,"%-2d ",meth->index);
   strncat(buf,numbuf,(CLIPS_STD_SIZE) buflen-3);
   for (j = 0 ; j < meth->restrictionCount ; j++)
     {
      rptr = &meth->restrictions[j];
      if ((j == meth->restrictionCount-1) && (meth->maxRestrictions == -1))
        {
         if ((rptr->tcnt == 0) && (rptr->query == NULL))
           {
            strncat(buf,"$?",buflen-strlen(buf));
            break;
           }
         strncat(buf,"($? ",buflen-strlen(buf));
        }
      else
        strncat(buf,"(",buflen-strlen(buf));
      for (k = 0 ; k < rptr->tcnt ; k++)
        {
#if OBJECT_SYSTEM
         strncat(buf,GetDefclassName(rptr->types[k]),buflen-strlen(buf));
#else
         strncat(buf,TypeName(ValueToInteger(rptr->types[k])),buflen-strlen(buf));
#endif
         if (k < (rptr->tcnt - 1))
           strncat(buf," ",buflen-strlen(buf));
        }
      if (rptr->query != NULL)
        {
         if (rptr->tcnt != 0)
           strncat(buf," ",buflen-strlen(buf));
         strncat(buf,"<qry>",buflen-strlen(buf));
        }
      strncat(buf,")",buflen-strlen(buf));
      if (j != (meth->restrictionCount-1))
        strncat(buf," ",buflen-strlen(buf));
     }
  }
    
#endif
 
/***************************************************
  NAME         : CheckGenericExists
  DESCRIPTION  : Finds the address of named
                  generic function and prints out
                  error message if not found
  INPUTS       : 1) Calling function
                 2) Name of generic function
  RETURNS      : Generic function address (NULL if
                   not found)
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
globle DEFGENERIC *CheckGenericExists(fname,gname)
  char *fname,*gname;
  {
   DEFGENERIC *gfunc;

   gfunc = LookupDefgenericByMdlOrScope(gname);
   if (gfunc == NULL)
     {
      PrintErrorID("GENRCFUN",3,CLIPS_FALSE);
      PrintCLIPS(WERROR,"Unable to find generic function ");
      PrintCLIPS(WERROR,gname);
      PrintCLIPS(WERROR," in function ");
      PrintCLIPS(WERROR,fname);
      PrintCLIPS(WERROR,".\n");
      SetEvaluationError(CLIPS_TRUE);
     }
   return(gfunc); 
  }

/***************************************************
  NAME         : CheckMethodExists
  DESCRIPTION  : Finds the array index of the
                  specified method and prints out
                  error message if not found
  INPUTS       : 1) Calling function
                 2) Generic function address
                 3) Index of method
  RETURNS      : Method array index (-1 if not found)
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
globle int CheckMethodExists(fname,gfunc,mi)
  char *fname;
  DEFGENERIC *gfunc;
  int mi;
  {
   int fi;

   fi = FindMethodByIndex(gfunc,(unsigned) mi);
   if (fi == -1)
     {
      PrintErrorID("GENRCFUN",2,CLIPS_FALSE);
      PrintCLIPS(WERROR,"Unable to find method ");
      PrintCLIPS(WERROR,GetDefgenericName((VOID *) gfunc));
      PrintCLIPS(WERROR," #");
      PrintLongInteger(WERROR,(long) mi);
      PrintCLIPS(WERROR," in function ");
      PrintCLIPS(WERROR,fname);
      PrintCLIPS(WERROR,".\n");
      SetEvaluationError(CLIPS_TRUE);
     }
   return(fi); 
  }

#if ! OBJECT_SYSTEM

/*******************************************************
  NAME         : TypeName
  DESCRIPTION  : Given an integer type code, this
                 function returns the string name of
                 the type
  INPUTS       : The type code
  RETURNS      : The name-string of the type, or 
                 "<???UNKNOWN-TYPE???>" for unrecognized
                 types
  SIDE EFFECTS : EvaluationError set and error message
                 printed for unrecognized types
  NOTES        : Used only when COOL is not present
 *******************************************************/
globle char *TypeName(tcode)
  int tcode;
  {
   switch (tcode)
     {
      case INTEGER             : return(INTEGER_TYPE_NAME);
      case FLOAT               : return(FLOAT_TYPE_NAME);
      case SYMBOL              : return(SYMBOL_TYPE_NAME);
      case STRING              : return(STRING_TYPE_NAME);
      case MULTIFIELD          : return(MULTIFIELD_TYPE_NAME);
      case EXTERNAL_ADDRESS    : return(EXTERNAL_ADDRESS_TYPE_NAME);
      case FACT_ADDRESS        : return(FACT_ADDRESS_TYPE_NAME);
      case INSTANCE_ADDRESS    : return(INSTANCE_ADDRESS_TYPE_NAME);
      case INSTANCE_NAME       : return(INSTANCE_NAME_TYPE_NAME);
      case OBJECT_TYPE_CODE    : return(OBJECT_TYPE_NAME);
      case PRIMITIVE_TYPE_CODE : return(PRIMITIVE_TYPE_NAME);
      case NUMBER_TYPE_CODE    : return(NUMBER_TYPE_NAME);
      case LEXEME_TYPE_CODE    : return(LEXEME_TYPE_NAME);
      case ADDRESS_TYPE_CODE   : return(ADDRESS_TYPE_NAME);
      case INSTANCE_TYPE_CODE  : return(INSTANCE_TYPE_NAME);
      default                  : PrintErrorID("INSCOM",1,CLIPS_FALSE);
                                 PrintCLIPS(WERROR,"Undefined type in function type.\n");
                                 SetEvaluationError(CLIPS_TRUE);
                                 return("<???UNKNOWN-TYPE???>");
     }
  }

#endif

/******************************************************
  NAME         : PrintGenericName
  DESCRIPTION  : Prints the name of a gneric function
                 (including the module name if the
                  generic is not in the current module)
  INPUTS       : 1) The logical name of the output
                 2) The generic functions
  RETURNS      : Nothing useful
  SIDE EFFECTS : Generic name printed
  NOTES        : None
 ******************************************************/
globle VOID PrintGenericName(log,gfunc)
  char *log;
  DEFGENERIC *gfunc;
  {
   if (gfunc->header.whichModule->theModule != ((struct defmodule *) GetCurrentModule()))
     {
      PrintCLIPS(log,GetDefmoduleName((VOID *) 
                        gfunc->header.whichModule->theModule));
      PrintCLIPS(log,"::");
     }
   PrintCLIPS(log,ValueToString((VOID *) gfunc->header.name));
  }

/* =========================================
   *****************************************
          INTERNALLY VISIBLE FUNCTIONS
   =========================================
   ***************************************** */
   
#if DEBUGGING_FUNCTIONS

/*********************************************************
  NAME         : DisplayGenericCore
  DESCRIPTION  : Prints out a description of a core
                   frame of applicable methods for
                   a particular call of a generic function
  INPUTS       : The generic function
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : None
 *********************************************************/
static VOID DisplayGenericCore(gfunc)
  DEFGENERIC *gfunc;
  {
   register int i;
   char buf[256];
   int rtn = CLIPS_FALSE;
   
   for (i = 0 ; i < gfunc->mcnt ; i++)
     {
      gfunc->methods[i].busy++;
      if (IsMethodApplicable(&gfunc->methods[i]))
        {
         rtn = CLIPS_TRUE;
         PrintCLIPS(WDISPLAY,GetDefgenericName((VOID *) gfunc));
         PrintCLIPS(WDISPLAY," #");
         PrintMethod(buf,255,&gfunc->methods[i]);
         PrintCLIPS(WDISPLAY,buf);
         PrintCLIPS(WDISPLAY,"\n");
#if ! IMPERATIVE_METHODS
         break;
#endif
        }
      gfunc->methods[i].busy--;
     }
   if (rtn == CLIPS_FALSE)
     {
      PrintCLIPS(WDISPLAY,"No applicable methods for ");
      PrintCLIPS(WDISPLAY,GetDefgenericName((VOID *) gfunc));
      PrintCLIPS(WDISPLAY,".\n");
     }
  }
  
#endif

#endif

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