prccode.c

一套美国国家宇航局人工智能中心NASA的专家系统工具源代码

   pstack = ptmp;
   EvaluateProcParameters(parameterList,numberOfParameters,pname,bodytype);
   if (EvaluationError)
     {
      ptmp = pstack;
      pstack = pstack->nxt;
      rtn_struct(ProcParamStack,ptmp);
      return;
     }

   /* ================================================================
      Record ProcParamExpressions and WildcardValue for previous frame
      AFTER evaluating arguments for the new frame, because they could
      have gone from NULL to non-NULL (if they were already non-NULL,
      they would remain unchanged.)
      ================================================================ */
#if DEFGENERIC_CONSTRUCT
   ptmp->ParamExpressions = ProcParamExpressions;
   ProcParamExpressions = NULL;
#endif
   ptmp->WildcardValue = WildcardValue;
   WildcardValue = NULL;
   ProcUnboundErrFunc = UnboundErrFunc;
  }
  
/******************************************************************
  NAME         : PopProcParameters
  DESCRIPTION  : Restores old procedure arrays
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : Stack popped and globals restored
  NOTES        : Assumes pstack != NULL
 ******************************************************************/
globle VOID PopProcParameters()
  {
   register PROC_PARAM_STACK *ptmp;
   
   if (ProcParamArray != NULL)
     rm((VOID *) ProcParamArray,(int) (sizeof(DATA_OBJECT) * ProcParamArraySize));

#if DEFGENERIC_CONSTRUCT
   if (ProcParamExpressions != NULL)
     rm((VOID *) ProcParamExpressions,(int) (sizeof(EXPRESSION) * ProcParamArraySize));
#endif

   ptmp = pstack;
   pstack = pstack->nxt;
   ProcParamArray = ptmp->ParamArray;
   ProcParamArraySize = ptmp->ParamArraySize;
   
#if DEFGENERIC_CONSTRUCT
   ProcParamExpressions = ptmp->ParamExpressions;
#endif

   if (WildcardValue != NULL)
     {
      MultifieldDeinstall((MULTIFIELD_PTR) WildcardValue->value);
      if (WildcardValue->value != NoParamValue)
        AddToMultifieldList((MULTIFIELD_PTR) WildcardValue->value);
      rtn_struct(dataObject,WildcardValue);
     }
   WildcardValue = ptmp->WildcardValue;
   ProcUnboundErrFunc = ptmp->UnboundErrFunc;
   rtn_struct(ProcParamStack,ptmp);
  }

#if DEFGENERIC_CONSTRUCT

/***********************************************************
  NAME         : GetProcParamExpressions
  DESCRIPTION  : Forms an array of expressions equivalent to
                 the current procedure paramter array.  Used
                 to conveniently attach these parameters as
                 arguments to a CLIPS system function call
                 (used by the generic dispatch).
  INPUTS       : None
  RETURNS      : A pointer to an array of expressions
  SIDE EFFECTS : Expression array created
  NOTES        : None
 ***********************************************************/
globle EXPRESSION *GetProcParamExpressions()
  {
   register int i;
   
   if ((ProcParamArray == NULL) || (ProcParamExpressions != NULL))
     return(ProcParamExpressions);
   ProcParamExpressions = (EXPRESSION *) 
               gm2((int) (sizeof(EXPRESSION) * ProcParamArraySize));   
   for (i = 0 ; i < ProcParamArraySize ; i++)
     {
      ProcParamExpressions[i].type = (short) ProcParamArray[i].type;
      if (ProcParamArray[i].type != MULTIFIELD)
        ProcParamExpressions[i].value = ProcParamArray[i].value;
      else
        ProcParamExpressions[i].value = (VOID *) &ProcParamArray[i];
      ProcParamExpressions[i].argList = NULL;
      ProcParamExpressions[i].nextArg = 
        ((i + 1) != ProcParamArraySize) ? &ProcParamExpressions[i+1] : NULL;
     }
   return(ProcParamExpressions);
  }

#endif

/***********************************************************
  NAME         : EvaluateProcActions
  DESCRIPTION  : Evaluates the actions of a deffunction,
                 generic function method or message-handler.
  INPUTS       : 1) The module where the actions should be
                    executed
                 2) The actions (linked by nextArg fields)
                 3) The number of local variables to reserve
                    space for.
                 4) A buffer to hold the result of evaluating
                    the actions.
                 5) A function which prints out the name of
                    the currently executing body for error
                    messages (can be NULL).
  RETURNS      : Nothing useful
  SIDE EFFECTS : Allocates and deallocates space for
                 local variable array.
  NOTES        : None
 ***********************************************************/
globle VOID EvaluateProcActions(theModule,actions,lvarcnt,result,crtproc)
  struct defmodule *theModule;
  EXPRESSION *actions;
  int lvarcnt;
  DATA_OBJECT *result;
  VOID (*crtproc)(VOID_ARG);
  {
   DATA_OBJECT *oldLocalVarArray;
   register int i;
   struct defmodule *oldModule;
   EXPRESSION *oldActions;
   
   oldLocalVarArray = LocalVarArray;
   LocalVarArray = (lvarcnt == 0) ? NULL :
                   (DATA_OBJECT *) gm2((int) (sizeof(DATA_OBJECT) * lvarcnt));
   for (i = 0 ; i < lvarcnt ; i++)
     LocalVarArray[i].supplementalInfo = CLIPSFalseSymbol;

   oldModule = ((struct defmodule *) GetCurrentModule());
   if (oldModule != theModule)
     SetCurrentModule((VOID *) theModule);
   oldActions = CurrentProcActions;
   CurrentProcActions = actions;
   if (EvaluateExpression(actions,result))
     {
      result->type = SYMBOL;
      result->value = CLIPSFalseSymbol;
     }
   CurrentProcActions = oldActions;
   if (oldModule != ((struct defmodule *) GetCurrentModule()))
     SetCurrentModule((VOID *) oldModule);
   if ((crtproc != NULL) ? HaltExecution : CLIPS_FALSE)
     {
      PrintErrorID("PRCCODE",4,CLIPS_FALSE);
      PrintCLIPS(WERROR,"Execution halted during the actions of ");
      (*crtproc)();
     }
   if ((WildcardValue != NULL) ? (result->value == WildcardValue->value) : CLIPS_FALSE)
     {
      MultifieldDeinstall((MULTIFIELD_PTR) WildcardValue->value);
      if (WildcardValue->value != NoParamValue)
        AddToMultifieldList((MULTIFIELD_PTR) WildcardValue->value);
      rtn_struct(dataObject,WildcardValue);
      WildcardValue = NULL;
     }

   if (lvarcnt != 0)
     {
      for (i = 0 ; i < lvarcnt ; i++)
        if (LocalVarArray[i].supplementalInfo == CLIPSTrueSymbol)
          ValueDeinstall(&LocalVarArray[i]);
      rm((VOID *) LocalVarArray,(int) (sizeof(DATA_OBJECT) * lvarcnt));
     }

   LocalVarArray = oldLocalVarArray;
  }
  
/****************************************************
  NAME         : PrintProcParamArray
  DESCRIPTION  : Displays the contents of the
                 current procedure parameter array
  INPUTS       : The logical name of the output
  RETURNS      : Nothing useful
  SIDE EFFECTS : None
  NOTES        : None
 ****************************************************/
globle VOID PrintProcParamArray(log)
  char *log;
  {
   register int i;
   
   PrintCLIPS(log," (");
   for (i = 0 ; i < ProcParamArraySize ; i++)
     {
      PrintDataObject(log,&ProcParamArray[i]);
      if (i != ProcParamArraySize-1)
        PrintCLIPS(log," ");
     }
   PrintCLIPS(log,")\n");
  }

/****************************************************************
  NAME         : GrabProcWildargs
  DESCRIPTION  : Groups a portion of the ProcParamArray
                   into a multi-field variable
  INPUTS       : 1) Starting index in ProcParamArray
                      for grouping of arguments into
                      multi-field variable
                 2) Caller's result value buffer
  RETURNS      : Nothing useful
  SIDE EFFECTS : Multi-field variable allocated and set
                   with corresponding values of ProcParamArray
  NOTES        : Multi-field is NOT on list of ephemeral segments
 ****************************************************************/
globle VOID GrabProcWildargs(result,index)
  DATA_OBJECT *result;
  int index;
  {
   register int i,j;
   long k; /* 6.04 Bug Fix */
   long size;
   DATA_OBJECT *val;
   static int oldindex = -1;

   result->type = MULTIFIELD;
   result->begin = 0;
   if (WildcardValue == NULL)
     {
      WildcardValue = get_struct(dataObject);
      WildcardValue->begin = 0;
     }
   else if (index == oldindex)
     {
      result->end = WildcardValue->end;
      result->value = WildcardValue->value;
      return;
     }
   else
     {
      MultifieldDeinstall((MULTIFIELD_PTR) WildcardValue->value);
      if (WildcardValue->value != NoParamValue)
        AddToMultifieldList((MULTIFIELD_PTR) WildcardValue->value);
     }
   oldindex = index;
   size = ProcParamArraySize - index + 1;
   if (size <= 0)
     {
      result->end = WildcardValue->end = -1;
      result->value = WildcardValue->value = NoParamValue;
      MultifieldInstall((MULTIFIELD_PTR) WildcardValue->value);
      return;
     }
   for (i = index-1 ; i < ProcParamArraySize ; i++)
     {
      if (ProcParamArray[i].type == MULTIFIELD)
        size += ProcParamArray[i].end - ProcParamArray[i].begin;
     }
   result->end = WildcardValue->end = size-1;
   result->value = WildcardValue->value = (VOID *) CreateMultifield2(size);
   for (i = index-1 , j = 1 ; i < ProcParamArraySize ; i++)
     {
      if (ProcParamArray[i].type != MULTIFIELD)
        {
         SetMFType(result->value,j,(short) ProcParamArray[i].type); 
         SetMFValue(result->value,j,ProcParamArray[i].value); 
         j++;
        }
      else
        {
         val = &ProcParamArray[i];
         for (k = val->begin + 1 ; k <= val->end + 1 ; k++ , j++)
           {
            SetMFType(result->value,j,GetMFType(val->value,k));
            SetMFValue(result->value,j,GetMFValue(val->value,k));
           }         
        }
     }
   MultifieldInstall((MULTIFIELD_PTR) WildcardValue->value);
  }
  
/* =========================================
   *****************************************
          INTERNALLY VISIBLE FUNCTIONS
   =========================================
   ***************************************** */

/*******************************************************************
  NAME         : EvaluateProcParameters
  DESCRIPTION  : Given a list of parameter expressions,
                   this function evaluates each expression
                   and stores the results in a contiguous
                   array of DATA_OBJECTS.  Used in creating a new
                   ProcParamArray for the execution of a
                   procedure
  INPUTS       : 1) The paramter expression list
                 2) The number of parameters in the list
                 3) The name of the procedure for which
                    these parameters are being evaluated
                 4) The type of procedure
  RETURNS      : Nothing useful
  SIDE EFFECTS : Any side-effects of the evaluation of the
                   parameter expressions
                 DATA_OBJECT array allocated (deallocated on errors)
                 ProcParamArray set
  NOTES        : EvaluationError set on errors
 *******************************************************************/
static VOID EvaluateProcParameters(parameterList,numberOfParameters,pname,bodytype)
  EXPRESSION *parameterList;
  int numberOfParameters;
  char *pname,*bodytype;
  {
   DATA_OBJECT *rva,temp;
   int i = 0;
   
   if (numberOfParameters == 0)
     {
      ProcParamArray = NULL;
      ProcParamArraySize = 0;
      return;
     }
   
   rva = (DATA_OBJECT *) gm2((int) (sizeof(DATA_OBJECT) * numberOfParameters));   
   while (parameterList != NULL)
     {
      if ((EvaluateExpression(parameterList,&temp) == CLIPS_TRUE) ? CLIPS_TRUE :
          (temp.type == RVOID))
        {
         if (temp.type == RVOID)
           {
            PrintErrorID("PRCCODE",2,CLIPS_FALSE);
            PrintCLIPS(WERROR,"Functions without a return value are illegal as ");
            PrintCLIPS(WERROR,bodytype);
            PrintCLIPS(WERROR," arguments.\n");
            SetEvaluationError(CLIPS_TRUE);
           }
         PrintErrorID("PRCCODE",6,CLIPS_FALSE);
         PrintCLIPS(WERROR,"This error occurred while evaluating arguments ");
         PrintCLIPS(WERROR,"for the ");
         PrintCLIPS(WERROR,bodytype);
         PrintCLIPS(WERROR," ");
         PrintCLIPS(WERROR,pname);
         PrintCLIPS(WERROR,".\n");
         rm((VOID *) rva,(int) (sizeof(DATA_OBJECT) * numberOfParameters));
         return;
        }
      rva[i].type = temp.type;
      rva[i].value = temp.value;
      rva[i].begin = temp.begin;
      rva[i].end = temp.end;