clips-sys 0.4.0

   /*******************************************************/
   /*      "C" Language Integrated Production System      */
   /*                                                     */
   /*            CLIPS Version 6.40  11/01/16             */
   /*                                                     */
   /*                                                     */
   /*******************************************************/

/**************************************************************/
/* Purpose: Procedural Code Support Routines for              */
/*          Deffunctions, Generic Function Methods,           */
/*          Message-Handlersand Rules                         */
/*                                                            */
/* Principal Programmer(s):                                   */
/*      Brian L. Dantes                                       */
/*                                                            */
/* Contributing Programmer(s):                                */
/*                                                            */
/* Revision History:                                          */
/*                                                            */
/*      6.23: Correction for FalseSymbol/TrueSymbol. DR0859   */
/*                                                            */
/*            Changed name of variable log to logName         */
/*            because of Unix compiler warnings of shadowed   */
/*            definitions.                                    */
/*                                                            */
/*      6.24: Renamed BOOLEAN macro type to intBool.          */
/*                                                            */
/*            Added pragmas to remove compilation warnings.   */
/*                                                            */
/*      6.30: Updated ENTITY_RECORD definitions to include    */
/*            additional NULL initializers.                   */
/*                                                            */
/*            Added ReleaseProcParameters call.               */
/*                                                            */
/*            Added tracked memory calls.                     */
/*                                                            */
/*            Removed conditional code for unsupported        */
/*            compilers/operating systems (IBM_MCW,           */
/*            MAC_MCW, and IBM_TBC).                          */
/*                                                            */
/*            Added const qualifiers to remove C++            */
/*            deprecation warnings.                           */
/*                                                            */
/*      6.40: Added Env prefix to GetEvaluationError and      */
/*            SetEvaluationError functions.                   */
/*                                                            */
/*            Pragma once and other inclusion changes.        */
/*                                                            */
/*            Added support for booleans with <stdbool.h>.    */
/*                                                            */
/*            Removed use of void pointers for specific       */
/*            data structures.                                */
/*                                                            */
/*            UDF redesign.                                   */
/*                                                            */
/*            Generic error message no longer printed when    */
/*            an alternate variable handling function         */
/*            generates an error.                             */
/*                                                            */
/**************************************************************/

/* =========================================
   *****************************************
               EXTERNAL DEFINITIONS
   =========================================
   ***************************************** */
#include "setup.h"

#include <stdio.h>

#include <stdlib.h>
#include <ctype.h>

#include "memalloc.h"
#include "constant.h"
#include "envrnmnt.h"
#if DEFGLOBAL_CONSTRUCT
#include "globlpsr.h"
#endif
#include "exprnpsr.h"
#include "multifld.h"
#if OBJECT_SYSTEM
#include "object.h"
#endif
#include "pprint.h"
#include "prcdrpsr.h"
#include "prntutil.h"
#include "router.h"
#include "utility.h"

#include "prccode.h"

/* =========================================
   *****************************************
               MACROS AND TYPES
   =========================================
   ***************************************** */
typedef struct
  {
   unsigned firstFlag  : 1;
   unsigned first      : 15;
   unsigned secondFlag : 1;
   unsigned second     : 15;
  } PACKED_PROC_VAR;

/***************************************/
/* LOCAL INTERNAL FUNCTION DEFINITIONS */
/***************************************/

   static void                    EvaluateProcParameters(Environment *,Expression *,unsigned int,const char *,const char *);
   static bool                    RtnProcParam(Environment *,void *,UDFValue *);
   static bool                    GetProcBind(Environment *,void *,UDFValue *);
   static bool                    PutProcBind(Environment *,void *,UDFValue *);
   static bool                    RtnProcWild(Environment *,void *,UDFValue *);
   static void                    DeallocateProceduralPrimitiveData(Environment *);
   static void                    ReleaseProcParameters(Environment *);

#if (! BLOAD_ONLY) && (! RUN_TIME)
   static unsigned int            FindProcParameter(CLIPSLexeme *,Expression *,CLIPSLexeme *);
   static bool                    ReplaceProcBinds(Environment *,Expression *,
                                                   int (*)(Environment *,Expression *,void *),void *);
   static Expression             *CompactActions(Environment *,Expression *);
#endif

#if (! DEFFUNCTION_CONSTRUCT) || (! DEFGENERIC_CONSTRUCT)
   static bool                    EvaluateBadCall(Environment *,void *,UDFValue *);
#endif

/* =========================================
   *****************************************
          EXTERNALLY VISIBLE FUNCTIONS
   =========================================
   ***************************************** */

/****************************************************
  NAME         : InstallProcedurePrimitives
  DESCRIPTION  : Installs primitive function handlers
                 for accessing parameters and local
                 variables within the bodies of
                 message-handlers, methods, rules and
                 deffunctions.
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : Primitive entities installed
  NOTES        : None
 ****************************************************/
void InstallProcedurePrimitives(
  Environment *theEnv)
  {
   EntityRecord procParameterInfo = { "PROC_PARAM", PROC_PARAM,0,1,0,NULL,NULL,NULL,
                                       (EntityEvaluationFunction *) RtnProcParam,
                                       NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL },
                     procWildInfo =  { "PROC_WILD_PARAM", PROC_WILD_PARAM,0,1,0,NULL,NULL,NULL,
                                       (EntityEvaluationFunction *) RtnProcWild,
                                       NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL },
                     procGetInfo =   { "PROC_GET_BIND", PROC_GET_BIND,0,1,0,NULL,NULL,NULL,
                                       (EntityEvaluationFunction *) GetProcBind,
                                       NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL },
                     procBindInfo =  { "PROC_BIND", PROC_BIND,0,1,0,NULL,NULL,NULL,
                                       (EntityEvaluationFunction *) PutProcBind,
                                       NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL };

#if ! DEFFUNCTION_CONSTRUCT
   EntityRecord deffunctionEntityRecord =
                     { "PCALL", PCALL,0,0,1,
                       NULL,NULL,NULL,
                       EvaluateBadCall,
                       NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL };
#endif
#if ! DEFGENERIC_CONSTRUCT
   EntityRecord genericEntityRecord =
                     { "GCALL", GCALL,0,0,1,
                       NULL,NULL,NULL,
                       EvaluateBadCall,
                       NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL };
#endif

   AllocateEnvironmentData(theEnv,PROCEDURAL_PRIMITIVE_DATA,sizeof(struct proceduralPrimitiveData),DeallocateProceduralPrimitiveData);

   memcpy(&ProceduralPrimitiveData(theEnv)->ProcParameterInfo,&procParameterInfo,sizeof(struct entityRecord));
   memcpy(&ProceduralPrimitiveData(theEnv)->ProcWildInfo,&procWildInfo,sizeof(struct entityRecord));
   memcpy(&ProceduralPrimitiveData(theEnv)->ProcGetInfo,&procGetInfo,sizeof(struct entityRecord));
   memcpy(&ProceduralPrimitiveData(theEnv)->ProcBindInfo,&procBindInfo,sizeof(struct entityRecord));

   InstallPrimitive(theEnv,&ProceduralPrimitiveData(theEnv)->ProcParameterInfo,PROC_PARAM);
   InstallPrimitive(theEnv,&ProceduralPrimitiveData(theEnv)->ProcWildInfo,PROC_WILD_PARAM);
   InstallPrimitive(theEnv,&ProceduralPrimitiveData(theEnv)->ProcGetInfo,PROC_GET_BIND);
   InstallPrimitive(theEnv,&ProceduralPrimitiveData(theEnv)->ProcBindInfo,PROC_BIND);

   ProceduralPrimitiveData(theEnv)->Oldindex = UINT_MAX;

   /* ===============================================
      Make sure a default evaluation function is
      in place for deffunctions and generic functions
      in the event that a binary image containing
      these items is loaded into a configuration
      that does not support them.
      =============================================== */

#if ! DEFFUNCTION_CONSTRUCT
   memcpy(&ProceduralPrimitiveData(theEnv)->DeffunctionEntityRecord,&deffunctionEntityRecord,sizeof(struct entityRecord));
   InstallPrimitive(theEnv,&ProceduralPrimitiveData(theEnv)->DeffunctionEntityRecord,PCALL);
#endif

#if ! DEFGENERIC_CONSTRUCT
   memcpy(&ProceduralPrimitiveData(theEnv)->GenericEntityRecord,&genericEntityRecord,sizeof(struct entityRecord));
   InstallPrimitive(theEnv,&ProceduralPrimitiveData(theEnv)->GenericEntityRecord,GCALL);
#endif

   /* =============================================
      Install the special empty multifield to
      let callers distinguish between no parameters
      and zero-length multifield parameters
      ============================================= */
   ProceduralPrimitiveData(theEnv)->NoParamValue = CreateUnmanagedMultifield(theEnv,0L);
   RetainMultifield(theEnv,ProceduralPrimitiveData(theEnv)->NoParamValue);
  }

/**************************************************************/
/* DeallocateProceduralPrimitiveData: Deallocates environment */
/*    data for the procedural primitives functionality.       */
/**************************************************************/
static void DeallocateProceduralPrimitiveData(
  Environment *theEnv)
  {
   ReturnMultifield(theEnv,ProceduralPrimitiveData(theEnv)->NoParamValue);
   ReleaseProcParameters(theEnv);
  }

#if (! BLOAD_ONLY) && (! RUN_TIME)

#if DEFFUNCTION_CONSTRUCT || OBJECT_SYSTEM

/************************************************************
  NAME         : ParseProcParameters
  DESCRIPTION  : Parses a parameter list for a
                  procedural routine, such as a
                  deffunction or message-handler
  INPUTS       : 1) The logical name of the input
                 2) A buffer for scanned tokens
                 3) The partial list of parameters so far
                    (can be NULL)
                 3) A buffer for a wildcard symbol (if any)
                 4) A buffer for a minimum of parameters
                 5) A buffer for a maximum of parameters
                    (will be set to -1 if there is a wilcard)
                 6) A buffer for an error flag
                 7) The address of a function to do specialized
                    checking on a parameter (can be NULL)
                    The function should accept a string and
                    return false if the parameter is OK, true
                    otherwise.
  RETURNS      : A list of expressions containing the
                   parameter names
  SIDE EFFECTS : Parameters parsed and expressions formed
  NOTES        : None
 ************************************************************/
Expression *ParseProcParameters(
  Environment *theEnv,
  const char *readSource,
  struct token *tkn,
  Expression *parameterList,
  CLIPSLexeme **wildcard,
  unsigned short *min,
  unsigned short *max,
  bool *error,
  bool (*checkfunc)(Environment *,const char *))
  {
   Expression *nextOne,*lastOne,*check;
   int paramprintp = 0;

   *wildcard = NULL;
   *min = 0;
   *error = true;
   lastOne = nextOne = parameterList;
   while (nextOne != NULL)
     {
      (*min)++;
      lastOne = nextOne;
      nextOne = nextOne->nextArg;
     }
   if (tkn->tknType != LEFT_PARENTHESIS_TOKEN)
     {
      SyntaxErrorMessage(theEnv,"parameter list");
      ReturnExpression(theEnv,parameterList);
      return NULL;
     }
   GetToken(theEnv,readSource,tkn);
   while ((tkn->tknType == SF_VARIABLE_TOKEN) || (tkn->tknType == MF_VARIABLE_TOKEN))
     {
      for (check = parameterList ; check != NULL ; check = check->nextArg)
        if (check->value == tkn->value)
         {
          PrintErrorID(theEnv,"PRCCODE",7,false);
          WriteString(theEnv,STDERR,"Duplicate parameter names not allowed.\n");
          ReturnExpression(theEnv,parameterList);
          return NULL;
         }
      if (*wildcard != NULL)
        {
         PrintErrorID(theEnv,"PRCCODE",8,false);
         WriteString(theEnv,STDERR,"No parameters allowed after wildcard parameter.\n");
         ReturnExpression(theEnv,parameterList);
         return NULL;
        }
      if ((checkfunc != NULL) ? (*checkfunc)(theEnv,tkn->lexemeValue->contents) : false)
        {
         ReturnExpression(theEnv,parameterList);
         return NULL;
        }
      nextOne = GenConstant(theEnv,TokenTypeToType(tkn->tknType),tkn->value);
      if (tkn->tknType == MF_VARIABLE_TOKEN)
        *wildcard = tkn->lexemeValue;
      else
        (*min)++;
      if (lastOne == NULL)
        { parameterList = nextOne; }
      else
        { lastOne->nextArg = nextOne; }
      lastOne = nextOne;
      SavePPBuffer(theEnv," ");
      paramprintp = 1;
      GetToken(theEnv,readSource,tkn);
     }
   if (tkn->tknType != RIGHT_PARENTHESIS_TOKEN)
     {
      SyntaxErrorMessage(theEnv,"parameter list");
      ReturnExpression(theEnv,parameterList);
      return NULL;
     }
   if (paramprintp)
     {
      PPBackup(theEnv);
      PPBackup(theEnv);
      SavePPBuffer(theEnv,")");
     }
   *error = false;
   *max = (*wildcard != NULL) ? PARAMETERS_UNBOUNDED : *min;
   return(parameterList);
  }

#endif

/*************************************************************************
  NAME         : ParseProcActions
  DESCRIPTION  : Parses the bodies of deffunctions, generic function
                 methods and message-handlers.  Replaces parameter
                 and local variable references with appropriate
                 runtime access functions
  INPUTS       : 1) The environment
                 2) The type of procedure body being parsed
                 3) The logical name of the input
                 4) A buffer for scanned tokens
                 5) A list of expressions containing the names
                    of the parameters
                 6) The wilcard parameter symbol (NULL if none)
                 7) A pointer to a function to parse variables not
                    recognized by the standard parser
                    The function should accept the variable
                    expression and a generic pointer for special
                    data (can be NULL) as arguments.  If the variable
                    is recognized, the function should modify the
                    expression to access this variable.  Return 1
                    if recognized, 0 if not, -1 on errors
                    This argument can be NULL.
                 8) A pointer to a function to handle binds in a
                    special way. The function should accept the
                    bind function call expression as an argument.
                    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 can be NULL.
                 9) A buffer for holding the number of local vars
                    used by this procedure body.
                10) Special user data buffer to pass to variable
                    reference and bind replacement functions
RETURNS      : A packed expression containing the body, NULL on
                   errors.
SIDE EFFECTS : Variable references replaced with runtime calls
                  to access the paramter and local variable array
NOTES        : None
*************************************************************************/
Expression *ParseProcActions(
  Environment *theEnv,
  const char *bodytype,
  const char *readSource,
  struct token *tkn,
  Expression *params,
  CLIPSLexeme *wildcard,
  int (*altvarfunc)(Environment *,Expression *,void *),
  int (*altbindfunc)(Environment *,Expression *,void *),
  unsigned short *lvarcnt,
  void *userBuffer)
  {
   Expression *actions,*pactions;

   /* ====================================================================
      Clear parsed bind list - so that only local vars from this body will
      be on it.  The position of vars on thsi list are used to generate
      indices into the LocalVarArray at runtime.  The parsing of the
      "bind" function adds vars to this list.
      ==================================================================== */
   ClearParsedBindNames(theEnv);
   actions = GroupActions(theEnv,readSource,tkn,true,NULL,false);
   if (actions == NULL)
     return NULL;

   /* ====================================================================
      Replace any bind functions with special functions before replacing
      any variable references.  This allows those bind names to be removed
      before they can be seen by variable replacement and thus generate
      incorrect indices.
      ==================================================================== */
   if (altbindfunc != NULL)
     {
      if (ReplaceProcBinds(theEnv,actions,altbindfunc,userBuffer))
        {
         ClearParsedBindNames(theEnv);
         ReturnExpression(theEnv,actions);
         return NULL;
        }
     }

   /* ======================================================================
      The number of names left on the bind list is the number of local
      vars for this procedure body.  Replace all variable reference with
      runtime access functions for ProcParamArray, LocalVarArray or
      other special items, such as direct slot references, global variables,
      or fact field references.
      ====================================================================== */
   *lvarcnt = CountParsedBindNames(theEnv);
   if (ReplaceProcVars(theEnv,bodytype,actions,params,wildcard,altvarfunc,userBuffer))
     {
      ClearParsedBindNames(theEnv);
      ReturnExpression(theEnv,actions);
      return NULL;
     }

   /* =======================================================================
      Normally, actions are grouped in a progn.  If there is only one action,
      the progn is unnecessary and can be removed.  Also, the actions are
      packed into a contiguous array to save on memory overhead.  The
      intermediate parsed bind names are freed to avoid tying up memory.
      ======================================================================= */
   actions = CompactActions(theEnv,actions);
   pactions = PackExpression(theEnv,actions);
   ReturnExpression(theEnv,actions);
   ClearParsedBindNames(theEnv);
   return(pactions);
  }

/*************************************************************************
  NAME         : ReplaceProcVars
  DESCRIPTION  : Examines an expression for variables
                   and replaces any that correspond to
                   procedure parameters or globals
                   with function calls that get these
                   variables' values at run-time.
                   For example, procedure arguments
                   are stored an array at run-time, so at
                   parse-time, parameter-references are replaced
                   with function calls referencing this array at
                   the appropriate position.
  INPUTS       : 1) The type of procedure being parsed
                 2) The expression-actions to be examined
                 3) The parameter list
                 4) The wildcard parameter symbol (NULL if none)
                 5) A pointer to a function to parse variables not
                    recognized by the standard parser
                    The function should accept the variable
                    expression and a generic pointer for special
                    data (can be NULL) as arguments.  If the variable
                    is recognized, the function should modify the
                    expression to access this variable.  Return 1
                    if recognized, 0 if not, -1 on errors
                    This argument can be NULL.
                 6) Data buffer to be passed to alternate parsing
                    function
  RETURNS      : False if OK, true on errors
  SIDE EFFECTS : Variable references replaced with function calls
  NOTES        : This function works from the ParsedBindNames list in
                    SPCLFORM.C to access local binds.  Make sure that
                    the list accurately reflects the binds by calling
                    ClearParsedBindNames(theEnv) before the parse of the body
                    in which variables are being replaced.
 *************************************************************************/
int ReplaceProcVars(
  Environment *theEnv,
  const char *bodytype,
  Expression *actions,
  Expression *parameterList,
  CLIPSLexeme *wildcard,
  int (*altvarfunc)(Environment *,Expression *,void *),
  void *specdata)
  {
   int altcode;
   unsigned position, boundPosn;
   Expression *arg_lvl,*altvarexp;
   CLIPSLexeme *bindName;
   PACKED_PROC_VAR pvar;
   int errorCode;

   while (actions != NULL)
     {
      if (actions->type == SF_VARIABLE)
        {
         /*===============================================*/
         /* See if the variable is in the parameter list. */
         /*===============================================*/

         bindName = actions->lexemeValue;
         position = FindProcParameter(bindName,parameterList,wildcard);

         /*=============================================================*/
         /* Check to see if the variable is bound within the procedure. */
         /*=============================================================*/

         boundPosn = SearchParsedBindNames(theEnv,bindName);

         /*=============================================*/
         /* If variable is not defined in the parameter */
         /* list or as part of a bind action then...    */
         /*=============================================*/

         if ((position == 0) && (boundPosn == 0))
           {
            /*================================================================*/
            /* Check to see if the variable has a special access function,    */
            /* such as direct slot reference or a rule RHS pattern reference. */
            /*================================================================*/

            if (altvarfunc == NULL)
              { errorCode = 0; }
            else
              { errorCode = (*altvarfunc)(theEnv,actions,specdata); }

            if (errorCode != 1)
              {
               if (errorCode == 0)
                 {
                  PrintErrorID(theEnv,"PRCCODE",3,true);
                  WriteString(theEnv,STDERR,"Undefined variable ?");
                  WriteString(theEnv,STDERR,bindName->contents);
                  WriteString(theEnv,STDERR," referenced in ");
                  WriteString(theEnv,STDERR,bodytype);
                  WriteString(theEnv,STDERR,".\n");
                 }
               return 1;
              }
           }

         /*===================================================*/
         /* Else if variable is defined in the parameter list */
         /* and not rebound within the procedure then...      */
         /*===================================================*/

         else if ((position > 0) && (boundPosn == 0))
           {
            actions->type = ((bindName != wildcard) ? PROC_PARAM : PROC_WILD_PARAM);
            actions->value = AddBitMap(theEnv,&position,sizeof(int));
           }

         /*=========================================================*/
         /* Else the variable is rebound within the procedure so... */
         /*=========================================================*/

         else
           {
            if (altvarfunc != NULL)
              {
               altvarexp = GenConstant(theEnv,actions->type,actions->value);
               altcode = (*altvarfunc)(theEnv,altvarexp,specdata);
               if (altcode == 0)
                 {
                  rtn_struct(theEnv,expr,altvarexp);
                  altvarexp = NULL;
                 }
               else if (altcode == -1)
                 {
                  rtn_struct(theEnv,expr,altvarexp);
                  return true;
                 }
              }
            else
              altvarexp = NULL;
            actions->type = PROC_GET_BIND;
            ClearBitString(&pvar,sizeof(PACKED_PROC_VAR));
            pvar.first = boundPosn;
            pvar.second = position;
            pvar.secondFlag = (bindName != wildcard) ? 0 : 1;
            actions->value = AddBitMap(theEnv,&pvar,sizeof(PACKED_PROC_VAR));
            actions->argList = GenConstant(theEnv,SYMBOL_TYPE,bindName);
            actions->argList->nextArg = altvarexp;
           }
        }
#if DEFGLOBAL_CONSTRUCT
      else if (actions->type == GBL_VARIABLE)
        {
         if (ReplaceGlobalVariable(theEnv,actions) == false)
           return(-1);
        }
#endif
      if ((altvarfunc != NULL) ? ((*altvarfunc)(theEnv,actions,specdata) == -1) : false)
        return 1;
      if (actions->argList != NULL)
        {
         if (ReplaceProcVars(theEnv,bodytype,actions->argList,parameterList,
                                        wildcard,altvarfunc,specdata))
           return 1;

         /* ====================================================================
            Check to see if this is a call to the bind function.  If so (and the
            second argument is a symbol) then it is a locally bound variable
            (as opposed to a global).

            Replace the call to "bind" with a call to PROC_BIND - the
            special internal function for procedure local variables.
            ==================================================================== */
         if ((actions->value == (void *) FindFunction(theEnv,"bind")) &&
             (actions->argList->type == SYMBOL_TYPE))
           {
            actions->type = PROC_BIND;
            boundPosn = SearchParsedBindNames(theEnv,actions->argList->lexemeValue);
            actions->value = AddBitMap(theEnv,&boundPosn,sizeof(int));
            arg_lvl = actions->argList->nextArg;
            rtn_struct(theEnv,expr,actions->argList);
            actions->argList = arg_lvl;
           }
        }
      actions = actions->nextArg;
     }
   return 0;
  }

#if DEFGENERIC_CONSTRUCT

/*****************************************************
  NAME         : GenProcWildcardReference
  DESCRIPTION  : Returns an expression to access the
                    wildcard parameter for a method
  INPUTS       : The starting index of the wildcard
  RETURNS      : An expression containing the wildcard
                 reference
  SIDE EFFECTS : Expression allocated
  NOTES        : None
 *****************************************************/
Expression *GenProcWildcardReference(
  Environment *theEnv,
  int theIndex)
  {
   return(GenConstant(theEnv,PROC_WILD_PARAM,AddBitMap(theEnv,&theIndex,sizeof(int))));
  }

#endif

#endif

/*******************************************************************
  NAME         : PushProcParameters
  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
                 The current arrays are saved on a stack.
  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
                 5) A pointer to a function to print out a trace
                    message about the currently executing
                    procedure when unbound variables are detected
                    at runtime (The function should take no
                    arguments and have no return value.  The
                    function should print its synopsis to STDERR
                    and include the final carriage-return.)
  RETURNS      : Nothing useful
  SIDE EFFECTS : Any side-effects of the evaluation of the
                   parameter expressions
                 UDFValue array allocated (deallocated on errors)
                 ProcParamArray set
  NOTES        : EvaluationError set on errors
 *******************************************************************/
void PushProcParameters(
  Environment *theEnv,
  Expression *parameterList,
  unsigned int numberOfParameters,
  const char *pname,
  const char *bodytype,
  void (*UnboundErrFunc)(Environment *,const char *))
  {
   PROC_PARAM_STACK *ptmp;

   ptmp = get_struct(theEnv,ProcParamStack);
   ptmp->ParamArray = ProceduralPrimitiveData(theEnv)->ProcParamArray;
   ptmp->ParamArraySize = ProceduralPrimitiveData(theEnv)->ProcParamArraySize;
   ptmp->UnboundErrFunc = ProceduralPrimitiveData(theEnv)->ProcUnboundErrFunc;
   ptmp->nxt = ProceduralPrimitiveData(theEnv)->pstack;
   ProceduralPrimitiveData(theEnv)->pstack = ptmp;
   EvaluateProcParameters(theEnv,parameterList,numberOfParameters,pname,bodytype);
   if (EvaluationData(theEnv)->EvaluationError)
     {
      ptmp = ProceduralPrimitiveData(theEnv)->pstack;
      ProceduralPrimitiveData(theEnv)->pstack = ProceduralPrimitiveData(theEnv)->pstack->nxt;
      rtn_struct(theEnv,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 = ProceduralPrimitiveData(theEnv)->ProcParamExpressions;
   ProceduralPrimitiveData(theEnv)->ProcParamExpressions = NULL;
#endif
   ptmp->WildcardValue = ProceduralPrimitiveData(theEnv)->WildcardValue;
   ProceduralPrimitiveData(theEnv)->WildcardValue = NULL;
   ProceduralPrimitiveData(theEnv)->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
 ******************************************************************/
void PopProcParameters(
  Environment *theEnv)
  {
   PROC_PARAM_STACK *ptmp;

   if (ProceduralPrimitiveData(theEnv)->ProcParamArray != NULL)
     rm(theEnv,ProceduralPrimitiveData(theEnv)->ProcParamArray,(sizeof(UDFValue) * ProceduralPrimitiveData(theEnv)->ProcParamArraySize));

#if DEFGENERIC_CONSTRUCT
   if (ProceduralPrimitiveData(theEnv)->ProcParamExpressions != NULL)
     rm(theEnv,ProceduralPrimitiveData(theEnv)->ProcParamExpressions,(sizeof(Expression) * ProceduralPrimitiveData(theEnv)->ProcParamArraySize));
#endif

   ptmp = ProceduralPrimitiveData(theEnv)->pstack;
   ProceduralPrimitiveData(theEnv)->pstack = ProceduralPrimitiveData(theEnv)->pstack->nxt;
   ProceduralPrimitiveData(theEnv)->ProcParamArray = ptmp->ParamArray;
   ProceduralPrimitiveData(theEnv)->ProcParamArraySize = ptmp->ParamArraySize;

#if DEFGENERIC_CONSTRUCT
   ProceduralPrimitiveData(theEnv)->ProcParamExpressions = ptmp->ParamExpressions;
#endif

   if (ProceduralPrimitiveData(theEnv)->WildcardValue != NULL)
     {
      ReleaseMultifield(theEnv,ProceduralPrimitiveData(theEnv)->WildcardValue->multifieldValue);
      if (ProceduralPrimitiveData(theEnv)->WildcardValue->value != ProceduralPrimitiveData(theEnv)->NoParamValue)
        AddToMultifieldList(theEnv,ProceduralPrimitiveData(theEnv)->WildcardValue->multifieldValue);
      rtn_struct(theEnv,udfValue,ProceduralPrimitiveData(theEnv)->WildcardValue);
     }
   ProceduralPrimitiveData(theEnv)->WildcardValue = ptmp->WildcardValue;
   ProceduralPrimitiveData(theEnv)->ProcUnboundErrFunc = ptmp->UnboundErrFunc;
   rtn_struct(theEnv,ProcParamStack,ptmp);
  }

/******************************************************************
  NAME         : ReleaseProcParameters
  DESCRIPTION  : Restores old procedure arrays
  INPUTS       : None
  RETURNS      : Nothing useful
  SIDE EFFECTS : Stack popped and globals restored
  NOTES        : Assumes pstack != NULL
 ******************************************************************/
static void ReleaseProcParameters(
  Environment *theEnv)
  {
   PROC_PARAM_STACK *ptmp, *next;

   if (ProceduralPrimitiveData(theEnv)->ProcParamArray != NULL)
     rm(theEnv,ProceduralPrimitiveData(theEnv)->ProcParamArray,(sizeof(UDFValue) * ProceduralPrimitiveData(theEnv)->ProcParamArraySize));


   if (ProceduralPrimitiveData(theEnv)->WildcardValue != NULL)
     {
      if (ProceduralPrimitiveData(theEnv)->WildcardValue->value != ProceduralPrimitiveData(theEnv)->NoParamValue)
        { ReturnMultifield(theEnv,ProceduralPrimitiveData(theEnv)->WildcardValue->multifieldValue); }

      rtn_struct(theEnv,udfValue,ProceduralPrimitiveData(theEnv)->WildcardValue);
     }

#if DEFGENERIC_CONSTRUCT
   if (ProceduralPrimitiveData(theEnv)->ProcParamExpressions != NULL)
     rm(theEnv,ProceduralPrimitiveData(theEnv)->ProcParamExpressions,(sizeof(Expression) * ProceduralPrimitiveData(theEnv)->ProcParamArraySize));
#endif

   ptmp = ProceduralPrimitiveData(theEnv)->pstack;

   while (ptmp != NULL)
     {
      next = ptmp->nxt;

      if (ptmp->ParamArray != NULL)
        { rm(theEnv,ptmp->ParamArray,(sizeof(UDFValue) * ptmp->ParamArraySize)); }

#if DEFGENERIC_CONSTRUCT
      if (ptmp->ParamExpressions != NULL)
        { rm(theEnv,ptmp->ParamExpressions,(sizeof(Expression) * ptmp->ParamArraySize)); }
#endif

      if (ptmp->WildcardValue != NULL)
        {
         if (ptmp->WildcardValue->value != ProceduralPrimitiveData(theEnv)->NoParamValue)
           { ReturnMultifield(theEnv,ptmp->WildcardValue->multifieldValue); }

         rtn_struct(theEnv,udfValue,ptmp->WildcardValue);
        }

      rtn_struct(theEnv,ProcParamStack,ptmp);
      ptmp = next;
     }
  }

#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 H/L 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
 ***********************************************************/
Expression *GetProcParamExpressions(
  Environment *theEnv)
  {
   unsigned int i;

   if ((ProceduralPrimitiveData(theEnv)->ProcParamArray == NULL) || (ProceduralPrimitiveData(theEnv)->ProcParamExpressions != NULL))
     return(ProceduralPrimitiveData(theEnv)->ProcParamExpressions);
   ProceduralPrimitiveData(theEnv)->ProcParamExpressions = (Expression *)
               gm2(theEnv,(sizeof(Expression) * ProceduralPrimitiveData(theEnv)->ProcParamArraySize));
   for (i = 0 ; i < ProceduralPrimitiveData(theEnv)->ProcParamArraySize ; i++)
     {
      ProceduralPrimitiveData(theEnv)->ProcParamExpressions[i].type = ProceduralPrimitiveData(theEnv)->ProcParamArray[i].header->type; // TBD Remove
      if (ProceduralPrimitiveData(theEnv)->ProcParamArray[i].header->type != MULTIFIELD_TYPE)
        ProceduralPrimitiveData(theEnv)->ProcParamExpressions[i].value = ProceduralPrimitiveData(theEnv)->ProcParamArray[i].value;
      else
        ProceduralPrimitiveData(theEnv)->ProcParamExpressions[i].value = &ProceduralPrimitiveData(theEnv)->ProcParamArray[i];
      ProceduralPrimitiveData(theEnv)->ProcParamExpressions[i].argList = NULL;
      ProceduralPrimitiveData(theEnv)->ProcParamExpressions[i].nextArg =
        ((i + 1) != ProceduralPrimitiveData(theEnv)->ProcParamArraySize) ? &ProceduralPrimitiveData(theEnv)->ProcParamExpressions[i+1] : NULL;
     }
   return(ProceduralPrimitiveData(theEnv)->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
 ***********************************************************/
void EvaluateProcActions(
  Environment *theEnv,
  Defmodule *theModule,
  Expression *actions,
  unsigned short lvarcnt,
  UDFValue *returnValue,
  void (*crtproc)(Environment *,const char *))
  {
   UDFValue *oldLocalVarArray;
   unsigned short i;
   Defmodule *oldModule;
   Expression *oldActions;
   struct trackedMemory *theTM;

   oldLocalVarArray = ProceduralPrimitiveData(theEnv)->LocalVarArray;
   ProceduralPrimitiveData(theEnv)->LocalVarArray = (lvarcnt == 0) ? NULL :
                   (UDFValue *) gm2(theEnv,(sizeof(UDFValue) * lvarcnt));

   if (lvarcnt != 0)
     { theTM = AddTrackedMemory(theEnv,ProceduralPrimitiveData(theEnv)->LocalVarArray,sizeof(UDFValue) * lvarcnt); }
   else
     { theTM = NULL; }

   for (i = 0 ; i < lvarcnt ; i++)
     ProceduralPrimitiveData(theEnv)->LocalVarArray[i].supplementalInfo = FalseSymbol(theEnv);

   oldModule = GetCurrentModule(theEnv);
   if (oldModule != theModule)
     SetCurrentModule(theEnv,theModule);
   oldActions = ProceduralPrimitiveData(theEnv)->CurrentProcActions;
   ProceduralPrimitiveData(theEnv)->CurrentProcActions = actions;

   if (EvaluateExpression(theEnv,actions,returnValue))
     {
      returnValue->value = FalseSymbol(theEnv);
     }

   ProceduralPrimitiveData(theEnv)->CurrentProcActions = oldActions;
   if (oldModule != GetCurrentModule(theEnv))
     SetCurrentModule(theEnv,oldModule);
   if ((crtproc != NULL) ? EvaluationData(theEnv)->HaltExecution : false)
     {
      const char *logName;

      if (GetEvaluationError(theEnv))
        {
         PrintErrorID(theEnv,"PRCCODE",4,false);
         logName = STDERR;
        }
      else
        {
         PrintWarningID(theEnv,"PRCCODE",4,false);
         logName = STDWRN;
        }
      WriteString(theEnv,logName,"Execution halted during the actions of ");
      (*crtproc)(theEnv,logName);
     }

   if ((ProceduralPrimitiveData(theEnv)->WildcardValue != NULL) ? (returnValue->value == ProceduralPrimitiveData(theEnv)->WildcardValue->value) : false)
     {
      ReleaseMultifield(theEnv,ProceduralPrimitiveData(theEnv)->WildcardValue->multifieldValue);
      if (ProceduralPrimitiveData(theEnv)->WildcardValue->value != ProceduralPrimitiveData(theEnv)->NoParamValue)
        AddToMultifieldList(theEnv,ProceduralPrimitiveData(theEnv)->WildcardValue->multifieldValue);
      rtn_struct(theEnv,udfValue,ProceduralPrimitiveData(theEnv)->WildcardValue);
      ProceduralPrimitiveData(theEnv)->WildcardValue = NULL;
     }

   if (lvarcnt != 0)
     {
      RemoveTrackedMemory(theEnv,theTM);
      for (i = 0 ; i < lvarcnt ; i++)
        if (ProceduralPrimitiveData(theEnv)->LocalVarArray[i].supplementalInfo == TrueSymbol(theEnv))
          ReleaseUDFV(theEnv,&ProceduralPrimitiveData(theEnv)->LocalVarArray[i]);
      rm(theEnv,ProceduralPrimitiveData(theEnv)->LocalVarArray,(sizeof(UDFValue) * lvarcnt));
     }

   ProceduralPrimitiveData(theEnv)->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
 ****************************************************/
void PrintProcParamArray(
  Environment *theEnv,
  const char *logName)
  {
   unsigned int i;

   WriteString(theEnv,logName," (");
   for (i = 0 ; i < ProceduralPrimitiveData(theEnv)->ProcParamArraySize ; i++)
     {
      WriteUDFValue(theEnv,logName,&ProceduralPrimitiveData(theEnv)->ProcParamArray[i]);
      if (i != ProceduralPrimitiveData(theEnv)->ProcParamArraySize-1)
        WriteString(theEnv,logName," ");
     }
   WriteString(theEnv,logName,")\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
 ****************************************************************/
void GrabProcWildargs(
  Environment *theEnv,
  UDFValue *returnValue,
  unsigned int theIndex)
  {
   unsigned int i, j;
   size_t k; /* 6.04 Bug Fix */
   size_t size;
   UDFValue *val;

   returnValue->begin = 0;
   if (ProceduralPrimitiveData(theEnv)->WildcardValue == NULL)
     {
      ProceduralPrimitiveData(theEnv)->WildcardValue = get_struct(theEnv,udfValue);
      ProceduralPrimitiveData(theEnv)->WildcardValue->begin = 0;
     }
   else if (theIndex == ProceduralPrimitiveData(theEnv)->Oldindex)
     {
      returnValue->range = ProceduralPrimitiveData(theEnv)->WildcardValue->range;
      returnValue->value = ProceduralPrimitiveData(theEnv)->WildcardValue->value;
      return;
     }
   else
     {
      ReleaseMultifield(theEnv,ProceduralPrimitiveData(theEnv)->WildcardValue->multifieldValue);
      if (ProceduralPrimitiveData(theEnv)->WildcardValue->value != ProceduralPrimitiveData(theEnv)->NoParamValue)
        AddToMultifieldList(theEnv,ProceduralPrimitiveData(theEnv)->WildcardValue->multifieldValue);
     }
   ProceduralPrimitiveData(theEnv)->Oldindex = theIndex;
   size = ProceduralPrimitiveData(theEnv)->ProcParamArraySize + 1 - theIndex;
     
   if (size == 0)
     {
      returnValue->range = 0;
      ProceduralPrimitiveData(theEnv)->WildcardValue->range = 0;
      returnValue->value = ProceduralPrimitiveData(theEnv)->WildcardValue->value = ProceduralPrimitiveData(theEnv)->NoParamValue;
      RetainMultifield(theEnv,ProceduralPrimitiveData(theEnv)->WildcardValue->multifieldValue);
      return;
     }
   for (i = theIndex-1 ; i < ProceduralPrimitiveData(theEnv)->ProcParamArraySize ; i++)
     {
      if (ProceduralPrimitiveData(theEnv)->ProcParamArray[i].header->type == MULTIFIELD_TYPE)
        size += ProceduralPrimitiveData(theEnv)->ProcParamArray[i].range - 1;
     }
   returnValue->range = size;
   ProceduralPrimitiveData(theEnv)->WildcardValue->range = size;
   returnValue->value = ProceduralPrimitiveData(theEnv)->WildcardValue->value = CreateUnmanagedMultifield(theEnv,size);
   for (i = theIndex-1 , j = 0 ; i < ProceduralPrimitiveData(theEnv)->ProcParamArraySize ; i++)
     {
      if (ProceduralPrimitiveData(theEnv)->ProcParamArray[i].header->type != MULTIFIELD_TYPE)
        {
         returnValue->multifieldValue->contents[j].value = ProceduralPrimitiveData(theEnv)->ProcParamArray[i].value;
         j++;
        }
      else
        {
         val = &ProceduralPrimitiveData(theEnv)->ProcParamArray[i];
         for (k = val->begin ; k < (val->begin + val->range)  ; k++ , j++)
           {
            returnValue->multifieldValue->contents[j].value = val->multifieldValue->contents[k].value;
           }
        }
     }
   RetainMultifield(theEnv,ProceduralPrimitiveData(theEnv)->WildcardValue->multifieldValue);
  }

/* =========================================
   *****************************************
          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
                 UDFValue array allocated (deallocated on errors)
                 ProcParamArray set
  NOTES        : EvaluationError set on errors
 *******************************************************************/
static void EvaluateProcParameters(
  Environment *theEnv,
  Expression *parameterList,
  unsigned int numberOfParameters,
  const char *pname,
  const char *bodytype)
  {
   UDFValue *rva,temp;
   int i = 0;

   if (numberOfParameters == 0)
     {
      ProceduralPrimitiveData(theEnv)->ProcParamArray = NULL;
      ProceduralPrimitiveData(theEnv)->ProcParamArraySize = 0;
      return;
     }

   rva = (UDFValue *) gm2(theEnv,(sizeof(UDFValue) * numberOfParameters));
   while (parameterList != NULL)
     {
      if ((EvaluateExpression(theEnv,parameterList,&temp) == true) ? true :
          (temp.header->type == VOID_TYPE))
        {
         if (temp.header->type == VOID_TYPE)
           {
            PrintErrorID(theEnv,"PRCCODE",2,false);
            WriteString(theEnv,STDERR,"Functions without a return value are illegal as ");
            WriteString(theEnv,STDERR,bodytype);
            WriteString(theEnv,STDERR," arguments.\n");
            SetEvaluationError(theEnv,true);
           }
         PrintErrorID(theEnv,"PRCCODE",6,false);
         WriteString(theEnv,STDERR,"This error occurred while evaluating arguments ");
         WriteString(theEnv,STDERR,"for the ");
         WriteString(theEnv,STDERR,bodytype);
         WriteString(theEnv,STDERR," '");
         WriteString(theEnv,STDERR,pname);
         WriteString(theEnv,STDERR,"'.\n");
         rm(theEnv,rva,(sizeof(UDFValue) * numberOfParameters));
         return;
        }
      rva[i].value = temp.value;
      rva[i].begin = temp.begin;
      rva[i].range = temp.range;
      parameterList = parameterList->nextArg;
      i++;
     }
   ProceduralPrimitiveData(theEnv)->ProcParamArraySize = numberOfParameters;
   ProceduralPrimitiveData(theEnv)->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 bool RtnProcParam(
  Environment *theEnv,
  void *value,
  UDFValue *returnValue)
  {
   UDFValue *src;

   src = &ProceduralPrimitiveData(theEnv)->ProcParamArray[*((int *) ((CLIPSBitMap *) value)->contents) - 1];
   returnValue->value = src->value;
   returnValue->begin = src->begin;
   returnValue->range = src->range;
   return 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 bool GetProcBind(
  Environment *theEnv,
  void *value,
  UDFValue *returnValue)
  {
   UDFValue *src;
   PACKED_PROC_VAR *pvar;

   pvar = (PACKED_PROC_VAR *) ((CLIPSBitMap *) value)->contents;
   src = &ProceduralPrimitiveData(theEnv)->LocalVarArray[pvar->first - 1];
   if (src->supplementalInfo == TrueSymbol(theEnv))
     {
      returnValue->value = src->value;
      returnValue->begin = src->begin;
      returnValue->range = src->range;
      return true;
     }
   if (GetFirstArgument()->nextArg != NULL)
     {
      EvaluateExpression(theEnv,GetFirstArgument()->nextArg,returnValue);
      return true;
     }
   if (pvar->second == 0)
     {
      PrintErrorID(theEnv,"PRCCODE",5,false);
      SetEvaluationError(theEnv,true);
      WriteString(theEnv,STDERR,"Variable ?");
      WriteString(theEnv,STDERR,GetFirstArgument()->lexemeValue->contents);
      if (ProceduralPrimitiveData(theEnv)->ProcUnboundErrFunc != NULL)
        {
         WriteString(theEnv,STDERR," unbound in ");
         (*ProceduralPrimitiveData(theEnv)->ProcUnboundErrFunc)(theEnv,STDERR);
        }
      else
        WriteString(theEnv,STDERR," unbound.\n");
      returnValue->value = FalseSymbol(theEnv);
      return true;
     }
   if (pvar->secondFlag == 0)
     {
      src = &ProceduralPrimitiveData(theEnv)->ProcParamArray[pvar->second - 1];
      returnValue->value = src->value;
      returnValue->begin = src->begin;
      returnValue->range = src->range;
     }
   else
     GrabProcWildargs(theEnv,returnValue,pvar->second);
   return 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 bool PutProcBind(
  Environment *theEnv,
  void *value,
  UDFValue *returnValue)
  {
   UDFValue *dst;

   dst = &ProceduralPrimitiveData(theEnv)->LocalVarArray[*((int *) ((CLIPSBitMap *) value)->contents) - 1];
   if (GetFirstArgument() == NULL)
     {
      if (dst->supplementalInfo == TrueSymbol(theEnv))
        ReleaseUDFV(theEnv,dst);
      dst->supplementalInfo = FalseSymbol(theEnv);
      returnValue->value = FalseSymbol(theEnv);
     }
   else
     {
      if (GetFirstArgument()->nextArg != NULL)
        StoreInMultifield(theEnv,returnValue,GetFirstArgument(),true);
      else
        EvaluateExpression(theEnv,GetFirstArgument(),returnValue);
      if (dst->supplementalInfo == TrueSymbol(theEnv))
        ReleaseUDFV(theEnv,dst);
      dst->supplementalInfo = TrueSymbol(theEnv);
      dst->value = returnValue->value;
      dst->begin = returnValue->begin;
      dst->range = returnValue->range;
      RetainUDFV(theEnv,dst);
     }
   return 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 bool RtnProcWild(
  Environment *theEnv,
  void *value,
  UDFValue *returnValue)
  {
   GrabProcWildargs(theEnv,returnValue,*(unsigned *) ((CLIPSBitMap *) value)->contents);
   return 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 unsigned int FindProcParameter(
  CLIPSLexeme *name,
  Expression *parameterList,
  CLIPSLexeme *wildcard)
  {
   unsigned 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      : False if OK, 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 bool ReplaceProcBinds(
  Environment *theEnv,
  Expression *actions,
  int (*altbindfunc)(Environment *,Expression *,void *),
  void *userBuffer)
  {
   int bcode;
   CLIPSLexeme *bname;

   while (actions != NULL)
     {
      if (actions->argList != NULL)
        {
         if (ReplaceProcBinds(theEnv,actions->argList,altbindfunc,userBuffer))
           return true;
         if ((actions->value == (void *) FindFunction(theEnv,"bind")) &&
             (actions->argList->type == SYMBOL_TYPE))
           {
            bname = actions->argList->lexemeValue;
            bcode = (*altbindfunc)(theEnv,actions,userBuffer);
            if (bcode == -1)
              return true;
            if (bcode == 1)
              RemoveParsedBindName(theEnv,bname);
           }
        }
      actions = actions->nextArg;
     }
   return 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 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(
  Environment *theEnv,
  Expression *actions)
  {
   struct expr *tmp;

   if (actions->argList == NULL)
     {
      actions->type = SYMBOL_TYPE;
      actions->value = FalseSymbol(theEnv);
     }
   else if (actions->argList->nextArg == NULL)
     {
      tmp = actions;
      actions = actions->argList;
      rtn_struct(theEnv,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      : 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 bool EvaluateBadCall(
  Environment *theEnv,
  void *value,
  UDFValue *returnValue)
  {
#if MAC_XCD
#pragma unused(value)
#endif
   PrintErrorID(theEnv,"PRCCODE",1,false);
   WriteString(theEnv,STDERR,"Attempted to call a deffunction/generic function ");
   WriteString(theEnv,STDERR,"which does not exist.\n");
   SetEvaluationError(theEnv,true);
   returnValue->value = FalseSymbol(theEnv);
   return false;
  }

#endif