genrcexe.c

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

   /*******************************************************/
   /*      "C" Language Integrated Production System      */
   /*                                                     */
   /*               CLIPS Version 6.05  04/09/97          */
   /*                                                     */
   /*                                                     */
   /*******************************************************/

/*************************************************************/
/* Purpose: CLIPS Generic Function Execution Routines        */
/*                                                           */
/* Principal Programmer(s):                                  */
/*      Brian L. Donnell                                     */
/*                                                           */
/* Contributing Programmer(s):                               */
/*                                                           */
/* Revision History:                                         */
/*                                                           */
/*************************************************************/
   
/* =========================================
   *****************************************
               EXTERNAL DEFINITIONS
   =========================================
   ***************************************** */
#include "setup.h"

#if DEFGENERIC_CONSTRUCT

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

#include "argacces.h"
#include "constrct.h"
#include "genrccom.h"
#include "prcdrfun.h"
#include "prccode.h"
#include "router.h"
#include "utility.h"

#define _GENRCEXE_SOURCE_
#include "genrcexe.h"

/* =========================================
   *****************************************
                   CONSTANTS
   =========================================
   ***************************************** */
#define BEGIN_TRACE     ">>"
#define END_TRACE       "<<"

/* =========================================
   *****************************************
               MACROS AND TYPES
   =========================================
   ***************************************** */   

/* =========================================
   *****************************************
      INTERNALLY VISIBLE FUNCTION HEADERS
   =========================================
   ***************************************** */
#if ANSI_COMPILER

static DEFMETHOD *FindApplicableMethod(DEFGENERIC *,DEFMETHOD *);

#if DEBUGGING_FUNCTIONS
static VOID WatchGeneric(char *);
static VOID WatchMethod(char *);
#endif

#if OBJECT_SYSTEM
static DEFCLASS *DetermineRestrictionClass(DATA_OBJECT *);
#endif

#else

static DEFMETHOD *FindApplicableMethod();

#if DEBUGGING_FUNCTIONS
static VOID WatchGeneric();
static VOID WatchMethod();
#endif

#if OBJECT_SYSTEM
static DEFCLASS *DetermineRestrictionClass();
#endif

#endif
      

/* =========================================
   *****************************************
      EXTERNALLY VISIBLE GLOBAL VARIABLES
   =========================================
   ***************************************** */

/* =========================================
   *****************************************
      INTERNALLY VISIBLE GLOBAL VARIABLES
   =========================================
   ***************************************** */

/* =========================================
   *****************************************
          EXTERNALLY VISIBLE FUNCTIONS
   =========================================
   ***************************************** */
   
/***********************************************************************************
  NAME         : GenericDispatch
  DESCRIPTION  : Executes the most specific applicable method
  INPUTS       : 1) The generic function
                 2) The method to start after in the search for an applicable
                    method (ignored if arg #3 is not NULL).
                 3) A specific method to call (NULL if want highest precedence
                    method to be called)
                 4) The generic function argument expressions
                 5) The caller's result value buffer
  RETURNS      : Nothing useful
  SIDE EFFECTS : Any side-effects of evaluating the generic function arguments
                 Any side-effects of evaluating query functions on method parameter
                   restrictions when determining the core (see warning #1)
                 Any side-effects of actual execution of methods (see warning #2)
                 Caller's buffer set to the result of the generic function call
                 
                 In case of errors, the result is FALSE, otherwise it is the
                   result returned by the most specific method (which can choose
                   to ignore or return the values of more general methods)
  NOTES        : WARNING #1: Query functions on method parameter restrictions
                    should not have side-effects, for they might be evaluated even
                    for methods that aren't applicable to the generic function call.
                 WARNING #2: Side-effects of method execution should not always rely
                    on only being executed once per generic function call.  Every
                    time a method calls (shadow-call) the same next-most-specific
                    method is executed.  Thus, it is possible for a method to be
                    executed multiple times per generic function call.
 ***********************************************************************************/
globle VOID GenericDispatch(gfunc,prevmeth,meth,params,result)
  DEFGENERIC *gfunc;
  DEFMETHOD *prevmeth,*meth;
  EXPRESSION *params;
  DATA_OBJECT *result;
  {
   DEFGENERIC *previousGeneric;
   DEFMETHOD *previousMethod;
   int oldce;
   
   result->type = SYMBOL;
   result->value = CLIPSFalseSymbol;
   EvaluationError = CLIPS_FALSE;
   if (HaltExecution)
     return;
   oldce = ExecutingConstruct();
   SetExecutingConstruct(CLIPS_TRUE);
   previousGeneric = CurrentGeneric;
   previousMethod = CurrentMethod;   
   CurrentGeneric = gfunc;
   CurrentEvaluationDepth++;
   gfunc->busy++;
   PushProcParameters(params,CountArguments(params),
                       GetDefgenericName((VOID *) gfunc),
                      "generic function",UnboundMethodErr);
   if (EvaluationError) 
     {
      gfunc->busy--;
      CurrentGeneric = previousGeneric;
      CurrentMethod = previousMethod;   
      CurrentEvaluationDepth--;
      PeriodicCleanup(CLIPS_FALSE,CLIPS_TRUE);
      SetExecutingConstruct(oldce);
      return;
     }
   if (meth != NULL)
     {
      if (IsMethodApplicable(meth))
        {
         meth->busy++;
         CurrentMethod = meth;
        }
      else
        {
         PrintErrorID("GENRCEXE",4,CLIPS_FALSE);
         SetEvaluationError(CLIPS_TRUE);
         CurrentMethod = NULL;  
         PrintCLIPS(WERROR,"Generic function ");
         PrintCLIPS(WERROR,GetDefgenericName((VOID *) gfunc));
         PrintCLIPS(WERROR," method #");
         PrintLongInteger(WERROR,(long) meth->index);
         PrintCLIPS(WERROR," is not applicable to the given arguments.\n");
        }
     }
   else
     CurrentMethod = FindApplicableMethod(gfunc,prevmeth);
   if (CurrentMethod != NULL)
     {
#if DEBUGGING_FUNCTIONS
      if (CurrentGeneric->trace)
        WatchGeneric(BEGIN_TRACE);
      if (CurrentMethod->trace)
        WatchMethod(BEGIN_TRACE);
#endif
      if (CurrentMethod->system)
        {
         EXPRESSION fcall;
      
         fcall.type = FCALL;
         fcall.value = CurrentMethod->actions->value;
         fcall.nextArg = NULL;
         fcall.argList = GetProcParamExpressions();
         EvaluateExpression(&fcall,result);
        }
      else
        EvaluateProcActions(CurrentGeneric->header.whichModule->theModule,
                            CurrentMethod->actions,CurrentMethod->localVarCount,
                            result,UnboundMethodErr);
      CurrentMethod->busy--;
#if DEBUGGING_FUNCTIONS
      if (CurrentMethod->trace)
        WatchMethod(END_TRACE);
      if (CurrentGeneric->trace)
        WatchGeneric(END_TRACE);
#endif
     }
   else if (! EvaluationError)
     {
      PrintErrorID("GENRCEXE",1,CLIPS_FALSE);
      PrintCLIPS(WERROR,"No applicable methods for ");
      PrintCLIPS(WERROR,GetDefgenericName((VOID *) gfunc));
      PrintCLIPS(WERROR,".\n");
      SetEvaluationError(CLIPS_TRUE);
     }
   gfunc->busy--;
   ReturnFlag = CLIPS_FALSE;
   PopProcParameters();
   CurrentGeneric = previousGeneric;
   CurrentMethod = previousMethod;
   CurrentEvaluationDepth--;
   PropagateReturnValue(result);
   PeriodicCleanup(CLIPS_FALSE,CLIPS_TRUE);
   SetExecutingConstruct(oldce);
  }

/*******************************************************
  NAME         : UnboundMethodErr
  DESCRIPTION  : Print out a synopis of the currently
                   executing method for unbound variable
                   errors
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : Error synopsis printed to WERROR
  NOTES        : None
 *******************************************************/
globle VOID UnboundMethodErr()
  {
   PrintCLIPS(WERROR,"generic function ");
   PrintCLIPS(WERROR,GetDefgenericName((VOID *) CurrentGeneric));
   PrintCLIPS(WERROR," method #");
   PrintLongInteger(WERROR,(long) CurrentMethod->index);
   PrintCLIPS(WERROR,".\n");
  }
  
/***********************************************************************
  NAME         : IsMethodApplicable
  DESCRIPTION  : Tests to see if a method satsifies the arguments of a
                   generic function
                 A method is applicable if all its restrictions are
                   satisfied by the corresponding arguments
  INPUTS       : The method address
  RETURNS      : CLIPS_TRUE if method is applicable, CLIPS_FALSE otherwise
  SIDE EFFECTS : Any query functions are evaluated
  NOTES        : Uses globals ProcParamArraySize and ProcParamArray
 ***********************************************************************/
globle BOOLEAN IsMethodApplicable(meth)
  DEFMETHOD *meth;
  {
   DATA_OBJECT temp;
   register int i,j,k;
   register RESTRICTION *rp;
#if OBJECT_SYSTEM
   VOID *type;
#else
   int type;
#endif

   if ((ProcParamArraySize < meth->minRestrictions) ||
       ((ProcParamArraySize > meth->minRestrictions) && (meth->maxRestrictions != -1)))
     return(CLIPS_FALSE);
   for (i = 0 , k = 0 ; i < ProcParamArraySize ; i++)
     {
      rp = &meth->restrictions[k];
      if (rp->tcnt != 0)
        {
#if OBJECT_SYSTEM
         type = (VOID *) DetermineRestrictionClass(&ProcParamArray[i]);
         if (type == NULL)
           return(CLIPS_FALSE);
         for (j = 0 ; j < rp->tcnt ; j++)
           {
            if (type == rp->types[j])
              break;
            if (HasSuperclass((DEFCLASS *) type,(DEFCLASS *) rp->types[j]))
              break;
            if (rp->types[j] == (VOID *) PrimitiveClassMap[INSTANCE_ADDRESS])
              {
               if (ProcParamArray[i].type == INSTANCE_ADDRESS)
                 break;
              }
            else if (rp->types[j] == (VOID *) PrimitiveClassMap[INSTANCE_NAME])
              {
               if (ProcParamArray[i].type == INSTANCE_NAME)
                 break;
              }
            else if (rp->types[j] == 
                (VOID *) PrimitiveClassMap[INSTANCE_NAME]->directSuperclasses.classArray[0])
              {
               if ((ProcParamArray[i].type == INSTANCE_NAME) ||
                   (ProcParamArray[i].type == INSTANCE_ADDRESS))
                 break;
              }
           }
#else
         type = ProcParamArray[i].type;
         for (j = 0 ; j < rp->tcnt ; j++)
           {
            if (type == ValueToInteger(rp->types[j]))
              break;
            if (SubsumeType(type,ValueToInteger(rp->types[j])))
              break;
           }
#endif
         if (j == rp->tcnt)
           return(CLIPS_FALSE);
        }
      if (rp->query != NULL)
        {
         GenericCurrentArgument = &ProcParamArray[i];
         EvaluateExpression(rp->query,&temp);
         if ((temp.type != SYMBOL) ? CLIPS_FALSE :