prccode.c

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

      parameterList = parameterList->nextArg;
      i++;
     }
   ProcParamArraySize = numberOfParameters;
   ProcParamArray = rva;
  }

/***************************************************
  NAME         : RtnProcParam
  DESCRIPTION  : Internal function for getting the
                   value of an argument passed to
                   a procedure
  INPUTS       : 1) Expression to evaluate
                    (PROC_PARAM index)
                 2) Caller's result value buffer
  RETURNS      : Nothing useful
  SIDE EFFECTS : Caller's buffer set to specified
                   node of ProcParamArray
  NOTES        : None
 ***************************************************/
static BOOLEAN RtnProcParam(value,result)
  VOID *value;
  DATA_OBJECT *result;
  {
   register DATA_OBJECT *src;
   
   src = &ProcParamArray[*((int *) ValueToBitMap(value)) - 1];
   result->type = src->type;
   result->value = src->value;
   result->begin = src->begin;
   result->end = src->end;
   return(CLIPS_TRUE);
  }
  
/**************************************************************
  NAME         : GetProcBind
  DESCRIPTION  : Internal function for looking up the
                    values of parameters or bound variables
                    within procedures
  INPUTS       : 1) Expression to evaluate
                    (PROC_GET_BIND index)
                 2) Caller's result value buffer
  RETURNS      : Nothing useful
  SIDE EFFECTS : Caller's buffer set to parameter value in
                   ProcParamArray or the value in LocalVarArray
  NOTES        : None
 **************************************************************/
static BOOLEAN GetProcBind(value,result)
  VOID *value;
  DATA_OBJECT *result;
  {
   register DATA_OBJECT *src;
   PACKED_PROC_VAR *pvar;
   
   pvar = (PACKED_PROC_VAR *) ValueToBitMap(value);
   src = &LocalVarArray[pvar->first - 1];
   if (src->supplementalInfo == CLIPSTrueSymbol)
     {
      result->type = src->type;
      result->value = src->value;
      result->begin = src->begin;
      result->end = src->end;
      return(CLIPS_TRUE);
     }
   if (GetFirstArgument()->nextArg != NULL)
     {
      EvaluateExpression(GetFirstArgument()->nextArg,result);
      return(CLIPS_TRUE);
     }
   if (pvar->second == 0)
     {
      PrintErrorID("PRCCODE",5,CLIPS_FALSE);
      SetEvaluationError(CLIPS_TRUE);
      PrintCLIPS(WERROR,"Variable ");
      PrintCLIPS(WERROR,ValueToString(GetFirstArgument()->value));
      if (ProcUnboundErrFunc != NULL)
        {
         PrintCLIPS(WERROR," unbound in ");
         (*ProcUnboundErrFunc)();
        }
      else
        PrintCLIPS(WERROR," unbound.\n");
      result->type = SYMBOL;
      result->value = CLIPSFalseSymbol;
      return(CLIPS_TRUE);
     }
   if (pvar->secondFlag == 0)
     {
      src = &ProcParamArray[pvar->second - 1];
      result->type = src->type;
      result->value = src->value;
      result->begin = src->begin;
      result->end = src->end;
     }
   else
     GrabProcWildargs(result,(int) pvar->second);
   return(CLIPS_TRUE);
  }

/**************************************************************
  NAME         : PutProcBind
  DESCRIPTION  : Internal function for setting the values of
                 of locally bound variables within procedures
  INPUTS       : 1) Expression to evaluate
                    (PROC_PARAM index)
                 2) Caller's result value buffer
  RETURNS      : Nothing useful
  SIDE EFFECTS : Bound variable in LocalVarArray set to
                   value in caller's buffer.
  NOTES        : None
 **************************************************************/
static BOOLEAN PutProcBind(value,result)
  VOID *value;
  DATA_OBJECT *result;
  {
   register DATA_OBJECT *dst;

   dst = &LocalVarArray[*((int *) ValueToBitMap(value)) - 1];
   if (GetFirstArgument() == NULL)
     {
      if (dst->supplementalInfo == CLIPSTrueSymbol)
        ValueDeinstall(dst);
      dst->supplementalInfo = CLIPSFalseSymbol;
      result->type = SYMBOL;
      result->value = CLIPSFalseSymbol;
     }
   else
     {
      if (GetFirstArgument()->nextArg != NULL)
        StoreInMultifield(result,GetFirstArgument(),CLIPS_TRUE);
      else
        EvaluateExpression(GetFirstArgument(),result);
      if (dst->supplementalInfo == CLIPSTrueSymbol)
        ValueDeinstall(dst);
      dst->supplementalInfo = CLIPSTrueSymbol;
      dst->type = result->type;
      dst->value = result->value;
      dst->begin = result->begin;
      dst->end = result->end;
      ValueInstall(dst);
     }
   return(CLIPS_TRUE);
  }

/****************************************************************
  NAME         : RtnProcWild
  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 (expression value)
                 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
 ****************************************************************/
static BOOLEAN RtnProcWild(value,result)
  VOID *value;
  DATA_OBJECT *result;
  {
   GrabProcWildargs(result,*(int *) ValueToBitMap(value));
   return(CLIPS_TRUE);
  }
  
#if (! BLOAD_ONLY) && (! RUN_TIME)

/***************************************************
  NAME         : FindProcParameter
  DESCRIPTION  : Determines the relative position in
                   an n-element list of a certain
                   parameter.  The index is 1..n.
  INPUTS       : 1) Parameter name
                 2) Parameter list
                 3) Wildcard symbol (NULL if none)
  RETURNS      : Index of parameter in list, 0 if
                   not found
  SIDE EFFECTS : None
  NOTES        : None
 ***************************************************/
static int FindProcParameter(name,parameterList,wildcard)
  SYMBOL_HN *name;
  EXPRESSION *parameterList;
  SYMBOL_HN *wildcard;
  {
   int i = 1;
   
   while (parameterList != NULL)
     {
      if (parameterList->value == (VOID *) name)
        return(i);
      i++;
      parameterList = parameterList->nextArg;
     }
     
   /* ===================================================================
      Wildcard may not be stored in actual list but know is always at end
      =================================================================== */
   if (name == wildcard)
     return(i);
   return(0);
  }

/*************************************************************************
  NAME         : ReplaceProcBinds
  DESCRIPTION  : Examines an expression and replaces calls to the
                 "bind" function which are specially recognized
                 
                 For example, in a message-handler,
                 
                   (bind ?self <value>) would be illegal
                   
                   and
                   
                   (bind ?self:<slot-name> <value>) would be
                   replaced with
                   (put <slot-name> <value>)
                   
  INPUTS       : 1) The actions in which to replace special binds
                 2) A pointer to a function to handle binds in a
                    special way. The function should accept the
                    bind function call expression and a specialized
                    data buffer (can be NULL) as arguments.
                    If the variable is recognized and treated specially,
                    the function should modify the expression
                    appropriately (including attaching/removing
                    any necessary argument expressions).  Return 1
                    if recognized, 0 if not, -1 on errors.
                    This argument CANNOT be NULL.
                 3) Specialized user data buffer
  RETURNS      : CLIPS_FALSE if OK, CLIPS_TRUE on errors
  SIDE EFFECTS : Some binds replaced with specialized calls
  NOTES        : Local variable binds are replaced in ReplaceProcVars
                 (after this routine has had a chance to replace all
                  special binds and remove the names from the parsed
                  bind list)
 *************************************************************************/
static int ReplaceProcBinds(actions,altbindfunc,userBuffer)
  EXPRESSION *actions;
#if ANSI_COMPILER
  int (*altbindfunc)(EXPRESSION *,VOID *);
#else
  int (*altbindfunc)();
#endif
  VOID *userBuffer;
  {
   int bcode;
   SYMBOL_HN *bname;
   
   while (actions != NULL)
     {
      if (actions->argList != NULL)
        {
         if (ReplaceProcBinds(actions->argList,altbindfunc,userBuffer))
           return(CLIPS_TRUE);
         if ((actions->value == (VOID *) FindFunction("bind")) && 
             (actions->argList->type == SYMBOL))
           {
            bname = (SYMBOL_HN *) actions->argList->value;
            bcode = (*altbindfunc)(actions,userBuffer);
            if (bcode == -1)
              return(CLIPS_TRUE);
            if (bcode == 1)
              RemoveParsedBindName(bname);
           }
        }
      actions = actions->nextArg;
     }
   return(CLIPS_FALSE);
  }

/*****************************************************
  NAME         : CompactActions
  DESCRIPTION  : Examines a progn expression chain,
                 and if there is only one action,
                 the progn header is deallocated and
                 the action is returned.  If there are
                 no actions, the progn expression is
                 modified to be the CLIPS FALSE symbol
                 and returned.  Otherwise, the progn
                 is simply returned.
  INPUTS       : The action expression
  RETURNS      : The compacted expression
  SIDE EFFECTS : Some expressions possibly deallocated
  NOTES        : Assumes actions is a progn expression
                 and actions->nextArg == NULL
 *****************************************************/
static EXPRESSION *CompactActions(actions)
  EXPRESSION *actions;
  {
   register struct expr *tmp;

   if (actions->argList == NULL)
     {
      actions->type = SYMBOL;
      actions->value = CLIPSFalseSymbol;
     }
   else if (actions->argList->nextArg == NULL)
     {
      tmp = actions;
      actions = actions->argList;
      rtn_struct(expr,tmp);
     }
   return(actions);
  }
  
#endif

#if (! DEFFUNCTION_CONSTRUCT) || (! DEFGENERIC_CONSTRUCT)

/******************************************************
  NAME         : EvaluateBadCall
  DESCRIPTION  : Default evaluation function for
                 deffunctions and gneric functions
                 in configurations where either
                 capability is not present.
  INPUTS       : 1) The function (ignored)
                 2) A data object buffer for the result
  RETURNS      : CLIPS_FALSE
  SIDE EFFECTS : Data object buffer set to the
                 symbol FALSE and evaluation error set
  NOTES        : Used for binary images which
                 contain deffunctions and generic
                 functions which cannot be used
 ******************************************************/
static BOOLEAN EvaluateBadCall(value,result)
  VOID *value;
  DATA_OBJECT *result;
  {
   PrintErrorID("PRCCODE",1,CLIPS_FALSE);
   PrintCLIPS(WERROR,"Attempted to call a deffunction/generic function ");
   PrintCLIPS(WERROR,"which does not exist.\n");
   SetEvaluationError(CLIPS_TRUE);
   SetpType(result,SYMBOL);
   SetpValue(result,CLIPSFalseSymbol);
   return(CLIPS_FALSE);
  }

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