/***************************************************************
 * pblck.c
 * Process a Pascal Block
 *
 *   Copyright (C) 2008-2009 Gregory Nutt. All rights reserved.
 *   Author: Gregory Nutt <spudmonkey@racsa.co.cr>
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 *
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in
 *    the documentation and/or other materials provided with the
 *    distribution.
 * 3. Neither the name NuttX nor the names of its contributors may be
 *    used to endorse or promote products derived from this software
 *    without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
 * COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
 * AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
 * ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 *
 ***************************************************************/

/***************************************************************
 * Included Files
 ***************************************************************/

#include <stdio.h>
#include <string.h>

#include "keywords.h"
#include "pasdefs.h"
#include "ptdefs.h"
#include "pedefs.h"
#include "podefs.h"

#include "pas.h"
#include "pblck.h"
#include "pexpr.h"
#include "pstm.h"
#include "pgen.h"
#include "ptkn.h"
#include "ptbl.h"
#include "pinsn.h"
#include "perr.h"

/***************************************************************
 * Private Definitions
 ***************************************************************/

/* This macro implements a test for:
 * FORM:  unsigned-constant = integer-number | real-number |
 *       character-literal | string-literal | constant-identifier |
 *       'nil'
 */

#define isConstant(x) \
        (  ((x) == tINT_CONST) \
        || ((x) == tBOOLEAN_CONST) \
        || ((x) == tCHAR_CONST) \
        || ((x) == tREAL_CONST) \
        || ((x) == sSCALAR_OBJECT))

#define isIntAligned(x) (((x) & (sINT_SIZE-1)) == 0)
#define intAlign(x)     (((x) + (sINT_SIZE-1)) & (~(sINT_SIZE-1)))

/***************************************************************
 * Private Function Prototypes
 ***************************************************************/

static void   pas_DeclareLabel          (void);
static void   pas_DeclareConst          (void);
static STYPE *pas_DeclareType           (char *typeName);
static STYPE *pas_DeclareOrdinalType    (char *typeName);
static STYPE *pas_DeclareVar            (void);
static void   pas_DeclareFile           (void);
static void   pas_ProcedureDeclaration  (void);
static void   pas_FunctionDeclaration   (void);

static void   pas_SetTypeSize           (STYPE *typePtr, bool allocate);
static STYPE *pas_TypeIdentifier        (bool allocate);
static STYPE *pas_TypeDenoter           (char *typeName, bool allocate);
static STYPE *pas_NewComplexType        (char *typeName);
static STYPE *pas_NewOrdinalType        (char *typeName);
static STYPE *pas_OrdinalTypeIdentifier (bool allocate);
static STYPE *pas_GetArrayType          (void);
static STYPE *pas_DeclareRecord         (char *recordName);
static STYPE *pas_DeclareField          (STYPE *recordPtr);
static STYPE *pas_DeclareParameter      (bool pointerType);
static bool   pas_IntAlignRequired      (STYPE *typePtr);

/***************************************************************
 * Private Global Variables
 ***************************************************************/

static int32_t g_nParms;
static int32_t g_dwVarSize;                      

/***************************************************************
 * Public Functions
 ***************************************************************/
/* Process BLOCK.  This function implements:
 *
 * block = declaration-group compound-statement
 *
 * Where block can appear in the followinging:
 *
 * function-block = block
 * function-declaration =
 *     function-heading ';' directive |
 *     function-heading ';' function-block
 *
 * procedure-block = block
 * procedure-declaration =
 *     procedure-heading ';' directive |
 *     procedure-heading ';' procedure-block
 *
 * program = program-heading ';' [ uses-section ] block '.'
 */

void block()
{
  uint16_t beginLabel   = ++label;     /* BEGIN label */
  int32_t saveDStack   = dstack;      /* Save DSEG size */
  char   *saveStringSP = stringSP;    /* Save top of string stack */
  int16_t saveNSym     = nsym;        /* Save top of symbol table */
  int16_t saveNConst   = nconst;      /* Save top of constant table */
  register int16_t i;

  TRACE(lstFile,"[block]");

  /* When we enter block at level zero, then we must be at the
   * entry point to the program.  Save the entry point label
   * in the POFF file.
   */

  if ((level == 0) && (FP0->kind == eIsProgram))
    {
      poffSetEntryPoint(poffHandle, label);
    }

  /* Init size of the new DSEG */

  dstack = 0;

  /* FORM: block = declaration-group compound-statement
   * Process the declaration-group
   *
   * declaration-group =
   *     label-declaration-group |
   *     constant-definition-group |
   *     type-definition-group |
   *     variable-declaration-group |
   *     function-declaration  |
   *     procedure-declaration
   */

  declarationGroup(beginLabel);

  /* Process the compound-statement
   *
   * FORM: compound-statement = 'begin' statement-sequence 'end'
   */

  /* Verify that the compound-statement begins with BEGIN */

  if (token != tBEGIN)
    {
      error (eBEGIN);
    }

  /* It may be necessary to jump around some local functions to
   * get to the main body of the block.  If any jumps are generated,
   * they will come to the beginLabel emitted here.
   */

  pas_GenerateDataOperation(opLABEL, (int32_t)beginLabel);

  /* Since we don't know for certain how we got here, invalidate
   * the level stack pointer (LSP).  This is, of course, only 
   * meaningful on architectures that implement an LSP.
   */

  pas_InvalidateCurrentStackLevel();

  /* Then emit the compoundStatement itself */

  if (dstack)
    {
      pas_GenerateDataOperation(opINDS, (int32_t)dstack);
    }

  compoundStatement();

  if (dstack)
    {
      pas_GenerateDataOperation(opINDS, -(int32_t)dstack);
    }

  /* Make sure all declared labels were defined in the block */

  verifyLabels(saveNSym);

  /* Re-initialize file table -- clear files defined in this level */

  for (i = 0; i <= MAX_FILES; i++)
    {
      if ((files [i].defined) && (files [i].flevel >= level)) {
        files [i].defined = 0;
        files [i].flevel  = 0;
        files [i].ftype   = 0;
        files [i].faddr   = 0;
        files [i].fsize   = 0;
      }
    }

  /* "Pop" declarations local to this block */

  dstack   = saveDStack;               /* Restore old DSEG size */
  stringSP = saveStringSP;             /* Restore top of string stack */
  nsym     = saveNSym;                 /* Restore top of symbol table */
  nconst   = saveNConst;               /* Restore top of constant table */
}

/***************************************************************/
/* Process declarative-part */

void declarationGroup(int32_t beginLabel)
{
  int16_t notFirst   = 0;             /* Init count of nested procs */
  int16_t saveNSym   = nsym;          /* Save top of symbol table */
  int16_t saveNConst = nconst;        /* Save top of constant table */

  TRACE(lstFile,"[declarationGroup]");

  /* FORM: declarative-part = { declaration-group }
   * FORM: declaration-group =
   *       label-declaration-group | constant-definition-group |
   *       type-definition-group   | variable-declaration-group |
   *       function-declaration    | procedure-declaration
   */

  /* Process label-declaration-group.
   * FORM: label-declaration-group = 'label' label { ',' label } ';'
   */

  if (token == tLABEL) pas_DeclareLabel();

  /* Process constant-definition-group.
   * FORM: constant-definition-group =
   *       'const' constant-definition ';' { constant-definition ';' }
   */

  if (token == tCONST)
    {
      const_strt = saveNConst;        /* Limit search to present level */
      getToken();                     /* Get identifier */
      const_strt = 0;

      /* Process constant-definition.
       * FORM: constant-definition = identifier '=' constant
       */

      constantDefinitionGroup();
    }

  /* Process type-definition-group
   * FORM: type-definition-group =
   *       'type' type-definition ';' { type-definition ';' }
   */

  if (token == tTYPE)
    {
      const_strt = saveNConst;        /* Limit search to present level */
      sym_strt   = saveNSym;
      getToken();                     /* Get identifier */
      const_strt = 0;
      sym_strt   = 0;

      /* Process the type-definitions in the type-definition-group
       * FORM: type-definition = identifier '=' type-denoter
       */

      typeDefinitionGroup();
    }

  /* Process variable-declaration-group
   * FORM: variable-declaration-group =
   *       'var' variable-declaration { ';' variable-declaration }
   */

  if (token == tVAR)
    {
      const_strt = saveNConst;        /* Limit search to present level */
      sym_strt   = saveNSym;
      getToken();                     /* Get identifier */
      const_strt = 0;
      sym_strt   = 0;

      /* Process the variable declarations
       * FORM: variable-declaration = identifier-list ':' type-denoter
       * FORM: identifier-list = identifier { ',' identifier }
       */

      variableDeclarationGroup();
    }

  /* Process procedure/function-declaration(s) if present 
   * FORM: function-declaration =
   *       function-heading ';' directive |
   *       function-heading ';' function-block
   * FORM: procedure-declaration =
   *       procedure-heading ';' directive |
   *       procedure-heading ';' procedure-block
   *
   * NOTE:  a JMP to the executable body of this block is generated
   * if there are nested procedures and this is not level=0
   */

  for (;;)
    {
      /* FORM: function-heading =
       *       'function' identifier [ formal-parameter-list ] ':' result-type
       */

      if (token == tFUNCTION)
        {
          /* Check if we need to put a jump around the function */

          if ((beginLabel > 0) && !(notFirst) && (level > 0))
            {
              pas_GenerateDataOperation(opJMP, (int32_t)beginLabel);
            }

          /* Get the procedure-identifier */

          const_strt = saveNConst;    /* Limit search to present level */
          sym_strt   = saveNSym;
          getToken();                 /* Get identifier */
          const_strt = 0;
          sym_strt   = 0;

          /* Define the function */

          pas_FunctionDeclaration();
          notFirst++;                 /* No JMP next time */
        }

      /* FORM: procedure-heading =
       *       'procedure' identifier [ formal-parameter-list ]
       */

      else if (token == tPROCEDURE)
        {
          /* Check if we need to put a jump around the function */

          if ((beginLabel > 0) && !(notFirst) && (level > 0))
            {
              pas_GenerateDataOperation(opJMP, (int32_t)beginLabel);
            }

          /* Get the procedure-identifier */

          const_strt = saveNConst;    /* Limit search to present level */
          sym_strt   = saveNSym;
          getToken();                 /* Get identifier */
          const_strt = 0;
          sym_strt   = 0;

          /* Define the procedure */

          pas_ProcedureDeclaration();
          notFirst++;                 /* No JMP next time */
        }
      else break;
    }
}

/***************************************************************/

void constantDefinitionGroup(void)
{
  /* Process constant-definition-group.
   * FORM: constant-definition-group =
   *       'const' constant-definition ';' { constant-definition ';' }
   * FORM: constant-definition = identifier '=' constant
   *
   * On entry, token should point to the identifier of the first
   * constant-definition.
   */

  for (;;)
    {
      if (token == tIDENT)
        {
          pas_DeclareConst();
          if (token != ';') break;
          else getToken();
        }
      else break;
    }
}

/***************************************************************/

void typeDefinitionGroup(void)
{
  char   *typeName;

  /* Process type-definition-group
   * FORM: type-definition-group =
   *       'type' type-definition ';' { type-definition ';' }
   * FORM: type-definition = identifier '=' type-denoter
   *
   * On entry, token refers to the first identifier (if any) of
   * the type-definition list.
   */

  for (;;)
    {
      if (token == tIDENT)
        {
          /* Save the type identifier */

          typeName = tkn_strt;
          getToken();

          /* Verify that '=' follows the type identifier */

          if (token != '=') error (eEQ);
          else getToken();

          (void)pas_DeclareType(typeName);
          if (token != ';') break;
          else getToken();

        }
      else break;
    }
}

/***************************************************************/

void variableDeclarationGroup(void)
{
   /* Process variable-declaration-group
    * FORM: variable-declaration-group =
    *       'var' variable-declaration { ';' variable-declaration }
    * FORM: variable-declaration = identifier-list ':' type-denoter
    * FORM: identifier-list = identifier { ',' identifier }
    *
    * Only entry, token holds the first identfier (if any) of the
    * variable-declaration list.
    */

  for (;;)
    {
      if (token == tIDENT)
        {
          (void)pas_DeclareVar();
          if (token != ';') break;
          else getToken();
        }
      else if (token == sFILE)
        {
          pas_DeclareFile();
          if (token != ';') break;
          else getToken();
        }
      else break;
    }
}

/***************************************************************/
/* Process formal-parameter-list */

int16_t formalParameterList(STYPE *procPtr)
{
  int16_t parameterOffset;
  int16_t i;
  bool    pointerType;

  TRACE(lstFile,"[formalParameterList]");

  /* FORM: formal-parameter-list =
   *       '(' formal-parameter-section { ';' formal-parameter-section } ')'
   * FORM: formal-parameter-section =
   *       value-parameter-specification |
   *       variable-parameter-specification |
   *       procedure-parameter-specification |
   *       function-parameter-specification
   * FORM: value-parameter-specification =
   *       identifier-list ':' type-identifier
   * FORM: variable-parameter-specification =
   *       'var' identifier-list ':' type-identifier
   *
   * On entry token should refer to the '(' at the beginning of the
   * (optional) formal parameter list.
   */

  g_nParms = 0;

  /* Check if the formal-parameter-list is present.  It is optional in
   * all contexts in which this function is called.
   */

  if (token == '(')
    {
      /* Process each formal-parameter-section */

      do
        {
          getToken();

          /* Check for variable-parameter-specification */

          if (token == tVAR)
            {
              pointerType = 1;
              getToken();
            } 
          else pointerType = 0;

          /* Process the common part of the variable-parameter-specification
           * and the value-parameter specification.
           * NOTE that procedure-parameter-specification and
           * function-parameter-specification are not yet supported.
           */

          (void)pas_DeclareParameter(pointerType);

        }
      while (token == ';');

      /* Verify that the formal parameter list terminates with a
       * right parenthesis.
       */

      if (token != ')') error (eRPAREN);
      else getToken();

    }

  /* Save the number of parameters found in sPROC/sFUNC symbol table entry */

  procPtr->sParm.p.nParms = g_nParms;

  /* Now, calculate the parameter offsets from the size of each parameter */

  parameterOffset = -sRETURN_SIZE;
  for (i = g_nParms; i > 0; i--)
    {
      /* The offset to the next parameter is the offset to the previous
       * parameter minus the size of the new parameter (aligned to
       * multiples of size of INTEGER).
       */

      parameterOffset -= procPtr[i].sParm.v.size;
      parameterOffset  = intAlign(parameterOffset);
      procPtr[i].sParm.v.offset = parameterOffset;
    }

  return parameterOffset;
}

/***************************************************************
 * Private Functions
 ***************************************************************/
/* Process LABEL block */

static void pas_DeclareLabel(void)
{
   char   *labelname;                   /* Label symbol table name */

   TRACE(lstFile,"[pas_DeclareLabel]");

   /* FORM:  LABEL <integer>[,<integer>[,<integer>][...]]]; */

   do
     {
       getToken();
       if ((token == tINT_CONST) && (tknInt >= 0))
         {
           labelname = stringSP;
           (void)sprintf (labelname, "%ld", tknInt);
           while (*stringSP++);
           (void)addLabel(labelname, ++label);
           getToken();
         }
       else error(eINTCONST);
     }
   while (token == ',');

   if (token != ';') error (eSEMICOLON);
   else getToken();
}

/***************************************************************/
/* Process constant definition:
 * FORM: constant-definition = identifier '=' constant
 * FORM: constant = [ sign ] integer-number |
 *                  [ sign ] real-number |
 *                  [ sign ] constant-identifier |
 *                           character-literal |
 *                           string-literal
 */

static void pas_DeclareConst(void)
{
  char *const_name;

  TRACE(lstFile,"[pas_DeclareConst]");

  /* FORM:  <identifier> = <numeric constant|string>
   * NOTE:  Only integer constants are supported
   */

  /* Save the name of the constant */

  const_name = tkn_strt;

  /* Verify that the name is followed by '=' and get the
   * following constant value.
   */

  getToken();
  if (token != '=') error (eEQ);
  else getToken();

  /* Handle constant expressions */

  constantExpression();

  /* Add the constant to the symbol table based on the type of
   * the constant found following the '= [ sign ]'
   */

  switch (constantToken)
    {
    case tINT_CONST :
    case tCHAR_CONST :
    case tBOOLEAN_CONST :
    case sSCALAR_OBJECT :
      (void)addConstant(const_name, constantToken, &constantInt, NULL);
      break;

    case tREAL_CONST :
      (void)addConstant(const_name, constantToken, (int32_t*)&constantReal, NULL);
      break;

    case tSTRING_CONST :
      {
        uint32_t offset = poffAddRoDataString(poffHandle, constantStart);
        (void)addStringConst(const_name, offset, strlen(constantStart));
      }
      break;

    default :
      error(eINVCONST);
    }
}

/***************************************************************/
/* Process TYPE declaration */

static STYPE *pas_DeclareType(char *typeName)
{
  STYPE *typePtr;

  TRACE(lstFile,"[pas_DeclareType]");

  /* This function processes the type-denoter in
   * FORM: type-definition = identifier '=' type-denoter
   * FORM: array-type = 'array' '[' index-type-list ']' 'of' type-denoter
   */

  /* FORM: type-denoter = type-identifier | new-type
   * FORM: new-type = new-ordinal-type | new-complex-type
   */

  typePtr = pas_NewComplexType(typeName);
  if (typePtr == NULL)
    {
      /* Check for Simple Types */

      typePtr = pas_DeclareOrdinalType(typeName);
      if (typePtr == NULL)
        {
          error(eINVTYPE);
        }
    }

  return typePtr;
}

/***************************************************************/
/* Process a simple TYPE declaration */

static STYPE *pas_DeclareOrdinalType(char *typeName)
{
  STYPE *typePtr;
  STYPE *typeIdPtr;

  /* Declare a new ordinal type */

  typePtr = pas_NewOrdinalType(typeName);

  /* Otherwise, declare a type equivalent to a previously defined type
   * NOTE: the following logic is incomplete.  Its is only good for
   * sKind == sType
   */

  if (typePtr == NULL)
     {
       typeIdPtr = pas_TypeIdentifier(1);
       if (typeIdPtr)
         {
           typePtr = addTypeDefine(typeName, typeIdPtr->sParm.t.type,
                                    g_dwVarSize, typeIdPtr);
         }
     }

   return typePtr;
}

/***************************************************************/
/* Process VAR declaration */

static STYPE *pas_DeclareVar(void)
{
  STYPE *varPtr;
  STYPE *typePtr;
  char  *varName;

  TRACE(lstFile,"[pas_DeclareVar]");

  /* FORM: variable-declaration = identifier-list ':' type-denoter
   * FORM: identifier-list = identifier { ',' identifier }
   */

  typePtr  = NULL;

  /* Save the current identifier */

  varName = tkn_strt;
  getToken();

  /* A comma indicates that there is another indentifier int the
   * identifier-list
   */

  if (token == ',')
    {
      /* Yes ..Process the next identifer in the indentifier list
       * via recursion
       */

      getToken();
      if (token != tIDENT) error(eIDENT);
      else typePtr = pas_DeclareVar();
    }
  else
    {
      /* No.. verify that the identifer-list is followed by ';' */

      if (token != ':') error(eCOLON);
      else getToken();

      /* Process the type-denoter */

      typePtr = pas_TypeDenoter(varName, 1);
      if (typePtr == NULL)
        {
          error(eINVTYPE);
        }
    }

  if (typePtr)
    {
      uint8_t varType = typePtr->sParm.t.type;

      /* Determine if alignment to INTEGER boundaries is necessary */

      if ((!isIntAligned(dstack)) && (pas_IntAlignRequired(typePtr)))
        dstack = intAlign(dstack);

      /* Add the new variable to the symbol table */

      varPtr = addVariable(varName, varType, dstack, g_dwVarSize, typePtr);

      /* If the variable is declared in an interface section at level zero,
       * then it is a candidate to imported or exported.
       */

      if ((!level) && (FP->section == eIsInterfaceSection))
        {
          /* Are we importing or exporting the interface?
           *
           * PROGRAM EXPORTS:
           * If we are generating a program binary (i.e., FP0->kind ==
           * eIsProgram) then the variable memory allocation must appear
           * on the initial stack allocation; therefore the variable
           * stack offset myst be exported by the program binary.
           *
           * UNIT IMPORTS:
           * If we are generating a unit binary (i.e., FP0->kind ==
           * eIsUnit), then we are importing the level 0 stack offset
           * from the main program.
           */

          if (FP0->kind == eIsUnit)
            {
              /* Mark the symbol as external and replace the absolute
               * offset with this relative offset.
               */

              varPtr->sParm.v.flags  |= SVAR_EXTERNAL;
              varPtr->sParm.v.offset  = dstack - FP->dstack;

              /* IMPORT the symbol; assign an offset relative to
               * the dstack at the beginning of this file
               */
 
              pas_GenerateStackImport(varPtr);
            }
          else /* if (FP0->kind == eIsProgram) */
            {
              /* EXPORT the symbol */

              pas_GenerateStackExport(varPtr);
            }
        }

      /* In any event, bump the stack offset to include space for 
       * this new symbol.  The 'bumped' stack offset will be the
       * offset for the next variable that is declared.
       */

      dstack += g_dwVarSize;
    }

  return typePtr;
}

/***************************************************************/
/* Process VAR FILE OF declaration */

static void pas_DeclareFile(void)
{
   int16_t fileNumber = tknPtr->sParm.fileNumber;
   STYPE *filePtr;

   TRACE(lstFile,"[pas_DeclareFile]");

   /* FORM:  <file identifier> : FILE OF <type> */
   /* OR:    <file identifier> : <FILE OF type identifier> */
   if (!(fileNumber)) error(eINVFILE);
   else if (files [fileNumber].defined) error(eDUPFILE);
   else {

     /* Skip over the <file identifier> */
     getToken();

     /* Verify that a colon follows the <file identifier> */
     if (token != ':') error (eCOLON);
     else getToken();

     /* Make sure that the data stack is aligned to INTEGER boundaries */
     dstack = intAlign(dstack);

     /* FORM:  <file identifier> : FILE OF <type> */
     if (token == sFILE_OF) {

       files[fileNumber].defined = -1;
       files[fileNumber].flevel  = level;
       files[fileNumber].ftype   = tknPtr->sParm.t.type;
       files[fileNumber].faddr   = dstack;
       files[fileNumber].fsize   = tknPtr->sParm.t.asize;
       dstack += (tknPtr->sParm.t.asize);
       getToken();

     }

     /* FORM:  <file identifier> : <FILE OF type identifier> */
     else {
       if (token != tFILE) error (eFILE);
       else getToken();
       if (token != tOF) error (eOF);
       else getToken();

       filePtr = pas_TypeIdentifier(1);
       if (filePtr) {

         files[fileNumber].defined = -1;
         files[fileNumber].flevel  = level;
         files[fileNumber].ftype   = filePtr->sParm.t.type;
         files[fileNumber].faddr   = dstack;
         files[fileNumber].fsize   = g_dwVarSize;
         dstack += g_dwVarSize;

       }
     }
   }
}

/***************************************************************/
/* Process Procedure Declaration Block */

static void pas_ProcedureDeclaration(void)
{
   uint16_t procLabel = ++label;
   char    *saveStringSP;
   STYPE   *procPtr;
   register int i;

   TRACE(lstFile,"[pas_ProcedureDeclaration]");

   /* FORM: procedure-declaration =
    *       procedure-heading ';' directive |
    *       procedure-heading ';' procedure-block
    * FORM: procedure-heading =
    *       'procedure' identifier [ formal-parameter-list ]
    * FORM: procedure-identifier = identifier
    *
    * On entry, token refers to token AFTER the 'procedure' reserved
    * word.
    */

   /* Process the procedure-heading */

   if (token != tIDENT)
     {
       error (eIDENT);
       return;
     }

   /* Add the procedure to the symbol table */

   procPtr = addProcedure(tkn_strt, sPROC, procLabel, 0, NULL);

   /* Save the string stack pointer so that we can release all
    * formal parameter strings later.  Then get the next token.
    */

   saveStringSP = stringSP;
   getToken();

   /* NOTE:  The level associated with the PROCEDURE symbol is the level
    * At which the procedure was declared.  Everything declare within the
    * PROCEDURE is at the next level
    */

   level++;

   /* Process parameter list */

   (void)formalParameterList(procPtr);

   if (token !=  ';') error (eSEMICOLON);
   else getToken();

   /* If we are here then we know that we are either in a program file
    * or the 'implementation' part of a unit file (see punit.c -- At present,
    * the procedure declarations of the 'interface' section of a unit file
    * follow a different path).  In the latter case (only), we should export
    * every procedure declared at level zero.
    */

   if ((level == 1) && (FP->kind == eIsUnit))
     {
       /* EXPORT the procedure symbol. */

       pas_GenerateProcExport(procPtr);
     }

   /* Save debug information about the procedure */

   pas_GenerateDebugInfo(procPtr, 0);

   /* Process block */

   pas_GenerateDataOperation(opLABEL, (int32_t)procLabel);
   block();

   /* Destroy formal parameter names */

   for (i = 1; i <= procPtr->sParm.p.nParms; i++)
     {
       procPtr[i].sName = NULL;
     }

   stringSP = saveStringSP;

   /* Generate exit from procedure */

   pas_GenerateSimple(opRET);
   level--;

   /* Verify that END terminates with a semicolon */

   if (token !=  ';') error (eSEMICOLON);
   else getToken();
}

/***************************************************************/
/* Process Function Declaration Block */

static void pas_FunctionDeclaration(void)
{
   uint16_t funcLabel = ++label;
   int16_t parameterOffset;
   char    *saveStringSP;
   STYPE   *funcPtr;
   STYPE   *valPtr;
   STYPE   *typePtr;
   char    *funcName;
   register int i;

   TRACE(lstFile,"[pas_FunctionDeclaration]");

   /* FORM: function-declaration =
    *       function-heading ';' directive |
    *       function-heading ';' function-block
    * FORM: function-heading =
    *       'function' function-identifier [ formal-parameter-list ]
    *       ':' result-type
    *
    * On entry token should lrefer to the function-identifier.
    */

   /* Verify function-identifier */

   if (token != tIDENT)
     {
       error (eIDENT);
       return;
     }

   funcPtr = addProcedure(tkn_strt, sFUNC, funcLabel, 0, NULL);

   /* NOTE:  The level associated with the FUNCTION symbol is the level
    * At which the procedure was declared.  Everything declare within the
    * PROCEDURE is at the next level
    */

   level++;

   /* Save the string stack pointer so that we can release all
    * formal parameter strings later.  Then get the next token.
    */

   funcName = tkn_strt;
   saveStringSP = stringSP;
   getToken();

   /* Process parameter list */

   parameterOffset = formalParameterList(funcPtr);

   /* Verify that the parameter list is followed by a colon */

   if (token !=  ':') error (eCOLON);
   else getToken();

   /* Declare the function return value variable.  This variable has
    * the same name as the function itself.  We fill the variable
    * symbol descriptor with bogus information now (but we fix it
    * below).
    */

   valPtr  = addVariable(funcName, sINT, 0, sINT_SIZE, NULL);

   /* Get function type, return value type/size and offset to return value */

   typePtr = pas_TypeIdentifier(0);
   if (typePtr) {

     /* The offset to the return value is the offset to the last
      * parameter minus the size of the return value (aligned to
      * multiples of size of INTEGER).
      */

     parameterOffset        -= g_dwVarSize;
     parameterOffset         = intAlign(parameterOffset);

     /* Save the TYPE for the function return value local variable */

     valPtr->sKind           = typePtr->sParm.t.rtype;
     valPtr->sParm.v.offset  = parameterOffset;
     valPtr->sParm.v.size    = g_dwVarSize;
     valPtr->sParm.v.parent  = typePtr;

     /* Save the TYPE for the function */

     funcPtr->sParm.p.parent = typePtr;

     /* If we are here then we know that we are either in a program file
      * or the 'implementation' part of a unit file (see punit.c -- At present,
      * the function declarations of the 'interface' section of a unit file
      * follow a different path).  In the latter case (only), we should export
      * every function declared at level zero.
      */

     if ((level == 1) && (FP->kind == eIsUnit))
       {
         /* EXPORT the function symbol. */

         pas_GenerateProcExport(funcPtr);
       }
   }
   else
     error(eINVTYPE);

   /* Save debug information about the function */

   pas_GenerateDebugInfo(funcPtr, g_dwVarSize);

   /* Process block */

   if (token !=  ';') error (eSEMICOLON);
   else getToken();

   pas_GenerateDataOperation(opLABEL, (int32_t)funcLabel);
   block();

   /* Destroy formal parameter names and the function return value name */

   for (i = 1; i <= funcPtr->sParm.p.nParms; i++)
     {
       funcPtr[i].sName = ((char *) NULL);
     }

   valPtr->sName = ((char *) NULL);
   stringSP = saveStringSP;

   /* Generate exit from procedure/function */

   pas_GenerateSimple(opRET);
   level--;

   /* Verify that END terminates with a semicolon */

   if (token !=  ';') error (eSEMICOLON);
   else getToken();
}

/***************************************************************/
/* Determine the size value to use with this type */

static void pas_SetTypeSize(STYPE *typePtr, bool allocate)
{
  TRACE(lstFile,"[pas_SetTypeSize]");

  /* Check for type-identifier */

  g_dwVarSize = 0;

  if (typePtr != NULL)
    {
      /* If allocate is true, then we want to return the size of
       * the type that we would use if we are going to allocate
       * an instance on the stack.
       */

      if (allocate)
        {
          /* Could it be a storage size value (such as is used for
           * the enhanced pascal string type?).  In an weak attempt to
           * be compatible with everyone in the world, we will allow
           * either '[]' or '()' to delimit the size specification.
           */

          if (((token == '[') || (token == '(')) &&
              ((typePtr->sParm.t.flags & STYPE_VARSIZE) != 0))
            {
              uint16_t term_token;
              uint16_t errcode;

              /* Yes... we need to parse the size from the input stream.
               * First, determine which token will terminate the size
               * specification.
               */

              if (token == '(')
                {
                  term_token = ')';    /* Should end with ')' */
                  errcode = eRPAREN;   /* If not, this is the error */
                }
              else
                {
                  term_token = ']';    /* Should end with ']' */
                  errcode = eRBRACKET; /* If not, this is the error */
                }

              /* Now, parse the size specification */

              /* We expect the size to consist of a single integer constant.
               * We should support any constant integer expression, but this
               * has not yet been implemented.
               */

              getToken();
              if (token != tINT_CONST) error(eINTCONST);
              /* else if (tknInt <= 0) error(eINVCONST); see below */
              else if (tknInt <= 2) error(eINVCONST);
              else
                {
                  /* Use the value of the integer constant for the size
                   * the allocation.  NOTE:  There is a problem here in
                   * that for the sSTRING type, it wants the first 2 bytes
                   * for the string length.  This means that the actual
                   * length is real two less than the specified length.
                   */

                  g_dwVarSize = tknInt;
                }

              /* Verify that the correct token terminated the size
               * specification.  This could be either ')' or ']'
               */

              getToken();
              if (token != term_token) error(errcode);
              else getToken();
            }
          else
            {
              /* Return the fixed size of the allocated instance of
               * this type */

              g_dwVarSize = typePtr->sParm.t.asize;
            }
        }

      /* If allocate is false, then we want to return the size of
       * the type that we would use if we are going to refer to
       * a reference on the stack.  This is really non-standard
       * and is handle certain optimatizations where we cheat and
       * pass some types by reference rather than by value.  The
       * enhanced pascal string type is the only example at present.
       */

      else
        {
          /* Return the size to a clone, reference to an instance */

          g_dwVarSize = typePtr->sParm.t.rsize;
        }
    }
}

/***************************************************************/
/* Verify that the next token is a type identifer
 * NOTE:  This function modifies the global variable g_dwVarSize
 * as a side-effect
 */

static STYPE *pas_TypeIdentifier(bool allocate)
{
  STYPE *typePtr = NULL;

  TRACE(lstFile,"[pas_TypeIdentifier]");

  /* Check for type-identifier */

  if (token == sTYPE)
    {
      /* Return a reference to the type token. */

      typePtr = tknPtr;
      getToken();

      /* Return the size value associated with this type */

      pas_SetTypeSize(typePtr, allocate);
    }

  return typePtr;
}

/***************************************************************/

static STYPE *pas_TypeDenoter(char *typeName, bool allocate)
{
  STYPE *typePtr;

  TRACE(lstFile,"[pas_TypeDenoter]");

  /* FORM: type-denoter = type-identifier | new-type
   *
   * Check for type-identifier
   */

  typePtr = pas_TypeIdentifier(allocate);
  if (typePtr != NULL)
    {
      /* Return the type identifier */

      return typePtr;
    }

  /* Check for new-type
   * FORM: new-type = new-ordinal-type | new-complex-type
   */

  /* Check for new-complex-type */

  typePtr = pas_NewComplexType(typeName);
  if (typePtr == NULL)
    {
      /* Check for new-ordinal-type */

      typePtr = pas_NewOrdinalType(typeName);
    }

  /* Return the size value associated with this type */

  pas_SetTypeSize(typePtr, allocate);

  return typePtr;
}

/***************************************************************/
/* Declare is new ordinal type */

static STYPE *pas_NewOrdinalType(char *typeName)
{
  STYPE *typePtr = NULL;

  /* Declare a new-ordinal-type
   * FORM: new-ordinal-type = enumerated-type | subrange-type
   */

  /* FORM: enumerated-type = '(' enumerated-constant-list ')' */

   if (token == '(')
     {
       int32_t nObjects;
       nObjects = 0;
       typePtr = addTypeDefine(typeName, sSCALAR, sINT_SIZE, NULL);

       /* Now declare each instance of the scalar */

       do {
         getToken();
         if (token != tIDENT) error(eIDENT);
         else
           {
             (void)addConstant(tkn_strt, sSCALAR_OBJECT, &nObjects, typePtr);
             nObjects++;
             getToken();
           }
       } while (token == ',');

       /* Save the number of objects associated with the scalar type (the
        * maximum ORD is nObjects - 1). */

       typePtr->sParm.t.maxValue = nObjects - 1;

       if (token != ')') error(eRPAREN);
       else getToken();

     }

   /* Declare a new subrange type
    * FORM: subrange-type = constant '..' constant
    * FORM: constant =
    *    [ sign ] integer-number |  [ sign ] real-number |
    *    [ sign ] constant-identifier | character-literal | string-literal
    *
    * Case 1: <constant> is INTEGER
    */

   else if (token == tINT_CONST)
     {
       /* Create the new INTEGER subrange type */

       typePtr = addTypeDefine(typeName, sSUBRANGE, sINT_SIZE, NULL);
       typePtr->sParm.t.subType  = sINT;
       typePtr->sParm.t.minValue = tknInt;
       typePtr->sParm.t.maxValue = MAXINT;

       /* Verify that ".." separates the two constants */

       getToken();
       if (token != tSUBRANGE) error(eSUBRANGE);
       else getToken();

       /* Verify that the ".." is following by an INTEGER constant */

       if ((token != tINT_CONST) || (tknInt < typePtr->sParm.t.minValue))
         error(eSUBRANGETYPE);
       else
         {
           typePtr->sParm.t.maxValue = tknInt;
           getToken();
         }
     }

   /* Case 2: <constant> is CHAR */

   else if (token == tCHAR_CONST)
     {
       /* Create the new CHAR subrange type */

       typePtr = addTypeDefine(typeName, sSUBRANGE, sCHAR_SIZE, NULL);
       typePtr->sParm.t.subType  = sCHAR;
       typePtr->sParm.t.minValue = tknInt;
       typePtr->sParm.t.maxValue = MAXCHAR;

       /* Verify that ".." separates the two constants */

       getToken();
       if (token != tSUBRANGE) error(eSUBRANGE);
       else getToken();

       /* Verify that the ".." is following by a CHAR constant */

       if ((token != tCHAR_CONST) || (tknInt < typePtr->sParm.t.minValue))
         error(eSUBRANGETYPE);
       else
         {
           typePtr->sParm.t.maxValue = tknInt;
           getToken();
         }
     }

   /* Case 3: <constant> is a SCALAR type */

   else if (token == sSCALAR_OBJECT)
     {
       /* Create the new SCALAR subrange type */

       typePtr = addTypeDefine(typeName, sSUBRANGE, sINT_SIZE, tknPtr);
       typePtr->sParm.t.subType  = token;
       typePtr->sParm.t.minValue = tknInt;
       typePtr->sParm.t.maxValue = MAXINT;

       /* Verify that ".." separates the two constants */

       getToken();
       if (token != tSUBRANGE) error(eSUBRANGE);
       else getToken();

       /* Verify that the ".." is following by a SCALAR constant of the same
        * type as the one which preceded it
        */

       if ((token != sSCALAR_OBJECT) ||
           (tknPtr != typePtr->sParm.t.parent) ||
           (tknPtr->sParm.c.val.i < typePtr->sParm.t.minValue))
         error(eSUBRANGETYPE);
       else
         {
           typePtr->sParm.t.maxValue = tknPtr->sParm.c.val.i;
           getToken();
         }
     }

   return typePtr;
}

/***************************************************************/

static STYPE *pas_NewComplexType(char *typeName)
{
  STYPE *typePtr = NULL;
  STYPE *typeIdPtr;

  TRACE(lstFile,"[pas_TypeDenoter]");

  /* FORM: new-complex-type = new-structured-type | new-pointer-type */

  switch (token)
    {
      /* FORM: new-pointer-type = '^' domain-type | '@' domain-type */

    case '^'      :
      getToken();
      typeIdPtr = pas_TypeIdentifier(1);
      if (typeIdPtr)
        {
          typePtr = addTypeDefine(typeName, sPOINTER, g_dwVarSize, typeIdPtr);
        }
      else
        {
          error(eINVTYPE);
        }
      break;

      /* FORM: new-structured-type =
       *     [ 'packed' ] array-type | [ 'packed' ] record-type |
       *     [ 'packed' ] set-type   | [ 'packed' ] file-type |
       *     [ 'packed' ] list-type  | object-type | string-type
       */

      /* PACKED Types */

    case tPACKED :
      error (eNOTYET);
      getToken();
      if (token != tARRAY) break;
      /* Fall through to process PACKED ARRAY type */

      /* Array Types
       * FORM: array-type = 'array' [ index-type-list ']' 'of' type-denoter
       */

    case tARRAY :
      getToken();
      typeIdPtr = pas_GetArrayType();
      if (typeIdPtr)
        {
          typePtr = addTypeDefine(typeName, sARRAY, g_dwVarSize, typeIdPtr);
        }
      else
        {
          error(eINVTYPE);
        }
      break;

      /* RECORD Types
       * FORM: record-type = 'record' field-list 'end'
       */

    case tRECORD :
      getToken();
      typePtr = pas_DeclareRecord(typeName);
      break;

      /* Set Types
       *
       * FORM: set-type = 'set' 'of' ordinal-type
       */

    case tSET :

      /* Verify that 'set' is followed by 'of' */

      getToken();
      if (token != tOF) error (eOF);
      else getToken();

      /* Verify that 'set of' is followed by an ordinal-type
       * If not, then declare a new one with no name
       */

      typeIdPtr = pas_OrdinalTypeIdentifier(1);
      if (typeIdPtr)
        getToken();
      else
        typeIdPtr = pas_DeclareOrdinalType(NULL);

      /* Verify that the ordinal-type is either a scalar or a 
       * subrange type.  These are the only valid types for 'set of'
       */

      if ((typeIdPtr) &&
          ((typeIdPtr->sParm.t.type == sSCALAR) ||
           (typeIdPtr->sParm.t.type == sSUBRANGE)))
        {
          /* Declare the SET type */

          typePtr = addTypeDefine(typeName, sSET_OF,
                                  typeIdPtr->sParm.t.asize, typeIdPtr);

          if (typePtr)
            {
              int16_t nObjects;

              /* Copy the scalar/subrange characteristics for convenience */

              typePtr->sParm.t.subType  = typeIdPtr->sParm.t.type;
              typePtr->sParm.t.minValue = typeIdPtr->sParm.t.minValue;
              typePtr->sParm.t.maxValue = typeIdPtr->sParm.t.minValue;

              /* Verify that the number of objects associated with the
               * scalar or subrange type will fit into an integer
               * representation of a set as a bit-string.
               */

              nObjects = typeIdPtr->sParm.t.maxValue
                - typeIdPtr->sParm.t.minValue + 1;
              if (nObjects > BITS_IN_INTEGER)
                {
                  error(eSETRANGE);
                  typePtr->sParm.t.maxValue = typePtr->sParm.t.minValue
                    + BITS_IN_INTEGER - 1;
                }
            }
        }
      else
        error(eSET);
      break;
 
      /* File Types
       * FORM: file-type = 'file' 'of' type-denoter
       */

      /* FORM: file-type = 'file' 'of' type-denoter */

    case tFILE :

      /* Make sure that 'file' is followed by 'of' */

      getToken();
      if (token != tOF) error (eOF);
      else getToken();

      /* Get the type-denoter */

      typeIdPtr = pas_TypeDenoter(NULL,1);
      if (typeIdPtr)
        {
          typePtr = addTypeDefine(typeName, sFILE_OF, g_dwVarSize, typeIdPtr);
          if (typePtr)
            {
              typePtr->sParm.t.subType = typeIdPtr->sParm.t.type;
            }
        }
      else
        {
          error(eINVTYPE);
        }
      break;

      /* FORM: string-type = pascal-string-type | c-string-type
       * FORM: pascal-string-type = 'string' [ max-string-length ]
       */
    case sSTRING :
      error (eNOTYET);
      getToken();
      break;

      /* FORM: list-type = 'list' 'of' type-denoter */
      /* FORM: object-type = 'object' | 'class' */
    default :
      break;

   }

  return typePtr;
}

/***************************************************************/
/* Verify that the next token is a type identifer
 */

static STYPE *pas_OrdinalTypeIdentifier(bool allocate)
{
  STYPE *typePtr;

  TRACE(lstFile,"[pas_OrdinalTypeIdentifier]");

  /* Get the next type from the input stream */

  typePtr = pas_TypeIdentifier(allocate);

  /* Was a type encountered? */

  if (typePtr != NULL)
    {
      switch (typePtr->sParm.t.type)
        {
          /* Check for an ordinal type (verify this list!) */

        case sINT :
        case sBOOLEAN :
        case sCHAR :
        case sSCALAR :
        case sSUBRANGE:
          /* If it is an ordinal type, then just return the
           * type pointer.
           */

          break;
        default :
          /* If not, return NULL */

          typePtr = NULL;
          break;
        }
    }
  return typePtr;
}

/***************************************************************/
/* get array type argument for TYPE block or variable declaration */

static STYPE *pas_GetArrayType(void)
{
   STYPE *typePtr = NULL;

   TRACE(lstFile,"[pas_GetArrayType]");

   /* FORM: array-type = 'array' '[' index-type-list ']' 'of' type-denoter */
   /* FORM: [PACKED] ARRAY [<integer>] OF type-denoter
    * NOTE: Bracketed value is the array size!  NONSTANDARD! */

   g_dwVarSize = 0;

   /* Verify that the index-type-list is preceded by '[' */

   if (token != '[') error (eLBRACKET);
   else
     {
       /* FORM: index-type-list = index-type { ',' index-type }
        * FORM: index-type = ordinal-type
        */

       getToken();
       if (token != tINT_CONST) error (eINTCONST);
       else
         {
           g_dwVarSize = tknInt;
           getToken();

           /* Verify that the index-type-list is followed by ']' */

           if (token != ']') error (eRBRACKET);
           else getToken();

           /* Verify that 'of' precedes the type-denoter */

           if (token != tOF) error (eOF);
           else getToken();

           /* We have the array size in elements, not get the type and convert
            * the size for the type found
            */

           typePtr = pas_DeclareType(NULL);
           if (typePtr)
             {
               g_dwVarSize *= typePtr->sParm.t.asize;
             }
         }
     }

   return typePtr;
}

/***************************************************************/

static STYPE *pas_DeclareRecord(char *recordName)
{
  STYPE *recordPtr;
  int16_t recordOffset;
  int recordCount, symbolIndex;

  TRACE(lstFile,"[pas_DeclareRecord]");

  /* FORM: record-type = 'record' field-list 'end' */

  /* Declare the new RECORD type */

  recordPtr = addTypeDefine(recordName, sRECORD, 0, NULL);

  /* Then declare the field-list associated with the RECORD
   * FORM: field-list =
   *       [
   *         fixed-part [ ';' ] variant-part [ ';' ] |
   *         fixed-part [ ';' ] |
   *         variant-part [ ';' ] |
   *       ]
   *
   * Process the fixed-part first.
   * FORM: fixed-part = record-section { ';' record-section }
   * FORM: record-section = identifier-list ':' type-denoter
   * FORM: identifier-list = identifier { ',' identifier }
   */

  for (;;)
    {
      /* Terminate parsing of the fixed-part when we encounter
       * 'case' indicating the beginning of the variant part of
       * the record.  If there is no fixed-part, then 'case' will
       * appear immediately.
       */

      if (token == tCASE) break;

      /* We now expect to see and indentifier representating the
       * beginning of the next fixed field.
       */

      (void)pas_DeclareField(recordPtr);

      /* If the field declaration terminates with a semicolon, then
       * we expect to see another <fixed part> declaration in the
       * record.
       */

      if (token == ';')
        {
          /* Skip over the semicolon and process the next fixed
           * field declaration.
           */

          getToken();

          /* We will treat this semi colon as optional.  If we
           * hit 'end' or 'case' after the semicolon, then we
           * will terminate the fixed part with no complaint.
           */

          if ((token == tEND) || (token == tCASE))
            break;
        }

      /* If there is no semicolon after the field declaration,
       * then 'end' or 'case' is expected.  This will be verified
       * below.
       */

      else break;
    }

  /* Get the total size of the RECORD type and the offset of each
   * field within the RECORD.
   */

  for (recordOffset = 0, symbolIndex = 1, recordCount = 0;
       recordCount < recordPtr->sParm.t.maxValue;
       symbolIndex++)
    {
      /* We know that 'maxValue' sRECORD_OBJECT symbols follow the sRECORD
       * type declaration.  However, these may not be sequential due to the
       * possible declaration of sTYPEs associated with each field.
       */

      if (recordPtr[symbolIndex].sKind == sRECORD_OBJECT)
        {
          /* Align the recordOffset (if necessary) */

          if ((!isIntAligned(recordOffset)) &&
              (pas_IntAlignRequired(recordPtr[symbolIndex].sParm.r.parent)))
            recordOffset = intAlign(recordOffset);

          /* Save the offset associated with this field, and determine the
           * offset to the next field (if there is one)
           */

          recordPtr[symbolIndex].sParm.r.offset = recordOffset;
          recordOffset += recordPtr[symbolIndex].sParm.r.size;
          recordCount++;
        }
    } 

  /* Update the RECORD entry for the total size of all fields */

  recordPtr->sParm.t.asize = recordOffset;

  /* Now we are ready to process the variant-part.
   * FORM: variant-part = 'case' variant-selector 'of' variant-body
   */

  if (token == tCASE)
    {
      int16_t variantOffset;
      uint16_t maxRecordSize;

      /* Skip over the 'case' */

      getToken();

      /* Check for variant-selector
       * FORM: variant-selector = [ identifier ':' ] ordinal-type-identifer
       */

      if (token != tIDENT) error(eRECORDDECLARE);

      /* Add a variant-selector to the fixed-part of the record */ 

      else
        {
          STYPE *typePtr;
          char  *fieldName;

          /* Save the field name */

          fieldName = tkn_strt;
          getToken();

          /* Verify that the identifier is followed by a colon */

          if (token != ':') error(eCOLON);
          else getToken();

          /* Get the ordinal-type-identifier */

          typePtr = pas_OrdinalTypeIdentifier(1);
          if (!typePtr) error(eINVTYPE);
          else
            {
              STYPE *fieldPtr;

              /* Declare a <field> with this <identifier> as its name */

              fieldPtr = addField(fieldName, recordPtr);

              /* Increment the number of fields in the record */

              recordPtr->sParm.t.maxValue++;

              /* Copy the size of field from the sTYPE entry into the
               * <field> type entry.  NOTE:  This element is not essential
               * since it  can be obtained from the parent type pointer
               */

              fieldPtr->sParm.r.size = typePtr->sParm.t.asize;

              /* Save a pointer back to the parent field type */

              fieldPtr->sParm.r.parent = typePtr;

              /* Align the recordOffset (if necessary) */

              if ((!isIntAligned(recordOffset)) &&
                  (pas_IntAlignRequired(typePtr)))
                recordOffset = intAlign(recordOffset);

              /* Save the offset associated with this field, and determine
               * the offset to the next field (if there is one)
               */

              fieldPtr->sParm.r.offset = recordOffset;
              recordOffset += recordPtr[symbolIndex].sParm.r.size;
            }
        }

      /* Save the offset to the start of the variant portion of the RECORD */

      variantOffset = recordOffset;
      maxRecordSize = recordOffset;

      /* Skip over the 'of' following the variant selector */

      if (token != tOF) error(eOF);
      else getToken();

      /* Loop to process the variant-body
       * FORM: variant-body =
       *       variant-list [ [ ';' ] variant-part-completer ] |
       *       variant-part-completer
       * FORM: variant-list = variant { ';' variant }
       * FORM: variant-part-completer = ( 'otherwise' | 'else' ) ( field-list )
       */

      for (;;)
        {
          /* Now process each variant where:
           * FORM: variant = case-constant-list ':' '(' field-list ')'
           * FORM: case-constant-list = case-specifier { ',' case-specifier }
           * FORM: case-specifier = case-constant [ '..' case-constant ]
           */

          /* Verify that the case selector begins with a case-constant.
           * Note that subrange case-specifiers are not yet supported.
           */

          if (!isConstant(token))
            {
              error(eINVCONST);
              break;
            }

          /* Just consume the <case selector> for now -- Really need to
           * verify that each constant is of the same type as the type
           * identifier (or the type associated with the tag) in the CASE
           */

          do
            {
              getToken();
              if (token == ',') getToken();
            }
          while (isConstant(token));

          /* Make sure a colon separates case-constant-list from the
           * field-list
           */

          if (token == ':') getToken();
          else error(eCOLON);

          /* The field-list must be enclosed in parentheses */

          if (token == '(') getToken();
          else error(eLPAREN);

          /* Special case the empty variant <field list> */

          if (token != ')')
            {
              /* Now process the <field list> for the variant.  This works
               * just like the field list of the fixed part, except the
               * offset is reset for each variant.
               * FORM: field-list =
               *       [
               *         fixed-part [ ';' ] variant-part [ ';' ] |
               *         fixed-part [ ';' ] |
               *         variant-part [ ';' ] |
               *       ]
               */

              for (;;)
                {
                  /* We now expect to see and indentifier representating the
                   * beginning of the next variablefield.
                   */

                  (void)pas_DeclareField(recordPtr);

                  /* If the field declaration terminates with a semicolon,
                   * then we expect to see another <variable part>
                   * declaration in the record.
                   */

                  if (token == ';')
                    {
                      /* Skip over the semicolon and process the next
                       * variable field declaration.
                       */

                      getToken();

                      /* We will treat this semi colon as optional.  If we
                       * hit 'end' after the semicolon, then we will
                       * terminate the fixed part with no complaint.
                       */

                      if (token == tEND)
                        break;
                    }
                  else break;
                }

              /* Get the total size of the RECORD type and the offset of each
               * field within the RECORD.
               */

              for (recordOffset = variantOffset;
                   recordCount < recordPtr->sParm.t.maxValue;
                   symbolIndex++)
                {
                  /* We know that 'maxValue' sRECORD_OBJECT symbols follow
                   * the sRECORD type declaration.  However, these may not
                   * be sequential due to the possible declaration of sTYPEs
                   * associated with each field.
                   */

                  if (recordPtr[symbolIndex].sKind == sRECORD_OBJECT)
                    {
                      /* Align the recordOffset (if necessary) */

                      if ((!isIntAligned(recordOffset)) &&
                          (pas_IntAlignRequired(recordPtr[symbolIndex].sParm.r.parent)))
                        recordOffset = intAlign(recordOffset);

                      /* Save the offset associated with this field, and
                       * determine the offset to the next field (if there
                       * is one)
                       */

                      recordPtr[symbolIndex].sParm.r.offset = recordOffset;
                      recordOffset += recordPtr[symbolIndex].sParm.r.size;
                      recordCount++;
                    }
                }

              /* Check if this is the largest variant that we have found
               * so far
               */

              if (recordOffset > maxRecordSize)
                maxRecordSize = recordOffset;
            } 

          /* Verify that the <field list> is enclosed in parentheses */

          if (token == ')') getToken();
          else error(eRPAREN);

          /* A semicolon at this position means that another <variant>
           * follows.  Keep looping until all of the variants have been
           * processed (i.e., no semi-colon)
           */

          if (token == ';') getToken();
          else break;
        }

      /* Update the RECORD entry for the maximum size of all variants */

      recordPtr->sParm.t.asize = maxRecordSize;
    }

  /* Verify that the RECORD declaration terminates with END */

  if (token != tEND) error(eRECORDDECLARE);
  else getToken();

  return recordPtr;
}

/***************************************************************/

static STYPE *pas_DeclareField(STYPE *recordPtr)
{
   STYPE *fieldPtr = NULL;
   STYPE *typePtr;

   TRACE(lstFile,"[pas_DeclareField]");

   /* Declare one record-section with a record.
    * FORM: record-section = identifier-list ':' type-denoter
    * FORM: identifier-list = identifier { ',' identifier }
    */

   if (token != tIDENT) error(eIDENT);
   else {

     /* Declare a <field> with this <identifier> as its name */

     fieldPtr = addField(tkn_strt, recordPtr);
     getToken();

     /* Check for multiple fields of this <type> */

     if (token == ',') {

       getToken();
       typePtr = pas_DeclareField(recordPtr);

     }
     else {

       if (token != ':') error(eCOLON);
       else getToken();

       /* Use the existing type or declare a new type with no name */

       typePtr = pas_TypeDenoter(NULL, 1);
     }

     recordPtr->sParm.t.maxValue++;
     if (typePtr) {

       /* Copy the size of field from the sTYPE entry into the <field> */
       /* type entry.  NOTE:  This element is not essential since it */
       /* can be obtained from the parent type pointer */

       fieldPtr->sParm.r.size     = typePtr->sParm.t.asize;

       /* Save a pointer back to the parent field type */

       fieldPtr->sParm.r.parent   = typePtr;

     }
   }

   return typePtr;
}
 
/***************************************************************/
/* Process VAR/value Parameter Declaration */
/* NOTE:  This function increments the global variable g_nParms */
/* as a side-effect */

static STYPE *pas_DeclareParameter(bool pointerType)
{
   int16_t varType = 0;
   STYPE  *varPtr;
   STYPE  *typePtr;

   TRACE(lstFile,"[pas_DeclareParameter]");

   /* FORM:
    * <identifier>[,<identifier>[,<identifier>[...]]] : <type identifier>
    */

   if (token != tIDENT) error (eIDENT);
   else
     {
       varPtr = addVariable(tkn_strt, sINT, 0, sINT_SIZE, NULL);
       getToken();

       if (token == ',')
         {
           getToken();
           typePtr = pas_DeclareParameter(pointerType);
         }
       else
         {
           if (token != ':') error (eCOLON);
           else getToken();
           typePtr = pas_TypeIdentifier(0);
         }

       if (pointerType)
         {
           varType = sVAR_PARM;
           g_dwVarSize = sPTR_SIZE;
         }
       else
         {
           varType = typePtr->sParm.t.rtype;
         }

       g_nParms++;
       varPtr->sKind          = varType;
       varPtr->sParm.v.size   = g_dwVarSize;
       varPtr->sParm.v.parent = typePtr;
     }

   return typePtr;
}

/***************************************************************/

static bool pas_IntAlignRequired(STYPE *typePtr)
{
  bool returnValue = false;

  /* Type CHAR and ARRAYS of CHAR do not require alignment (unless
   * they are passed as value parameters).  Otherwise, alignment
   * to type INTEGER boundaries is required.
   */

  if (typePtr)
    {
      if (typePtr->sKind == sCHAR)
        {
          returnValue = true;
        }
      else if (typePtr->sKind == sARRAY)
        {
          typePtr = typePtr->sParm.t.parent;
          if ((typePtr) && (typePtr->sKind == sCHAR))
            {
              returnValue = true;
            }
        }
    }

  return returnValue;
}

/***************************************************************/
