Open64 (mfef90, whirl2f, and IR tools): osprey1.0/crayf90/fe90/s

Go to the documentation of this file.
00001 /*
00002 
00003   Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.
00004 
00005   This program is free software; you can redistribute it and/or modify it
00006   under the terms of version 2 of the GNU General Public License as
00007   published by the Free Software Foundation.
00008 
00009   This program is distributed in the hope that it would be useful, but
00010   WITHOUT ANY WARRANTY; without even the implied warranty of
00011   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  
00012 
00013   Further, this software is distributed without any warranty that it is
00014   free of the rightful claim of any third person regarding infringement 
00015   or the like.  Any license provided herein, whether implied or 
00016   otherwise, applies only to this software file.  Patent licenses, if 
00017   any, provided herein do not apply to combinations of this program with 
00018   other software, or any other product whatsoever.  
00019 
00020   You should have received a copy of the GNU General Public License along
00021   with this program; if not, write the Free Software Foundation, Inc., 59
00022   Temple Place - Suite 330, Boston MA 02111-1307, USA.
00023 
00024   Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
00025   Mountain View, CA 94043, or:
00026 
00027   http://www.sgi.com
00028 
00029   For further information regarding this notice, see:
00030 
00031   http://oss.sgi.com/projects/GenInfo/NoticeExplan
00032 
00033 */
00034 
00035 
00036 
00037 static char USMID[] = "\n@(#)5.0_pl/sources/s_dcls.c    5.7     09/29/99 17:38:13\n";
00038 
00039 # include "defines.h"           /* Machine dependent ifdefs */
00040 
00041 # include "host.m"              /* Host machine dependent macros.*/
00042 # include "host.h"              /* Host machine dependent header.*/
00043 # include "target.m"            /* Target machine dependent macros.*/
00044 # include "target.h"            /* Target machine dependent header.*/
00045 
00046 # include "globals.m"
00047 # include "tokens.m"
00048 # include "sytb.m"
00049 # include "s_globals.m"
00050 # include "debug.m"
00051 
00052 # include "globals.h"
00053 # include "tokens.h"
00054 # include "sytb.h"
00055 # include "s_globals.h"
00056 
00057 
00058 /*********************************************************\
00059 |* Globals used between decl_semantics and attr_semantics |
00060 \*********************************************************/
00061 
00062         int     allocatable_list_idx;
00063         int     alt_entry_equiv_blk;
00064         int     alt_entry_equiv_grp;
00065         int     init_sh_start_idx;
00066         int     init_sh_end_idx;
00067         int     namelist_list_idx;
00068         int     number_of_allocatables;
00069         int     pointee_based_blk;
00070         int     reshape_array_list;
00071 
00072 
00073 /*****************************************************************\
00074 |* Function prototypes of static functions declared in this file *|
00075 \*****************************************************************/
00076 
00077 static  void    assign_offsets_for_equiv_groups(void);
00078 static  void    attr_semantics(int, boolean);
00079 static  void    bound_resolution(int);
00080 static  boolean compare_darg_or_rslt_types(int, int);
00081 static  void    compare_duplicate_interface_bodies(int);
00082 static  void    compare_entry_to_func_rslt(int, int);
00083 static  boolean darg_in_entry_list(int, int);
00084 static  void    deallocate_local_allocatables(void);
00085 static  void    distribution_resolution(int);
00086 static  void    equivalence_semantics(void);
00087 static  void    gen_assumed_shape_copy(opnd_type *);
00088 static  int     gen_auto_length(int, opnd_type *);
00089 static  void    gen_branch_around_ir(int, int, int);
00090 static  int     gen_darg_branch_test(int);
00091 static  boolean gen_ir_at_this_entry(int, int);
00092 static  void    gen_present_ir(int, int, int);
00093 static  void    gen_single_automatic_allocate(int);
00094 static  void    gen_tmp_eq_zero_ir(int);
00095 static  void    insert_argchck_calls(int, int);
00096 static  void    insert_sh_after_entries(int, int, int, boolean, boolean);
00097 static  void    linearize_list_for_equiv(int);
00098 static  int     merge_entry_lists(int, int);
00099 static  int     merge_entry_list_count(int, int);
00100 static  void    merge_equivalence_groups1(void);
00101 static  void    merge_equivalence_groups2(void);
00102 static  boolean must_reassign_XT_temp(opnd_type *);
00103 static  void    namelist_resolution(int);
00104 static  int     ntr_bnds_sh_tmp_list(opnd_type *, int, int, boolean, int);
00105 static  void    reshape_array_semantics(void);
00106 static  void    tmp_il_resolution(int);
00107 static  void    tmp_ir_resolution(int);
00108 static  void    verify_interface (int);
00109 static  void    gen_allocatable_ptr_ptee(int);
00110 static  int     set_up_bd_tmps(int, int, int, int, boolean);
00111 
00112 # if defined(_TARGET_WORD_ADDRESS) ||  \
00113      (defined(_HEAP_REQUEST_IN_WORDS) && defined(_TARGET_BYTE_ADDRESS))
00114 static  void    gen_word_align_byte_length_ir(opnd_type *);
00115 # endif
00116 
00117 # if !defined(_SINGLE_ALLOCS_FOR_AUTOMATIC)
00118 static  void    gen_multiple_automatic_allocate(int);
00119 # endif
00120 
00121 # if (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
00122 # pragma inline create_equiv_stor_blk
00123 # else
00124 # pragma _CRI inline create_equiv_stor_blk
00125 # endif
00126 
00127 
00128 /******************************************************************************\
00129 |*                                                                            *|
00130 |* Description:                                                               *|
00131 |*      Perform semantic checks for EQUIVALENCE statements.                   *|
00132 |*                                                                            *|
00133 |* Input parameters:                                                          *|
00134 |*      NONE                                                                  *|
00135 |*                                                                            *|
00136 |* Output parameters:                                                         *|
00137 |*      NONE                                                                  *|
00138 |*                                                                            *|
00139 |* Returns:                                                                   *|
00140 |*      NONE                                                                  *|
00141 |*                                                                            *|
00142 \******************************************************************************/
00143 static void     equivalence_semantics(void)
00144 {
00145 
00146    int                  attr_idx;
00147    boolean              automatic;
00148    int                  common_attr_idx;
00149    int                  common_sb_idx;
00150    boolean              default_numeric_sequence;
00151    boolean              default_numeric_type;
00152    boolean              default_character_sequence;
00153    boolean              default_character_type;
00154    int                  group;
00155    int                  il_idx;
00156    int                  ir_idx;
00157    boolean              is_volatile;
00158    int                  item;
00159    int                  list_idx;
00160    int                  new_idx;
00161    int                  nondefault_sequence_type;
00162    int                  nondefault_intrinsic_type;
00163    int                  offset_idx;
00164    boolean              ok;
00165    opnd_type            opnd;
00166    expr_arg_type        opnd_desc;
00167    long_type            result[MAX_WORDS_FOR_INTEGER];
00168    cif_usage_code_type  save_xref_state;
00169    int                  sb_idx;
00170    int                  subscript_count;
00171    int                  substring_list;
00172    int                  type_idx;
00173 
00174 
00175    TRACE (Func_Entry, "equivalence_semantics", NULL);
00176 
00177    group = SCP_FIRST_EQUIV_GRP(curr_scp_idx);
00178 
00179    while (group != NULL_IDX) {
00180       item              = group;
00181       common_attr_idx   = NULL_IDX;
00182       common_sb_idx     = NULL_IDX;
00183 
00184       while (item != NULL_IDX) {
00185 
00186          if (ATD_IN_COMMON(EQ_ATTR_IDX(item))) {
00187 
00188             if (common_sb_idx == NULL_IDX) {
00189                common_attr_idx  = EQ_ATTR_IDX(item);
00190                common_sb_idx    = ATD_STOR_BLK_IDX(common_attr_idx);
00191             }
00192             else if (common_sb_idx != ATD_STOR_BLK_IDX(common_attr_idx)) {
00193 
00194                /* Two different items from the same common */
00195                /* block are equivalenced together.         */
00196 
00197                PRINTMSG(EQ_LINE_NUM(item), 826, Error, EQ_COLUMN_NUM(item),
00198                         AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)),
00199                         AT_OBJ_NAME_PTR(common_attr_idx));
00200             }
00201 
00202             if (SB_BLK_HAS_NPES(common_sb_idx)) {
00203                PRINTMSG(EQ_LINE_NUM(item), 1228, Error, EQ_COLUMN_NUM(item),
00204                         AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)),
00205                         SB_BLANK_COMMON(common_sb_idx) ?
00206                         "" : SB_NAME_PTR(common_sb_idx));
00207                AT_DCL_ERR(EQ_ATTR_IDX(item))    = TRUE;
00208             }
00209 
00210 # if 0
00211             if (SB_ALIGN_SYMBOL(common_sb_idx) ||
00212                 SB_FILL_SYMBOL(common_sb_idx)) {
00213                AT_DCL_ERR(EQ_ATTR_IDX(item))    = TRUE;
00214                PRINTMSG(EQ_LINE_NUM(item), 1488, Error, EQ_COLUMN_NUM(item),
00215                         AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)),
00216                         SB_NAME_PTR(common_sb_idx),
00217                         SB_ALIGN_SYMBOL(common_sb_idx) ? "ALIGN_SYMBOL" :
00218                                                          "FILL_SYMBOL");
00219             }
00220 # endif
00221          }
00222 # if 0
00223          else if (SB_MODULE(ATD_STOR_BLK_IDX(EQ_ATTR_IDX(item))) &&
00224                   (SB_ALIGN_SYMBOL(ATD_STOR_BLK_IDX(EQ_ATTR_IDX(item))) ||
00225                    SB_FILL_SYMBOL(ATD_STOR_BLK_IDX(EQ_ATTR_IDX(item))))) {
00226             AT_DCL_ERR(EQ_ATTR_IDX(item))       = TRUE;
00227             PRINTMSG(EQ_LINE_NUM(item), 1489, Error, EQ_COLUMN_NUM(item),
00228                      AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)),
00229                      AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)),
00230                      SB_ALIGN_SYMBOL(ATD_STOR_BLK_IDX(EQ_ATTR_IDX(item))) ?
00231                                      "ALIGN_SYMBOL" : "FILL_SYMBOL");
00232          }
00233 # endif
00234 
00235          if (EQ_OPND_FLD(item) == NO_Tbl_Idx) {
00236 
00237             /* if stand alone name, then offset is set to 0 */
00238 
00239             NTR_IR_LIST_TBL(new_idx);
00240             EQ_LIST_IDX(item)           = new_idx;
00241             IL_FLD(new_idx)             = CN_Tbl_Idx;
00242             IL_IDX(new_idx)             = CN_INTEGER_ZERO_IDX;
00243             IL_LINE_NUM(new_idx)        = 1;
00244             IL_COL_NUM(new_idx)         = 0;
00245          }
00246          else if ((!EQ_SUBSTRINGED(item) && 
00247                    ATD_ARRAY_IDX(EQ_ATTR_IDX(item)) == NULL_IDX) ||
00248                   (EQ_SUBSTRINGED(item) &&
00249                    TYP_TYPE(ATD_TYPE_IDX(EQ_ATTR_IDX(item))) != Character)) {
00250             AT_DCL_ERR(EQ_ATTR_IDX(item)) = TRUE;
00251             PRINTMSG(EQ_LINE_NUM(item), 840, Error,
00252                      EQ_COLUMN_NUM(item),
00253                      AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)));
00254             NTR_IR_LIST_TBL(new_idx);
00255             EQ_LIST_IDX(item)           = new_idx;
00256             IL_FLD(new_idx)             = CN_Tbl_Idx;
00257             IL_IDX(new_idx)             = CN_INTEGER_ZERO_IDX;
00258             IL_LINE_NUM(new_idx)        = 1;
00259             IL_COL_NUM(new_idx)         = 0;
00260          }
00261          else {
00262 
00263             /* this is true only if something follows the object */
00264             /* that is a subscript and or substring              */
00265 
00266             OPND_FLD(opnd)              = EQ_OPND_FLD(item);
00267             OPND_IDX(opnd)              = EQ_OPND_IDX(item);
00268             OPND_LINE_NUM(opnd)         = EQ_LINE_NUM(item);
00269             OPND_COL_NUM(opnd)          = EQ_COLUMN_NUM(item);
00270             opnd_desc.rank              = 0;
00271             expr_mode                   = Initialization_Expr;
00272             save_xref_state             = xref_state;
00273             xref_state                  = CIF_Symbol_Reference;
00274             attr_idx                    = find_left_attr(&opnd);
00275             ATD_PARENT_OBJECT(attr_idx) = TRUE;
00276             ok                          = expr_semantics(&opnd, &opnd_desc);
00277             xref_state                  = save_xref_state;
00278             expr_mode                   = Regular_Expr;
00279             ATD_PARENT_OBJECT(attr_idx) = FALSE;
00280 
00281             if (!ok) {
00282                EQ_LIST_IDX(item)= NULL_IDX;
00283                EQ_ERROR(item)   = TRUE;
00284                item             = EQ_NEXT_EQUIV_OBJ(item);
00285                continue;
00286             }
00287 
00288             /* Break the subscripts and substrings up. */
00289 
00290             subscript_count     = 0;
00291             substring_list      = NULL_IDX;
00292 
00293             ir_idx = (OPND_FLD(opnd) == IR_Tbl_Idx) ? OPND_IDX(opnd): NULL_IDX;
00294 
00295             if (ir_idx != NULL_IDX &&
00296                 (IR_OPR(ir_idx) == Substring_Opr ||
00297                  IR_OPR(ir_idx) == Whole_Substring_Opr)) {
00298                EQ_SUBSTRINGED(item)     = TRUE;
00299                substring_list           = IR_IDX_R(ir_idx);
00300                ir_idx = (IR_FLD_L(ir_idx) == IR_Tbl_Idx) ? IR_IDX_L(ir_idx) :
00301                                                            NULL_IDX;
00302             }
00303 
00304             if (ir_idx != NULL_IDX &&
00305                  IR_OPR(ir_idx) == Whole_Subscript_Opr) {
00306                ir_idx = (IR_FLD_L(ir_idx) == IR_Tbl_Idx) ? IR_IDX_L(ir_idx) :
00307                                                            NULL_IDX;
00308             }
00309 
00310             if (ir_idx != NULL_IDX && 
00311                 (IR_OPR(ir_idx) == Section_Subscript_Opr ||
00312                  IR_OPR(ir_idx) == Struct_Opr)) {
00313 
00314                if (IR_OPR(ir_idx) == Section_Subscript_Opr) {
00315                   PRINTMSG(EQ_LINE_NUM(item), 250, Error, EQ_COLUMN_NUM(item));
00316                }
00317                else {
00318                   PRINTMSG(EQ_LINE_NUM(item), 1537, Error, EQ_COLUMN_NUM(item));
00319                }
00320 
00321 
00322                EQ_LIST_IDX(item)        = NULL_IDX;
00323                EQ_ERROR(item)           = TRUE;
00324                item                     = EQ_NEXT_EQUIV_OBJ(item);
00325                continue;
00326             }
00327 
00328             if (ir_idx != NULL_IDX && 
00329                 (IR_OPR(ir_idx) == Subscript_Opr ||
00330                  IR_OPR(ir_idx) == Whole_Subscript_Opr ||
00331                  IR_OPR(ir_idx) == Section_Subscript_Opr)) {
00332                subscript_count   = IR_LIST_CNT_R(ir_idx);
00333                EQ_LIST_IDX(item) = IR_IDX_R(ir_idx);
00334             }
00335 
00336             if (substring_list != NULL_IDX) {  /* Add the substring list */
00337 
00338                if (EQ_LIST_IDX(item) == NULL_IDX) {
00339                   EQ_LIST_IDX(item) = substring_list;
00340                }
00341                else {
00342                   il_idx = EQ_LIST_IDX(item);
00343 
00344                   while (IL_NEXT_LIST_IDX(il_idx) != NULL_IDX) {
00345                      il_idx = IL_NEXT_LIST_IDX(il_idx);
00346                   }
00347                   IL_NEXT_LIST_IDX(il_idx) = substring_list;
00348                }
00349 
00350                il_idx = IL_NEXT_LIST_IDX(substring_list);  /* End substring*/
00351                il_idx = IL_NEXT_LIST_IDX(il_idx);
00352 
00353                /* il_idx is now the character length in the substring.  */
00354                /* This is not needed, but a NULL entry is, so clear it. */
00355                /* But check for a zero length substring first.          */
00356 
00357                if (IL_FLD(il_idx) == CN_Tbl_Idx) {
00358                   type_idx    = CG_LOGICAL_DEFAULT_TYPE;
00359 
00360                   folder_driver((char *) &CN_CONST(IL_IDX(il_idx)),
00361                                          CN_TYPE_IDX(IL_IDX(il_idx)),
00362                                 (char *) &CN_CONST(CN_INTEGER_ZERO_IDX),
00363                                          CN_TYPE_IDX(CN_INTEGER_ZERO_IDX),
00364                                          result,
00365                                          &type_idx,
00366                                          EQ_LINE_NUM(item),
00367                                          EQ_COLUMN_NUM(item),
00368                                          2,
00369                                          Le_Opr);
00370 
00371                  if (THIS_IS_TRUE(result, type_idx)) {
00372                     PRINTMSG(EQ_LINE_NUM(item), 1627,Error,EQ_COLUMN_NUM(item));
00373                  }
00374                }
00375                IL_OPND(il_idx) = null_opnd;
00376             }
00377             else if (EQ_LIST_IDX(item) != NULL_IDX) {
00378 
00379                /* Just have subscripts.  Find end of list and add NULL */
00380 
00381                il_idx = EQ_LIST_IDX(item);
00382 
00383                while (IL_NEXT_LIST_IDX(il_idx) != NULL_IDX) {
00384                   il_idx = IL_NEXT_LIST_IDX(il_idx);
00385                }
00386                NTR_IR_LIST_TBL(new_idx);
00387                IL_NEXT_LIST_IDX(il_idx) = new_idx;
00388                IL_OPND(new_idx)         = null_opnd;
00389                IL_LINE_NUM(new_idx)     = EQ_LINE_NUM(item);
00390                IL_COL_NUM(new_idx)      = EQ_COLUMN_NUM(item);
00391             }
00392 
00393             EQ_OPND_FLD(item)   = NO_Tbl_Idx;
00394             EQ_OPND_IDX(item)   = NULL_IDX;
00395 
00396             if (ATD_ARRAY_IDX(EQ_ATTR_IDX(item)) > 0) {
00397 
00398                if (! dump_flags.no_dimension_padding &&
00399                    subscript_count < BD_RANK(ATD_ARRAY_IDX(EQ_ATTR_IDX(item)))){
00400                   PRINTMSG(EQ_LINE_NUM(item), 375, Warning, 
00401                            EQ_COLUMN_NUM(item));
00402                }
00403                else if (subscript_count > 
00404                         BD_RANK(ATD_ARRAY_IDX(EQ_ATTR_IDX(item)))) {
00405                   PRINTMSG(EQ_LINE_NUM(item), 204, Error, 
00406                            EQ_COLUMN_NUM(item));
00407 
00408                   /* Do not want to call linearize_list_for_equiv because the */
00409                   /* rank of the array is less than the number of dimension.  */
00410 
00411                   item = EQ_NEXT_EQUIV_OBJ(item);
00412                   continue;
00413                }
00414             }
00415 
00416             linearize_list_for_equiv(item);
00417          }
00418 
00419          item = EQ_NEXT_EQUIV_OBJ(item);
00420       }
00421       group = EQ_NEXT_EQUIV_GRP(group);
00422    }
00423 
00424    merge_equivalence_groups1();
00425 
00426    assign_offsets_for_equiv_groups();
00427 
00428    merge_equivalence_groups2();
00429 
00430    group = SCP_FIRST_EQUIV_GRP(curr_scp_idx);
00431 
00432    while (group != NULL_IDX) {
00433       item              = group;
00434       sb_idx            = NULL_IDX;
00435       automatic         = FALSE;
00436       is_volatile       = FALSE;
00437 
00438       while (item != NULL_IDX) {
00439 
00440          if (EQ_ERROR(item)) {
00441             item = EQ_NEXT_EQUIV_OBJ(item);
00442             continue;
00443          }
00444 
00445          attr_idx       = EQ_ATTR_IDX(item);
00446 
00447          if (!EQ_SEARCH_DONE(item) &&
00448              (ATD_CLASS(EQ_ATTR_IDX(item)) == Variable &&
00449               ATD_EQUIV_LIST(EQ_ATTR_IDX(item)) != NULL_IDX)) {
00450 
00451             /* This attr is in this equivalence group more than once. */
00452             /* All these items need to have the same offset.  We make */
00453             /* the assumption that the constant table shares entries, */
00454             /* so all these offset indexes should be the same.  If    */
00455             /* they are not, issue an error.                          */
00456 
00457             list_idx                    = ATD_EQUIV_LIST(EQ_ATTR_IDX(item));
00458             offset_idx                  = EQ_OFFSET_IDX(item);
00459             EQ_SEARCH_DONE(item)        = TRUE;
00460 
00461             while (list_idx != NULL_IDX) {
00462 
00463             if (fold_relationals(EQ_OFFSET_IDX(AL_EQ_IDX(list_idx)),
00464                                  offset_idx,
00465                                  Ne_Opr)) {
00466 
00467                   PRINTMSG(EQ_LINE_NUM(item), 528, Error,
00468                            EQ_COLUMN_NUM(item),
00469                            AT_OBJ_NAME_PTR(attr_idx));
00470                }
00471 
00472                list_idx = AL_NEXT_IDX(list_idx);
00473             }
00474          }
00475 
00476          if (sb_idx != NULL_IDX && sb_idx != ATD_STOR_BLK_IDX(attr_idx) &&
00477              SB_IS_COMMON(ATD_STOR_BLK_IDX(attr_idx)) &&
00478              SB_IS_COMMON(sb_idx)) {
00479             PRINTMSG(EQ_LINE_NUM(item), 823, Error,
00480                      EQ_COLUMN_NUM(item),
00481                      SB_BLANK_COMMON(sb_idx) ?
00482                      "" : SB_NAME_PTR(sb_idx),
00483                      SB_BLANK_COMMON(ATD_STOR_BLK_IDX(attr_idx)) ?
00484                      "" : SB_NAME_PTR(ATD_STOR_BLK_IDX(attr_idx)));
00485          }
00486 
00487          automatic   |= ATD_STACK(attr_idx);
00488          is_volatile |= ATD_VOLATILE(attr_idx);
00489 
00490          /* if item is in a common block move all items to that block */
00491 
00492          if (SB_IS_COMMON(ATD_STOR_BLK_IDX(attr_idx))) {
00493             sb_idx = ATD_STOR_BLK_IDX(attr_idx);
00494 
00495             /* If any item is in a common block and dalign is not     */
00496             /* specified on the commandline, none of the items in     */
00497             /* the equivalence group can be double aligned.           */
00498 
00499             EQ_DO_NOT_DALIGN(group) = !cmd_line_flags.dalign;
00500          }
00501          else if (SB_HOSTED_STATIC(ATD_STOR_BLK_IDX(attr_idx))) {
00502  
00503             if (sb_idx == NULL_IDX || !SB_IS_COMMON(sb_idx)) {
00504                sb_idx = ATD_STOR_BLK_IDX(attr_idx);
00505             }
00506          }
00507          else if (SB_HOSTED_STACK(ATD_STOR_BLK_IDX(attr_idx))) {
00508 
00509             if (sb_idx == NULL_IDX || 
00510                 (!SB_IS_COMMON(sb_idx) && !SB_HOSTED_STATIC(sb_idx))) {
00511                sb_idx = ATD_STOR_BLK_IDX(attr_idx);
00512             }
00513          }
00514          else if (SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx)) == Static ||
00515                   SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx)) == Static_Named ||
00516                   SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx)) == Static_Local) {
00517 
00518             if (sb_idx == NULL_IDX) {
00519 
00520                /* if no storage block yet and item is in @DATA */
00521                /* move all items to @DATA                      */
00522 
00523                sb_idx = ATD_STOR_BLK_IDX(attr_idx);
00524             }
00525          }
00526 
00527          if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure &&
00528              !cmd_line_flags.dalign &&
00529              ATT_DCL_NUMERIC_SEQ(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) {
00530             EQ_DO_NOT_DALIGN(group) = TRUE;
00531          }
00532 
00533          item = EQ_NEXT_EQUIV_OBJ(item);
00534       }
00535 
00536       if (sb_idx == NULL_IDX) {
00537          sb_idx = create_equiv_stor_blk(EQ_ATTR_IDX(group), Stack);
00538       }
00539 
00540 # if defined(_SEPARATE_NONCOMMON_EQUIV_GROUPS)
00541 
00542       else if (SB_HOSTED_STATIC(sb_idx)) {
00543          sb_idx = create_equiv_stor_blk(EQ_ATTR_IDX(group), Static);
00544          SB_HOSTED_STATIC(sb_idx)       = TRUE;
00545       }
00546       else if (SB_HOSTED_STACK(sb_idx)) {
00547          sb_idx = create_equiv_stor_blk(EQ_ATTR_IDX(group), Stack);
00548          SB_HOSTED_STACK(sb_idx)        = TRUE;
00549       }
00550       else if ((SB_BLK_TYPE(sb_idx) == Static ||
00551                 SB_BLK_TYPE(sb_idx) == Static_Named ||
00552                 SB_BLK_TYPE(sb_idx) == Static_Local) &&
00553                !SB_MODULE(sb_idx)) {
00554          sb_idx = create_equiv_stor_blk(EQ_ATTR_IDX(group),SB_BLK_TYPE(sb_idx));
00555       }
00556 # endif
00557 
00558       SB_EQUIVALENCED(sb_idx)           = TRUE;
00559 
00560       if (SB_PAD_BLK(sb_idx) && !SB_IS_COMMON(sb_idx)) {
00561          PRINTMSG(EQ_LINE_NUM(group), 1352, Warning, EQ_COLUMN_NUM(group));
00562       }
00563 
00564       item                              = group;
00565       default_numeric_sequence          = FALSE;
00566       default_numeric_type              = FALSE;
00567       default_character_sequence        = FALSE;
00568       default_character_type            = FALSE;
00569       nondefault_sequence_type          = NULL_IDX;
00570       nondefault_intrinsic_type         = NULL_IDX;
00571 
00572       /* An item in an equivalence group can be one of 6 type categories */
00573       /* according to the standard.  The standard only allows mixing of  */
00574       /* certain categories and Cray allows a few extra extensions.      */
00575 
00576       /* The categories are:                                             */
00577       /*   default_numeric_sequence   -> A derived type whose components */
00578       /*                                 are all default numeric types.  */
00579       /*   default_numeric_type       -> The type must be a default      */
00580       /*                                 numeric type.  (Not character,  */
00581       /*                                 derived type, or CRI pointer.)  */
00582       /*   default_character_sequence -> A derived type whose components */
00583       /*                                 are all default character types.*/
00584       /*   default_character_type     -> The type is default character.  */
00585       /*   nondefault_sequence_type   -> A derived type with mixed       */
00586       /*                                 components, both numeric and    */
00587       /*                                 character or non-default numeric*/
00588       /*   nondefault_intrinsic_type  -> The type is not a default type. */
00589 
00590 
00591       while (item != NULL_IDX) {
00592 
00593          if (EQ_ERROR(item)) {
00594             item = EQ_NEXT_EQUIV_OBJ(item);
00595             continue;
00596          }
00597 
00598          ATD_VOLATILE(EQ_ATTR_IDX(item))        = is_volatile;
00599 
00600          if (SB_IS_COMMON(sb_idx)) {
00601 
00602             if (ATD_SAVED(EQ_ATTR_IDX(item))) {
00603 
00604                /* An object with the SAVE attribute may not be */
00605                /* equivalenced to an object in a common block. */
00606 
00607                PRINTMSG(EQ_LINE_NUM(item), 1256, Error, EQ_COLUMN_NUM(item),
00608                         AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)),
00609                         "SAVE");
00610             }
00611 
00612             if (ATD_STACK(EQ_ATTR_IDX(item))) {
00613 
00614                /* An object with the AUTOMATIC attribute may not be */
00615                /* equivalenced to an object in a common block.      */
00616 
00617                PRINTMSG(EQ_LINE_NUM(item), 1256, Error, EQ_COLUMN_NUM(item),
00618                         AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)),
00619                         "AUTOMATIC");
00620             }
00621 
00622             if (TYP_TYPE(ATD_TYPE_IDX(EQ_ATTR_IDX(item))) == Structure &&
00623                ATT_DEFAULT_INITIALIZED(TYP_IDX(
00624                                        ATD_TYPE_IDX(EQ_ATTR_IDX(item))))) {
00625                PRINTMSG(EQ_LINE_NUM(item), 1591, Error, EQ_COLUMN_NUM(item),
00626                         AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)),
00627                         AT_OBJ_NAME_PTR(TYP_IDX(
00628                                         ATD_TYPE_IDX(EQ_ATTR_IDX(item)))));
00629             }
00630          }
00631          else if (automatic && !ATD_STACK(EQ_ATTR_IDX(item))) {
00632 
00633             /* All must have the automatic attribute.  */
00634 
00635             PRINTMSG(EQ_LINE_NUM(item), 1257, Error, EQ_COLUMN_NUM(item),
00636                      AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)),
00637                      "AUTOMATIC", "AUTOMATIC");
00638          }
00639 
00640          ATD_STOR_BLK_IDX(EQ_ATTR_IDX(item)) = sb_idx;
00641          type_idx                            = ATD_TYPE_IDX(EQ_ATTR_IDX(item));
00642 
00643          if (TYP_TYPE(type_idx) == Structure) {
00644 
00645             if (!ATT_SEQUENCE_SET(TYP_IDX(type_idx))) {
00646                PRINTMSG(EQ_LINE_NUM(item), 294, Error,
00647                         EQ_COLUMN_NUM(item),
00648                         AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)));
00649             }
00650 
00651             if (ATT_POINTER_CPNT(TYP_IDX(type_idx))) {
00652                PRINTMSG(EQ_LINE_NUM(item), 354, Error,
00653                         EQ_COLUMN_NUM(item),
00654                         AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)));
00655             }
00656 
00657             if (ATT_CHAR_SEQ(TYP_IDX(type_idx))) {
00658 
00659                /* default_character_sequence */
00660 
00661                if (default_numeric_sequence || default_numeric_type) {
00662                   PRINTMSG(EQ_LINE_NUM(item), 1239, Error,
00663                            EQ_COLUMN_NUM(item),
00664                            AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)));
00665                }
00666                else if (nondefault_sequence_type != NULL_IDX) {
00667                   PRINTMSG(EQ_LINE_NUM(nondefault_sequence_type), 1242, Error,
00668                            EQ_COLUMN_NUM(nondefault_sequence_type),
00669                            AT_OBJ_NAME_PTR(EQ_ATTR_IDX(
00670                                            nondefault_sequence_type)));
00671                }
00672                else if (nondefault_intrinsic_type != NULL_IDX) {
00673                   PRINTMSG(EQ_LINE_NUM(nondefault_intrinsic_type), 1241, Error,
00674                            EQ_COLUMN_NUM(nondefault_intrinsic_type),
00675                            AT_OBJ_NAME_PTR(EQ_ATTR_IDX(
00676                                            nondefault_intrinsic_type)));
00677                }
00678                else {
00679                   default_character_sequence    = TRUE;
00680                }
00681             }
00682             else if (!ATT_NON_DEFAULT_CPNT(TYP_IDX(type_idx)) &&
00683                       ATT_DCL_NUMERIC_SEQ(TYP_IDX(type_idx))) {
00684 
00685                /* default_numeric_sequence */
00686 
00687                if (default_character_sequence || default_character_type) {
00688                   PRINTMSG(EQ_LINE_NUM(item), 1240, Error,
00689                            EQ_COLUMN_NUM(item),
00690                            AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)));
00691                }
00692                else if (nondefault_sequence_type != NULL_IDX) {
00693                   PRINTMSG(EQ_LINE_NUM(nondefault_sequence_type), 1242, Error,
00694                            EQ_COLUMN_NUM(nondefault_sequence_type),
00695                            AT_OBJ_NAME_PTR(EQ_ATTR_IDX(
00696                                            nondefault_sequence_type)));
00697                }
00698                else if (nondefault_intrinsic_type != NULL_IDX) {
00699                   PRINTMSG(EQ_LINE_NUM(nondefault_intrinsic_type), 1241, Error,
00700                            EQ_COLUMN_NUM(nondefault_intrinsic_type),
00701                            AT_OBJ_NAME_PTR(EQ_ATTR_IDX(
00702                                            nondefault_intrinsic_type)));
00703                }
00704 
00705                else {
00706 
00707 # if defined(_ACCEPT_CMD_s_32)
00708                   if (cmd_line_flags.s_default32) {
00709                      PRINTMSG(EQ_LINE_NUM(item), 1244, Warning,
00710                               EQ_COLUMN_NUM(item),
00711                               AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)),
00712                               AT_OBJ_NAME_PTR(TYP_IDX(type_idx)));
00713                   }
00714 # endif
00715                   default_numeric_sequence      = TRUE;
00716                }
00717             }
00718             else {  /* nondefault sequence type */
00719 
00720                if (default_character_sequence || default_character_type) {
00721                   PRINTMSG(EQ_LINE_NUM(item), 1240, Error,
00722                            EQ_COLUMN_NUM(item),
00723                            AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)));
00724                }
00725                else if (default_numeric_sequence || default_numeric_type) {
00726                   PRINTMSG(EQ_LINE_NUM(item), 1239, Error,
00727                               EQ_COLUMN_NUM(item),
00728                               AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)));
00729                }
00730                else if (nondefault_intrinsic_type != NULL_IDX) {
00731                   PRINTMSG(EQ_LINE_NUM(nondefault_intrinsic_type), 1241, Error,
00732                            EQ_COLUMN_NUM(nondefault_intrinsic_type),
00733                            AT_OBJ_NAME_PTR(EQ_ATTR_IDX(
00734                                            nondefault_intrinsic_type)));
00735                }
00736 #if 0
00737 /* 28Feb01[sos] : deleted for PV 816483 */
00738                else if (nondefault_sequence_type != NULL_IDX &&
00739                         !compare_derived_types(type_idx,
00740                          ATD_TYPE_IDX(EQ_ATTR_IDX(nondefault_sequence_type)))) {
00741                   PRINTMSG(EQ_LINE_NUM(nondefault_sequence_type), 1242, Error,
00742                            EQ_COLUMN_NUM(nondefault_sequence_type),
00743                            AT_OBJ_NAME_PTR(
00744                                   EQ_ATTR_IDX(nondefault_sequence_type)));
00745                }
00746 #endif
00747                else {
00748                   nondefault_sequence_type      = item;
00749                }
00750             }
00751          }
00752          else if (TYP_TYPE(type_idx) == Character) {
00753 
00754             if (default_numeric_sequence) {
00755                PRINTMSG(EQ_LINE_NUM(item), 1239, Error,
00756                         EQ_COLUMN_NUM(item),
00757                         AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)));
00758             }
00759             else if (default_numeric_type) {
00760                PRINTMSG(EQ_LINE_NUM(item), 522, Ansi,
00761                         EQ_COLUMN_NUM(item));
00762                default_character_type   = TRUE;
00763             }
00764             else if (nondefault_sequence_type != NULL_IDX) {
00765                PRINTMSG(EQ_LINE_NUM(nondefault_sequence_type), 1242, Error,
00766                         EQ_COLUMN_NUM(nondefault_sequence_type),
00767                         AT_OBJ_NAME_PTR(EQ_ATTR_IDX(nondefault_sequence_type)));
00768             }
00769             else if (nondefault_intrinsic_type != NULL_IDX) {
00770 # if 0
00771                PRINTMSG(EQ_LINE_NUM(nondefault_intrinsic_type), 1241, Error,
00772                         EQ_COLUMN_NUM(nondefault_intrinsic_type),
00773                        AT_OBJ_NAME_PTR(EQ_ATTR_IDX(nondefault_intrinsic_type)));
00774 # endif
00775                PRINTMSG(EQ_LINE_NUM(nondefault_intrinsic_type), 522, Ansi,
00776                         EQ_COLUMN_NUM(nondefault_intrinsic_type));
00777                default_character_type   = TRUE;
00778             }
00779             else {
00780                default_character_type   = TRUE;
00781             }
00782          }
00783          else if (TYP_DESC(type_idx) == Default_Typed ||
00784                   TYP_LINEAR(type_idx) == INTEGER_DEFAULT_TYPE ||
00785                   TYP_LINEAR(type_idx) == LOGICAL_DEFAULT_TYPE ||
00786                   TYP_LINEAR(type_idx) == REAL_DEFAULT_TYPE ||
00787                   TYP_LINEAR(type_idx) == DOUBLE_DEFAULT_TYPE ||
00788                   TYP_LINEAR(type_idx) == COMPLEX_DEFAULT_TYPE) {
00789 
00790             if (default_character_sequence) {
00791                PRINTMSG(EQ_LINE_NUM(item), 1240, Error,
00792                         EQ_COLUMN_NUM(item),
00793                         AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)));
00794             }
00795             else if (default_character_type) {
00796                PRINTMSG(EQ_LINE_NUM(item), 522, Ansi,
00797                         EQ_COLUMN_NUM(item));
00798                default_numeric_type             = TRUE;
00799             }
00800             else if (nondefault_sequence_type != NULL_IDX) {
00801                PRINTMSG(EQ_LINE_NUM(nondefault_sequence_type), 1242, Error,
00802                         EQ_COLUMN_NUM(nondefault_sequence_type),
00803                         AT_OBJ_NAME_PTR(EQ_ATTR_IDX(nondefault_sequence_type)));
00804             }
00805             else if (nondefault_intrinsic_type != NULL_IDX) {
00806 # if 0
00807                PRINTMSG(EQ_LINE_NUM(nondefault_intrinsic_type), 1241, Error,
00808                         EQ_COLUMN_NUM(nondefault_intrinsic_type),
00809                        AT_OBJ_NAME_PTR(EQ_ATTR_IDX(nondefault_intrinsic_type)));
00810 # endif
00811                PRINTMSG(EQ_LINE_NUM(nondefault_intrinsic_type), 1097, Ansi,
00812                         EQ_COLUMN_NUM(nondefault_intrinsic_type));
00813                default_numeric_type             = TRUE;
00814             }
00815             else {
00816                default_numeric_type             = TRUE;
00817             }
00818          }
00819          else {
00820 
00821             if (default_character_sequence) {
00822                PRINTMSG(EQ_LINE_NUM(item), 1240, Error,
00823                         EQ_COLUMN_NUM(item),
00824                         AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)));
00825             }
00826             else if (default_character_type) {
00827                PRINTMSG(EQ_LINE_NUM(item), 522, Ansi, EQ_COLUMN_NUM(item));
00828                nondefault_intrinsic_type                = item;
00829             }
00830             else if (default_numeric_type) {
00831 # if 0
00832                PRINTMSG(EQ_LINE_NUM(item), 1239, Error,
00833                         EQ_COLUMN_NUM(item),
00834                         AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)));
00835 # endif
00836                PRINTMSG(EQ_LINE_NUM(item), 1097, Ansi, EQ_COLUMN_NUM(item));
00837                nondefault_intrinsic_type                = item;
00838             }
00839             else if (default_numeric_sequence) {
00840                PRINTMSG(EQ_LINE_NUM(item), 1239, Error,
00841                         EQ_COLUMN_NUM(item),
00842                         AT_OBJ_NAME_PTR(EQ_ATTR_IDX(item)));
00843             }
00844 #if 0
00845 /* 28Feb01[sos] : deleted for PV 816483 */
00846             else if (nondefault_sequence_type != NULL_IDX) {
00847                PRINTMSG(EQ_LINE_NUM(nondefault_sequence_type), 1242, Error,
00848                         EQ_COLUMN_NUM(nondefault_sequence_type),
00849                         AT_OBJ_NAME_PTR(EQ_ATTR_IDX(nondefault_sequence_type)));
00850             }
00851 #endif
00852             else if (nondefault_intrinsic_type != NULL_IDX &&
00853                      TYP_LINEAR(ATD_TYPE_IDX(
00854                                 EQ_ATTR_IDX(nondefault_intrinsic_type))) !=
00855                      TYP_LINEAR(type_idx)) {
00856 # if 0
00857                PRINTMSG(EQ_LINE_NUM(nondefault_intrinsic_type), 1241, Error,
00858                         EQ_COLUMN_NUM(nondefault_intrinsic_type),
00859                        AT_OBJ_NAME_PTR(EQ_ATTR_IDX(nondefault_intrinsic_type)));
00860 # endif
00861                PRINTMSG(EQ_LINE_NUM(item), 1097, Ansi, EQ_COLUMN_NUM(item));
00862                nondefault_intrinsic_type                = item;
00863             }
00864             else {
00865                nondefault_intrinsic_type                = item;
00866             }
00867          }
00868          
00869          item = EQ_NEXT_EQUIV_OBJ(item);
00870       }
00871 
00872       group = EQ_NEXT_EQUIV_GRP(group);
00873    }
00874 
00875    TRACE (Func_Exit, "equivalence_semantics", NULL);
00876 
00877    return;
00878 
00879 }  /* equivalence_semantics */
00880 
00881 /******************************************************************************\
00882 |*                                                                            *|
00883 |* Description:                                                               *|
00884 |*      Linearize an EQUIVALENCE subscript/substring reference.               *|
00885 |*                                                                            *|
00886 |* Input parameters:                                                          *|
00887 |*      NONE                                                                  *|
00888 |*                                                                            *|
00889 |* Output parameters:                                                         *|
00890 |*      NONE                                                                  *|
00891 |*                                                                            *|
00892 |* Returns:                                                                   *|
00893 |*      NONE                                                                  *|
00894 |*                                                                            *|
00895 \******************************************************************************/
00896 static void     linearize_list_for_equiv(int    item)
00897 {
00898    int                  attr_idx;
00899    int                  bd_idx;
00900    size_offset_type     bit_offset;
00901    int                  dim;
00902    int                  l_idx;
00903    int                  list_idx;
00904    size_offset_type     left;
00905    size_offset_type     result;
00906    size_offset_type     right;
00907    int                  start_expr_idx;
00908    int                  trail_l_idx;
00909 
00910 
00911    TRACE (Func_Entry, "linearize_list_for_equiv", NULL);
00912 
00913    attr_idx             = EQ_ATTR_IDX(item);
00914    list_idx             = EQ_LIST_IDX(item);
00915    bit_offset.fld       = CN_Tbl_Idx;
00916    bit_offset.idx       = CN_INTEGER_ZERO_IDX;
00917 
00918    if (list_idx != NULL_IDX) {
00919 
00920       if (!EQ_SUBSTRINGED(item)) {
00921 
00922          if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
00923             bd_idx      = ATD_ARRAY_IDX(attr_idx);
00924             dim         = 1;
00925             l_idx       = list_idx;
00926 
00927             while (l_idx != NULL_IDX && IL_FLD(l_idx) != NO_Tbl_Idx) {
00928                right.fld        = BD_LB_FLD(bd_idx,dim);
00929                right.idx        = BD_LB_IDX(bd_idx,dim);
00930                left.fld         = IL_FLD(l_idx);
00931                left.idx         = IL_IDX(l_idx);
00932 
00933                if (!size_offset_binary_calc(&left, &right, Minus_Opr, &result)){
00934                   break;
00935                }
00936 
00937                left.fld         = BD_SM_FLD(bd_idx,dim);
00938                left.idx         = BD_SM_IDX(bd_idx,dim);
00939 
00940                if (!size_offset_binary_calc(&left, &result, Mult_Opr, &result)){
00941                   break;
00942                }
00943 
00944                if (!size_offset_binary_calc(&bit_offset,
00945                                             &result,
00946                                              Plus_Opr,
00947                                             &bit_offset)) {
00948                   break;
00949                }
00950 
00951                l_idx = IL_NEXT_LIST_IDX(l_idx);
00952                dim++;
00953             }
00954          }
00955       }
00956       else { /* it is substringed */
00957 
00958          if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {
00959             l_idx = list_idx;
00960 
00961             while (l_idx != NULL_IDX && IL_FLD(l_idx) != NO_Tbl_Idx) {
00962                trail_l_idx      = l_idx;
00963                l_idx            = IL_NEXT_LIST_IDX(l_idx);
00964             }
00965 
00966             start_expr_idx      = IL_PREV_LIST_IDX(trail_l_idx); 
00967 
00968             left.fld            = IL_FLD(start_expr_idx);
00969             left.idx            = IL_IDX(start_expr_idx);
00970             right.fld           = CN_Tbl_Idx;
00971             right.idx           = CN_INTEGER_ONE_IDX;
00972 
00973             size_offset_binary_calc(&left, &right, Minus_Opr, &bit_offset);
00974 
00975             IL_FLD(start_expr_idx) = NO_Tbl_Idx;
00976 
00977             if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
00978 
00979                if (IL_FLD(list_idx) == NO_Tbl_Idx) {
00980                   AT_DCL_ERR(attr_idx)  = TRUE;
00981                   PRINTMSG(IL_LINE_NUM(list_idx), 250, Error,
00982                            IL_COL_NUM(list_idx));
00983                }
00984 
00985                bd_idx   = ATD_ARRAY_IDX(attr_idx);
00986                dim      = 1;
00987                l_idx    = list_idx;
00988 
00989                while (l_idx != NULL_IDX && IL_FLD(l_idx) != NO_Tbl_Idx) {
00990 
00991                   left.fld      = IL_FLD(l_idx);
00992                   left.idx      = IL_IDX(l_idx);
00993                   right.fld     = BD_LB_FLD(bd_idx, dim);
00994                   right.idx     = BD_LB_IDX(bd_idx, dim);
00995 
00996                   if (!size_offset_binary_calc(&left, 
00997                                                &right,
00998                                                 Minus_Opr,
00999                                                &result)) {
01000                      break;
01001                   }
01002    
01003                   left.fld      = BD_SM_FLD(bd_idx, dim);
01004                   left.idx      = BD_SM_IDX(bd_idx, dim);
01005 
01006                   if (!size_offset_binary_calc(&left, 
01007                                                &result,
01008                                                 Mult_Opr,
01009                                                &result)) {
01010                      break;
01011                   }
01012    
01013                   if (!size_offset_binary_calc(&bit_offset,
01014                                                &result,
01015                                                 Plus_Opr,
01016                                                &bit_offset)) {
01017                      break;
01018                   }
01019    
01020                   l_idx = IL_NEXT_LIST_IDX(l_idx);
01021                   dim = dim + 1;
01022                }
01023             }
01024          }
01025       }  /* it is substringed */
01026    }
01027 
01028    if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {
01029       result.fld        = CN_Tbl_Idx;
01030       result.idx        = CN_INTEGER_CHAR_BIT_IDX;
01031    }
01032    else {
01033       result.fld        = CN_Tbl_Idx;
01034       result.idx        = CN_INTEGER_BITS_PER_WORD_IDX;
01035 
01036 # if defined(_TARGET_OS_MAX) || defined(_WHIRL_HOST64_TARGET64)
01037 
01038       /* Complex_4 does not go here because it is aligned for 64 bits.     */
01039       /* The stride multiplier for one of these types is based on 32 bits  */
01040       /* not the standard 64 bits.  (MPP only)                             */
01041 
01042       if (PACK_HALF_WORD_TEST_CONDITION(ATD_TYPE_IDX(attr_idx))) {
01043          C_TO_F_INT(result.constant,
01044                     TARGET_BITS_PER_WORD / 2, 
01045                     CG_INTEGER_DEFAULT_TYPE);
01046          result.fld             = NO_Tbl_Idx;
01047          result.type_idx        = CG_INTEGER_DEFAULT_TYPE;
01048       }
01049 # endif
01050 
01051 # if defined(_INTEGER_1_AND_2)
01052 
01053       if (on_off_flags.integer_1_and_2) {
01054 
01055          if (PACK_8_BIT_TEST_CONDITION(ATD_TYPE_IDX(attr_idx))) {
01056             C_TO_F_INT(result.constant, 8, CG_INTEGER_DEFAULT_TYPE);
01057             result.fld          = NO_Tbl_Idx;
01058             result.type_idx     = CG_INTEGER_DEFAULT_TYPE;
01059          }
01060          else if (PACK_16_BIT_TEST_CONDITION(ATD_TYPE_IDX(attr_idx))) {
01061             C_TO_F_INT(result.constant, 16, CG_INTEGER_DEFAULT_TYPE);
01062             result.fld          = NO_Tbl_Idx;
01063             result.type_idx     = CG_INTEGER_DEFAULT_TYPE;
01064          }
01065       }
01066 
01067 # endif
01068    }
01069 
01070    size_offset_binary_calc(&bit_offset, &result, Mult_Opr, &bit_offset);
01071 
01072    if (bit_offset.fld == NO_Tbl_Idx) {
01073       IL_FLD(list_idx) = CN_Tbl_Idx;
01074       IL_IDX(list_idx) = ntr_const_tbl(bit_offset.type_idx,
01075                                        FALSE,
01076                                        bit_offset.constant);
01077    }
01078    else {
01079       IL_FLD(list_idx) = bit_offset.fld;
01080       IL_IDX(list_idx) = bit_offset.idx;
01081    }
01082 
01083    IL_LINE_NUM(list_idx) = 1;
01084    IL_COL_NUM(list_idx)  = 0;
01085 
01086    TRACE (Func_Exit, "linearize_list_for_equiv", NULL);
01087 
01088    return;
01089 
01090 }  /* linearize_list_for_equiv */
01091 
01092 
01093 /******************************************************************************\
01094 |*                                                                            *|
01095 |* Description:                                                               *|
01096 |*      This merge routine will search through two equivalence groups at a    *|
01097 |*      time.  If an identical object is found in both groups those two       *|
01098 |*      groups are merged into one equivalence group.   Identical means       *|
01099 |*      that we are looking at the same attr and the bit offset value is      *|
01100 |*      identical on these two objects.  Because we are merging only when     *|
01101 |*      the offsets on the two objects are identical there is no need to      *|
01102 |*      adjust offsets for the objects in the merged groups.                  *|
01103 |*                                                                            *|
01104 |* Input parameters:                                                          *|
01105 |*      NONE                                                                  *|
01106 |*                                                                            *|
01107 |* Output parameters:                                                         *|
01108 |*      NONE                                                                  *|
01109 |*                                                                            *|
01110 |* Returns:                                                                   *|
01111 |*      NONE                                                                  *|
01112 |*                                                                            *|
01113 \******************************************************************************/
01114 static void     merge_equivalence_groups1(void)
01115 {
01116 
01117    int           group;
01118    int           group_end;
01119    int           item;
01120    int           list_idx;
01121    int           list_item;
01122    int           prev_group;
01123 
01124 
01125    TRACE (Func_Entry, "merge_equivalence_groups1", NULL);
01126 
01127    group = SCP_FIRST_EQUIV_GRP(curr_scp_idx);
01128 
01129    while (group != NULL_IDX) {
01130 
01131       if (EQ_MERGED(group)) {
01132 
01133          /* This group has been merged with a previous   */
01134          /* group, so remove it from the group list.     */
01135          
01136          EQ_NEXT_EQUIV_GRP(prev_group) = EQ_NEXT_EQUIV_GRP(group);
01137       }
01138       else {
01139          group_end      = EQ_GRP_END_IDX(group);
01140          item           = group;
01141    
01142          while (item != NULL_IDX) {
01143 
01144             if (EQ_ERROR(item)) {
01145                item             = EQ_NEXT_EQUIV_OBJ(item);
01146                continue;
01147             }
01148 
01149             if (EQ_SEARCH_DONE(item)) {
01150 
01151                /* This item has been merged into this group because it */
01152                /* Matches another item in this group.  Do not search   */
01153                /* again.  It is a waste of time because we've already  */
01154                /* searched all occurences of this item.  We will not   */
01155                /* come across this eq item in this routine again,      */
01156                /* because we are doing only one pass through all       */
01157                /* groups and items, so turn off the flag so it can be  */
01158                /* used in the group2 merge later on.                   */
01159 
01160                EQ_SEARCH_DONE(item) = FALSE;
01161             }
01162             else if (ATD_CLASS(EQ_ATTR_IDX(item)) == Variable &&
01163                      ATD_EQUIV_LIST(EQ_ATTR_IDX(item)) != NULL_IDX) {
01164 
01165                /* This attr is in more than one equivalence group. */
01166 
01167                list_idx = ATD_EQUIV_LIST(EQ_ATTR_IDX(item));
01168 
01169                while (list_idx != NULL_IDX) {
01170                   list_item = AL_EQ_IDX(list_idx);
01171 
01172                   if (list_item != item && EQ_GRP_IDX(list_item) != group &&
01173                       (IL_IDX(EQ_LIST_IDX(list_item)) ==
01174                                 IL_IDX(EQ_LIST_IDX(item)))) {
01175 
01176                      /* Same attr with same offset.  Merge them.  Do not */
01177                      /* merge if this item is already in this group.     */
01178 
01179                      /* 1) Mark list item to prevent researching.        */
01180                      /* 2) Merge the new group to the end of the old.    */
01181                      /* 3) Mark the merged group as merged, so it can    */
01182                      /*    be removed from the group list.               */
01183                      /* 4) Set EQ_GRP_IDX for all members of new group.  */
01184 
01185                      EQ_SEARCH_DONE(list_item)          = TRUE;
01186                      EQ_NEXT_EQUIV_OBJ(group_end)       = EQ_GRP_IDX(list_item);
01187                      EQ_MERGED(EQ_GRP_IDX(list_item))   = TRUE;
01188 
01189                      group_end  = EQ_GRP_END_IDX(EQ_GRP_IDX(list_item));
01190                      list_item  = EQ_GRP_IDX(list_item);  /* Group start */
01191 
01192                      while (list_item != NULL_IDX) {
01193                         EQ_GRP_IDX(list_item)   = group;
01194                         list_item               = EQ_NEXT_EQUIV_OBJ(list_item);
01195                      }
01196                   }
01197                   list_idx      = AL_NEXT_IDX(list_idx);
01198                }
01199             }
01200             item                = EQ_NEXT_EQUIV_OBJ(item);
01201          }
01202          EQ_GRP_END_IDX(group)  = group_end;
01203          prev_group             = group;
01204       }
01205       group                     = EQ_NEXT_EQUIV_GRP(group);
01206    }
01207 
01208    TRACE (Func_Exit, "merge_equivalence_groups1", NULL);
01209 
01210    return;
01211 
01212 }  /* merge_equivalence_groups1 */
01213 
01214 
01215 /******************************************************************************\
01216 |*                                                                            *|
01217 |* Description:                                                               *|
01218 |*      This merge routine is slightly different than                         *|
01219 |*      merge_equivalence_groups1 in that two groups are merged if they       *|
01220 |*      contain an identical object regardless of the offset attached to      *|
01221 |*      that object.  At this point we know that the offsets attached to      *|
01222 |*      the objects are different so we will have to adjust all the offsets   *|
01223 |*      in one of the two groups by the difference in the offsets of the      *|
01224 |*      two identical objects.                                                *|
01225 |*                                                                            *|
01226 |* Input parameters:                                                          *|
01227 |*      NONE                                                                  *|
01228 |*                                                                            *|
01229 |* Output parameters:                                                         *|
01230 |*      NONE                                                                  *|
01231 |*                                                                            *|
01232 |* Returns:                                                                   *|
01233 |*      NONE                                                                  *|
01234 |*                                                                            *|
01235 \******************************************************************************/
01236 static void     merge_equivalence_groups2(void)
01237 {
01238    boolean              adjust;
01239    size_offset_type     adjust_by;
01240    int                  group;
01241    int                  group_end;
01242    int                  item;
01243    size_offset_type     left;
01244    int                  list_idx;
01245    int                  list_item;
01246    int                  prev_group;
01247    size_offset_type     result;
01248    size_offset_type     right;
01249 
01250 
01251    TRACE (Func_Entry, "merge_equivalence_groups2", NULL);
01252 
01253    group = SCP_FIRST_EQUIV_GRP(curr_scp_idx);
01254 
01255    while (group != NULL_IDX) {
01256 
01257       if (EQ_MERGED(group)) {
01258 
01259          /* This group has been merged with a previous   */
01260          /* group, so remove it from the group list.     */
01261          
01262          EQ_NEXT_EQUIV_GRP(prev_group) = EQ_NEXT_EQUIV_GRP(group);
01263       }
01264       else {
01265          group_end      = EQ_GRP_END_IDX(group);
01266          item           = group;
01267    
01268          while (item != NULL_IDX) {
01269 
01270             if (EQ_ERROR(item)) {
01271                item             = EQ_NEXT_EQUIV_OBJ(item);
01272                continue;
01273             }
01274 
01275             if (ATD_CLASS(EQ_ATTR_IDX(item)) == Variable &&
01276                 ATD_EQUIV_LIST(EQ_ATTR_IDX(item)) != NULL_IDX) {
01277 
01278                /* This attr is in more than one equivalence group. */
01279 
01280                list_idx = ATD_EQUIV_LIST(EQ_ATTR_IDX(item));
01281 
01282                while (list_idx != NULL_IDX) {
01283                   list_item = AL_EQ_IDX(list_idx);
01284 
01285                   if (list_item != item && EQ_GRP_IDX(list_item) != group) {
01286 
01287                      /* Do not merge if item is already in this group.   */
01288 
01289                      /* 1) Merge the new group to the end of the old.    */
01290                      /* 2) Mark the merged group as merged, so it can    */
01291                      /*    be removed from the group list.               */
01292                      /* 3) Adjust the offsets for all groups if the      */
01293                      /*    offsets are different.                        */
01294 
01295                      if (EQ_OFFSET_IDX(list_item) != EQ_OFFSET_IDX(item) ||
01296                          EQ_OFFSET_FLD(list_item) != EQ_OFFSET_FLD(item)) {
01297                         left.fld        = EQ_OFFSET_FLD(list_item);
01298                         left.idx        = EQ_OFFSET_IDX(list_item);
01299                         right.fld       = EQ_OFFSET_FLD(item);
01300                         right.idx       = EQ_OFFSET_IDX(item);
01301 
01302                         if (!size_offset_binary_calc(&left,
01303                                                      &right,
01304                                                       Minus_Opr,
01305                                                      &adjust_by)) {
01306                            adjust = FALSE;
01307                            break;
01308                         }
01309                         adjust = TRUE;
01310                      }
01311                      else {
01312                         adjust = FALSE;
01313                      }
01314 
01315                      EQ_NEXT_EQUIV_OBJ(group_end)       = EQ_GRP_IDX(list_item);
01316                      EQ_MERGED(EQ_GRP_IDX(list_item))   = TRUE;
01317 
01318                      group_end  = EQ_GRP_END_IDX(EQ_GRP_IDX(list_item));
01319                      list_item  = EQ_GRP_IDX(list_item);  /* Group start */
01320 
01321                      if (adjust) {
01322 
01323                         while (list_item != NULL_IDX) {
01324                            EQ_GRP_IDX(list_item)= group;
01325                            left.fld             = EQ_OFFSET_FLD(list_item);
01326                            left.idx             = EQ_OFFSET_IDX(list_item);
01327 
01328                            if (!size_offset_binary_calc(&left,
01329                                                         &adjust_by,
01330                                                          Minus_Opr,
01331                                                         &result)) {
01332                               break;
01333                            }
01334 
01335                            if (result.fld == NO_Tbl_Idx) {
01336                               EQ_OFFSET_FLD(list_item) = CN_Tbl_Idx;
01337                               EQ_OFFSET_IDX(list_item) = ntr_const_tbl(
01338                                                                result.type_idx,
01339                                                                FALSE,
01340                                                                result.constant);
01341                            }
01342                            else {
01343                               EQ_OFFSET_FLD(list_item) = result.fld;
01344                               EQ_OFFSET_IDX(list_item) = result.idx;
01345                            }
01346 
01347                            list_item            = EQ_NEXT_EQUIV_OBJ(list_item);
01348                         }
01349                      }
01350                      else {
01351                         while (list_item != NULL_IDX) {
01352                            EQ_GRP_IDX(list_item)        = group;
01353                            list_item            = EQ_NEXT_EQUIV_OBJ(list_item);
01354                         }
01355                      }
01356                   }
01357                   list_idx      = AL_NEXT_IDX(list_idx);
01358                }
01359             }
01360             item                = EQ_NEXT_EQUIV_OBJ(item);
01361          }
01362          EQ_GRP_END_IDX(group)  = group_end;
01363          prev_group             = group;
01364       }
01365       group                     = EQ_NEXT_EQUIV_GRP(group);
01366    }
01367 
01368    TRACE (Func_Exit, "merge_equivalence_groups2", NULL);
01369 
01370    return;
01371 
01372 }  /* merge_equivalence_groups2 */
01373 
01374 /******************************************************************************\
01375 |*                                                                            *|
01376 |* Description:                                                               *|
01377 |*      Assign offsets to the items in equivalence groups.                    *|
01378 |*                                                                            *|
01379 |* Input parameters:                                                          *|
01380 |*      NONE                                                                  *|
01381 |*                                                                            *|
01382 |* Output parameters:                                                         *|
01383 |*      NONE                                                                  *|
01384 |*                                                                            *|
01385 |* Returns:                                                                   *|
01386 |*      NONE                                                                  *|
01387 |*                                                                            *|
01388 \******************************************************************************/
01389 static void     assign_offsets_for_equiv_groups(void)
01390 {
01391    int                  group;
01392    int                  item;
01393    size_offset_type     largest_offset;
01394    size_offset_type     result;
01395 
01396 
01397    TRACE (Func_Entry, "assign_offsets_for_equiv_groups", NULL);
01398 
01399    group = SCP_FIRST_EQUIV_GRP(curr_scp_idx);
01400 
01401    while (group != NULL_IDX) {
01402 
01403       item               = group;
01404       largest_offset.idx = CN_INTEGER_ZERO_IDX;
01405       largest_offset.fld = CN_Tbl_Idx;
01406 
01407       while (item != NULL_IDX) {
01408 
01409          if (!EQ_ERROR(item) &&
01410              IL_IDX(EQ_LIST_IDX(item)) != CN_INTEGER_ZERO_IDX &&
01411              fold_relationals(IL_IDX(EQ_LIST_IDX(item)),
01412                               largest_offset.idx,
01413                               Ge_Opr)) {
01414             largest_offset.fld  = IL_FLD(EQ_LIST_IDX(item));
01415             largest_offset.idx  = IL_IDX(EQ_LIST_IDX(item));
01416          }
01417 
01418          item = EQ_NEXT_EQUIV_OBJ(item);
01419       }
01420 
01421       if (largest_offset.idx != CN_INTEGER_ZERO_IDX) {
01422 
01423          /* If the largest is zero - then they are all zero, */
01424          /* so we don't need to do the subtraction.          */
01425 
01426          item = group;
01427 
01428          while (item != NULL_IDX) {
01429 
01430             if (EQ_ERROR(item)) {
01431                item = EQ_NEXT_EQUIV_OBJ(item);
01432                continue;
01433             }
01434 
01435             /* largest_offset_idx - IL_IDX(EQ_LIST_IDX(item)) */
01436 
01437             if (fold_relationals(IL_IDX(EQ_LIST_IDX(item)),
01438                                  CN_INTEGER_ZERO_IDX,
01439                                  Eq_Opr)) {
01440                EQ_OFFSET_FLD(item)      = largest_offset.fld;
01441                EQ_OFFSET_IDX(item)      = largest_offset.idx;
01442             }
01443             else {
01444                result.fld               = IL_FLD(EQ_LIST_IDX(item));
01445                result.idx               = IL_IDX(EQ_LIST_IDX(item));
01446 
01447                if (size_offset_binary_calc(&largest_offset,
01448                                            &result,
01449                                             Minus_Opr,
01450                                            &result)) {
01451 
01452                   if (result.fld == NO_Tbl_Idx) {
01453                      EQ_OFFSET_FLD(item) = CN_Tbl_Idx;
01454                      EQ_OFFSET_IDX(item) = ntr_const_tbl(result.type_idx,
01455                                                          FALSE,
01456                                                          result.constant);
01457                   }
01458                   else {
01459                      EQ_OFFSET_FLD(item) = result.fld;
01460                      EQ_OFFSET_IDX(item) = result.idx;
01461                   }
01462                }
01463                else {
01464                    break;
01465                }
01466             }
01467             item = EQ_NEXT_EQUIV_OBJ(item);
01468          }
01469       }
01470 
01471       group = EQ_NEXT_EQUIV_GRP(group);
01472    }
01473 
01474 
01475    TRACE (Func_Exit, "assign_offsets_for_equiv_groups", NULL);
01476 
01477    return;
01478 
01479 }  /* assign_offsets_for_equiv_groups */
01480 
01481 /******************************************************************************\
01482 |*                                                                            *|
01483 |* Description:                                                               *|
01484 |*      This routine resolves the lower and upper bounds to a constant or a   *|
01485 |*      temp.  Calculate the extent and stride multiplier for each dimension. *|
01486 |*                                                                            *|
01487 |* Input parameters:                                                          *|
01488 |*      attr_idx -> Index to attribute for array.                             *|
01489 |*                                                                            *|
01490 |* Output parameters:                                                         *|
01491 |*      NONE                                                                  *|
01492 |*                                                                            *|
01493 |* Returns:                                                                   *|
01494 |*      NONE                                                                  *|
01495 |*                                                                            *|
01496 \******************************************************************************/
01497 void    array_dim_resolution(int        attr_idx,
01498                              boolean    need_const_array)
01499 {
01500    bd_array_size_type   array_size_type;
01501    int                  at_idx;
01502    int                  bd_idx;
01503    int                  column;
01504    int                  cvrt_idx;
01505    int                  dim;
01506    int                  entry_count;
01507    int                  entry_list;
01508    expr_arg_type        expr_desc;
01509    int                  extent_entry_idx        = NULL_IDX;
01510    fld_type             extent_fld;
01511    int                  extent_idx;
01512    int                  ir_idx;
01513    boolean              is_interface;
01514    int                  len_ir_idx;
01515    int                  length_idx;
01516    int                  length_entry_idx        = NULL_IDX;
01517    int                  line;
01518    int                  mult_idx;
01519    int                  new_bd_idx;
01520    int                  next_ir_idx;
01521    opnd_type            opnd;
01522    int                  sh_idx;
01523    int                  stride_entry_idx        = NULL_IDX;
01524    int                  stride_entry_count;
01525    size_offset_type     stride;
01526    int                  type;
01527  enum bd_array_values   ffmm;
01528 
01529    TRACE (Func_Entry, "array_dim_resolution", NULL);
01530 
01531    is_interface = SCP_IS_INTERFACE(curr_scp_idx);
01532    bd_idx       = ATD_ARRAY_IDX(attr_idx);
01533 
01534    ffmm = BD_ARRAY_CLASS(bd_idx);
01535 
01536    if (ATD_CLASS(attr_idx) == Function_Result) {
01537       entry_list        = ATP_NO_ENTRY_LIST(ATD_FUNC_IDX(attr_idx));
01538    }
01539    else {
01540       entry_list        = ATD_NO_ENTRY_LIST(attr_idx);
01541    }
01542 
01543    if (BD_ARRAY_CLASS(bd_idx) == Deferred_Shape) {
01544 
01545       /* This is called by PARAMETER processing.  This must be an explicit */
01546       /* shape constant size array.  PARAMETER processing will issue the   */
01547       /* error.  If this is needed elsewhere, it will come through again   */
01548       /* during decl_semantics.                                            */
01549 
01550       if (need_const_array) {
01551          goto EXIT;
01552       }
01553 
01554       if (ATD_CLASS(attr_idx) == Compiler_Tmp && ATD_IM_A_DOPE(attr_idx)) {
01555          goto EXIT;              /* everything is ok */
01556       }
01557 
01558 
01559       if (ATD_CLASS(attr_idx) == Dummy_Argument && !ATD_POINTER(attr_idx)) {
01560 
01561          /* Don't convert intrinsic dargs to assumed shape */
01562 
01563          if (ATD_INTRIN_DARG(attr_idx)) {
01564             goto EXIT;
01565          }
01566 
01567          new_bd_idx                     = reserve_array_ntry(BD_RANK(bd_idx));
01568          BD_RANK(new_bd_idx)            = BD_RANK(bd_idx);
01569          BD_DCL_ERR(new_bd_idx)         = BD_DCL_ERR(bd_idx);
01570          BD_ARRAY_CLASS(new_bd_idx)     = Assumed_Shape;
01571          BD_ARRAY_SIZE(new_bd_idx)      = Constant_Size;
01572          BD_LINE_NUM(new_bd_idx)        = BD_LINE_NUM(bd_idx);
01573          BD_COLUMN_NUM(new_bd_idx)      = BD_COLUMN_NUM(bd_idx);
01574 
01575          for (dim = 1; dim <= BD_RANK(new_bd_idx); dim++) {
01576             BD_LB_FLD(new_bd_idx, dim)  = CN_Tbl_Idx;
01577             BD_LB_IDX(new_bd_idx, dim)  = CN_INTEGER_ONE_IDX;
01578          }
01579 
01580          bd_idx                         = ntr_array_in_bd_tbl(new_bd_idx);
01581          BD_ARRAY_SIZE(bd_idx)          = Constant_Size;
01582          BD_RESOLVED(bd_idx)            = TRUE;
01583          ATD_ARRAY_IDX(attr_idx)        = bd_idx;
01584 
01585          if (ATD_IGNORE_TKR(attr_idx)) {
01586             AT_DCL_ERR(attr_idx)        = TRUE;
01587             PRINTMSG(AT_DEF_LINE(attr_idx), 1459, Error, 
01588                      AT_DEF_COLUMN(attr_idx),
01589                      AT_OBJ_NAME_PTR(attr_idx),
01590                      "IGNORE_TKR",
01591                      "assumed-shape DIMENSION");
01592          }
01593 
01594 # if defined(_TARGET_OS_MAX)
01595          if (ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX) {
01596             AT_DCL_ERR(attr_idx)        = TRUE;
01597             PRINTMSG(BD_LINE_NUM(ATD_PE_ARRAY_IDX(attr_idx)), 1583, Error,
01598                      BD_COLUMN_NUM(ATD_PE_ARRAY_IDX(attr_idx)),
01599                      "co-array dimensions",
01600                      "assumed-shape arrays");
01601          }
01602 # endif
01603       }
01604       else if (!ATD_POINTER(attr_idx) && !ATD_ALLOCATABLE(attr_idx)) {
01605          AT_DCL_ERR(attr_idx)           = TRUE;
01606 
01607          if (ATD_CLASS(attr_idx) == Function_Result) {
01608             PRINTMSG(AT_DEF_LINE(attr_idx), 571, Error,
01609                      AT_DEF_COLUMN(attr_idx),
01610                      AT_OBJ_NAME_PTR(attr_idx));
01611          }
01612          else {
01613             PRINTMSG(AT_DEF_LINE(attr_idx), 353, Error,
01614                      AT_DEF_COLUMN(attr_idx),
01615                      AT_OBJ_NAME_PTR(attr_idx));
01616          }
01617       }
01618       else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character &&
01619                TYP_CHAR_CLASS(ATD_TYPE_IDX(attr_idx)) == Var_Len_Char) {
01620          entry_list = merge_entry_lists(entry_list,
01621                            ATD_NO_ENTRY_LIST(TYP_IDX(ATD_TYPE_IDX(attr_idx))));
01622 
01623          if (entry_list != NULL_IDX &&
01624              (SCP_ALT_ENTRY_CNT(curr_scp_idx)+1) == AL_ENTRY_COUNT(entry_list)){
01625             PRINTMSG(AT_DEF_LINE(attr_idx), 662, Error,
01626                      AT_DEF_COLUMN(attr_idx), 
01627                      AT_OBJ_NAME_PTR(attr_idx));
01628             AT_DCL_ERR(attr_idx)        = TRUE;
01629          }
01630       }
01631 /* here add keep Deferred_Shape array in "array" form instead of 
01632    generating dope vector */
01633   else {  
01634 
01635    if (BD_ARRAY_CLASS(bd_idx) == Deferred_Shape) {
01636 
01637       BD_RESOLVED(bd_idx)  = TRUE;
01638       BD_ARRAY_SIZE(bd_idx)      = Unknown_Size;
01639       BD_ARRAY_CLASS(bd_idx)=Deferred_Shape1;
01640 /*      BD_ARRAY_CLASS(bd_idx)=Deferred_Shape; */
01641       
01642 
01643       for (dim = 1; dim <= BD_RANK(bd_idx); dim++) {
01644 #if 0  /*FMZ Sept 2005 */
01645            BD_LB_FLD(bd_idx,dim)       = CN_Tbl_Idx;
01646            BD_LB_IDX(bd_idx, dim)  = CN_INTEGER_ONE_IDX;
01647 #else
01648            BD_LB_FLD(bd_idx,dim)       = NO_Tbl_Idx;
01649 #endif 
01650            BD_UB_FLD(bd_idx, dim)      = NO_Tbl_Idx;
01651            BD_XT_FLD(bd_idx, dim)      = NO_Tbl_Idx;
01652            
01653       }
01654     BD_LEN_FLD(bd_idx) = NO_Tbl_Idx;
01655  
01656      }
01657      
01658    } 
01659 
01660       goto EXIT;
01661    }
01662 
01663    if (BD_ARRAY_CLASS(bd_idx) == Assumed_Shape) {
01664 
01665       /* This is called by PARAMETER processing.  This must be an explicit */
01666       /* shape constant size array.  PARAMETER processing will issue the   */
01667       /* error.  If this is needed elsewhere, it will come through again   */
01668       /* during decl_semantics.                                            */
01669 
01670       if (need_const_array) {
01671          goto EXIT;
01672       }
01673 
01674       /* These must always be dummy arguments, so they can never be automatic */
01675 
01676 /*      ATD_IM_A_DOPE(attr_idx) = TRUE; */
01677 
01678       if (!BD_RESOLVED(bd_idx)) {
01679          BD_RESOLVED(bd_idx)    = TRUE;
01680          array_size_type        = Constant_Size;
01681          length_entry_idx       = NULL_IDX;
01682 
01683          for (dim = 1; dim <= BD_RANK(bd_idx); dim++) {
01684 
01685             if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) {
01686                at_idx = BD_LB_IDX(bd_idx, dim);
01687 
01688                if (ATD_CLASS(at_idx) == Constant) {
01689                   BD_LB_FLD(bd_idx, dim)        = CN_Tbl_Idx;
01690                   BD_LB_IDX(bd_idx, dim)        = ATD_CONST_IDX(at_idx);
01691                }
01692                else if (ATD_SYMBOLIC_CONSTANT(at_idx)) {
01693                   array_size_type               = Symbolic_Constant_Size;
01694                }
01695                else {
01696                   length_entry_idx = merge_entry_lists(
01697                                       length_entry_idx,
01698                                       ATD_NO_ENTRY_LIST(BD_LB_IDX(bd_idx,dim)));
01699                   array_size_type  = Var_Len_Array;
01700                }
01701             }
01702          }
01703 
01704          BD_ARRAY_SIZE(bd_idx) = array_size_type;
01705 
01706          if (length_entry_idx != NULL_IDX) {
01707             entry_count = SCP_ALT_ENTRY_CNT(curr_scp_idx) + 1; 
01708 
01709             if (entry_count == AL_ENTRY_COUNT(length_entry_idx))  {
01710 
01711                /* Error if problem with lower and/or upper bounds coming in   */
01712                /* different entry points.  Bounds for this array declaration  */
01713                /* cannot be calculated at any entry point, because dummy args */
01714                /* used in the expression do not enter at all the same points. */
01715 
01716                PRINTMSG(AT_DEF_LINE(attr_idx), 660, Error,
01717                         AT_DEF_COLUMN(attr_idx), 
01718                         AT_OBJ_NAME_PTR(attr_idx));
01719                AT_DCL_ERR(attr_idx)     = TRUE;
01720             }
01721             else {
01722 
01723                if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character &&
01724                    TYP_FLD(ATD_TYPE_IDX(attr_idx)) == AT_Tbl_Idx) {
01725 
01726                   length_entry_idx = merge_entry_lists(length_entry_idx,
01727                             ATD_NO_ENTRY_LIST(TYP_IDX(ATD_TYPE_IDX(attr_idx))));
01728 
01729                   if (entry_count == AL_ENTRY_COUNT(length_entry_idx))  {
01730 
01731                      /* Bounds for this array declaration cannot be calculated*/
01732                      /* at any entry point, because dummy arguments used in   */
01733                      /* the expression do not enter at all the same points.   */
01734 
01735                      PRINTMSG(AT_DEF_LINE(attr_idx), 661, Error,
01736                               AT_DEF_COLUMN(attr_idx), 
01737                               AT_OBJ_NAME_PTR(attr_idx));
01738                      AT_DCL_ERR(attr_idx)       = TRUE;
01739                   }
01740                }
01741 
01742                if (!AT_DCL_ERR(attr_idx) && entry_list != NULL_IDX) {
01743                   length_entry_idx = merge_entry_lists(length_entry_idx,
01744                                                        entry_list);
01745 
01746                   if (length_entry_idx != NULL_IDX &&
01747                       entry_count == AL_ENTRY_COUNT(length_entry_idx))  {
01748 
01749                      /* This array and its bounds variables do not enter at   */
01750                      /* the same entry point.                                 */
01751 
01752                      PRINTMSG(AT_DEF_LINE(attr_idx), 662, Error,
01753                               AT_DEF_COLUMN(attr_idx), 
01754                               AT_OBJ_NAME_PTR(attr_idx));
01755                      AT_DCL_ERR(attr_idx)       = TRUE;
01756                   }
01757                }
01758             }
01759          }
01760       }
01761              
01762       if (ATD_CLASS(attr_idx) != Dummy_Argument || ATD_POINTER(attr_idx)) {
01763          AT_DCL_ERR(attr_idx) = TRUE;
01764          PRINTMSG(AT_DEF_LINE(attr_idx), 351, Error,
01765                   AT_DEF_COLUMN(attr_idx),
01766                   AT_OBJ_NAME_PTR(attr_idx));
01767       }
01768 
01769       goto EXIT;
01770    }
01771 
01772    /* If this array bounds entry has already been resolved, skip the section  */
01773    /* that calculates the extent, length, and stride multiplier.              */
01774    /* The only array entries that are shared are of the same type.  Each attr */
01775    /* will have to calculate it's own automatic stuff.                        */
01776 
01777    if (BD_RESOLVED(bd_idx)) {
01778       goto NEXT;
01779    }
01780 
01781    array_size_type      = Constant_Size;
01782 
01783    for (dim = 1; dim <= BD_RANK(bd_idx); dim++) {
01784 
01785       if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) {
01786 
01787          if (ATD_CLASS(BD_LB_IDX(bd_idx, dim)) == Constant) { 
01788             BD_LB_FLD(bd_idx, dim)      = CN_Tbl_Idx;
01789             BD_LB_IDX(bd_idx, dim)      = ATD_CONST_IDX(BD_LB_IDX(bd_idx, dim));
01790          }
01791          else if (ATD_SYMBOLIC_CONSTANT(BD_LB_IDX(bd_idx, dim))) {
01792             array_size_type     = Symbolic_Constant_Size;
01793          }
01794          else {
01795             array_size_type     = Var_Len_Array;
01796             OPND_FLD(opnd)      = BD_LB_FLD(bd_idx, dim);
01797             OPND_IDX(opnd)      = BD_LB_IDX(bd_idx, dim);
01798             OPND_LINE_NUM(opnd) = BD_LINE_NUM(bd_idx);
01799             OPND_COL_NUM(opnd)  = BD_COLUMN_NUM(bd_idx);
01800          }
01801       }
01802    
01803       if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx) {
01804 
01805          if (ATD_CLASS(BD_UB_IDX(bd_idx, dim)) == Constant) {
01806             BD_UB_FLD(bd_idx, dim)      = CN_Tbl_Idx;
01807             BD_UB_IDX(bd_idx, dim)      = ATD_CONST_IDX(BD_UB_IDX(bd_idx, dim));
01808          }
01809          else if (ATD_SYMBOLIC_CONSTANT(BD_UB_IDX(bd_idx, dim))) {
01810 
01811             if (array_size_type != Var_Len_Array) {
01812                array_size_type  = Symbolic_Constant_Size;
01813             }
01814          }
01815          else {
01816             array_size_type     = Var_Len_Array;
01817             OPND_FLD(opnd)      = BD_UB_FLD(bd_idx, dim);
01818             OPND_IDX(opnd)      = BD_UB_IDX(bd_idx, dim);
01819             OPND_LINE_NUM(opnd) = BD_LINE_NUM(bd_idx);
01820             OPND_COL_NUM(opnd)  = BD_COLUMN_NUM(bd_idx);
01821          }
01822       }
01823    }
01824 
01825    if (BD_ARRAY_CLASS(bd_idx) == Assumed_Size) {
01826 
01827       /* This is called by PARAMETER processing.  This must be an explicit */
01828       /* shape constant size array.  PARAMETER processing will issue the   */
01829       /* error.  If this is needed elsewhere, it will come through again   */
01830       /* during decl_semantics.                                            */
01831 
01832       if (need_const_array) {
01833          goto EXIT;
01834       }
01835 
01836       BD_ARRAY_SIZE(bd_idx)     = array_size_type;
01837    }
01838    else { 
01839       BD_ARRAY_SIZE(bd_idx)     = array_size_type;
01840 
01841       if (array_size_type == Var_Len_Array) {
01842 
01843          BD_ARRAY_SIZE(bd_idx)  = Var_Len_Array;
01844 
01845          /* This is called by PARAMETER processing.  This must be an explicit */
01846          /* shape constant size array.  PARAMETER processing will issue the   */
01847          /* error.  If this is needed elsewhere, it will come through again   */
01848          /* during decl_semantics.                                            */
01849 
01850          if (need_const_array) {
01851             goto EXIT;
01852          }
01853 
01854          if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Function &&
01855              ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Subroutine) {
01856             PRINTMSG(AT_DEF_LINE(attr_idx), 131, Error,
01857                      AT_DEF_COLUMN(attr_idx), 
01858                      AT_OBJ_NAME_PTR(attr_idx));
01859             BD_DCL_ERR(bd_idx) = TRUE;
01860          }
01861       }
01862    }
01863 
01864    BD_RESOLVED(bd_idx)  = TRUE;
01865 
01866    set_stride_for_first_dim(ATD_TYPE_IDX(attr_idx), &stride);
01867 
01868    if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character &&
01869       stride.fld == AT_Tbl_Idx && 
01870       ATD_NO_ENTRY_LIST(stride.idx) != NULL_IDX) {
01871       stride_entry_idx  = merge_entry_lists(NULL_IDX,
01872                                             ATD_NO_ENTRY_LIST(stride.idx));
01873    }
01874    else {
01875       stride_entry_idx  = NULL_IDX;
01876    }
01877 
01878    NTR_IR_TBL(len_ir_idx);
01879    IR_TYPE_IDX(len_ir_idx) = SA_INTEGER_DEFAULT_TYPE;
01880 
01881    BD_LEN_IDX(bd_idx)   = len_ir_idx;   /* Save this so it can be folded */
01882    BD_LEN_FLD(bd_idx)   = IR_Tbl_Idx;
01883    length_entry_idx     = NULL_IDX;
01884    line                 = BD_LINE_NUM(bd_idx);
01885    column               = BD_COLUMN_NUM(bd_idx);
01886 
01887    for (dim = 1; dim <= BD_RANK(bd_idx); dim++) {
01888       BD_SM_FLD(bd_idx, dim)    = stride.fld;
01889       BD_SM_IDX(bd_idx, dim)    = stride.idx;
01890 
01891       if (extent_entry_idx != NULL_IDX) {
01892          free_attr_list(extent_entry_idx);
01893          extent_entry_idx       = NULL_IDX;
01894       }
01895 
01896       if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) {
01897          at_idx = BD_LB_IDX(bd_idx, dim);
01898 
01899          if (ATD_NO_ENTRY_LIST(at_idx) != NULL_IDX) {
01900             extent_entry_idx = merge_entry_lists(NULL_IDX, 
01901                                                  ATD_NO_ENTRY_LIST(at_idx));
01902          }
01903       }
01904    
01905       if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx) {
01906          at_idx = BD_UB_IDX(bd_idx, dim);
01907 
01908          if (ATD_NO_ENTRY_LIST(at_idx) != NULL_IDX) {
01909             extent_entry_idx = merge_entry_lists(extent_entry_idx, 
01910                                                  ATD_NO_ENTRY_LIST(at_idx));
01911          }
01912       }
01913 
01914       if (BD_LB_FLD(bd_idx, dim) == CN_Tbl_Idx &&
01915           fold_relationals(BD_LB_IDX(bd_idx, dim),
01916                            CN_INTEGER_ONE_IDX,
01917                            Eq_Opr)) {
01918 
01919          /* If the lb is a one, just use the ub for the extent */
01920 
01921          extent_fld = BD_UB_FLD(bd_idx, dim);
01922          extent_idx = BD_UB_IDX(bd_idx, dim);
01923       }
01924       else {
01925 /* # if 0  cannot get ride of it.Because array initialize need BD_XT valuses to be correct!!!*/
01926          NTR_IR_TBL(ir_idx);                    /* Create 1 - lower */
01927          IR_OPR(ir_idx)                         = Minus_Opr;
01928          IR_TYPE_IDX(ir_idx)                    = SA_INTEGER_DEFAULT_TYPE;
01929          IR_FLD_L(ir_idx)                       = CN_Tbl_Idx;
01930          IR_IDX_L(ir_idx)                       = CN_INTEGER_ONE_IDX;
01931          IR_LINE_NUM_L(ir_idx)                  = line;
01932          IR_COL_NUM_L(ir_idx)                   = column;
01933          IR_FLD_R(ir_idx)                       = BD_LB_FLD(bd_idx, dim);
01934          IR_IDX_R(ir_idx)                       = BD_LB_IDX(bd_idx, dim);
01935          IR_LINE_NUM_R(ir_idx)                  = line;
01936          IR_COL_NUM_R(ir_idx)                   = column;
01937          IR_LINE_NUM(ir_idx)                    = line;
01938          IR_COL_NUM(ir_idx)                     = column;
01939 
01940          NTR_IR_TBL(next_ir_idx);               /* Upper + (1 - lower) */
01941          IR_OPR(next_ir_idx)                    = Plus_Opr;
01942          IR_TYPE_IDX(next_ir_idx)               = SA_INTEGER_DEFAULT_TYPE;
01943          IR_IDX_L(next_ir_idx)                  = BD_UB_IDX(bd_idx, dim);
01944          IR_FLD_L(next_ir_idx)                  = BD_UB_FLD(bd_idx, dim);
01945          IR_LINE_NUM_L(next_ir_idx)             = line;
01946          IR_COL_NUM_L(next_ir_idx)              = column;
01947          IR_FLD_R(next_ir_idx)                  = IR_Tbl_Idx;
01948          IR_IDX_R(next_ir_idx)                  = ir_idx;
01949          IR_LINE_NUM_R(next_ir_idx)             = line;
01950          IR_COL_NUM_R(next_ir_idx)              = column;
01951          IR_LINE_NUM(next_ir_idx)               = line;
01952          IR_COL_NUM(next_ir_idx)                = column;
01953 
01954          if (BD_ARRAY_SIZE(bd_idx) == Symbolic_Constant_Size) {
01955             IR_OPR(next_ir_idx) = Symbolic_Plus_Opr;
01956             IR_OPR(ir_idx)      = Symbolic_Minus_Opr;
01957             extent_idx          = gen_compiler_tmp(line, column, Priv, TRUE);
01958             extent_fld          = AT_Tbl_Idx;
01959 
01960             ATD_SYMBOLIC_CONSTANT(extent_idx)   = TRUE;
01961             ATD_TYPE_IDX(extent_idx)            = SA_INTEGER_DEFAULT_TYPE;
01962             ATD_FLD(extent_idx)                 = IR_Tbl_Idx;
01963             ATD_TMP_IDX(extent_idx)             = next_ir_idx;
01964 
01965 
01966             /* KAY - Some of this may be folded if they are both not */
01967             /*       symbolic constants.                             */
01968          }
01969          else {
01970 
01971             OPND_FLD(opnd)                      = IR_Tbl_Idx;
01972             OPND_IDX(opnd)                      = next_ir_idx;
01973             OPND_LINE_NUM(opnd)                 = stmt_start_line;
01974             OPND_COL_NUM(opnd)                  = stmt_start_col;
01975 
01976             sh_idx                              = ntr_sh_tbl();
01977             SH_GLB_LINE(sh_idx)                 = stmt_start_line;
01978             SH_COL_NUM(sh_idx)                  = stmt_start_col;
01979             SH_STMT_TYPE(sh_idx)                = Automatic_Base_Size_Stmt;
01980             SH_COMPILER_GEN(sh_idx)             = TRUE;
01981             SH_P2_SKIP_ME(sh_idx)               = TRUE;
01982 
01983             expr_desc.rank = 0;
01984             xref_state     = CIF_No_Usage_Rec;
01985 
01986             /* This is in terms of tmps - so it will never   */
01987             /* generate more than one statement.             */
01988 
01989             issue_overflow_msg_719 = FALSE;
01990 
01991             if (!expr_semantics(&opnd, &expr_desc)) {
01992 
01993                if (need_to_issue_719) {
01994                       
01995                   need_to_issue_719     = FALSE;
01996                   PRINTMSG(AT_DEF_LINE(attr_idx), 951, Error,
01997                            AT_DEF_COLUMN(attr_idx), 
01998                            dim,
01999                            AT_OBJ_NAME_PTR(attr_idx));
02000                }
02001                AT_DCL_ERR(attr_idx)     = TRUE;
02002             }
02003 
02004             if (OPND_FLD(opnd) == CN_Tbl_Idx) {
02005                extent_fld       = CN_Tbl_Idx;
02006                extent_idx       = OPND_IDX(opnd);
02007                FREE_SH_NODE(sh_idx);
02008             }
02009             else {
02010                extent_fld = AT_Tbl_Idx;
02011                extent_idx = ntr_bnds_sh_tmp_list(&opnd,
02012                                                  extent_entry_idx,
02013                                                  is_interface ? NULL_IDX:sh_idx,
02014                                                  FALSE,
02015                                                  SA_INTEGER_DEFAULT_TYPE);
02016             }
02017          }
02018       }
02019 
02020       if (extent_fld == CN_Tbl_Idx) {
02021 
02022          if (compare_cn_and_value(extent_idx, 0, Lt_Opr)) {
02023             extent_idx = CN_INTEGER_ZERO_IDX;
02024          }
02025       }
02026       else {  /* Generate  tmp = max(0, extent) */
02027 
02028          OPND_FLD(opnd)         = extent_fld;
02029          OPND_IDX(opnd)         = extent_idx;
02030          OPND_LINE_NUM(opnd)    = line;
02031          OPND_COL_NUM(opnd)     = column;
02032 
02033          gen_tmp_equal_max_zero(&opnd, 
02034                                 SA_INTEGER_DEFAULT_TYPE,
02035                                 extent_entry_idx,
02036                                 (BD_ARRAY_SIZE(bd_idx)==Symbolic_Constant_Size),
02037                                 is_interface);
02038          extent_fld             = OPND_FLD(opnd);
02039          extent_idx             = OPND_IDX(opnd);
02040 /* # endif */
02041 # if 0
02042          extent_fld             = BD_UB_FLD(bd_idx,dim); /* April */
02043          extent_idx             = BD_UB_IDX(bd_idx,dim);
02044 # endif
02045       }
02046       BD_XT_FLD(bd_idx, dim)    = extent_fld;
02047       BD_XT_IDX(bd_idx, dim)    = extent_idx;
02048 
02049       /* STRIDE = STRIDE * (EXTENT of previous dimension) */
02050       /* Fix stride for next dimension.                   */
02051       /* Calculate length.                                */
02052 
02053       if (dim < BD_RANK(bd_idx)) {
02054          NTR_IR_TBL(ir_idx);            /* Create Stride * Extent */
02055          IR_OPR(ir_idx)                 = Mult_Opr;
02056          IR_TYPE_IDX(ir_idx)            = SA_INTEGER_DEFAULT_TYPE;
02057          IR_LINE_NUM(ir_idx)            = BD_LINE_NUM(bd_idx);
02058          IR_COL_NUM(ir_idx)             = BD_COLUMN_NUM(bd_idx);
02059          IR_FLD_L(ir_idx)               = stride.fld;
02060          IR_IDX_L(ir_idx)               = stride.idx;
02061          IR_LINE_NUM_L(ir_idx)          = BD_LINE_NUM(bd_idx);
02062          IR_COL_NUM_L(ir_idx)           = BD_COLUMN_NUM(bd_idx);
02063          IR_FLD_R(ir_idx)               = extent_fld;
02064          IR_IDX_R(ir_idx)               = extent_idx;
02065          IR_LINE_NUM_R(ir_idx)          = BD_LINE_NUM(bd_idx);
02066          IR_COL_NUM_R(ir_idx)           = BD_COLUMN_NUM(bd_idx);
02067 
02068          if (BD_ARRAY_SIZE(bd_idx) == Symbolic_Constant_Size) {
02069             IR_OPR(ir_idx)      = Symbolic_Mult_Opr;
02070             stride.fld          = AT_Tbl_Idx;
02071             stride.idx          = gen_compiler_tmp(line, column, Priv, TRUE);
02072 
02073             ATD_TYPE_IDX(stride.idx)            = SA_INTEGER_DEFAULT_TYPE;
02074             ATD_FLD(stride.idx)                 = IR_Tbl_Idx;
02075             ATD_TMP_IDX(stride.idx)             = ir_idx;
02076             ATD_SYMBOLIC_CONSTANT(stride.idx)   = TRUE;
02077          }
02078          else {
02079             OPND_FLD(opnd)              = IR_Tbl_Idx;
02080             OPND_IDX(opnd)              = ir_idx;
02081             OPND_LINE_NUM(opnd)         = stmt_start_line;
02082             OPND_COL_NUM(opnd)          = stmt_start_col;
02083 
02084             sh_idx                      = ntr_sh_tbl();
02085             SH_STMT_TYPE(sh_idx)        = Automatic_Base_Size_Stmt;
02086             SH_COMPILER_GEN(sh_idx)     = TRUE;
02087             SH_P2_SKIP_ME(sh_idx)       = TRUE;
02088             SH_GLB_LINE(sh_idx)         = stmt_start_line;
02089             SH_COL_NUM(sh_idx)          = stmt_start_col;
02090 
02091             expr_desc.rank              = 0;
02092             xref_state                  = CIF_No_Usage_Rec;
02093 
02094             expr_semantics(&opnd, &expr_desc);
02095 
02096             if (OPND_FLD(opnd) == CN_Tbl_Idx) {
02097                stride.fld               = CN_Tbl_Idx;
02098                stride.idx               = OPND_IDX(opnd);
02099                FREE_SH_NODE(sh_idx);
02100             }
02101             else {
02102 
02103                if (!is_interface) {
02104 
02105                   /* Stride must be non-constant, if extent is non-constant */
02106 
02107                   if (extent_entry_idx != NULL_IDX) {
02108                      stride_entry_idx = merge_entry_lists(stride_entry_idx, 
02109                                                           extent_entry_idx);
02110                      length_entry_idx = merge_entry_lists(length_entry_idx, 
02111                                                           extent_entry_idx);
02112                   }
02113                }
02114 
02115                stride.fld = AT_Tbl_Idx;
02116                stride.idx = ntr_bnds_sh_tmp_list(&opnd,
02117                                               stride_entry_idx,
02118                                               (is_interface) ? NULL_IDX: sh_idx,
02119                                               FALSE,
02120                                               SA_INTEGER_DEFAULT_TYPE);
02121             }
02122          }
02123 
02124          NTR_IR_TBL(mult_idx);   /* Create length = extent * extent */
02125          IR_LINE_NUM(mult_idx)          = BD_LINE_NUM(bd_idx);
02126          IR_COL_NUM(mult_idx)           = BD_COLUMN_NUM(bd_idx);
02127 
02128          if (BD_ARRAY_SIZE(bd_idx) == Symbolic_Constant_Size) {
02129             IR_OPR(mult_idx)            = Symbolic_Mult_Opr;
02130          }
02131          else {
02132             IR_OPR(mult_idx)            = Mult_Opr;
02133          }
02134 
02135          IR_TYPE_IDX(mult_idx)          = SA_INTEGER_DEFAULT_TYPE;
02136          IR_IDX_R(len_ir_idx)           = mult_idx;
02137          IR_FLD_R(len_ir_idx)           = IR_Tbl_Idx;
02138          IR_LINE_NUM_R(len_ir_idx)      = BD_LINE_NUM(bd_idx);
02139          IR_COL_NUM_R(len_ir_idx)       = BD_COLUMN_NUM(bd_idx);
02140          IR_IDX_L(mult_idx)             = extent_idx;
02141          IR_FLD_L(mult_idx)             = extent_fld;
02142          IR_LINE_NUM_L(mult_idx)        = BD_LINE_NUM(bd_idx);
02143          IR_COL_NUM_L(mult_idx)         = BD_COLUMN_NUM(bd_idx);
02144          len_ir_idx                     = mult_idx;
02145       }
02146       else if (dim == 1) {
02147 
02148          /* Last dimension is the only dimension, so length = xtent */
02149 
02150          BD_LEN_FLD(bd_idx)     = extent_fld;
02151          BD_LEN_IDX(bd_idx)     = extent_idx;
02152          length_entry_idx       = extent_entry_idx;
02153          stride_entry_idx       = merge_entry_lists(stride_entry_idx,
02154                                                     extent_entry_idx);
02155          extent_entry_idx       = NULL_IDX;  /* List now pointed by length.. */
02156 
02157          if (length_entry_idx != NULL_IDX) {  /* Alt entries - need tmp = 0 */
02158             gen_tmp_eq_zero_ir(extent_idx);
02159          }
02160       }
02161 
02162       /* Last dimension */
02163 
02164       else if (BD_ARRAY_SIZE(bd_idx) == Symbolic_Constant_Size) {
02165          IR_IDX_R(len_ir_idx)           = extent_idx;
02166          IR_FLD_R(len_ir_idx)           = extent_fld;
02167          IR_LINE_NUM_R(len_ir_idx)      = BD_LINE_NUM(bd_idx);
02168          IR_COL_NUM_R(len_ir_idx)       = BD_COLUMN_NUM(bd_idx);
02169          OPND_FLD(opnd)                 = IR_FLD_R(BD_LEN_IDX(bd_idx));
02170          OPND_IDX(opnd)                 = IR_IDX_R(BD_LEN_IDX(bd_idx));
02171 
02172          BD_LEN_FLD(bd_idx)     = AT_Tbl_Idx;
02173          BD_LEN_IDX(bd_idx)     = gen_compiler_tmp(line, column, Priv, TRUE);
02174 
02175          ATD_TYPE_IDX(BD_LEN_IDX(bd_idx))       = SA_INTEGER_DEFAULT_TYPE;
02176          ATD_FLD(BD_LEN_IDX(bd_idx))            = OPND_FLD(opnd);
02177          ATD_TMP_IDX(BD_LEN_IDX(bd_idx))        = OPND_IDX(opnd);
02178 
02179          ATD_SYMBOLIC_CONSTANT(BD_LEN_IDX(bd_idx))      = TRUE;
02180       }
02181       else {
02182          IR_IDX_R(len_ir_idx)           = extent_idx;
02183          IR_FLD_R(len_ir_idx)           = extent_fld;
02184          IR_LINE_NUM_R(len_ir_idx)      = BD_LINE_NUM(bd_idx);
02185          IR_COL_NUM_R(len_ir_idx)       = BD_COLUMN_NUM(bd_idx);
02186          OPND_FLD(opnd)                 = IR_FLD_R(BD_LEN_IDX(bd_idx));
02187          OPND_IDX(opnd)                 = IR_IDX_R(BD_LEN_IDX(bd_idx));
02188          OPND_LINE_NUM(opnd)            = BD_LINE_NUM(bd_idx);
02189          OPND_COL_NUM(opnd)             = BD_COLUMN_NUM(bd_idx);
02190 
02191          sh_idx                         = ntr_sh_tbl();
02192          SH_STMT_TYPE(sh_idx)           = Automatic_Base_Size_Stmt;
02193          SH_COMPILER_GEN(sh_idx)        = TRUE;
02194          SH_P2_SKIP_ME(sh_idx)          = TRUE;
02195          SH_GLB_LINE(sh_idx)            = stmt_start_line;
02196          SH_COL_NUM(sh_idx)             = stmt_start_col;
02197 
02198          /* expr_semantics needs curr_stmt_sh_idx set to something valid.  */
02199          /* It does not need SH_IR_IDX(curr_stmt_sh_idx) set to something. */
02200 
02201          expr_desc.rank = 0;
02202          xref_state     = CIF_No_Usage_Rec;
02203 
02204 # if defined(_CHECK_MAX_MEMORY)
02205 
02206          if (!target_t3e) {
02207             issue_overflow_msg_719 = FALSE;
02208          }
02209 # endif
02210 
02211          if (!expr_semantics(&opnd, &expr_desc)) {
02212 
02213             if (need_to_issue_719) {
02214 
02215                /* We have overflowed - Reattempt with a bigger int type */
02216 
02217                if (OPND_FLD(opnd) == IR_Tbl_Idx) {
02218                   IR_TYPE_IDX(OPND_IDX(opnd)) = SA_INTEGER_DEFAULT_TYPE;
02219 
02220                   switch (IR_FLD_L(OPND_IDX(opnd))) {
02221                   case AT_Tbl_Idx:
02222                      type = TYP_LINEAR(ATD_TYPE_IDX(IR_IDX_L(OPND_IDX(opnd))));
02223                      break;
02224 
02225                   case IR_Tbl_Idx:
02226                      type = TYP_LINEAR(IR_TYPE_IDX(IR_IDX_L(OPND_IDX(opnd))));
02227                      break;
02228 
02229                   case CN_Tbl_Idx:
02230                      type = TYP_LINEAR(CN_TYPE_IDX(IR_IDX_L(OPND_IDX(opnd))));
02231                      break;
02232                   }
02233 
02234                   if (type < SA_INTEGER_DEFAULT_TYPE) {
02235                      NTR_IR_TBL(cvrt_idx);
02236                      IR_OPR(cvrt_idx)            = Cvrt_Opr;
02237                      IR_TYPE_IDX(cvrt_idx)       = SA_INTEGER_DEFAULT_TYPE;
02238                      IR_LINE_NUM(cvrt_idx)       = BD_LINE_NUM(bd_idx);
02239                      IR_COL_NUM(cvrt_idx)        = BD_COLUMN_NUM(bd_idx);
02240                      COPY_OPND(IR_OPND_L(cvrt_idx), IR_OPND_L(OPND_IDX(opnd)));
02241                      IR_FLD_L(OPND_IDX(opnd))    = IR_Tbl_Idx;
02242                      IR_IDX_L(OPND_IDX(opnd))    = cvrt_idx;
02243                   }
02244 
02245                   switch (IR_FLD_R(OPND_IDX(opnd))) {
02246                   case AT_Tbl_Idx:
02247                      type = TYP_LINEAR(ATD_TYPE_IDX(IR_IDX_R(OPND_IDX(opnd))));
02248                      break;
02249 
02250                   case IR_Tbl_Idx:
02251                      type = TYP_LINEAR(IR_TYPE_IDX(IR_IDX_R(OPND_IDX(opnd))));
02252                      break;
02253 
02254                   case CN_Tbl_Idx:
02255                      type = TYP_LINEAR(CN_TYPE_IDX(IR_IDX_R(OPND_IDX(opnd))));
02256                      break;
02257                   }
02258 
02259                   if (type < SA_INTEGER_DEFAULT_TYPE) {
02260                      NTR_IR_TBL(cvrt_idx);
02261                      IR_OPR(cvrt_idx)            = Cvrt_Opr;
02262                      IR_TYPE_IDX(cvrt_idx)       = SA_INTEGER_DEFAULT_TYPE;
02263                      IR_LINE_NUM(cvrt_idx)       = BD_LINE_NUM(bd_idx);
02264                      IR_COL_NUM(cvrt_idx)        = BD_COLUMN_NUM(bd_idx);
02265                      COPY_OPND(IR_OPND_L(cvrt_idx), IR_OPND_R(OPND_IDX(opnd)));
02266                      IR_FLD_R(OPND_IDX(opnd))    = IR_Tbl_Idx;
02267                      IR_IDX_R(OPND_IDX(opnd))    = cvrt_idx;
02268                   }
02269                   need_to_issue_719     = FALSE;
02270                }
02271 
02272                if (!expr_semantics(&opnd, &expr_desc)) {
02273 
02274                   if (!target_t3e) {
02275                      AT_DCL_ERR(attr_idx)       = TRUE;
02276                   }
02277                }
02278             }
02279             else if (!target_t3e) {
02280                AT_DCL_ERR(attr_idx)     = TRUE;
02281             }
02282 
02283             if (need_to_issue_719) {
02284                need_to_issue_719        = FALSE;
02285                AT_DCL_ERR(attr_idx)     = TRUE;
02286                ISSUE_STORAGE_SIZE_EXCEEDED_MSG(attr_idx, Error);
02287             }
02288          }
02289 
02290          if (OPND_FLD(opnd) == CN_Tbl_Idx) {
02291             BD_LEN_FLD(bd_idx)  = CN_Tbl_Idx;
02292             BD_LEN_IDX(bd_idx)  = OPND_IDX(opnd);
02293             FREE_SH_NODE(sh_idx);
02294          }
02295          else {
02296 
02297             if (!is_interface) {
02298 
02299                if (extent_entry_idx != NULL_IDX) {
02300                   stride_entry_idx = merge_entry_lists(stride_entry_idx, 
02301                                                        extent_entry_idx);
02302                   length_entry_idx = merge_entry_lists(length_entry_idx, 
02303                                                        extent_entry_idx);
02304                }
02305             }
02306 
02307             length_idx = ntr_bnds_sh_tmp_list(&opnd,
02308                                               length_entry_idx,
02309                                               (is_interface) ? NULL_IDX:sh_idx,
02310                                               TRUE,
02311                                               SA_INTEGER_DEFAULT_TYPE);
02312             BD_LEN_IDX(bd_idx) = length_idx;
02313             BD_LEN_FLD(bd_idx) = AT_Tbl_Idx;
02314          }
02315       }
02316    }
02317 
02318    /* After the dimensions are processed, stride_entry_idx contains a list   */
02319    /* of all bad entry points, for the array - including all extents and     */
02320    /* type information.  Stride is calculated from the (previous dimension's */
02321    /* extent) * (previous dimension's stride).  A stride_entry_idx is made   */
02322    /* for the last dimension, even though actual stride isn't calculated for */
02323    /* this dimension.                                                        */
02324 
02325    if (stride_entry_idx != NULL_IDX) {
02326       entry_count       = SCP_ALT_ENTRY_CNT(curr_scp_idx) + 1; 
02327 
02328       if (length_entry_idx != NULL_IDX &&
02329           entry_count == AL_ENTRY_COUNT(length_entry_idx))  {
02330 
02331          /* Error if problem with lower and/or upper bounds coming in    */
02332          /* different entry points.  Bounds for this array declaration   */
02333          /* cannot be calculated at any entry point, because dummy args  */
02334          /* used in the expression do not enter at all the same points.  */
02335 
02336          PRINTMSG(AT_DEF_LINE(attr_idx), 660, Error,
02337                   AT_DEF_COLUMN(attr_idx), 
02338                   AT_OBJ_NAME_PTR(attr_idx));
02339          AT_DCL_ERR(attr_idx)   = TRUE;
02340       }
02341       else if (entry_count == AL_ENTRY_COUNT(stride_entry_idx))  {
02342 
02343          /* If the length is okay, but there's a problem with the        */
02344          /* stride, that means that it's a character and a bound         */
02345          /* forming the char length, doesn't enter the same as all       */
02346          /* the dimension bounds.  Bounds for this array declaration     */
02347          /* cannot be calculated at any entry point, because dummy args  */
02348          /* used in the expression de not enter at all the same points.  */
02349 
02350          PRINTMSG(AT_DEF_LINE(attr_idx), 661, Error,
02351                   AT_DEF_COLUMN(attr_idx), 
02352                   AT_OBJ_NAME_PTR(attr_idx));
02353          AT_DCL_ERR(attr_idx)   = TRUE;
02354       }
02355       else if (entry_list != NULL_IDX) {
02356          stride_entry_count = merge_entry_list_count(stride_entry_idx,
02357                                                      entry_list);
02358 
02359          if (entry_count == stride_entry_count) {
02360 
02361             /* This array and its bound variables do not enter at the  */
02362             /* same entry point.                                       */
02363 
02364             PRINTMSG(AT_DEF_LINE(attr_idx), 662, Error,
02365                      AT_DEF_COLUMN(attr_idx), 
02366                      AT_OBJ_NAME_PTR(attr_idx));
02367             AT_DCL_ERR(attr_idx)        = TRUE;
02368          }
02369       }
02370    }
02371 
02372 NEXT:
02373 
02374    /* Every array must have the following semantic checks.  So even if the   */
02375    /* bounds for the array are already resolved, it still must get these     */
02376    /* checks.                                                                */
02377 
02378    if (BD_ARRAY_CLASS(bd_idx) == Explicit_Shape &&
02379        BD_ARRAY_SIZE(bd_idx) == Constant_Size) {
02380 
02381       /* Check so the item does not exceed max storage size.  Do it here,     */
02382       /* even though it is also done in final_decl_semantics because this     */
02383       /* may be a constant array involved in data or parameter statements or  */
02384       /* it may get folded.                                                   */
02385 
02386       stor_bit_size_of(attr_idx, TRUE, TRUE);
02387    }
02388    else if (need_const_array) {  
02389 
02390       /* Need an explicit_shape constant size array for parameter processing */
02391       /* An error will be issued in PARAMETER processing if this isn't a     */
02392       /* constant size array.                                                */
02393 
02394       /* This if block is intentionally blank. */
02395    }
02396    else {
02397 
02398       if (BD_ARRAY_SIZE(bd_idx) == Symbolic_Constant_Size) {
02399          fnd_semantic_err(Obj_Sym_Constant_Arr,
02400                           AT_DEF_LINE(attr_idx),
02401                           AT_DEF_COLUMN(attr_idx),
02402                           attr_idx,
02403                           TRUE);
02404 
02405          if (ATD_STOR_BLK_IDX(attr_idx) != NULL_IDX) {
02406             SB_BLK_HAS_NPES(ATD_STOR_BLK_IDX(attr_idx)) = TRUE;
02407          }
02408 
02409          if (cmd_line_flags.malleable) {
02410             PRINTMSG(AT_DEF_LINE(attr_idx), 1232, Error,
02411                      AT_DEF_COLUMN(attr_idx));
02412          }
02413       }
02414 
02415       if (BD_ARRAY_CLASS(bd_idx) == Assumed_Size) {
02416 
02417          /* This is called by PARAMETER processing.  This must be an explicit */
02418          /* shape constant size array.  PARAMETER processing will issue the   */
02419          /* error.  If this is needed elsewhere, it will come through again   */
02420          /* during decl_semantics.                                            */
02421 
02422          if (ATD_CLASS(attr_idx) == CRI__Pointee) {
02423 
02424             if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) {
02425                AT_DCL_ERR(attr_idx) = TRUE;
02426                PRINTMSG(AT_DEF_LINE(attr_idx), 1419, Error,
02427                         AT_DEF_COLUMN(attr_idx),
02428                         AT_OBJ_NAME_PTR(attr_idx));
02429             }
02430          }
02431          else if (ATD_CLASS(attr_idx) != Dummy_Argument) {
02432 
02433             /* Must be dummy arg or CRI pointee.  */
02434 
02435             if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {
02436                AT_DCL_ERR(attr_idx) = TRUE;
02437                PRINTMSG(AT_DEF_LINE(attr_idx), 501, Error,
02438                         AT_DEF_COLUMN(attr_idx),
02439                         AT_OBJ_NAME_PTR(attr_idx));
02440             }
02441             else {
02442                AT_DCL_ERR(attr_idx) = TRUE;
02443                PRINTMSG(AT_DEF_LINE(attr_idx), 500, Error,
02444                         AT_DEF_COLUMN(attr_idx),
02445                         AT_OBJ_NAME_PTR(attr_idx));
02446             }
02447          }
02448 
02449 # if defined(_TARGET_OS_MAX)
02450          if (ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX) {
02451             AT_DCL_ERR(attr_idx)        = TRUE;
02452             PRINTMSG(BD_LINE_NUM(ATD_PE_ARRAY_IDX(attr_idx)), 1583, Error,
02453                      BD_COLUMN_NUM(ATD_PE_ARRAY_IDX(attr_idx)),
02454                      "co-array dimensions",
02455                      "assumed-size arrays");
02456          }
02457 # endif
02458       }
02459       else if (BD_ARRAY_SIZE(bd_idx) == Var_Len_Array) {
02460          fnd_semantic_err(Obj_Var_Len_Arr,
02461                           AT_DEF_LINE(attr_idx),
02462                           AT_DEF_COLUMN(attr_idx),
02463                           attr_idx,
02464                           TRUE);
02465 
02466          if (ATD_CLASS(attr_idx) == Variable) {
02467 
02468             if (ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX) {
02469                AT_DCL_ERR(attr_idx)     = TRUE;
02470                PRINTMSG(AT_DEF_LINE(attr_idx), 1577, Error,
02471                         AT_DEF_COLUMN(attr_idx),
02472                         AT_OBJ_NAME_PTR(attr_idx));
02473             }
02474             else {
02475                ATD_AUTOMATIC(attr_idx) = TRUE;
02476             }
02477 
02478             if (stride_entry_idx != NULL_IDX) {
02479                PRINTMSG(AT_DEF_LINE(attr_idx), 1046, Caution,
02480                         AT_DEF_COLUMN(attr_idx),
02481                         AT_OBJ_NAME_PTR(attr_idx));
02482             }
02483          }
02484       }
02485    }
02486  
02487 
02488 EXIT:
02489 
02490    if (stride_entry_idx != NULL_IDX) {
02491       free_attr_list(stride_entry_idx);
02492    }
02493 
02494    if (length_entry_idx != NULL_IDX) {
02495       free_attr_list(length_entry_idx);
02496    }
02497 
02498    if (ATD_CLASS(attr_idx) == Function_Result) {
02499       ATP_NO_ENTRY_LIST(ATD_FUNC_IDX(attr_idx)) = entry_list;
02500    }
02501    else {
02502       ATD_NO_ENTRY_LIST(attr_idx)               = entry_list;
02503    }
02504 
02505    TRACE (Func_Exit, "array_dim_resolution", NULL);
02506 
02507    return;
02508 
02509 }  /* array_dim_resolution */
02510 
02511 /******************************************************************************\
02512 |*                                                                            *|
02513 |* Description:                                                               *|
02514 |*      This routine resolves the lower and upper bounds to a constant or a   *|
02515 |*      temp.  Calculate the extent and stride multiplier for each dimension. *|
02516 |*                                                                            *|
02517 |* Input parameters:                                                          *|
02518 |*      attr_idx -> Index to attribute for array.                             *|
02519 |*                                                                            *|
02520 |* Output parameters:                                                         *|
02521 |*      NONE                                                                  *|
02522 |*                                                                            *|
02523 |* Returns:                                                                   *|
02524 |*      NONE                                                                  *|
02525 |*                                                                            *|
02526 \******************************************************************************/
02527 
02528 void    pe_array_dim_resolution(int        attr_idx)
02529 
02530 {
02531    bd_array_size_type   array_size_type;
02532    int                  at_idx;
02533    int                  bd_idx;
02534    int                  dim;
02535    int                  entry_count;
02536    int                  entry_list;
02537    expr_arg_type        expr_desc;
02538    int                  extent_entry_idx        = NULL_IDX;
02539    fld_type             extent_fld;
02540    int                  extent_idx;
02541    int                  ir_idx;
02542    boolean              is_interface;
02543    int                  len_ir_idx;
02544    int                  length_idx;
02545    int                  length_entry_idx        = NULL_IDX;
02546    int                  mult_idx;
02547    int                  next_ir_idx;
02548    opnd_type            opnd;
02549    int                  sh_idx;
02550    int                  stride_entry_idx        = NULL_IDX;
02551    int                  stride_entry_count;
02552    size_offset_type     stride;
02553 
02554 
02555    TRACE (Func_Entry, "pe_array_dim_resolution", NULL);
02556 
02557    is_interface = SCP_IS_INTERFACE(curr_scp_idx);
02558    bd_idx       = ATD_PE_ARRAY_IDX(attr_idx);
02559 
02560    if (ATD_CLASS(attr_idx) == Function_Result) {
02561       entry_list        = ATP_NO_ENTRY_LIST(ATD_FUNC_IDX(attr_idx));
02562    }
02563    else {
02564       entry_list        = ATD_NO_ENTRY_LIST(attr_idx);
02565    }
02566 
02567    if (BD_ARRAY_CLASS(bd_idx) == Deferred_Shape ||
02568        BD_ARRAY_CLASS(bd_idx) == Deferred_Shape1  ) {
02569 
02570       if (! ATD_ALLOCATABLE(attr_idx)) {
02571          PRINTMSG(AT_DEF_LINE(attr_idx), 1587, Error, AT_DEF_COLUMN(attr_idx),
02572                   AT_OBJ_NAME_PTR(attr_idx));
02573          BD_DCL_ERR(bd_idx) = TRUE;
02574          AT_DCL_ERR(attr_idx) = TRUE;
02575       }
02576      BD_RESOLVED(bd_idx)   = TRUE;
02577      BD_ARRAY_SIZE(bd_idx) = Unknown_Size;
02578      BD_ARRAY_CLASS(bd_idx)= Deferred_Shape1;
02579 
02580     for (dim = 1; dim <= BD_RANK(bd_idx); dim++) {
02581        BD_LB_FLD(bd_idx,dim)   = CN_Tbl_Idx;
02582        BD_LB_IDX(bd_idx,dim)   = CN_INTEGER_ONE_IDX;
02583        BD_UB_FLD(bd_idx,dim)   = NO_Tbl_Idx;
02584        BD_XT_FLD(bd_idx,dim)   = NO_Tbl_Idx;
02585     }
02586 
02587    BD_LEN_FLD(bd_idx) = NO_Tbl_Idx;
02588 
02589       goto EXIT;
02590    }
02591 
02592    /* If this array bounds entry has already been resolved, skip the section  */
02593    /* that calculates the extent, length, and stride multiplier.              */
02594    /* The only array entries that are shared are of the same type.  Each attr */
02595    /* will have to calculate it's own automatic stuff.                        */
02596 
02597    if (BD_RESOLVED(bd_idx)) {
02598       goto NEXT;
02599    }
02600 
02601    array_size_type      = Constant_Size;
02602 
02603    for (dim = 1; dim <= BD_RANK(bd_idx); dim++) {
02604 
02605       if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) {
02606 
02607          if (ATD_CLASS(BD_LB_IDX(bd_idx, dim)) == Constant) {
02608             BD_LB_FLD(bd_idx, dim)      = CN_Tbl_Idx;
02609             BD_LB_IDX(bd_idx, dim)      = ATD_CONST_IDX(BD_LB_IDX(bd_idx, dim));
02610          }
02611          else if (ATD_SYMBOLIC_CONSTANT(BD_LB_IDX(bd_idx, dim))) {
02612             array_size_type     = Symbolic_Constant_Size;
02613          }
02614          else {
02615             array_size_type     = Var_Len_Array;
02616          }
02617       }
02618 
02619       if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx) {
02620 
02621          if (ATD_CLASS(BD_UB_IDX(bd_idx, dim)) == Constant) {
02622             BD_UB_FLD(bd_idx, dim)      = CN_Tbl_Idx;
02623             BD_UB_IDX(bd_idx, dim)      = ATD_CONST_IDX(BD_UB_IDX(bd_idx, dim));
02624          }
02625          else if (ATD_SYMBOLIC_CONSTANT(BD_UB_IDX(bd_idx, dim))) {
02626 
02627             if (array_size_type != Var_Len_Array) {
02628                array_size_type  = Symbolic_Constant_Size;
02629             }
02630          }
02631          else {
02632             array_size_type     = Var_Len_Array;
02633          }
02634       }
02635    }
02636 
02637 /* fzhao if (BD_ARRAY_CLASS(bd_idx) == Assumed_Size ) { */
02638 
02639    if (BD_ARRAY_CLASS(bd_idx) != Assumed_Size ) {
02640        PRINTMSG(AT_DEF_LINE(attr_idx),1576,Error,
02641                 AT_DEF_COLUMN(attr_idx));
02642        AT_DCL_ERR(attr_idx)    = TRUE;
02643 
02644       /* This is called by PARAMETER processing.  This must be an explicit */
02645       /* shape constant size array.  PARAMETER processing will issue the   */
02646       /* error.  If this is needed elsewhere, it will come through again   */
02647       /* during decl_semantics.                                            */
02648 
02649       BD_ARRAY_SIZE(bd_idx)     = array_size_type;
02650    }
02651    else {
02652       BD_ARRAY_SIZE(bd_idx)     = array_size_type;
02653 
02654       if (array_size_type == Var_Len_Array) {
02655 
02656          BD_ARRAY_SIZE(bd_idx)  = Var_Len_Array;
02657 
02658          /* This is called by PARAMETER processing.  This must be an explicit */
02659          /* shape constant size array.  PARAMETER processing will issue the   */
02660          /* error.  If this is needed elsewhere, it will come through again   */
02661          /* during decl_semantics.                                            */
02662 
02663          if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Function &&
02664              ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Subroutine) {
02665             PRINTMSG(AT_DEF_LINE(attr_idx), 131, Error,
02666                      AT_DEF_COLUMN(attr_idx),
02667                      AT_OBJ_NAME_PTR(attr_idx));
02668             BD_DCL_ERR(bd_idx) = TRUE;
02669          }
02670       }
02671    }
02672 
02673    BD_RESOLVED(bd_idx)  = TRUE;
02674 
02675    /* stride for first pe dim is always 1 */
02676 
02677    stride.fld = CN_Tbl_Idx;
02678    stride.idx = CN_INTEGER_ONE_IDX;
02679 
02680    stride_entry_idx  = NULL_IDX;
02681 
02682    NTR_IR_TBL(len_ir_idx);
02683    IR_TYPE_IDX(len_ir_idx) = INTEGER_DEFAULT_TYPE;
02684 
02685    BD_LEN_IDX(bd_idx)   = len_ir_idx;   /* Save this so it can be folded */
02686    BD_LEN_FLD(bd_idx)   = IR_Tbl_Idx;
02687    length_entry_idx     = NULL_IDX;
02688 
02689    for (dim = 1; dim <= BD_RANK(bd_idx); dim++) {
02690       BD_SM_FLD(bd_idx, dim)    = stride.fld;
02691       BD_SM_IDX(bd_idx, dim)    = stride.idx;
02692 
02693       if (extent_entry_idx != NULL_IDX) {
02694          free_attr_list(extent_entry_idx);
02695          extent_entry_idx          = NULL_IDX;
02696       }
02697 
02698       if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx) {
02699          at_idx = BD_LB_IDX(bd_idx, dim);
02700 
02701          if (ATD_NO_ENTRY_LIST(at_idx) != NULL_IDX) {
02702             extent_entry_idx = merge_entry_lists(NULL_IDX,
02703                                                  ATD_NO_ENTRY_LIST(at_idx));
02704          }
02705       }
02706 
02707       if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx) {
02708          at_idx = BD_UB_IDX(bd_idx, dim);
02709 
02710          if (ATD_NO_ENTRY_LIST(at_idx) != NULL_IDX) {
02711             extent_entry_idx = merge_entry_lists(extent_entry_idx,
02712                                                  ATD_NO_ENTRY_LIST(at_idx));
02713          }
02714       }
02715 
02716       if (BD_LB_FLD(bd_idx, dim) == CN_Tbl_Idx &&
02717           fold_relationals(BD_LB_IDX(bd_idx, dim),
02718                            CN_INTEGER_ONE_IDX,
02719                            Eq_Opr)) {
02720 
02721          /* If the lb is a one, just use the ub for the extent */
02722 
02723          extent_fld = BD_UB_FLD(bd_idx, dim);
02724          extent_idx = BD_UB_IDX(bd_idx, dim);
02725       }
02726       else {
02727          NTR_IR_TBL(ir_idx);                    /* Create 1 - lower */
02728          IR_OPR(ir_idx)                         = Minus_Opr;
02729          IR_TYPE_IDX(ir_idx)                    = INTEGER_DEFAULT_TYPE;
02730          IR_FLD_L(ir_idx)                       = CN_Tbl_Idx;
02731          IR_IDX_L(ir_idx)                       = CN_INTEGER_ONE_IDX;
02732          IR_LINE_NUM_L(ir_idx)                  = BD_LINE_NUM(bd_idx);
02733          IR_COL_NUM_L(ir_idx)                   = BD_COLUMN_NUM(bd_idx);
02734          IR_FLD_R(ir_idx)                       = BD_LB_FLD(bd_idx, dim);
02735          IR_IDX_R(ir_idx)                       = BD_LB_IDX(bd_idx, dim);
02736          IR_LINE_NUM_R(ir_idx)                  = BD_LINE_NUM(bd_idx);
02737          IR_COL_NUM_R(ir_idx)                   = BD_COLUMN_NUM(bd_idx);
02738          IR_LINE_NUM(ir_idx)                    = BD_LINE_NUM(bd_idx);
02739          IR_COL_NUM(ir_idx)                     = BD_COLUMN_NUM(bd_idx);
02740 
02741          NTR_IR_TBL(next_ir_idx);               /* Upper + (1 - lower) */
02742          IR_OPR(next_ir_idx)                    = Plus_Opr;
02743          IR_TYPE_IDX(next_ir_idx)               = INTEGER_DEFAULT_TYPE;
02744          IR_IDX_L(next_ir_idx)                  = BD_UB_IDX(bd_idx, dim);
02745          IR_FLD_L(next_ir_idx)                  = BD_UB_FLD(bd_idx, dim);
02746          IR_LINE_NUM_L(next_ir_idx)             = BD_LINE_NUM(bd_idx);
02747          IR_COL_NUM_L(next_ir_idx)              = BD_COLUMN_NUM(bd_idx);
02748          IR_FLD_R(next_ir_idx)                  = IR_Tbl_Idx;
02749          IR_IDX_R(next_ir_idx)                  = ir_idx;
02750          IR_LINE_NUM_R(next_ir_idx)             = BD_LINE_NUM(bd_idx);
02751          IR_COL_NUM_R(next_ir_idx)              = BD_COLUMN_NUM(bd_idx);
02752          IR_LINE_NUM(next_ir_idx)               = BD_LINE_NUM(bd_idx);
02753          IR_COL_NUM(next_ir_idx)                = BD_COLUMN_NUM(bd_idx);
02754 
02755          if (BD_ARRAY_SIZE(bd_idx) == Symbolic_Constant_Size) {
02756             IR_OPR(next_ir_idx) = Symbolic_Plus_Opr;
02757             IR_OPR(ir_idx)      = Symbolic_Minus_Opr;
02758             extent_idx          = gen_compiler_tmp(BD_LINE_NUM(bd_idx),
02759                                                    BD_COLUMN_NUM(bd_idx),
02760                                                    Priv, TRUE);
02761             extent_fld          = AT_Tbl_Idx;
02762 
02763             ATD_SYMBOLIC_CONSTANT(extent_idx)   = TRUE;
02764             ATD_TYPE_IDX(extent_idx)            = CG_INTEGER_DEFAULT_TYPE;
02765             ATD_FLD(extent_idx)                 = IR_Tbl_Idx;
02766             ATD_TMP_IDX(extent_idx)             = next_ir_idx;
02767 
02768 
02769             /* KAY - Some of this may be folded if they are both not */
02770             /*       symbolic constants.                             */
02771          }
02772          else {
02773 
02774             OPND_FLD(opnd)                      = IR_Tbl_Idx;
02775             OPND_IDX(opnd)                      = next_ir_idx;
02776             OPND_LINE_NUM(opnd)                 = stmt_start_line;
02777             OPND_COL_NUM(opnd)                  = stmt_start_col;
02778 
02779             sh_idx                              = ntr_sh_tbl();
02780             SH_GLB_LINE(sh_idx)                 = stmt_start_line;
02781             SH_COL_NUM(sh_idx)                  = stmt_start_col;
02782             SH_STMT_TYPE(sh_idx)                = Automatic_Base_Size_Stmt;
02783             SH_COMPILER_GEN(sh_idx)             = TRUE;
02784             SH_P2_SKIP_ME(sh_idx)               = TRUE;
02785 
02786             expr_desc.rank = 0;
02787             xref_state     = CIF_No_Usage_Rec;
02788 
02789             /* This is in terms of tmps - so it will never   */
02790             /* generate more than one statement.             */
02791 
02792             if (!expr_semantics(&opnd, &expr_desc)) {
02793                PRINTMSG(AT_DEF_LINE(attr_idx), 951, Error,
02794                         AT_DEF_COLUMN(attr_idx),
02795                         dim,
02796                         AT_OBJ_NAME_PTR(attr_idx));
02797                AT_DCL_ERR(attr_idx)     = TRUE;
02798             }
02799 
02800             if (OPND_FLD(opnd) == CN_Tbl_Idx) {
02801                extent_fld       = CN_Tbl_Idx;
02802                extent_idx       = OPND_IDX(opnd);
02803                FREE_SH_NODE(sh_idx);
02804             }
02805             else {
02806                extent_fld       = AT_Tbl_Idx;
02807                extent_idx       = ntr_bnds_sh_tmp_list(&opnd,
02808                                                extent_entry_idx,
02809                                                (is_interface) ? NULL_IDX:sh_idx,
02810                                                FALSE,
02811                                                SA_INTEGER_DEFAULT_TYPE);
02812             }
02813          }
02814       }
02815 
02816       if (extent_fld == CN_Tbl_Idx) {
02817 
02818          if (compare_cn_and_value(extent_idx, 0, Lt_Opr)) {
02819             extent_idx = CN_INTEGER_ZERO_IDX;
02820          }
02821       }
02822       else {  /* Generate  tmp = max(0, extent) */
02823 
02824          OPND_FLD(opnd)         = extent_fld;
02825          OPND_IDX(opnd)         = extent_idx;
02826          OPND_LINE_NUM(opnd)    = BD_LINE_NUM(bd_idx);
02827          OPND_COL_NUM(opnd)     = BD_COLUMN_NUM(bd_idx);
02828 
02829          gen_tmp_equal_max_zero(&opnd, 
02830                                 INTEGER_DEFAULT_TYPE,
02831                                 extent_entry_idx,
02832                                 (BD_ARRAY_SIZE(bd_idx)==Symbolic_Constant_Size),
02833                                 is_interface);
02834 
02835          extent_fld             = OPND_FLD(opnd);
02836          extent_idx             = OPND_IDX(opnd);
02837       }
02838 
02839       BD_XT_FLD(bd_idx, dim)    = extent_fld;
02840       BD_XT_IDX(bd_idx, dim)    = extent_idx;
02841 
02842       /* STRIDE = STRIDE * (EXTENT of previous dimension) */
02843       /* Fix stride for next dimension.                   */
02844       /* Calculate length.                                */
02845 
02846       if (dim < BD_RANK(bd_idx)) {
02847          NTR_IR_TBL(ir_idx);            /* Create Stride * Extent */
02848          IR_OPR(ir_idx)                 = Mult_Opr;
02849          IR_TYPE_IDX(ir_idx)            = INTEGER_DEFAULT_TYPE;
02850          IR_LINE_NUM(ir_idx)            = BD_LINE_NUM(bd_idx);
02851          IR_COL_NUM(ir_idx)             = BD_COLUMN_NUM(bd_idx);
02852          IR_FLD_L(ir_idx)               = stride.fld;
02853          IR_IDX_L(ir_idx)               = stride.idx;
02854          IR_LINE_NUM_L(ir_idx)          = BD_LINE_NUM(bd_idx);
02855          IR_COL_NUM_L(ir_idx)           = BD_COLUMN_NUM(bd_idx);
02856          IR_FLD_R(ir_idx)               = extent_fld;
02857          IR_IDX_R(ir_idx)               = extent_idx;
02858          IR_LINE_NUM_R(ir_idx)          = BD_LINE_NUM(bd_idx);
02859          IR_COL_NUM_R(ir_idx)           = BD_COLUMN_NUM(bd_idx);
02860 
02861          if ((extent_fld == AT_Tbl_Idx && ATD_SYMBOLIC_CONSTANT(extent_idx)) ||
02862              (stride.fld == AT_Tbl_Idx && ATD_SYMBOLIC_CONSTANT(stride.idx))) {
02863             IR_OPR(ir_idx)      = Symbolic_Mult_Opr;
02864             stride.fld          = AT_Tbl_Idx;
02865             stride.idx          = gen_compiler_tmp(BD_LINE_NUM(bd_idx),
02866                                                    BD_COLUMN_NUM(bd_idx),
02867                                                    Priv, TRUE);
02868 
02869             ATD_TYPE_IDX(stride.idx)            = CG_INTEGER_DEFAULT_TYPE;
02870             ATD_FLD(stride.idx)                 = IR_Tbl_Idx;
02871             ATD_TMP_IDX(stride.idx)             = ir_idx;
02872             ATD_SYMBOLIC_CONSTANT(stride.idx)   = TRUE;
02873          }
02874          else {
02875             OPND_FLD(opnd)              = IR_Tbl_Idx;
02876             OPND_IDX(opnd)              = ir_idx;
02877             OPND_LINE_NUM(opnd)         = stmt_start_line;
02878             OPND_COL_NUM(opnd)          = stmt_start_col;
02879 
02880             sh_idx                      = ntr_sh_tbl();
02881             SH_STMT_TYPE(sh_idx)        = Automatic_Base_Size_Stmt;
02882             SH_COMPILER_GEN(sh_idx)     = TRUE;
02883             SH_P2_SKIP_ME(sh_idx)       = TRUE;
02884             SH_GLB_LINE(sh_idx)         = stmt_start_line;
02885             SH_COL_NUM(sh_idx)          = stmt_start_col;
02886 
02887             expr_desc.rank              = 0;
02888             xref_state                  = CIF_No_Usage_Rec;
02889 
02890             expr_semantics(&opnd, &expr_desc);
02891 
02892             if (OPND_FLD(opnd) == CN_Tbl_Idx) {
02893                stride.fld               = CN_Tbl_Idx;
02894                stride.idx               = OPND_IDX(opnd);
02895                FREE_SH_NODE(sh_idx);
02896             }
02897             else {
02898 
02899                if (!is_interface) {
02900 
02901                   /* Stride must be non-constant, if extent is non-constant */
02902 
02903                   if (extent_entry_idx != NULL_IDX) {
02904                      stride_entry_idx = merge_entry_lists(stride_entry_idx,
02905                                                           extent_entry_idx);
02906                      length_entry_idx = merge_entry_lists(length_entry_idx,
02907                                                           extent_entry_idx);
02908                   }
02909                }
02910 
02911                stride.fld = AT_Tbl_Idx;
02912                stride.idx = ntr_bnds_sh_tmp_list(&opnd,
02913                                                  stride_entry_idx,
02914                                                  is_interface ? NULL_IDX:sh_idx,
02915                                                  FALSE,
02916                                                  SA_INTEGER_DEFAULT_TYPE);
02917             }
02918          }
02919 
02920          NTR_IR_TBL(mult_idx);   /* Create length = extent * extent */
02921          IR_LINE_NUM(mult_idx)          = BD_LINE_NUM(bd_idx);
02922          IR_COL_NUM(mult_idx)           = BD_COLUMN_NUM(bd_idx);
02923          IR_OPR(mult_idx)               = (extent_fld == AT_Tbl_Idx &&
02924                                           ATD_SYMBOLIC_CONSTANT(extent_idx)) ?
02925                                           Symbolic_Mult_Opr : Mult_Opr;
02926          IR_TYPE_IDX(mult_idx)          = INTEGER_DEFAULT_TYPE;
02927          IR_IDX_R(len_ir_idx)           = mult_idx;
02928          IR_FLD_R(len_ir_idx)           = IR_Tbl_Idx;
02929          IR_LINE_NUM_R(len_ir_idx)      = BD_LINE_NUM(bd_idx);
02930          IR_COL_NUM_R(len_ir_idx)       = BD_COLUMN_NUM(bd_idx);
02931          IR_IDX_L(mult_idx)             = extent_idx;
02932          IR_FLD_L(mult_idx)             = extent_fld;
02933          IR_LINE_NUM_L(mult_idx)        = BD_LINE_NUM(bd_idx);
02934          IR_COL_NUM_L(mult_idx)         = BD_COLUMN_NUM(bd_idx);
02935          len_ir_idx                     = mult_idx;
02936       }
02937       else if (dim == 1) {
02938 
02939          /* Last dimension is the only dimension, so length = xtent */
02940 
02941          BD_LEN_FLD(bd_idx)     = extent_fld;
02942          BD_LEN_IDX(bd_idx)     = extent_idx;
02943          length_entry_idx       = extent_entry_idx;
02944          stride_entry_idx       = merge_entry_lists(stride_entry_idx,
02945                                                     extent_entry_idx);
02946 
02947          extent_entry_idx       = NULL_IDX;  /* Now length holds list */
02948 
02949          if (length_entry_idx != NULL_IDX) {  /* Alt entries - need tmp = 0 */
02950             gen_tmp_eq_zero_ir(extent_idx);
02951          }
02952       }
02953 
02954       /* Last dimension */
02955 
02956       else if (BD_ARRAY_SIZE(bd_idx) == Symbolic_Constant_Size) {
02957          IR_IDX_R(len_ir_idx)           = extent_idx;
02958          IR_FLD_R(len_ir_idx)           = extent_fld;
02959          IR_LINE_NUM_R(len_ir_idx)      = BD_LINE_NUM(bd_idx);
02960          IR_COL_NUM_R(len_ir_idx)       = BD_COLUMN_NUM(bd_idx);
02961 
02962          BD_LEN_FLD(bd_idx)     = AT_Tbl_Idx;
02963          BD_LEN_IDX(bd_idx)     = gen_compiler_tmp(BD_LINE_NUM(bd_idx),
02964                                                    BD_COLUMN_NUM(bd_idx),
02965                                                    Priv, TRUE);
02966          ATD_TYPE_IDX(BD_LEN_IDX(bd_idx))       = CG_INTEGER_DEFAULT_TYPE;
02967          ATD_FLD(BD_LEN_IDX(bd_idx))            = IR_FLD_R(BD_LEN_IDX(bd_idx));
02968          ATD_TMP_IDX(BD_LEN_IDX(bd_idx))        = IR_IDX_R(BD_LEN_IDX(bd_idx));
02969 
02970          ATD_SYMBOLIC_CONSTANT(BD_LEN_IDX(bd_idx))      = TRUE;
02971       }
02972       else {
02973          IR_IDX_R(len_ir_idx)           = extent_idx;
02974          IR_FLD_R(len_ir_idx)           = extent_fld;
02975          IR_LINE_NUM_R(len_ir_idx)      = BD_LINE_NUM(bd_idx);
02976          IR_COL_NUM_R(len_ir_idx)       = BD_COLUMN_NUM(bd_idx);
02977          OPND_FLD(opnd)                 = IR_FLD_R(BD_LEN_IDX(bd_idx));
02978          OPND_IDX(opnd)                 = IR_IDX_R(BD_LEN_IDX(bd_idx));
02979          OPND_LINE_NUM(opnd)            = BD_LINE_NUM(bd_idx);
02980          OPND_COL_NUM(opnd)             = BD_COLUMN_NUM(bd_idx);
02981 
02982          sh_idx                         = ntr_sh_tbl();
02983          SH_STMT_TYPE(sh_idx)           = Automatic_Base_Size_Stmt;
02984          SH_COMPILER_GEN(sh_idx)        = TRUE;
02985          SH_P2_SKIP_ME(sh_idx)          = TRUE;
02986          SH_GLB_LINE(sh_idx)            = stmt_start_line;
02987          SH_COL_NUM(sh_idx)             = stmt_start_col;
02988 
02989          /* expr_semantics needs curr_stmt_sh_idx set to something valid.  */
02990          /* It does not need SH_IR_IDX(curr_stmt_sh_idx) set to something. */
02991 
02992          expr_desc.rank = 0;
02993          xref_state     = CIF_No_Usage_Rec;
02994 
02995          if (!expr_semantics(&opnd, &expr_desc)) {
02996 
02997 # if defined(_CHECK_MAX_MEMORY)
02998 
02999             if (!target_t3e) {
03000                AT_DCL_ERR(attr_idx)     = TRUE;
03001             }
03002 # endif
03003          }
03004 
03005          if (OPND_FLD(opnd) == CN_Tbl_Idx) {
03006             BD_LEN_FLD(bd_idx)  = CN_Tbl_Idx;
03007             BD_LEN_IDX(bd_idx)  = OPND_IDX(opnd);
03008             FREE_SH_NODE(sh_idx);
03009          }
03010          else {
03011 
03012             if (!is_interface) {
03013 
03014                if (extent_entry_idx != NULL_IDX) {
03015                   stride_entry_idx = merge_entry_lists(stride_entry_idx,
03016                                                        extent_entry_idx);
03017                   length_entry_idx = merge_entry_lists(length_entry_idx,
03018                                                        extent_entry_idx);
03019                }
03020             }
03021 
03022             length_idx = ntr_bnds_sh_tmp_list(&opnd,
03023                                               length_entry_idx,
03024                                               (is_interface) ? NULL_IDX:sh_idx,
03025                                               TRUE,
03026                                               SA_INTEGER_DEFAULT_TYPE);
03027             BD_LEN_IDX(bd_idx) = length_idx;
03028             BD_LEN_FLD(bd_idx) = AT_Tbl_Idx;
03029          }
03030       }
03031    }
03032 
03033    /* After the dimensions are processed, stride_entry_idx contains a list   */
03034    /* of all bad entry points, for the array - including all extents and     */
03035    /* type information.  Stride is calculated from the (previous dimension's */
03036    /* extent) * (previous dimension's stride).  A stride_entry_idx is made   */
03037    /* for the last dimension, even though actual stride isn't calculated for */
03038    /* this dimension.                                                        */
03039 
03040    if (stride_entry_idx != NULL_IDX) {
03041       entry_count       = SCP_ALT_ENTRY_CNT(curr_scp_idx) + 1;
03042 
03043       if (length_entry_idx != NULL_IDX &&
03044           entry_count == AL_ENTRY_COUNT(length_entry_idx))  {
03045 
03046          /* Error if problem with lower and/or upper bounds coming in    */
03047          /* different entry points.  Bounds for this array declaration   */
03048          /* cannot be calculated at any entry point, because dummy args  */
03049          /* used in the expression do not enter at all the same points.  */
03050 
03051          PRINTMSG(AT_DEF_LINE(attr_idx), 660, Error,
03052                   AT_DEF_COLUMN(attr_idx),
03053                   AT_OBJ_NAME_PTR(attr_idx));
03054          AT_DCL_ERR(attr_idx)   = TRUE;
03055       }
03056       else if (entry_count == AL_ENTRY_COUNT(stride_entry_idx))  {
03057 
03058          /* If the length is okay, but there's a problem with the        */
03059          /* stride, that means that it's a character and a bound         */
03060          /* forming the char length, doesn't enter the same as all       */
03061          /* the dimension bounds.  Bounds for this array declaration     */
03062          /* cannot be calculated at any entry point, because dummy args  */
03063          /* used in the expression de not enter at all the same points.  */
03064 
03065          PRINTMSG(AT_DEF_LINE(attr_idx), 661, Error,
03066                   AT_DEF_COLUMN(attr_idx),
03067                   AT_OBJ_NAME_PTR(attr_idx));
03068          AT_DCL_ERR(attr_idx)   = TRUE;
03069       }
03070       else if (entry_list != NULL_IDX) {
03071          stride_entry_count = merge_entry_list_count(stride_entry_idx,
03072                                                      entry_list);
03073 
03074          if (entry_count == stride_entry_count) {
03075 
03076             /* This array and its bound variables do not enter at the  */
03077             /* same entry point.                                       */
03078 
03079             PRINTMSG(AT_DEF_LINE(attr_idx), 662, Error,
03080                      AT_DEF_COLUMN(attr_idx),
03081                      AT_OBJ_NAME_PTR(attr_idx));
03082             AT_DCL_ERR(attr_idx)        = TRUE;
03083          }
03084       }
03085    }
03086 
03087 NEXT:
03088 
03089    /* Every array must have the following semantic checks.  So even if the   */
03090    /* bounds for the array are already resolved, it still must get these     */
03091    /* checks.                                                                */
03092 
03093 # if 0
03094    if (BD_ARRAY_CLASS(bd_idx) != Assumed_Size) {
03095       PRINTMSG(AT_DEF_LINE(attr_idx), 1576, Error,
03096                AT_DEF_COLUMN(attr_idx));
03097       AT_DCL_ERR(attr_idx)        = TRUE;
03098    }
03099 # endif
03100 
03101 EXIT:
03102 
03103    if (stride_entry_idx != NULL_IDX) {
03104       free_attr_list(stride_entry_idx);
03105    }
03106 
03107    if (length_entry_idx != NULL_IDX) {
03108       free_attr_list(length_entry_idx);
03109    }
03110 
03111    if (ATD_CLASS(attr_idx) == Function_Result) {
03112       ATP_NO_ENTRY_LIST(ATD_FUNC_IDX(attr_idx)) = entry_list;
03113    }
03114    else {
03115       ATD_NO_ENTRY_LIST(attr_idx)               = entry_list;
03116    }
03117 
03118    TRACE (Func_Exit, "pe_array_dim_resolution", NULL);
03119 
03120    return;
03121 
03122 }  /* pe_array_dim_resolution */
03123 
03124 /******************************************************************************\
03125 |*                                                                            *|
03126 |* Description:                                                               *|
03127 |*      It does semantic checking and tries to fold the bound.  If the bound  *|
03128 |*      folds to a constant, ATD_FLD(tmp) is set to CN_Tbl_Idx and            *|
03129 |*      ATD_TMP_IDX(tmp) is set to the constant table index of the constant.  *|
03130 |*      AT_REFERENCED(tmp) = Not_Referenced, so the temp doesn't get added to *|
03131 |*      the IR stream at entry point processing.  array_dim_resolution and    *|
03132 |*      char_len_resolution then check ATD_FLD(tmp).  If it is CN_Tbl_Idx     *|
03133 |*      the item resolves to a constant bounded item.  If it doesn't resolve  *|
03134 |*      to a folded item, ATD_FLD(tmp) = SH_Tbl_Idx and ATD_TMP_IDX(tmp)      *|
03135 |*      is the index to the first statement header for the bound.  A bound    *|
03136 |*      may have more than one statement, after going through expr_semantics. *|
03137 |*      The statements are all linked together.                               *|
03138 |*                                                                            *|
03139 |*      Assumption:  All non-interface blocks have a valid curr_stmt_sh_idx   *|
03140 |*      It is set to the Entry SH when decl_semantics is called.  All bounds  *|
03141 |*      IR SH's go in following this and curr_stmt_sh_idx is advanced.        *|
03142 |*                                                                            *|
03143 |* Input parameters:                                                          *|
03144 |*      NONE                                                                  *|
03145 |*                                                                            *|
03146 |* Output parameters:                                                         *|
03147 |*      NONE                                                                  *|
03148 |*                                                                            *|
03149 |* Returns:                                                                   *|
03150 |*      NONE                                                                  *|
03151 |*                                                                            *|
03152 \******************************************************************************/
03153 static  void    bound_resolution(int    attr_idx)
03154 
03155 {
03156    boolean              ansi;
03157    msg_lvl_type         save_msg_level;
03158    int                  start_sh_idx;
03159 
03160 
03161    TRACE (Func_Entry, "bound_resolution", NULL);
03162 
03163    if (ATD_CLASS(attr_idx) == Constant) {
03164 
03165       /* Intentionally blank */
03166    }
03167    else if (AT_REFERENCED(attr_idx) == Not_Referenced) {
03168 
03169       /* These are tmps that are only here, because CIF generation is on. */
03170       /* These are shared tmps and normally would not have been kept      */
03171       /* around.  Call expr_semantics with them, so the proper CIF calls  */
03172       /* can be generated and then free the IR.                           */
03173 
03174       xref_state                        = CIF_Symbol_Reference;
03175       cif_tmp_so_no_msg                 = TRUE;
03176       no_func_expansion                 = TRUE;
03177       save_msg_level                    = cmd_line_flags.msg_lvl_suppressed;
03178       ansi                              = on_off_flags.issue_ansi_messages;
03179       cmd_line_flags.msg_lvl_suppressed = Error_Lvl;
03180 
03181       bound_semantics(attr_idx, FALSE);          /* Don't get stmts */
03182 
03183       if (ATD_CLASS(attr_idx) != Constant) {
03184          ATD_TMP_IDX(attr_idx)          = NULL_IDX;
03185          ATD_FLD(attr_idx)              = NO_Tbl_Idx;
03186       }
03187 
03188       AT_REFERENCED(attr_idx)           = Not_Referenced;
03189       AT_DEFINED(attr_idx)              = FALSE;
03190       no_func_expansion                 = FALSE;
03191       cmd_line_flags.msg_lvl_suppressed = save_msg_level;
03192       on_off_flags.issue_ansi_messages  = ansi;
03193       cif_tmp_so_no_msg                 = FALSE;
03194    }
03195    else {
03196 
03197       if (ATD_TMP_SEMANTICS_DONE(attr_idx)) {
03198 
03199          /* These are tmps that were folded during pass1, because they were */
03200          /* referenced in a bound for a parameterized character or array.   */
03201          /* These did not fold to a constant, so they must be sent thru     */
03202          /* expression semantics, so that everything gets folded and/or     */
03203          /* expanded correctly.   Stop message issuing, because it has been */
03204          /* done once already.                                              */
03205 
03206          save_msg_level                    = cmd_line_flags.msg_lvl_suppressed;
03207          ansi                              = on_off_flags.issue_ansi_messages;
03208          cmd_line_flags.msg_lvl_suppressed = Error_Lvl;
03209 
03210          /* If this isn't an interface block - generate stmts after */
03211          /* curr_stmt_sh_idx for this bound.                        */
03212 
03213          start_sh_idx = bound_semantics(attr_idx,
03214                                         !SCP_IS_INTERFACE(curr_scp_idx));
03215 
03216          cmd_line_flags.msg_lvl_suppressed = save_msg_level;
03217          on_off_flags.issue_ansi_messages  = ansi;
03218       }
03219       else {
03220 
03221          /* If this isn't an interface block - generate stmts after */
03222          /* curr_stmt_sh_idx for this bound.                        */
03223 
03224          xref_state   = CIF_Symbol_Reference;
03225          start_sh_idx = bound_semantics(attr_idx,
03226                                         !SCP_IS_INTERFACE(curr_scp_idx));
03227       }
03228 
03229       if (ATD_CLASS(attr_idx) != Constant &&
03230           !ATD_SYMBOLIC_CONSTANT(attr_idx) &&
03231           SCP_ENTRY_IDX(curr_scp_idx) != NULL_IDX) {
03232 
03233          /* Enter the code at each alternate entry.  We do generate tmp = 0   */
03234          /* code, because the bounds can be referenced for whole subscript    */
03235          /* and whole substring references.  These are all bounds tmps for    */
03236          /* arrays (upper or lower) or character length. We do not have to    */
03237          /* worry about OPTIONAL dummy arguments here because it is illegal   */
03238          /* to use an OPTIONAL dummy argument in a bound expression.  Start   */
03239          /* the copy at SH_PREV_IDX(start_sh_idx) and end at curr_stmt_sh_idx.*/
03240 
03241          insert_sh_after_entries(attr_idx, 
03242                                  SH_PREV_IDX(start_sh_idx),
03243                                  curr_stmt_sh_idx,
03244                                  TRUE,
03245                                  TRUE);     /* Advance ATP_FIRST_SH_IDX */
03246       }
03247    }
03248 
03249    TRACE (Func_Exit, "bound_resolution", NULL);
03250 
03251    return;
03252    
03253 }  /* bound_resolution */
03254 
03255 /******************************************************************************\
03256 |*                                                                            *|
03257 |* Description:                                                               *|
03258 |*      This routine calls expr_semantics for a declaration bound and         *|
03259 |*      handles semantic checking.  If the bounds folds to a constant,        *|
03260 |*      ATD_FLD(tmp) is set to CN_Tbl_Idx and ATD_TMP_IDX(tmp) is set to the  *|
03261 |*      constant table index of the constant.  AT_REFERENCED(tmp) =           *|
03262 |*      Not_Referenced, so the temp does not get used in other phases of      *|
03263 |*      compilation.                                                          *|
03264 |*      Also, if non-constant a cvrt opr will be added if necessary to set    *|
03265 |*      the type to the correct size/addresss/offset type.                    *|
03266 |*                                                                            *|
03267 |* Input parameters:                                                          *|
03268 |*      attr_idx            - Index of bound tmp to call expr_semantics for.  *|
03269 |*      insert_in_SH_stream - TRUE if IR should be inserted in IR stream.     *|
03270 |*                                                                            *|
03271 |* Output parameters:                                                         *|
03272 |*      NONE                                                                  *|
03273 |*                                                                            *|
03274 |* Returns:                                                                   *|
03275 |*      bound_sh_idx        - Index of statement header for bound.            *|
03276 |*                                                                            *|
03277 \******************************************************************************/
03278 int     bound_semantics(int             attr_idx,
03279                         boolean         insert_in_SH_stream)
03280 
03281 {
03282    int                  bound_sh_idx;
03283    expr_arg_type        expr_desc;
03284    int                  list_idx;
03285    fld_type             new_fld;
03286    int                  new_ir_idx;
03287    opnd_type            opnd;
03288    int                  save_sh_idx;
03289    int                  type_idx;
03290 
03291 
03292    TRACE (Func_Entry, "bound_semantics", NULL);
03293 
03294    if (AT_OBJ_CLASS(attr_idx) != Data_Obj ||
03295        ATD_CLASS(attr_idx) != Compiler_Tmp) {
03296       return(NULL_IDX);
03297    }
03298 
03299    expr_mode                            = Specification_Expr;
03300    expr_desc.rank                       = 0;
03301    ATD_TMP_SEMANTICS_DONE(attr_idx)     = TRUE;
03302 
03303    /* Save a copy of the IR.  If this does not fold to a constant, we need    */
03304    /* to keep the IR before it goes through expr_semantics.  This ir is used, */
03305    /* if this bound is part of a description of an interface for a function.  */
03306    /* (Interface block, internal function or module procedure function.)      */
03307 
03308    gen_opnd(&opnd, ATD_TMP_IDX(attr_idx), (fld_type) ATD_FLD(attr_idx),
03309             stmt_start_line, stmt_start_col);
03310    copy_subtree(&opnd, &opnd);
03311    new_ir_idx = OPND_IDX(opnd);
03312    new_fld = OPND_FLD(opnd);
03313 
03314    /* Create a stmt header to link the IR to.  This way if expr_semantics  */
03315    /* generates some statements, they get attached where they need to be.  */
03316 
03317    bound_sh_idx                         = ntr_sh_tbl();
03318    SH_IR_IDX(bound_sh_idx)              = ATD_TMP_IDX(attr_idx);
03319    SH_STMT_TYPE(bound_sh_idx)           = Automatic_Base_Size_Stmt;
03320    SH_COMPILER_GEN(bound_sh_idx)        = TRUE;
03321    SH_P2_SKIP_ME(bound_sh_idx)          = TRUE;
03322    SH_GLB_LINE(bound_sh_idx)            = stmt_start_line;
03323    SH_COL_NUM(bound_sh_idx)             = stmt_start_col;
03324    save_sh_idx                          = curr_stmt_sh_idx;
03325    curr_stmt_sh_idx                     = bound_sh_idx;
03326 
03327 # if defined(GENERATE_WHIRL)
03328 
03329    if (ATD_TMP_HAS_CVRT_OPR(attr_idx)) {
03330 
03331       /* Need to do expr_semantics without the cvrt to do error checking */
03332 
03333       COPY_OPND(opnd, IR_OPND_L(IR_IDX_R(ATD_TMP_IDX(attr_idx))));
03334    }
03335    else {
03336       COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(attr_idx)));
03337    }
03338 # else
03339 
03340    COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(attr_idx)));
03341 # endif
03342 
03343    if (!expr_semantics(&opnd, &expr_desc)) {
03344 
03345       /* There were problems with this expression.  Replace it with a   */
03346       /* constant one.  Constant bound processing will free the IR.     */
03347 
03348       OPND_IDX(opnd)            = CN_INTEGER_ONE_IDX;
03349       OPND_FLD(opnd)            = CN_Tbl_Idx;
03350       OPND_LINE_NUM(opnd)       = stmt_start_line;
03351       OPND_COL_NUM(opnd)        = stmt_start_col;
03352 
03353       /* This is a newly created list after each call to expr_semantics.*/
03354       /* It contains dargs found in this specification expression.      */
03355 
03356       free_attr_list(SCP_TMP_LIST(curr_scp_idx));
03357       SCP_TMP_LIST(curr_scp_idx) = NULL_IDX;  /* Clear in case of list */
03358    }
03359    else if (expr_desc.rank != 0) {
03360       PRINTMSG(AT_DEF_LINE(attr_idx), 907, Error,
03361               AT_DEF_COLUMN(attr_idx));
03362       AT_DCL_ERR(attr_idx) = TRUE;
03363    }
03364    else if (expr_desc.type != Integer) {
03365 
03366       /* The tmp must be integer.  This must be its first pass thru and no */
03367       /* no previous error messages must have been issued about this tmp.  */
03368 
03369       if (expr_desc.linear_type == Typeless_4 ||
03370           expr_desc.linear_type == Typeless_8) { 
03371          PRINTMSG(AT_DEF_LINE(attr_idx), 221, Ansi, 
03372                   AT_DEF_COLUMN(attr_idx));
03373       }
03374       else if (expr_desc.linear_type == Short_Typeless_Const) {
03375          PRINTMSG(AT_DEF_LINE(attr_idx), 221, Ansi,
03376                   AT_DEF_COLUMN(attr_idx));
03377          OPND_IDX(opnd) = cast_typeless_constant(OPND_IDX(opnd),
03378                                                  INTEGER_DEFAULT_TYPE,
03379                                                  OPND_LINE_NUM(opnd),
03380                                                  OPND_COL_NUM(opnd));
03381          expr_desc.type_idx    = INTEGER_DEFAULT_TYPE;
03382          expr_desc.type        = Integer;
03383          expr_desc.linear_type = INTEGER_DEFAULT_TYPE;
03384 
03385       }
03386       else {
03387 
03388          if (!AT_DCL_ERR(attr_idx)) {
03389 
03390             if (expr_desc.linear_type == Long_Typeless) { 
03391 
03392                /* hollerith too long */
03393 
03394                PRINTMSG(AT_DEF_LINE(attr_idx), 1133, Error, 
03395                         AT_DEF_COLUMN(attr_idx));
03396             }
03397             else {  /* bad type */
03398                PRINTMSG(AT_DEF_LINE(attr_idx), 488, Error,
03399                         AT_DEF_COLUMN(attr_idx),
03400                         get_basic_type_str(expr_desc.type_idx));
03401             }
03402             AT_DCL_ERR(attr_idx) = TRUE;
03403          }
03404 
03405          /* There were problems with this expression.  Replace with a one. */
03406 
03407          OPND_IDX(opnd)         = CN_INTEGER_ONE_IDX;
03408          OPND_FLD(opnd)         = CN_Tbl_Idx;
03409          OPND_LINE_NUM(opnd)    = AT_DEF_LINE(attr_idx);
03410          OPND_COL_NUM(opnd)     = AT_DEF_COLUMN(attr_idx);
03411 
03412          /* This is a newly created list after each call to expr_semantics.*/
03413          /* It contains dargs found in this specification expression.      */
03414 
03415          free_attr_list(SCP_TMP_LIST(curr_scp_idx));
03416          SCP_TMP_LIST(curr_scp_idx) = NULL_IDX;  /* Clear in case of list */
03417       }
03418    }
03419    else if (expr_desc.has_symbolic) {
03420 
03421       /* This expression contains a reference to a symbolic constant.     */
03422 
03423       /* Determine if this is a symbolic constant expression or not.      */
03424       /* If this is a symbolic constant expression, ATD_SYMBOLIC_CONSTANT */
03425       /* will be set on the compiler temp.                                */
03426 
03427       ATD_SYMBOLIC_CONSTANT(attr_idx) = expr_is_symbolic_constant(&opnd);
03428    }
03429 
03430 # if defined(GENERATE_WHIRL)
03431 
03432    else if (ATD_TMP_HAS_CVRT_OPR(attr_idx)) {
03433       COPY_OPND(IR_OPND_L(IR_IDX_R(ATD_TMP_IDX(attr_idx))), opnd);
03434 
03435       if (OPND_FLD(opnd) == CN_Tbl_Idx) {
03436          COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(attr_idx)));
03437          expr_semantics(&opnd, &expr_desc);
03438       }
03439       else {
03440          COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(attr_idx)));
03441       }
03442    }
03443 # endif
03444 
03445    if (OPND_FLD(opnd) == CN_Tbl_Idx) {
03446 
03447       /* Folded to a constant.   NOTE:  Cannot free IR, because IR can  */
03448       /* be shared and you could free IR that is used in other places.  */
03449 
03450       /* Change the tmp to a constant, so it gets folded whenever it is  */
03451       /* referenced.  AT_DEFINED is left clear.  It is set on declared   */
03452       /* parameters, so that parameter constants can be differentiated   */
03453       /* from compiler tmp constants.  CIF wants all parameters, whether */
03454       /* they are referenced or not, so AT_DEFINED is used to tell the   */
03455       /* difference between them.                                        */
03456 
03457       CLEAR_VARIANT_ATTR_INFO(attr_idx, Data_Obj);
03458 
03459       ATD_CLASS(attr_idx)       = Constant;
03460       AT_TYPED(attr_idx)        = TRUE;
03461       ATD_TYPE_IDX(attr_idx)    = CN_TYPE_IDX(OPND_IDX(opnd));
03462       AT_REFERENCED(attr_idx)   = Not_Referenced;  /* Temp not used      */
03463       AT_DEFINED(attr_idx)      = FALSE;           /* Temp not defined   */
03464       ATD_CONST_IDX(attr_idx)   = OPND_IDX(opnd);
03465       ATD_FLD(attr_idx)         = CN_Tbl_Idx;
03466       curr_stmt_sh_idx          = save_sh_idx;
03467       FREE_SH_NODE(bound_sh_idx);
03468       bound_sh_idx              = NULL_IDX;
03469    }
03470    else if (ATD_SYMBOLIC_CONSTANT(attr_idx)) {
03471 
03472       /* This is a symbolic constant expression.  A temp holds it. */
03473 
03474       curr_stmt_sh_idx          = save_sh_idx;
03475       FREE_SH_NODE(bound_sh_idx);
03476       bound_sh_idx              = NULL_IDX;
03477       ATD_FLD(attr_idx)         = OPND_FLD(opnd);
03478       ATD_TMP_IDX(attr_idx)     = OPND_IDX(opnd);
03479    }
03480    else { 
03481 
03482       if (OPND_FLD(opnd) == AT_Tbl_Idx) {
03483 
03484          if (AT_IS_DARG(OPND_IDX(opnd))) {
03485 
03486             /* CIF wants to know if a bound is made up of just one dummy */
03487             /* argument.  NO expression.  AT_CIF_USE_IN_BND is set when  */
03488             /* this is found for a dummy argument.                       */
03489 
03490             AT_CIF_USE_IN_BND(OPND_IDX(opnd))   = TRUE;
03491          }
03492 
03493          /* Let PDGCS know if a temp is set to one var.  Give them       */
03494          /* the link between them.  Use ATD_DEFINING_ATTR_IDX.           */
03495 
03496          ATD_DEFINING_ATTR_IDX(attr_idx)        = OPND_IDX(opnd);
03497       }
03498 
03499       /* Make sure this is set to the correct addressing/offset type. */
03500 
03501       type_idx  = check_type_for_size_address(&opnd);
03502 
03503       COPY_OPND(IR_OPND_R(ATD_TMP_IDX(attr_idx)), opnd);
03504 
03505       /* Reset type if necessary on the Asg_Opr and bound tmp. */
03506 
03507       ATD_TYPE_IDX(attr_idx)                    = type_idx;
03508       IR_TYPE_IDX(ATD_TMP_IDX(attr_idx))        = type_idx;
03509 
03510       /* SCP_TMP_LIST contains a list of dummy args referenced in this */
03511       /* expression.  If there are NO alternate entries, SCP_TMP_LIST  */
03512       /* will always be NULL.                                          */
03513 
03514       if (SCP_TMP_LIST(curr_scp_idx) != NULL_IDX) {
03515 
03516          /* Convert the bounds list of dargs that are used in this      */
03517          /* expression, but do not come in at every entry point, into   */
03518          /* a list of entry points where this expression cannot be.     */
03519 
03520          list_idx = SCP_TMP_LIST(curr_scp_idx);
03521 
03522          while (list_idx != NULL_IDX) {
03523             ATD_NO_ENTRY_LIST(attr_idx) = 
03524                 merge_entry_lists(ATD_NO_ENTRY_LIST(attr_idx),
03525                             (AT_OBJ_CLASS(AL_ATTR_IDX(list_idx)) == Data_Obj) ?
03526                                     ATD_NO_ENTRY_LIST(AL_ATTR_IDX(list_idx)) :
03527                                     ATP_NO_ENTRY_LIST(AL_ATTR_IDX(list_idx)));
03528             list_idx = AL_NEXT_IDX(list_idx);
03529          }
03530 
03531          free_attr_list(SCP_TMP_LIST(curr_scp_idx));
03532          SCP_TMP_LIST(curr_scp_idx) = NULL_IDX;
03533       }
03534 
03535       if (!insert_in_SH_stream) {
03536 
03537          /* Statement headers are not wanted.  Leave this as IR.  These tmps  */
03538          /* become place holders.  If this is a parameter bound, this is an   */
03539          /* error situation.  If this is an interface block, all these tmps   */
03540          /* are just place holders.  NOTE:  Cannot free IR, because IR can    */
03541          /* be shared and you could free IR that is used in other places.     */
03542 
03543          AT_REFERENCED(attr_idx)        = Not_Referenced;
03544          AT_DEFINED(attr_idx)           = FALSE;
03545 
03546          while (curr_stmt_sh_idx != NULL_IDX) {
03547             bound_sh_idx        = curr_stmt_sh_idx;
03548             curr_stmt_sh_idx    = SH_PREV_IDX(curr_stmt_sh_idx);
03549             FREE_SH_NODE(bound_sh_idx);
03550          }
03551          bound_sh_idx                   = NULL_IDX;
03552          curr_stmt_sh_idx               = save_sh_idx;
03553       }
03554       else {
03555 
03556          /* can't assume that the SH_NEXT_IDX(save_sh_idx) is null */
03557 
03558          if (SH_NEXT_IDX(save_sh_idx) != NULL_IDX) {
03559             while (SH_NEXT_IDX(bound_sh_idx) != NULL_IDX) {
03560                bound_sh_idx = SH_NEXT_IDX(bound_sh_idx);
03561             }
03562             SH_NEXT_IDX(bound_sh_idx)      = SH_NEXT_IDX(save_sh_idx);
03563             if (SH_NEXT_IDX(bound_sh_idx)) {
03564                SH_PREV_IDX(SH_NEXT_IDX(bound_sh_idx)) = bound_sh_idx;
03565             }
03566          }
03567 
03568          while (SH_PREV_IDX(bound_sh_idx) != NULL_IDX) {
03569             bound_sh_idx = SH_PREV_IDX(bound_sh_idx);
03570          }
03571 
03572          SH_PREV_IDX(bound_sh_idx)      = save_sh_idx;
03573          SH_NEXT_IDX(save_sh_idx)       = bound_sh_idx;
03574          AT_DEFINED(attr_idx)           = TRUE;
03575          AT_REFERENCED(attr_idx)        = Referenced;
03576       }
03577 
03578       /* Save the unexpanded IR, so it can be expanded later if this  */
03579       /* is part of a function that may be called.                    */
03580 
03581       /* Adjust type if necessary in the save unexpanded IR. */
03582 
03583       OPND_FLD(opnd)                    = new_fld;
03584       OPND_IDX(opnd)                    = new_ir_idx;
03585       OPND_LINE_NUM(opnd)               = AT_DEF_LINE(attr_idx);
03586       OPND_COL_NUM(opnd)                = AT_DEF_COLUMN(attr_idx);
03587 
03588       type_idx  = check_type_for_size_address(&opnd);
03589 
03590       ATD_FLD(attr_idx)                 = OPND_FLD(opnd);
03591       ATD_TMP_IDX(attr_idx)             = OPND_IDX(opnd);
03592    }
03593 
03594    expr_mode = Regular_Expr;
03595 
03596    TRACE (Func_Exit, "bound_semantics", NULL);
03597 
03598    return(bound_sh_idx);
03599 
03600 }  /* bound_semantics */
03601 
03602 /******************************************************************************\
03603 |*                                                                            *|
03604 |* Description:                                                               *|
03605 |*      This routine resolves the character length to a temp.                 *|
03606 |*      NOTE:  This does not handle component character lengths.  They are    *|
03607 |*      done in parse_cpnt_dcl_stmt.                                          *|
03608 |*                                                                            *|
03609 |* Input parameters:                                                          *|
03610 |*      attr_idx -> Index to attribute for array.                             *|
03611 |*                                                                            *|
03612 |* Output parameters:                                                         *|
03613 |*      NONE                                                                  *|
03614 |*                                                                            *|
03615 |* Returns:                                                                   *|
03616 |*      NONE                                                                  *|
03617 |*                                                                            *|
03618 \******************************************************************************/
03619 void    char_len_resolution(int         attr_idx,
03620                             boolean     must_be_const_array)
03621 
03622 {
03623    int          column;
03624    int          entry_count;
03625    int          ir_idx;
03626    boolean      is_interface;
03627    int          len_entry_count;
03628    int          len_idx;
03629    int          line;
03630    int          list_idx;
03631    int          max_idx;
03632    int          new_len_idx;
03633    opnd_type    opnd;
03634    int          sh_idx;
03635    int          tmp_attr_idx;
03636    int          t_idx;
03637    int          type_idx;
03638    int          zero_idx;
03639 
03640 
03641    TRACE (Func_Entry, "char_len_resolution", NULL);
03642 
03643    is_interface = SCP_IS_INTERFACE(curr_scp_idx);
03644    type_idx     = ATD_TYPE_IDX(attr_idx);
03645 
03646    if (TYP_CHAR_CLASS(type_idx) == Unknown_Char) {
03647 
03648       if (AT_OBJ_CLASS(TYP_IDX(type_idx)) == Data_Obj && 
03649           ATD_CLASS(TYP_IDX(type_idx)) == Constant) {
03650          TYP_IDX(type_idx)              = ATD_CONST_IDX(TYP_IDX(type_idx));
03651          TYP_FLD(type_idx)              = CN_Tbl_Idx;
03652          TYP_CHAR_CLASS(type_idx)       = Const_Len_Char;
03653       }
03654       else if (AT_OBJ_CLASS(TYP_IDX(type_idx)) == Data_Obj && 
03655                ATD_SYMBOLIC_CONSTANT(TYP_IDX(type_idx))) {
03656 
03657          PRINTMSG(AT_DEF_LINE(attr_idx), 1211, Error, 
03658                   AT_DEF_COLUMN(attr_idx),
03659                   AT_OBJ_NAME_PTR(attr_idx));
03660          AT_DCL_ERR(attr_idx)   = TRUE;
03661          ATD_TYPE_IDX(attr_idx) = CHARACTER_DEFAULT_TYPE;
03662       }
03663       else {
03664          TYP_CHAR_CLASS(type_idx)       = Var_Len_Char;
03665          TYP_ORIG_LEN_IDX(type_idx)     = TYP_IDX(type_idx);
03666       }
03667    }
03668 
03669    if (TYP_CHAR_CLASS(type_idx) == Var_Len_Char) {
03670 
03671       /* This is called from PARAMETER processing.  This must be a const  */
03672       /* length array.  If it is not, do not process now.  It will happen */
03673       /* at decl_sematics time.  PARAMETER processing will issue error.   */
03674 
03675       if (must_be_const_array) {
03676          goto EXIT;
03677       }
03678 
03679       if (fnd_semantic_err(Obj_Var_Len_Ch,
03680                            AT_DEF_LINE(attr_idx),
03681                            AT_DEF_COLUMN(attr_idx),
03682                            attr_idx,
03683                            TRUE)) {
03684          ATD_TYPE_IDX(attr_idx) = CHARACTER_DEFAULT_TYPE;
03685       }
03686       else if (ATD_CLASS(attr_idx) == Function_Result && 
03687                !ATP_EXPL_ITRFC(ATD_FUNC_IDX(attr_idx))) {
03688          PRINTMSG(AT_DEF_LINE(attr_idx), 916, Error, 
03689                   AT_DEF_COLUMN(attr_idx),
03690                   AT_OBJ_NAME_PTR(ATD_FUNC_IDX(attr_idx)));
03691          AT_DCL_ERR(attr_idx)   = TRUE;
03692          ATD_TYPE_IDX(attr_idx) = CHARACTER_DEFAULT_TYPE;
03693       }
03694       else {
03695 
03696          if (!TYP_RESOLVED(type_idx)) {
03697 
03698             /* generate max(0,length) - then switch length to new tmp */
03699 
03700             NTR_IR_TBL(max_idx);
03701             IR_OPR(max_idx)             = Max_Opr;
03702             IR_LINE_NUM(max_idx)        = AT_DEF_LINE(attr_idx);
03703             IR_COL_NUM(max_idx)         = AT_DEF_COLUMN(attr_idx);
03704             IR_LIST_CNT_L(max_idx)      = 2;
03705 
03706             NTR_IR_LIST_TBL(list_idx);
03707             IR_FLD_L(max_idx)           = IL_Tbl_Idx;
03708             IR_IDX_L(max_idx)           = list_idx;
03709 
03710             OPND_FLD(opnd)              = TYP_FLD(type_idx);
03711             OPND_IDX(opnd)              = TYP_IDX(type_idx);
03712             OPND_LINE_NUM(opnd)         = AT_DEF_LINE(attr_idx);
03713             OPND_COL_NUM(opnd)          = AT_DEF_COLUMN(attr_idx);
03714             t_idx                       = check_type_for_size_address(&opnd);
03715 
03716             COPY_OPND(IL_OPND(list_idx), opnd);
03717 
03718             IR_TYPE_IDX(max_idx)        = t_idx;
03719 
03720             NTR_IR_LIST_TBL(zero_idx);
03721             IL_NEXT_LIST_IDX(list_idx)  = zero_idx;
03722             IL_PREV_LIST_IDX(zero_idx)  = list_idx;
03723             IL_FLD(zero_idx)            = CN_Tbl_Idx;
03724             IL_IDX(zero_idx)            = CN_INTEGER_ZERO_IDX;
03725             IL_LINE_NUM(zero_idx)       = AT_DEF_LINE(attr_idx);
03726             IL_COL_NUM(zero_idx)        = AT_DEF_COLUMN(attr_idx);
03727 
03728             if (!is_interface) {
03729                sh_idx                   = ntr_sh_tbl();
03730                SH_STMT_TYPE(sh_idx)     = Automatic_Base_Size_Stmt;
03731                SH_P2_SKIP_ME(sh_idx)    = TRUE;
03732                SH_COMPILER_GEN(sh_idx)  = TRUE;
03733                SH_GLB_LINE(sh_idx)      = stmt_start_line;
03734                SH_COL_NUM(sh_idx)       = stmt_start_col;
03735             }
03736 
03737             OPND_FLD(opnd)      = IR_Tbl_Idx;
03738             OPND_IDX(opnd)      = max_idx;
03739             OPND_LINE_NUM(opnd) = stmt_start_line;
03740             OPND_COL_NUM(opnd)  = stmt_start_col;
03741             new_len_idx         = ntr_bnds_sh_tmp_list(
03742                                            &opnd,
03743                                            ATD_NO_ENTRY_LIST(TYP_IDX(type_idx)),
03744                                            (is_interface) ? NULL_IDX : sh_idx,
03745                                            TRUE,
03746                                            t_idx);
03747 
03748             TYP_FLD(type_idx)   = AT_Tbl_Idx;
03749             TYP_IDX(type_idx)   = new_len_idx;
03750 
03751             if (ATD_NO_ENTRY_LIST(new_len_idx) != NULL_IDX) {
03752                entry_count = SCP_ALT_ENTRY_CNT(curr_scp_idx) + 1;
03753 
03754                if (entry_count==AL_ENTRY_COUNT(ATD_NO_ENTRY_LIST(new_len_idx))){
03755 
03756                   /* The length for this character cannot be calculated at    */
03757                   /* any entry point, because dargs used in the expression do */
03758                   /* not enter at all the same points.                        */
03759 
03760                   PRINTMSG(AT_DEF_LINE(attr_idx), 659, Error,
03761                            AT_DEF_COLUMN(attr_idx), 
03762                            AT_OBJ_NAME_PTR(attr_idx));
03763                   AT_DCL_ERR(attr_idx)  = TRUE;
03764                }
03765                else if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) {
03766                   len_entry_count =
03767                       merge_entry_list_count(ATD_NO_ENTRY_LIST(new_len_idx),
03768                             ((ATD_CLASS(attr_idx) == Function_Result) ?
03769                                  ATP_NO_ENTRY_LIST(ATD_FUNC_IDX(attr_idx)) :
03770                                  ATD_NO_ENTRY_LIST(attr_idx)));
03771    
03772                   if (entry_count == len_entry_count) {
03773                      PRINTMSG(AT_DEF_LINE(attr_idx), 662, Error,
03774                               AT_DEF_COLUMN(attr_idx), 
03775                               AT_OBJ_NAME_PTR(attr_idx));
03776                      AT_DCL_ERR(attr_idx) = TRUE;
03777                   }
03778                   else if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
03779                            ATD_CLASS(attr_idx) == Variable) {
03780                      PRINTMSG(AT_DEF_LINE(attr_idx), 1046, Caution,
03781                               AT_DEF_COLUMN(attr_idx),
03782                               AT_OBJ_NAME_PTR(attr_idx));
03783                   }
03784                }
03785             }
03786          }
03787 
03788          if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
03789 
03790             if (ATD_CLASS(attr_idx) != Function_Result &&
03791                 ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Function &&