evaluatn.c

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

/*   (in use) values for a DATA_OBJECT structure.   */
/****************************************************/
globle VOID ValueDeinstall(vPtr)
  DATA_OBJECT *vPtr;
  {
   if (vPtr->type == MULTIFIELD) MultifieldDeinstall((struct multifield *) vPtr->value);
   else AtomDeinstall(vPtr->type,vPtr->value);
  }
  
/*****************************************/
/* AtomInstall: Increments the reference */
/*   count of an atomic data type.       */
/*****************************************/
globle VOID AtomInstall(type,vPtr)
  int type;
  VOID *vPtr;
  {
   switch (type)
     {
      case SYMBOL:
      case STRING:
#if DEFGLOBAL_CONSTRUCT
      case GBL_VARIABLE:
#endif
#if OBJECT_SYSTEM
      case INSTANCE_NAME:
#endif
        IncrementSymbolCount(vPtr);
        break;

      case FLOAT:
        IncrementFloatCount(vPtr);
        break;

      case INTEGER:
        IncrementIntegerCount(vPtr);
        break;

      case MULTIFIELD:
        MultifieldInstall(vPtr);
        break;
        
      case RVOID:
        break;

      default:
        if (PrimitivesArray[type] == NULL) break;
        if (PrimitivesArray[type]->bitMap) IncrementBitMapCount(vPtr);
        else if (PrimitivesArray[type]->incrementBusyCount)
          { (*PrimitivesArray[type]->incrementBusyCount)(vPtr); }
        break;
     }
  }

/*******************************************/
/* AtomDeinstall: Decrements the reference */
/*   count of an atomic data type.         */
/*******************************************/
globle VOID AtomDeinstall(type,vPtr)
  int type;
  VOID *vPtr;
  {
   switch (type)
     {
      case SYMBOL:
      case STRING:
#if DEFGLOBAL_CONSTRUCT
      case GBL_VARIABLE:
#endif
#if OBJECT_SYSTEM
      case INSTANCE_NAME:
#endif
        DecrementSymbolCount(vPtr);
        break;

      case FLOAT:
        DecrementFloatCount(vPtr);
        break;

      case INTEGER:
        DecrementIntegerCount(vPtr);
        break;

      case MULTIFIELD:
        MultifieldDeinstall(vPtr);
        break;
        
      case RVOID:
        break;
        
      default:
        if (PrimitivesArray[type] == NULL) break;
        if (PrimitivesArray[type]->bitMap) DecrementBitMapCount(vPtr);
        else if (PrimitivesArray[type]->decrementBusyCount)
          { (*PrimitivesArray[type]->decrementBusyCount)(vPtr); }
     }
  }
  
/*********************************************************************/
/* PropagateReturnValue: Decrements the associated depth for a value */
/*   stored in a DATA_OBJECT structure. In effect, the values        */
/*   returned by certain evaluations (such as a deffunction call)    */
/*   are passed up to the previous depth of evaluation. The return   */
/*   value's depth is decremented so that it will not be garbage     */
/*   collected along with other items that are no longer needed from */
/*   the evaluation that generated the return value.                 */
/*********************************************************************/
globle VOID PropagateReturnValue(vPtr)
  DATA_OBJECT *vPtr;
  {
   long i; /* 6.04 Bug Fix */
   struct multifield *theSegment;
   struct field HUGE_ADDR *theMultifield;

   if (vPtr->type != MULTIFIELD)
     PropagateReturnAtom(vPtr->type,vPtr->value);
   else
     {
      theSegment = (struct multifield *) vPtr->value;
      if (theSegment->depth > CurrentEvaluationDepth)
        theSegment->depth = (short) CurrentEvaluationDepth;
      theMultifield = theSegment->theFields;
      i = vPtr->begin;
      while (i <= vPtr->end)
        {
         PropagateReturnAtom(theMultifield[i].type,theMultifield[i].value);
         i++;
        }
     }
  }

/*****************************************/
/* PropagateReturnAtom: Support function */
/*   for PropagateReturnValue.           */
/*****************************************/
static VOID PropagateReturnAtom(type,value)
  int type;
  VOID *value;
  {
   switch (type)
     {
      case INTEGER         :
      case FLOAT           :
      case SYMBOL          :
      case STRING          :
#if OBJECT_SYSTEM
      case INSTANCE_NAME   :
#endif
        if (((SYMBOL_HN *) value)->depth > CurrentEvaluationDepth)
          { ((SYMBOL_HN *) value)->depth = CurrentEvaluationDepth; }
        break;

#if OBJECT_SYSTEM
      case INSTANCE_ADDRESS : 
        if (((INSTANCE_TYPE *) value)->depth > CurrentEvaluationDepth)
          { ((INSTANCE_TYPE *) value)->depth = CurrentEvaluationDepth; }
        break;
#endif
      case FACT_ADDRESS :
        if (((int) ((struct fact *) value)->depth) > CurrentEvaluationDepth)
          { ((struct fact *) value)->depth = (unsigned) CurrentEvaluationDepth; }
        break;
     }
  }
  
#if DEFFUNCTION_CONSTRUCT || DEFGENERIC_CONSTRUCT

/************************************************/
/* CLIPSFunctionCall: Allows CLIPS Deffunctions */
/*   and Generic Functions to be called from C. */
/*   Allows only constants as arguments.        */
/************************************************/
globle int CLIPSFunctionCall(name,args,result)
  char *name,*args;
  DATA_OBJECT *result;
  {
#if DEFGENERIC_CONSTRUCT
   VOID *gfunc;
#endif
#if DEFFUNCTION_CONSTRUCT
   VOID *dptr;
#endif
   struct FunctionDefinition *fptr;
   EXPRESSION *argexps, *top;
   int error = CLIPS_FALSE;
   
   /*=============================================*/
   /* Force periodic cleanup if the function call */
   /* was executed from an embedded application.  */
   /*=============================================*/

   if ((CurrentEvaluationDepth == 0) && (! EvaluatingTopLevelCommand) &&
       (CurrentExpression == NULL))
     { PeriodicCleanup(CLIPS_TRUE,CLIPS_FALSE); } 

   /*========================*/
   /* Reset the error state. */
   /*========================*/
   
   if (CurrentEvaluationDepth == 0) SetHaltExecution(CLIPS_FALSE);
   EvaluationError = CLIPS_FALSE;

   /*======================================*/
   /* Initialize the default return value. */
   /*======================================*/
   
   result->type = SYMBOL;
   result->value = CLIPSFalseSymbol;

   /*============================*/
   /* Parse the argument string. */
   /*============================*/
    
   argexps = ParseConstantArguments(args,&error);
   if (error == CLIPS_TRUE) return(CLIPS_TRUE);

   /*=====================================================*/
   /* Check to see if the function call is a deffunction. */
   /*=====================================================*/
   
#if DEFFUNCTION_CONSTRUCT
   if ((dptr = (VOID *) LookupDeffunctionInScope(name)) != NULL)
     {
      top = GenConstant(PCALL,dptr);
      top->argList = argexps;
      error = EvaluateExpression(top,result);
     }
   else
#endif

   /*====================================================*/
   /* Check to see if the function call is a defgeneric. */
   /*====================================================*/
   
#if DEFGENERIC_CONSTRUCT
   if ((gfunc = (VOID *) LookupDefgenericInScope(name)) != NULL)
     {
      top = GenConstant(GCALL,gfunc);
      top->argList = argexps;
      error = EvaluateExpression(top,result);
     }
   else
#endif

   /*======================================*/
   /* Check to see if the function call is */
   /* a system or user defined function.   */
   /*======================================*/
   
   if ((fptr = FindFunction(name)) != NULL)
     {
      top = GenConstant(FCALL,fptr);
      top->argList = argexps;
      error = EvaluateExpression(top,result);
     }
     
   /*=========================================================*/
   /* Otherwise signal an error if a deffunction, defgeneric, */
   /* or user defined function doesn't exist that matches     */
   /* the specified function name.                            */
   /*=========================================================*/
   
   else
     {   
      PrintErrorID("EVALUATN",2,CLIPS_FALSE);
      PrintCLIPS(WERROR,"No function, generic function or deffunction of name ");
      PrintCLIPS(WERROR,name);
      PrintCLIPS(WERROR," exists for external call.\n");
      top = argexps;
      error = CLIPS_TRUE;
     }

   /*========================*/
   /* Return the expression. */
   /*========================*/
   
   ReturnExpression(top);
   
   /*==========================*/
   /* Return the error status. */
   /*==========================*/
   
   return(error);
  }

#endif

/***************************************************/
/* CopyDataObject: Copies the values from a source */
/*   DATA_OBJECT to a destination DATA_OBJECT.     */
/***************************************************/
globle VOID CopyDataObject(dst,src,garbageMultifield)
  DATA_OBJECT *dst,*src;
  int garbageMultifield;
  {
   if (src->type != MULTIFIELD)
     {
      dst->type = src->type;
      dst->value = src->value;
     }
   else
     {
      DuplicateMultifield(dst,src);
      if (garbageMultifield)
        { AddToMultifieldList((struct multifield *) dst->value); }
     }
  }

/************************************************************************/
/* ConvertValueToExpression: Converts the value stored in a data object */
/*   into an expression. For multifield values, a chain of expressions  */
/*   is generated and the chain is linked by the nextArg field. For a   */
/*   single field value, a single expression is created.                */
/************************************************************************/
globle struct expr *ConvertValueToExpression(theValue)
  DATA_OBJECT *theValue;
  {
   long i; /* 6.04 Bug Fix */
   struct expr *head = NULL, *last = NULL, *new;
   
   if (GetpType(theValue) != MULTIFIELD)
     { return(GenConstant(GetpType(theValue),GetpValue(theValue))); }
   
   for (i = GetpDOBegin(theValue); i <= GetpDOEnd(theValue); i++)
     {
      new = GenConstant(GetMFType(GetpValue(theValue),i),
                        GetMFValue(GetpValue(theValue),i));
      if (last == NULL) head = new;
      else last->nextArg = new;
      last = new;
     }
   
   if (head == NULL)
     return(GenConstant(FCALL,(VOID *) FindFunction("create$")));
     
   return(head);
  }

/****************************************/
/* GetAtomicHashValue: Returns the hash */
/*   value for an atomic data type.     */
/****************************************/
unsigned int GetAtomicHashValue(type,value,position)
  int type;
  VOID *value;
  int position;
  {
   unsigned int tvalue;
   union
     {
      double fv;
      unsigned int liv;
     } fis;
   
   switch (type)
     {
      case FLOAT:
        fis.fv = ValueToDouble(value);
        tvalue = fis.liv;
        break;
        
      case INTEGER:
        tvalue = (unsigned int) ValueToLong(value);
        break;
        
      case FACT_ADDRESS:
#if OBJECT_SYSTEM
      case INSTANCE_ADDRESS:
#endif
      case EXTERNAL_ADDRESS:
         tvalue = (unsigned int) value;
         break;
         
      case STRING:
#if OBJECT_SYSTEM
      case INSTANCE_NAME:
#endif
      case SYMBOL:
        tvalue = ((SYMBOL_HN *) value)->bucket;
        break;
        
      default:
        tvalue = type;
     }
   
   if (position < 0) return(tvalue);
   
   return((unsigned int) (tvalue * (position + 29)));
  }