multifun.c

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

   ReturnExpression(top);
   return(NULL);
  }

/**********************************************/
/* ReplaceMvPrognFieldVars: Replaces variable */
/*   references found in the progn$ function. */
/**********************************************/
static VOID ReplaceMvPrognFieldVars(fieldVar,exp,depth)
  SYMBOL_HN *fieldVar;
  struct expr *exp;
  int depth;
  {
   int flen;
   
   flen = strlen(ValueToString(fieldVar));
   while (exp != NULL)
     {
      if ((exp->type != SF_VARIABLE) ? CLIPS_FALSE :
          (strncmp(ValueToString(exp->value),ValueToString(fieldVar),
                   (CLIPS_STD_SIZE) flen) == 0))
        {
         if (ValueToString(exp->value)[flen] == '\0')
           {
            exp->type = FCALL;
            exp->value = (VOID *) FindFunction((VOID *) "(get-progn$-field)");
            exp->argList = GenConstant(INTEGER,AddLong((long) depth));
           }
         else if (strcmp(ValueToString(exp->value) + flen,"-index") == 0)
           {
            exp->type = FCALL;
            exp->value = (VOID *) FindFunction((VOID *) "(get-progn$-index)");
            exp->argList = GenConstant(INTEGER,AddLong((long) depth));
           }
        }
      else if (exp->argList != NULL)
        {
         if ((exp->type == FCALL) && (exp->value == (VOID *) FindFunction("progn$")))
           ReplaceMvPrognFieldVars(fieldVar,exp->argList,depth+1);
         else
           ReplaceMvPrognFieldVars(fieldVar,exp->argList,depth);
        }
      exp = exp->nextArg;
     }
  }

#endif

/*****************************************/
/* MultifieldPrognFunction: CLIPS access */
/*   routine for the progn$ function.    */
/*****************************************/
globle VOID MultifieldPrognFunction(result)
  DATA_OBJECT_PTR result;
  {
   EXPRESSION *exp;
   DATA_OBJECT argval;
   long i, end; /* 6.04 Bug Fix */
   FIELD_VAR_STACK *tmpField;
   
   tmpField = get_struct(fieldVarStack);
   tmpField->type = SYMBOL;
   tmpField->value = CLIPSFalseSymbol;
   tmpField->nxt = FieldVarStack;
   FieldVarStack = tmpField;
   result->type = SYMBOL;
   result->value = CLIPSFalseSymbol;
   if (ArgTypeCheck("progn$",1,MULTIFIELD,&argval) == CLIPS_FALSE)
     {
      FieldVarStack = tmpField->nxt;
      rtn_struct(fieldVarStack,tmpField);
      return;
     }
   end = GetDOEnd(argval);
   for (i = GetDOBegin(argval) ; i <= end ; i++)
     {
      tmpField->type = GetMFType(argval.value,i);
      tmpField->value = GetMFValue(argval.value,i);
      tmpField->index = i;
      for (exp = GetFirstArgument()->nextArg ; exp != NULL ; exp = exp->nextArg)
        {
         CurrentEvaluationDepth++;
         EvaluateExpression(exp,result);
         CurrentEvaluationDepth--;
         if (ReturnFlag == CLIPS_TRUE)
           { PropagateReturnValue(result); }
         PeriodicCleanup(CLIPS_FALSE,CLIPS_TRUE);
         if (HaltExecution || BreakFlag || ReturnFlag)
           {
            BreakFlag = CLIPS_FALSE;
            if (HaltExecution)
              {
               result->type = SYMBOL;
               result->value = CLIPSFalseSymbol;
              }
            FieldVarStack = tmpField->nxt;
            rtn_struct(fieldVarStack,tmpField);
            return;
           }
        }
     }
   BreakFlag = CLIPS_FALSE;
   FieldVarStack = tmpField->nxt;
   rtn_struct(fieldVarStack,tmpField);
  }

/***************************************************/
/* GetMvPrognField                                 */
/***************************************************/
globle VOID GetMvPrognField(result)
  DATA_OBJECT_PTR result;
  {
   int depth;
   FIELD_VAR_STACK *tmpField;
   
   depth = ValueToInteger(GetFirstArgument()->value);
   tmpField = FieldVarStack;
   while (depth > 0)
     {
      tmpField = tmpField->nxt;
      depth--;
     }
   result->type = tmpField->type;
   result->value = tmpField->value;
  }

/***************************************************/
/* GetMvPrognField                                 */
/***************************************************/
globle long GetMvPrognIndex()
  {
   int depth;
   FIELD_VAR_STACK *tmpField;
   
   depth = ValueToInteger(GetFirstArgument()->value);
   tmpField = FieldVarStack;
   while (depth > 0)
     {
      tmpField = tmpField->nxt;
      depth--;
     }
   return(tmpField->index);
  }

#endif

#if OBJECT_SYSTEM || MULTIFIELD_FUNCTIONS

/**************************************************************************
  NAME         : ReplaceMultiValueField
  DESCRIPTION  : Performs a replace on the src multi-field value
                   storing the results in the dst multi-field value
  INPUTS       : 1) The destination value buffer
                 2) The source value (can be NULL)
                 3) Beginning of index range
                 4) End of range
                 5) The new field value
  RETURNS      : CLIPS_TRUE if successful, CLIPS_FALSE otherwise
  SIDE EFFECTS : Allocates and sets a ephemeral segment (even if new
                   number of fields is 0)
                 Src value segment is not changed
  NOTES        : index is NOT guaranteed to be valid
                 src is guaranteed to be a multi-field variable or NULL
 **************************************************************************/
globle int ReplaceMultiValueField(dst,src,rb,re,field,funcName)
  DATA_OBJECT *dst,*src,*field;
  long rb,re;
  char *funcName;
  {
   long i,j,k; 
   struct field *deptr;
   struct field *septr;
   long srclen,dstlen;  

   srclen = (src != NULL) ? (src->end - src->begin + 1) : 0;
   if ((re < rb) ||
       (rb < 1) || (re < 1) ||
       (rb > srclen) || (re > srclen))
     {
      MVRangeError(rb,re,srclen,funcName);
      return(CLIPS_FALSE);
     }
   rb = src->begin + rb - 1;
   re = src->begin + re - 1;
   if (field->type == MULTIFIELD)
     dstlen = srclen + GetpDOLength(field) - (re-rb+1);
   else
     dstlen = srclen + 1 - (re-rb+1);
   dst->type = MULTIFIELD;
   dst->begin = 0;
   dst->value = CreateMultifield(dstlen);
   dst->end = dstlen-1;
   for (i = 0 , j = src->begin ; j < rb ; i++ , j++)
     {
      deptr = &((struct multifield *) dst->value)->theFields[i];
      septr = &((struct multifield *) src->value)->theFields[j];
      deptr->type = septr->type;
      deptr->value = septr->value;
     }
   if (field->type != MULTIFIELD)
     {
      deptr = &((struct multifield *) dst->value)->theFields[i++];
      deptr->type = (short) field->type;
      deptr->value = field->value;
     }
   else
     {
      for (k = field->begin ; k <= field->end ; k++ , i++)
        {
         deptr = &((struct multifield *) dst->value)->theFields[i];
         septr = &((struct multifield *) field->value)->theFields[k];
         deptr->type = septr->type;
         deptr->value = septr->value;
        }
     }
   while (j < re)
     j++;
   for (j++ ; i < dstlen ; i++ , j++)
     {
      deptr = &((struct multifield *) dst->value)->theFields[i];
      septr = &((struct multifield *) src->value)->theFields[j];
      deptr->type = septr->type;
      deptr->value = septr->value;
     }
   return(CLIPS_TRUE);
  }

/**************************************************************************
  NAME         : InsertMultiValueField
  DESCRIPTION  : Performs an insert on the src multi-field value
                   storing the results in the dst multi-field value
  INPUTS       : 1) The destination value buffer
                 2) The source value (can be NULL)
                 3) The index for the change
                 4) The new field value
  RETURNS      : CLIPS_TRUE if successful, CLIPS_FALSE otherwise
  SIDE EFFECTS : Allocates and sets a ephemeral segment (even if new
                   number of fields is 0)
                 Src value segment is not changed
  NOTES        : index is NOT guaranteed to be valid
                 src is guaranteed to be a multi-field variable or NULL
 **************************************************************************/
globle int InsertMultiValueField(dst,src,index,field,funcName)
  DATA_OBJECT *dst,*src,*field;
  long index;
  char *funcName;
  {
   register long i,j,k;
   register FIELD *deptr, *septr;
   long srclen,dstlen; /* 6.04 Bug Fix */

   srclen = (src != NULL) ? (src->end - src->begin + 1) : 0;
   if (index < 1)
     {
      MVRangeError(index,index,srclen+1,funcName);
      return(CLIPS_FALSE);
     }
   if (index > (srclen + 1))
     index = srclen + 1;
   dst->type = MULTIFIELD;
   dst->begin = 0;
   if (src == NULL)
     {
      if (field->type == MULTIFIELD)
        {
         DuplicateMultifield(dst,field);
         AddToMultifieldList((struct multifield *) dst->value);
        }
      else
        {
         dst->value = CreateMultifield(0L);
         dst->end = 0;
         deptr = &((struct multifield *) dst->value)->theFields[0];
         deptr->type = (short) field->type;
         deptr->value = field->value;
        }
      return(CLIPS_TRUE);
     }
   dstlen = (field->type == MULTIFIELD) ? GetpDOLength(field) + srclen : srclen + 1;
   dst->value = CreateMultifield(dstlen);
   dst->end = dstlen-1;
   index--;
   for (i = 0 , j = src->begin ; i < index ; i++ , j++)
     {
      deptr = &((struct multifield *) dst->value)->theFields[i];
      septr = &((struct multifield *) src->value)->theFields[j];
      deptr->type = septr->type;
      deptr->value = septr->value;
     }
   if (field->type != MULTIFIELD)
     {
      deptr = &((struct multifield *) dst->value)->theFields[index];
      deptr->type = (short) field->type;
      deptr->value = field->value;
      i++;
     }
   else
     {
      for (k = field->begin ; k <= field->end ; k++ , i++)
        {
         deptr = &((struct multifield *) dst->value)->theFields[i];
         septr = &((struct multifield *) field->value)->theFields[k];
         deptr->type = septr->type;
         deptr->value = septr->value;
        }
     }
   for ( ; j <= src->end ; i++ , j++)
     {
      deptr = &((struct multifield *) dst->value)->theFields[i];
      septr = &((struct multifield *) src->value)->theFields[j];
      deptr->type = septr->type;
      deptr->value = septr->value;
     }
   return(CLIPS_TRUE);
  }

/*******************************************************
  NAME         : MVRangeError
  DESCRIPTION  : Prints out an error messages for index
                   out-of-range errors in multi-field
                   access functions
  INPUTS       : 1) The bad range start
                 2) The bad range end
                 3) The max end of the range (min is
                     assumed to be 1)
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : None
 ******************************************************/
static VOID MVRangeError(brb,bre,max,funcName)
  long brb,bre,max;
  char *funcName;
  {
   PrintErrorID("MULTIFUN",1,CLIPS_FALSE);
   PrintCLIPS(WERROR,"Multifield index ");
   if (brb == bre)
     PrintLongInteger(WERROR,(long) brb);
   else
     {
      PrintCLIPS(WERROR,"range ");
      PrintLongInteger(WERROR,(long) brb);
      PrintCLIPS(WERROR,"..");
      PrintLongInteger(WERROR,(long) bre);
     }
   PrintCLIPS(WERROR," out of range 1..");
   PrintLongInteger(WERROR,(long) max);
   if (funcName != NULL)
     {
      PrintCLIPS(WERROR," in function ");
      PrintCLIPS(WERROR,funcName);
     }
   PrintCLIPS(WERROR,".\n");
  }

/**************************************************************************
  NAME         : DeleteMultiValueField
  DESCRIPTION  : Performs a modify on the src multi-field value
                   storing the results in the dst multi-field value
  INPUTS       : 1) The destination value buffer
                 2) The source value (can be NULL)
                 3) The beginning index for deletion
                 4) The ending index for deletion
  RETURNS      : CLIPS_TRUE if successful, CLIPS_FALSE otherwise
  SIDE EFFECTS : Allocates and sets a ephemeral segment (even if new
                   number of fields is 0)
                 Src value segment is not changed
  NOTES        : index is NOT guaranteed to be valid
                 src is guaranteed to be a multi-field variable or NULL
 **************************************************************************/
globle int DeleteMultiValueField(dst,src,rb,re,funcName)
  DATA_OBJECT *dst,*src;
  long rb,re;
  char *funcName;
  {
   register long i,j;
   register FIELD_PTR deptr,septr;
   long srclen, dstlen;

   srclen = (src != NULL) ? (src->end - src->begin + 1) : 0;
   if ((re < rb) ||
       (rb < 1) || (re < 1) ||
       (rb > srclen) || (re > srclen))
     {
      MVRangeError(rb,re,srclen,funcName);
      return(CLIPS_FALSE);
     }
   dst->type = MULTIFIELD;
   dst->begin = 0;
   if (srclen == 0)
    {
     dst->value = CreateMultifield(0L);
     dst->end = -1;
     return(CLIPS_TRUE);
    }
   rb = src->begin + rb -1;
   re = src->begin + re -1;
   dstlen = srclen-(re-rb+1);
   dst->end = dstlen-1;
   dst->value = CreateMultifield(dstlen);
   for (i = 0 , j = src->begin ; j < rb ; i++ , j++)
     {
      deptr = &((struct multifield *) dst->value)->theFields[i];
      septr = &((struct multifield *) src->value)->theFields[j];
      deptr->type = septr->type;
      deptr->value = septr->value;
     }
   while (j < re)
     j++;
   for (j++ ; i <= dst->end ; j++ , i++)
     {
      deptr = &((struct multifield *) dst->value)->theFields[i];
      septr = &((struct multifield *) src->value)->theFields[j];
      deptr->type = septr->type;
      deptr->value = septr->value;
     }
   return(CLIPS_TRUE);
  }

#endif