/*
 * Copyright (C) 2007, 2008. PathScale, LLC. All Rights Reserved.
 */
/*
 *  Copyright (C) 2006, 2007. QLogic Corporation. All Rights Reserved.
 */

/*
 * Copyright 2005, 2006 PathScale, Inc.  All Rights Reserved.
 */

/*

  Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.

   Path64 is free software; you can redistribute it and/or modify it
   under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2, or (at your option)
   any later version.

   Path64 is distributed in the hope that it will be useful, but WITHOUT
   ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
   or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
   License for more details.

   You should have received a copy of the GNU General Public License
   along with Path64; see the file COPYING.  If not, write to the Free
   Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
   02110-1301, USA.

   Special thanks goes to SGI for their continued support to open source

*/



static char USMID[] = "\n@(#)5.0_pl/sources/p_dcl_util.c	5.7	10/28/99 10:03:56\n";

# include "defines.h"		/* Machine dependent ifdefs */

# include "host.m"		/* Host machine dependent macros.*/
# include "host.h"		/* Host machine dependent header.*/
# include "target.m"		/* Target machine dependent macros.*/
# include "target.h"		/* Target machine dependent header.*/

# include "globals.m"
# include "tokens.m"
# include "sytb.m"
# include "p_globals.m"
# include "debug.m"

# include "globals.h"
# include "tokens.h"
# include "sytb.h"
# include "p_globals.h"

/*****************************************************************\
|* function prototypes of static functions declared in this file *|
\*****************************************************************/

static	int	ntr_bnds_tmp_list(opnd_type *);
#ifndef KEY /* Bug 10572 */
static	boolean	parse_int_spec_expr(long *, fld_type *, boolean, boolean,
				    boolean);
#endif /* KEY Bug 10572 */
static	void	parse_kind_selector(int);
static	boolean	is_attr_referenced_in_bound(int, int);


static	boolean	kind0seen;
static	boolean	kind0E0seen;
static	boolean	kind0D0seen;
static	boolean	kindconstseen;


int function_ret_type;
opnd_type function_ret_kindspec;

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*      Parses the array_spec for declarations                                *|
|*             array_spec is explicit-shape-spec-list                         *|
|*                            is [lower-bound :]upper-bound                   *|
|*                               [specification-expr :] specification-expr    *|
|*                       is assumed-shape-spec-list                           *|
|*                          is [lower-bound] :                                *|
|*                       is deferred-shape-spec-list                          *|
|*                          is :                                              *|
|*                       is assumed-size-spec                                 *|
|*                          is [explicit-shape-spec-list,] [lower-bound:]*    *|
|*                                                                            *|
|*       Position  - entry - token is open paren                              *|
|*                   exit  - token is verified close paren                    *|
|*                           if close paren is missing.  LA_CH is set to      *|
|*                           colon-colon, or EOS                              *|
|*                                                                            *|
|* Returns:								      *|
|*	NONE                                                                  *|
|*									      *|
\******************************************************************************/
int	parse_array_spec(int	attr_idx)

{
   int			bd_idx;
   int			column;
   boolean		fold_it;
   boolean		found_end		= FALSE;
   boolean		found_error		= FALSE;
   fld_type		lb_fld;
   long			lb_len_idx;
   int			line;
   boolean		lower_bound_found;
   boolean		non_constant_size	= FALSE;
   boolean		possible_assumed_shape	= FALSE;
   int			rank			= 1;
   reference_type	referenced;
   fld_type		ub_fld;
   long			ub_len_idx;

  
   TRACE (Func_Entry, "parse_array_spec", NULL);

# ifdef _DEBUG
   if (LA_CH_VALUE != LPAREN) {
      PRINTMSG(LA_CH_LINE, 295, Internal, LA_CH_COLUMN,
               "parse_array_spec", "LPAREN");
   }
# endif

   NEXT_LA_CH;				                     /* Skip Lparen   */
   bd_idx			= reserve_array_ntry(7);
   referenced			= (reference_type) AT_REFERENCED(attr_idx);
   AT_REFERENCED(attr_idx)	= Not_Referenced;
   BD_LINE_NUM(bd_idx)		= LA_CH_LINE;
   BD_COLUMN_NUM(bd_idx)	= LA_CH_COLUMN;

   /* If LA_CH is RPAREN, there is no dimension, so default to a rank 1       */
   /* constant sized array of length 1 and return.                            */

   if (LA_CH_VALUE == RPAREN) {
      parse_err_flush(Find_None, "dimension-spec");
      BD_ARRAY_CLASS(bd_idx)	= Explicit_Shape;
      BD_ARRAY_SIZE(bd_idx)	= Constant_Size;
      BD_DCL_ERR(bd_idx)	= TRUE;
      BD_RANK(bd_idx)		= 1;
      BD_LB_FLD(bd_idx, 1)	= CN_Tbl_Idx;
      BD_LB_IDX(bd_idx, 1)	= CN_INTEGER_ONE_IDX;
      BD_UB_FLD(bd_idx, 1)	= CN_Tbl_Idx;
      BD_UB_IDX(bd_idx, 1)	= CN_INTEGER_ONE_IDX;
      NEXT_LA_CH;
      goto EXIT;
   }

   /* Set fold_it flag.  Will continue on and do pass2 style semantic     */
   /* checking and constant folding, if this is a component declaration.  */

   fold_it = (CURR_BLK == Derived_Type_Blk);

   do {  /* Process each dimension of the array */
      lower_bound_found 	= FALSE;
      lb_len_idx		= CN_INTEGER_ONE_IDX;
      lb_fld			= CN_Tbl_Idx;
      ub_len_idx		= NULL_IDX;
      ub_fld			= NO_Tbl_Idx;

      if (LA_CH_VALUE != COLON && LA_CH_VALUE != STAR) {
         line		= LA_CH_LINE;
         column		= LA_CH_COLUMN;

         /* If LA_CH isn't a COLON or a STAR, then this must be an expression.*/
         /* Get the expression and determine if it is a lower or upper bound. */
         /* If there is a parse error, a constant one is returned.            */

         if (!parse_int_spec_expr(&ub_len_idx, &ub_fld, fold_it, FALSE, FALSE)) {
            ub_len_idx		= CN_INTEGER_ONE_IDX;
            ub_fld		= CN_Tbl_Idx;
            BD_DCL_ERR(bd_idx)	= TRUE;
         }

         if (ub_fld != CN_Tbl_Idx) {
            non_constant_size	= TRUE;
         }

         if (LA_CH_VALUE == COLON) {	               /* This is lower bound */
            lower_bound_found		= TRUE;
            possible_assumed_shape	= TRUE;
            lb_len_idx			= ub_len_idx;
            lb_fld			= ub_fld;
            ub_len_idx			= NULL_IDX;
            ub_fld			= NO_Tbl_Idx;
         }

         /* If LA_CH isn't a COLON this must be an upper bound.  If it is an  */
         /* upper bound and the array has already been classified as deferred */
         /* shape, issue an error, because a deferred shape array can never   */
         /* have an upper bound.  Otherwise set as an Explicit_Shape array.   */

         else if (BD_ARRAY_CLASS(bd_idx) == Deferred_Shape) {

            /* DIMENSION A(10,:)  --> Illegal - Set Upper bound to NULL_IDX.  */

            ub_len_idx		= NULL_IDX;
            ub_fld		= NO_Tbl_Idx;
            BD_DCL_ERR(bd_idx)	= TRUE;
            PRINTMSG(line, 114, Error, column);
         }
         else {
            BD_ARRAY_CLASS(bd_idx)	= Explicit_Shape;
         }
      }
         
      /* Now the parser is in one of 3 states.  1) Lower bound found, upper   */
      /* bound = NULL, LA_CH must be COLON.  2) Lower bound not found, so it  */
      /* is set to a default of 1, upper bound is found and LA_CH is COMMA or */
      /* RPAREN.   (LA_CH must be COLON.)  3) Neither lower bound or upper    */
      /* bound have been seen, they are set to defaults of lb=1, ub=NULL.     */
      /* LA_CH is COLON or STAR.  If the LA_CH is COLON, this is either a     */
      /* Deferred-Shape spec or it is followed by the upper bound for an      */
      /* Explicit-Shape spec.  NOTE: LA_CH may be EOS - this is parse error.  */

      if (LA_CH_VALUE == COLON) {
         line		= LA_CH_LINE;
         column		= LA_CH_COLUMN;
         NEXT_LA_CH;				/* Skip COLON */

         if (LA_CH_VALUE == COMMA || LA_CH_VALUE == RPAREN) {

            /* Have one of two cases  1)  ARRAY(1:)  - This is an assumed     */
            /* shape spec which is classed as a Deferred-Shape, or 2) ARRAY(:)*/
            /* which is a deferred-Shape spec.   Issue an error if this array */
            /* has already been classified as an Explicit_Shape array.        */

            if (BD_ARRAY_CLASS(bd_idx) == Explicit_Shape) {
               PRINTMSG(line, 115, Error, column);
               BD_DCL_ERR(bd_idx)	= TRUE;
            }
            else {  /* Must be Deferred-Shape spec */
               BD_ARRAY_CLASS(bd_idx)	= Deferred_Shape;
            }
         }
         else {

            /* Have one of two cases  1)  ARRAY (1:10) - legal - pick up upper*/
            /* bound expression.  Err if array is already set to Deferred-    */
            /* Shape spec.  2) ARRAY (:10) - illegal - issue error.           */
            /* If the upper bound is a STAR, pick it up in the next section.  */

            if (!lower_bound_found) {			/* A(:10) - illegal   */
               PRINTMSG(LA_CH_LINE, 119, Error, LA_CH_COLUMN, &LA_CH_VALUE);
               BD_DCL_ERR(bd_idx)	= TRUE;
            }

            if (LA_CH_VALUE != STAR) {
               line	= LA_CH_LINE;
               column	= LA_CH_COLUMN;

               if (!parse_int_spec_expr(&ub_len_idx, &ub_fld, fold_it,
					FALSE, FALSE)) {

                  /* Expression parser recovers LA_CH to : ) , or EOS */

                  BD_DCL_ERR(bd_idx)	= TRUE;
                  ub_len_idx		= CN_INTEGER_ONE_IDX;
                  ub_fld		= CN_Tbl_Idx;
               }

               if (ub_fld != CN_Tbl_Idx) {
                  non_constant_size	= TRUE;
               }

               if (BD_ARRAY_CLASS(bd_idx) == Deferred_Shape) { /*A(:,1:2)*/
                  PRINTMSG(line, 114, Error, column);
                  BD_DCL_ERR(bd_idx)	= TRUE;
                  ub_len_idx		= NULL_IDX;
                  ub_fld		= NO_Tbl_Idx;
               }
               else {
                  BD_ARRAY_CLASS(bd_idx)= Explicit_Shape;
               }
            }
         }
      }

      /* The parser may be:  1)  ARRAY(*) - lb=1, ub=NULL_IDX.  2) ARR(10:*)  */
      /* lb is set, and ub=NULL_IDX.  3)  ARRAY(:*) - illegal -error already  */
      /* issued.  You could not have picked up a lower bound and/or an upper  */
      /* bound and got to this position, because a * is part of an expression.*/
      /* The expression parser stops at COLON, COMMA, RPAREN or EOS.          */

      if (LA_CH_VALUE == STAR) {
         line	= LA_CH_LINE;
         column	= LA_CH_COLUMN;
         NEXT_LA_CH;				/* Skip STAR */

         if (BD_ARRAY_CLASS(bd_idx) == Deferred_Shape) {

            /* can't have asterisk with a deferred shape spec */

            PRINTMSG(line, 114, Error, column);
            parse_err_flush(Find_Rparen, NULL);
            BD_DCL_ERR(bd_idx)	= TRUE;
         }
         else {
            BD_ARRAY_CLASS(bd_idx)	= Assumed_Size;
            ub_len_idx			= lb_len_idx;
            ub_fld			= lb_fld;

            if (LA_CH_VALUE != RPAREN) {
 
               /* The assumed-size specifier * must be in the last dimension. */

               BD_DCL_ERR(bd_idx)	= TRUE;
               PRINTMSG(line, 116, Error, column);
               parse_err_flush(Find_Rparen, NULL);
            }
         }
      }

      BD_LB_IDX(bd_idx, rank)	= lb_len_idx;
      BD_LB_FLD(bd_idx, rank)	= lb_fld;
      BD_UB_IDX(bd_idx, rank)	= ub_len_idx;
      BD_UB_FLD(bd_idx, rank)	= ub_fld;

      if (LA_CH_VALUE == COMMA) {

         if (rank++ == 7) {          /* issue error - too many ranks */
            found_end		= TRUE;
            BD_DCL_ERR(bd_idx)	= TRUE;
            PRINTMSG(LA_CH_LINE, 117, Error, LA_CH_COLUMN);
            parse_err_flush(Find_Rparen, NULL);
         }
         else {
            NEXT_LA_CH;
         }
      }
      else {
         found_end = TRUE;
      }

      found_error = BD_DCL_ERR(bd_idx) | found_error;
   }
   while (!found_end);

   if (LA_CH_VALUE == RPAREN || 
       parse_err_flush(Find_Rparen, (found_error) ? NULL : ", or )")) {

      NEXT_LA_CH;		/* Skip RPAREN */
   }

   if (BD_ARRAY_CLASS(bd_idx) == Deferred_Shape) {

      if (possible_assumed_shape) {
         BD_ARRAY_CLASS(bd_idx) = Assumed_Shape;
      }
   }
   else if (!non_constant_size) {
      BD_ARRAY_SIZE(bd_idx) = Constant_Size;
   }

   BD_RANK(bd_idx) = rank;

# ifdef _DEBUG
   if (BD_ARRAY_CLASS(bd_idx) == Unknown_Array) {

      /* There is a parsing problem here.  This must never be Unknown_Array */

      PRINTMSG(LA_CH_LINE, 178, Internal, LA_CH_COLUMN);
   }
# endif

EXIT:

   if (AT_REFERENCED(attr_idx) > Not_Referenced) {
      is_attr_referenced_in_bound(bd_idx, attr_idx);
   }

   if (AT_REFERENCED(attr_idx) < referenced) {
      AT_REFERENCED(attr_idx)	= referenced;
   }

   bd_idx = ntr_array_in_bd_tbl(bd_idx);

   TRACE (Func_Exit, "parse_array_spec", NULL);

   return(bd_idx);

}  /* parse_array_spec */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Parse a POSSIBLE generic spec.                                        *|
|*									      *|
|*	Input position  : The identifier, OPERATOR, or ASSIGNMENT token.      *|
|*	Output position : The comma or EOS after the interface or id.         *|
|*	Called By       : parse_access_stmt, parse_interface_stmt,            *|
|*	                  parse_use_stmt                                      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if parsed spec.  FALSE if found a fatal error.		      *|
|*									      *|
\******************************************************************************/

boolean	parse_generic_spec(void)

{
   boolean	parse_ok;


   TRACE (Func_Entry, "parse_generic_spec", NULL);

   if (MATCHED_TOKEN_CLASS(Tok_Class_Keyword)) {
      parse_ok	= TRUE;

      if (TOKEN_VALUE(token) == Tok_Id) {
         /* Intentionally left blank */
      }
      else if (TOKEN_VALUE(token) == Tok_Kwd_Assignment &&
               LA_CH_VALUE == LPAREN) {
         NEXT_LA_CH;				/* Pick up LPAREN */
 
         if (LA_CH_VALUE == EQUAL) {

            MATCHED_TOKEN_CLASS(Tok_Class_Op);

            if (TOKEN_VALUE(token) == Tok_Op_Assign) {

               if (LA_CH_VALUE == RPAREN || parse_err_flush(Find_Rparen, ")")) {
                  NEXT_LA_CH;			/* Pick up RPAREN */
               }
            }
            else {
               PRINTMSG(TOKEN_LINE(token), 197, Error, TOKEN_COLUMN(token),
                        "=", TOKEN_STR(token));
               parse_ok = FALSE;

               if (parse_err_flush(Find_Rparen, NULL)) {
                  NEXT_LA_CH;                         /* Pick up RPAREN */
               }
            }
         }
         else if (parse_err_flush(Find_Rparen, "=")) {
            parse_ok = FALSE;
            NEXT_LA_CH;				/* Pick up RPAREN */
         }
      }
      else if (TOKEN_VALUE(token) == Tok_Kwd_Operator && 
               LA_CH_VALUE == LPAREN) {
         NEXT_LA_CH;				/* Pick up LPAREN */

         if (MATCHED_TOKEN_CLASS(Tok_Class_Op)) {

            switch (TOKEN_VALUE(token)) {
               case Tok_Const_True:
               case Tok_Const_False:
                  parse_ok = FALSE;
                  PRINTMSG(TOKEN_LINE(token), 499, Error, TOKEN_COLUMN(token));
                  break;

               case Tok_Op_Deref:
               case Tok_Op_Ptr_Assign:
               case Tok_Op_Assign:
                  parse_ok = FALSE;
                  PRINTMSG(TOKEN_LINE(token), 300, Error, TOKEN_COLUMN(token));
                  break;

               case Tok_Op_Eq :
                  TOKEN_STR(token)[0] = 'e';
                  TOKEN_STR(token)[1] = 'q';
                  break;

               case Tok_Op_Ge :
                  TOKEN_STR(token)[0] = 'g';
                  TOKEN_STR(token)[1] = 'e';
                  break;

               case Tok_Op_Gt :
                  TOKEN_STR(token)[0] = 'g';
                  TOKEN_STR(token)[1] = 't';
                  break;

               case Tok_Op_Le :
                  TOKEN_STR(token)[0] = 'l';
                  TOKEN_STR(token)[1] = 'e';
                  break;

               case Tok_Op_Lt :
                  TOKEN_STR(token)[0] = 'l';
                  TOKEN_STR(token)[1] = 't';
                  break;

               case Tok_Op_Ne :
                  TOKEN_STR(token)[0] = 'n';
                  TOKEN_STR(token)[1] = 'e';
                  break;

               case Tok_Op_Lg :
                  TOKEN_STR(token)[0] = 'l';
                  TOKEN_STR(token)[1] = 'g';
                  break;

               default:
                  break;
            }

            if (LA_CH_VALUE == RPAREN || parse_err_flush(Find_Rparen, ")")) {
                  NEXT_LA_CH;				/* Pick up RPAREN */
            }
         }
         else if (LA_CH_VALUE == SLASH) {

            /* this clause is needed  because lex thinks that "/)" is an */
            /* array constructor punctuator.                             */

            TOKEN_STR(token)[0] = LA_CH_VALUE;
            TOKEN_VALUE(token)  = Tok_Op_Div;
            TOKEN_LEN(token)    = 1;
            NEXT_LA_CH;

            if (LA_CH_VALUE == RPAREN || parse_err_flush(Find_Rparen, ")")) {
                  NEXT_LA_CH;                           /* Pick up RPAREN */
            }
         }
         else if (parse_err_flush(Find_Rparen, "defined-operator")) {
            parse_ok = FALSE;
            NEXT_LA_CH;		/* Pick up RPAREN */
         }
      }
      else {
         reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
         MATCHED_TOKEN_CLASS(Tok_Class_Id);
      }
   }
   else {
      parse_err_flush(Find_Comma, "OPERATOR or ASSIGNMENT or generic-name");
      parse_ok = FALSE;
   }

   TRACE (Func_Exit, "parse_generic_spec", NULL);
   return(parse_ok);

}  /* parse_generic_spec */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*      BNF       - intent-spec   is  IN  or  OUT  or INOUT                   *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	intent_type - Returns the INTENT value.  Default is Intent_Inout if   *|
|*                    there is an error.  Otherwise it's whatever was parsed. *|
|*									      *|
\******************************************************************************/

intent_type	parse_intent_spec()

{
   char		*err_str	= NULL;
   intent_type	 intent		= Intent_Inout;


   TRACE (Func_Entry, "parse_intent_spec", NULL);

   if (LA_CH_VALUE != LPAREN) {
      err_str = "(";
   }
   else {
      NEXT_LA_CH;			/* Skip Lparen */

      if (matched_specific_token(Tok_Kwd_In, Tok_Class_Keyword)) {

         if (!matched_specific_token(Tok_Kwd_Out, Tok_Class_Keyword)) {
            intent = Intent_In;
         }
      }
      else if (matched_specific_token(Tok_Kwd_Out, Tok_Class_Keyword)) {
         intent = Intent_Out;
      }
      else {
         parse_err_flush(Find_Rparen, "IN or OUT or INOUT");
         intent = Intent_Unseen;	/* Signal parse error */
      }

      if (LA_CH_VALUE == RPAREN) {
         NEXT_LA_CH;			/* Skip Rparen */
      }
      else {
         err_str = ")";
      }
   }

   if (err_str != NULL) {
      parse_err_flush(Find_Rparen, err_str);
      matched_specific_token(Tok_Punct_Rparen, Tok_Class_Punct);
      intent = Intent_Unseen;
   }

   TRACE (Func_Exit, "parse_intent_spec", NULL);

   return(intent);

}  /* parse_intent_spec */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*      BNF       - ([KIND =] scalar-int-initialization-expr)                 *|
|*      Position  - entry - Token before start of expression                  *|
|*                  exit  - Token at end of expression                        *|
|*                                                                            *|
|*      QUESTIONS:  Need to know what the expression parser is going to do,   *|
|*                  if it hits an error?   Need to advance to the end of the  *|
|*                  specification expression.                                 *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/
 
static	void	parse_kind_selector(int function_ret_kind_flag)

{
   int		al_idx;
   fld_type	field_type;
   long		kind_idx;
   opnd_type	opnd;


   TRACE (Func_Entry, "parse_kind_selector", NULL);

   if (matched_specific_token(Tok_Kwd_Kind, Tok_Class_Keyword) &&
       !matched_specific_token(Tok_Punct_Eq, Tok_Class_Punct)) {
      reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
   }

   OPND_LINE_NUM(opnd)	= LA_CH_LINE;
   OPND_COL_NUM(opnd)	= LA_CH_COLUMN;

   /* These should usually be constants.  The only case where it is
    * not is the kind specification of a function's return type.  We
    * have to check these later. */

   parsing_kind_selector = !function_ret_kind_flag;
   kind0seen = FALSE;
   kind0E0seen = FALSE;
   kind0D0seen = FALSE;
   kindconstseen = FALSE;

   if (parse_int_spec_expr(&kind_idx, &field_type, TRUE,
			   FALSE, function_ret_kind_flag)) {
      OPND_FLD(opnd)		= field_type;
      OPND_IDX(opnd)		= kind_idx;

      if (function_ret_kind_flag && field_type != CN_Tbl_Idx) {
	  /* Fold the kindspec later */
	  function_ret_kindspec = opnd;
	  function_ret_type = TYP_TYPE(ATD_TYPE_IDX(AT_WORK_IDX));

      } else {
	  OPND_FLD(function_ret_kindspec) = NO_Tbl_Idx;
	  OPND_IDX(function_ret_kindspec) = NULL_IDX;
      }

      if (field_type == CN_Tbl_Idx &&
	  !kind_to_linear_type(&opnd,
			       AT_WORK_IDX,
			       kind0seen,
			       kind0E0seen,
			       kind0D0seen,
			       kindconstseen)) {
         AT_DCL_ERR(AT_WORK_IDX)	= TRUE;
      }

# if !defined(_TARGET_OS_MAX)

      if (!on_off_flags.enable_double_precision &&
          (TYP_TYPE(ATD_TYPE_IDX(AT_WORK_IDX)) == Complex ||
           TYP_TYPE(ATD_TYPE_IDX(AT_WORK_IDX)) == Real) &&
          TYP_DCL_VALUE(ATD_TYPE_IDX(AT_WORK_IDX)) == 16) {
         PRINTMSG(OPND_LINE_NUM(opnd), 586, Warning, OPND_COL_NUM(opnd));
      }
# endif

# if defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN)
      if ((TYP_TYPE(ATD_TYPE_IDX(AT_WORK_IDX)) == Complex ||
           TYP_TYPE(ATD_TYPE_IDX(AT_WORK_IDX)) == Real) &&
          TYP_DCL_VALUE(ATD_TYPE_IDX(AT_WORK_IDX)) == 16) {
         PRINTMSG(OPND_LINE_NUM(opnd), 541, Error, OPND_COL_NUM(opnd));
      }
# endif

      if (field_type == AT_Tbl_Idx) {

         /* Mark tmp not referenced and remove it from the tmp list.  This */
         /* tmp was not shared when it was entered into the bounds list.   */

         AT_REFERENCED(kind_idx)	= Not_Referenced;
         al_idx				= SCP_TMP_FW_IDX(curr_scp_idx);
         SCP_TMP_FW_IDX(curr_scp_idx)	= AL_NEXT_IDX(al_idx);
      }
   }

   parsing_kind_selector = FALSE;

   TRACE (Func_Exit, "parse_kind_selector", NULL);

   return;

}  /* parse_kind_selector */


/******************************************************************************\
|*                                                                            *|
|* Description:								      *|
|*   If i_can_have_len_equal                                                  *|
|*      BNF - [LEN =] type-param-value                                        *|
|*   If !(i_can_have_len_equal)                                               *|
|*      BNF - *(type-param-value)  OR *scalar-int-literal-constant            *|
|*   type-param-value IS   specification-expr OR *                            *|
|*                                                                            *|
|*   Position  - entry - token is token following (                           *|
|*                       or following LEN=                                    *|
|*                       or *                                                 *|
|*               exit  - LA is comma or right paren or EOS                    *|
|*									      *|
|* Input parameters:							      *|
|*	i_can_have_len_equal - LEN = is allowed.  See description.            *|
|*	parsing_length_selector - We are parsing the length-selector on the   *|
|*	                        CHARACTER statement, as opposed to parsing    *|
|*	                        the char-length on a variable name in a list. *|
|*	                        This is needed for the obsolescence message.  *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if there are no errors, else FALSE				      *|
|*                                                                            *|
\******************************************************************************/
void	parse_length_selector(int	attr_idx,
			      boolean	i_can_have_len_equal,
			      boolean	parsing_length_selector)

{
   type_char_type	char_class	= Unknown_Char;
   int			column;
   fld_type		field_type;
   boolean		fold_it;
   long			len_idx;
   int			line;
   opnd_type		opnd;
   reference_type	referenced;


   TRACE (Func_Entry, "parse_length_selector", NULL);

   /* Set fold_it flag.  Will continue on and do pass2 style semantic     */
   /* checking and constant folding, if this is a component declaration.  */
  
   fold_it			= (CURR_BLK == Derived_Type_Blk);
   referenced			= (reference_type) AT_REFERENCED(attr_idx);
   AT_REFERENCED(attr_idx)	= Not_Referenced;

   CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);

   if (i_can_have_len_equal) {

      if (matched_specific_token(Tok_Kwd_Len, Tok_Class_Keyword) &&
          !matched_specific_token(Tok_Punct_Eq, Tok_Class_Punct)) {
         reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
      }
      line		= LA_CH_LINE;
      column		= LA_CH_COLUMN;

      if (LA_CH_VALUE == STAR) {
         NEXT_LA_CH;
         len_idx	= 0;
         field_type	= NO_Tbl_Idx;
         char_class	= Assumed_Size_Char;
      }
      else {

	 if (!parse_int_spec_expr(&len_idx, &field_type, fold_it,
				  TRUE, FALSE)) {
            len_idx	= CN_INTEGER_ONE_IDX;
            field_type	= CN_Tbl_Idx;
         }

         if (field_type != AT_Tbl_Idx) {
            char_class	= Const_Len_Char;
         }
      }
   }
   else {
#ifdef KEY /* Bug 318, 321 */
      line		= TOKEN_LINE(token);
      column		= TOKEN_COLUMN(token);
      PRINTMSG(line, 1563, Ansi, Comment, column); /* Obsolescent */
#endif /* KEY Bug 318, 321 */
      NEXT_LA_CH;                    /* Skip Star */

      if (LA_CH_VALUE == LPAREN) {   /*    *(*)  or *(length)   */
         NEXT_LA_CH;  /* Skip Lparen */
         line		= LA_CH_LINE;
         column		= LA_CH_COLUMN;

         if (LA_CH_VALUE == STAR) {
            NEXT_LA_CH;
            len_idx	= 0;
            field_type	= NO_Tbl_Idx;
            char_class	= Assumed_Size_Char;
         }
         else {

	    if (!parse_int_spec_expr(&len_idx, &field_type, fold_it,
				     TRUE, FALSE)) {
               len_idx		= CN_INTEGER_ONE_IDX;
               field_type	= CN_Tbl_Idx;
            }

            if (field_type != AT_Tbl_Idx) {
               char_class	= Const_Len_Char;
            }
         }

         if (LA_CH_VALUE == RPAREN || parse_err_flush(Find_Rparen, ")")) {
            NEXT_LA_CH;                 /* Skip Rparen */
         }
      }
      else if (MATCHED_TOKEN_CLASS(Tok_Class_Int_Spec)) {
         len_idx	= TOKEN_CONST_TBL_IDX(token);
         field_type	= CN_Tbl_Idx;
         char_class	= Const_Len_Char;
         line		= TOKEN_LINE(token);
         column		= TOKEN_COLUMN(token);

#ifndef KEY /* Bug 318, 321 */
         if (parsing_length_selector) {
            PRINTMSG(line, 1563, Comment, column); /* Obsolescent */
         }
#endif /* KEY Bug 318, 321 */
      }
      else {
         line		= LA_CH_LINE;
         column		= LA_CH_COLUMN;
         len_idx	= CN_INTEGER_ONE_IDX;
         field_type	= CN_Tbl_Idx;
         char_class	= Const_Len_Char;
         parse_err_flush(Find_None, "scalar-int-literal-constant or (");
      }
   }

   if (char_class == Assumed_Size_Char && CURR_BLK == Derived_Type_Blk) {

      /* Components cannot be assumed size character. */
      
      PRINTMSG(line, 191, Error, column);
      char_class	= Const_Len_Char;
      len_idx		= CN_INTEGER_ONE_IDX;
      field_type	= CN_Tbl_Idx;
   }
  
   if (AT_REFERENCED(attr_idx) > Not_Referenced) {

      /* The attr was referenced in the dimension bound describing the attr. */
      /* Find the reference to the attr, so that we can issue a really good  */
      /* error message.  It's a little compile time, but it's a fatal error. */

      AT_DCL_ERR(attr_idx)	= TRUE;

      if (field_type == AT_Tbl_Idx &&
          ATD_FLD(len_idx) == IR_Tbl_Idx &&
          find_attr_in_ir(attr_idx, ATD_TMP_IDX(len_idx), &opnd)) {
         PRINTMSG(OPND_LINE_NUM(opnd), 1035, Error,
                  OPND_COL_NUM(opnd),
                  AT_OBJ_NAME_PTR(attr_idx));
         len_idx	= CN_INTEGER_ONE_IDX;
         field_type	= CN_Tbl_Idx;
      }
   }

   if (AT_REFERENCED(attr_idx) < referenced) {
      AT_REFERENCED(attr_idx)	= referenced;
   }

   TYP_TYPE(TYP_WORK_IDX)		= Character;
   TYP_LINEAR(TYP_WORK_IDX)		= CHARACTER_DEFAULT_TYPE;
   TYP_CHAR_CLASS(TYP_WORK_IDX)		= char_class;
   TYP_FLD(TYP_WORK_IDX)		= field_type;
   TYP_IDX(TYP_WORK_IDX)		= len_idx;

   TRACE (Func_Exit, "parse_length_selector", NULL);

   return;

}  /* parse_length_selector */
#ifdef KEY /* Bug 8422 */

/*
 * This is the part of parse_type_spec() which processed the "ddd" in
 * something like "integer*ddd"; I have separated it so that it can be used
 * for the extension which allows something like "integer i*ddd" as well
 * (but it is not used for "character c*ddd", which was already handled by
 * parse_length_selector().)
 */
int
parse_non_char_kind_selector(boolean double_precision) {
   if (MATCHED_TOKEN_CLASS(Tok_Class_Int_Spec)) {
      long num	= (long) CN_INT_TO_C(TOKEN_CONST_TBL_IDX(token));
      linear_type_type linear_type	= Err_Res;
      int type_idx	= ATD_TYPE_IDX(AT_WORK_IDX);
      char *type_str	= basic_type_str[TYP_TYPE(type_idx)];

      switch (TYP_TYPE(type_idx)) {

      case Integer:
	    
	 switch (num) {

	 case 1:
	    linear_type = (cmd_line_flags.s_cf77types) ?
			  INTEGER_DEFAULT_TYPE : Integer_1;
	    break;

	 case 2:
	    linear_type = (cmd_line_flags.s_cf77types) ?
			  INTEGER_DEFAULT_TYPE : Integer_2;
	    break;

	 case 4:
	    linear_type = (cmd_line_flags.s_cf77types) ?
			  INTEGER_DEFAULT_TYPE : Integer_4;
	    break;

	 case 8:
	    linear_type = (cmd_line_flags.s_cf77types) ?
			  INTEGER_DEFAULT_TYPE : Integer_8;
	    break;

	 };

      break;


      case Real:

	 if (double_precision) {
	    type_str	= "DOUBLE PRECISION";

	    if (num == 16) {

# ifdef _TARGET_OS_MAX /* Msg was issued when DOUBLE PRECISION was parsed.*/
	       linear_type = Real_8;
# elif defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN)
	       PRINTMSG(TOKEN_LINE(token), 541, Error, 
			TOKEN_COLUMN(token));
# else
	       linear_type = Real_16;

	       if (!on_off_flags.enable_double_precision) {
		  PRINTMSG(TOKEN_LINE(token), 710, Warning, 
			   TOKEN_COLUMN(token),
			   type_str,
			   num);
	       }
# endif
	    }
	 }
	 else {
	    switch (num) {

	    case 4:
	       linear_type = (cmd_line_flags.s_cf77types) ?
			     REAL_DEFAULT_TYPE : Real_4;
	       break;

	    case 8:
	       linear_type = (cmd_line_flags.s_cf77types) ?
			     REAL_DEFAULT_TYPE : Real_8;
	       break;

	    case 16:

# ifdef _TARGET_OS_MAX
	       PRINTMSG(TOKEN_LINE(token), 391, Warning,
			TOKEN_COLUMN(token),
			type_str, num, type_str, 8);
	       linear_type = Real_8;
# elif defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN)
	       PRINTMSG(TOKEN_LINE(token), 541, Error, 
			TOKEN_COLUMN(token));
# else
	       linear_type = Real_16;

	       if (!on_off_flags.enable_double_precision) {
		  PRINTMSG(TOKEN_LINE(token), 710, Warning, 
			   TOKEN_COLUMN(token),
			   type_str,
			   num);
	       }
# endif
	       break;
	    };
	 }

	 break;


      case Complex:

	 switch (num) {

	 case 8:
	    linear_type = (cmd_line_flags.s_cf77types) ?
			  COMPLEX_DEFAULT_TYPE : Complex_4;
	    break;

	 case 16:
	    linear_type = Complex_8;
	    break;

	 case 32:

# ifdef _TARGET_OS_MAX
	    PRINTMSG(TOKEN_LINE(token), 391, Warning, 
		     TOKEN_COLUMN(token),
		     type_str, num, type_str, 16);
	    linear_type = Complex_8;
# elif defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN)
	       PRINTMSG(TOKEN_LINE(token), 541, Error, 
			TOKEN_COLUMN(token));
# else
	    linear_type = Complex_16;

	    if (!on_off_flags.enable_double_precision) {
	       PRINTMSG(TOKEN_LINE(token), 710, Warning, 
			TOKEN_COLUMN(token),
			type_str,
			num);
	    }
# endif
	    break;
	 };

	 break;


      case Logical:

	 switch (num) {

	 case 1:
	    linear_type = (cmd_line_flags.s_cf77types) ?
			  LOGICAL_DEFAULT_TYPE : Logical_1;
	    break;

	 case 2:
	    linear_type = (cmd_line_flags.s_cf77types) ?
			  LOGICAL_DEFAULT_TYPE : Logical_2;
	    break;

	 case 4:
	    linear_type = (cmd_line_flags.s_cf77types) ?
			  LOGICAL_DEFAULT_TYPE : Logical_4;
	    break;

	 case 8:
	    linear_type = (cmd_line_flags.s_cf77types) ?
			  LOGICAL_DEFAULT_TYPE : Logical_8;
	    break;

	 };  /* end switch */

	 break;

      }  /* end switch */


      if (linear_type == Err_Res) {
	 PRINTMSG(TOKEN_LINE(token), 125, Error,
		  TOKEN_COLUMN(token),
		  num,
		  type_str);
      }
      else {
	 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
	 TYP_TYPE(TYP_WORK_IDX)		= TYP_TYPE(type_idx);
	 TYP_LINEAR(TYP_WORK_IDX)		= linear_type;
	 TYP_DCL_VALUE(TYP_WORK_IDX)	= num;
	 TYP_DESC(TYP_WORK_IDX)		= Star_Typed;
	 int result = ntr_type_tbl();

	 PRINTMSG(TOKEN_LINE(token), 124, Ansi, 
		  TOKEN_COLUMN(token),
		  type_str,
		  num);
	 return result;

      }
   }
   else { /* Cannot search - because of IMPLICIT calls */
      parse_err_flush(Find_None, "scalar-int-literal-constant");
   }
   /* 0th entry of type_tbl is guaranteed to be initialized (see p_driver.c)
    * so error doesn't cause crash later on (SiCortex bug 4840) */ 
   return NULL_IDX;
}
#endif /* KEY Bug 8422 */




/******************************************************************************\
|*									      *|
|* Description:								      *|
|*      Parse the procedure interface specification inside the parens.        *|
|*      Set pp_type_idx to an intrincic type index if found                   *|
|*      Set pp_interface_idx to the symbol index of the non-type symbol       *|
|*      Both are set to NULL_IDX if not found.                                *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if parsed OK						      *|
|*									      *|
\******************************************************************************/

static int parse_procedure_interface_spec(void) {
int name_idx;

    pp_type_idx      = NULL_IDX;
    pp_interface_idx = NULL_IDX;

    if (!matched_specific_token(Tok_Punct_Lparen, Tok_Class_Punct)) {
	parse_err_flush(Find_EOS, "Left Paren");

	NEXT_LA_CH;
	return FALSE;
    }

    if (LA_CH_VALUE == ')')
	NEXT_LA_CH;

    else {
       	if (matched_specific_token(Tok_Id, Tok_Class_Keyword)) {
	    pp_interface_idx =
		srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx);

	    if (pp_interface_idx == NULL_IDX)
		pp_interface_idx = ntr_sym_tbl(&token, name_idx);

	} else {
	    get_token(Tok_Class_Keyword);
	    if (parse_type_spec(TRUE, FALSE, FALSE))
		pp_type_idx = ATD_TYPE_IDX(AT_WORK_IDX);

	    else {
		NEXT_LA_CH;    /* Error already issued */
		return FALSE;
	    }
	}

	if (!matched_specific_token(Tok_Punct_Rparen, Tok_Class_Punct)) {
	    parse_err_flush(Find_EOS, "Right Paren");
	    NEXT_LA_CH;
	    return FALSE;
	}
    }

    AT_TYPED(AT_WORK_IDX) = TRUE;
    return TRUE;
}




/******************************************************************************\
|*                                                                            *|
|* Description:								      *|
|*                                                                            *|
|*      BNF    - is INTEGER [kind-selector]                                   *|
|*               or REAL    [kind-selector]                                   *|
|*               or COMPLEX [kind-selector]                                   *|
|*               or LOGICAL [kind-selector]                                   *|
|*               or TYPE(type-name)                                           *|
|*               or DOUBLE PRECISION                                          *|
|*               or DOUBLE COMPLEX                                            *|
|*               CHARACTER [char-selector]                                    *|
|*                         where char_selector is                             *|
|*               * (type-param-value)                                         *|
|*               * scalar-int-literal-constant                                *|
|*               ([LEN=] type-param-value)                                    *|
|*               (LEN=type-param-value,KIND=scalar-int-initialization-exp)    *|
|*               (type-param-value, [KIND=] scalar-int-initialization-exp)    *|
|*               (KIND=scalar-int-initialization-exp [,LEN=type-param-value]) *|
|*                                                                            *|
|* Input parameters:							      *|
|*	chk_kind - TRUE if check for kind (or kind/len for character) on type *|
|*			spec				                      *|
|*      proc_ok  - TRUE if it is OK for a PROCEDURE decl to be here           *|
|*      func_type - TRUE if this type is a function return type               *|
|*                                                                            *|
|* Output parameters:							      *|
|*	NONE								      *|
|*                                                                            *|
|* Returns:								      *|
|*	TRUE is statement parsed okay.  (There may be fatal errors. )         *|
|*	FALSE if first token is not INTEGER, REAL, COMPLEX, LOGICAL, TYPE     *|
|*	      DOUBLE or CHARACTER.  ATD_TYPE_IDX will be NULL??               *|
|*	FALSE if this is found to be an assignment statement.                 *|
|*	Note: In case of error and stmt_type is known, the only searching     *|
|*	      will be for a right paren, if a left one has been found.        *|
|*                                                                            *|
\******************************************************************************/

boolean parse_type_spec(boolean chk_kind, boolean proc_ok, boolean func_type)

{
   int			 al_idx;
   int			 attr_idx;
   int			 column;
   boolean		 do_kind_first;
   boolean		 double_precision	= FALSE;
   int			 host_attr_idx;
   int			 host_name_idx;
   int			 line;
   int			 name_idx;
   boolean		 parse_err		= FALSE;
   boolean		 save_err		= FALSE;
   boolean		 type_done		= FALSE;
#ifndef KEY /* Bug 8422 */
   long			 num;
   linear_type_type	 linear_type;
   int			 type_idx;
   char			*type_str;
#endif /* KEY Bug 8422 */


   TRACE (Func_Entry, "parse_type_spec", NULL);
   
   if (SH_ERR_FLG(curr_stmt_sh_idx)) {
      SH_ERR_FLG(curr_stmt_sh_idx)	= FALSE;
      save_err				= TRUE;
   }

   CLEAR_ATTR_NTRY(AT_WORK_IDX);

   switch (TOKEN_VALUE(token)) {
   case Tok_Kwd_Byte:
      PRINTMSG(TOKEN_LINE(token), 1253, Ansi, TOKEN_COLUMN(token), "BYTE");
      ATD_TYPE_IDX(AT_WORK_IDX) = Integer_1;
      break;

   case Tok_Kwd_Integer:
      ATD_TYPE_IDX(AT_WORK_IDX) = INTEGER_DEFAULT_TYPE;
      break;

   case Tok_Kwd_Real:
      ATD_TYPE_IDX(AT_WORK_IDX) = REAL_DEFAULT_TYPE;
      break;

   case Tok_Kwd_Complex:
      ATD_TYPE_IDX(AT_WORK_IDX) = COMPLEX_DEFAULT_TYPE;
      break;

   case Tok_Kwd_Logical:
      ATD_TYPE_IDX(AT_WORK_IDX) = LOGICAL_DEFAULT_TYPE;
      break;

   case Tok_Kwd_Procedure:
      if (proc_ok) {
	  ATD_TYPE_IDX(AT_WORK_IDX) = pp_type_index();
	  AT_TYPED(AT_WORK_IDX) = TRUE;
	  return parse_procedure_interface_spec();
      }

      PRINTMSG(TOKEN_LINE(token), 197, Error, TOKEN_COLUMN(token),
               "INTEGER, REAL, DOUBLE, COMPLEX, LOGICAL, CHARACTER or TYPE",
               TOKEN_STR(token));

      return FALSE;

   case Tok_Kwd_Character:
      line			= TOKEN_LINE(token);
      column			= TOKEN_COLUMN(token);
      ATD_TYPE_IDX(AT_WORK_IDX)	= CHARACTER_DEFAULT_TYPE;

      if (LA_CH_VALUE == LPAREN) {

         if (chk_kind) {
            NEXT_LA_CH;				/* Skip LPAREN */
            do_kind_first = FALSE;

            if (LA_CH_VALUE == 'K' &&
                matched_specific_token(Tok_Kwd_Kind, Tok_Class_Keyword)) {

               if (LA_CH_VALUE == EQUAL) {
                  do_kind_first = TRUE;
               }
               reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
            }

            if (do_kind_first) {
               parse_kind_selector(FALSE);

               if (LA_CH_VALUE == COMMA) {
                  NEXT_LA_CH;			/* Skip comma */

                  /* We can have length equal and we are parsing the */
                  /* length selector.  Hence  TRUE, TRUE.            */

                  parse_length_selector(AT_WORK_IDX, TRUE, TRUE);
                  TYP_DCL_VALUE(TYP_WORK_IDX)	= TYP_DCL_VALUE(ATD_TYPE_IDX(
                                                                AT_WORK_IDX));
                  TYP_DESC(TYP_WORK_IDX) = TYP_DESC(ATD_TYPE_IDX(AT_WORK_IDX));
                  ATD_TYPE_IDX(AT_WORK_IDX) = ntr_type_tbl();
               }
            }
            else {

               /* We can have length equal and we are parsing the */
               /* length selector.  Hence  TRUE, TRUE.            */

               parse_length_selector(AT_WORK_IDX, TRUE, TRUE);
               ATD_TYPE_IDX(AT_WORK_IDX)	= ntr_type_tbl();

               if (LA_CH_VALUE == COMMA) {
                  NEXT_LA_CH;			/* Skip comma */
                  parse_kind_selector(FALSE);
               }
            }

            if (LA_CH_VALUE == RPAREN || parse_err_flush(Find_Rparen, ")")) {
               NEXT_LA_CH;			/* Skip Rparen */
            }
         }
      }
      else if (LA_CH_VALUE == STAR) {

         /* This can't have LEN =, so pass FALSE */
         /* TRUE means this is a length-selector */

         parse_length_selector(AT_WORK_IDX, FALSE, TRUE);
         ATD_TYPE_IDX(AT_WORK_IDX)	= ntr_type_tbl();
      }

      type_done = TRUE;
      break;


   case Tok_Kwd_Double:
      line	= TOKEN_LINE(token);
      column	= TOKEN_COLUMN(token);

      if (LA_CH_VALUE == 'C' &&
          matched_specific_token(Tok_Kwd_Complex, Tok_Class_Keyword)) {

# if defined(_TARGET_OS_MAX)

         if (!on_off_flags.enable_double_precision) {
            PRINTMSG(line, 20, Ansi, column);
         }
         else if (cmd_line_flags.s_default32) {

            /* Use DOUBLE COMPLEX because -sdefault32 is built into the macro.*/

            PRINTMSG(line, 20, Ansi, column);
         }
         else {
            PRINTMSG(line, 702, Error, column);
         }
# else
         PRINTMSG(line, 20, Ansi, column);
# endif

         ATD_TYPE_IDX(AT_WORK_IDX)	= DOUBLE_COMPLEX_TYPE_IDX;
         type_done			= TRUE;
      }
      else if (LA_CH_VALUE == 'P' &&
               matched_specific_token(Tok_Kwd_Precision, Tok_Class_Keyword)) {

         ATD_TYPE_IDX(AT_WORK_IDX)      = DOUBLE_PRECISION_TYPE_IDX;

# ifdef _TARGET_OS_MAX

         if (! cmd_line_flags.s_default32 &&
             on_off_flags.enable_double_precision) {
            PRINTMSG(line, 1110, Warning, column);
            ATD_TYPE_IDX(AT_WORK_IDX)	= REAL_DEFAULT_TYPE;
         }
# endif

         double_precision		= TRUE;

         if (LA_CH_VALUE != STAR) {     /* Kind is not allowed */
            type_done			= TRUE;
         }
      }
      else {
         type_done			= TRUE;
         ATD_TYPE_IDX(AT_WORK_IDX)	= DOUBLE_PRECISION_TYPE_IDX;
         parse_err_flush(Find_None, "COMPLEX or PRECISION");
      }
      break;


   case Tok_Kwd_Type:

      if (LA_CH_VALUE != LPAREN) {
         parse_err_flush(Find_None, "(");
         ATD_TYPE_IDX(AT_WORK_IDX) = TYPELESS_DEFAULT_TYPE;
      }
      else {
         NEXT_LA_CH;				/* Skip Lparen */

         if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
            parse_err_flush(Find_Rparen, "type-name");
         }
         else if (LA_CH_VALUE == RPAREN) {
            attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token),
                                    &name_idx);

            if (attr_idx == NULL_IDX) {       /* search host sym table */
               host_attr_idx = srch_host_sym_tbl(TOKEN_STR(token),
                                                 TOKEN_LEN(token),
                                                 &host_name_idx,
                                                 FALSE);

               if (host_attr_idx == NULL_IDX) {
                  attr_idx			= ntr_sym_tbl(&token, name_idx);
                  AT_OBJ_CLASS(attr_idx)	= Derived_Type;
                  AT_LOCKED_IN(attr_idx)	= TRUE;
                  ATT_STRUCT_BIT_LEN_FLD(attr_idx)	= CN_Tbl_Idx;
                  ATT_STRUCT_BIT_LEN_IDX(attr_idx)	= CN_INTEGER_ZERO_IDX;
               }
               else if (stmt_type == Implicit_Stmt ||
                        stmt_type == Function_Stmt) {

                  /* Enter into the local scope, and link to the host's    */
                  /* attr.  Cannot lock in on this, because it may be      */
                  /* defined later in this scope.  Cannot issue error if   */
                  /* it's not a derived type for the same reason.          */
                  /* Catch AT_NOT_VISIBLE stuff when this is resolved.     */

                  /* ntr_host_in_sym_tbl just makes a new empty attr and   */
                  /* attr links it to the host_attr_idx.                   */

                  attr_idx = ntr_host_in_sym_tbl(&token,
                                                 name_idx,
                                                 host_attr_idx,
                                                 host_name_idx,
                                                 TRUE);

                  if (AT_OBJ_CLASS(host_attr_idx) == Derived_Type) {
                     COPY_ATTR_NTRY(attr_idx, host_attr_idx);
                     AT_CIF_SYMBOL_ID(attr_idx)	= 0;
                     AT_DEF_LINE(attr_idx)	= TOKEN_LINE(token);
                     AT_DEF_COLUMN(attr_idx)	= TOKEN_COLUMN(token);
                     AT_LOCKED_IN(attr_idx)	= FALSE;
                     AT_ATTR_LINK(attr_idx)	= host_attr_idx;
                  }
                  else {
                     AT_OBJ_CLASS(attr_idx)		= Derived_Type;
                     ATT_STRUCT_BIT_LEN_FLD(attr_idx)	= CN_Tbl_Idx;
                     ATT_STRUCT_BIT_LEN_IDX(attr_idx)	= CN_INTEGER_ZERO_IDX;
                  }
               }
               else if (AT_OBJ_CLASS(host_attr_idx) == Derived_Type &&
                        !AT_NOT_VISIBLE(host_attr_idx)) {

                  /* Lock into using the host definition */

                  attr_idx = ntr_host_in_sym_tbl(&token,
                                                 name_idx,
                                                 host_attr_idx,
                                                 host_name_idx,
                                                 TRUE);

                  COPY_ATTR_NTRY(attr_idx, host_attr_idx);
                  AT_CIF_SYMBOL_ID(attr_idx)	= 0;
                  AT_DEF_LINE(attr_idx)		= TOKEN_LINE(token);
                  AT_DEF_COLUMN(attr_idx)	= TOKEN_COLUMN(token);
                  AT_ATTR_LINK(attr_idx)	= host_attr_idx;
                  AT_LOCKED_IN(attr_idx)	= TRUE;
               }
               else if (!fnd_semantic_err(Obj_Use_Derived_Type, 
                                          TOKEN_LINE(token),
                                          TOKEN_COLUMN(token),
                                          host_attr_idx,
                                          TRUE)) {

                  /* Has just PUBLIC or PRIVATE set.  Lock into using the  */
                  /* host definition.                                      */

                  attr_idx = ntr_host_in_sym_tbl(&token,
                                                 name_idx,
                                                 host_attr_idx,
                                                 host_name_idx,
                                                 TRUE);

                  AT_DEF_LINE(attr_idx)		= TOKEN_LINE(token);
                  AT_DEF_COLUMN(attr_idx)	= TOKEN_COLUMN(token);
                  AT_LOCKED_IN(attr_idx)	= TRUE;
               }
               else {  /* Lock into this use.  Issue error - create new    */
                       /* local attr to hopefully prevent error escalation.*/
                       /* Need to make this a better msg, because it comes */
                       /* from the host.                                   */

                  attr_idx			= ntr_sym_tbl(&token, name_idx);
                  AT_OBJ_CLASS(attr_idx)	= Derived_Type;
                  AT_DCL_ERR(attr_idx)		= TRUE;
                  AT_LOCKED_IN(attr_idx)	= TRUE;
                  ATT_STRUCT_BIT_LEN_FLD(attr_idx)	= CN_Tbl_Idx;
                  ATT_STRUCT_BIT_LEN_IDX(attr_idx)	= CN_INTEGER_ZERO_IDX;
               }
            }
            else if (AT_OBJ_CLASS(attr_idx) == Derived_Type &&
                     !AT_NOT_VISIBLE(attr_idx)) {
               AT_LOCKED_IN(attr_idx)	= TRUE;
            }
            else if (AT_ATTR_LINK(attr_idx) != NULL_IDX) {
               host_attr_idx = AT_ATTR_LINK(attr_idx);

               while (AT_ATTR_LINK(host_attr_idx) != NULL_IDX) {
                  host_attr_idx = AT_ATTR_LINK(host_attr_idx);
               }

               if (AT_OBJ_CLASS(host_attr_idx) == Derived_Type) {
                  CLEAR_VARIANT_ATTR_INFO(attr_idx, Derived_Type);
                  ATT_STRUCT_BIT_LEN_FLD(attr_idx)	= CN_Tbl_Idx;
                  ATT_STRUCT_BIT_LEN_IDX(attr_idx)	= CN_INTEGER_ZERO_IDX;
                  AT_LOCKED_IN(attr_idx)	= TRUE;
               }
               else {
                  PRINTMSG(TOKEN_LINE(token), 956, Error, 
                           TOKEN_COLUMN(token),
                           AT_OBJ_NAME_PTR(attr_idx));
                  CREATE_ERR_ATTR(attr_idx, TOKEN_LINE(token),
                                            TOKEN_COLUMN(token),
                                            Derived_Type);
                  ATT_STRUCT_BIT_LEN_FLD(attr_idx)	= CN_Tbl_Idx;
                  ATT_STRUCT_BIT_LEN_IDX(attr_idx)	= CN_INTEGER_ZERO_IDX;

                  /* Switch the name table to use the new attr, to limit      */
                  /* cascading errors for derived type definitions.           */

                  LN_ATTR_IDX(name_idx)		= attr_idx;
                  LN_NAME_IDX(name_idx)		= AT_NAME_IDX(attr_idx);
                  AT_LOCKED_IN(attr_idx)	= TRUE;
               }
            }
            else if (!fnd_semantic_err(Obj_Use_Derived_Type,
                                       TOKEN_LINE(token),
                                       TOKEN_COLUMN(token),
                                       attr_idx,
                                       TRUE)) {

               /* Has just PUBLIC or PRIVATE set */

               CLEAR_VARIANT_ATTR_INFO(attr_idx, Derived_Type);
               ATT_STRUCT_BIT_LEN_FLD(attr_idx)	= CN_Tbl_Idx;
               ATT_STRUCT_BIT_LEN_IDX(attr_idx)	= CN_INTEGER_ZERO_IDX;
               AT_LOCKED_IN(attr_idx)	= TRUE;
            }
            else {
               CREATE_ERR_ATTR(attr_idx, TOKEN_LINE(token),
                                         TOKEN_COLUMN(token), 
                                         Derived_Type);
               ATT_STRUCT_BIT_LEN_FLD(attr_idx)	= CN_Tbl_Idx;
               ATT_STRUCT_BIT_LEN_IDX(attr_idx)	= CN_INTEGER_ZERO_IDX;

               /* Add replaced attr to cif error list, so it gets a cif rec */
               /* Switch the name table to use the new attr, to limit       */
               /* cascading errors for derived type definitions.            */

               NTR_ATTR_LIST_TBL(al_idx);
               AL_ATTR_IDX(al_idx)	= LN_ATTR_IDX(name_idx);
               AL_NEXT_IDX(al_idx)	= SCP_CIF_ERR_LIST(curr_scp_idx);
               SCP_CIF_ERR_LIST(curr_scp_idx)	= al_idx;

               LN_ATTR_IDX(name_idx)	= attr_idx;
               LN_NAME_IDX(name_idx)	= AT_NAME_IDX(attr_idx);
               AT_LOCKED_IN(attr_idx)	= TRUE;

            }

            if ((cif_flags & XREF_RECS) != 0) {
      
               if (AT_ATTR_LINK(attr_idx) == NULL_IDX) {
                  host_attr_idx = attr_idx;
               }
               else {
                  host_attr_idx = AT_ATTR_LINK(attr_idx);

                  while (AT_ATTR_LINK(host_attr_idx) != NULL_IDX) {
                     host_attr_idx = AT_ATTR_LINK(host_attr_idx);
                  }
               }

               cif_usage_rec(host_attr_idx, 
                             AT_Tbl_Idx,
                             TOKEN_LINE(token),
                             TOKEN_COLUMN(token),
                             CIF_Derived_Type_Name_Reference);
            }
            
            CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
            TYP_TYPE(TYP_WORK_IDX)	= Structure;
            TYP_LINEAR(TYP_WORK_IDX)	= Structure_Type;
            TYP_IDX(TYP_WORK_IDX)	= attr_idx;
            ATD_TYPE_IDX(AT_WORK_IDX)	= ntr_type_tbl();

            NEXT_LA_CH;			/* Skip Rparen */
         }
         else {
            ATD_TYPE_IDX(AT_WORK_IDX) = TYPELESS_DEFAULT_TYPE;
            parse_err_flush(Find_Rparen, ")");
         }
      }

      type_done = TRUE;
      break;


   default:
      ATD_TYPE_IDX(AT_WORK_IDX)	= TYPELESS_DEFAULT_TYPE;
      type_done			= TRUE;
      PRINTMSG(TOKEN_LINE(token), 197, Error, TOKEN_COLUMN(token),
               "INTEGER, REAL, DOUBLE, COMPLEX, LOGICAL, CHARACTER or TYPE",
               TOKEN_STR(token));
      break;

   }  /* end switch */
            
   AT_TYPED(AT_WORK_IDX) = TRUE;

   if (!type_done) {

      if (chk_kind && LA_CH_VALUE == LPAREN) {
           
         NEXT_LA_CH;			/* Skip Lparen */
         parse_kind_selector(func_type);

         if (LA_CH_VALUE == RPAREN || parse_err_flush(Find_Rparen,  ")")) {
            NEXT_LA_CH;			/* Skip Rparen */
         }
      }
      else if (LA_CH_VALUE == STAR) {
         NEXT_LA_CH;			/* Skip Star */

#ifdef KEY /* Bug 8422 */
      ATD_TYPE_IDX(AT_WORK_IDX) =
        parse_non_char_kind_selector(double_precision);
#endif /* KEY Bug 8422 */
      }
   }


#if 0

   /* LRR    2 Feb 1996							      */
   /* I turned off the following code in response to an email direction to do */
   /* so from Peggy Boike.  I did not remove the code due to the belief that  */
   /* we just might need to turn it back on.  If some months go by, and the   */
   /* libraries really can handle this, then the code should be safe to       */
   /* actually be removed.						      */

   if ((target_triton  &&  target_ieee)   &&
       (TYP_LINEAR(ATD_TYPE_IDX(AT_WORK_IDX)) == Real_16  ||
       TYP_LINEAR(ATD_TYPE_IDX(AT_WORK_IDX)) == Complex_16)) {

      /* Temporary warning because PRECISION may not be as high as requested */

      PRINTMSG(TOKEN_LINE(token), 1145, Warning, 0);
      SET_MSG_SUPPRESS_TBL(1145);  /* Issue once per compilation unit */
   }

#endif


   parse_err			= SH_ERR_FLG(curr_stmt_sh_idx);
   SH_ERR_FLG(curr_stmt_sh_idx) = save_err || parse_err;

   TRACE (Func_Exit, "parse_type_spec", NULL);

   return (!parse_err);

}  /* parse_type_spec */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Add the PUBLIC or PRIVATE attribute to an attr.			      *|
|*									      *|
|* Input parameters:							      *|
|*	attr_idx -> Attr index to add the PUBLIC or PRIVATE access to.        *|
|*	line     -> The line number of the object to add the attribute to     *|
|*	column   -> The line number of the object to add the attribute to     *|
|*	access   -> Public or Private                                         *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if successful merge.					      *|
|*									      *|
\******************************************************************************/

boolean merge_access(int		attr_idx,
	             int		line,
		     int		column,
		     access_type	access)

{
   boolean 	err_found;
   int		sn_idx;


   TRACE (Func_Entry, "merge_access", NULL);

   /* Error if access is already set, or if it is host associated */

   err_found = ((AT_ACCESS_SET(attr_idx) && access != AT_PRIVATE(attr_idx)) ||
                 AT_NOT_VISIBLE(attr_idx) ||
                (AT_ATTR_LINK(attr_idx) != NULL_IDX));

   switch (AT_OBJ_CLASS(attr_idx)) {
      case Data_Obj:

         if (ATD_SYMBOLIC_CONSTANT(attr_idx)) {
            err_found = TRUE;
         }
         break;

      case Pgm_Unit:
         if (ATP_PROC(attr_idx) == Intrin_Proc ||
             ATP_PGM_UNIT(attr_idx) == Program ||
             ATP_PGM_UNIT(attr_idx) == Module ||
             ATP_PGM_UNIT(attr_idx) == Blockdata) {
            err_found = TRUE;
         }
         break;

      case Interface:
         break;

      case Stmt_Func:
         err_found = TRUE;
         break;

      case Label:
         err_found = TRUE;
         break;

      default:
         break;

   }  /* end switch */


# ifdef _DEBUG

   /* Check to make sure that this routine is catching everything in the  */
   /* semantic tables, because it only calls fnd_semantic_err if it finds */
   /* an error.                                                           */

   if (!err_found &&
       fnd_semantic_err(((access == Public) ? Obj_Public : Obj_Private),
                        line, 
                        column,
                        attr_idx,
                        TRUE)) {
      PRINTMSG(line, 655, Internal, column, "merge_access");
   }
# endif

   if (err_found) {
      fnd_semantic_err(((access == Public) ? Obj_Public : Obj_Private),
                       line,
                       column,
                       attr_idx,
                       TRUE);
   }
   else {

      if (AT_ACCESS_SET(attr_idx)) {  /* Duplicate declaration */
#ifdef KEY /* Bug 5040 */
         PRINTMSG(line, 1259, ansi_or_warning(), column,
                  AT_OBJ_NAME_PTR(attr_idx), AT_DEF_LINE(attr_idx),
                  (access == Public) ? "PUBLIC":"PRIVATE");
#else /* KEY Bug 5040 */
         PRINTMSG(line, 1259, Ansi, column,
                  AT_OBJ_NAME_PTR(attr_idx),
                  (access == Public) ? "PUBLIC":"PRIVATE");
#endif /* KEY Bug 5040 */
      }

      AT_PRIVATE(attr_idx)	= access;
      AT_ACCESS_SET(attr_idx)	= TRUE;

      if (AT_OBJ_CLASS(attr_idx) == Interface) { 

         if (AT_IS_INTRIN(attr_idx)) {
            sn_idx	= ATI_FIRST_SPECIFIC_IDX(attr_idx);

            while (sn_idx != NULL_IDX) {

               if (AT_IS_INTRIN(SN_ATTR_IDX(sn_idx))) {
                  AT_PRIVATE(SN_ATTR_IDX(sn_idx))	= access;
                  AT_ACCESS_SET(SN_ATTR_IDX(sn_idx))	= TRUE;
               }
               sn_idx = SN_SIBLING_LINK(sn_idx);
            }
         }
         else if (ATI_PROC_IDX(attr_idx) != NULL_IDX) {
            AT_PRIVATE(ATI_PROC_IDX(attr_idx))		= access;
            AT_ACCESS_SET(ATI_PROC_IDX(attr_idx))	= TRUE;
         }
      }
   }

   TRACE (Func_Exit, "merge_access", NULL);

   return(!err_found);

}  /* merge_access */

#ifdef KEY /* Bug 5091 */
boolean merge_protected(boolean		chk_semantics,
	             int		line,
		     int		column,
		     int		attr_idx)

{
   boolean 	err_found;
   int		sn_idx;


   TRACE (Func_Entry, "merge_protected", NULL);

   boolean	chk_err		= FALSE;

   TRACE (Func_Entry, "merge_protected", NULL);

   if (chk_semantics) {
      chk_err = fnd_semantic_err(Obj_Protected, line, column, attr_idx, TRUE);

      if (!chk_err) {
        if ( AT_PROTECTED(attr_idx)) {
	  PRINTMSG(line, 1259, ansi_or_warning(), column,
	    AT_OBJ_NAME_PTR(attr_idx), AT_DEF_LINE(attr_idx), "PROTECTED");
	}
      AT_PROTECTED(attr_idx)	= TRUE;
      }
   }
   else {
      SET_IMPL_TYPE(attr_idx);
      AT_PROTECTED(attr_idx)	= TRUE;
   }

   TRACE (Func_Exit, "merge_protected", NULL);

   return(!chk_err);

}  /* merge_protected */
#endif /* KEY Bug 5091 */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Add the ALLOCATABLE attribute to an attr.			      *|
|*									      *|
|* Input parameters:							      *|
|*	chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
|*	                 is FALSE, just add the attribute to the attr.        *|
|*	line     -> The line number of the object to add the attribute to     *|
|*	column   -> The line number of the object to add the attribute to     *|
|*	attr_idx -> Attr index to add the ALLOCATABLE attribute to.           *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if successful merge.					      *|
|*									      *|
\******************************************************************************/

boolean merge_allocatable(boolean chk_semantics,
	                  int	  line,
		          int     column,
			  int	  attr_idx)

{
   boolean	fnd_err		= FALSE;


   TRACE (Func_Entry, "merge_allocatable", NULL);

#ifdef KEY /* Bug 6845 */
   /* Changes for bug 6845 imitate function merge_pointer(); we need to
    * deal with the situation where the "allocatable" statement is the first
    * clue that the current procedure is a function, etc. */
   if (AT_OBJ_CLASS(attr_idx) == Interface && 
       ATI_PROC_IDX(attr_idx) != NULL_IDX) {
       attr_idx = ATI_PROC_IDX(attr_idx);
   }
#endif /* KEY Bug 6845 */

   if (chk_semantics) {
#ifdef KEY /* Bug 6845 */
      if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit && ATP_RSLT_NAME(attr_idx)) {
         PRINTMSG(line, 36, Error, column, AT_OBJ_NAME_PTR(attr_idx),
                  AT_OBJ_NAME_PTR(ATP_RSLT_IDX(attr_idx)));
         fnd_err                = TRUE;
         AT_DCL_ERR(attr_idx)   = TRUE;
      }
      else {
	fnd_err = fnd_semantic_err(Obj_Allocatable, line, column, attr_idx,
				   TRUE);
      }

      if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit ||
	ATD_CLASS(attr_idx) == Function_Result) {
	PRINTMSG(line, 1679, Ansi, column);
      }

      if (!fnd_err && AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {

         if (ATP_RSLT_IDX(attr_idx) == NULL_IDX) {
	    int rslt_idx = NULL_IDX;
            CREATE_FUNC_RSLT(attr_idx, rslt_idx);
            ATP_PGM_UNIT(attr_idx)      = Function;
            SET_IMPL_TYPE(rslt_idx);
            attr_idx                    = rslt_idx;
         }
         else {
            attr_idx = ATP_RSLT_IDX(attr_idx);
            fnd_err  = fnd_semantic_err(Obj_Pointer, line, column, attr_idx,
                                        TRUE);
         }
      }
#else /* KEY Bug 6845 */
	fnd_err = fnd_semantic_err(Obj_Allocatable,
				   line,
				   column,
				   attr_idx,
				   TRUE);
#endif /* KEY Bug 6845 */

      if (!fnd_err) {

         if (ATD_ALLOCATABLE(attr_idx)) {
#ifdef KEY /* Bug 5040 */
            PRINTMSG(line, 1259, ansi_or_warning(), column,
                     AT_OBJ_NAME_PTR(attr_idx), AT_DEF_LINE(attr_idx),
                     "ALLOCATABLE");
#else /* KEY Bug 5040 */
            PRINTMSG(line, 1259, Ansi, column,
                     AT_OBJ_NAME_PTR(attr_idx),
                     "ALLOCATABLE");
#endif /* KEY Bug 5040 */
         }
         ATD_ALLOCATABLE(attr_idx) = TRUE;
         ATD_IM_A_DOPE(attr_idx)   = TRUE;
      }
   }
   else {
      SET_IMPL_TYPE(attr_idx);
      ATD_ALLOCATABLE(attr_idx) = TRUE;
      ATD_IM_A_DOPE(attr_idx)   = TRUE;
   }


   TRACE (Func_Exit, "merge_allocatable", NULL);

   return(!fnd_err);

}  /* merge_allocatable */



/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Add the AUTOMATIC attribute to an attr.				      *|
|*									      *|
|* Input parameters:							      *|
|*	chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
|*	                 is FALSE, just add the attribute to the attr.        *|
|*	line     -> The line number of the object to add the attribute to     *|
|*	column   -> The line number of the object to add the attribute to     *|
|*	attr_idx -> Attr index to add the AUTOMATIC attribute to.             *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if successful merge.					      *|
|*									      *|
\******************************************************************************/

boolean merge_automatic(boolean		chk_semantics,
	                int		line,
		        int		column,
			int		attr_idx)

{
   boolean	fnd_err		= FALSE;
   int		rslt_idx;


   TRACE (Func_Entry, "merge_automatic", NULL);

   if (chk_semantics) {
      fnd_err = fnd_semantic_err(Obj_Automatic,
                                 line,
                                 column,
                                 attr_idx,
                                 TRUE);

      if (!fnd_err && AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {

         if (ATP_RSLT_IDX(attr_idx) == NULL_IDX) {
            CREATE_FUNC_RSLT(attr_idx, rslt_idx);
            ATP_PGM_UNIT(attr_idx)	= Function;
            SET_IMPL_TYPE(rslt_idx);
            attr_idx			= rslt_idx;
         }
         else {
            attr_idx = ATP_RSLT_IDX(attr_idx);
            fnd_err  = fnd_semantic_err(Obj_Automatic, 
                                        line,
                                        column,
                                        attr_idx,
                                        TRUE);
         }
      }

      if (!fnd_err && ATD_CLASS(attr_idx) == Function_Result &&
          (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character ||
           TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure ||
           ATD_ARRAY_IDX(attr_idx) != NULL_IDX ||
           ATD_POINTER(attr_idx))) {
         AT_DCL_ERR(attr_idx)	= TRUE;
         fnd_err			= TRUE;
         PRINTMSG(line, 1255, Error, column, AT_OBJ_NAME_PTR(attr_idx));
      }

      if (!fnd_err) {

         if (ATD_STACK(attr_idx)) {
#ifdef KEY /* Bug 5040 */
            PRINTMSG(line, 1259, ansi_or_warning(), column,
                     AT_OBJ_NAME_PTR(attr_idx), AT_DEF_LINE(attr_idx),
                     "AUTOMATIC");
#else /* KEY Bug 5040 */
            PRINTMSG(line, 1259, Ansi, column,
                     AT_OBJ_NAME_PTR(attr_idx),
                     "AUTOMATIC");
#endif /* KEY Bug 5040 */
         }
         ATD_STACK(attr_idx) = TRUE;
      }
   }
   else {
      SET_IMPL_TYPE(attr_idx);
      ATD_STACK(attr_idx) = TRUE;
   }

   TRACE (Func_Exit, "merge_automatic", NULL);

   return(!fnd_err);

}  /* merge_automatic */

#ifdef KEY /* Bug 14150 */
/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Add the BIND attribute to an attr. Imitating the (bad) example of     *|
|*      merge_intent(), the binding label comes from a global variable.       *|
|*	Note that common (sb_idx) is handled elsewhere, not here.             *|
|*									      *|
|* Input parameters:							      *|
|*	chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
|*	                 is FALSE, just add the attribute to the attr.        *|
|*	line     -> The line number of the object to add the attribute to     *|
|*	column   -> The line number of the object to add the attribute to     *|
|*	attr_idx -> Attr index to add the BIND attribute to.                  *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if successful merge.					      *|
|*									      *|
\******************************************************************************/

boolean merge_bind(boolean		chk_semantics,
	                int		line,
		        int		column,
			int		attr_idx)

{
   boolean fnd_err  = FALSE;
   TRACE (Func_Entry, "merge_bind", NULL);

   if (chk_semantics) {
     fnd_err = fnd_semantic_err(Obj_Bind, line, column, attr_idx, TRUE);
   }
   else if (!fnd_err && AT_BIND_ATTR(attr_idx)) {
     /* Make this an error, not warning, because it's not a legacy feature, and
      * binding labels might not match if we allow redundant "bind" */
     PRINTMSG(line, 1259, Error, column, AT_OBJ_NAME_PTR(attr_idx),
       AT_DEF_LINE(attr_idx), "BIND");
  }

  if (!fnd_err) {
    if (ATD_TYPE_IDX(attr_idx) == NULL_IDX) {
      SET_IMPL_TYPE(attr_idx);
    }
    set_binding_label(AT_Tbl_Idx, attr_idx, &new_binding_label);
  }

  TRACE (Func_Exit, "merge_bind", NULL);
  return !fnd_err;
}  /* merge_bind */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Add the VALUE attribute to an attr                                    *|
|*									      *|
|* Input parameters:							      *|
|*	chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
|*	                 is FALSE, just add the attribute to the attr.        *|
|*	line     -> The line number of the object to add the attribute to     *|
|*	column   -> The line number of the object to add the attribute to     *|
|*	attr_idx -> Attr index to add the VALUE attribute to.                 *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if successful merge.					      *|
|*									      *|
\******************************************************************************/

boolean merge_value(boolean		chk_semantics,
	                int		line,
		        int		column,
			int		attr_idx)

{
   boolean fnd_err  = FALSE;
   TRACE (Func_Entry, "merge_value", NULL);

   if (chk_semantics) {
     fnd_err = fnd_semantic_err(Obj_Value, line, column, attr_idx, TRUE);
     if (!fnd_err) {
       if (ATD_CLASS(attr_idx) == Dummy_Argument && ATD_VALUE_ATTR(attr_idx)) {
	 /* Make this error, not warning, because it's not a legacy feature */
	 PRINTMSG(line, 1259, Error, column, AT_OBJ_NAME_PTR(attr_idx),
	   AT_DEF_LINE(attr_idx), "VALUE");
	 fnd_err = TRUE;
       }
       else if (ATD_INTENT(attr_idx) == Intent_Out ||
         ATD_INTENT(attr_idx) == Intent_Inout) {
	 PRINTMSG(line, 550, Error, column, AT_OBJ_NAME_PTR(attr_idx),
	   "VALUE", "INTENT(OUT)", AT_DEF_LINE(attr_idx));
	 fnd_err = TRUE;
       }
     }
   }
   else {
      SET_IMPL_TYPE(attr_idx);
   }

  if (!fnd_err) {
     /* Imitate merge_intent(). attr_semantics() detects use of "intent" or
      * "value" on non-dummy */
     ATD_CLASS(attr_idx) = Dummy_Argument;
     ATD_VALUE_ATTR(attr_idx) = TRUE;
  }

  TRACE (Func_Exit, "merge_value", NULL);
  return !fnd_err;
}  /* merge_value */
#endif /* KEY Bug 14150 */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Add the DIMENSION attribute to an attr.			      	      *|
|*									      *|
|* Input parameters:							      *|
|*	attr_idx -> Attr index to add the ALLOCATABLE attribute to.           *|
|*	line     -> The line number of the object to add the attribute to     *|
|*	column   -> The line number of the object to add the attribute to     *|
|*	array_idx-> The index of the bounds table index to add to the attr.   *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if successful merge.					      *|
|*									      *|
\******************************************************************************/

boolean merge_dimension(int	attr_idx,
	                int	line,
		        int	column,
                        int	array_idx)

{
#ifdef KEY /* Bug 10177 */
   obj_type		dcl_type = Obj_Done;
   boolean		err_fnd = FALSE;
#else /* KEY Bug 10177 */
   obj_type		dcl_type;
   boolean		err_fnd;
#endif /* KEY Bug 10177 */
   int			i;
   int			old_bd_idx;
   int			rslt_idx;
   boolean		same;


   TRACE (Func_Entry, "merge_dimension", NULL);

   if (BD_DCL_ERR(array_idx)) {  /* Don't try if bad array declaration */
      AT_DCL_ERR(attr_idx)	= TRUE;
      err_fnd			= TRUE;
      goto EXIT;
   }
       
   switch (BD_ARRAY_CLASS(array_idx)) {

      case Explicit_Shape:
         dcl_type = Obj_Expl_Shp_Arr;
         break;

      case Deferred_Shape:
         dcl_type = Obj_Defrd_Shp_Arr;
         break;

      case Assumed_Size:
         dcl_type = Obj_Assum_Size_Arr;
         break;

      case Assumed_Shape:
         dcl_type = Obj_Assum_Shp_Arr;
         break;

   }  /* End switch */

   if (AT_OBJ_CLASS(attr_idx) == Interface && 
       ATI_PROC_IDX(attr_idx) != NULL_IDX) {
       attr_idx = ATI_PROC_IDX(attr_idx);
   }

   if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit && ATP_PGM_UNIT(attr_idx) != Module) {
      rslt_idx = ATP_RSLT_IDX(attr_idx);

      if (rslt_idx != NULL_IDX) {	/* Has a function result already */

         if (ATP_RSLT_NAME(attr_idx) && !AT_NOT_VISIBLE(attr_idx)) {
            PRINTMSG(line, 27, Error, column, AT_OBJ_NAME_PTR(attr_idx),
                     AT_OBJ_NAME_PTR(rslt_idx));
            AT_DCL_ERR(attr_idx)	= TRUE;
            AT_DCL_ERR(rslt_idx)	= TRUE;
         }
         else {

            if (AT_REFERENCED(attr_idx) > Not_Referenced &&
                is_attr_referenced_in_bound(array_idx, attr_idx)) {
               err_fnd	= TRUE;
            }
            else {
               err_fnd = fnd_semantic_err(dcl_type,
                                          line,
                                          column,
                                          attr_idx,
                                          TRUE);
            }

            if (!err_fnd) {

               if (ATD_ARRAY_IDX(rslt_idx) != NULL_IDX) {

                  /* This has an array declaration already.  Is it the same? */

                  old_bd_idx	= ATD_ARRAY_IDX(rslt_idx);
                  same		= (old_bd_idx == array_idx);

                  if (!same && 
                      BD_ARRAY_CLASS(old_bd_idx)==BD_ARRAY_CLASS(array_idx)&&
                      BD_RANK(old_bd_idx) == BD_RANK(array_idx) &&
                      BD_ARRAY_SIZE(old_bd_idx) == BD_ARRAY_SIZE(array_idx)){

                     if (BD_ARRAY_CLASS(array_idx) != Deferred_Shape) {
                        same	= TRUE;

                        for (i = 1; i <= BD_RANK(array_idx); i++) {

                           if (BD_UB_FLD(old_bd_idx,i)!=BD_UB_FLD(array_idx,i)||
                               (BD_UB_FLD(old_bd_idx,i) == AT_Tbl_Idx &&
                              BD_UB_IDX(old_bd_idx,i)!=BD_UB_IDX(array_idx,i))||
                               (BD_UB_FLD(old_bd_idx,i) == CN_Tbl_Idx &&
                                fold_relationals(BD_UB_IDX(old_bd_idx,i),
                                                 BD_UB_IDX(array_idx,i),
                                                 Ne_Opr)) ||
                               BD_LB_FLD(old_bd_idx,i)!=BD_LB_FLD(array_idx,i)||
                               (BD_LB_FLD(old_bd_idx,i) == AT_Tbl_Idx &&
                              BD_LB_IDX(old_bd_idx,i)!=BD_LB_IDX(array_idx,i))||
                               (BD_LB_FLD(old_bd_idx,i) == CN_Tbl_Idx &&
                                fold_relationals(BD_LB_IDX(old_bd_idx,i),
                                                 BD_LB_IDX(array_idx,i),
                                                 Ne_Opr))) {
                              same	= FALSE;
                              break;
                           }
                        }
                     }
                  }

                  if (same) {
#ifdef KEY /* Bug 5040 */
                     PRINTMSG(line, 1259, ansi_or_warning(), column, 
                              AT_OBJ_NAME_PTR(rslt_idx), AT_DEF_LINE(attr_idx),
			      "DIMENSION");
                  }
                  else {
                     PRINTMSG(line, 554, Error, column, 
                              AT_OBJ_NAME_PTR(rslt_idx), "DIMENSION",
                              "DIMENSION", AT_DEF_LINE(rslt_idx));
#else /* KEY Bug 5040 */
                     PRINTMSG(line, 1259, Ansi, column, 
                              AT_OBJ_NAME_PTR(rslt_idx), "DIMENSION");
                  }
                  else {
                     PRINTMSG(line, 554, Error, column, 
                              AT_OBJ_NAME_PTR(rslt_idx), "DIMENSION",
                              "DIMENSION");
#endif /* KEY Bug 5040 */
                  }
               }
               else {
                  ATD_ARRAY_IDX(rslt_idx) = array_idx;
               }
            }

            if (ATP_RECURSIVE(attr_idx) && !on_off_flags.recursive) {
               PRINTMSG(line, 184, Caution, column, AT_OBJ_NAME_PTR(attr_idx));
            }
         }
      }
      else {

         if (AT_REFERENCED(attr_idx) > Not_Referenced &&
             is_attr_referenced_in_bound(array_idx, attr_idx)) {
            err_fnd	= TRUE;
         }
         else {
            err_fnd = fnd_semantic_err(dcl_type,
                                       line,
                                       column,
                                       attr_idx,
                                       TRUE);
         }

         /* This must be a Function if it's legal */

         if (!err_fnd) {
            CREATE_FUNC_RSLT(attr_idx, rslt_idx);
            ATP_PGM_UNIT(attr_idx)	= Function;
            ATD_ARRAY_IDX(rslt_idx)	= array_idx;
            SET_IMPL_TYPE(rslt_idx);
         }
      }
   }
   else {
      if (AT_REFERENCED(attr_idx) > Not_Referenced &&
          is_attr_referenced_in_bound(array_idx, attr_idx)) {
         err_fnd	= TRUE;
      }
      else {
         err_fnd = fnd_semantic_err(dcl_type,
                                    line,
                                    column,
                                    attr_idx,
                                    TRUE);
      }
         
      if (!err_fnd) {

         if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {

            /* This has an array declaration already.  Is it the same? */

            old_bd_idx	= ATD_ARRAY_IDX(attr_idx);
            same	= (old_bd_idx == array_idx);

            if (!same && 
                BD_ARRAY_CLASS(old_bd_idx) == BD_ARRAY_CLASS(array_idx) &&
                BD_RANK(old_bd_idx) == BD_RANK(array_idx) &&
                BD_ARRAY_SIZE(old_bd_idx) == BD_ARRAY_SIZE(array_idx)) {

               if (BD_ARRAY_CLASS(array_idx) != Deferred_Shape) {
                  same	= TRUE;

                  for (i = 1; i <= BD_RANK(array_idx); i++) {

                     if (BD_UB_FLD(old_bd_idx,i) != BD_UB_FLD(array_idx,i)||
                         (BD_UB_FLD(old_bd_idx,i) == AT_Tbl_Idx &&
                          BD_UB_IDX(old_bd_idx,i) != BD_UB_IDX(array_idx,i))||
                         (BD_UB_FLD(old_bd_idx,i) == CN_Tbl_Idx &&
                          fold_relationals(BD_UB_IDX(old_bd_idx,i),
                                           BD_UB_IDX(array_idx,i),
                                           Ne_Opr)) ||
                         BD_LB_FLD(old_bd_idx,i) != BD_LB_FLD(array_idx,i)||
                         (BD_LB_FLD(old_bd_idx,i) == AT_Tbl_Idx &&
                          BD_LB_IDX(old_bd_idx,i) != BD_LB_IDX(array_idx,i))||
                         (BD_LB_FLD(old_bd_idx,i) == CN_Tbl_Idx &&
                          fold_relationals(BD_LB_IDX(old_bd_idx,i),
                                           BD_LB_IDX(array_idx,i),
                                           Ne_Opr))) {

                        same	= FALSE;
                        break;
                     }
                  }
               }
            }

            if (same) {
#ifdef KEY /* Bug 5040 */
               PRINTMSG(line, 1259, ansi_or_warning(), column, 
                        AT_OBJ_NAME_PTR(attr_idx), AT_DEF_LINE(attr_idx),
			"DIMENSION");
            }
            else {
               PRINTMSG(line, 554, Error, column, 
                        AT_OBJ_NAME_PTR(attr_idx), "DIMENSION", "DIMENSION",
			AT_DEF_LINE(attr_idx));
#else /* KEY Bug 5040 */
               PRINTMSG(line, 1259, Ansi, column, 
                        AT_OBJ_NAME_PTR(attr_idx), "DIMENSION");
            }
            else {
               PRINTMSG(line, 554, Error, column, 
                        AT_OBJ_NAME_PTR(attr_idx), "DIMENSION", "DIMENSION");
#endif /* KEY Bug 5040 */
            }
         }
         else {
            ATD_ARRAY_IDX(attr_idx)	= array_idx;

            if (BD_ARRAY_CLASS(array_idx) == Assumed_Shape ||
                BD_ARRAY_CLASS(array_idx) == Deferred_Shape) {

               ATD_IM_A_DOPE(attr_idx) = TRUE;
            }
         }
      }
   }

EXIT:

   TRACE (Func_Exit, "merge_dimension", NULL);

   return(!err_fnd);

}  /* merge_dimension */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Add the DATA or initialization attribute to an Attr.		      *|
|*      As long as we're here, also mark the Attr as being defined.	      *|
|*									      *|
|* Input parameters:							      *|
|*	chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
|*	                 is FALSE, just add the attribute to the Attr.        *|
|*	line     -> The line number of the object to add the attribute to.    *|
|*	column   -> The line number of the object to add the attribute to.    *|
|*	attr_idx -> Attr index to add the DATA attribute to.                  *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if successful merge.					      *|
|*									      *|
\******************************************************************************/

boolean merge_data(boolean	chk_semantics,
	           int		line,
		   int		column,
		   int		attr_idx)

{
   boolean	fnd_err 	= FALSE;


   TRACE (Func_Entry, "merge_data", NULL);
   
   if (chk_semantics) {
      fnd_err = fnd_semantic_err(Obj_Data_Init,
                                 line,
                                 column,
                                 attr_idx,
                                 TRUE);
   }

   if (!fnd_err) {
      AT_DEFINED(attr_idx)    = TRUE;
      ATD_DATA_INIT(attr_idx) = TRUE;
      ATD_CLASS(attr_idx)     = Variable;
   }

   TRACE (Func_Exit, "merge_data", NULL);

   return(!fnd_err);

}  /* merge_data */



/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Add the EXTERNAL attribute to an attr.			      	      *|
|*									      *|
|* Input parameters:							      *|
|*	chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
|*	                 is FALSE, just add the attribute to the attr.        *|
|*	line     -> The line number of the object to add the attribute to     *|
|*	column   -> The line number of the object to add the attribute to     *|
|*	attr_idx -> Attr index to add the EXTERNAL attribute to.              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if successful merge.					      *|
|*									      *|
\******************************************************************************/

boolean merge_external(boolean	chk_semantics,
		       int	line,
		       int	column,
		       int	attr_idx)

{
   long		chk_err		= FALSE;


   TRACE (Func_Entry, "merge_external", NULL);

   if (AT_OBJ_CLASS(attr_idx) == Interface && 
       !AT_IS_INTRIN(attr_idx) &&		/* JBL  - this is a kludge */
       ATI_PROC_IDX(attr_idx) != NULL_IDX) {
       attr_idx = ATI_PROC_IDX(attr_idx);
   }

   if (chk_semantics && fnd_semantic_err(Obj_Dcl_Extern,
                                         line,
                                         column,
                                         attr_idx,
                                         TRUE)) {
      chk_err = TRUE;
   }
   else {

#ifdef KEY /* Bug 14150 */
      /* fnd_semantic_err() detects addition of bind to external, not vice
       * versa */
      if ((!(AT_OBJ_CLASS(attr_idx) == Data_Obj && 
	ATD_CLASS(attr_idx) == Dummy_Argument)) &&
	AT_BIND_ATTR(attr_idx)) {
	PRINTMSG(line, 550, Error, column, AT_OBJ_NAME_PTR(attr_idx), "BIND",
	  "EXTERNAL", AT_DEF_LINE(attr_idx));
	chk_err = TRUE;
      }
  #endif /* KEY Bug 14150 */

      if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {

         /* By passing Pgm_Unknown, chg_data_obj_to_pgm_unit will decide */
         /* if this attr, should become a Function or a Pgm_Unknown.     */

         chg_data_obj_to_pgm_unit(attr_idx, 
                                  Pgm_Unknown,
                                  Extern_Proc);
      }
      else {

         if (ATP_DCL_EXTERNAL(attr_idx)) {
#ifdef KEY /* Bug 5040 */
            PRINTMSG(line, 1259, ansi_or_warning(), column, 
                     AT_OBJ_NAME_PTR(attr_idx), AT_DEF_LINE(attr_idx),
                     "EXTERNAL");
#else /* KEY Bug 5040 */
            PRINTMSG(line, 1259, Ansi, column, 
                     AT_OBJ_NAME_PTR(attr_idx),
                     "EXTERNAL");
#endif /* KEY Bug 5040 */
         }

         if (ATP_PROC(attr_idx) == Unknown_Proc) {
            ATP_PROC(attr_idx) = Extern_Proc;
         }

         if (attr_idx == SCP_ATTR_IDX(curr_scp_idx)) {

            /* SUBROUTINE JOE(); EXTERNAL JOE   is non-standard. */
   
            PRINTMSG(line, 279, Ansi, column, AT_OBJ_NAME_PTR(attr_idx));
         }
      }

      ATP_DCL_EXTERNAL(attr_idx)	= TRUE;
      ATP_SCP_IDX(attr_idx)		= curr_scp_idx;
   }

   TRACE (Func_Exit, "merge_external", NULL);

   return(!chk_err);

}  /* merge_external */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Add the INTENT attribute to an attr.			      	      *|
|*      NOTE:  The intent to add is picked up from a global variable, called  *|
|*             new_intent.                                                    *|
|*									      *|
|* Input parameters:							      *|
|*	chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
|*	                 is FALSE, just add the attribute to the attr.        *|
|*	line     -> The line number of the object to add the attribute to     *|
|*	column   -> The line number of the object to add the attribute to     *|
|*	attr_idx -> Attr index to add the EXTERNAL attribute to.              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if successful merge.					      *|
|*									      *|
\******************************************************************************/

boolean merge_intent(boolean		chk_semantics,
	             int		line,
		     int		column,
		     int		attr_idx)

{
   boolean	fnd_err		= FALSE;


   TRACE (Func_Entry, "merge_intent", NULL);

   if (AT_OBJ_CLASS(attr_idx) == Interface && 
       ATI_PROC_IDX(attr_idx) != NULL_IDX) {
       attr_idx = ATI_PROC_IDX(attr_idx);
   }
   
   if (chk_semantics) {
      fnd_err = fnd_semantic_err(Obj_Intent,
                                 line,
                                 column,
                                 attr_idx,
                                 TRUE);

      if (!fnd_err) {

#ifdef KEY /* Bug 14110, 14150 */
         if (new_intent == Intent_In) {
	   if (ATD_VOLATILE(attr_idx)) {
	     PRINTMSG(line, 550, Error, column, AT_OBJ_NAME_PTR(attr_idx),
	       "VOLATILE", "INTENT(IN)", AT_DEF_LINE(attr_idx));
	   }
	 }
	 else {
	   if (ATD_VALUE_ATTR(attr_idx)) {
	     PRINTMSG(line, 550, Error, column, AT_OBJ_NAME_PTR(attr_idx),
	       "VALUE", "INTENT(OUT)", AT_DEF_LINE(attr_idx));
	   }
	 }
#endif /* KEY Bug 14110, 14150 */

         if (ATD_INTENT(attr_idx) != Intent_Unseen) {

            if (ATD_INTENT(attr_idx) == new_intent) {
#ifdef KEY /* Bug 5040 */
               PRINTMSG(line, 1259, ansi_or_warning(), column,
	         AT_OBJ_NAME_PTR(attr_idx), AT_DEF_LINE(attr_idx), "INTENT");
            }
            else {  /* The intent is different */
               PRINTMSG(line, 554, Error, column, AT_OBJ_NAME_PTR(attr_idx),
                        "INTENT", "INTENT", AT_DEF_LINE(attr_idx));
#else /* KEY Bug 5040 */
               PRINTMSG(line, 1259, Ansi, column, AT_OBJ_NAME_PTR(attr_idx),
                        "INTENT");
            }
            else {  /* The intent is different */
               PRINTMSG(line, 554, Error, column, AT_OBJ_NAME_PTR(attr_idx),
                        "INTENT", "INTENT");
#endif /* KEY Bug 5040 */
            }
         }
      }
   }
   else {
      SET_IMPL_TYPE(attr_idx);
   }

   if (!fnd_err) {
      ATD_CLASS(attr_idx)	= Dummy_Argument;
      ATD_INTENT(attr_idx)	= new_intent;
   }

   TRACE (Func_Exit, "merge_intent", NULL);

   return(!fnd_err);

}  /* merge_intent */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Add the INTRINSIC attribute to an attr.			      	      *|
|*									      *|
|* Input parameters:							      *|
|*	chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
|*	                 is FALSE, just add the attribute to the attr.        *|
|*	line     -> The line number of the object to add the attribute to     *|
|*	column   -> The line number of the object to add the attribute to     *|
|*	attr_idx -> Attr index to add the EXTERNAL attribute to.              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if successful merge.					      *|
|*									      *|
\******************************************************************************/

boolean merge_intrinsic(boolean	chk_semantics,
	                int	line,
		        int	column,
			int	attr_idx)

{
   boolean	found_error	= FALSE;
   int		save_curr_scp_idx;
   int		host_name_idx;
   int		host_attr_idx;
   int		sn_idx;
   int		type_idx;


   TRACE (Func_Entry, "merge_intrinsic", NULL);

   if (chk_semantics && fnd_semantic_err(Obj_Dcl_Intrin, 
                                         line, 
                                         column, 
                                         attr_idx,
                                         TRUE)) {
      found_error = TRUE;
   }
   else if (AT_IS_INTRIN(attr_idx) && AT_OBJ_CLASS(attr_idx) == Interface) {

      if (ATI_DCL_INTRINSIC(attr_idx)) {
#ifdef KEY /* Bug 5040 */
         PRINTMSG(line, 1259, ansi_or_warning(), column,
	   AT_OBJ_NAME_PTR(attr_idx), AT_DEF_LINE(attr_idx), "INTRINSIC");
#else /* KEY Bug 5040 */
         PRINTMSG(line, 1259, Ansi, column, AT_OBJ_NAME_PTR(attr_idx),
                  "INTRINSIC");
#endif /* KEY Bug 5040 */
      }
      ATI_DCL_INTRINSIC(attr_idx) = TRUE;
   }
   else {

      /* The INTRINSIC has not been copied down yet. - So copy it. */

      host_attr_idx = srch_host_sym_tbl(AT_OBJ_NAME_PTR(attr_idx),
                                        AT_NAME_LEN(attr_idx),
                                        &host_name_idx,
                                        TRUE);

      if (host_attr_idx != NULL_IDX) {

         /* go directly to the INTRINSIC scope if not interface */
         /* or if it is not the name of a specific intrinsic.   */

         if (AT_OBJ_CLASS(host_attr_idx) != Interface ||
             !ATI_GENERIC_INTRINSIC(host_attr_idx)) {
            save_curr_scp_idx = curr_scp_idx;
            curr_scp_idx = INTRINSIC_SCP_IDX;
            host_attr_idx = srch_sym_tbl(AT_OBJ_NAME_PTR(attr_idx),
                                         AT_NAME_LEN(attr_idx),
                                         &host_name_idx);
            curr_scp_idx = save_curr_scp_idx;
         }

         if (host_attr_idx != NULL_IDX &&
             AT_IS_INTRIN(host_attr_idx) &&
             ATI_FIRST_SPECIFIC_IDX(host_attr_idx) == NULL_IDX) {
            complete_intrinsic_definition(host_attr_idx);
         }
      }

      if (host_attr_idx == NULL_IDX) {

         /* Error - Couldn't find the intrinsic.  Set implicit type.  */

         PRINTMSG(line, 701, Error, column, AT_OBJ_NAME_PTR(attr_idx));
         found_error = TRUE;

         if (AT_OBJ_CLASS(attr_idx) == Data_Obj && !AT_TYPED(attr_idx)) {
            SET_IMPL_TYPE(attr_idx);
         }
         else {

            if (AT_OBJ_CLASS(attr_idx) == Interface && 
                ATI_PROC_IDX(attr_idx) != NULL_IDX) {
               attr_idx = ATI_PROC_IDX(attr_idx);
            }

            if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit && 
                ATP_PGM_UNIT(attr_idx) == Function &&
               !AT_TYPED(ATP_RSLT_IDX(attr_idx))) {
               SET_IMPL_TYPE(ATP_RSLT_IDX(attr_idx));
            }
         }
      }
      else if (AT_OBJ_CLASS(attr_idx) == Interface) {

         /* Both are interfaces.   Add these specific intrinsics behind     */
         /* any user declared specifics that have previously been declared. */

         AT_IS_INTRIN(attr_idx)		= TRUE;
         ATI_DCL_INTRINSIC(attr_idx)	= TRUE;
         ATI_NUM_SPECIFICS(attr_idx)   += ATI_NUM_SPECIFICS(host_attr_idx);

         sn_idx = ATI_FIRST_SPECIFIC_IDX(attr_idx);

         if (sn_idx == NULL_IDX) {
            ATI_FIRST_SPECIFIC_IDX(attr_idx) = 
                                          ATI_FIRST_SPECIFIC_IDX(host_attr_idx);
         }
         else {
            while (SN_SIBLING_LINK(sn_idx) != NULL_IDX) {
               sn_idx = SN_SIBLING_LINK(sn_idx);
            }
            SN_SIBLING_LINK(sn_idx) = ATI_FIRST_SPECIFIC_IDX(host_attr_idx);
         }
      }
      else {

         if (ATI_INTERFACE_CLASS(host_attr_idx) == 
                                                Generic_Subroutine_Interface) {

            if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {

               if (ATP_RSLT_IDX(attr_idx) != NULL_IDX && 
                   AT_TYPED(ATP_RSLT_IDX(attr_idx))) {
                  PRINTMSG(line, 869, Error, column,
                           AT_OBJ_NAME_PTR(attr_idx));
                  found_error = TRUE;
               }
   
               ATP_RSLT_IDX(attr_idx) = NULL_IDX;
            }
            else if (AT_OBJ_CLASS(attr_idx) == Data_Obj && AT_TYPED(attr_idx)){
               PRINTMSG(line, 869, Error, column, AT_OBJ_NAME_PTR(attr_idx));
               found_error = TRUE;
            }
         }

         type_idx = NULL_IDX;

         if (AT_TYPED(attr_idx)) {

            if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
               type_idx = ATD_TYPE_IDX(attr_idx);
            }
            else if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit &&
                     ATP_RSLT_IDX(attr_idx) != NULL_IDX) {
               type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx));
            }
         }

         COPY_VARIANT_ATTR_INFO(host_attr_idx,
                                attr_idx, 
                                Interface);

         AT_ELEMENTAL_INTRIN(attr_idx)	= AT_ELEMENTAL_INTRIN(host_attr_idx);
         AT_IS_INTRIN(attr_idx)		= TRUE;
         ATD_TYPE_IDX(attr_idx)		= type_idx;
         ATI_DCL_INTRINSIC(attr_idx)	= TRUE;
      }
   }

   TRACE (Func_Exit, "merge_intrinsic", NULL);

   return(!found_error);

}  /* merge_intrinsic */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*      NOTES: The object must be a dummy argument.             (p5-2,17-18)  *|
|*             The object must be in a subpgm or interface blk  (5.2.2)       *|
|*             The stmt must not be declared in a blockdata pgm (p11-6,31-33) *|
|*             If in an ASSIGNMENT or an OPERATOR interface     (p12-6,1-4)   *|
|*                cannot specify optional                                     *|
|*             Must not be specified in a main program          (p11-1,33-36) *|
|*                                                                            *|
|*  END of declaration:                                                       *|
|*         If allocatable - it must be a deferred-shape array.                *|
|*									      *|
|* Input parameters:							      *|
|*	chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
|*	                 is FALSE, just add the attribute to the attr.        *|
|*	line     -> The line number of the object to add the attribute to     *|
|*	column   -> The line number of the object to add the attribute to     *|
|*	attr_idx -> Attr index to add the EXTERNAL attribute to.              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if successful merge					      *|
|*									      *|
\******************************************************************************/

boolean merge_optional (boolean	chk_semantics,
		        int	line,
		        int	column,
			int	attr_idx)

{
   boolean	chk_err		= FALSE;


   TRACE (Func_Entry, "merge_optional", NULL);

   if (chk_semantics) {
      chk_err = fnd_semantic_err(Obj_Optional,
                                 line,
                                 column,
                                 attr_idx,
                                 TRUE);

      if (!chk_err && AT_OPTIONAL(attr_idx)) {
#ifdef KEY /* Bug 5040 */
         PRINTMSG(line, 1259, ansi_or_warning(), column,
	   AT_OBJ_NAME_PTR(attr_idx), AT_DEF_LINE(attr_idx), "OPTIONAL");
#else /* KEY Bug 5040 */
         PRINTMSG(line, 1259, Ansi, column, AT_OBJ_NAME_PTR(attr_idx),
                  "OPTIONAL");
#endif /* KEY Bug 5040 */
      }
   }
   else {
      SET_IMPL_TYPE(attr_idx);
   }

   if (!chk_err) {

      if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
         ATD_CLASS(attr_idx)	= Dummy_Argument;
      }
      else {
         ATP_PROC(attr_idx)	= Dummy_Proc;
      }
      AT_OPTIONAL(attr_idx)	= TRUE;
   }

   TRACE (Func_Exit, "merge_optional", NULL);

   return(!chk_err);

}  /* merge_optional */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Add the POINTER attribute to an attr.			      	      *|
|*									      *|
|* Input parameters:							      *|
|*	chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
|*	                 is FALSE, just add the attribute to the attr.        *|
|*	line     -> The line number of the object to add the attribute to     *|
|*	column   -> The line number of the object to add the attribute to     *|
|*	attr_idx -> Attr index to add the POINTER attribute to.               *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if successful merge.					      *|
|*									      *|
\******************************************************************************/

boolean merge_pointer(boolean	chk_semantics,
	              int	line,
		      int	column,
		      int	attr_idx)

{
   boolean	fnd_err		= FALSE;
   int		rslt_idx;


   TRACE (Func_Entry, "merge_pointer", NULL);

   if (AT_OBJ_CLASS(attr_idx) == Interface && 
       ATI_PROC_IDX(attr_idx) != NULL_IDX) {
       attr_idx = ATI_PROC_IDX(attr_idx);
   }

   if (chk_semantics) {

      if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit && ATP_RSLT_NAME(attr_idx)) {
         PRINTMSG(line, 36, Error, column, AT_OBJ_NAME_PTR(attr_idx),
                  AT_OBJ_NAME_PTR(ATP_RSLT_IDX(attr_idx)));
         fnd_err		= TRUE;
         AT_DCL_ERR(attr_idx)	= TRUE;
      }
      else {
         fnd_err = fnd_semantic_err(Obj_Pointer,
                                    line,
                                    column,
                                    attr_idx,
                                    TRUE);
      }

      if (!fnd_err && AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {

         if (ATP_RSLT_IDX(attr_idx) == NULL_IDX) {
            CREATE_FUNC_RSLT(attr_idx, rslt_idx);
            ATP_PGM_UNIT(attr_idx)	= Function;
            SET_IMPL_TYPE(rslt_idx);
            attr_idx			= rslt_idx;
         }
         else {
            attr_idx = ATP_RSLT_IDX(attr_idx);
            fnd_err  = fnd_semantic_err(Obj_Pointer, 
                                        line,
                                        column,
                                        attr_idx,
                                        TRUE);
         }
      }

      if (!fnd_err) {

         if (ATD_POINTER(attr_idx)) {
#ifdef KEY /* Bug 5040 */
            PRINTMSG(line, 1259, ansi_or_warning(), column,
	      AT_OBJ_NAME_PTR(attr_idx), AT_DEF_LINE(attr_idx), "POINTER");
#else /* KEY Bug 5040 */
            PRINTMSG(line, 1259, Ansi, column, AT_OBJ_NAME_PTR(attr_idx),
                     "POINTER");
#endif /* KEY Bug 5040 */
         }
         ATD_POINTER(attr_idx)   = TRUE;
         ATD_IM_A_DOPE(attr_idx) = TRUE;
      }
   }
   else {
      SET_IMPL_TYPE(attr_idx);
      ATD_POINTER(attr_idx)   = TRUE;
      ATD_IM_A_DOPE(attr_idx) = TRUE;
   }

   TRACE (Func_Exit, "merge_pointer", NULL);

   return(!fnd_err);

}  /* merge_pointer */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Add the SAVE attribute to an attr.			      	      *|
|*									      *|
|* Input parameters:							      *|
|*	chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
|*	                 is FALSE, just add the attribute to the attr.        *|
|*	line     -> The line number of the object to add the attribute to     *|
|*	column   -> The line number of the object to add the attribute to     *|
|*	attr_idx -> Attr index to add the EXTERNAL attribute to.              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if successful merge.					      *|
|*									      *|
\******************************************************************************/

boolean merge_save(boolean	chk_semantics,
	           int		line,
		   int		column,
		   int		attr_idx)

{
   boolean	fnd_err		= FALSE;


   TRACE (Func_Entry, "merge_save", NULL);

   if (chk_semantics) {
      fnd_err = fnd_semantic_err(Obj_Saved, line, column, attr_idx, TRUE);

      if (!fnd_err && ATD_SAVED(attr_idx)) {
#ifdef KEY /* Bug 5040 */
         PRINTMSG(line, 1259, ansi_or_warning(), column,
	   AT_OBJ_NAME_PTR(attr_idx), AT_DEF_LINE(attr_idx), "SAVE");
#else /* KEY Bug 5040 */
         PRINTMSG(line, 1259, Ansi, column, AT_OBJ_NAME_PTR(attr_idx), "SAVE");
#endif /* KEY Bug 5040 */
      }
   }
   else {
      SET_IMPL_TYPE(attr_idx);
   }

   if (!fnd_err) {
      ATD_SAVED(attr_idx) = TRUE;
      ATD_CLASS(attr_idx) = Variable;
   }

   TRACE (Func_Exit, "merge_save", NULL);

   return(!fnd_err);

}  /* merge_save */


/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Add the TARGET attribute to an attr.			      	      *|
|*									      *|
|* Input parameters:							      *|
|*	chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
|*	                 is FALSE, just add the attribute to the attr.        *|
|*	line     -> The line number of the object to add the attribute to     *|
|*	column   -> The line number of the object to add the attribute to     *|
|*	attr_idx -> Attr index to add the TARGET attribute to.                *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if successful merge.					      *|
|*									      *|
\******************************************************************************/

boolean merge_target(boolean	chk_semantics,
	             int	line,
		     int	column,
		     int	attr_idx)

{
   boolean	fnd_err		= FALSE;
   int		rslt_idx;


   TRACE (Func_Entry, "merge_target", NULL);

   if (AT_OBJ_CLASS(attr_idx) == Interface && 
       ATI_PROC_IDX(attr_idx) != NULL_IDX) {
       attr_idx = ATI_PROC_IDX(attr_idx);
   }

   if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit && ATP_RSLT_NAME(attr_idx)) {
      PRINTMSG(line, 132, Error, column, AT_OBJ_NAME_PTR(attr_idx),
               AT_OBJ_NAME_PTR(ATP_RSLT_IDX(attr_idx)));
      fnd_err			= TRUE;
      AT_DCL_ERR(attr_idx)	= TRUE;
   }
   else if (chk_semantics) {
      fnd_err = fnd_semantic_err(Obj_Target, line, column, attr_idx, TRUE);
   }
   else {
      SET_IMPL_TYPE(attr_idx);
   }

   if (!fnd_err && AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {

      if (ATP_RSLT_IDX(attr_idx) == NULL_IDX) {
         CREATE_FUNC_RSLT(attr_idx, rslt_idx);
         ATP_PGM_UNIT(attr_idx)	= Function;
         SET_IMPL_TYPE(rslt_idx);
         attr_idx = rslt_idx;
      } 
      else {
         attr_idx = ATP_RSLT_IDX(attr_idx);
         fnd_err  = fnd_semantic_err(Obj_Target,
                                     line,
                                     column,
                                     attr_idx,
                                     TRUE);
      }
   }

   if (!fnd_err) {

      if (!fnd_err && ATD_TARGET(attr_idx)) {
#ifdef KEY /* Bug 5040 */
         PRINTMSG(line, 1259, ansi_or_warning(), column,
	   AT_OBJ_NAME_PTR(attr_idx), AT_DEF_LINE(attr_idx), "TARGET");
#else /* KEY Bug 5040 */
         PRINTMSG(line, 1259, Ansi, column, AT_OBJ_NAME_PTR(attr_idx),"TARGET");
#endif /* KEY Bug 5040 */
      }
      ATD_TARGET(attr_idx) = TRUE;
   }

   TRACE (Func_Exit, "merge_target", NULL);

   return(!fnd_err);

}  /* merge_target */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	This routine parses integer specification expressions.  It is used by *|
|*      the parsing routines for array boundaries, character lengths, and     *|
|*      kind type parameters.  It takes a shortcut if there is just a literal *|
|*      integer constant like B(10).  It would pick this up itself without    *|
|*      calling the expression parser.  Expression semantics is called only   *|
|*      if input fold_it tells it do it.  This is because kind type parameters*|
|*      can be folded right away, but array and character bounds must wait    *|
|*      until the end of pass1.  If this doesn't come out to be a constant    *|
|*      value, tmp = is generated and the tmp is added to the bounds list.    *|
|*									      *|
|* Input parameters:							      *|
|*	fold_it          -> A flag that tells this routine whether to try to  *|
|*                          fold this value or not.                           *|
|*	kind_type        -> A flag that tells this routine is being called    *|
|*                          to process kind type or not.                      *|
|*									      *|
|* Output parameters:							      *|
|*	len_idx	    -> This is a ptr to a table index.  field_type tells what *|
|*                     kind of index this is.                                 *|
|*	field_type  -> This is a ptr to what kind of table index this is.  It *|
|*		       contains the fld_type enum. (AT_Tbl_Idx, IR_Tbl_Idx ect*|
|*									      *|
|* Returns:								      *|
|*	Returns TRUE if it parsed okay.					      *|
|*									      *|
\******************************************************************************/
#ifndef KEY /* Bug 10572 */
static
#endif /* KEY Bug 10572 */
boolean	parse_int_spec_expr(long		*len_idx,
			    fld_type		*field_type,
			    boolean		fold_it,
			    boolean		char_len,
			    boolean		function_ret_kind)

{
   int			column;
   expr_arg_type	expr_desc;
   opnd_type		len_opnd;
   int			line;
   boolean		parse_ok;
   expr_mode_type	save_expr_mode	= expr_mode;
   int			type_idx;

# if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) || defined(_TARGET_OS_DARWIN)
   int			cvrt_idx;
   int			new_type;
# endif


   TRACE (Func_Entry, "parse_int_spec_expr", NULL);

   xref_state		= CIF_Symbol_Reference;
   *field_type		= CN_Tbl_Idx;
   *len_idx		= CN_INTEGER_ONE_IDX;
   line			= LA_CH_LINE;
   column		= LA_CH_COLUMN;
   expr_desc		= init_exp_desc;

   expr_mode		= fold_it
       ? (function_ret_kind ? Regular_Expr : Initialization_Expr)
       : Specification_Expr;

   if (!parse_expr(&len_opnd)) {
      parse_ok	= FALSE;
      goto EXIT;
   }


   if (fold_it) {

      expr_desc.rank = 0;

      if (!expr_semantics(&len_opnd, &expr_desc)) {
         parse_ok	= FALSE;
         goto EXIT;
      }

      if (expr_desc.rank != 0) {
         PRINTMSG(line, 907, Error, column);
         parse_ok	= FALSE;
         goto EXIT;
      }

      if (OPND_FLD(len_opnd) != CN_Tbl_Idx) {
	  if (function_ret_kind) {
	      *field_type = OPND_FLD(len_opnd);
	      *len_idx    = OPND_IDX(len_opnd);
	      parse_ok    = TRUE;

	  } else {
	      PRINTMSG(line, 1531, Error, column);
	      parse_ok	= FALSE;
	  }

         goto EXIT;
      }

      if (parsing_kind_selector) {
         if (expr_desc.kind0seen) {
            kind0seen = TRUE;
         }
         else if (expr_desc.kind0E0seen) {
            kind0E0seen = TRUE;
         }
         else if (expr_desc.kind0D0seen) {
            kind0D0seen = TRUE;
         }
         else if (! expr_desc.kindnotconst) {
            kindconstseen = TRUE;
         }
      }
   }

   parse_ok = TRUE;

   if (OPND_FLD(len_opnd) == CN_Tbl_Idx) {
      type_idx	= CN_TYPE_IDX(OPND_IDX(len_opnd));

      if (TYP_TYPE(type_idx) != Integer) {
    
         if (TYP_TYPE(type_idx) == Typeless) {

            if (TYP_LINEAR(type_idx) == Short_Typeless_Const) {
               PRINTMSG(line, 221, Ansi, column);

               OPND_IDX(len_opnd) = cast_typeless_constant(OPND_IDX(len_opnd),
                                                           INTEGER_DEFAULT_TYPE,
                                                           line, 
                                                           column);
               type_idx = INTEGER_DEFAULT_TYPE;
            }
            else { /* hollerith too long */
               PRINTMSG(line, 1133, Error, column);
               parse_ok = FALSE;
            }
         }
         else {
            PRINTMSG(line, 488, Error, column,
                     get_basic_type_str(type_idx));
            parse_ok	= FALSE;
         }
      }

      *len_idx          = (long) OPND_IDX(len_opnd);
      *field_type       = CN_Tbl_Idx;

# if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) || defined(_TARGET_OS_DARWIN)

      if (!parsing_kind_selector) {
         new_type	= NULL_IDX;

         if (char_len) {     /* All char lens must be integer_4 */

            if (TYP_LINEAR(CN_TYPE_IDX(OPND_IDX(len_opnd))) != Integer_4) {
               new_type	= Integer_4;
            }
         }
         else if (cmd_line_flags.s_pointer8 &&
                  TYP_LINEAR(CN_TYPE_IDX(OPND_IDX(len_opnd))) !=
                             SA_INTEGER_DEFAULT_TYPE) {
               new_type	= SA_INTEGER_DEFAULT_TYPE;
         }
         else if (TYP_LINEAR(CN_TYPE_IDX(OPND_IDX(len_opnd))) <
                             SA_INTEGER_DEFAULT_TYPE) {

            /* Bump up integer*1 and integer*2 to avoid overflows KAY  */

            new_type	= SA_INTEGER_DEFAULT_TYPE;
         }

         if (new_type != NULL_IDX) {
            NTR_IR_TBL(cvrt_idx);
            IR_OPR(cvrt_idx)		= Cvrt_Opr;
            IR_TYPE_IDX(cvrt_idx)	= new_type;
            IR_LINE_NUM(cvrt_idx)	= line;
            IR_COL_NUM(cvrt_idx)	= column;

            COPY_OPND(IR_OPND_L(cvrt_idx), len_opnd);

            OPND_IDX(len_opnd)		= cvrt_idx;
            OPND_FLD(len_opnd)		= IR_Tbl_Idx;

            if (fold_it) {
               expr_desc.rank = 0;

               if (!expr_semantics(&len_opnd, &expr_desc)) {
                  parse_ok	= FALSE;
                  goto EXIT;
               }

               *len_idx		= (long) OPND_IDX(len_opnd); 
               *field_type	= CN_Tbl_Idx;
            }
            else {
               *field_type      		= AT_Tbl_Idx;
               *len_idx				= ntr_bnds_tmp_list(&len_opnd);
               ATD_TMP_HAS_CVRT_OPR(*len_idx)	= TRUE;
            }
         }
         else {
            *len_idx	= (long) OPND_IDX(len_opnd); 
            *field_type	= CN_Tbl_Idx;
         }
      }

# endif

   }

   else {

# if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) || defined(_TARGET_OS_DARWIN)
      new_type	= NULL_IDX;

      if (!parsing_kind_selector) { 

         if (char_len) {     /* All char lens must be integer_4 */
            new_type	= Integer_4;
         }
         else if (cmd_line_flags.s_pointer8) { 
            new_type	= SA_INTEGER_DEFAULT_TYPE;
         }

         if (new_type != NULL_IDX) {
            NTR_IR_TBL(cvrt_idx);
            IR_OPR(cvrt_idx)		= Cvrt_Opr;
            IR_TYPE_IDX(cvrt_idx)	= new_type;
            IR_LINE_NUM(cvrt_idx)	= line;
            IR_COL_NUM(cvrt_idx)	= column;

            COPY_OPND(IR_OPND_L(cvrt_idx), len_opnd);

            OPND_IDX(len_opnd)		= cvrt_idx;
            OPND_FLD(len_opnd)		= IR_Tbl_Idx;

            if (fold_it) {
               expr_desc.rank = 0;

               if (!expr_semantics(&len_opnd, &expr_desc)) {
                  parse_ok	= FALSE;
                  goto EXIT;
               }
            }
         }
      }

      *field_type       = AT_Tbl_Idx;
      *len_idx		= ntr_bnds_tmp_list(&len_opnd);

      ATD_TMP_SEMANTICS_DONE(*len_idx) = fold_it;

      if (new_type != NULL_IDX) {
         ATD_TMP_HAS_CVRT_OPR(*len_idx) = TRUE;
      }
# else
      *field_type       = AT_Tbl_Idx;
      *len_idx		= ntr_bnds_tmp_list(&len_opnd);

      ATD_TMP_SEMANTICS_DONE(*len_idx) = fold_it;
# endif

   }

EXIT:

   expr_mode = save_expr_mode;

   TRACE (Func_Exit, "parse_int_spec_expr", NULL);

   return(parse_ok);

}  /* parse_int_spec_expr */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	This routine takes a bounds ir stream, and searches the bounds tmp    *|
|*      list for a match.  If a match is found, it returns the attr_idx of    *|
|*      the matched bound.  If there is no match, a compiler temp is          *|
|*      generated and added to the end of the bounds tmp list.   This assumes *|
|*      that the ir pointed to by ATD_TMP_IDX is always of the form           *|
|*      TMP = ir_stream, so it passes to compare_ir the right operand of      *|
|*      the compiler temp.  And then if a new temp is needed, this routine    *|
|*      generates the TMP =.                                                  *|
|*									      *|
|* Input parameters:							      *|
|*	opnd   A pointer to an operand pointing to the attribute or ir stream *|
|*	       that needs a temp.  This should NOT have TMP = generated yet.  *|
|*									      *|
|* Output parameters:							      *|
|*	 NONE								      *|
|*									      *|
|* Returns:								      *|
|*	attr_idx  Index to attr table for this temp.                          *|
|*									      *|
\******************************************************************************/
static int ntr_bnds_tmp_list (opnd_type	*opnd)

{
   int		al_idx;
   int		attr_idx;
   int		cif_attr	= NULL_IDX;
   int		column;
   int		ir_idx;
   int		line;
   int		prev_al		= NULL_IDX;


   TRACE (Func_Entry, "ntr_bnds_tmp_list", NULL);

   al_idx	= SCP_TMP_FW_IDX(curr_scp_idx);
   attr_idx	= NULL_IDX;

   while (al_idx != NULL_IDX) {
      attr_idx	= AL_ATTR_IDX(al_idx);

      if (ATD_CLASS(attr_idx) == Constant) {
         
         /* This tmp has resolved to a constant, because it has gone   */
         /* thru expr_semantics already.  Remove it from the tmp list. */
         /* A tmp may go through expr_semantics early, if the item     */
         /* needs to be folded because it is referenced in a bound of  */
         /* a component declaration.  prev_al stays the same.          */

         al_idx = AL_NEXT_IDX(al_idx);

         if (prev_al == NULL_IDX) {
            SCP_TMP_FW_IDX(curr_scp_idx) = al_idx;
         }
         else {
            AL_NEXT_IDX(prev_al)	 = al_idx;
         }
         continue;
      }

      /* Okay to pass a pointer to the operand here, because it should */
      /* not move.  This is only a call to compare operands.           */

      if (compare_opnds(opnd, &(IR_OPND_R(ATD_TMP_IDX(attr_idx)))) ) {

         /* If this is CIF - retain the IR, even though the tmp gets shared */

         if ((cif_flags & XREF_RECS) != 0) {

            if (cif_attr == NULL_IDX) {
               cif_attr	= attr_idx;
            }
         }
         else {

            if (OPND_FLD((*opnd)) == IR_Tbl_Idx) { 
               free_ir_stream(OPND_IDX((*opnd)));
            }
            goto EXIT;
         }
      }

      prev_al	= al_idx;
      al_idx	= AL_NEXT_IDX(al_idx);
   }

   /* Each new bound has to be added at the end of the list. */

   NTR_ATTR_LIST_TBL(al_idx);

   if (prev_al == NULL_IDX) {
      SCP_TMP_FW_IDX(curr_scp_idx)	= al_idx;
   }
   else {
      AL_NEXT_IDX(prev_al)		= al_idx;
   }
   find_opnd_line_and_column(opnd, &line, &column);

   GEN_COMPILER_TMP_ASG(ir_idx, 
                        attr_idx,
                        FALSE,		/* Tmp should go through semantics */
                        line,
                        column,
                        INTEGER_DEFAULT_TYPE,
                        Priv);

   AL_ATTR_IDX(al_idx)		= attr_idx;

   COPY_OPND(IR_OPND_R(ir_idx), (*opnd));	/* IR_OPND_R = *opnd  */

   if (cif_attr != NULL_IDX) {

      /* This tmp is only being kept for CIF - Return the tmp to be shared. */

      AT_REFERENCED(attr_idx)	= Not_Referenced;
      attr_idx			= cif_attr;
   }

EXIT:

   TRACE (Func_Exit, "ntr_bnds_tmp_list", NULL);

   return (attr_idx);

}  /* ntr_bnds_tmp_list */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Parse a POSSIBLE generic spec.  If OPERATOR(operator) or ASSIGNMENT   *|
|*	  (=) is found, search for (create if necessary)  an attr entry.      *|
|*	  If identifier found, return attr index if found, else 0.     	      *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	attr index of new attribute.                       	 	      *|
|*									      *|
\******************************************************************************/

int	generic_spec_semantics(void) 

{
   int		attr_idx;
   boolean	generic_name;
   int		host_attr_idx;
   int		host_name_idx;
   int		name_idx;
   boolean	new_attr	= FALSE;
   int		new_attr_idx;
   int		scp_idx;
   int		type_idx;


   TRACE (Func_Entry, "generic_spec_semantics", NULL);

   generic_name = TOKEN_VALUE(token) == Tok_Id;
   attr_idx	= srch_sym_tbl(TOKEN_STR(token),
                               TOKEN_LEN(token),
                               &name_idx);

   if (stmt_type == Interface_Stmt) {

      if (attr_idx == NULL_IDX) {  /* Didn't find entry in local scope */
         host_attr_idx = srch_host_sym_tbl(TOKEN_STR(token), 
                                           TOKEN_LEN(token),
                                           &host_name_idx,
                                           TRUE);

         if (host_attr_idx == NULL_IDX ||
            AT_OBJ_CLASS(host_attr_idx) != Interface) {

            /* The only host association in this situation, is if the   */
            /* host is an INTERFACE.  If it is not, make a LN_DEF_LOC   */
            /* interface entry in the local scope.                      */

            attr_idx			= ntr_sym_tbl(&token, name_idx);
            AT_OBJ_CLASS(attr_idx)	= Interface;
            LN_DEF_LOC(name_idx)	= TRUE;
            new_attr			= TRUE;

            if (generic_name) {
               ATI_INTERFACE_CLASS(attr_idx) = Generic_Unknown_Interface;
            }
         }
         else if (AT_NOT_VISIBLE(host_attr_idx)) {
            PRINTMSG(TOKEN_LINE(token), 486, Error,
                     TOKEN_COLUMN(token),
                     AT_OBJ_NAME_PTR(host_attr_idx),
                     AT_OBJ_NAME_PTR(AT_MODULE_IDX((host_attr_idx))));
            attr_idx			= ntr_sym_tbl(&token, name_idx);
            AT_OBJ_CLASS(attr_idx)	= Interface;
            LN_DEF_LOC(name_idx)	= TRUE;
            new_attr			= TRUE;

            if (generic_name) {
               ATI_INTERFACE_CLASS(attr_idx) = Generic_Unknown_Interface;
            }
         }
         else { /* Found interface in host.  Make a new entry in the local   */
                /* scp and copy the attr.  LN_DEF_LOC gets set in local scp. */

            if (AT_IS_INTRIN(host_attr_idx) &&
                ATI_FIRST_SPECIFIC_IDX(host_attr_idx) == NULL_IDX) {
               complete_intrinsic_definition(host_attr_idx);
               attr_idx	= srch_sym_tbl(TOKEN_STR(token), 
                                       TOKEN_LEN(token), 
                                       &name_idx);
            }

            attr_idx = ntr_host_in_sym_tbl(&token, 
                                           name_idx,
                                           host_attr_idx,
                                           host_name_idx,
                                           TRUE);

            type_idx = (AT_TYPED(host_attr_idx)) ? ATD_TYPE_IDX(host_attr_idx) :
                                                   NULL_IDX;

            COPY_VARIANT_ATTR_INFO(host_attr_idx, attr_idx, Interface);

            LN_DEF_LOC(name_idx)	  = TRUE;
            AT_ATTR_LINK(attr_idx)	  = NULL_IDX;
            AT_IS_INTRIN(attr_idx)	  = AT_IS_INTRIN(host_attr_idx);
            AT_ELEMENTAL_INTRIN(attr_idx) = AT_ELEMENTAL_INTRIN(host_attr_idx);
            ATD_TYPE_IDX(attr_idx)	  = type_idx;
            AT_DEF_LINE(attr_idx)	  = TOKEN_LINE(token);
            AT_DEF_COLUMN(attr_idx)	  = TOKEN_COLUMN(token);
         }
      }
      else if ((!AT_USE_ASSOCIATED(attr_idx) ||
                 AT_OBJ_CLASS(attr_idx) != Pgm_Unit ||
                 ATP_PROC(attr_idx) != Module_Proc) &&
               fnd_semantic_err(Obj_Generic_Interface,
                                TOKEN_LINE(token),
                                TOKEN_COLUMN(token),
                                attr_idx,
                                TRUE)) {
         CREATE_ERR_ATTR(attr_idx, TOKEN_LINE(token),
                                   TOKEN_COLUMN(token), Interface);
         AT_OBJ_CLASS(attr_idx)	= Interface;
      }
      else if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {

         /* Must be a function or subroutine */

         NTR_ATTR_TBL(new_attr_idx);
         COPY_COMMON_ATTR_INFO(attr_idx, new_attr_idx, Interface);
         AT_DEF_LINE(new_attr_idx)	= TOKEN_LINE(token);
         AT_DEF_COLUMN(new_attr_idx)	= TOKEN_COLUMN(token);
         ATI_PROC_IDX(new_attr_idx)	= attr_idx;
         LN_ATTR_IDX(name_idx)		= new_attr_idx;
         LN_NAME_IDX(name_idx)		= AT_NAME_IDX(new_attr_idx);

         if (ATP_RSLT_IDX(attr_idx) != NULL_IDX && 
             AT_TYPED(ATP_RSLT_IDX(attr_idx))) {
            ATD_TYPE_IDX(new_attr_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx));
         }

         attr_idx			= new_attr_idx;

         if (generic_name) {
            ATI_INTERFACE_CLASS(attr_idx) = Generic_Unknown_Interface;
         }
      }
      else if (AT_OBJ_CLASS(attr_idx) != Interface) {
         scp_idx		= curr_scp_idx;
         curr_scp_idx		= INTRINSIC_SCP_IDX;
         host_attr_idx		= srch_sym_tbl(TOKEN_STR(token), 
                                               TOKEN_LEN(token),
                                               &host_name_idx);
         curr_scp_idx		= scp_idx;

         if (host_attr_idx == NULL_IDX) {
            CLEAR_VARIANT_ATTR_INFO(attr_idx, Interface);
            type_idx		= NULL_IDX;
         }
         else {  /* It is an intrinsic */
            complete_intrinsic_definition(host_attr_idx);
            COPY_VARIANT_ATTR_INFO(host_attr_idx, attr_idx, Interface);
            AT_ATTR_LINK(attr_idx)	  = NULL_IDX;
            AT_IS_INTRIN(attr_idx)	  = AT_IS_INTRIN(host_attr_idx);
            AT_ELEMENTAL_INTRIN(attr_idx) = AT_ELEMENTAL_INTRIN(host_attr_idx);
            type_idx			  = ATD_TYPE_IDX(host_attr_idx);
         }

         ATD_TYPE_IDX(attr_idx)		  = type_idx;
         AT_DEF_LINE(attr_idx)		  = TOKEN_LINE(token);
         AT_DEF_COLUMN(attr_idx)	  = TOKEN_COLUMN(token);
      }
   }
   else if (CURR_BLK == Module_Blk) {		/* Public/Private statement */

      if (attr_idx == NULL_IDX) {
         attr_idx		= ntr_sym_tbl(&token, name_idx);
         LN_DEF_LOC(name_idx)	= TRUE;
         new_attr		= TRUE;

         if (generic_name) {
            SET_IMPL_TYPE(attr_idx);
         }
         else {
            AT_OBJ_CLASS(attr_idx)	= Interface;
         }
      }  /* NOT_VISIBLE and other semantics are done by the caller */
   }
   else if (attr_idx == NULL_IDX) {
      attr_idx			= ntr_sym_tbl(&token, name_idx);
      LN_DEF_LOC(name_idx)	= TRUE;
      new_attr			= TRUE;

      if (generic_name) {
         SET_IMPL_TYPE(attr_idx);
      }
      else {
         AT_OBJ_CLASS(attr_idx)	= Interface;
      }
   }
   else if (AT_REFERENCED(attr_idx) == Char_Rslt_Bound_Ref) {
      AT_ATTR_LINK(attr_idx)   = NULL_IDX;
      LN_DEF_LOC(name_idx)     = TRUE;
   }


   /* CIF processing uses ATI_USER_SPECIFIED and AT_IS_INTRINSIC to determine */
   /* that an intrinsic procedure name is being overloaded.  Must check that  */
   /* the current statement is an interface block statement because this      */
   /* routine is also called to parse the generic name in a PUBLIC/PRIVATE    */
   /* statement.							      */

   if (stmt_type == Interface_Stmt  && 
       AT_OBJ_CLASS(attr_idx) == Interface  &&  generic_name) {
      ATI_USER_SPECIFIED(attr_idx) = TRUE;
   }


   if (new_attr && !generic_name) {

      switch (TOKEN_VALUE(token)) {
      case Tok_Op_Add :
         ATI_DEFINED_OPR(attr_idx)     = Plus_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Unary_Or_Binary_Interface;
         break;

      case Tok_Op_Div :
         ATI_DEFINED_OPR(attr_idx)     = Div_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
         break;

      case Tok_Op_Mult :
         ATI_DEFINED_OPR(attr_idx)     = Mult_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
         break;

      case Tok_Op_Power :
         ATI_DEFINED_OPR(attr_idx)     = Power_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
         break;

      case Tok_Op_Sub :
         ATI_DEFINED_OPR(attr_idx)     = Minus_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Unary_Or_Binary_Interface;
         break;

      case Tok_Op_Concat :
         ATI_DEFINED_OPR(attr_idx)     = Concat_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
         break;

      case Tok_Op_Eq :
         ATI_DEFINED_OPR(attr_idx)     = Eq_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
         break;

      case Tok_Op_Ge :
         ATI_DEFINED_OPR(attr_idx)     = Ge_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
         break;

      case Tok_Op_Gt :
         ATI_DEFINED_OPR(attr_idx)     = Gt_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
         break;

      case Tok_Op_Le :
         ATI_DEFINED_OPR(attr_idx)     = Le_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
         break;

      case Tok_Op_Lt :
         ATI_DEFINED_OPR(attr_idx)     = Lt_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
         break;

      case Tok_Op_Ne :
         ATI_DEFINED_OPR(attr_idx)     = Ne_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
         break;

      case Tok_Op_Lg :
         ATI_DEFINED_OPR(attr_idx)     = Lg_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
         break;

      case Tok_Op_And :
         ATI_DEFINED_OPR(attr_idx)     = And_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
         break;

      case Tok_Op_Eqv :
         ATI_DEFINED_OPR(attr_idx)     = Eqv_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
         break;

      case Tok_Op_Neqv :
         ATI_DEFINED_OPR(attr_idx)     = Neqv_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
         break;

      case Tok_Op_Not :
         ATI_DEFINED_OPR(attr_idx)     = Not_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Unary_Interface;
         break;

      case Tok_Op_Or :
         ATI_DEFINED_OPR(attr_idx)     = Or_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
         break;

      case Tok_Op_Assign :
         ATI_DEFINED_OPR(attr_idx)     = Asg_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Assign_Interface;
         break;

      case Tok_Op_Defined :
         ATI_DEFINED_OPR(attr_idx)     = Null_Opr;
         ATI_INTERFACE_CLASS(attr_idx) = Defined_Unary_Or_Binary_Interface;
         break;
      }
   }

   if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
      ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE;
   }

   if ((cif_flags & XREF_RECS) != 0) {
      cif_usage_rec(attr_idx, 
                    AT_Tbl_Idx,
                    TOKEN_LINE(token),
                    TOKEN_COLUMN(token),
                    CIF_Symbol_Declaration);
   }

   TRACE (Func_Exit, "generic_spec_semantics", NULL);

   return(attr_idx);

}  /* generic_spec_semantics */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Check to see if attr was used to declare its own bounds.   An object  *|
|*	cannot be dimensioned after it is referenced, so an error situation   *|
|*	definitely exists.  This is a bit of compile time to check, but we    *|
|*	are in an error situation anyway.  This searches the bounds looking   *|
|*	for a reference to the attr in the bounds for the array.              *|
|*									      *|
|* Input parameters:							      *|
|*	attr index to look for                            	 	      *|
|*	bd index of dimension to searh 					      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if an error is issued.					      *|
|*									      *|
\******************************************************************************/

static boolean	is_attr_referenced_in_bound(int		bd_idx,
					    int		attr_idx) 

{
   boolean	error		= FALSE;
   opnd_type	opnd;
   int		rank;


   TRACE (Func_Entry, "is_attr_referenced_in_bound", NULL);

   if (BD_ARRAY_CLASS(bd_idx) != Deferred_Shape) {

      for (rank = BD_RANK(bd_idx); rank >0; rank--) {

         if (BD_LB_FLD(bd_idx, rank) == AT_Tbl_Idx &&
             ATD_FLD(BD_LB_IDX(bd_idx, rank)) == IR_Tbl_Idx &&
             find_attr_in_ir(attr_idx, 
                             ATD_TMP_IDX(BD_LB_IDX(bd_idx, rank)),
                             &opnd)) {
            AT_DCL_ERR(attr_idx)	= TRUE;
            BD_DCL_ERR(bd_idx)		= TRUE;
            error			= TRUE;
            PRINTMSG(OPND_LINE_NUM(opnd), 1036, Error,
                     OPND_COL_NUM(opnd),
                     AT_OBJ_NAME_PTR(attr_idx));
            break;
         }

         if (BD_UB_FLD(bd_idx, rank) == AT_Tbl_Idx &&
             ATD_FLD(BD_UB_IDX(bd_idx, rank)) == IR_Tbl_Idx &&
             find_attr_in_ir(attr_idx, 
                             ATD_TMP_IDX(BD_UB_IDX(bd_idx, rank)),
                             &opnd)) {
            AT_DCL_ERR(attr_idx)	= TRUE;
            BD_DCL_ERR(bd_idx)		= TRUE;
            error			= TRUE;
            PRINTMSG(OPND_LINE_NUM(opnd), 1036, Error,
                     OPND_COL_NUM(opnd),
                     AT_OBJ_NAME_PTR(attr_idx));
            break;
         }
      }
   }

   TRACE (Func_Exit, "is_attr_referenced_in_bound", NULL);

   return(error);

}  /* is_attr_referenced_in_bound */

/******************************************************************************\
|*                                                                            *|
|* Description:                                                               *|
|*      Parses the pe array_spec for declarations (F--)                       *|
|*             array_spec is explicit-shape-spec-list                         *|
|*                            is [lower-bound :]upper-bound                   *|
|*                               [specification-expr :] specification-expr    *|
|*                       is assumed-size-spec                                 *|
|*                          is [explicit-shape-spec-list,] [lower-bound:]*    *|
|*                                                                            *|
|*       Position  - entry - token is open brkt                               *|
|*                   exit  - token is verified close brkt                     *|
|*                           if close brkt is missing.  LA_CH is set to       *|
|*                           colon-colon, or EOS                              *|
|*                                                                            *|
|* Returns:                                                                   *|
|*      NONE                                                                  *|
|*                                                                            *|
\******************************************************************************/
int     parse_pe_array_spec(int    attr_idx)

{
   int                  bd_idx;
   int                  column;
   boolean              fold_it;
   boolean              found_end               = FALSE;
   boolean              found_error             = FALSE;
   fld_type             lb_fld;
   long                 lb_len_idx;
   int                  line;
   boolean              lower_bound_found;
   boolean              non_constant_size       = FALSE;
   int                  rank                    = 1;
   reference_type       referenced;
   fld_type             ub_fld;
   long                 ub_len_idx;


   TRACE (Func_Entry, "parse_pe_array_spec", NULL);

# ifdef _DEBUG
   if (LA_CH_VALUE != LBRKT) {
      PRINTMSG(LA_CH_LINE, 295, Internal, LA_CH_COLUMN,
               "parse_pe_array_spec", "LBRKT");
   }
# endif

   NEXT_LA_CH;                                               /* Skip Lbrkt   */
   bd_idx                       = reserve_array_ntry(7);
   referenced                   = (reference_type) AT_REFERENCED(attr_idx);
   AT_REFERENCED(attr_idx)      = Not_Referenced;
   BD_LINE_NUM(bd_idx)          = LA_CH_LINE;
   BD_COLUMN_NUM(bd_idx)        = LA_CH_COLUMN;

   /* If LA_CH is RBRKT, there is no dimension, so default to a rank 1       */
   /* constant sized array of length 1 and return.                            */

   if (LA_CH_VALUE == RBRKT) {
      parse_err_flush(Find_None, "dimension-spec");
      BD_ARRAY_CLASS(bd_idx)    = Explicit_Shape;
      BD_ARRAY_SIZE(bd_idx)     = Constant_Size;
      BD_DCL_ERR(bd_idx)        = TRUE;
      BD_RANK(bd_idx)           = 1;
      BD_LB_FLD(bd_idx, 1)      = CN_Tbl_Idx;
      BD_LB_IDX(bd_idx, 1)      = CN_INTEGER_ONE_IDX;
      BD_UB_FLD(bd_idx, 1)      = CN_Tbl_Idx;
      BD_UB_IDX(bd_idx, 1)      = CN_INTEGER_ONE_IDX;
      NEXT_LA_CH;
      goto EXIT;
   }

   /* Set fold_it flag.  Will continue on and do pass2 style semantic     */
   /* checking and constant folding, if this is a component declaration.  */

   fold_it = (CURR_BLK == Derived_Type_Blk);

   do {  /* Process each dimension of the array */
      lower_bound_found         = FALSE;
      lb_len_idx                = CN_INTEGER_ONE_IDX;
      lb_fld                    = CN_Tbl_Idx;
      ub_len_idx                = NULL_IDX;
      ub_fld                    = NO_Tbl_Idx;

      if (LA_CH_VALUE != COLON && LA_CH_VALUE != STAR) {
         line           = LA_CH_LINE;
         column         = LA_CH_COLUMN;

         /* If LA_CH isn't a COLON or a STAR, then this must be an expression.*/
         /* Get the expression and determine if it is a lower or upper bound. */
         /* If there is a parse error, a constant one is returned.            */

         if (!parse_int_spec_expr(&ub_len_idx, &ub_fld, fold_it,
				  FALSE, FALSE)) {
            ub_len_idx          = CN_INTEGER_ONE_IDX;
            ub_fld              = CN_Tbl_Idx;
            BD_DCL_ERR(bd_idx)  = TRUE;
         }

         if (ub_fld != CN_Tbl_Idx) {
            non_constant_size   = TRUE;
         }

         if (LA_CH_VALUE == COLON) {                   /* This is lower bound */
            lower_bound_found           = TRUE;
            lb_len_idx                  = ub_len_idx;
            lb_fld                      = ub_fld;
            ub_len_idx                  = NULL_IDX;
            ub_fld                      = NO_Tbl_Idx;
         }
         else {
            BD_ARRAY_CLASS(bd_idx)      = Explicit_Shape;
         }
      }

      /* Now the parser is in one of 3 states. (1) Lower bound found, upper   */
      /* bound = NULL, LA_CH must be COLON. (2) Lower bound not found, so it  */
      /* is set to a default of 1, upper bound is found and LA_CH is COMMA or */
      /* RBRKT.   (LA_CH must be COLON.) (3) Neither lower bound or upper    */
      /* bound have been seen, they are set to defaults of lb=1, ub=NULL.     */
      /* LA_CH is COLON or STAR.  If the LA_CH is COLON, this is either a     */
      /* Deferred-Shape spec or it is followed by the upper bound for an      */
      /* Explicit-Shape spec.  NOTE: LA_CH may be EOS - this is parse error.  */

      if (LA_CH_VALUE == COLON) {
         line           = LA_CH_LINE;
         column         = LA_CH_COLUMN;
         NEXT_LA_CH;                            /* Skip COLON */

         if (LA_CH_VALUE == COMMA || LA_CH_VALUE == RBRKT) {

            /* Have one of two cases  1)  ARRAY(1:)  - This is an assumed     */
            /* shape spec which is classed as a Deferred-Shape, or 2) ARRAY(:)*/
            /* which is a deferred-Shape spec.   Issue an error if this array */
            /* has already been classified as an Explicit_Shape array.        */

            if (BD_ARRAY_CLASS(bd_idx) == Explicit_Shape) {
               PRINTMSG(line, 115, Error, column);
               BD_DCL_ERR(bd_idx)       = TRUE;
            }
            else {  /* Must be Deferred-Shape spec */
               BD_ARRAY_CLASS(bd_idx)   = Deferred_Shape;
            }
         }
         else {

            /* Have one of two cases  1)  ARRAY (1:10) - legal - pick up upper*/
            /* bound expression.  Err if array is already set to Deferred-    */
            /* Shape spec.  2) ARRAY (:10) - illegal - issue error.           */
            /* If the upper bound is a STAR, pick it up in the next section.  */

            if (!lower_bound_found) {                   /* A(:10) - illegal   */
               PRINTMSG(LA_CH_LINE, 119, Error, LA_CH_COLUMN, &LA_CH_VALUE);
               BD_DCL_ERR(bd_idx)       = TRUE;
            }

            if (LA_CH_VALUE != STAR) {
               line     = LA_CH_LINE;
               column   = LA_CH_COLUMN;

               if (!parse_int_spec_expr(&ub_len_idx, &ub_fld, fold_it,
					FALSE, FALSE)) {

                  /* Expression parser recovers LA_CH to : ) , or EOS */

                  BD_DCL_ERR(bd_idx)    = TRUE;
                  ub_len_idx            = CN_INTEGER_ONE_IDX;
                  ub_fld                = CN_Tbl_Idx;
               }

               if (ub_fld != CN_Tbl_Idx) {
                  non_constant_size     = TRUE;
               }

               BD_ARRAY_CLASS(bd_idx)= Explicit_Shape;
            }
         }
      }

      /* The parser may be:  1)  ARRAY(*) - lb=1, ub=NULL_IDX.  2) ARR(10:*)  */
      /* lb is set, and ub=NULL_IDX.  3)  ARRAY(:*) - illegal -error already  */
      /* issued.  You could not have picked up a lower bound and/or an upper  */
      /* bound and got to this position, because a * is part of an expression.*/
      /* The expression parser stops at COLON, COMMA, RBRKT or EOS.          */

      if (LA_CH_VALUE == STAR) {
         line   = LA_CH_LINE;
         column = LA_CH_COLUMN;
         NEXT_LA_CH;                            /* Skip STAR */

         BD_ARRAY_CLASS(bd_idx)      = Assumed_Size;
         ub_len_idx                  = lb_len_idx;
         ub_fld                      = lb_fld;

         if (LA_CH_VALUE != RBRKT) {

            /* The assumed-size specifier * must be in the last dimension. */

            BD_DCL_ERR(bd_idx)       = TRUE;
            PRINTMSG(line, 116, Error, column);
            parse_err_flush(Find_Rparen, NULL);
         }
      }

      BD_LB_IDX(bd_idx, rank)   = lb_len_idx;
      BD_LB_FLD(bd_idx, rank)   = lb_fld;
      BD_UB_IDX(bd_idx, rank)   = ub_len_idx;
      BD_UB_FLD(bd_idx, rank)   = ub_fld;

      if (LA_CH_VALUE == COMMA) {

         if (rank++ == 7) {          /* issue error - too many ranks */
            found_end           = TRUE;
            BD_DCL_ERR(bd_idx)  = TRUE;
            PRINTMSG(LA_CH_LINE, 117, Error, LA_CH_COLUMN);
            parse_err_flush(Find_Rparen, NULL);
         }
         else {
            NEXT_LA_CH;
         }
      }
      else {
         found_end = TRUE;
      }

      found_error = BD_DCL_ERR(bd_idx) | found_error;
   }
   while (!found_end);

   if (LA_CH_VALUE == RBRKT ||
       parse_err_flush(Find_EOS, (found_error) ? NULL : ", or )")) {

      NEXT_LA_CH;               /* Skip RBRKT */
   }

   if (!non_constant_size) {
      BD_ARRAY_SIZE(bd_idx) = Constant_Size;
   }

   BD_RANK(bd_idx) = rank;

# ifdef _DEBUG
   if (BD_ARRAY_CLASS(bd_idx) == Unknown_Array) {

      /* There is a parsing problem here.  This must never be Unknown_Array */

      PRINTMSG(LA_CH_LINE, 178, Internal, LA_CH_COLUMN);
   }
# endif

EXIT:

   if (AT_REFERENCED(attr_idx) > Not_Referenced) {
      is_attr_referenced_in_bound(bd_idx, attr_idx);
   }

   if (AT_REFERENCED(attr_idx) < referenced) {
      AT_REFERENCED(attr_idx)   = referenced;
   }

   bd_idx = ntr_array_in_bd_tbl(bd_idx);

   TRACE (Func_Exit, "parse_pe_array_spec", NULL);

   return(bd_idx);

}  /* parse_pe_array_spec */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Add the co-array attribute to the attr.             		      *|
|*									      *|
|* Input parameters:							      *|
|*	chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
|*	                 is FALSE, just add the attribute to the Attr.        *|
|*	line          -> The line number of the object.                       *|
|*	column        -> The column number of the object.                     *|
|*	attr_idx      -> Attr index to add the co-array attribute to.         *|
|*	pe_array_idx  -> bounds table index describing the co-array.          *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if successful merge.					      *|
|*									      *|
\******************************************************************************/

boolean merge_co_array(boolean	chk_semantics,
	           int		line,
		   int		column,
		   int		attr_idx,
		   int		pe_array_idx)
{
   boolean	fnd_err;


   TRACE (Func_Entry, "merge_co_array", NULL);
   
   if (!chk_semantics || !fnd_semantic_err(Obj_Co_Array,
                                           line,
                                           column,
                                           attr_idx,
                                           TRUE)) {
      ATD_PE_ARRAY_IDX(attr_idx) = pe_array_idx;
      fnd_err	= FALSE;
   }
   else {
      fnd_err	= TRUE;
   }

   TRACE (Func_Exit, "merge_co_array", NULL);

   return(!fnd_err);

}  /* merge_co_array */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Add the SAVE attribute to an attr.			      	      *|
|*									      *|
|* Input parameters:							      *|
|*	chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
|*	                 is FALSE, just add the attribute to the attr.        *|
|*	line     -> The line number of the object to add the attribute to     *|
|*	column   -> The line number of the object to add the attribute to     *|
|*	attr_idx -> Attr index to add the EXTERNAL attribute to.              *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	TRUE if successful merge.					      *|
|*									      *|
\******************************************************************************/

boolean merge_volatile(boolean	chk_semantics,
	               int		line,
		       int		column,
		       int		attr_idx)

{
   boolean	fnd_err		= FALSE;


   TRACE (Func_Entry, "merge_volatile", NULL);

   if (chk_semantics) {
      fnd_err = fnd_semantic_err(Obj_Volatile, line, column, attr_idx, TRUE);

#ifdef KEY /* Bug 14110 */
      if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
	 ATD_INTENT(attr_idx) == Intent_In) {
	 PRINTMSG(line, 550, Error, column, AT_OBJ_NAME_PTR(attr_idx),
	    "INTENT(IN)", "VOLATILE", AT_DEF_LINE(attr_idx));
      }
#endif /* KEY Bug 14110 */

      if (!fnd_err && ATD_VOLATILE(attr_idx)) {
#ifdef KEY /* Bug 5040 */
         PRINTMSG(line, 1259, ansi_or_warning(), column,
	   AT_OBJ_NAME_PTR(attr_idx), AT_DEF_LINE(attr_idx), "VOLATILE");
#else /* KEY Bug 5040 */
         PRINTMSG(line, 1259, Ansi, column, AT_OBJ_NAME_PTR(attr_idx), 
                  "VOLATILE");
#endif /* KEY Bug 5040 */
      }
   }
   else {
      SET_IMPL_TYPE(attr_idx);
   }

   if (!fnd_err) {
      ATD_VOLATILE(attr_idx)	= TRUE;
   }

   TRACE (Func_Exit, "merge_volatile", NULL);

   return(!fnd_err);

}  /* merge_volatile */
#ifdef KEY /* Bug 14150 */
/*
 *	BNF is
 *		( C )
 *	or
 *	      	( C [, NAME = scalar-char-initialization-expr ] )
 *
 *  result	If null on input, then we don't allow the optional clause.
 *		Otherwise, we set TOKEN_LINE(*result) and TOKEN_COLUMN(*result).
 *		We set BIND_SPECIFIES_NAME(*result) to indicate whether the
 *		optional clause is present, and if so, we set TOKEN_STR(*result)
 *		and TOKEN_LEN(*result). Note that the presence of the optional
 *		clause is semantically different than its absence, even if the
 *		string is empty.
 *
 *  returns	1 if parsed ok, 0 if erroneous
 */
int
parse_language_binding_spec(token_type *result) {
  int ok = 1;
  if (result) {
    TOKEN_LEN(*result) = 0;
    TOKEN_LINE(*result) = LA_CH_LINE;
    TOKEN_COLUMN(*result) = LA_CH_COLUMN;
    SET_BIND_SPECIFIES_NAME(*result, FALSE);
  }

  if (LA_CH_VALUE != LPAREN) {
    parse_err_flush(Find_EOS, "(");
    return 0;
  }
  NEXT_LA_CH; /* Consume left paren */
  if (LA_CH_VALUE != 'C' && LA_CH_VALUE != 'c') {
    parse_err_flush(Find_EOS, "C");
    return 0;
  }
  NEXT_LA_CH; /* Consume 'c' */
  if (result) {
    if (LA_CH_VALUE == COMMA) {
      NEXT_LA_CH; /* Consume comma */
      if (!matched_specific_token(Tok_Kwd_Name, Tok_Class_Keyword)) {
	parse_err_flush(Find_Rparen, "NAME");
	if (LA_CH_VALUE == RPAREN) {
	  NEXT_LA_CH;
	}
	return 0;
      }
      if (LA_CH_VALUE != EQUAL) {
	parse_err_flush(Find_Rparen, "=");
	if (LA_CH_VALUE == RPAREN) {
	  NEXT_LA_CH;
	}
	return 0;
      }
      NEXT_LA_CH; /* Consume equal */
      opnd_type opnd;
      check_type_conversion = FALSE; /* TRUE causes exp_desc to be wrong */
      target_type_idx = 0;
      target_char_len_idx = 0;
      expr_arg_type exp_desc = init_exp_desc;
      exp_desc.rank = 0;
      expr_mode_type save_expr_mode = expr_mode;
      expr_mode = Initialization_Expr;
      xref_state = CIF_Symbol_Reference;
      comp_gen_expr = TRUE;
      if (parse_expr(&opnd) && expr_semantics(&opnd, &exp_desc)) {
	TOKEN_LINE(*result) = opnd.line_num;
	TOKEN_COLUMN(*result) = opnd.col_num;
        if (exp_desc.type != Character ||
	  exp_desc.linear_type != Short_Char_Const ||
	  !exp_desc.constant || exp_desc.rank) {
	  PRINTMSG(opnd.line_num, 1690, Error, opnd.col_num);
	  ok = 0;
	  }
	else {
	  int len = CN_INT_TO_C(exp_desc.char_len.idx);
	  /* Sigh. CN table doesn't null terminate. */
	  memcpy(TOKEN_STR(*result), (char *) &CN_CONST(opnd.idx), len);
	  TOKEN_LEN(*result) = len;
	  SET_BIND_SPECIFIES_NAME(*result, TRUE);
	}
      }
    expr_mode = save_expr_mode;
    }
  }
  if (LA_CH_VALUE != RPAREN) {
    parse_err_flush(Find_Rparen, ")");
    if (LA_CH_VALUE == RPAREN) {
      NEXT_LA_CH; /* Consume right paren */
      return 0;
    }
  }
  NEXT_LA_CH; /* Consume right paren */
  return ok;
}
#endif /* KEY Bug 14150 */
