p_dcls.c

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/p_dcls.c    5.10    10/08/99 08:26:21\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 "p_globals.m"
00050 # include "debug.m"
00051 
00052 # include "globals.h"
00053 # include "tokens.h"
00054 # include "sytb.h"
00055 # include "p_globals.h"
00056 # include "p_dcls.h"
00057 
00058 
00059 /*****************************************************************\
00060 |* function prototypes of static functions declared in this file *|
00061 \*****************************************************************/
00062 
00063 static  void    issue_attr_blk_err(char *);
00064 static  void    issue_attr_err(attr_type, long);
00065 static  void    merge_parameter(boolean, int, int, int, opnd_type *,
00066                                 expr_arg_type *, int, int);
00067 static  void    merge_type(int, int, int, int);
00068 static  void    parse_cpnt_dcl_stmt(void);
00069 static  long    parse_attr_spec(int *, boolean *);
00070 static  boolean parse_data_imp_do(opnd_type *);
00071 static  void    parse_derived_type_stmt(void);
00072 static  boolean parse_initializer(int);
00073 static  void    parse_only_spec(int);
00074 static  void    retype_attr(int);
00075 
00076 
00077 /******************************************************************************\
00078 |*                                                                            *|
00079 |* Description:                                                               *|
00080 |*      COMMON [/[common-block-name]/] common-block-object-list [[,]          *|
00081 |*             /[common-block-name]/ common-block-object-list]...             *|
00082 |*      common-block-object IS variable-name [(explicit-shape-spec-list)]     *|
00083 |*                                                                            *|
00084 |* Input parameters:                                                          *|
00085 |*      NONE                                                                  *|
00086 |*                                                                            *|
00087 |* Output parameters:                                                         *|
00088 |*      NONE                                                                  *|
00089 |*                                                                            *|
00090 |* Returns:                                                                   *|
00091 |*      NONE                                                                  *|
00092 |*                                                                            *|
00093 \******************************************************************************/
00094 
00095 void parse_common_stmt (void)
00096 
00097 {
00098    int          array_idx;
00099    int          attr_idx;
00100    boolean      blank_common    = FALSE;
00101    boolean      blk_err         = FALSE;
00102    int          column;
00103    int          line;
00104    int          name_idx;
00105    int          new_sb_idx;
00106    int          last_attr_idx;
00107    boolean      parse_err       = FALSE;
00108    token_type   save_token;
00109    int          sb_idx          = NULL_IDX;
00110 
00111 
00112    TRACE (Func_Entry, "parse_common_stmt", NULL);
00113 
00114    if (stmt_type == Task_Common_Stmt) {
00115 
00116       if (!matched_specific_token(Tok_Kwd_Common, Tok_Class_Keyword)) {
00117          parse_err_flush(Find_Comma_Slash, "COMMON");
00118          blk_err = TRUE;
00119       }
00120 
00121 # if !defined(_TASK_COMMON_EXTENSION)
00122       PRINTMSG(stmt_start_line, 1118, Error, stmt_start_col);
00123 # else
00124 
00125       /* ANSI message, Task common statements are extensions */
00126 
00127       PRINTMSG(stmt_start_line, 46, Ansi, stmt_start_col);
00128 # endif
00129    }
00130 
00131    if ((STMT_OUT_OF_ORDER(curr_stmt_category, stmt_type) ||
00132         STMT_CANT_BE_IN_BLK(stmt_type, CURR_BLK)) && iss_blk_stk_err()) {
00133       blk_err = TRUE;           /* Block error issued */
00134    }
00135    else {
00136       curr_stmt_category = Declaration_Stmt_Cat;
00137    }
00138 
00139    do {
00140       if (sb_idx == NULL_IDX || LA_CH_VALUE == SLASH) {
00141          parse_err      = blk_err;      /* New common block list */
00142          blank_common   = FALSE;
00143          last_attr_idx  = NULL_IDX;
00144 
00145          if (LA_CH_VALUE != SLASH) {
00146             CREATE_ID(TOKEN_ID(token), 
00147                       BLANK_COMMON_NAME,
00148                       BLANK_COMMON_NAME_LEN);
00149             TOKEN_LEN(token)            = BLANK_COMMON_NAME_LEN;
00150             TOKEN_VALUE(token)          = Tok_Id;
00151             TOKEN_LINE(token)           = LA_CH_LINE; 
00152             TOKEN_COLUMN(token)         = LA_CH_COLUMN;
00153             blank_common                = TRUE;
00154 
00155             if (stmt_type == Task_Common_Stmt) {       /* Task can't be blank */
00156                PRINTMSG(LA_CH_LINE, 109, Error, LA_CH_COLUMN);
00157             }
00158          }
00159          else {
00160             NEXT_LA_CH;
00161 
00162             if (LA_CH_VALUE == SLASH) {
00163                CREATE_ID(TOKEN_ID(token), 
00164                          BLANK_COMMON_NAME,
00165                          BLANK_COMMON_NAME_LEN);
00166                TOKEN_LEN(token)         = BLANK_COMMON_NAME_LEN;
00167                TOKEN_VALUE(token)       = Tok_Id;
00168                TOKEN_LINE(token)        = LA_CH_LINE; 
00169                TOKEN_COLUMN(token)      = LA_CH_COLUMN;
00170                blank_common             = TRUE;
00171 
00172                if (stmt_type == Task_Common_Stmt) {   /* Task can't be blank */
00173                   PRINTMSG(LA_CH_LINE, 109, Error, LA_CH_COLUMN);
00174                }
00175                NEXT_LA_CH;
00176             }
00177             else if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
00178 
00179                if (LA_CH_VALUE == SLASH) {
00180                   NEXT_LA_CH;
00181                }
00182                else {
00183                   parse_err     = TRUE;
00184                   save_token    = token;  /* parse_err_flush destroys token */
00185 
00186                   if (parse_err_flush(Find_Comma_Slash, "/") &&
00187                       LA_CH_VALUE == SLASH) {
00188                       NEXT_LA_CH;
00189                   }
00190                   token         = save_token;  /* Restore common block name */
00191                }
00192             }
00193             else {
00194                line     = LA_CH_LINE; 
00195                column   = LA_CH_COLUMN;
00196 
00197                if (parse_err_flush(Find_Comma_Slash, "common-block-name or /")&&
00198                    LA_CH_VALUE == SLASH) {
00199                   NEXT_LA_CH;
00200                }
00201 
00202                CREATE_ID(TOKEN_ID(token), "//", 2);
00203                TOKEN_LEN(token)         = 2;
00204                TOKEN_VALUE(token)       = Tok_Id;
00205                TOKEN_LINE(token)        = line;
00206                TOKEN_COLUMN(token)      = column;
00207                parse_err                = TRUE;
00208 
00209             }
00210          }
00211 
00212          sb_idx = srch_stor_blk_tbl(TOKEN_STR(token),
00213                                     TOKEN_LEN(token),
00214                                     curr_scp_idx);
00215 
00216          if (sb_idx == NULL_IDX) {
00217             sb_idx                      = ntr_stor_blk_tbl(TOKEN_STR(token),
00218                                                            TOKEN_LEN(token),
00219                                                            TOKEN_LINE(token),
00220                                                            TOKEN_COLUMN(token),
00221                                                            Common);
00222             SB_BLANK_COMMON(sb_idx)             = blank_common;
00223             SB_COMMON_NEEDS_OFFSET(sb_idx)      = TRUE;
00224          }
00225          else if (SB_USE_ASSOCIATED(sb_idx) || SB_HOST_ASSOCIATED(sb_idx)) {
00226 
00227             /* Common block has been use or host associated into this scope. */
00228             /* Make an entry for this block and hide the associated block    */
00229             /* storage_blk_resolution will resolve the blocks.               */
00230 
00231             new_sb_idx = ntr_stor_blk_tbl(TOKEN_STR(token),
00232                                           TOKEN_LEN(token),
00233                                           TOKEN_LINE(token),
00234                                           TOKEN_COLUMN(token),
00235                                           Common);
00236             SB_BLANK_COMMON(new_sb_idx)         = blank_common;
00237             SB_COMMON_NEEDS_OFFSET(new_sb_idx)  = TRUE;
00238             SB_HIDDEN(sb_idx)                   = TRUE;
00239             SB_DEF_MULT_SCPS(sb_idx)            = TRUE;
00240             SB_MERGED_BLK_IDX(sb_idx)           = new_sb_idx;
00241             sb_idx                              = new_sb_idx;
00242          }
00243          else if (SB_FIRST_ATTR_IDX(sb_idx) != NULL_IDX) {
00244             last_attr_idx       = SB_FIRST_ATTR_IDX(sb_idx);
00245 
00246             while (ATD_NEXT_MEMBER_IDX(last_attr_idx) != NULL_IDX) {
00247                last_attr_idx    = ATD_NEXT_MEMBER_IDX(last_attr_idx);
00248             }
00249          }
00250 # if 0
00251          /* we want to allow THREADPRIVATE before the common stmt. */
00252          /* I'm leaving this in for now. BHJ                       */
00253 
00254          else if (SB_BLK_TYPE(sb_idx) == Threadprivate && !SB_DCL_ERR(sb_idx)) {
00255 
00256             /* Must be declared completely before THREADPRIVATE */
00257 
00258             PRINTMSG(TOKEN_LINE(token), 1479, Error, TOKEN_COLUMN(token),
00259                      SB_NAME_PTR(sb_idx));
00260          }
00261 # endif
00262 
00263          if ((cif_flags & XREF_RECS) != 0) {
00264             cif_sb_usage_rec(sb_idx,
00265                              TOKEN_LINE(token),
00266                              TOKEN_COLUMN(token),
00267                              CIF_Symbol_Declaration);
00268          }
00269 
00270          if (stmt_type == Task_Common_Stmt) {
00271 
00272             /* A common block may be specified, multiple times.  If any       */
00273             /* specifications are task common, then they all are.             */
00274 
00275             SB_BLK_TYPE(sb_idx)         = Task_Common;
00276             SB_RUNTIME_INIT(sb_idx)     = FALSE;
00277             SB_IS_COMMON(sb_idx)        = TRUE;
00278          }
00279 
00280          if (parse_err) {
00281             SB_DCL_ERR(sb_idx)  = TRUE;
00282          }
00283 
00284          if (LA_CH_CLASS == Ch_Class_Letter) {
00285             continue;           /* Get first object in common list */
00286          }
00287          else {
00288             /* There must be a common object name following.  If LA_CH is EOS */
00289             /* this will just fall out of the while.  If it's slash, it will  */
00290             /* pick up another common block name.  And a comma is usually     */
00291             /* expected.                                                      */
00292 
00293             if (!parse_err) {
00294                parse_err_flush(Find_Comma_Slash, "common-block-object");
00295                parse_err        = TRUE;
00296             }
00297             SB_DCL_ERR(sb_idx)  = TRUE;
00298          }
00299       }
00300       else if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
00301          line           = TOKEN_LINE(token);
00302          column         = TOKEN_COLUMN(token);
00303          attr_idx       = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token),
00304                                        &name_idx);
00305 
00306          if (attr_idx == NULL_IDX) {
00307             attr_idx                    = ntr_sym_tbl(&token, name_idx);
00308             LN_DEF_LOC(name_idx)        = TRUE;
00309             AT_DCL_ERR(attr_idx)        = parse_err;
00310             AT_OBJ_CLASS(attr_idx)      = Data_Obj; 
00311             ATD_CLASS(attr_idx)         = Variable;
00312             ATD_IN_COMMON(attr_idx)     = TRUE;
00313             ATD_STOR_BLK_IDX(attr_idx)  = sb_idx;
00314             SET_IMPL_TYPE(attr_idx);
00315          }
00316          else if (!fnd_semantic_err(Obj_Common_Obj,line,column,attr_idx,TRUE)) {
00317 
00318             if (AT_REFERENCED(attr_idx) == Char_Rslt_Bound_Ref) {
00319                AT_ATTR_LINK(attr_idx)   = NULL_IDX;
00320                LN_DEF_LOC(name_idx)     = TRUE;
00321             }
00322 
00323             if (AT_ATTR_LINK(attr_idx) != NULL_IDX) {
00324                AT_ATTR_LINK(attr_idx)           = NULL_IDX;
00325                AT_HOST_ASSOCIATED(attr_idx)     = FALSE;
00326                LN_DEF_LOC(name_idx)             = TRUE;
00327                SET_IMPL_TYPE(attr_idx);
00328             }
00329 
00330             ATD_IN_COMMON(attr_idx)     = TRUE;
00331             ATD_STOR_BLK_IDX(attr_idx)  = sb_idx;
00332             ATD_CLASS(attr_idx)         = Variable;
00333             AT_DCL_ERR(attr_idx)        = parse_err || AT_DCL_ERR(attr_idx);
00334 
00335             if (ATD_AUXILIARY(attr_idx)) {
00336                SB_AUXILIARY(sb_idx)     = TRUE;
00337             }
00338          }
00339 
00340          if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
00341             ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE;
00342          }
00343 
00344          if ((cif_flags & XREF_RECS) != 0) {
00345             cif_usage_rec(attr_idx, 
00346                           AT_Tbl_Idx,
00347                           line,
00348                           column,
00349                           CIF_Symbol_Declaration);
00350          }
00351 
00352          if (!AT_DCL_ERR(attr_idx)) {
00353 
00354             if (last_attr_idx == NULL_IDX) {
00355                SB_FIRST_ATTR_IDX(sb_idx)                = attr_idx;
00356             }
00357             else {
00358                ATD_NEXT_MEMBER_IDX(last_attr_idx)       = attr_idx;
00359             }
00360 
00361             last_attr_idx                               = attr_idx;
00362          }
00363          else {
00364             SB_DCL_ERR(sb_idx)          = TRUE;
00365          }
00366 
00367          if (LA_CH_VALUE == LPAREN) {  /* Array specifier follows */
00368             array_idx = parse_array_spec(attr_idx);
00369 
00370             if (BD_ARRAY_CLASS(array_idx) == Deferred_Shape) {
00371 
00372                /* Arrays specified on a COMMON list must be    */
00373                /* explicit-shape-specs.  Common can have a     */
00374                /* deferred-shape-spec specified, but it has to */
00375                /* be on a seperate DIMENSION statement.        */
00376 
00377                PRINTMSG(BD_LINE_NUM(array_idx), 372, Error, 
00378                         BD_COLUMN_NUM(array_idx));
00379                AT_DCL_ERR(attr_idx)     = TRUE;
00380             }
00381             merge_dimension(attr_idx, line, column, array_idx);
00382          }
00383 
00384 # ifdef COARRAY_FORTRAN
00385          if (LA_CH_VALUE == LBRKT &&
00386              cmd_line_flags.co_array_fortran) {
00387             ATD_PE_ARRAY_IDX(attr_idx) = parse_pe_array_spec(attr_idx);
00388          }
00389 # endif
00390       }
00391       else { /* Problem with common block name.  Default to blank common name */
00392          line   = LA_CH_LINE;
00393          column = LA_CH_COLUMN;
00394 
00395          parse_err_flush(Find_Comma_Slash, "common-block-object or /");
00396 
00397          if (sb_idx == NULL_IDX) {
00398             CREATE_ID(TOKEN_ID(token), "//", 2);
00399             TOKEN_LEN(token)            = 2;
00400             TOKEN_VALUE(token)          = Tok_Id;
00401             TOKEN_LINE(token)           = line; 
00402             TOKEN_COLUMN(token)         = column;
00403             parse_err                   = TRUE;
00404 
00405             sb_idx = srch_stor_blk_tbl(TOKEN_STR(token),
00406                                        TOKEN_LEN(token),
00407                                        curr_scp_idx);
00408 
00409             if (sb_idx == NULL_IDX) {
00410                sb_idx = ntr_stor_blk_tbl(TOKEN_STR(token),
00411                                          TOKEN_LEN(token),
00412                                          TOKEN_LINE(token),
00413                                          TOKEN_COLUMN(token),
00414                                          Common);
00415                SB_COMMON_NEEDS_OFFSET(sb_idx)   = TRUE;
00416             }
00417             else if (SB_USE_ASSOCIATED(sb_idx) || SB_HOST_ASSOCIATED(sb_idx)) {
00418 
00419                /* Common block has been use or host associated into this scp. */
00420                /* Make an entry for this block and hide the associated block. */
00421                /* storage_blk_resolution will resolve the blocks.             */
00422 
00423                new_sb_idx = ntr_stor_blk_tbl(TOKEN_STR(token),
00424                                              TOKEN_LEN(token),
00425                                              TOKEN_LINE(token),
00426                                              TOKEN_COLUMN(token),
00427                                              Common);
00428                SB_COMMON_NEEDS_OFFSET(new_sb_idx)       = TRUE;
00429                SB_HIDDEN(sb_idx)                        = TRUE;
00430                SB_DEF_MULT_SCPS(sb_idx)                 = TRUE;
00431                sb_idx                                   = new_sb_idx;
00432             }
00433          }
00434          SB_DCL_ERR(sb_idx)             = TRUE;
00435       }
00436 
00437       if (LA_CH_VALUE != COMMA && LA_CH_VALUE != SLASH && LA_CH_VALUE != EOS) {
00438          parse_err_flush(Find_Comma_Slash, "/ or, or " EOS_STR);
00439          parse_err      = TRUE;
00440       }
00441 
00442       if (LA_CH_VALUE == COMMA) {
00443          NEXT_LA_CH;
00444 
00445          if (LA_CH_VALUE == EOS) {      /* ,, case */
00446             parse_err_flush(Find_None, "common-block-object or /");
00447          }
00448       }
00449    }
00450    while (LA_CH_VALUE != EOS);
00451 
00452    NEXT_LA_CH;
00453 
00454    TRACE (Func_Exit, "parse_common_stmt", NULL);
00455 
00456    return;
00457 
00458 }  /* parse_common_stmt */
00459 
00460 
00461 /******************************************************************************\
00462 |*                                                                            *|
00463 |* Description:                                                               *|
00464 |*      BNF is CONTAINS                                                       *|
00465 |*                                                                            *|
00466 |* Input parameters:                                                          *|
00467 |*      NONE                                                                  *|
00468 |*                                                                            *|
00469 |* Output parameters:                                                         *|
00470 |*      NONE                                                                  *|
00471 |*                                                                            *|
00472 |* Returns:                                                                   *|
00473 |*      NONE                                                                  *|
00474 |*                                                                            *|
00475 \******************************************************************************/
00476 
00477 void parse_contains_stmt (void)
00478 
00479 {
00480    boolean      have_blk_err    = FALSE;
00481 
00482 
00483    TRACE (Func_Entry, "parse_contains_stmt", NULL);
00484 
00485    do_cmic_blk_checks();
00486 
00487    if (LA_CH_VALUE == EOS) {
00488 
00489       if (STMT_CANT_BE_IN_BLK(Contains_Stmt, CURR_BLK) && iss_blk_stk_err()) {
00490          have_blk_err   = TRUE;
00491       }
00492       else {
00493          curr_stmt_category     = Sub_Func_Stmt_Cat;
00494       }
00495 
00496       if (CURR_BLK != Interface_Blk) {
00497  
00498          /* If this were an Interface_Blk, this is an error situation.  */
00499          /* We don't want to push the contains blk, because it creates  */
00500          /* havoc with interface block compressing.                     */
00501 
00502          PUSH_BLK_STK(Contains_Blk);
00503          CURR_BLK_NO_EXEC = TRUE;
00504          CURR_BLK_ERR     = have_blk_err;
00505 
00506          if (cif_flags) {
00507             cif_module_proc_start_line    = LA_CH_LINE;
00508             cif_internal_proc_start_line  = LA_CH_LINE;
00509             BLK_CIF_SCOPE_ID(blk_stk_idx) = BLK_CIF_SCOPE_ID(blk_stk_idx - 1);
00510          }
00511       }
00512       else {
00513          CURR_BLK_ERR     = TRUE;
00514       }
00515    }
00516    else {
00517       parse_err_flush(Find_EOS, EOS_STR);
00518    }
00519 
00520    NEXT_LA_CH;                  /* Skip EOS */
00521 
00522    TRACE (Func_Exit, "parse_contains_stmt", NULL);
00523 
00524    return;
00525 
00526 }  /* parse_contains_stmt */
00527 
00528 /******************************************************************************\
00529 |*                                                                            *|
00530 |* Description:                                                               *|
00531 |*   BNF   component-def-stmt                                                 *|
00532 |*           type-spec [[,component-attr-spec-list]::] component-decl-list    *|
00533 |*   Notes     - This routine is only entered if in a derived type statement. *|
00534 |*                                                                            *|
00535 |* Input parameters:                                                          *|
00536 |*      NONE                                                                  *|
00537 |*                                                                            *|
00538 |* Output parameters:                                                         *|
00539 |*      NONE                                                                  *|
00540 |*                                                                            *|
00541 |* Returns:                                                                   *|
00542 |*      NONE                                                                  *|
00543 |*                                                                            *|
00544 \******************************************************************************/
00545 
00546 static void parse_cpnt_dcl_stmt()
00547 
00548 {
00549    int          alignment;
00550    int          array_column;
00551    int          array_line;
00552    int          attr_idx;
00553    int          bd_idx;
00554    int          dt_idx;
00555    boolean      found_colon;
00556    boolean      GT_encountered;
00557    boolean      have_attr_list          = FALSE;
00558    int          idx;
00559    int          init_ir_idx;
00560    opnd_type    init_opnd;
00561    boolean      junk;
00562    int          np_idx;
00563    int          old_bd_idx;
00564    int          save_column;
00565    int          save_line;
00566    int          sn_idx;
00567    int          stmt_number;
00568    boolean      type_err;
00569    int          type_idx;
00570 
00571 
00572    TRACE (Func_Entry, "parse_cpnt_dcl_stmt", NULL);
00573 
00574    found_colon                  = FALSE;
00575    colon_recovery               = TRUE;            /* Can recover at ::  */
00576    type_err                     = !parse_type_spec(TRUE);  /* Get KIND   */
00577    type_idx                     = ATD_TYPE_IDX(AT_WORK_IDX);
00578    AT_DCL_ERR(AT_WORK_IDX)      = type_err;
00579    stmt_number                  = statement_number;
00580 
00581    if (TYP_TYPE(type_idx) == Character) { /* Must be const len char */
00582       ATT_CHAR_CPNT(CURR_BLK_NAME) = TRUE;
00583 
00584       if (fold_relationals(TYP_IDX(type_idx), CN_INTEGER_ZERO_IDX, Lt_Opr)) {
00585 
00586          /* Zero Length character */
00587 
00588          CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
00589          TYP_TYPE(TYP_WORK_IDX)         = Character;
00590          TYP_LINEAR(TYP_WORK_IDX)       = CHARACTER_DEFAULT_TYPE;
00591          TYP_DESC(TYP_WORK_IDX)         = TYP_DESC(type_idx);
00592          TYP_DCL_VALUE(TYP_WORK_IDX)    = TYP_DCL_VALUE(type_idx);
00593          TYP_CHAR_CLASS(TYP_WORK_IDX)   = Const_Len_Char;
00594          TYP_FLD(TYP_WORK_IDX)          = CN_Tbl_Idx;
00595          TYP_IDX(TYP_WORK_IDX)          = CN_INTEGER_ZERO_IDX;
00596          type_idx                       = ntr_type_tbl();
00597          ATD_TYPE_IDX(AT_WORK_IDX)      = type_idx;
00598       }
00599    }
00600    else if (TYP_TYPE(type_idx) != Structure) {
00601       ATT_NUMERIC_CPNT(CURR_BLK_NAME) = TRUE;
00602    }
00603 
00604    if (TYP_DESC(type_idx) == Default_Typed ||
00605        TYP_LINEAR(type_idx) == INTEGER_DEFAULT_TYPE ||
00606        TYP_LINEAR(type_idx) == LOGICAL_DEFAULT_TYPE ||
00607        TYP_LINEAR(type_idx) == REAL_DEFAULT_TYPE ||
00608        TYP_LINEAR(type_idx) == DOUBLE_DEFAULT_TYPE ||
00609        TYP_LINEAR(type_idx) == COMPLEX_DEFAULT_TYPE) {
00610 
00611        /* Intentionally blank */
00612    }
00613    else {
00614       ATT_NON_DEFAULT_CPNT(CURR_BLK_NAME) = TRUE;
00615    } 
00616 
00617    /* Assume all type errors issued - la_ch is comma, ::, or id */
00618 
00619    while (LA_CH_VALUE == COMMA) {
00620       NEXT_LA_CH;                       /* Skip Comma */
00621 
00622       if (MATCHED_TOKEN_CLASS(Tok_Class_Keyword)) {
00623 
00624          switch (TOKEN_VALUE(token)) {
00625 
00626             case Tok_Kwd_Pointer:
00627 
00628                if (ATD_POINTER(AT_WORK_IDX)) { /* duplicate error msg */
00629                   PRINTMSG (TOKEN_LINE(token), 273, Error, 
00630                             TOKEN_COLUMN(token), "POINTER");
00631                }
00632 
00633                have_attr_list                   = TRUE;
00634                ATD_POINTER(AT_WORK_IDX)         = TRUE;
00635 /* keep array form,don't generate dope vector */
00636 /*               ATD_IM_A_DOPE(AT_WORK_IDX)     = TRUE; */
00637                ATT_POINTER_CPNT(CURR_BLK_NAME)  = TRUE;
00638               ATT_NUMERIC_CPNT(CURR_BLK_NAME)   = TRUE;
00639 
00640               break; 
00641 
00642             case Tok_Kwd_Dimension:
00643 
00644                if (ATD_ARRAY_IDX(AT_WORK_IDX) != NULL_IDX) { /* Duplicate err */
00645                   PRINTMSG (TOKEN_LINE(token), 273, Error, 
00646                             TOKEN_COLUMN(token), "DIMENSION");
00647                }
00648 
00649                have_attr_list   = TRUE;
00650 
00651                if (LA_CH_VALUE == LPAREN) {
00652                   array_line                    = TOKEN_LINE(token);
00653                   array_column                  = TOKEN_COLUMN(token);
00654                   idx                           = parse_array_spec(AT_WORK_IDX);
00655                   ATD_ARRAY_IDX(AT_WORK_IDX)    = idx;
00656                }
00657 # ifdef COARRAY_FORTRAN
00658                else if (!cmd_line_flags.co_array_fortran ||
00659                         LA_CH_VALUE != LBRKT) 
00660 # else
00661                else 
00662 # endif
00663                           {    /* DIMENSION attribute must have an array spec */
00664 
00665                   parse_err_flush(Find_Comma, "("); 
00666                   AT_DCL_ERR(AT_WORK_IDX) = TRUE;
00667                }
00668 
00669 # ifdef COARRAY_FORTRAN
00670                if (LA_CH_VALUE == LBRKT && cmd_line_flags.co_array_fortran) {
00671                   ATD_PE_ARRAY_IDX(AT_WORK_IDX) = 
00672                                            parse_pe_array_spec(AT_WORK_IDX);
00673                }
00674 # endif
00675 
00676                break;
00677                           
00678             default: /* POINTER and/or DIMENSION must follow the first comma */
00679                PRINTMSG(TOKEN_LINE(token), 197, Error, TOKEN_COLUMN(token),
00680                         "POINTER or DIMENSION", TOKEN_STR(token));
00681                parse_err_flush(Find_Comma, NULL);
00682                AT_DCL_ERR(AT_WORK_IDX) = TRUE;
00683                break;
00684 
00685          }   /* switch */
00686       }
00687       else {
00688          parse_err_flush(Find_Comma, "POINTER or DIMENSION");
00689       }
00690    }  /* end while */
00691 
00692    found_colon = matched_specific_token(Tok_Punct_Colon_Colon, Tok_Class_Punct);
00693 
00694    if (!found_colon && have_attr_list) {
00695       PRINTMSG (LA_CH_LINE, 187, Error, LA_CH_COLUMN);
00696    }
00697 
00698    colon_recovery = FALSE;                                         /* Past :: */
00699 
00700    if (TYP_TYPE(type_idx) == Structure) {
00701 
00702       if (!ATD_POINTER(AT_WORK_IDX)) {
00703          dt_idx = TYP_IDX(type_idx);
00704 
00705          if (CURR_BLK_NAME == dt_idx) {        /* Points to itself */
00706             PRINTMSG(TOKEN_LINE(token), 33, Error, TOKEN_COLUMN(token));
00707             ATT_NUMERIC_CPNT(CURR_BLK_NAME)     = TRUE;
00708             AT_DCL_ERR(AT_WORK_IDX)             = TRUE;
00709             AT_DCL_ERR(CURR_BLK_NAME)           = TRUE;
00710          }
00711          else if (!AT_DEFINED(dt_idx)) {
00712             ATT_NUMERIC_CPNT(CURR_BLK_NAME)     = TRUE;
00713 
00714             if (!AT_DCL_ERR(AT_WORK_IDX)) {
00715                AT_DCL_ERR(AT_WORK_IDX)          = TRUE;
00716 
00717                /* Must have components declared before they are used. */
00718 
00719                if (!AT_DCL_ERR(dt_idx)) {
00720                   issue_undefined_type_msg(dt_idx, 
00721                                            TOKEN_LINE(token),
00722                                            TOKEN_COLUMN(token));
00723                }
00724             }
00725          }
00726          else {  /* This type must be defined by this point */
00727             ATT_CHAR_CPNT(CURR_BLK_NAME)        |= ATT_CHAR_CPNT(dt_idx);
00728             ATT_NUMERIC_CPNT(CURR_BLK_NAME)     |= ATT_NUMERIC_CPNT(dt_idx);
00729             ATT_POINTER_CPNT(CURR_BLK_NAME)     |= ATT_POINTER_CPNT(dt_idx);
00730             ATT_NON_DEFAULT_CPNT(CURR_BLK_NAME) |= ATT_NON_DEFAULT_CPNT(dt_idx);
00731             ATT_DEFAULT_INITIALIZED(CURR_BLK_NAME) |= 
00732                                                 ATT_DEFAULT_INITIALIZED(dt_idx);
00733          }
00734       }
00735    }
00736 
00737    alignment = WORD_ALIGN;
00738 
00739    if (ATD_POINTER(AT_WORK_IDX)) {
00740 
00741       if (cmd_line_flags.s_pointer8) {
00742          alignment = Align_64;
00743       }
00744       else {
00745          alignment = WORD_ALIGN;
00746       }
00747    }
00748    else if (TYP_TYPE(type_idx) == Structure) {
00749          alignment = ATT_ALIGNMENT(TYP_IDX(type_idx));
00750    }
00751    else if (TYP_TYPE(type_idx) == Character) {
00752 
00753 # if defined(_CHAR_IS_ALIGN_8)
00754       alignment = Align_8;
00755 # else
00756       alignment = Align_Bit;
00757 # endif
00758    }
00759 
00760 # if defined(_ALIGN_REAL16_TO_16_BYTES)
00761 
00762    else if (TYP_LINEAR(type_idx) == Complex_16 ||
00763             TYP_LINEAR(type_idx) == Real_16) {
00764       alignment = Align_128;
00765    }
00766 # endif
00767 
00768 # if defined(_TARGET_PACK_HALF_WORD_TYPES)
00769 
00770    else if (dump_flags.pack_half_word && 
00771             PACK_HALF_WORD_TEST_CONDITION(type_idx)) {
00772       alignment = Align_32;
00773    }
00774 # endif
00775 
00776 # if defined(_HOST32) 
00777  
00778    else if (DALIGN_TEST_CONDITION(type_idx)) {
00779       alignment = Align_64;
00780    }
00781 # endif
00782 
00783 # if defined(_INTEGER_1_AND_2)
00784 
00785    else if (on_off_flags.integer_1_and_2 &&
00786             PACK_8_BIT_TEST_CONDITION(type_idx)) {
00787       alignment = Align_8;
00788    }
00789    else if (on_off_flags.integer_1_and_2 &&
00790             PACK_16_BIT_TEST_CONDITION(type_idx)){
00791       alignment = Align_16;
00792    }
00793 
00794 # endif
00795 
00796    if (ATT_ALIGNMENT(CURR_BLK_NAME) < alignment) {
00797       ATT_ALIGNMENT(CURR_BLK_NAME) = alignment;
00798    }
00799 
00800    do {
00801       if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
00802          parse_err_flush(Find_Comma, "component-name");
00803          continue;
00804       }
00805 
00806       sn_idx    = ATT_FIRST_CPNT_IDX(CURR_BLK_NAME);
00807       attr_idx  = srch_linked_sn(TOKEN_STR(token),
00808                                  TOKEN_LEN(token),
00809                                  &sn_idx);
00810 
00811       if (attr_idx == NULL_IDX) {
00812          NTR_SN_TBL(sn_idx);
00813          NTR_NAME_POOL(TOKEN_ID(token).words, TOKEN_LEN(token), np_idx);
00814          NTR_ATTR_TBL(attr_idx);
00815          AT_DEF_LINE(attr_idx)          = TOKEN_LINE(token);
00816          AT_DEF_COLUMN(attr_idx)        = TOKEN_COLUMN(token);
00817          AT_NAME_LEN(attr_idx)          = TOKEN_LEN(token);
00818          AT_NAME_IDX(attr_idx)          = np_idx;
00819          SN_NAME_LEN(sn_idx)            = TOKEN_LEN(token);
00820          SN_NAME_IDX(sn_idx)            = np_idx;
00821          SN_ATTR_IDX(sn_idx)            = attr_idx;
00822 
00823          if (BLK_LAST_CPNT_IDX(blk_stk_idx) == NULL_IDX) {
00824             ATT_FIRST_CPNT_IDX(CURR_BLK_NAME)   = sn_idx;
00825             ATT_NUM_CPNTS(CURR_BLK_NAME)        = 1;
00826          }
00827          else {
00828             ATT_NUM_CPNTS(CURR_BLK_NAME)                       += 1;
00829             SN_SIBLING_LINK(BLK_LAST_CPNT_IDX(blk_stk_idx))     = sn_idx;
00830          }
00831          BLK_LAST_CPNT_IDX(blk_stk_idx) = sn_idx;
00832       }
00833       else {   /* Error - Duplicate component names for this derived type */
00834          PRINTMSG (TOKEN_LINE(token), 188, Error, TOKEN_COLUMN(token),
00835                    AT_OBJ_NAME_PTR(attr_idx));
00836          AT_DCL_ERR(attr_idx)   = TRUE;
00837       }
00838 
00839       /* Mark semantics done, so it doesn't go thru declaration semantics */
00840 
00841       AT_SEMANTICS_DONE(attr_idx)       = TRUE;
00842       ATD_CLASS(attr_idx)               = Struct_Component;
00843       ATD_DERIVED_TYPE_IDX(attr_idx)    = CURR_BLK_NAME;
00844       ATD_ARRAY_IDX(attr_idx)           = ATD_ARRAY_IDX(AT_WORK_IDX);
00845       ATD_PE_ARRAY_IDX(attr_idx)        = ATD_PE_ARRAY_IDX(AT_WORK_IDX);
00846       ATD_POINTER(attr_idx)             = ATD_POINTER(AT_WORK_IDX);
00847 /*      ATD_IM_A_DOPE(attr_idx)         = ATD_IM_A_DOPE(AT_WORK_IDX); */
00848       save_line                         = array_line;
00849       save_column                       = array_column;
00850       AT_TYPED(attr_idx)                = AT_TYPED(AT_WORK_IDX);
00851       AT_DCL_ERR(attr_idx)              = AT_DCL_ERR(AT_WORK_IDX);
00852 
00853       if (type_err) {
00854          SET_IMPL_TYPE(attr_idx);
00855       }
00856       else {
00857          ATD_TYPE_IDX(attr_idx) = type_idx;
00858       }
00859 
00860       if ((cif_flags & XREF_RECS) != 0) {
00861          cif_usage_rec(attr_idx,
00862                        AT_Tbl_Idx,
00863                        TOKEN_LINE(token),
00864                        TOKEN_COLUMN(token),
00865                        CIF_Symbol_Declaration);
00866       }
00867 
00868       if (LA_CH_VALUE == LPAREN) {
00869          save_line                      = TOKEN_LINE(token);
00870          save_column                    = TOKEN_COLUMN(token);
00871          idx                            = parse_array_spec(attr_idx);
00872          ATD_ARRAY_IDX(attr_idx)        = idx;
00873       }
00874 
00875 # ifdef COARRAY_FORTRAN
00876       if (LA_CH_VALUE == LBRKT && cmd_line_flags.co_array_fortran) {
00877          ATD_PE_ARRAY_IDX(attr_idx) = parse_pe_array_spec(attr_idx);
00878       }
00879 # endif
00880 
00881       bd_idx = ATD_ARRAY_IDX(attr_idx);
00882 
00883       if (bd_idx != NULL_IDX) {  /* Array declared */
00884          AT_DCL_ERR(attr_idx) = BD_DCL_ERR(bd_idx) | AT_DCL_ERR(attr_idx);
00885 
00886          if (ATD_POINTER(attr_idx)) {
00887 
00888             if (BD_ARRAY_CLASS(bd_idx) != Deferred_Shape && 
00889                 BD_ARRAY_CLASS(bd_idx) != Deferred_Shape1 ) {
00890                PRINTMSG(save_line, 189, Error, save_column,
00891                         AT_OBJ_NAME_PTR(attr_idx));
00892                AT_DCL_ERR(attr_idx)      = TRUE;
00893             }
00894          }
00895          else if (BD_ARRAY_CLASS(bd_idx) != Explicit_Shape ||
00896                   BD_ARRAY_SIZE(bd_idx) != Constant_Size) {
00897             PRINTMSG(save_line, 190, Error, save_column,
00898                      AT_OBJ_NAME_PTR(attr_idx));
00899             AT_DCL_ERR(attr_idx)        = TRUE;
00900          }
00901       }
00902 
00903       if (LA_CH_VALUE == STAR) {
00904          save_line                      = LA_CH_LINE;
00905          save_column                    = LA_CH_COLUMN;
00906 
00907          /* Pick up character length.  LEN = is not allowed here (FALSE)   */
00908          /* We are not parsing the character* part of the line, so this    */
00909          /* is not the length_selector.  It is the char-length on the name */
00910 
00911          parse_length_selector(attr_idx, FALSE, FALSE);
00912 
00913          TYP_DCL_VALUE(TYP_WORK_IDX)    = TYP_DCL_VALUE(type_idx);
00914          TYP_DESC(TYP_WORK_IDX)         = TYP_DESC(type_idx);
00915 
00916          if (TYP_TYPE(type_idx) != Character) {
00917             PRINTMSG(save_line, 192, Error, save_column);
00918             AT_DCL_ERR(attr_idx)        = TRUE;
00919          }
00920          else if (TYP_CHAR_CLASS(TYP_WORK_IDX) == Const_Len_Char) { 
00921 
00922             if (fold_relationals(TYP_IDX(TYP_WORK_IDX), 
00923                                  CN_INTEGER_ZERO_IDX, 
00924                                  Le_Opr)) {
00925                TYP_IDX(TYP_WORK_IDX)    = CN_INTEGER_ZERO_IDX;
00926             }
00927 
00928             ATD_TYPE_IDX(attr_idx)      = ntr_type_tbl();
00929          }
00930          else if (!AT_DCL_ERR(attr_idx)) {
00931 
00932             /* Must be a constant length char */
00933 
00934             PRINTMSG(save_line, 191, Error, save_column);
00935 
00936             ATD_TYPE_IDX(attr_idx)      = CHARACTER_DEFAULT_TYPE;
00937             AT_DCL_ERR(attr_idx)        = TRUE;
00938          }
00939 
00940          /* Have a different character length than the one specified on the   */
00941          /* CHARACTER component statement.  (ie:  CHARACTER*(2) :: A*(10),B)  */
00942          /* If this is an array, it may need a seperate bounds table entry if */
00943          /* this is a shared array entry.  The stride multiplier is kept in   */
00944          /* the bounds table and is dependent on type.  Therefore, if two     */
00945          /* items have seperate types, they must have seperate bounds entries.*/
00946          /* Ex:  CHARACTER*(2), DIMENSION(100) :: A*(10), B   ! A and B need  */
00947          /*                     seperate bounds entries.                      */
00948          /*      CHARACTER*(2), DIMENSION(100) :: A(20)*(10), B  ! They       */
00949          /*                     already have seperate bounds entries, because */
00950          /*                     they have seperate dimensions.                */
00951          /*      CHARACTER*(2), DIMENSION(100) :: A,B  ! They have the same   */
00952          /*                     type, so they can share a bound entry.        */
00953 
00954          old_bd_idx     = ATD_ARRAY_IDX(attr_idx);
00955 
00956          if (old_bd_idx != NULL_IDX && 
00957              old_bd_idx == ATD_ARRAY_IDX(AT_WORK_IDX) ){ /*  && */
00958 /*             BD_ARRAY_CLASS(old_bd_idx) != Deferred_Shape) { &*/
00959             bd_idx = reserve_array_ntry(BD_RANK(old_bd_idx));
00960             COPY_BD_NTRY(bd_idx, old_bd_idx);
00961             ATD_ARRAY_IDX(attr_idx) = ntr_array_in_bd_tbl(bd_idx);
00962          }
00963       }
00964 
00965       if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
00966          bd_idx = ATD_ARRAY_IDX(attr_idx);
00967       
00968          if (BD_RESOLVED(bd_idx) ) { /* || */
00969 # if 0 /*keep deferred shape array form */
00970              BD_ARRAY_CLASS(bd_idx) == Deferred_Shape ||
00971              BD_ARRAY_CLASS(bd_idx) == Assumed_Shape) {
00972 # endif
00973          }
00974          else {
00975 
00976             /* All the array bounds must be constants.  parse_array_spec */
00977             /* calls parse_int_spec_expr, which guarantees these to be   */
00978             /* constants if CURR_BLK == Derived_Type_Blk.                */
00979 
00980             if (BD_ARRAY_CLASS(bd_idx) == Assumed_Size) {
00981 
00982                /* A component cannot be assumed size.  So copy the array     */
00983                /* entry and make the last dimension have a upper bound equal */
00984                /* to the lower bound. Can't just make the upper bound be 1,  */
00985                /* because it could end up being a zero-sized array.          */
00986 
00987                old_bd_idx       = bd_idx;
00988                bd_idx           = reserve_array_ntry(BD_RANK(old_bd_idx));
00989                COPY_BD_NTRY(bd_idx, old_bd_idx);
00990                BD_UB_IDX(bd_idx, BD_RANK(bd_idx)) = BD_LB_IDX(bd_idx,
00991                                                               BD_RANK(bd_idx));
00992                BD_UB_FLD(bd_idx, BD_RANK(bd_idx)) = BD_LB_FLD(bd_idx,
00993                                                               BD_RANK(bd_idx));
00994                BD_ARRAY_CLASS(bd_idx)   = Explicit_Shape;
00995                BD_DCL_ERR(bd_idx)       = TRUE;
00996                ATD_ARRAY_IDX(attr_idx)  = ntr_array_in_bd_tbl(bd_idx);
00997             }
00998             array_bounds_resolution(attr_idx, &junk);
00999          }
01000       }
01001 
01002       if (ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX) {
01003          PRINTMSG(BD_LINE_NUM(ATD_PE_ARRAY_IDX(attr_idx)), 1579, Error,
01004                   BD_COLUMN_NUM(ATD_PE_ARRAY_IDX(attr_idx)),
01005                   AT_OBJ_NAME_PTR(attr_idx),
01006                   AT_OBJ_NAME_PTR(CURR_BLK_NAME));
01007          AT_DCL_ERR(attr_idx)           = TRUE;
01008          ATD_PE_ARRAY_IDX(attr_idx)     = NULL_IDX;
01009       }
01010 
01011       if (LA_CH_VALUE == EQUAL) {
01012          NEXT_LA_CH;
01013          save_line      = LA_CH_LINE;
01014          save_column    = LA_CH_COLUMN;
01015 
01016          if (LA_CH_VALUE == GT) {
01017             NEXT_LA_CH;
01018             save_line           = LA_CH_LINE;
01019             save_column         = LA_CH_COLUMN;
01020             GT_encountered      = TRUE;
01021          }
01022          else {
01023             GT_encountered      = FALSE;
01024          }
01025   
01026          if (parse_expr(&init_opnd)) {
01027 
01028             if (!found_colon) {
01029                PRINTMSG(save_line, 121, Error, save_column);
01030                AT_DCL_ERR(attr_idx) = TRUE;
01031             }
01032 
01033             NTR_IR_TBL(init_ir_idx);
01034             ATD_CPNT_INIT_IDX(attr_idx)                 = init_ir_idx;
01035             ATD_FLD(attr_idx)                           = IR_Tbl_Idx;
01036             ATT_DEFAULT_INITIALIZED(CURR_BLK_NAME)      = TRUE;
01037 
01038             if (OPND_FLD(init_opnd) == IR_Tbl_Idx &&
01039                 IR_OPR(OPND_IDX(init_opnd)) == Call_Opr &&
01040                 AT_IS_INTRIN(IR_IDX_L(OPND_IDX(init_opnd))) &&
01041                 strcmp(AT_OBJ_NAME_PTR(IR_IDX_L(OPND_IDX(init_opnd))),
01042                                                                  "NULL") == 0) {
01043 
01044                if (IR_IDX_R(OPND_IDX(init_opnd)) != NULL_IDX) {
01045                   PRINTMSG(IR_LINE_NUM(OPND_IDX(init_opnd)), 1573, Error, 
01046                            IR_COL_NUM(OPND_IDX(init_opnd))); 
01047                   AT_DCL_ERR(attr_idx)          = TRUE;
01048                   ATD_CPNT_INIT_IDX(attr_idx)   = NULL_IDX;
01049                   ATD_FLD(attr_idx)             = NO_Tbl_Idx;
01050                }
01051 
01052                IR_OPR(init_ir_idx) = Null_Opr;
01053 
01054                if (!GT_encountered) {
01055                   PRINTMSG(TOKEN_LINE(token), 1562, Error, TOKEN_COLUMN(token));
01056                   AT_DCL_ERR(attr_idx)          = TRUE;
01057                   ATD_CPNT_INIT_IDX(attr_idx)   = NULL_IDX;
01058                   ATD_FLD(attr_idx)             = NO_Tbl_Idx;
01059                }
01060             }
01061             else {
01062                IR_OPR(init_ir_idx) = Init_Opr;
01063 
01064                if (GT_encountered) {
01065                   PRINTMSG(TOKEN_LINE(token), 1562, Error, TOKEN_COLUMN(token));
01066                   AT_DCL_ERR(attr_idx)          = TRUE;
01067                   ATD_CPNT_INIT_IDX(attr_idx)   = NULL_IDX;
01068                   ATD_FLD(attr_idx)             = NO_Tbl_Idx;
01069                }
01070             }
01071 
01072             if (ATD_CPNT_INIT_IDX(attr_idx) != NULL_IDX) {
01073                IR_TYPE_IDX(init_ir_idx)    = TYPELESS_DEFAULT_TYPE;
01074                IR_LINE_NUM(init_ir_idx)    = AT_DEF_LINE(attr_idx);
01075                IR_COL_NUM(init_ir_idx)     = AT_DEF_COLUMN(attr_idx);
01076                IR_LINE_NUM_L(init_ir_idx)  = AT_DEF_LINE(attr_idx);
01077                IR_COL_NUM_L(init_ir_idx)   = AT_DEF_COLUMN(attr_idx);
01078                IR_FLD_L(init_ir_idx)       = AT_Tbl_Idx;
01079                IR_IDX_L(init_ir_idx)       = attr_idx;
01080 
01081                COPY_OPND(IR_OPND_R(init_ir_idx), init_opnd);
01082             }
01083          }
01084          else { /* error from parse_expr */
01085             AT_DCL_ERR(attr_idx) = TRUE;
01086          }
01087       }
01088 
01089       if (!AT_DCL_ERR(attr_idx)) {
01090          assign_offset(attr_idx);       /* Assign offsets to components */
01091       }
01092       else {
01093          ATD_CPNT_OFFSET_IDX(attr_idx)  = CN_INTEGER_ZERO_IDX;
01094          ATD_OFFSET_FLD(attr_idx)       = CN_Tbl_Idx;
01095       }
01096 
01097       ATD_OFFSET_ASSIGNED(attr_idx)     = TRUE;
01098       AT_DCL_ERR(CURR_BLK_NAME)         = AT_DCL_ERR(CURR_BLK_NAME) ||
01099                                           AT_DCL_ERR(attr_idx);
01100 
01101    }   /* Do while */
01102    while (LA_CH_VALUE == COMMA &&
01103           matched_specific_token(Tok_Punct_Comma, Tok_Class_Punct));
01104 
01105    if (LA_CH_VALUE != EOS) {
01106       parse_err_flush(Find_EOS, ", or " EOS_STR);
01107    }
01108 
01109    if (cif_flags & MISC_RECS) {
01110       cif_stmt_type_rec(TRUE, CIF_Type_Declaration_Stmt, stmt_number);
01111    }
01112 
01113    NEXT_LA_CH;                          /* Skip EOS */
01114 
01115    TRACE (Func_Exit, "parse_cpnt_dcl_stmt", NULL);
01116 
01117    return;
01118 
01119 }  /* parse_cpnt_dcl_stmt */
01120 
01121 
01122 /******************************************************************************\
01123 |*                                                                            *|
01124 |* Description:                                                               *|
01125 |*      Parse the DATA statement.                                             *|
01126 |*                                                                            *|
01127 |* Input parameters:                                                          *|
01128 |*      NONE                                                                  *|
01129 |*                                                                            *|
01130 |* Output parameters:                                                         *|
01131 |*      NONE                                                                  *|
01132 |*                                                                            *|
01133 |* Returns:                                                                   *|
01134 |*      NONE                                                                  *|
01135 |*                                                                            *|
01136 \******************************************************************************/
01137 
01138 void parse_data_stmt (void)
01139 
01140 {
01141    int          attr_idx;
01142    boolean      found_attr;
01143    boolean      found_comma     = FALSE;
01144    int          il_idx;
01145    int          init_ir_idx;
01146    int          name_column;
01147    int          name_idx;
01148    int          name_line;
01149    int          obj_chain_end;
01150    opnd_type    opnd;
01151 
01152 
01153    TRACE (Func_Entry, "parse_data_stmt", NULL);
01154 
01155    if ((STMT_OUT_OF_ORDER(curr_stmt_category, Data_Stmt)  ||
01156         STMT_CANT_BE_IN_BLK(Data_Stmt, CURR_BLK))             &&
01157        iss_blk_stk_err()) {
01158 
01159       /* Issued block error - intentionally blank.                            */
01160 
01161    }
01162    else if (curr_stmt_category < Declaration_Stmt_Cat) {
01163       curr_stmt_category = Declaration_Stmt_Cat;
01164    }
01165    else if (curr_stmt_category > Declaration_Stmt_Cat) {
01166       PRINTMSG(TOKEN_LINE(token), 1571, Comment,            /* Obsolescent */
01167                TOKEN_COLUMN(token));
01168    }
01169 
01170 DATA_STMT_SET:
01171 
01172    obj_chain_end      = NULL_IDX;
01173    TOKEN_VALUE(token) = Tok_Const_False;
01174 
01175    NTR_IR_TBL(init_ir_idx);
01176    SH_IR_IDX(curr_stmt_sh_idx) = init_ir_idx;
01177    IR_OPR(init_ir_idx)         = Init_Opr;
01178    IR_TYPE_IDX(init_ir_idx)    = TYPELESS_DEFAULT_TYPE;
01179    IR_LINE_NUM(init_ir_idx)    = LA_CH_LINE;
01180    IR_COL_NUM(init_ir_idx)     = LA_CH_COLUMN;
01181 
01182    while (MATCHED_TOKEN_CLASS(Tok_Class_Id)  ||  LA_CH_VALUE == LPAREN) {
01183 
01184       found_comma = FALSE;
01185 
01186       if (TOKEN_VALUE(token) != Tok_Const_False) {
01187          attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx);
01188 
01189          if (attr_idx == NULL_IDX) {
01190             found_attr           = FALSE;
01191             attr_idx             = ntr_sym_tbl(&token, name_idx);
01192             LN_DEF_LOC(name_idx) = TRUE;
01193             SET_IMPL_TYPE(attr_idx);
01194          }
01195          else {
01196             found_attr = TRUE;
01197 
01198             if (AT_REFERENCED(attr_idx) == Char_Rslt_Bound_Ref) {
01199                AT_ATTR_LINK(attr_idx)   = NULL_IDX;
01200                LN_DEF_LOC(name_idx)     = TRUE;
01201             }
01202          }
01203 
01204          if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
01205             ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE;
01206          }
01207 
01208 
01209          name_line   = TOKEN_LINE(token);
01210          name_column = TOKEN_COLUMN(token);
01211 
01212          /* Note: If a cross reference was requested, the Usage record for the*/
01213          /* target will be produced by the Semantics Pass so that expr_       */
01214          /* semantics can produce a "modification" record for the target and  */
01215          /* "reference" records for any subscripts, substring expressions,    */
01216          /* etc.                                                              */
01217 
01218          if (LA_CH_VALUE == LPAREN  ||  LA_CH_VALUE == PERCENT) {
01219 
01220             if (parse_deref(&opnd, NULL_IDX)) {
01221 
01222                if (OPND_FLD(opnd) == IR_Tbl_Idx  &&
01223                    IR_OPR(OPND_IDX(opnd)) == Call_Opr) {
01224                   PRINTMSG(name_line, 699, Error, name_column);
01225                   parse_err_flush(Find_EOS, NULL);
01226                   goto EXIT;
01227                }
01228             }
01229             else {
01230                parse_err_flush(Find_EOS, NULL);
01231                goto EXIT;
01232             }
01233          }
01234          else {
01235             OPND_LINE_NUM(opnd) = TOKEN_LINE(token);
01236             OPND_COL_NUM(opnd)  = TOKEN_COLUMN(token);
01237             OPND_FLD(opnd)      = AT_Tbl_Idx;
01238             OPND_IDX(opnd)      = attr_idx;
01239          }
01240 
01241          if (! merge_data(found_attr, name_line, name_column, attr_idx)) {
01242             parse_err_flush(Find_EOS, NULL);
01243             goto EXIT;
01244          }
01245       }
01246       else {
01247 
01248          if (! parse_data_imp_do(&opnd)) {
01249               parse_err_flush(Find_EOS, NULL);
01250               goto EXIT;
01251          }
01252       }
01253 
01254       NTR_IR_LIST_TBL(il_idx);
01255       COPY_OPND(IL_OPND(il_idx), opnd);
01256 
01257       switch (IL_FLD(il_idx)) {
01258 
01259          case AT_Tbl_Idx:
01260             IL_LINE_NUM(il_idx) = TOKEN_LINE(token);
01261             IL_COL_NUM(il_idx)  = TOKEN_COLUMN(token);
01262             break;
01263       
01264          case IR_Tbl_Idx: 
01265             IL_LINE_NUM(il_idx) = IR_LINE_NUM(IL_IDX(il_idx));
01266             IL_COL_NUM(il_idx)  = IR_COL_NUM(IL_IDX(il_idx));
01267             break;
01268 
01269          default:
01270             PRINTMSG(stmt_start_line, 179, Internal, stmt_start_col,
01271                      "parse_data_stmt");
01272       }
01273 
01274       if (obj_chain_end == NULL_IDX) {
01275          IR_FLD_L(init_ir_idx) = IL_Tbl_Idx;
01276          IR_IDX_L(init_ir_idx) = il_idx;
01277       }
01278       else {
01279          IL_NEXT_LIST_IDX(obj_chain_end) = il_idx;
01280          IL_PREV_LIST_IDX(il_idx)        = obj_chain_end;
01281       }
01282 
01283       obj_chain_end = il_idx;
01284       ++IR_LIST_CNT_L(init_ir_idx);
01285 
01286       TOKEN_VALUE(token) = Tok_Const_False;
01287 
01288       if (LA_CH_VALUE == COMMA) {
01289          found_comma = TRUE;
01290          NEXT_LA_CH;
01291       }
01292       else if (LA_CH_VALUE != SLASH) {
01293          parse_err_flush(Find_EOS, "comma or /");
01294          goto EXIT;
01295       } 
01296 
01297    }  /* End while */
01298 
01299 
01300    /* We have just found a token that does not belong in the data-stmt-object */
01301    /* list.  At this point, we could be processing either the first target    */
01302    /* list or trying to process a target list following a value list.         */
01303    /* Have we actually seen any targets in the current list we're trying to   */
01304    /* parse?                                                                  */
01305    /*   Y: Was the last token a comma?                                        */
01306    /*        Y: Error.  The comma must be followed by an id or implied-DO.    */
01307    /*        N: OK.  Go see if the next token is a '/'.                       */
01308    /*   N: Are we trying to parse the first target list?                      */
01309    /*        Y: Error.  The first thing must be an id or an implied-DO.       */
01310    /*        N: Was the last token a comma?                                   */
01311    /*             Y: Error.  The comma must be followed by an id or implied-  */
01312    /*                DO.                                                      */
01313    /*             N: Error.  The next token must be a target, comma, or EOS.  */
01314 
01315    if (IR_IDX_L(init_ir_idx) != NULL_IDX) { 
01316 
01317       if (found_comma) {
01318          parse_err_flush(Find_EOS, "data-stmt-object");
01319          goto EXIT;
01320       }
01321    }
01322    else {
01323 
01324       if (! SH_COMPILER_GEN(curr_stmt_sh_idx)) {
01325          parse_err_flush(Find_EOS, "data-stmt-object");
01326          goto EXIT;
01327       }
01328       else {
01329 
01330          if (found_comma) {
01331             parse_err_flush(Find_EOS, "data-stmt-object");
01332             goto EXIT;
01333          }
01334          else {
01335             parse_err_flush(Find_EOS, "comma, data-stmt-object, or EOS");
01336             goto EXIT;
01337          }
01338       }
01339    }
01340 
01341    if (LA_CH_VALUE == SLASH) {
01342       NEXT_LA_CH;
01343 
01344       if (!parse_initializer(init_ir_idx)) {
01345          goto EXIT;
01346       }
01347 
01348       if (LA_CH_VALUE == COMMA) {
01349          found_comma = TRUE;
01350          NEXT_LA_CH;
01351       }
01352       else {
01353          found_comma = FALSE;
01354       }
01355       
01356       if (LA_CH_VALUE != EOS) {
01357          gen_sh(After, Data_Stmt, LA_CH_LINE, LA_CH_COLUMN, FALSE, FALSE, TRUE);
01358          goto DATA_STMT_SET;
01359       }
01360       else if (found_comma) {
01361          parse_err_flush(Find_EOS, "data-stmt-object");
01362       }
01363    }
01364    else {
01365       parse_err_flush(Find_EOS, "/");
01366    }
01367             
01368 EXIT:
01369 
01370    NEXT_LA_CH;
01371    strcpy(parse_operand_insert, "operand");
01372    
01373    TRACE (Func_Exit, "parse_data_stmt", NULL);
01374 
01375    return;
01376 
01377 }  /* parse_data_stmt */
01378 
01379 
01380 /******************************************************************************\
01381 |*                                                                            *|
01382 |* Description:                                                               *|
01383 |*      BNF       - TYPE [[,access_spec]::type-name                           *|
01384 |*                                                                            *|
01385 |* Input parameters:                                                          *|
01386 |*      NONE                                                                  *|
01387 |*                                                                            *|
01388 |* Output parameters:                                                         *|
01389 |*      NONE                                                                  *|
01390 |*                                                                            *|
01391 |* Returns:                                                                   *|
01392 |*      NONE                                                                  *|
01393 |*                                                                            *|
01394 \******************************************************************************/
01395 
01396 static void parse_derived_type_stmt()
01397 
01398 {
01399    access_type   access;
01400    boolean       access_set     = FALSE;
01401    int           dt_idx         = NULL_IDX;
01402    boolean       err;
01403    int           name_idx;
01404    char         *str;
01405 
01406 
01407    TRACE (Func_Entry, "parse_derived_type_stmt", NULL);
01408 
01409    access = (access_type) AT_PRIVATE(SCP_ATTR_IDX(curr_scp_idx));
01410 
01411    if (LA_CH_VALUE == COMMA) {
01412       colon_recovery    = TRUE;                          /* Can recover at :: */
01413       NEXT_LA_CH;                                        /* Skip COMMA        */
01414 
01415       if (matched_specific_token(Tok_Kwd_Private, Tok_Class_Keyword)  ||
01416           matched_specific_token(Tok_Kwd_Public, Tok_Class_Keyword)) {
01417          access     = TOKEN_VALUE(token) == Tok_Kwd_Private ? Private : Public;
01418          access_set = TRUE;
01419 
01420          if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Module) {
01421             str     = access == Private ? "PRIVATE" : "PUBLIC";
01422             PRINTMSG(TOKEN_LINE(token), 596, Error, TOKEN_COLUMN(token), str);
01423             access_set = FALSE;
01424          }
01425 
01426          if (!matched_specific_token(Tok_Punct_Colon_Colon, Tok_Class_Punct)) {
01427             parse_err_flush(Find_None, "::");
01428          }
01429       }
01430       else {
01431          parse_err_flush(Find_None, "PUBLIC or PRIVATE");
01432          /* Bypass ::, just in case it's there */
01433          matched_specific_token(Tok_Punct_Colon_Colon, Tok_Class_Punct);
01434       }
01435       colon_recovery = FALSE;
01436    }
01437    else {  /* Colon Colon is optional here */
01438       matched_specific_token(Tok_Punct_Colon_Colon, Tok_Class_Punct);
01439    }
01440 
01441 
01442    if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
01443       
01444       if (LA_CH_VALUE != EOS) {
01445          parse_err_flush(Find_EOS, EOS_STR);
01446       }
01447 
01448       err = FALSE;
01449 
01450       switch (TOKEN_STR(token)[0]) {
01451          case 'C':
01452             err = (strcmp(TOKEN_STR(token), "CHARACTER") == 0) ||
01453                   (strcmp(TOKEN_STR(token), "COMPLEX") == 0);
01454             break;
01455          case 'D':
01456             err = (strcmp(TOKEN_STR(token), "DOUBLEPRECISION") == 0);
01457             break;
01458          case 'I':
01459             err = (strcmp(TOKEN_STR(token), "INTEGER") == 0);
01460             break;
01461          case 'L':
01462             err = (strcmp(TOKEN_STR(token), "LOGICAL") == 0);
01463             break;
01464          case 'R':
01465             err = (strcmp(TOKEN_STR(token), "REAL") == 0);
01466             break;
01467       }  /* end switch */
01468 
01469       if (err) {        /* Issue msg - but allow name to be used */
01470          PRINTMSG (TOKEN_LINE(token), 286, Error, TOKEN_COLUMN(token),
01471                    TOKEN_STR(token));
01472       }
01473 
01474       dt_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx);
01475 
01476       if (dt_idx == NULL_IDX) {
01477          dt_idx                         = ntr_sym_tbl(&token, name_idx);
01478          AT_OBJ_CLASS(dt_idx)           = Derived_Type;
01479          ATT_STRUCT_BIT_LEN_FLD(dt_idx) = CN_Tbl_Idx;
01480          ATT_STRUCT_BIT_LEN_IDX(dt_idx) = CN_INTEGER_ZERO_IDX;
01481          ATT_SCP_IDX(dt_idx)            = curr_scp_idx;
01482       }
01483       else if (AT_NOT_VISIBLE(dt_idx)) {
01484          PRINTMSG(TOKEN_LINE(token), 486, Error,
01485                   TOKEN_COLUMN(token),
01486                   AT_OBJ_NAME_PTR(dt_idx),
01487                   AT_OBJ_NAME_PTR(AT_MODULE_IDX(dt_idx)));
01488          CREATE_ERR_ATTR(dt_idx,
01489                          TOKEN_LINE(token), 
01490                          TOKEN_COLUMN(token),
01491                          Derived_Type);
01492          ATT_STRUCT_BIT_LEN_FLD(dt_idx) = CN_Tbl_Idx;
01493          ATT_STRUCT_BIT_LEN_IDX(dt_idx) = CN_INTEGER_ZERO_IDX;
01494          ATT_SCP_IDX(dt_idx)            = curr_scp_idx;
01495       }
01496       else if (AT_ATTR_LINK(dt_idx) != NULL_IDX) {
01497          AT_DEF_LINE(dt_idx)            = TOKEN_LINE(token);
01498          AT_DEF_COLUMN(dt_idx)          = TOKEN_COLUMN(token);
01499          AT_ATTR_LINK(dt_idx)           = NULL_IDX;
01500          CLEAR_VARIANT_ATTR_INFO(dt_idx, Derived_Type);
01501          ATT_STRUCT_BIT_LEN_FLD(dt_idx) = CN_Tbl_Idx;
01502          ATT_STRUCT_BIT_LEN_IDX(dt_idx) = CN_INTEGER_ZERO_IDX;
01503          ATT_SCP_IDX(dt_idx)            = curr_scp_idx;
01504 
01505          if (AT_LOCKED_IN(dt_idx)) {
01506             PRINTMSG(TOKEN_LINE(token), 390, Error, TOKEN_COLUMN(token),
01507                      AT_OBJ_NAME_PTR(dt_idx));
01508             AT_DCL_ERR(dt_idx)          = TRUE;
01509          }
01510       }
01511       else if (AT_OBJ_CLASS(dt_idx) == Derived_Type) {
01512          ATT_SCP_IDX(dt_idx)            = curr_scp_idx;
01513 
01514          if (AT_DEFINED(dt_idx)) {
01515             AT_DCL_ERR(dt_idx)   = TRUE;
01516             PRINTMSG(TOKEN_LINE(token), 123, Error, TOKEN_COLUMN(token),
01517                      AT_OBJ_NAME_PTR(dt_idx));
01518          }
01519       }
01520       else if (fnd_semantic_err(Obj_Derived_Type,
01521                                 TOKEN_LINE(token),
01522                                 TOKEN_COLUMN(token),
01523                                 dt_idx,
01524                                 TRUE)) {
01525 
01526          /* Create an error attr - but leave LN pointing to the original one. */
01527 
01528          CREATE_ERR_ATTR(dt_idx,
01529                          TOKEN_LINE(token), 
01530                          TOKEN_COLUMN(token),
01531                          Derived_Type);
01532          ATT_STRUCT_BIT_LEN_FLD(dt_idx) = CN_Tbl_Idx;
01533          ATT_STRUCT_BIT_LEN_IDX(dt_idx) = CN_INTEGER_ZERO_IDX;
01534          ATT_SCP_IDX(dt_idx)            = curr_scp_idx;
01535       }
01536       else {  /* Can only have been specified in an access statement */
01537 
01538          CLEAR_VARIANT_ATTR_INFO(dt_idx, Derived_Type);
01539          ATT_STRUCT_BIT_LEN_FLD(dt_idx) = CN_Tbl_Idx;
01540          ATT_STRUCT_BIT_LEN_IDX(dt_idx) = CN_INTEGER_ZERO_IDX;
01541          ATT_SCP_IDX(dt_idx)            = curr_scp_idx;
01542       }
01543 
01544       if (CURR_BLK != Interface_Body_Blk) {
01545 
01546          /* Interface_Body_Blk stuff is counted during interface collapse. */
01547 
01548          num_of_derived_types++;
01549       }
01550 
01551       if ((cif_flags & XREF_RECS) != 0) {
01552          cif_usage_rec(dt_idx, 
01553                        AT_Tbl_Idx,
01554                        TOKEN_LINE(token),
01555                        TOKEN_COLUMN(token),
01556                        CIF_Derived_Type_Name_Definition);
01557       }
01558 
01559       LN_DEF_LOC(name_idx)      = TRUE;
01560       AT_DEFINED(dt_idx)        = TRUE;
01561       AT_LOCKED_IN(dt_idx)      = TRUE;
01562 
01563       if (AT_ACCESS_SET(dt_idx)) {
01564 
01565          if (access_set) {
01566             AT_DCL_ERR(dt_idx)  = TRUE;
01567             PRINTMSG (TOKEN_LINE(token), 275, Error, TOKEN_COLUMN(token),
01568                       AT_OBJ_NAME_PTR(dt_idx));
01569          }
01570       }
01571       else {
01572          AT_PRIVATE(dt_idx)     = access;
01573          AT_ACCESS_SET(dt_idx)  = access_set;
01574       }
01575    }
01576    else {
01577       parse_err_flush(Find_EOS, "type-name");
01578    }
01579 
01580    stmt_type                            = Derived_Type_Stmt;
01581    SH_STMT_TYPE(curr_stmt_sh_idx)       = Derived_Type_Stmt;
01582 
01583    if ((STMT_OUT_OF_ORDER(curr_stmt_category, Derived_Type_Stmt) ||
01584         STMT_CANT_BE_IN_BLK(Derived_Type_Stmt, CURR_BLK)) &&
01585         iss_blk_stk_err()) {
01586       PUSH_BLK_STK(Derived_Type_Blk);
01587       CURR_BLK_ERR              = TRUE;
01588    }
01589    else {
01590       PUSH_BLK_STK(Derived_Type_Blk);
01591       curr_stmt_category        = Declaration_Stmt_Cat;
01592    }
01593 
01594    CURR_BLK_NO_EXEC             = TRUE;
01595    CURR_BLK_NAME                = dt_idx;
01596 
01597    NEXT_LA_CH;                  /* Skip EOS */
01598 
01599    TRACE (Func_Exit, "parse_derived_type_stmt", NULL);
01600 
01601    return;
01602 
01603 }  /* parse_derived_type_stmt */
01604 
01605 
01606 /******************************************************************************\
01607 |*                                                                            *|
01608 |* Description:                                                               *|
01609 |*      Parse the EQUIVALENCE statement.                                      *|
01610 |*                                                                            *|
01611 |* Input parameters:                                                          *|
01612 |*      NONE                                                                  *|
01613 |*                                                                            *|
01614 |* Output parameters:                                                         *|
01615 |*      NONE                                                                  *|
01616 |*                                                                            *|
01617 |* Returns:                                                                   *|
01618 |*      NONE                                                                  *|
01619 |*                                                                            *|
01620 \******************************************************************************/
01621 
01622 void parse_equivalence_stmt (void)
01623 
01624 {
01625    int          al_idx;
01626    int          attr_idx;
01627    int          column;
01628    int          eq_idx;
01629    boolean      fnd_attr;
01630    int          group;
01631    boolean      have_array;
01632    int          items_in_list;
01633    int          line;
01634    int          list_idx;
01635    int          list2_idx;
01636    int          name_idx;
01637    opnd_type    opnd;
01638    boolean      parsed_ok       = TRUE;
01639    int          rank;
01640    opnd_type    result_opnd;
01641    int          subs_idx        = NULL_IDX;
01642    boolean      substring;
01643    int          substring_idx;
01644 
01645 
01646    TRACE (Func_Entry, "parse_equivalence_stmt", NULL);
01647 
01648    if (LA_CH_VALUE == LPAREN) {
01649 
01650       NTR_EQ_TBL(eq_idx);
01651 
01652       while (LA_CH_VALUE == LPAREN) {
01653          NEXT_LA_CH;  /* eat the ( */
01654 
01655          EQ_NEXT_EQUIV_GRP(eq_idx)         = SCP_FIRST_EQUIV_GRP(curr_scp_idx);
01656          SCP_FIRST_EQUIV_GRP(curr_scp_idx) = eq_idx;
01657          group                             = eq_idx;
01658          items_in_list                     = 0;
01659 
01660          do {
01661             if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
01662                attr_idx                 = srch_sym_tbl(TOKEN_STR(token),  
01663                                                        TOKEN_LEN(token), 
01664                                                        &name_idx);
01665                fnd_attr                 = attr_idx;
01666                line                     = TOKEN_LINE(token);
01667                column                   = TOKEN_COLUMN(token);
01668                EQ_LINE_NUM(eq_idx)      = line;
01669                EQ_COLUMN_NUM(eq_idx)    = column;
01670                items_in_list            = items_in_list + 1;
01671 
01672                if (attr_idx == NULL_IDX) {
01673                   attr_idx                      = ntr_sym_tbl(&token, name_idx);
01674                   LN_DEF_LOC(name_idx)          = TRUE;
01675                   SET_IMPL_TYPE(attr_idx);
01676                   AT_OBJ_CLASS(attr_idx)        = Data_Obj;
01677                   ATD_CLASS(attr_idx)           = Variable;
01678                }
01679                else if (AT_REFERENCED(attr_idx) == Char_Rslt_Bound_Ref) {
01680                   AT_ATTR_LINK(attr_idx)        = NULL_IDX;
01681                   LN_DEF_LOC(name_idx)          = TRUE;
01682                }
01683 
01684                if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
01685                   ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE;
01686                }
01687 
01688                if ((cif_flags & XREF_RECS) != 0) { 
01689                   cif_usage_rec(attr_idx,
01690                                 AT_Tbl_Idx,
01691                                 line,
01692                                 column,
01693                                 CIF_Symbol_Declaration);
01694                }
01695 
01696                if (group != eq_idx) {
01697                   EQ_NEXT_EQUIV_OBJ(EQ_GRP_END_IDX(group))      = eq_idx;
01698                }
01699 
01700                if (!fnd_attr || !fnd_semantic_err(Obj_Equiv,
01701                                                   line,
01702                                                   column,
01703                                                   attr_idx,
01704                                                   TRUE)) {
01705 
01706                   NTR_ATTR_LIST_TBL(al_idx);
01707 
01708                   AL_IDX_IS_EQ(al_idx)          = TRUE;
01709                   AL_NEXT_IDX(al_idx)           = ATD_EQUIV_LIST(attr_idx);
01710                   AL_EQ_IDX(al_idx)             = eq_idx;
01711                   ATD_CLASS(attr_idx)           = Variable;
01712                   ATD_EQUIV(attr_idx)           = TRUE;
01713                   ATD_EQUIV_LIST(attr_idx)      = al_idx;
01714                   ATD_DCL_EQUIV(attr_idx)       = TRUE;
01715                }
01716                EQ_ATTR_IDX(eq_idx)              = attr_idx;
01717                EQ_GRP_IDX(eq_idx)               = group;
01718                EQ_GRP_END_IDX(group)            = eq_idx;
01719 
01720                if (LA_CH_VALUE == LPAREN) {  /* Array and/or substring */
01721                   expr_mode                     = Initialization_Expr;
01722                   OPND_FLD(result_opnd)         = AT_Tbl_Idx;
01723                   OPND_IDX(result_opnd)         = attr_idx;
01724                   OPND_LINE_NUM(result_opnd)    = TOKEN_LINE(token);
01725                   OPND_COL_NUM(result_opnd)     = TOKEN_COLUMN(token);
01726                   substring                     = is_substring_ref();
01727                   have_array    = (ATD_ARRAY_IDX(attr_idx) != NULL_IDX);
01728 
01729                   if (have_array && substring) {
01730                      PRINTMSG(TOKEN_LINE(token), 250,Error,TOKEN_COLUMN(token));
01731                   }
01732 
01733                   if (!substring) {
01734                      rank = 0;
01735                      NTR_IR_TBL(subs_idx);
01736 
01737                      /* copy the attr_idx */
01738 
01739                      COPY_OPND(IR_OPND_L(subs_idx), result_opnd);
01740 
01741                      /* put subs_idx into result opnd for now */
01742 
01743                      OPND_FLD(result_opnd)      = IR_Tbl_Idx;
01744                      OPND_IDX(result_opnd)      = subs_idx;
01745 
01746                      /* LA_CH is '(' */
01747                      IR_LINE_NUM(subs_idx)      = LA_CH_LINE;
01748                      IR_COL_NUM(subs_idx)       = LA_CH_COLUMN;
01749                      IR_OPR(subs_idx)           = Subscript_Opr;
01750                      IR_FLD_R(subs_idx)         = IL_Tbl_Idx;
01751                      list_idx                   = NULL_IDX;
01752 
01753                      do {
01754                         NEXT_LA_CH;
01755 
01756                         if (list_idx == NULL_IDX) {
01757                            NTR_IR_LIST_TBL(list_idx);
01758                            IR_IDX_R(subs_idx) = list_idx;
01759                         }
01760                         else {
01761                            NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01762                            IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) =
01763                                                                   list_idx;
01764                            list_idx = IL_NEXT_LIST_IDX(list_idx);
01765                         }
01766 
01767                         if (LA_CH_VALUE != COLON) {
01768                            parsed_ok = parse_expr(&opnd) && parsed_ok;
01769                            COPY_OPND(IL_OPND(list_idx), opnd);
01770                         }
01771                         rank++;
01772                      }
01773                      while (LA_CH_VALUE == COMMA);
01774 
01775                      if (! matched_specific_token(Tok_Punct_Rparen,
01776                                                   Tok_Class_Punct)) {
01777                         parse_err_flush(Find_EOS, ")");
01778                         parsed_ok = FALSE;
01779                         expr_mode = Regular_Expr;
01780                         goto EXIT;
01781                      }
01782          
01783                      IR_LIST_CNT_R(subs_idx) = rank;
01784    
01785                   } /* if (array) */
01786 
01787                   /* now check for possible substring reference */
01788 
01789                   if (LA_CH_VALUE == LPAREN && is_substring_ref()) {
01790                      EQ_SUBSTRINGED(eq_idx)     = TRUE;
01791                      NTR_IR_TBL(substring_idx);
01792                      IR_OPR(substring_idx)      = Substring_Opr;
01793                      IR_LINE_NUM(substring_idx) = LA_CH_LINE;
01794                      IR_COL_NUM(substring_idx)  = LA_CH_COLUMN;
01795     
01796                      COPY_OPND(IR_OPND_L(substring_idx), result_opnd);
01797 
01798                      /* put substring idx into result_opnd */
01799 
01800                      OPND_FLD(result_opnd)              = IR_Tbl_Idx;
01801                      OPND_IDX(result_opnd)              = substring_idx;
01802                      IR_FLD_R(substring_idx)            = IL_Tbl_Idx;
01803                      IR_LIST_CNT_R(substring_idx)       = 2;
01804                      NTR_IR_LIST_TBL(list_idx);
01805                      NTR_IR_LIST_TBL(list2_idx);
01806                      IR_IDX_R(substring_idx)            = list_idx;
01807                      IL_NEXT_LIST_IDX(list_idx)         = list2_idx;
01808                      IL_PREV_LIST_IDX(list2_idx)        = list_idx;
01809 
01810                      NEXT_LA_CH;        /* consume ( */
01811 
01812                      if (LA_CH_VALUE != COLON) {
01813                         parsed_ok = parse_expr(&opnd) && parsed_ok;
01814                         COPY_OPND(IL_OPND(list_idx), opnd);
01815                      }
01816 
01817                      if (LA_CH_VALUE != COLON) {
01818 
01819                         if (parse_err_flush(Find_EOS, ":")) {
01820                            NEXT_LA_CH;
01821                         }
01822 
01823                         parsed_ok = FALSE;
01824                         expr_mode = Regular_Expr;
01825                         goto EXIT;
01826                      }
01827 
01828                      NEXT_LA_CH;  /* consume : */
01829 
01830                      if (LA_CH_VALUE != RPAREN) {
01831                         parsed_ok = parse_expr(&opnd) && parsed_ok;
01832                         COPY_OPND(IL_OPND(list2_idx), opnd);
01833                      }
01834 
01835                      if (LA_CH_VALUE != RPAREN) {
01836 
01837                         if (parse_err_flush(Find_EOS, ")")) {
01838                            NEXT_LA_CH;
01839                         }
01840                         parsed_ok = FALSE;
01841                         expr_mode = Regular_Expr;
01842                         goto EXIT;
01843                      }
01844                      NEXT_LA_CH;     /* Consume rparen */
01845                   }  /* substring reference */
01846 
01847                   expr_mode                     = Regular_Expr;
01848                   EQ_OPND_FLD(eq_idx)           = OPND_FLD(result_opnd);
01849                   EQ_OPND_IDX(eq_idx)           = OPND_IDX(result_opnd);
01850                }
01851                NTR_EQ_TBL(eq_idx);
01852 
01853 # ifdef COARRAY_FORTRAN
01854 
01855                if (LA_CH_VALUE == LBRKT && cmd_line_flags.co_array_fortran) {
01856                   PRINTMSG(LA_CH_LINE, 1578, Error, LA_CH_COLUMN,
01857                            AT_OBJ_NAME_PTR(attr_idx), "EQUIVALENCE");
01858 
01859                   /* Disregard the list_idx.  It's just a place holder */
01860                   /* so that we can parse correctly.                   */
01861 
01862                   list2_idx = parse_pe_array_spec(attr_idx);
01863                }
01864 # endif
01865             }
01866             else {
01867                parse_err_flush(Find_Comma_Rparen, "equivalence-object");
01868             }
01869 
01870             if (LA_CH_VALUE != COMMA && LA_CH_VALUE != RPAREN) {
01871                parse_err_flush(Find_EOS, ", or )");
01872                goto EXIT;
01873             }
01874    
01875             if (LA_CH_VALUE == COMMA) {
01876                NEXT_LA_CH;  /* eat the , */
01877             }
01878             else {
01879                break;
01880             }
01881 
01882          }  /* End while */
01883          while (TRUE);
01884 
01885          if (items_in_list < 2) {
01886             PRINTMSG(LA_CH_LINE, 137, Error, LA_CH_COLUMN);
01887          }
01888 
01889          if (LA_CH_VALUE != RPAREN) {
01890             parse_err_flush(Find_EOS, ")");
01891             goto EXIT; 
01892          }
01893          NEXT_LA_CH;  /* eat the ) */
01894 
01895          if (LA_CH_VALUE != COMMA && LA_CH_VALUE != EOS) {
01896             parse_err_flush(Find_EOS, ", or " EOS_STR);
01897             goto EXIT;
01898          }
01899 
01900          if (LA_CH_VALUE == COMMA) {
01901             NEXT_LA_CH;  /* eat the , */
01902          }
01903       }  /* End while */
01904 
01905       if ((STMT_OUT_OF_ORDER(curr_stmt_category, Equivalence_Stmt) ||
01906            STMT_CANT_BE_IN_BLK(Equivalence_Stmt, CURR_BLK)) &&
01907           iss_blk_stk_err()) {
01908          /* Issued block stack error - intentionally left blank */
01909       }
01910       else {
01911          curr_stmt_category = Declaration_Stmt_Cat;
01912       }
01913    }
01914    else {
01915       parse_err_flush(Find_EOS, "(");
01916       goto EXIT;
01917    }
01918 
01919    if (LA_CH_VALUE != EOS) {
01920       parse_err_flush(Find_EOS, EOS_STR);
01921    }
01922 
01923 EXIT:
01924 
01925    NEXT_LA_CH;  /* eat the EOS */
01926  
01927    TRACE (Func_Exit, "parse_equivalence_stmt", NULL);
01928    
01929    return;
01930 
01931 }  /* parse_equivalence_stmt */
01932 
01933 /******************************************************************************\
01934 |*                                                                            *|
01935 |* Description:                                                               *|
01936 |*      This function parses the implicit statement.  If the statement is an  *|
01937 |*      IMPLICIT NONE statement, stmt_type is changed to reflect the fact.    *|
01938 |*      The syntax that is parsed is a follows:                               *|
01939 |*                                                                            *|
01940 |*         implicit-stmt  =>  IMPLICIT implicit-spec-list  |  IMPLICIT NONE   *|
01941 |*         implicit-spec  =>  type-spec ( letter-spec-list )                  *|
01942 |*         letter-spec    =>  letter [- letter]                               *|
01943 |*                                                                            *|
01944 |*      This routine also parses and extension -> IMPLICIT UNDEFINED          *|
01945 |*      This is the same as IMPLICIT NONE.                                    *|
01946 |*                                                                            *|
01947 |* Input parameters:                                                          *|
01948 |*      NONE                                                                  *|
01949 |*                                                                            *|
01950 |* Output parameters:                                                         *|
01951 |*      NONE                                                                  *|
01952 |*                                                                            *|
01953 |* Returns:                                                                   *|
01954 |*      NONE                                                                  *|
01955 |*                                                                            *|
01956 \******************************************************************************/
01957 
01958 void parse_implicit_stmt (void)
01959 
01960 {
01961    int                  al_idx;
01962    int                  attr_idx;
01963    boolean              end_found       = FALSE;
01964    int                  end_idx;
01965    int                  err_idx;
01966    char                 err_str[80];
01967    boolean              found_type;
01968    boolean              have_kind;
01969    int                  idx;
01970    boolean              implicit_undefined;
01971    int                  name_idx;
01972    char                 start_char;
01973    int                  start_idx;
01974    int                  stmt_number;
01975    int                  storage;
01976    boolean              type_err;
01977    int                  type_idx;
01978 
01979 
01980    TRACE (Func_Entry, "parse_implicit_stmt", NULL);
01981 
01982    stmt_number          = statement_number;
01983    implicit_undefined   = FALSE;
01984 
01985    if (LA_CH_VALUE == 'U' &&
01986        matched_specific_token(Tok_Kwd_Undefined, Tok_Class_Keyword)) {
01987       implicit_undefined = TRUE;
01988       PRINTMSG(stmt_start_line, 1253, Ansi, stmt_start_col,
01989                "IMPLICIT UNDEFINED");
01990    }
01991 
01992    if (implicit_undefined ||
01993        (LA_CH_VALUE == 'N' &&
01994         matched_specific_token(Tok_Kwd_None, Tok_Class_Keyword))) {
01995 
01996       if (LA_CH_VALUE == EOS) {
01997          stmt_type                      = Implicit_None_Stmt;
01998          SH_STMT_TYPE(curr_stmt_sh_idx) = Implicit_None_Stmt;
01999 
02000          if (cif_flags & MISC_RECS) {
02001             cif_stmt_type_rec(TRUE, CIF_Implicit_None_Stmt, stmt_number);
02002          }
02003 
02004          if ((STMT_OUT_OF_ORDER(curr_stmt_category, Implicit_None_Stmt) ||
02005               STMT_CANT_BE_IN_BLK(Implicit_None_Stmt, CURR_BLK)) &&
02006              iss_blk_stk_err()) {
02007             /* Intentionally left blank */
02008          }
02009          else {
02010             curr_stmt_category = Implicit_None_Stmt_Cat;
02011          }
02012 
02013          if (SCP_IMPL_NONE(curr_scp_idx)) { /* IMPLICIT NONE already in scope */
02014             PRINTMSG(stmt_start_line, 298, Error, stmt_start_col);
02015          }
02016 
02017          SCP_IMPL_NONE(curr_scp_idx)    = TRUE;
02018       } 
02019       else {
02020          parse_err_flush(Find_EOS, EOS_STR);
02021       }
02022 
02023       goto EXIT;
02024    }  
02025 
02026    if (cif_flags & MISC_RECS) {
02027       cif_stmt_type_rec(TRUE, CIF_Implicit_Stmt, stmt_number);
02028    }
02029 
02030    if ((STMT_OUT_OF_ORDER(curr_stmt_category, Implicit_Stmt) ||
02031         STMT_CANT_BE_IN_BLK(Implicit_Stmt, CURR_BLK)) &&
02032        iss_blk_stk_err()) {
02033       /* Issued block stack error - intentionally left blank */
02034    }
02035    else {
02036       curr_stmt_category = Implicit_Stmt_Cat;
02037    }
02038 
02039    found_type   = FALSE;
02040 
02041    do {
02042 
02043       if (!MATCHED_TOKEN_CLASS (Tok_Class_Keyword)) {
02044 
02045          /* We could also have AUTOMATIC or STATIC but they are not */
02046          /* included in the list because this is an old MIPS        */
02047          /* extension and we do not want to encourage this use.     */
02048 
02049          if (!parse_err_flush(Find_Comma, "INTEGER, REAL, DOUBLE, COMPLEX,"
02050                              " LOGICAL, CHARACTER or TYPE")) {
02051              goto EXIT;  /* Didn't find a comma */
02052          }
02053          NEXT_LA_CH;
02054          continue;
02055       }
02056 
02057       if (TOKEN_VALUE(token) == Tok_Kwd_Automatic) {
02058          storage = Impl_Automatic_Storage;
02059       }
02060       else if (TOKEN_VALUE(token) == Tok_Kwd_Static) {
02061          storage = Impl_Static_Storage;
02062       }
02063       else {
02064          storage        = Impl_Default_Storage;
02065 
02066          found_type     = TRUE;
02067 
02068          /* Set have_kind if there is more than one paren group following the */
02069          /* implicit type keyword.  If there is only one paren group, that    */
02070          /* means, that the paren group is the letter(s) for the implict type */
02071 
02072          have_kind = (LA_CH_VALUE == LPAREN && 
02073                       TOKEN_VALUE(token) != Tok_Kwd_Type &&
02074                       ch_after_paren_grp() == LPAREN);
02075 
02076          type_err       = !parse_type_spec(have_kind);
02077          type_idx       = ATD_TYPE_IDX(AT_WORK_IDX);
02078 
02079          if (type_err) { /* No valid type keyword */
02080 
02081             if (!parse_err_flush(Find_Comma, NULL)) {
02082                 goto EXIT;  /* Didn't find a comma */
02083             }
02084             NEXT_LA_CH;
02085             continue;
02086          }
02087 
02088          if (TYP_TYPE(type_idx) == Character &&
02089              TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char) {
02090 
02091             /* implicit character *(*) is not allowed */
02092 
02093             PRINTMSG(TOKEN_LINE(token), 32, Error, TOKEN_COLUMN(token));
02094 
02095             if (!parse_err_flush(Find_Comma, NULL)) {
02096                goto EXIT;  /* Didn't find a comma */
02097             }
02098             NEXT_LA_CH;
02099             continue;
02100          }
02101       }
02102 
02103       if (LA_CH_VALUE != LPAREN) {
02104 
02105          if (!parse_err_flush(Find_Comma, "(")) {
02106             goto EXIT;
02107          }
02108          NEXT_LA_CH;
02109          continue;
02110       }
02111 
02112       do {
02113          NEXT_LA_CH;
02114 
02115          if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
02116             parse_err_flush(Find_Comma_Rparen,
02117                         "A,B,C,D,E,F,G,H,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y or Z");
02118             continue;
02119          }
02120 
02121          if (TOKEN_LEN(token) > 1) {
02122              PRINTMSG(TOKEN_LINE(token), 197, Error, TOKEN_COLUMN(token),
02123                       "A,B,C,D,E,F,G,H,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y or Z",
02124                       TOKEN_STR(token));
02125              parse_err_flush(Find_Comma_Rparen, NULL);
02126              continue;
02127          }
02128 
02129          start_char     = TOKEN_STR(token)[0];
02130          start_idx      = IMPL_IDX(start_char);
02131          end_idx        = start_idx;
02132 
02133          if (LA_CH_VALUE == DASH) {
02134             NEXT_LA_CH;
02135 
02136             if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
02137                parse_err_flush(Find_Comma_Rparen,
02138                         "A,B,C,D,E,F,G,H,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y or Z");
02139                continue;
02140             }
02141 
02142             if (TOKEN_LEN(token) > 1) {
02143                PRINTMSG(TOKEN_LINE(token), 197, Error,TOKEN_COLUMN(token),
02144                         "B,C,D,E,F,G,H,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y or Z",
02145                         TOKEN_STR(token));
02146                parse_err_flush(Find_Comma_Rparen, NULL);
02147                continue;
02148             }
02149             end_idx     = IMPL_IDX(TOKEN_STR(token)[0]);
02150 
02151             if (start_idx > end_idx) {  /* start range exceeds end */
02152                PRINTMSG(TOKEN_LINE(token), 175, Error,TOKEN_COLUMN(token),
02153                         start_char, TOKEN_STR(token)[0]);
02154             }
02155          }
02156 
02157          err_idx = NULL_IDX;
02158 
02159          if (storage == Impl_Default_Storage) {  /* Implicit type statement */
02160 
02161             for (idx = start_idx; idx <= end_idx; idx++) {
02162 
02163                if (IM_SET(curr_scp_idx, idx)) {
02164                   err_str[err_idx++]    = COMMA;
02165                   err_str[err_idx++]    = ' ';
02166                   err_str[err_idx++]    = idx + 'A';
02167                }
02168                else {
02169                   IM_SET(curr_scp_idx, idx)     = TRUE;
02170                   IM_TYPE_IDX(curr_scp_idx, idx)        = type_idx;
02171                }
02172             }
02173 
02174             if (err_idx != NULL_IDX) {
02175                err_str[err_idx]         = EOS;
02176                PRINTMSG(TOKEN_LINE(token), 1629, Error, TOKEN_COLUMN(token),
02177                         "type",
02178                         &err_str[2]);  /* Skip first , blank in string */
02179             }
02180          }
02181          else {
02182             for (idx = start_idx; idx <= end_idx; idx++) {
02183 
02184                if (IM_STORAGE(curr_scp_idx, idx) != Impl_Default_Storage) {
02185                   err_str[err_idx++]    = COMMA;
02186                   err_str[err_idx++]    = ' ';
02187                   err_str[err_idx++]    = idx + 'A';
02188                }
02189                else {
02190                   IM_STORAGE(curr_scp_idx, idx) = storage;
02191                }
02192             }
02193 
02194             if (err_idx != NULL_IDX) {
02195                err_str[err_idx]         = EOS;
02196                PRINTMSG(TOKEN_LINE(token), 1629, Error, TOKEN_COLUMN(token),
02197                         "storage",
02198                         &err_str[2]);  /* Skip first , blank in string */
02199             }
02200          }
02201 
02202          if (LA_CH_VALUE != COMMA && LA_CH_VALUE != RPAREN) {
02203             parse_err_flush(Find_Comma_Rparen, ", or )");
02204          }
02205 
02206       }  /* End while */
02207       while (LA_CH_VALUE == COMMA);
02208 
02209       if (LA_CH_VALUE == RPAREN) {
02210          NEXT_LA_CH;
02211       }
02212 
02213       if (LA_CH_VALUE == EOS || (LA_CH_VALUE != COMMA &&
02214                                 !parse_err_flush(Find_Comma, ", or " EOS_STR))){
02215          end_found = TRUE;
02216       }
02217       else {
02218          NEXT_LA_CH;
02219       }
02220    }  /* while */
02221    while (!end_found);
02222 
02223    if (SCP_IMPL_NONE(curr_scp_idx) && found_type) {
02224 
02225       /* IMPLICIT NONE already set in scope */
02226 
02227       PRINTMSG (stmt_start_line, 176, Error, stmt_start_col);
02228       parse_err_flush(Find_EOS, NULL);
02229       goto EXIT;
02230    }
02231 
02232    for (name_idx = SCP_LN_FW_IDX(curr_scp_idx) + 1;
02233         name_idx < SCP_LN_LW_IDX(curr_scp_idx); name_idx++) {
02234 
02235       attr_idx = LN_ATTR_IDX(name_idx);
02236 
02237       if (AT_ATTR_LINK(attr_idx) == NULL_IDX && !AT_USE_ASSOCIATED(attr_idx)) {
02238          retype_attr(attr_idx);
02239       }
02240    }
02241 
02242    al_idx = SCP_ATTR_LIST(curr_scp_idx);
02243 
02244    while (al_idx != NULL_IDX) {
02245 
02246       if (AT_ATTR_LINK(AL_ATTR_IDX(al_idx)) == NULL_IDX &&
02247           !AT_USE_ASSOCIATED(AL_ATTR_IDX(al_idx))) {
02248          retype_attr(AL_ATTR_IDX(al_idx));
02249       }
02250       al_idx = AL_NEXT_IDX(al_idx);
02251    }
02252 
02253 EXIT:
02254 
02255    NEXT_LA_CH;
02256 
02257    TRACE (Func_Exit, "parse_implicit_stmt", NULL);
02258 
02259    return;
02260 
02261 }  /* parse_implicit_stmt */
02262 
02263 /******************************************************************************\
02264 |*                                                                            *|
02265 |* Description:                                                               *|
02266 |*                                                                            *|
02267 |* Input parameters:                                                          *|
02268 |*      NONE                                                                  *|
02269 |*                                                                            *|
02270 |* Output parameters:                                                         *|
02271 |*      NONE                                                                  *|
02272 |*                                                                            *|
02273 |* Returns:                                                                   *|
02274 |*      NONE                                                                  *|
02275 |*                                                                            *|
02276 \******************************************************************************/
02277 
02278 static void retype_attr(int     attr_idx)
02279 
02280 {
02281    int  old_type_idx;
02282 
02283 
02284    TRACE (Func_Entry, "retype_attr", NULL);
02285 
02286    /* Retype possible function name, dummy args, and any thing used in */
02287    /* a bounds expression for character.  Special case for N$PES.      */
02288 
02289    switch (AT_OBJ_CLASS(attr_idx)) {
02290 
02291    case Data_Obj:
02292 
02293       if (!AT_TYPED(attr_idx) && !ATD_SYMBOLIC_CONSTANT(attr_idx)) {
02294 
02295          if (ATD_CLASS(attr_idx) == Constant) {
02296             old_type_idx = ATD_TYPE_IDX(attr_idx);
02297             SET_IMPL_TYPE(attr_idx);
02298 
02299             if (old_type_idx != ATD_TYPE_IDX(attr_idx)) {
02300                PRINTMSG(AT_DEF_LINE(attr_idx), 238, Error, 
02301                         AT_DEF_COLUMN(attr_idx),
02302                         AT_OBJ_NAME_PTR(attr_idx),
02303                         get_basic_type_str(old_type_idx));
02304                ATD_TYPE_IDX(attr_idx) = old_type_idx;
02305             }
02306          }
02307          else if (ATD_CLASS(attr_idx) != Compiler_Tmp) {
02308 
02309             if (AT_REFERENCED(attr_idx) > Not_Referenced) {
02310                old_type_idx = ATD_TYPE_IDX(attr_idx);
02311                SET_IMPL_TYPE(attr_idx);
02312 
02313                if (old_type_idx != ATD_TYPE_IDX(attr_idx)) {
02314                   ATD_TYPE_IDX(attr_idx)        = old_type_idx;
02315                   AT_DCL_ERR(attr_idx)          = TRUE;
02316                   PRINTMSG(AT_DEF_LINE(attr_idx), 827, Error,
02317                            AT_DEF_COLUMN(attr_idx),
02318                            AT_OBJ_NAME_PTR(attr_idx),
02319                            get_basic_type_str(old_type_idx));
02320                }
02321             }
02322             else {
02323                SET_IMPL_TYPE(attr_idx);
02324             }
02325          }
02326       }
02327       break;
02328 
02329    case Pgm_Unit:
02330 
02331       if (ATP_PGM_UNIT(attr_idx) == Function &&
02332           !ATP_RSLT_NAME(attr_idx) &&            /* Will catch with own name */
02333           !AT_TYPED(ATP_RSLT_IDX(attr_idx))) { 
02334          SET_IMPL_TYPE(ATP_RSLT_IDX(attr_idx));
02335       }
02336       break;
02337 
02338    default: /* Any stmt_functions would be host associated */
02339       break;
02340 
02341    }  /* End switch */
02342 
02343    TRACE (Func_Exit, "retype_attr", NULL);
02344 
02345    return;
02346 
02347 }  /* retype_attr */
02348 
02349 /******************************************************************************\
02350 |*                                                                            *|
02351 |* Description:                                                               *|
02352 |*      BNF is    INTERFACE [ generic spec ]                                  *|
02353 |*                                                                            *|
02354 |* Input parameters:                                                          *|
02355 |*      NONE                                                                  *|
02356 |*                                                                            *|
02357 |* Output parameters:                                                         *|
02358 |*      NONE                                                                  *|
02359 |*                                                                            *|
02360 |* Returns:                                                                   *|
02361 |*      NONE                                                                  *|
02362 |* Notes:                                                                     *|
02363 |*                                                                            *|
02364 |*      From interp 99:                                                       *|
02365 |*      If two or more generic interfaces that are accessible in a scoping    *|
02366 |*      unit have the same name, ..., they are interpreted as a single        *|
02367 |*      generic interface.                                                    *|
02368 |*                                                                            *|
02369 |*                                                                            *|
02370 \******************************************************************************/
02371 
02372 void parse_interface_stmt (void)
02373 
02374 {
02375    int          attr_idx        = NULL_IDX;
02376    id_str_type  name;
02377    int          stmt_number;
02378 
02379 
02380    TRACE (Func_Entry, "parse_interface_stmt", NULL);
02381 
02382    stmt_number = statement_number;
02383 
02384    if (LA_CH_VALUE != EOS) {
02385 
02386       if (parse_generic_spec()) {
02387          attr_idx = generic_spec_semantics();
02388 
02389          /* Even if this interface came from a module, it is being extended */
02390          /* in this program unit, so it is not the exact same as the one    */
02391          /* from the module.                                                */
02392 
02393          AT_MODULE_IDX(attr_idx) = NULL_IDX;
02394 
02395          /* CIF usage record is generated by generic_spec_semantics */
02396 
02397          if (LA_CH_VALUE != EOS) {
02398             parse_err_flush(Find_EOS, EOS_STR);
02399          }
02400          else {
02401 
02402             if ((cif_flags & MISC_RECS)  &&  attr_idx != NULL_IDX) {
02403                
02404                if (TOKEN_VALUE(token) == Tok_Id) {
02405                   cif_stmt_type_rec(TRUE, 
02406                                     CIF_Interface_Generic_Stmt, 
02407                                     stmt_number);
02408                }
02409                else if (TOKEN_VALUE(token) == Tok_Op_Assign) {
02410                   cif_stmt_type_rec(TRUE, 
02411                                     CIF_Interface_Assignment_Stmt, 
02412                                     stmt_number);
02413                }
02414                else {
02415                   cif_stmt_type_rec(TRUE, 
02416                                     CIF_Interface_Operator_Stmt, 
02417                                     stmt_number);
02418                }
02419             }
02420          }
02421       }
02422       else {
02423          CREATE_ID(name, "unnamed interface", 17);
02424          attr_idx = ntr_local_attr_list(name.string,
02425                                         17,
02426                                         TOKEN_LINE(token),
02427                                         TOKEN_COLUMN(token));
02428          AT_OBJ_CLASS(attr_idx)                 = Interface;
02429          ATI_UNNAMED_INTERFACE(attr_idx)        = TRUE;
02430          AT_DCL_ERR(attr_idx)                   = TRUE;
02431          parse_err_flush(Find_EOS, NULL);
02432       }
02433    }
02434    else {
02435 
02436       /* Generate an unnamed attr entry for this interface.  It is used */
02437       /* for collapsing the individual interface bodies at one time.    */
02438 
02439       CREATE_ID(name, "unnamed interface", 17);
02440       attr_idx = ntr_local_attr_list(name.string,
02441                                      17,
02442                                      TOKEN_LINE(token),
02443                                      TOKEN_COLUMN(token));
02444       AT_OBJ_CLASS(attr_idx)            = Interface;
02445       ATI_UNNAMED_INTERFACE(attr_idx)   = TRUE;
02446 
02447       if (cif_flags & MISC_RECS) {
02448          cif_stmt_type_rec(TRUE, CIF_Interface_Explicit_Stmt, stmt_number);
02449       }
02450    }
02451 
02452    if ((STMT_OUT_OF_ORDER(curr_stmt_category, Interface_Stmt) ||
02453         STMT_CANT_BE_IN_BLK(Interface_Stmt, CURR_BLK)) &&
02454         iss_blk_stk_err()) {
02455       PUSH_BLK_STK(Interface_Blk);
02456       CURR_BLK_ERR              = TRUE;
02457    }
02458    else {
02459       PUSH_BLK_STK(Interface_Blk);
02460       curr_stmt_category        = Sub_Func_Stmt_Cat;
02461    }
02462 
02463    CURR_BLK_NO_EXEC             = TRUE;
02464 
02465    /* Save the unnamed interface attr in the blk stack, but not in   */
02466    /* CURR_BLK_NAME.  If it is in CURR_BLK_NAME, there are too many  */
02467    /* ways the block stack can get messed up.                        */
02468  
02469    if (attr_idx != NULL_IDX && ATI_UNNAMED_INTERFACE(attr_idx)) {
02470       BLK_UNNAMED_INTERFACE(blk_stk_idx) = attr_idx;
02471       attr_idx = NULL_IDX;
02472    }
02473    
02474    CURR_BLK_NAME = attr_idx;
02475    NEXT_LA_CH;                          /* Pick up EOS */
02476          
02477    if (cif_flags & BASIC_RECS) {
02478       cif_begin_scope_rec();
02479 
02480       if (attr_idx != NULL_IDX) {
02481          ATI_CIF_SCOPE_ID(attr_idx) = BLK_CIF_SCOPE_ID(blk_stk_idx);
02482       }
02483       else if (BLK_UNNAMED_INTERFACE(blk_stk_idx) != NULL_IDX) {
02484          ATI_CIF_SCOPE_ID(BLK_UNNAMED_INTERFACE(blk_stk_idx)) =
02485             BLK_CIF_SCOPE_ID(blk_stk_idx);
02486       }
02487    }
02488 
02489    TRACE (Func_Exit, "parse_interface_stmt", NULL);
02490 
02491    return;
02492 
02493 }  /* parse_interface_stmt */
02494 
02495 
02496 /******************************************************************************\
02497 |*                                                                            *|
02498 |* Description:                                                               *|
02499 |*      Parse the NAMELIST statement.  BNF is:                                *|
02500 |*                                                                            *|
02501 |*        NAMELIST /namelist-group-name/ namelist-group-object-list           *|
02502 |*                 [[,] /namelist-group-name/ namelist-group-object-list]...  *|
02503 |*                                                                            *|
02504 |* Input parameters:                                                          *|
02505 |*      NONE                                                                  *|
02506 |*                                                                            *|
02507 |* Output parameters:                                                         *|
02508 |*      NONE                                                                  *|
02509 |*                                                                            *|
02510 |* Returns:                                                                   *|
02511 |*      NONE                                                                  *|
02512 |*                                                                            *|
02513 \******************************************************************************/
02514 
02515 void parse_namelist_stmt (void)
02516 
02517 {
02518    int          attr_idx;
02519    boolean      end_grp_list    =FALSE;
02520    int          grp_attr;
02521    int          host_attr_idx;
02522    int          host_name_idx;
02523    int          name_idx;
02524    int          sn_idx;
02525 
02526 
02527    TRACE (Func_Entry, "parse_namelist_stmt", NULL);
02528 
02529    if ((STMT_OUT_OF_ORDER(curr_stmt_category, Namelist_Stmt) ||
02530       STMT_CANT_BE_IN_BLK(Namelist_Stmt, CURR_BLK)) && iss_blk_stk_err()) {
02531       /* Issued block stack error - intentionally left blank */
02532    }
02533    else if (curr_stmt_category < Declaration_Stmt_Cat) {
02534       curr_stmt_category = Declaration_Stmt_Cat;
02535    }
02536    else if (curr_stmt_category == Executable_Stmt_Cat) {
02537       PRINTMSG(stmt_start_line, 265, Ansi, stmt_start_col);
02538    }
02539 
02540    if (LA_CH_VALUE != SLASH) {
02541       parse_err_flush (Find_EOS,"/");
02542    }
02543 
02544    /* Will always have a Slash or an EOS at this point. */
02545    while (LA_CH_VALUE == SLASH) {
02546       NEXT_LA_CH;       /* Consume the slash */
02547 
02548       if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
02549          parse_err_flush (Find_EOS, "namelist-group-name");
02550          goto EXIT;
02551       }
02552 
02553       /* At this point have a namelist group name.  Enter it into the */
02554       /* symbol table.                                                */
02555 
02556       grp_attr = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx);
02557 
02558       if (grp_attr == NULL_IDX) {
02559          grp_attr               = ntr_sym_tbl(&token, name_idx);
02560          LN_DEF_LOC(name_idx)   = TRUE;
02561          AT_OBJ_CLASS(grp_attr) = Namelist_Grp;
02562       }
02563       else if (!fnd_semantic_err(Obj_Namelist_Grp,
02564                                  TOKEN_LINE(token),
02565                                  TOKEN_COLUMN(token),
02566                                  grp_attr,
02567                                  TRUE)) {
02568 
02569          if (AT_REFERENCED(grp_attr) == Referenced) {
02570             PRINTMSG(TOKEN_LINE(token), 39, Error, TOKEN_COLUMN(token),
02571                      AT_OBJ_NAME_PTR(grp_attr));
02572          }
02573 
02574          AT_OBJ_CLASS(grp_attr) = Namelist_Grp;
02575       }
02576       else {
02577          parse_err_flush(Find_EOS, NULL);
02578          goto EXIT;
02579       }
02580 
02581       if ((cif_flags & XREF_RECS) != 0) { 
02582          cif_usage_rec(grp_attr,
02583                        AT_Tbl_Idx,
02584                        TOKEN_LINE(token),
02585                        TOKEN_COLUMN(token),
02586                        CIF_Symbol_Declaration);
02587       }
02588 
02589       if (LA_CH_VALUE != SLASH) {
02590          parse_err_flush (Find_EOS, "/");
02591          goto EXIT;
02592       }
02593 
02594       /* Have a matching set of slashes, now parse group object list */
02595       NEXT_LA_CH;               /* Consume slash */
02596 
02597       while (!end_grp_list) {
02598 
02599          if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
02600             parse_err_flush(Find_EOS, "namelist-group-object");
02601             AT_DCL_ERR(grp_attr) = TRUE;
02602             goto EXIT;
02603          }
02604 
02605          attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token),
02606                                  &name_idx);
02607 
02608          if (attr_idx == NULL_IDX) {    /* search host sym tab */
02609             host_attr_idx = srch_host_sym_tbl(TOKEN_STR(token),
02610                                               TOKEN_LEN(token), 
02611                                               &host_name_idx,
02612                                               FALSE);  /* Don't srch INTRINSIC*/
02613  
02614             /* Because of forward referencing - NOT_VISIBLE gets checked when */
02615             /* the rest of the namelist objects semantics are done.           */
02616 
02617             if (host_attr_idx != NULL_IDX) {
02618                attr_idx = ntr_host_in_sym_tbl(&token, name_idx,
02619                                               host_attr_idx, host_name_idx, 
02620                                               TRUE);
02621             }
02622             else {
02623                attr_idx = ntr_sym_tbl(&token, name_idx);
02624                SET_IMPL_TYPE(attr_idx);
02625             }
02626          }
02627 
02628          if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
02629             ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE;
02630          }
02631 
02632 
02633          if ((cif_flags & XREF_RECS) != 0) { 
02634             cif_usage_rec(attr_idx,
02635                           AT_Tbl_Idx,
02636                           TOKEN_LINE(token),
02637                           TOKEN_COLUMN(token),
02638                           CIF_Symbol_Declaration);
02639          }
02640 
02641          AT_NAMELIST_OBJ(attr_idx)      = TRUE;
02642 
02643          NTR_SN_TBL(sn_idx);
02644 
02645          SN_ATTR_IDX(sn_idx)    = attr_idx;
02646          SN_NAME_LEN(sn_idx)    = AT_NAME_LEN(attr_idx);
02647          SN_NAME_IDX(sn_idx)    = AT_NAME_IDX(attr_idx);
02648          SN_LINE_NUM(sn_idx)    = TOKEN_LINE(token);
02649          SN_COLUMN_NUM(sn_idx)  = TOKEN_COLUMN(token);
02650 
02651          if (ATN_FIRST_NAMELIST_IDX(grp_attr) == NULL_IDX) {
02652             ATN_FIRST_NAMELIST_IDX(grp_attr) = sn_idx;
02653          }
02654          else {
02655             SN_SIBLING_LINK(ATN_LAST_NAMELIST_IDX(grp_attr)) = sn_idx;
02656          }
02657 
02658          ATN_LAST_NAMELIST_IDX(grp_attr)        = sn_idx;
02659          ATN_NUM_NAMELIST(grp_attr)            += 1;
02660 
02661          if (LA_CH_VALUE != COMMA && 
02662              LA_CH_VALUE != SLASH &&
02663              LA_CH_VALUE != EOS) {
02664             parse_err_flush(Find_EOS, "/ or, or " EOS_STR);
02665             AT_DCL_ERR(grp_attr) = TRUE;
02666             goto EXIT;
02667          }
02668 
02669          /* At this point la will be comma, slash or eos. */
02670 
02671          if (LA_CH_VALUE == COMMA) {
02672             NEXT_LA_CH;
02673 
02674             if (LA_CH_VALUE == SLASH) {
02675                /* have start of new group */
02676                end_grp_list = TRUE;
02677             }
02678          }
02679          else {
02680             end_grp_list = TRUE;
02681          }
02682       } /* while */
02683 
02684       end_grp_list = FALSE;
02685    }  /* end while groups*/
02686 
02687 EXIT:
02688 
02689    if (LA_CH_VALUE != EOS) {
02690       parse_err_flush(Find_EOS, EOS_STR);
02691    }
02692 
02693    NEXT_LA_CH;
02694    
02695    TRACE (Func_Exit, "parse_namelist_stmt", NULL);
02696 
02697    return;
02698 
02699 }  /* parse_namelist_stmt */
02700 
02701 /******************************************************************************\
02702 |*                                                                            *|
02703 |* Description:                                                               *|
02704 |*      BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE                          *|
02705 |*                                                                            *|
02706 |* Input parameters:                                                          *|
02707 |*      NONE                                                                  *|
02708 |*                                                                            *|
02709 |* Output parameters:                                                         *|
02710 |*      NONE                                                                  *|
02711 |*                                                                            *|
02712 |* Returns:                                                                   *|
02713 |*      NONE                                                                  *|
02714 |*                                                                            *|
02715 \******************************************************************************/
02716 
02717 void parse_parameter_stmt (void)
02718 
02719 {
02720    int                  attr_idx;
02721    int                  column;
02722    int                  const_column;
02723    int                  const_line;
02724    expr_arg_type        exp_desc;
02725    boolean              fnd_attr;
02726    opnd_type            init_opnd;
02727    int                  line;
02728    int                  name_idx;
02729 
02730 
02731    TRACE (Func_Entry, "parse_parameter_stmt", NULL);
02732 
02733    /* NOTE:  CFT77 does allow a PARAMETER stmt to preceed an IMPLICIT   */
02734    /*        NONE stmt but there isn't a way to do it without getting   */
02735    /*        an error later down the line...the IMPLICIT NONE is        */
02736    /*        imposed on the PARAMETER stmt and is therefore typeless    */
02737    /*        and an is generated.                                       */
02738 
02739    if (LA_CH_VALUE != LPAREN) {
02740       parse_err_flush(Find_EOS, "(");
02741       goto EXIT;
02742    }
02743 
02744    if ((STMT_OUT_OF_ORDER(curr_stmt_category, Parameter_Stmt) ||
02745         STMT_CANT_BE_IN_BLK(Parameter_Stmt,CURR_BLK)) && iss_blk_stk_err()) {
02746       /* Block error - intentionally blank */
02747    }
02748    else if (curr_stmt_category <= Implicit_Stmt_Cat) {
02749       curr_stmt_category = Implicit_Stmt_Cat;
02750    }
02751    else {
02752       curr_stmt_category = Declaration_Stmt_Cat;
02753    }
02754 
02755    do {
02756       NEXT_LA_CH;   /* Skip first Lparen, and then skips the commas */
02757 
02758       if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
02759          parse_err_flush(Find_Comma_Rparen, "named-constant");
02760          continue;
02761       }
02762 
02763       attr_idx  = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx);
02764       fnd_attr  = attr_idx;
02765       line      = TOKEN_LINE(token);
02766       column    = TOKEN_COLUMN(token);
02767 
02768       if (attr_idx == NULL_IDX) {
02769          attr_idx               = ntr_sym_tbl(&token, name_idx);
02770          LN_DEF_LOC(name_idx)   = TRUE;
02771          SET_IMPL_TYPE(attr_idx);
02772       }
02773       else if (AT_REFERENCED(attr_idx) == Char_Rslt_Bound_Ref) {
02774          AT_ATTR_LINK(attr_idx) = NULL_IDX;
02775          LN_DEF_LOC(name_idx)   = TRUE;
02776       }
02777 
02778       if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
02779          ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE;
02780       }
02781 
02782       if (LA_CH_VALUE != EQUAL) {
02783           parse_err_flush(Find_Comma_Rparen, "=");
02784           continue;
02785       }
02786 
02787       NEXT_LA_CH;               /* Skip = */
02788       const_line        = LA_CH_LINE;
02789       const_column      = LA_CH_COLUMN;
02790 
02791       if (parse_expr(&init_opnd)) {
02792          exp_desc.rank  = 0;
02793          expr_mode      = Initialization_Expr;
02794          xref_state     = CIF_Symbol_Reference;
02795 
02796          if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
02797              TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character &&
02798              TYP_CHAR_CLASS(ATD_TYPE_IDX(attr_idx)) == Unknown_Char) {
02799 
02800             char_bounds_resolution(attr_idx,
02801                                    &fnd_attr);
02802          }
02803 
02804          if (AT_OBJ_CLASS(attr_idx) == Data_Obj && ATD_ARRAY_IDX(attr_idx)) {
02805             array_bounds_resolution(attr_idx, &fnd_attr);
02806          }
02807 
02808          if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
02809 
02810             if (ATD_ARRAY_IDX(attr_idx)) {
02811                target_array_idx = ATD_ARRAY_IDX(attr_idx);
02812             }
02813 
02814             switch (TYP_TYPE(ATD_TYPE_IDX(attr_idx))) {
02815             case Integer:
02816             case Real:
02817             case Complex:
02818                check_type_conversion = TRUE;
02819                target_type_idx       = ATD_TYPE_IDX(attr_idx);
02820                break;
02821 
02822             case Character:
02823 
02824                if (TYP_CHAR_CLASS(ATD_TYPE_IDX(attr_idx)) == Const_Len_Char) {
02825                   check_type_conversion = TRUE;
02826                   target_type_idx = Character_1;
02827                   target_char_len_idx = TYP_IDX(ATD_TYPE_IDX(attr_idx));
02828                }
02829                break;
02830             }
02831          }
02832 
02833          /* set comp_gen_expr to TRUE. This forces the fold of REAL   */
02834          /* constant expressions. When -Oieeeconform is specified,    */
02835          /* the folding of Real and Complex expressions is prevented. */
02836 
02837          comp_gen_expr = TRUE;
02838 
02839          if (expr_semantics(&init_opnd, &exp_desc)) {
02840             check_type_conversion = FALSE;
02841             target_array_idx      = NULL_IDX;
02842             expr_mode             = Regular_Expr;
02843             merge_parameter(fnd_attr,
02844                             attr_idx,
02845                             line,
02846                             column,
02847                             &init_opnd,
02848                             &exp_desc,
02849                             const_line,
02850                             const_column);
02851 
02852             if ((cif_flags & XREF_RECS) != 0) {
02853                cif_usage_rec(attr_idx,
02854                              AT_Tbl_Idx,
02855                              line,
02856                              column,
02857                              CIF_Symbol_Declaration);
02858             }
02859          }
02860          else {
02861             check_type_conversion = FALSE;
02862             target_array_idx      = NULL_IDX;
02863             expr_mode             = Regular_Expr;
02864             AT_DCL_ERR(attr_idx) = TRUE;
02865          }
02866 
02867          /* reset comp_gen_expr to FALSE. end of compiler generated expr */
02868          comp_gen_expr = FALSE;
02869       }
02870       else {
02871          /* error from parse_expr */
02872          AT_DCL_ERR(attr_idx) = TRUE;
02873       }
02874 
02875       if (LA_CH_VALUE != COMMA && LA_CH_VALUE != RPAREN) {
02876          parse_err_flush(Find_Comma_Rparen, ", or )");
02877       }
02878    }
02879    while (LA_CH_VALUE == COMMA);
02880 
02881    if (LA_CH_VALUE == RPAREN) {
02882       NEXT_LA_CH;
02883    }
02884 
02885 EXIT:
02886 
02887    NEXT_LA_CH;       /* Pick up EOS */
02888    
02889    TRACE (Func_Exit, "parse_parameter_stmt", NULL);
02890 
02891    return;
02892 
02893 }  /* parse_parameter_stmt */
02894 
02895 /******************************************************************************\
02896 |*                                                                            *|
02897 |* Description:                                                               *|
02898 |*      BNF   SEQUENCE                                                        *|
02899 |*                                                                            *|
02900 |* Input parameters:                                                          *|
02901 |*      NONE                                                                  *|
02902 |*                                                                            *|
02903 |* Output parameters:                                                         *|
02904 |*      NONE                                                                  *|
02905 |*                                                                            *|
02906 |* Returns:                                                                   *|
02907 |*      NONE                                                                  *|
02908 |*                                                                            *|
02909 \******************************************************************************/
02910 
02911 void parse_sequence_stmt (void)
02912 
02913 {
02914    TRACE (Func_Entry, "parse_sequence_stmt", NULL);
02915 
02916    if (CURR_BLK == Derived_Type_Blk) {
02917 
02918       if (LA_CH_VALUE == EOS) {
02919 
02920          if (ATT_SEQUENCE_SET(CURR_BLK_NAME)) {
02921             PRINTMSG (TOKEN_LINE(token), 41, Error,
02922                       TOKEN_COLUMN(token), "SEQUENCE",
02923                       AT_OBJ_NAME_PTR(CURR_BLK_NAME));
02924          }
02925 
02926          if (ATT_FIRST_CPNT_IDX(CURR_BLK_NAME) != NULL_IDX) {
02927             PRINTMSG(TOKEN_LINE(token), 8, Error, TOKEN_COLUMN(token),
02928                      "SEQUENCE", AT_OBJ_NAME_PTR(CURR_BLK_NAME));
02929          }
02930 
02931          ATT_SEQUENCE_SET(CURR_BLK_NAME) = TRUE;
02932       }
02933       else {
02934          parse_err_flush(Find_EOS, EOS_STR);
02935       }
02936    }
02937    else {
02938       parse_err_flush(Find_EOS, NULL);
02939       iss_blk_stk_err();        /* Not assignment statement */
02940    }
02941 
02942    NEXT_LA_CH;                  /* Skip EOS */
02943 
02944    TRACE (Func_Exit, "parse_sequence_stmt", NULL);
02945 
02946    return;
02947 
02948 }  /* parse_sequence_stmt */
02949 
02950 /******************************************************************************\
02951 |*                                                                            *|
02952 |* Description:                                                               *|
02953 |*      This parses a statement function.  Unlike other stmt parsers, this    *|
02954 |*      routine is called from parse_assignment_stmt, not from the stmt table.*|
02955 |*      At entry the name of the statement function has been entered into the.*|
02956 |*      attr table.                                                           *|
02957 |*                                                                            *|
02958 |* Input parameters:                                                          *|
02959 |*      NONE                                                                  *|
02960 |*                                                                            *|
02961 |* Output parameters:                                                         *|
02962 |*      NONE                                                                  *|
02963 |*                                                                            *|
02964 |* Returns:                                                                   *|
02965 |*      NONE                                                                  *|
02966 |*                                                                            *|
02967 \******************************************************************************/
02968 
02969 void parse_stmt_func_stmt(int   sf_attr_idx,
02970                           int   sf_name_idx)
02971 
02972 {
02973    int          attr_idx;
02974    int          count;
02975    int          first_idx;
02976    boolean      found_end               = FALSE;
02977    int          i;
02978    int          name_idx;
02979    int          new_attr_idx;
02980    opnd_type    opnd;
02981    int          sn_idx;
02982    int          sn_attr_idx;
02983    int          stmt_number;
02984 
02985 
02986    TRACE (Func_Entry, "parse_stmt_func_stmt", NULL);
02987 
02988    stmt_type = Stmt_Func_Stmt;
02989    stmt_number = statement_number;
02990 
02991    if ((STMT_OUT_OF_ORDER(curr_stmt_category, Stmt_Func_Stmt) ||
02992         STMT_CANT_BE_IN_BLK(Stmt_Func_Stmt, CURR_BLK)) && iss_blk_stk_err()) {
02993       /* Issued block error - intentionally left blank */
02994    }
02995    else {
02996       curr_stmt_category = Declaration_Stmt_Cat;
02997    }
02998 
02999    if (!fnd_semantic_err(Obj_Stmt_Func, 
03000                          TOKEN_LINE(token),
03001                          TOKEN_COLUMN(token),
03002                          sf_attr_idx,
03003                          TRUE)) {
03004 
03005       if (AT_REFERENCED(sf_attr_idx) == Char_Rslt_Bound_Ref) {
03006          AT_ATTR_LINK(sf_attr_idx)   = NULL_IDX;
03007          LN_DEF_LOC(sf_name_idx)     = TRUE;
03008       }
03009 
03010       /* MUST be a data object - has been implicitly typed already */
03011 
03012       AT_OBJ_CLASS(sf_attr_idx) = Stmt_Func;
03013       LN_DEF_LOC(sf_name_idx)   = TRUE;
03014    }
03015    else {
03016       CREATE_ERR_ATTR(sf_attr_idx, 
03017                       TOKEN_LINE(token),
03018                       TOKEN_COLUMN(token),
03019                       Stmt_Func);
03020    }
03021 
03022    if ((cif_flags & XREF_RECS) != 0) {
03023       cif_usage_rec(sf_attr_idx,
03024                     AT_Tbl_Idx,
03025                     TOKEN_LINE(token),
03026                     TOKEN_COLUMN(token),
03027                     CIF_Symbol_Declaration);
03028    }
03029 
03030    NEXT_LA_CH;   /* Must be Lparen to be here - Consume Lparen */
03031 
03032    if (LA_CH_VALUE == RPAREN) {
03033       goto DONE;
03034    }
03035 
03036    do {
03037 
03038       if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
03039          attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx);
03040 
03041          if (attr_idx == NULL_IDX) {
03042             attr_idx                    = ntr_sym_tbl(&token, name_idx);
03043             LN_DEF_LOC(name_idx)        = TRUE;
03044             AT_OBJ_CLASS(attr_idx)      = Data_Obj;
03045             ATD_CLASS(attr_idx)         = Dummy_Argument;
03046             SET_IMPL_TYPE(attr_idx);
03047             AT_IS_DARG(attr_idx)        = TRUE;
03048             ATD_SF_DARG(attr_idx)       = TRUE;
03049          }
03050          else {
03051 
03052             if (fnd_semantic_err(Obj_Sf_Darg, 
03053                                  TOKEN_LINE(token),
03054                                  TOKEN_COLUMN(token),
03055                                  attr_idx,
03056                                  TRUE)) {
03057 
03058                AT_DCL_ERR(sf_attr_idx) = TRUE;
03059             }
03060 
03061             NTR_ATTR_TBL(new_attr_idx);
03062             COPY_COMMON_ATTR_INFO(attr_idx, new_attr_idx, Data_Obj);
03063             AT_OBJ_CLASS(new_attr_idx)          = Data_Obj;
03064             ATD_CLASS(new_attr_idx)             = Dummy_Argument;
03065             AT_IS_DARG(new_attr_idx)            = TRUE;
03066             AT_IS_INTRIN(new_attr_idx)          = FALSE;
03067             AT_ELEMENTAL_INTRIN(new_attr_idx)   = FALSE;
03068             ATD_SF_DARG(new_attr_idx)           = TRUE;
03069 
03070             if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
03071                 AT_TYPED(new_attr_idx)          = AT_TYPED(attr_idx);
03072                 ATD_TYPE_IDX(new_attr_idx)      = ATD_TYPE_IDX(attr_idx);
03073             }
03074             else {
03075                SET_IMPL_TYPE(new_attr_idx);
03076             }
03077             ATD_SF_LINK(new_attr_idx)           = attr_idx;
03078             LN_ATTR_IDX(name_idx)               = new_attr_idx;
03079             attr_idx                            = new_attr_idx;
03080          }
03081 
03082          if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
03083             ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE;
03084          }
03085 
03086 
03087          if ((cif_flags & XREF_RECS) != 0) {
03088             cif_usage_rec(attr_idx,
03089                           AT_Tbl_Idx,
03090                           TOKEN_LINE(token),
03091                           TOKEN_COLUMN(token),
03092                           CIF_Symbol_Is_Dummy_Arg);
03093          }
03094 
03095          /* Enter into secondary name table */
03096 
03097          sn_attr_idx = srch_kwd_name(TOKEN_STR(token),
03098                                      TOKEN_LEN(token),
03099                                      sf_attr_idx,
03100                                      &sn_idx);
03101 
03102          if (sn_attr_idx != NULL_IDX) { /* Have duplicate dummy arg */
03103             PRINTMSG(TOKEN_LINE(token), 10, Error, TOKEN_COLUMN(token),
03104                      TOKEN_STR(token));
03105             AT_DCL_ERR(sf_attr_idx) = TRUE;
03106          }
03107          else { 
03108             NTR_SN_TBL(sn_idx);
03109             SN_ATTR_IDX(sn_idx)         = attr_idx;
03110             SN_NAME_LEN(sn_idx)         = AT_NAME_LEN(attr_idx);
03111             SN_NAME_IDX(sn_idx)         = AT_NAME_IDX(attr_idx);
03112             SN_LINE_NUM(sn_idx)         = TOKEN_LINE(token);
03113             SN_COLUMN_NUM(sn_idx)       = TOKEN_COLUMN(token);
03114 
03115             if (ATP_FIRST_IDX(sf_attr_idx) == NULL_IDX) {
03116                ATP_FIRST_IDX(sf_attr_idx) = sn_idx;
03117             }
03118             ATP_NUM_DARGS(sf_attr_idx) += 1;
03119          }
03120       }
03121       else  {
03122 
03123          AT_DCL_ERR(sf_attr_idx) = TRUE;
03124 
03125          if (!parse_err_flush(Find_Comma_Rparen, "dummy-arg-name")) {
03126             goto EXIT;
03127          }
03128       }
03129 
03130       if (LA_CH_VALUE != RPAREN && LA_CH_VALUE != COMMA) {
03131 
03132          AT_DCL_ERR(sf_attr_idx) = TRUE;
03133 
03134          if (!parse_err_flush(Find_Comma_Rparen, ", or )")) {
03135             goto EXIT;
03136          }
03137       }
03138 
03139       if (LA_CH_VALUE == COMMA) {
03140          NEXT_LA_CH;
03141       }
03142       else {
03143          found_end = TRUE;
03144       }
03145 
03146    }  /* end do while */
03147    while (!found_end);
03148 
03149 DONE:
03150 
03151    NEXT_LA_CH;  /* Consume RPAREN */
03152 
03153    if (matched_specific_token(Tok_Punct_Eq, Tok_Class_Punct)) {
03154       expr_mode                 = Stmt_Func_Expr;
03155 
03156       if (parse_expr(&opnd)) {
03157          ATS_SF_FLD(sf_attr_idx)        = OPND_FLD(opnd);
03158          ATS_SF_IDX(sf_attr_idx)        = OPND_IDX(opnd);
03159       }
03160       else {
03161          AT_DCL_ERR(sf_attr_idx) = TRUE;
03162       }
03163 
03164       expr_mode                 = Regular_Expr;
03165 
03166       if (cif_flags & MISC_RECS) {
03167          cif_stmt_type_rec(TRUE, CIF_Statement_Function_Stmt, stmt_number);
03168       }
03169    }
03170    else {
03171       AT_DCL_ERR(sf_attr_idx) = TRUE;
03172       parse_err_flush(Find_EOS, "=");
03173    }
03174 
03175    first_idx = ATP_FIRST_IDX(sf_attr_idx);
03176    count     = ATP_NUM_DARGS(sf_attr_idx);
03177 
03178    /* Remove the dargs from the local name table */
03179 
03180    for (i = first_idx; i < (first_idx + count); i++) {
03181       attr_idx = SN_ATTR_IDX(i);
03182       srch_sym_tbl(AT_OBJ_NAME_PTR(attr_idx), AT_NAME_LEN(attr_idx), &name_idx);
03183 
03184       if (ATD_SF_LINK(attr_idx) != NULL_IDX) {
03185          LN_ATTR_IDX(name_idx) = ATD_SF_LINK(attr_idx);
03186       }
03187       else {
03188          remove_ln_ntry(name_idx);
03189       }
03190    }
03191 
03192    if (LA_CH_VALUE != EOS) {
03193       AT_DCL_ERR(sf_attr_idx) = TRUE;
03194       parse_err_flush(Find_EOS, EOS_STR);
03195    }
03196 
03197 EXIT:
03198 
03199    TRACE (Func_Exit, "parse_stmt_func_stmt", NULL);
03200 
03201    return;
03202 
03203 }  /* parse_stmt_func_stmt */
03204 
03205 /******************************************************************************\
03206 |*                                                                            *|
03207 |* Description:                                                               *|
03208 |*    Parses the type declaration statement                                   *|
03209 |*                                                                            *|
03210 |*      BNF   type_spec[[,attr_spec]...::]entity-decl-list                    *|
03211 |*              type-spec is  INTEGER [kind-selector]                         *|
03212 |*                            REAL [kind-selector]                            *|
03213 |*                            DOUBLE PRECISION                                *|
03214 |*                            COMPLEX [kind-selector]                         *|
03215 |*                            CHARACTER [char-selector]                       *|
03216 |*                            LOGICAL [kind-selector]                         *|
03217 |*                            TYPE (type-name)                                *|
03218 |*                            BYTE                                            *|
03219 |*            entity_dcl_list is                                              *|
03220 |*              object-name[(array-spec)][*char-length][=initialization-expr] *|
03221 |*            attr_spec is    done in parse_attr_spec                         *|
03222 |*                                                                            *|
03223 \******************************************************************************/
03224 
03225 void parse_type_dcl_stmt (void)
03226 
03227 {
03228    int                  array_idx;
03229    int                  attr_idx;
03230    long                 attr_list               = 0;
03231    int                  buf_idx;
03232    boolean              check_char_comma;
03233    boolean              GT_encountered          = FALSE;
03234    boolean              chk_semantics;
03235    expr_arg_type        exp_desc;
03236    boolean              found_colon;
03237    boolean              found_end;
03238    boolean              has_parameter           = FALSE;
03239    int                  id_column;
03240    int                  id_line;
03241    int                  il_idx;
03242    int                  init_ir_idx;
03243    opnd_type            init_opnd;
03244    int                  name_idx;
03245    boolean              need_new_array;
03246    int                  new_array_idx;
03247    int                  new_pe_array_idx        = NULL_IDX;
03248    boolean              new_attr;
03249    int                  old_array_idx;
03250    int                  pe_array_idx            = NULL_IDX;
03251    boolean              possible_func;
03252    int                  save_column;
03253    int                  save_line;
03254    int                  stmt_number;
03255    int                  stmt_num;
03256    boolean              type_err;
03257    int                  type_idx;
03258    int                  usage_code;
03259 
03260 
03261    TRACE (Func_Entry, "parse_type_dcl_stmt", NULL);
03262 
03263    colon_recovery = TRUE;               /* Can recover to :: */
03264    stmt_number = statement_number;
03265 
03266    if (TOKEN_VALUE(token) == Tok_Kwd_Type  &&  LA_CH_VALUE != LPAREN) {
03267 
03268       if (LA_CH_VALUE == EOS) {
03269 
03270          /* Expecting either a TYPE statement or a derived type statement. */
03271 
03272          parse_err_flush(Find_EOS, "( or , or :: or type-name");
03273          NEXT_LA_CH;    /* Skip EOS */
03274          goto EXIT;
03275       }
03276 
03277       /* Allows for nested  derived types.  The block stack will allow for    */
03278       /* this.  Context/block checking catches and issues the error.          */
03279 
03280       parse_derived_type_stmt();
03281 
03282       if (cif_flags & MISC_RECS) {
03283          cif_stmt_type_rec(TRUE, CIF_Type_Stmt, stmt_number);
03284       }
03285 
03286       goto EXIT;
03287    }
03288 
03289    if (CURR_BLK == Derived_Type_Blk) {
03290       stmt_type = Cpnt_Decl_Stmt;
03291       parse_cpnt_dcl_stmt();
03292       goto EXIT;
03293    }
03294 
03295    if (curr_stmt_category == Sub_Func_Stmt_Cat) {
03296 
03297       /* In contains or Interface block - must be function statement.         */
03298       /* DO NOT end curr_stmt_category == Init_Stmt_Cat thru here, because it */
03299       /* may not be a FUNCTION statement.  The following is a legal type dcl  */
03300       /* stmt:   INTEGER FUNCTION A(10) in fixed format.                      */
03301 
03302       CLEAR_ATTR_NTRY(AT_WORK_IDX);             /* Used for AT_TYPED */
03303       parse_typed_function_stmt();
03304       goto EXIT;
03305    }
03306 
03307    check_char_comma             = (TOKEN_VALUE(token) == Tok_Kwd_Character &&
03308                                    LA_CH_VALUE == STAR);
03309    found_colon                  = FALSE;
03310    found_end                    = FALSE;
03311    type_err                     = !parse_type_spec(TRUE);
03312    AT_DCL_ERR(AT_WORK_IDX)      = type_err;
03313    type_idx                     = ATD_TYPE_IDX(AT_WORK_IDX);
03314    array_idx                    = NULL_IDX;
03315 
03316 
03317    if (LA_CH_VALUE == COMMA && (!check_char_comma || stmt_has_double_colon())) {
03318 
03319       if ((STMT_OUT_OF_ORDER(curr_stmt_category, Type_Decl_Stmt) ||
03320            STMT_CANT_BE_IN_BLK(Type_Decl_Stmt, CURR_BLK)) && iss_blk_stk_err()){
03321          /* Block error - intentionally left blank */
03322       }
03323       else {
03324          curr_stmt_category = Declaration_Stmt_Cat;
03325       }
03326 
03327       /* Check that type is defined before it is used. */
03328 
03329       if (TYP_TYPE(type_idx) == Structure &&
03330           !AT_DEFINED(TYP_IDX(type_idx)) && !AT_DCL_ERR(TYP_IDX(type_idx))) {
03331          issue_undefined_type_msg(TYP_IDX(type_idx), 
03332                                   TOKEN_LINE(token),
03333                                   TOKEN_COLUMN(token));
03334       }
03335 
03336       /* Attr_list contains a bit vector of which attrs are specified.  */
03337       /* array_idx contains the index of the array spec, if DIMESION is */
03338       /* specified.  AT_WORK_IDX does not get updated with it, because  */
03339       /* it has to be updated later in case the variable is followed    */
03340       /* by its own dimension.  ie:  REAL,DIMENSION(5),POINTER :: B(:)  */
03341       /* is legal.  Dimension cannot be merged until B is processed.    */
03342 
03343       new_intent        = Intent_Unseen;
03344       attr_list         = parse_attr_spec(&array_idx, &has_parameter);
03345 
03346 # ifdef COARRAY_FORTRAN
03347       if (AT_OBJ_CLASS(AT_WORK_IDX) == Data_Obj) {
03348          pe_array_idx  = ATD_PE_ARRAY_IDX(AT_WORK_IDX);
03349       }
03350 # endif
03351       found_colon       = TRUE;
03352       colon_recovery    = FALSE;        /* Past ::    */
03353    }
03354    else {          /* Not followed by a COMMA  or CHARACTER*8,             */
03355       colon_recovery    = FALSE;  /* No error recovery attempted before :: */
03356 
03357       if (curr_stmt_category == Init_Stmt_Cat) {
03358 
03359          /* Check to see if this is a FUNCTION statement.  Have to go as   */
03360          /* far as the dummy arg list, because the following is a legal    */
03361          /* type dcl statement:  INTEGER FUNCTION A(10)                    */
03362 
03363          save_line              = LA_CH_LINE;
03364          save_column            = LA_CH_COLUMN;
03365          buf_idx                = LA_CH_BUF_IDX;
03366          stmt_num               = LA_CH_STMT_NUM;
03367          possible_func          = TRUE;
03368 
03369          while (MATCHED_TOKEN_CLASS(Tok_Class_Keyword) &&  possible_func) {
03370 
03371             switch(TOKEN_VALUE(token)) {
03372             case Tok_Kwd_Recursive:
03373             case Tok_Kwd_Elemental:
03374             case Tok_Kwd_Pure:
03375                break;
03376 
03377             case Tok_Kwd_Function:
03378 
03379                if (MATCHED_TOKEN_CLASS(Tok_Class_Id) && LA_CH_VALUE == LPAREN) {
03380                   NEXT_LA_CH;
03381 
03382                   if (LA_CH_VALUE == RPAREN || LA_CH_CLASS == Ch_Class_Letter) {
03383 
03384                      /* TRUE = type-spec is parsed - type is in AT_WORK_IDX */
03385                      /* Reset to pick up recursive, pure and elemental and  */
03386                      /* the function name.  This will isolated semantics.   */
03387 
03388                      reset_lex(buf_idx, stmt_num);
03389                      AT_DCL_ERR(AT_WORK_IDX) = SH_ERR_FLG(curr_stmt_sh_idx);
03390                      parse_typed_function_stmt();
03391                      goto EXIT;
03392                   }
03393                }
03394                possible_func    = FALSE;
03395                break;
03396 
03397             default:   /* Tok_Kwd_Id */
03398                possible_func    = FALSE;
03399                break;
03400             }
03401          }
03402 
03403          /* Actually had a match and need to reset and clear attr */
03404          /* INTEGER FUNCTION A(10) in fixed form would get here.  */
03405 
03406          if (LA_CH_LINE != save_line || LA_CH_COLUMN != save_column) {
03407             reset_lex(buf_idx, stmt_num);
03408          }
03409       }
03410 
03411       if (LA_CH_VALUE == COMMA) {
03412          NEXT_LA_CH;
03413       }
03414 
03415       found_colon = matched_specific_token(Tok_Punct_Colon_Colon,
03416                                            Tok_Class_Punct);
03417 
03418       if ((STMT_OUT_OF_ORDER(curr_stmt_category, Type_Decl_Stmt) ||
03419            STMT_CANT_BE_IN_BLK(Type_Decl_Stmt, CURR_BLK)) && iss_blk_stk_err()){
03420             /* Block error - intentionally left blank */
03421       }
03422       else {
03423          curr_stmt_category = Declaration_Stmt_Cat;
03424       }
03425 
03426       if (TYP_TYPE(type_idx) == Structure && !AT_DEFINED(TYP_IDX(type_idx)) && 
03427           !AT_DCL_ERR(TYP_IDX(type_idx))) {
03428          issue_undefined_type_msg(TYP_IDX(type_idx), 
03429                                   AT_DEF_LINE(TYP_IDX(type_idx)),
03430                                   AT_DEF_COLUMN(TYP_IDX(type_idx)));
03431       }
03432    }
03433 
03434    AT_DCL_ERR(AT_WORK_IDX) = SH_ERR_FLG(curr_stmt_sh_idx);
03435 
03436    do {
03437       if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
03438          found_end = !parse_err_flush(Find_Comma, "object-name");
03439          NEXT_LA_CH;
03440          continue;
03441       }
03442 
03443       type_idx          = ATD_TYPE_IDX(AT_WORK_IDX);
03444       attr_idx          = srch_sym_tbl(TOKEN_STR(token),
03445                                        TOKEN_LEN(token), &name_idx);
03446       id_line           = TOKEN_LINE(token);
03447       id_column         = TOKEN_COLUMN(token);
03448       new_attr          = FALSE;
03449       new_array_idx     = array_idx;
03450       new_pe_array_idx  = pe_array_idx;
03451 
03452       /* If the type is assumed size character, we cannot share array bounds */
03453       /* because each object may assume a different size upon entry.         */
03454 
03455       need_new_array    = (TYP_TYPE(type_idx) == Character && 
03456                            TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char);
03457 
03458       if (attr_idx == NULL_IDX) {
03459          attr_idx                       = ntr_sym_tbl(&token, name_idx);
03460          LN_DEF_LOC(name_idx)           = TRUE;
03461          new_attr                       = TRUE;
03462          AT_NAME_LEN(AT_WORK_IDX)       = AT_NAME_LEN(attr_idx);
03463          AT_NAME_IDX(AT_WORK_IDX)       = AT_NAME_IDX(attr_idx);
03464          AT_DEF_LINE(AT_WORK_IDX)       = AT_DEF_LINE(attr_idx);
03465          AT_DEF_COLUMN(AT_WORK_IDX)     = AT_DEF_COLUMN(attr_idx);
03466          COPY_ATTR_NTRY(attr_idx, AT_WORK_IDX);
03467          AT_CIF_SYMBOL_ID(attr_idx)     = 0;
03468 
03469          if (type_err) {
03470             SET_IMPL_TYPE(attr_idx);
03471          }
03472       }
03473       else if (AT_REFERENCED(attr_idx) == Char_Rslt_Bound_Ref) {
03474          AT_ATTR_LINK(attr_idx)         = NULL_IDX;
03475          LN_DEF_LOC(name_idx)           = TRUE;
03476       }
03477 
03478       if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
03479          ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE;
03480       }
03481 
03482       /* Have to merge the intrinsic now, because the INTRINSIC scope has to */
03483       /* be searched and the INTRINSIC attr copied down.  Then all the other */
03484       /* things declared on this line, are added to this the attr.  Check    */
03485       /* semantics if this isn't a new attr.  If this is an INTRINSIC subrtn */
03486       /* the error will be issued from merge_intrinsic whether other         */
03487       /* semantics checking is done or not.                                  */
03488 
03489       if (attr_list & (1 << Intrinsic_Attr)) {
03490          merge_intrinsic(!new_attr, id_line, id_column, attr_idx);
03491       }
03492 
03493       /* Always have to merge_external, because it has to be switched to a   */
03494       /* program unit.  Do semantic checking if this isn't a new attr.       */
03495 
03496       if (attr_list & (1 << External_Attr)) {
03497          merge_external(!new_attr, id_line, id_column, attr_idx);
03498       }
03499 
03500       if (LA_CH_VALUE == LPAREN) { 
03501 
03502          /* If LA_CH is left paren, then a dimension spec is specified on    */
03503          /* the variable name.  This overrides the specification on the      */
03504          /* dimension attribute.                                             */
03505 
03506          new_array_idx  = parse_array_spec(attr_idx);
03507          need_new_array = FALSE;
03508       }
03509 
03510 # ifdef COARRAY_FORTRAN
03511 
03512       if (LA_CH_VALUE == LBRKT && cmd_line_flags.co_array_fortran) {
03513          new_pe_array_idx  = parse_pe_array_spec(attr_idx);
03514       }
03515 # endif
03516 
03517       if (LA_CH_VALUE == STAR) { /* Pick up char len.  LEN = not allowed here */
03518 
03519          /* We are not parsing the character* part of the line, so this    */
03520          /* is not the length_selector.  It is the char-length on the name */
03521 
03522          parse_length_selector(attr_idx, FALSE, FALSE);
03523 
03524          if (TYP_TYPE(type_idx) == Character) {
03525             TYP_DESC(TYP_WORK_IDX)      = TYP_DESC(type_idx);
03526             TYP_DCL_VALUE(TYP_WORK_IDX) = TYP_DCL_VALUE(type_idx);
03527             type_idx                    = ntr_type_tbl();
03528 
03529             if (TYP_CHAR_CLASS(type_idx) != Assumed_Size_Char) {
03530                need_new_array = FALSE;
03531             }
03532 
03533             if (new_attr) {
03534                switch (AT_OBJ_CLASS(attr_idx)) {
03535                case