clipsruby 0.0.2

data/ext/clipsruby/exprnpsr.c

@@ -0,0 +1,1112 @@
+   /*******************************************************/
+   /*      "C" Language Integrated Production System      */
+   /*                                                     */
+   /*            CLIPS Version 6.40  12/17/18             */
+   /*                                                     */
+   /*              EXPRESSION PARSER MODULE               */
+   /*******************************************************/
+
+/*************************************************************/
+/* Purpose: Provides routines for parsing expressions.       */
+/*                                                           */
+/* Principal Programmer(s):                                  */
+/*      Gary D. Riley                                        */
+/*                                                           */
+/* Contributing Programmer(s):                               */
+/*      Brian L. Dantes                                      */
+/*                                                           */
+/* Revision History:                                         */
+/*                                                           */
+/*      6.23: Changed name of variable exp to theExp         */
+/*            because of Unix compiler warnings of shadowed  */
+/*            definitions.                                   */
+/*                                                           */
+/*      6.24: Renamed BOOLEAN macro type to intBool.         */
+/*                                                           */
+/*      6.30: Module specifier can be used within an         */
+/*            expression to refer to a deffunction or        */
+/*            defgeneric exported by the specified module,   */
+/*            but not necessarily imported by the current    */
+/*            module.                                        */
+/*                                                           */
+/*            Added const qualifiers to remove C++           */
+/*            deprecation warnings.                          */
+/*                                                           */
+/*            Converted API macros to function calls.        */
+/*                                                           */
+/*            Changed find construct functionality so that   */
+/*            imported modules are search when locating a    */
+/*            named construct.                               */
+/*                                                           */
+/*      6.31: Fixed bug where sequence expansion was always  */
+/*            occurring when using $ with global variables.  */
+/*                                                           */
+/*            Fast router used for ParseConstantArguments.   */
+/*                                                           */
+/*            Fixed crash bug when module separator :: is    */
+/*            used but no module name specified.             */
+/*                                                           */
+/*      6.40: Changed restrictions from char * to            */
+/*            CLIPSLexeme * to support strings               */
+/*            originating from sources that are not          */
+/*            statically allocated.                          */
+/*                                                           */
+/*            Pragma once and other inclusion changes.       */
+/*                                                           */
+/*            Added support for booleans with <stdbool.h>.   */
+/*                                                           */
+/*            Removed use of void pointers for specific      */
+/*            data structures.                               */
+/*                                                           */
+/*            ALLOW_ENVIRONMENT_GLOBALS no longer supported. */
+/*                                                           */
+/*            Static constraint checking is always enabled.  */
+/*                                                           */
+/*            UDF redesign.                                  */
+/*                                                           */
+/*            Eval support for run time and bload only.      */
+/*                                                           */
+/*************************************************************/
+
+#include "setup.h"
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <ctype.h>
+
+#include "argacces.h"
+#include "constant.h"
+#include "cstrnchk.h"
+#include "envrnmnt.h"
+#include "expressn.h"
+#include "memalloc.h"
+#include "modulutl.h"
+#include "pprint.h"
+#include "prcdrfun.h"
+#include "prntutil.h"
+#include "router.h"
+#include "scanner.h"
+#include "strngrtr.h"
+
+#if DEFRULE_CONSTRUCT
+#include "network.h"
+#endif
+
+#if DEFGENERIC_CONSTRUCT
+#include "genrccom.h"
+#endif
+
+#if DEFFUNCTION_CONSTRUCT
+#include "dffnxfun.h"
+#endif
+
+#include "exprnpsr.h"
+
+#if (! RUN_TIME)
+
+/***************************************************/
+/* Function0Parse: Parses a function. Assumes that */
+/*   none of the function has been parsed yet.     */
+/***************************************************/
+struct expr *Function0Parse(
+  Environment *theEnv,
+  const char *logicalName)
+  {
+   struct token theToken;
+   struct expr *top;
+
+   /*=================================*/
+   /* All functions begin with a '('. */
+   /*=================================*/
+
+   GetToken(theEnv,logicalName,&theToken);
+   if (theToken.tknType != LEFT_PARENTHESIS_TOKEN)
+     {
+      SyntaxErrorMessage(theEnv,"function calls");
+      return NULL;
+     }
+
+   /*=================================*/
+   /* Parse the rest of the function. */
+   /*=================================*/
+
+   top = Function1Parse(theEnv,logicalName);
+   return(top);
+  }
+
+#endif
+
+/*******************************************************/
+/* Function1Parse: Parses a function. Assumes that the */
+/*   opening left parenthesis has already been parsed. */
+/*******************************************************/
+struct expr *Function1Parse(
+  Environment *theEnv,
+  const char *logicalName)
+  {
+   struct token theToken;
+   struct expr *top;
+
+   /*========================*/
+   /* Get the function name. */
+   /*========================*/
+
+   GetToken(theEnv,logicalName,&theToken);
+   if (theToken.tknType != SYMBOL_TOKEN)
+     {
+      PrintErrorID(theEnv,"EXPRNPSR",1,true);
+      WriteString(theEnv,STDERR,"A function name must be a symbol.\n");
+      return NULL;
+     }
+
+   /*=================================*/
+   /* Parse the rest of the function. */
+   /*=================================*/
+
+   top = Function2Parse(theEnv,logicalName,theToken.lexemeValue->contents);
+   return(top);
+  }
+
+/****************************************************/
+/* Function2Parse: Parses a function. Assumes that  */
+/*   the opening left parenthesis and function name */
+/*   have already been parsed.                      */
+/****************************************************/
+struct expr *Function2Parse(
+  Environment *theEnv,
+  const char *logicalName,
+  const char *name)
+  {
+   struct functionDefinition *theFunction;
+   struct expr *top;
+   bool moduleSpecified = false;
+   unsigned position;
+   CLIPSLexeme *moduleName = NULL, *constructName = NULL;
+#if DEFGENERIC_CONSTRUCT
+   Defgeneric *gfunc;
+#endif
+#if DEFFUNCTION_CONSTRUCT
+   Deffunction *dptr;
+#endif
+
+   /*==============================*/
+   /* Look for a module specifier. */
+   /*==============================*/
+
+   if ((position = FindModuleSeparator(name)) != 0)
+     {
+      moduleName = ExtractModuleName(theEnv,position,name);
+      
+      if (moduleName == NULL)
+        {
+         PrintErrorID(theEnv,"EXPRNPSR",7,true);
+         WriteString(theEnv,STDERR,"Missing module name for '");
+         WriteString(theEnv,STDERR,name);
+         WriteString(theEnv,STDERR,"'.\n");
+         return NULL;
+        }
+
+      constructName = ExtractConstructName(theEnv,position,name,SYMBOL_TYPE);
+      moduleSpecified = true;
+     }
+
+   /*================================*/
+   /* Has the function been defined? */
+   /*================================*/
+
+   theFunction = FindFunction(theEnv,name);
+
+#if DEFGENERIC_CONSTRUCT
+   if (moduleSpecified)
+     {
+      if (ConstructExported(theEnv,"defgeneric",moduleName,constructName) ||
+          GetCurrentModule(theEnv) == FindDefmodule(theEnv,moduleName->contents))
+        { gfunc = FindDefgenericInModule(theEnv,name); }
+      else
+        { gfunc = NULL; }
+     }
+   else
+     { gfunc = LookupDefgenericInScope(theEnv,name); }
+#endif
+
+#if DEFFUNCTION_CONSTRUCT
+#if DEFGENERIC_CONSTRUCT
+   if ((theFunction == NULL)
+        && (gfunc == NULL))
+#else
+   if (theFunction == NULL)
+#endif
+     if (moduleSpecified)
+       {
+        if (ConstructExported(theEnv,"deffunction",moduleName,constructName) ||
+            GetCurrentModule(theEnv) == FindDefmodule(theEnv,moduleName->contents))
+          { dptr = FindDeffunctionInModule(theEnv,name); }
+        else
+          { dptr = NULL; }
+       }
+     else
+       { dptr = LookupDeffunctionInScope(theEnv,name); }
+   else
+     dptr = NULL;
+#endif
+
+   /*=============================*/
+   /* Define top level structure. */
+   /*=============================*/
+
+#if DEFFUNCTION_CONSTRUCT
+   if (dptr != NULL)
+     top = GenConstant(theEnv,PCALL,dptr);
+   else
+#endif
+#if DEFGENERIC_CONSTRUCT
+   if (gfunc != NULL)
+     top = GenConstant(theEnv,GCALL,gfunc);
+   else
+#endif
+   if (theFunction != NULL)
+     top = GenConstant(theEnv,FCALL,theFunction);
+   else
+     {
+      PrintErrorID(theEnv,"EXPRNPSR",3,true);
+      WriteString(theEnv,STDERR,"Missing function declaration for '");
+      WriteString(theEnv,STDERR,name);
+      WriteString(theEnv,STDERR,"'.\n");
+      return NULL;
+     }
+
+   /*=======================================================*/
+   /* Check to see if function has its own parsing routine. */
+   /*=======================================================*/
+
+   PushRtnBrkContexts(theEnv);
+   ExpressionData(theEnv)->ReturnContext = false;
+   ExpressionData(theEnv)->BreakContext = false;
+
+#if DEFGENERIC_CONSTRUCT || DEFFUNCTION_CONSTRUCT
+   if (top->type == FCALL)
+#endif
+     {
+      if (theFunction->parser != NULL)
+        {
+         top = (*theFunction->parser)(theEnv,top,logicalName);
+         PopRtnBrkContexts(theEnv);
+         if (top == NULL) return NULL;
+         if (ReplaceSequenceExpansionOps(theEnv,top->argList,top,FindFunction(theEnv,"(expansion-call)"),
+                                         FindFunction(theEnv,"expand$")))
+           {
+            ReturnExpression(theEnv,top);
+            return NULL;
+           }
+         return(top);
+        }
+     }
+
+   /*========================================*/
+   /* Default parsing routine for functions. */
+   /*========================================*/
+
+   top = CollectArguments(theEnv,top,logicalName);
+   PopRtnBrkContexts(theEnv);
+   if (top == NULL) return NULL;
+
+   if (ReplaceSequenceExpansionOps(theEnv,top->argList,top,FindFunction(theEnv,"(expansion-call)"),
+                                    FindFunction(theEnv,"expand$")))
+     {
+      ReturnExpression(theEnv,top);
+      return NULL;
+     }
+
+   /*============================================================*/
+   /* If the function call uses the sequence expansion operator, */
+   /* its arguments cannot be checked until runtime.             */
+   /*============================================================*/
+
+   if (top->value == FindFunction(theEnv,"(expansion-call)"))
+     { return(top); }
+
+   /*============================*/
+   /* Check for argument errors. */
+   /*============================*/
+
+   if (top->type == FCALL)
+     {
+      if (CheckExpressionAgainstRestrictions(theEnv,top,theFunction,name))
+        {
+         ReturnExpression(theEnv,top);
+         return NULL;
+        }
+     }
+
+#if DEFFUNCTION_CONSTRUCT
+   else if (top->type == PCALL)
+     {
+      if (CheckDeffunctionCall(theEnv,(Deffunction *) top->value,CountArguments(top->argList)) == false)
+        {
+         ReturnExpression(theEnv,top);
+         return NULL;
+        }
+     }
+#endif
+
+   /*========================*/
+   /* Return the expression. */
+   /*========================*/
+
+   return(top);
+  }
+
+/***********************************************************************
+  NAME         : ReplaceSequenceExpansionOps
+  DESCRIPTION  : Replaces function calls which have multifield
+                   references as arguments into a call to a
+                   special function which expands the multifield
+                   into single arguments at run-time.
+                 Multifield references which are not function
+                   arguments are errors
+  INPUTS       : 1) The expression
+                 2) The current function call
+                 3) The address of the internal H/L function
+                    (expansion-call)
+                 4) The address of the H/L function expand$
+  RETURNS      : False if OK, true on errors
+  SIDE EFFECTS : Function call expressions modified, if necessary
+  NOTES        : Function calls which truly want a multifield
+                   to be passed need use only a single-field
+                   refernce (i.e. ? instead of $? - the $ is
+                   being treated as a special expansion operator)
+ **********************************************************************/
+bool ReplaceSequenceExpansionOps(
+  Environment *theEnv,
+  Expression *actions,
+  Expression *fcallexp,
+  void *expcall,
+  void *expmult)
+  {
+   Expression *theExp;
+
+   while (actions != NULL)
+     {
+      if ((ExpressionData(theEnv)->SequenceOpMode == false) &&
+          ((actions->type == MF_VARIABLE) || (actions->type == MF_GBL_VARIABLE)))
+        {
+         if (actions->type == MF_VARIABLE)
+           { actions->type = SF_VARIABLE; }
+         else if (actions->type == MF_GBL_VARIABLE)
+           { actions->type = GBL_VARIABLE; }
+        }
+        
+      if ((actions->type == MF_VARIABLE) || (actions->type == MF_GBL_VARIABLE) ||
+          (actions->value == expmult))
+        {
+         if ((fcallexp->type != FCALL) ? false :
+             (fcallexp->functionValue->sequenceuseok == false))
+           {
+            PrintErrorID(theEnv,"EXPRNPSR",4,false);
+            WriteString(theEnv,STDERR,"$ Sequence operator not a valid argument for function '");
+            WriteString(theEnv,STDERR,fcallexp->functionValue->callFunctionName->contents);
+            WriteString(theEnv,STDERR,"'.\n");
+            return true;
+           }
+         if (fcallexp->value != expcall)
+           {
+            theExp = GenConstant(theEnv,fcallexp->type,fcallexp->value);
+            theExp->argList = fcallexp->argList;
+            theExp->nextArg = NULL;
+            fcallexp->type = FCALL;
+            fcallexp->value = expcall;
+            fcallexp->argList = theExp;
+           }
+         if (actions->value != expmult)
+           {
+            theExp = GenConstant(theEnv,SF_VARIABLE,actions->value);
+            if (actions->type == MF_GBL_VARIABLE)
+              theExp->type = GBL_VARIABLE;
+            actions->argList = theExp;
+            actions->type = FCALL;
+            actions->value = expmult;
+           }
+        }
+      if (actions->argList != NULL)
+        {
+         if ((actions->type == GCALL) ||
+             (actions->type == PCALL) ||
+             (actions->type == FCALL))
+           theExp = actions;
+         else
+           theExp = fcallexp;
+         if (ReplaceSequenceExpansionOps(theEnv,actions->argList,theExp,expcall,expmult))
+           return true;
+        }
+      actions = actions->nextArg;
+     }
+   return false;
+  }
+
+/*************************************************/
+/* PushRtnBrkContexts: Saves the current context */
+/*   for the break/return functions.             */
+/*************************************************/
+void PushRtnBrkContexts(
+  Environment *theEnv)
+  {
+   SavedContexts *svtmp;
+
+   svtmp = get_struct(theEnv,savedContexts);
+   svtmp->rtn = ExpressionData(theEnv)->ReturnContext;
+   svtmp->brk = ExpressionData(theEnv)->BreakContext;
+   svtmp->nxt = ExpressionData(theEnv)->svContexts;
+   ExpressionData(theEnv)->svContexts = svtmp;
+  }
+
+/***************************************************/
+/* PopRtnBrkContexts: Restores the current context */
+/*   for the break/return functions.               */
+/***************************************************/
+void PopRtnBrkContexts(
+  Environment *theEnv)
+  {
+   SavedContexts *svtmp;
+
+   ExpressionData(theEnv)->ReturnContext = ExpressionData(theEnv)->svContexts->rtn;
+   ExpressionData(theEnv)->BreakContext = ExpressionData(theEnv)->svContexts->brk;
+   svtmp = ExpressionData(theEnv)->svContexts;
+   ExpressionData(theEnv)->svContexts = ExpressionData(theEnv)->svContexts->nxt;
+   rtn_struct(theEnv,savedContexts,svtmp);
+  }
+  
+#if (! RUN_TIME)
+
+/**********************/
+/* RestrictionExists: */
+/**********************/
+bool RestrictionExists(
+   const char *restrictionString,
+   int position)
+   {
+    int i = 0, currentPosition = 0;
+
+    if (restrictionString == NULL)
+      { return false; }
+      
+    while (restrictionString[i] != '\0')
+      {
+       if (restrictionString[i] == ';')
+         {
+          if (currentPosition == position) return true;
+          currentPosition++;
+         }
+       i++;
+      }
+
+    if (position == currentPosition) return true;
+
+    return false;
+   }
+
+#endif
+
+/*****************************************************************/
+/* CheckExpressionAgainstRestrictions: Compares the arguments to */
+/*   a function to the set of restrictions for that function to  */
+/*   determine if any incompatibilities exist. If so, the value  */
+/*   true is returned, otherwise false is returned.              */
+/*****************************************************************/
+FunctionArgumentsError CheckExpressionAgainstRestrictions(
+  Environment *theEnv,
+  struct expr *theExpression,
+  struct functionDefinition *theFunction,
+  const char *functionName)
+  {
+   unsigned int j = 1;
+   unsigned short number1, number2;
+   unsigned short argCount;
+   struct expr *argPtr;
+   const char *restrictions;
+   unsigned defaultRestriction2, argRestriction2;
+
+   if (theFunction->restrictions == NULL)
+     { restrictions = NULL; }
+   else
+     { restrictions = theFunction->restrictions->contents; }
+
+   /*=========================================*/
+   /* Count the number of function arguments. */
+   /*=========================================*/
+
+   argCount = CountArguments(theExpression->argList);
+
+   /*======================================*/
+   /* Get the minimum number of arguments. */
+   /*======================================*/
+
+   number1 = theFunction->minArgs;
+
+   /*======================================*/
+   /* Get the maximum number of arguments. */
+   /*======================================*/
+
+   number2 = theFunction->maxArgs;
+
+   /*============================================*/
+   /* Check for the correct number of arguments. */
+   /*============================================*/
+
+   if ((number1 == UNBOUNDED) && (number2 == UNBOUNDED))
+     { /* Any number of arguments allowed. */ }
+   else if (number1 == number2)
+     {
+      if (argCount != number1)
+        {
+         ExpectedCountError(theEnv,functionName,EXACTLY,number1);
+         return FAE_COUNT_ERROR;
+        }
+     }
+   else if (argCount < number1)
+     {
+      ExpectedCountError(theEnv,functionName,AT_LEAST,number1);
+      return FAE_COUNT_ERROR;
+     }
+   else if ((number2 != UNBOUNDED) && (argCount > number2))
+     {
+      ExpectedCountError(theEnv,functionName,NO_MORE_THAN,number2);
+      return FAE_COUNT_ERROR;
+     }
+
+   /*===============================================*/
+   /* Return if there are no argument restrictions. */
+   /*===============================================*/
+
+   if (restrictions == NULL) return FAE_NO_ERROR;
+
+   /*=======================================*/
+   /* Check for the default argument types. */
+   /*=======================================*/
+
+   PopulateRestriction(theEnv,&defaultRestriction2,ANY_TYPE_BITS,restrictions,0);
+
+   /*======================*/
+   /* Check each argument. */
+   /*======================*/
+
+   for (argPtr = theExpression->argList;
+        argPtr != NULL;
+        argPtr = argPtr->nextArg)
+     {
+      PopulateRestriction(theEnv,&argRestriction2,defaultRestriction2,restrictions,j);
+
+      if (CheckArgumentAgainstRestriction(theEnv,argPtr,argRestriction2))
+        {
+         ExpectedTypeError0(theEnv,functionName,j);
+         PrintTypesString(theEnv,STDERR,argRestriction2,true);
+         return FAE_TYPE_ERROR;
+        }
+
+      j++;
+     }
+
+   return FAE_NO_ERROR;
+  }
+
+/*******************************************************/
+/* CollectArguments: Parses and groups together all of */
+/*   the arguments for a function call expression.     */
+/*******************************************************/
+struct expr *CollectArguments(
+  Environment *theEnv,
+  struct expr *top,
+  const char *logicalName)
+  {
+   bool errorFlag;
+   struct expr *lastOne, *nextOne;
+
+   /*========================================*/
+   /* Default parsing routine for functions. */
+   /*========================================*/
+
+   lastOne = NULL;
+
+   while (true)
+     {
+      SavePPBuffer(theEnv," ");
+
+      errorFlag = false;
+      nextOne = ArgumentParse(theEnv,logicalName,&errorFlag);
+
+      if (errorFlag == true)
+        {
+         ReturnExpression(theEnv,top);
+         return NULL;
+        }
+
+      if (nextOne == NULL)
+        {
+         PPBackup(theEnv);
+         PPBackup(theEnv);
+         SavePPBuffer(theEnv,")");
+         return(top);
+        }
+
+      if (lastOne == NULL)
+        { top->argList = nextOne; }
+      else
+        { lastOne->nextArg = nextOne; }
+
+      lastOne = nextOne;
+     }
+  }
+
+/********************************************/
+/* ArgumentParse: Parses an argument within */
+/*   a function call expression.            */
+/********************************************/
+struct expr *ArgumentParse(
+  Environment *theEnv,
+  const char *logicalName,
+  bool *errorFlag)
+  {
+   struct expr *top;
+   struct token theToken;
+
+   /*===============*/
+   /* Grab a token. */
+   /*===============*/
+
+   GetToken(theEnv,logicalName,&theToken);
+
+   /*============================*/
+   /* ')' counts as no argument. */
+   /*============================*/
+
+   if (theToken.tknType == RIGHT_PARENTHESIS_TOKEN)
+     { return NULL; }
+
+   /*================================*/
+   /* Parse constants and variables. */
+   /*================================*/
+
+   if ((theToken.tknType == SF_VARIABLE_TOKEN) || (theToken.tknType == MF_VARIABLE_TOKEN) ||
+       (theToken.tknType == SYMBOL_TOKEN) || (theToken.tknType == STRING_TOKEN) ||
+#if DEFGLOBAL_CONSTRUCT
+       (theToken.tknType == GBL_VARIABLE_TOKEN) ||
+       (theToken.tknType == MF_GBL_VARIABLE_TOKEN) ||
+#endif
+#if OBJECT_SYSTEM
+       (theToken.tknType == INSTANCE_NAME_TOKEN) ||
+#endif
+       (theToken.tknType == FLOAT_TOKEN) || (theToken.tknType == INTEGER_TOKEN))
+     { return(GenConstant(theEnv,TokenTypeToType(theToken.tknType),theToken.value)); }
+
+   /*======================*/
+   /* Parse function call. */
+   /*======================*/
+
+   if (theToken.tknType != LEFT_PARENTHESIS_TOKEN)
+     {
+      PrintErrorID(theEnv,"EXPRNPSR",2,true);
+      WriteString(theEnv,STDERR,"Expected a constant, variable, or expression.\n");
+      *errorFlag = true;
+      return NULL;
+     }
+
+   top = Function1Parse(theEnv,logicalName);
+   if (top == NULL) *errorFlag = true;
+   return(top);
+  }
+
+/************************************************************/
+/* ParseAtomOrExpression: Parses an expression which may be */
+/*   a function call, atomic value (string, symbol, etc.),  */
+/*   or variable (local or global).                         */
+/************************************************************/
+struct expr *ParseAtomOrExpression(
+  Environment *theEnv,
+  const char *logicalName,
+  struct token *useToken)
+  {
+   struct token theToken, *thisToken;
+   struct expr *rv;
+
+   if (useToken == NULL)
+     {
+      thisToken = &theToken;
+      GetToken(theEnv,logicalName,thisToken);
+     }
+   else thisToken = useToken;
+
+   if ((thisToken->tknType == SYMBOL_TOKEN) || (thisToken->tknType == STRING_TOKEN) ||
+       (thisToken->tknType == INTEGER_TOKEN) || (thisToken->tknType == FLOAT_TOKEN) ||
+#if OBJECT_SYSTEM
+       (thisToken->tknType == INSTANCE_NAME_TOKEN) ||
+#endif
+#if DEFGLOBAL_CONSTRUCT
+       (thisToken->tknType == GBL_VARIABLE_TOKEN) ||
+       (thisToken->tknType == MF_GBL_VARIABLE_TOKEN) ||
+#endif
+       (thisToken->tknType == SF_VARIABLE_TOKEN) || (thisToken->tknType == MF_VARIABLE_TOKEN))
+     { rv = GenConstant(theEnv,TokenTypeToType(thisToken->tknType),thisToken->value); }
+   else if (thisToken->tknType == LEFT_PARENTHESIS_TOKEN)
+     {
+      rv = Function1Parse(theEnv,logicalName);
+      if (rv == NULL) return NULL;
+     }
+   else
+     {
+      PrintErrorID(theEnv,"EXPRNPSR",2,true);
+      WriteString(theEnv,STDERR,"Expected a constant, variable, or expression.\n");
+      return NULL;
+     }
+
+   return(rv);
+  }
+
+/*********************************************/
+/* GroupActions: Groups together a series of */
+/*   actions within a progn expression. Used */
+/*   for example to parse the RHS of a rule. */
+/*********************************************/
+struct expr *GroupActions(
+  Environment *theEnv,
+  const char *logicalName,
+  struct token *theToken,
+  bool readFirstToken,
+  const char *endWord,
+  bool functionNameParsed)
+  {
+   struct expr *top, *nextOne, *lastOne = NULL;
+
+   /*=============================*/
+   /* Create the enclosing progn. */
+   /*=============================*/
+
+   top = GenConstant(theEnv,FCALL,FindFunction(theEnv,"progn"));
+
+   /*========================================================*/
+   /* Continue until all appropriate commands are processed. */
+   /*========================================================*/
+
+   while (true)
+     {
+      /*================================================*/
+      /* Skip reading in the token if this is the first */
+      /* pass and the initial token was already read    */
+      /* before calling this function.                  */
+      /*================================================*/
+
+      if (readFirstToken)
+        { GetToken(theEnv,logicalName,theToken); }
+      else
+        { readFirstToken = true; }
+
+      /*=================================================*/
+      /* Look to see if a symbol has terminated the list */
+      /* of actions (such as "else" in an if function).  */
+      /*=================================================*/
+
+      if ((theToken->tknType == SYMBOL_TOKEN) &&
+          (endWord != NULL) &&
+          (! functionNameParsed))
+        {
+         if (strcmp(theToken->lexemeValue->contents,endWord) == 0)
+           { return(top); }
+        }
+
+      /*====================================*/
+      /* Process a function if the function */
+      /* name has already been read.        */
+      /*====================================*/
+
+      if (functionNameParsed)
+        {
+         nextOne = Function2Parse(theEnv,logicalName,theToken->lexemeValue->contents);
+         functionNameParsed = false;
+        }
+
+      /*========================================*/
+      /* Process a constant or global variable. */
+      /*========================================*/
+
+      else if ((theToken->tknType == SYMBOL_TOKEN) || (theToken->tknType == STRING_TOKEN) ||
+          (theToken->tknType == INTEGER_TOKEN) || (theToken->tknType == FLOAT_TOKEN) ||
+#if DEFGLOBAL_CONSTRUCT
+          (theToken->tknType == GBL_VARIABLE_TOKEN) ||
+          (theToken->tknType == MF_GBL_VARIABLE_TOKEN) ||
+#endif
+#if OBJECT_SYSTEM
+          (theToken->tknType == INSTANCE_NAME_TOKEN) ||
+#endif
+          (theToken->tknType == SF_VARIABLE_TOKEN) || (theToken->tknType == MF_VARIABLE_TOKEN))
+        { nextOne = GenConstant(theEnv,TokenTypeToType(theToken->tknType),theToken->value); }
+
+      /*=============================*/
+      /* Otherwise parse a function. */
+      /*=============================*/
+
+      else if (theToken->tknType == LEFT_PARENTHESIS_TOKEN)
+        { nextOne = Function1Parse(theEnv,logicalName); }
+
+      /*======================================*/
+      /* Otherwise replace sequence expansion */
+      /* variables and return the expression. */
+      /*======================================*/
+
+      else
+        {
+         if (ReplaceSequenceExpansionOps(theEnv,top,NULL,
+                                         FindFunction(theEnv,"(expansion-call)"),
+                                         FindFunction(theEnv,"expand$")))
+           {
+            ReturnExpression(theEnv,top);
+            return NULL;
+           }
+
+         return(top);
+        }
+
+      /*===========================*/
+      /* Add the new action to the */
+      /* list of progn arguments.  */
+      /*===========================*/
+
+      if (nextOne == NULL)
+        {
+         theToken->tknType = UNKNOWN_VALUE_TOKEN;
+         ReturnExpression(theEnv,top);
+         return NULL;
+        }
+
+      if (lastOne == NULL)
+        { top->argList = nextOne; }
+      else
+        { lastOne->nextArg = nextOne; }
+
+      lastOne = nextOne;
+
+      PPCRAndIndent(theEnv);
+     }
+  }
+
+/************************/
+/* PopulateRestriction: */
+/************************/
+void PopulateRestriction(
+   Environment *theEnv,
+   unsigned *restriction,
+   unsigned defaultRestriction,
+   const char *restrictionString,
+   unsigned int position)
+   {
+    unsigned int i = 0, currentPosition = 0, valuesRead = 0;
+    char buffer[2];
+
+    *restriction = 0;
+
+    if (restrictionString == NULL)
+      {
+       *restriction = defaultRestriction;
+       return;
+      }
+
+    while (restrictionString[i] != '\0')
+      {
+       char theChar = restrictionString[i];
+
+       switch(theChar)
+         {
+          case ';':
+            if (currentPosition == position) return;
+            currentPosition++;
+            *restriction = 0;
+            valuesRead = 0;
+            break;
+
+          case 'l':
+            *restriction |= INTEGER_BIT;
+            valuesRead++;
+            break;
+
+          case 'd':
+            *restriction |= FLOAT_BIT;
+            valuesRead++;
+            break;
+
+          case 's':
+            *restriction |= STRING_BIT;
+            valuesRead++;
+            break;
+
+          case 'y':
+            *restriction |= SYMBOL_BIT;
+            valuesRead++;
+            break;
+
+          case 'n':
+            *restriction |= INSTANCE_NAME_BIT;
+            valuesRead++;
+            break;
+
+          case 'm':
+            *restriction |= MULTIFIELD_BIT;
+            valuesRead++;
+            break;
+
+          case 'f':
+            *restriction |= FACT_ADDRESS_BIT;
+            valuesRead++;
+            break;
+
+          case 'i':
+            *restriction |= INSTANCE_ADDRESS_BIT;
+            valuesRead++;
+            break;
+
+          case 'e':
+            *restriction |= EXTERNAL_ADDRESS_BIT;
+            valuesRead++;
+            break;
+
+          case 'v':
+            *restriction |= VOID_BIT;
+            valuesRead++;
+            break;
+
+          case 'b':
+            *restriction |= BOOLEAN_BIT;
+            valuesRead++;
+            break;
+
+          case '*':
+            *restriction |= ANY_TYPE_BITS;
+            valuesRead++;
+            break;
+
+          default:
+            buffer[0] = theChar;
+            buffer[1] = 0;
+            WriteString(theEnv,STDERR,"Invalid argument type character ");
+            WriteString(theEnv,STDERR,buffer);
+            WriteString(theEnv,STDERR,"\n");
+            valuesRead++;
+            break;
+         }
+
+       i++;
+      }
+
+    if (position == currentPosition)
+      {
+       if (valuesRead == 0)
+         { *restriction = defaultRestriction; }
+       return;
+      }
+
+    *restriction = defaultRestriction;
+   }
+
+/*******************************************/
+/* ParseConstantArguments: Parses a string */
+/*    into a set of constant expressions.  */
+/*******************************************/
+Expression *ParseConstantArguments(
+  Environment *theEnv,
+  const char *argstr,
+  bool *error)
+  {
+   Expression *top = NULL,*bot = NULL,*tmp;
+   const char *router = "***FNXARGS***";
+   struct token tkn;
+   const char *oldRouter;
+   const char *oldString;
+   long oldIndex;
+
+   *error = false;
+
+   if (argstr == NULL) return NULL;
+
+   /*=============================*/
+   /* Use the fast router bypass. */
+   /*=============================*/
+
+   oldRouter = RouterData(theEnv)->FastCharGetRouter;
+   oldString = RouterData(theEnv)->FastCharGetString;
+   oldIndex  = RouterData(theEnv)->FastCharGetIndex;
+
+   RouterData(theEnv)->FastCharGetRouter = router;
+   RouterData(theEnv)->FastCharGetString = argstr;
+   RouterData(theEnv)->FastCharGetIndex  = 0;
+
+   /*======================*/
+   /* Parse the constants. */
+   /*======================*/
+
+   GetToken(theEnv,router,&tkn);
+   while (tkn.tknType != STOP_TOKEN)
+     {
+      if ((tkn.tknType != SYMBOL_TOKEN) && (tkn.tknType != STRING_TOKEN) &&
+          (tkn.tknType != FLOAT_TOKEN) && (tkn.tknType != INTEGER_TOKEN) &&
+          (tkn.tknType != INSTANCE_NAME_TOKEN))
+        {
+         PrintErrorID(theEnv,"EXPRNPSR",6,false);
+         WriteString(theEnv,STDERR,"Only constant arguments allowed for external function call.\n");
+         ReturnExpression(theEnv,top);
+         *error = true;
+         CloseStringSource(theEnv,router);
+         return NULL;
+        }
+      tmp = GenConstant(theEnv,TokenTypeToType(tkn.tknType),tkn.value);
+      if (top == NULL)
+        top = tmp;
+      else
+        bot->nextArg = tmp;
+      bot = tmp;
+      GetToken(theEnv,router,&tkn);
+     }
+
+   /*===========================================*/
+   /* Restore the old state of the fast router. */
+   /*===========================================*/
+
+   RouterData(theEnv)->FastCharGetRouter = oldRouter;
+   RouterData(theEnv)->FastCharGetString = oldString;
+   RouterData(theEnv)->FastCharGetIndex  = oldIndex;
+
+   /*=======================*/
+   /* Return the arguments. */
+   /*=======================*/
+
+   return(top);
+  }
+
+/************************/
+/* RemoveUnneededProgn: */
+/************************/
+struct expr *RemoveUnneededProgn(
+  Environment *theEnv,
+  struct expr *theExpression)
+  {
+   struct functionDefinition *fptr;
+   struct expr *temp;
+
+   if (theExpression == NULL) return(theExpression);
+
+   if (theExpression->type != FCALL) return(theExpression);
+
+   fptr = theExpression->functionValue;
+
+   if (fptr->functionPointer != PrognFunction)
+     { return(theExpression); }
+
+   if ((theExpression->argList != NULL) &&
+       (theExpression->argList->nextArg == NULL))
+     {
+      temp = theExpression;
+      theExpression = theExpression->argList;
+      temp->argList = NULL;
+      temp->nextArg = NULL;
+      ReturnExpression(theEnv,temp);
+     }
+
+   return(theExpression);
+  }
+