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

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_dcl_util.c        5.7     10/28/99 10:03:56\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 
00057 /*****************************************************************\
00058 |* function prototypes of static functions declared in this file *|
00059 \*****************************************************************/
00060 
00061 static  int     ntr_bnds_tmp_list(opnd_type *);
00062 static  boolean parse_int_spec_expr(long *, fld_type *, boolean, boolean);
00063 static  void    parse_kind_selector(void);
00064 static  boolean is_attr_referenced_in_bound(int, int);
00065 
00066 
00067 static  boolean kind0seen;
00068 static  boolean kind0E0seen;
00069 static  boolean kind0D0seen;
00070 static  boolean kindconstseen;
00071 
00072 /******************************************************************************\
00073 |*                                                                            *|
00074 |* Description:                                                               *|
00075 |*      Parses the array_spec for declarations                                *|
00076 |*             array_spec is explicit-shape-spec-list                         *|
00077 |*                            is [lower-bound :]upper-bound                   *|
00078 |*                               [specification-expr :] specification-expr    *|
00079 |*                       is assumed-shape-spec-list                           *|
00080 |*                          is [lower-bound] :                                *|
00081 |*                       is deferred-shape-spec-list                          *|
00082 |*                          is :                                              *|
00083 |*                       is assumed-size-spec                                 *|
00084 |*                          is [explicit-shape-spec-list,] [lower-bound:]*    *|
00085 |*                                                                            *|
00086 |*       Position  - entry - token is open paren                              *|
00087 |*                   exit  - token is verified close paren                    *|
00088 |*                           if close paren is missing.  LA_CH is set to      *|
00089 |*                           colon-colon, or EOS                              *|
00090 |*                                                                            *|
00091 |* Returns:                                                                   *|
00092 |*      NONE                                                                  *|
00093 |*                                                                            *|
00094 \******************************************************************************/
00095 int     parse_array_spec(int    attr_idx)
00096 
00097 {
00098    int                  bd_idx;
00099    int                  column;
00100    boolean              fold_it;
00101    boolean              found_end               = FALSE;
00102    boolean              found_error             = FALSE;
00103    fld_type             lb_fld;
00104    long                 lb_len_idx;
00105    int                  line;
00106    boolean              lower_bound_found;
00107    boolean              non_constant_size       = FALSE;
00108    boolean              possible_assumed_shape  = FALSE;
00109    int                  rank                    = 1;
00110    reference_type       referenced;
00111    fld_type             ub_fld;
00112    long                 ub_len_idx;
00113 
00114   
00115    TRACE (Func_Entry, "parse_array_spec", NULL);
00116 
00117 # ifdef _DEBUG
00118    if (LA_CH_VALUE != LPAREN) {
00119       PRINTMSG(LA_CH_LINE, 295, Internal, LA_CH_COLUMN,
00120                "parse_array_spec", "LPAREN");
00121    }
00122 # endif
00123 
00124    NEXT_LA_CH;                                               /* Skip Lparen   */
00125    bd_idx                       = reserve_array_ntry(7);
00126    referenced                   = (reference_type) AT_REFERENCED(attr_idx);
00127    AT_REFERENCED(attr_idx)      = Not_Referenced;
00128    BD_LINE_NUM(bd_idx)          = LA_CH_LINE;
00129    BD_COLUMN_NUM(bd_idx)        = LA_CH_COLUMN;
00130 
00131    /* If LA_CH is RPAREN, there is no dimension, so default to a rank 1       */
00132    /* constant sized array of length 1 and return.                            */
00133 
00134    if (LA_CH_VALUE == RPAREN) {
00135       parse_err_flush(Find_None, "dimension-spec");
00136       BD_ARRAY_CLASS(bd_idx)    = Explicit_Shape;
00137       BD_ARRAY_SIZE(bd_idx)     = Constant_Size;
00138       BD_DCL_ERR(bd_idx)        = TRUE;
00139       BD_RANK(bd_idx)           = 1;
00140       BD_LB_FLD(bd_idx, 1)      = CN_Tbl_Idx;
00141       BD_LB_IDX(bd_idx, 1)      = CN_INTEGER_ONE_IDX;
00142       BD_UB_FLD(bd_idx, 1)      = CN_Tbl_Idx;
00143       BD_UB_IDX(bd_idx, 1)      = CN_INTEGER_ONE_IDX;
00144       NEXT_LA_CH;
00145       goto EXIT;
00146    }
00147 
00148    /* Set fold_it flag.  Will continue on and do pass2 style semantic     */
00149    /* checking and constant folding, if this is a component declaration.  */
00150 
00151    fold_it = (CURR_BLK == Derived_Type_Blk);
00152 
00153    do {  /* Process each dimension of the array */
00154       lower_bound_found         = FALSE;
00155       lb_len_idx                = CN_INTEGER_ONE_IDX;
00156       lb_fld                    = CN_Tbl_Idx;
00157       ub_len_idx                = NULL_IDX;
00158       ub_fld                    = NO_Tbl_Idx;
00159 
00160       if (LA_CH_VALUE != COLON && LA_CH_VALUE != STAR) {
00161          line           = LA_CH_LINE;
00162          column         = LA_CH_COLUMN;
00163 
00164          /* If LA_CH isn't a COLON or a STAR, then this must be an expression.*/
00165          /* Get the expression and determine if it is a lower or upper bound. */
00166          /* If there is a parse error, a constant one is returned.            */
00167 
00168          if (!parse_int_spec_expr(&ub_len_idx, &ub_fld, fold_it, FALSE)) {
00169             ub_len_idx          = CN_INTEGER_ONE_IDX;
00170             ub_fld              = CN_Tbl_Idx;
00171             BD_DCL_ERR(bd_idx)  = TRUE;
00172          }
00173 
00174          if (ub_fld != CN_Tbl_Idx) {
00175             non_constant_size   = TRUE;
00176          }
00177 
00178          if (LA_CH_VALUE == COLON) {                   /* This is lower bound */
00179             lower_bound_found           = TRUE;
00180             possible_assumed_shape      = TRUE;
00181             lb_len_idx                  = ub_len_idx;
00182             lb_fld                      = ub_fld;
00183             ub_len_idx                  = NULL_IDX;
00184             ub_fld                      = NO_Tbl_Idx;
00185          }
00186 
00187          /* If LA_CH isn't a COLON this must be an upper bound.  If it is an  */
00188          /* upper bound and the array has already been classified as deferred */
00189          /* shape, issue an error, because a deferred shape array can never   */
00190          /* have an upper bound.  Otherwise set as an Explicit_Shape array.   */
00191 
00192          else if (BD_ARRAY_CLASS(bd_idx) == Deferred_Shape) {
00193 
00194             /* DIMENSION A(10,:)  --> Illegal - Set Upper bound to NULL_IDX.  */
00195 
00196             ub_len_idx          = NULL_IDX;
00197             ub_fld              = NO_Tbl_Idx;
00198             BD_DCL_ERR(bd_idx)  = TRUE;
00199             PRINTMSG(line, 114, Error, column);
00200          }
00201          else {
00202             BD_ARRAY_CLASS(bd_idx)      = Explicit_Shape;
00203          }
00204       }
00205          
00206       /* Now the parser is in one of 3 states.  1) Lower bound found, upper   */
00207       /* bound = NULL, LA_CH must be COLON.  2) Lower bound not found, so it  */
00208       /* is set to a default of 1, upper bound is found and LA_CH is COMMA or */
00209       /* RPAREN.   (LA_CH must be COLON.)  3) Neither lower bound or upper    */
00210       /* bound have been seen, they are set to defaults of lb=1, ub=NULL.     */
00211       /* LA_CH is COLON or STAR.  If the LA_CH is COLON, this is either a     */
00212       /* Deferred-Shape spec or it is followed by the upper bound for an      */
00213       /* Explicit-Shape spec.  NOTE: LA_CH may be EOS - this is parse error.  */
00214 
00215       if (LA_CH_VALUE == COLON) {
00216          line           = LA_CH_LINE;
00217          column         = LA_CH_COLUMN;
00218          NEXT_LA_CH;                            /* Skip COLON */
00219 
00220          if (LA_CH_VALUE == COMMA || LA_CH_VALUE == RPAREN) {
00221 
00222             /* Have one of two cases  1)  ARRAY(1:)  - This is an assumed     */
00223             /* shape spec which is classed as a Deferred-Shape, or 2) ARRAY(:)*/
00224             /* which is a deferred-Shape spec.   Issue an error if this array */
00225             /* has already been classified as an Explicit_Shape array.        */
00226 
00227             if (BD_ARRAY_CLASS(bd_idx) == Explicit_Shape) {
00228                PRINTMSG(line, 115, Error, column);
00229                BD_DCL_ERR(bd_idx)       = TRUE;
00230             }
00231             else {  /* Must be Deferred-Shape spec */
00232                BD_ARRAY_CLASS(bd_idx)   = Deferred_Shape;
00233             }
00234          }
00235          else {
00236 
00237             /* Have one of two cases  1)  ARRAY (1:10) - legal - pick up upper*/
00238             /* bound expression.  Err if array is already set to Deferred-    */
00239             /* Shape spec.  2) ARRAY (:10) - illegal - issue error.           */
00240             /* If the upper bound is a STAR, pick it up in the next section.  */
00241 
00242             if (!lower_bound_found) {                   /* A(:10) - illegal   */
00243                PRINTMSG(LA_CH_LINE, 119, Error, LA_CH_COLUMN, &LA_CH_VALUE);
00244                BD_DCL_ERR(bd_idx)       = TRUE;
00245             }
00246 
00247             if (LA_CH_VALUE != STAR) {
00248                line     = LA_CH_LINE;
00249                column   = LA_CH_COLUMN;
00250 
00251                if (!parse_int_spec_expr(&ub_len_idx, &ub_fld, fold_it, FALSE)) {
00252 
00253                   /* Expression parser recovers LA_CH to : ) , or EOS */
00254 
00255                   BD_DCL_ERR(bd_idx)    = TRUE;
00256                   ub_len_idx            = CN_INTEGER_ONE_IDX;
00257                   ub_fld                = CN_Tbl_Idx;
00258                }
00259 
00260                if (ub_fld != CN_Tbl_Idx) {
00261                   non_constant_size     = TRUE;
00262                }
00263 
00264                if (BD_ARRAY_CLASS(bd_idx) == Deferred_Shape) { /*A(:,1:2)*/
00265                   PRINTMSG(line, 114, Error, column);
00266                   BD_DCL_ERR(bd_idx)    = TRUE;
00267                   ub_len_idx            = NULL_IDX;
00268                   ub_fld                = NO_Tbl_Idx;
00269                }
00270                else {
00271                   BD_ARRAY_CLASS(bd_idx)= Explicit_Shape;
00272                }
00273             }
00274          }
00275       }
00276 
00277       /* The parser may be:  1)  ARRAY(*) - lb=1, ub=NULL_IDX.  2) ARR(10:*)  */
00278       /* lb is set, and ub=NULL_IDX.  3)  ARRAY(:*) - illegal -error already  */
00279       /* issued.  You could not have picked up a lower bound and/or an upper  */
00280       /* bound and got to this position, because a * is part of an expression.*/
00281       /* The expression parser stops at COLON, COMMA, RPAREN or EOS.          */
00282 
00283       if (LA_CH_VALUE == STAR) {
00284          line   = LA_CH_LINE;
00285          column = LA_CH_COLUMN;
00286          NEXT_LA_CH;                            /* Skip STAR */
00287 
00288          if (BD_ARRAY_CLASS(bd_idx) == Deferred_Shape) {
00289 
00290             /* can't have asterisk with a deferred shape spec */
00291 
00292             PRINTMSG(line, 114, Error, column);
00293             parse_err_flush(Find_Rparen, NULL);
00294             BD_DCL_ERR(bd_idx)  = TRUE;
00295          }
00296          else {
00297             BD_ARRAY_CLASS(bd_idx)      = Assumed_Size;
00298             ub_len_idx                  = lb_len_idx;
00299             ub_fld                      = lb_fld;
00300 
00301             if (LA_CH_VALUE != RPAREN) {
00302  
00303                /* The assumed-size specifier * must be in the last dimension. */
00304 
00305                BD_DCL_ERR(bd_idx)       = TRUE;
00306                PRINTMSG(line, 116, Error, column);
00307                parse_err_flush(Find_Rparen, NULL);
00308             }
00309          }
00310       }
00311 
00312       BD_LB_IDX(bd_idx, rank)   = lb_len_idx;
00313       BD_LB_FLD(bd_idx, rank)   = lb_fld;
00314       BD_UB_IDX(bd_idx, rank)   = ub_len_idx;
00315       BD_UB_FLD(bd_idx, rank)   = ub_fld;
00316 
00317       if (LA_CH_VALUE == COMMA) {
00318 
00319          if (rank++ == 7) {          /* issue error - too many ranks */
00320             found_end           = TRUE;
00321             BD_DCL_ERR(bd_idx)  = TRUE;
00322             PRINTMSG(LA_CH_LINE, 117, Error, LA_CH_COLUMN);
00323             parse_err_flush(Find_Rparen, NULL);
00324          }
00325          else {
00326             NEXT_LA_CH;
00327          }
00328       }
00329       else {
00330          found_end = TRUE;
00331       }
00332 
00333       found_error = BD_DCL_ERR(bd_idx) | found_error;
00334    }
00335    while (!found_end);
00336 
00337    if (LA_CH_VALUE == RPAREN || 
00338        parse_err_flush(Find_Rparen, (found_error) ? NULL : ", or )")) {
00339 
00340       NEXT_LA_CH;               /* Skip RPAREN */
00341    }
00342 
00343    if (BD_ARRAY_CLASS(bd_idx) == Deferred_Shape) {
00344 
00345       if (possible_assumed_shape) {
00346          BD_ARRAY_CLASS(bd_idx) = Assumed_Shape;
00347       }
00348    }
00349    else if (!non_constant_size) {
00350       BD_ARRAY_SIZE(bd_idx) = Constant_Size;
00351    }
00352 
00353    BD_RANK(bd_idx) = rank;
00354 
00355 # ifdef _DEBUG
00356    if (BD_ARRAY_CLASS(bd_idx) == Unknown_Array) {
00357 
00358       /* There is a parsing problem here.  This must never be Unknown_Array */
00359 
00360       PRINTMSG(LA_CH_LINE, 178, Internal, LA_CH_COLUMN);
00361    }
00362 # endif
00363 
00364 EXIT:
00365 
00366    if (AT_REFERENCED(attr_idx) > Not_Referenced) {
00367       is_attr_referenced_in_bound(bd_idx, attr_idx);
00368    }
00369 
00370    if (AT_REFERENCED(attr_idx) < referenced) {
00371       AT_REFERENCED(attr_idx)   = referenced;
00372    }
00373 
00374    bd_idx = ntr_array_in_bd_tbl(bd_idx);
00375 
00376    TRACE (Func_Exit, "parse_array_spec", NULL);
00377 
00378    return(bd_idx);
00379 
00380 }  /* parse_array_spec */
00381 
00382 
00383 /******************************************************************************\
00384 |*                                                                            *|
00385 |* Description:                                                               *|
00386 |*      Parse a POSSIBLE generic spec.                                        *|
00387 |*                                                                            *|
00388 |*      Input position  : The identifier, OPERATOR, or ASSIGNMENT token.      *|
00389 |*      Output position : The comma or EOS after the interface or id.         *|
00390 |*      Called By       : parse_access_stmt, parse_interface_stmt,            *|
00391 |*                        parse_use_stmt                                      *|
00392 |*                                                                            *|
00393 |* Input parameters:                                                          *|
00394 |*      NONE                                                                  *|
00395 |*                                                                            *|
00396 |* Output parameters:                                                         *|
00397 |*      NONE                                                                  *|
00398 |*                                                                            *|
00399 |* Returns:                                                                   *|
00400 |*      TRUE if parsed spec.  FALSE if found a fatal error.                   *|
00401 |*                                                                            *|
00402 \******************************************************************************/
00403 
00404 boolean parse_generic_spec(void)
00405 
00406 {
00407    boolean      parse_ok;
00408 
00409 
00410    TRACE (Func_Entry, "parse_generic_spec", NULL);
00411 
00412    if (MATCHED_TOKEN_CLASS(Tok_Class_Keyword)) {
00413       parse_ok  = TRUE;
00414 
00415       if (TOKEN_VALUE(token) == Tok_Id) {
00416          /* Intentionally left blank */
00417       }
00418       else if (TOKEN_VALUE(token) == Tok_Kwd_Assignment &&
00419                LA_CH_VALUE == LPAREN) {
00420          NEXT_LA_CH;                            /* Pick up LPAREN */
00421  
00422          if (LA_CH_VALUE == EQUAL) {
00423 
00424             MATCHED_TOKEN_CLASS(Tok_Class_Op);
00425 
00426             if (TOKEN_VALUE(token) == Tok_Op_Assign) {
00427 
00428                if (LA_CH_VALUE == RPAREN || parse_err_flush(Find_Rparen, ")")) {
00429                   NEXT_LA_CH;                   /* Pick up RPAREN */
00430                }
00431             }
00432             else {
00433                PRINTMSG(TOKEN_LINE(token), 197, Error, TOKEN_COLUMN(token),
00434                         "=", TOKEN_STR(token));
00435                parse_ok = FALSE;
00436 
00437                if (parse_err_flush(Find_Rparen, NULL)) {
00438                   NEXT_LA_CH;                         /* Pick up RPAREN */
00439                }
00440             }
00441          }
00442          else if (parse_err_flush(Find_Rparen, "=")) {
00443             parse_ok = FALSE;
00444             NEXT_LA_CH;                         /* Pick up RPAREN */
00445          }
00446       }
00447       else if (TOKEN_VALUE(token) == Tok_Kwd_Operator && 
00448                LA_CH_VALUE == LPAREN) {
00449          NEXT_LA_CH;                            /* Pick up LPAREN */
00450 
00451          if (MATCHED_TOKEN_CLASS(Tok_Class_Op)) {
00452 
00453             switch (TOKEN_VALUE(token)) {
00454                case Tok_Const_True:
00455                case Tok_Const_False:
00456                   parse_ok = FALSE;
00457                   PRINTMSG(TOKEN_LINE(token), 499, Error, TOKEN_COLUMN(token));
00458                   break;
00459 
00460                case Tok_Op_Deref:
00461                case Tok_Op_Ptr_Assign:
00462                case Tok_Op_Assign:
00463                   parse_ok = FALSE;
00464                   PRINTMSG(TOKEN_LINE(token), 300, Error, TOKEN_COLUMN(token));
00465                   break;
00466 
00467                case Tok_Op_Eq :
00468                   TOKEN_STR(token)[0] = 'e';
00469                   TOKEN_STR(token)[1] = 'q';
00470                   break;
00471 
00472                case Tok_Op_Ge :
00473                   TOKEN_STR(token)[0] = 'g';
00474                   TOKEN_STR(token)[1] = 'e';
00475                   break;
00476 
00477                case Tok_Op_Gt :
00478                   TOKEN_STR(token)[0] = 'g';
00479                   TOKEN_STR(token)[1] = 't';
00480                   break;
00481 
00482                case Tok_Op_Le :
00483                   TOKEN_STR(token)[0] = 'l';
00484                   TOKEN_STR(token)[1] = 'e';
00485                   break;
00486 
00487                case Tok_Op_Lt :
00488                   TOKEN_STR(token)[0] = 'l';
00489                   TOKEN_STR(token)[1] = 't';
00490                   break;
00491 
00492                case Tok_Op_Ne :
00493                   TOKEN_STR(token)[0] = 'n';
00494                   TOKEN_STR(token)[1] = 'e';
00495                   break;
00496 
00497                case Tok_Op_Lg :
00498                   TOKEN_STR(token)[0] = 'l';
00499                   TOKEN_STR(token)[1] = 'g';
00500                   break;
00501 
00502                default:
00503                   break;
00504             }
00505 
00506             if (LA_CH_VALUE == RPAREN || parse_err_flush(Find_Rparen, ")")) {
00507                   NEXT_LA_CH;                           /* Pick up RPAREN */
00508             }
00509          }
00510          else if (LA_CH_VALUE == SLASH) {
00511 
00512             /* this clause is needed  because lex thinks that "/)" is an */
00513             /* array constructor punctuator.                             */
00514 
00515             TOKEN_STR(token)[0] = LA_CH_VALUE;
00516             TOKEN_VALUE(token)  = Tok_Op_Div;
00517             TOKEN_LEN(token)    = 1;
00518             NEXT_LA_CH;
00519 
00520             if (LA_CH_VALUE == RPAREN || parse_err_flush(Find_Rparen, ")")) {
00521                   NEXT_LA_CH;                           /* Pick up RPAREN */
00522             }
00523          }
00524          else if (parse_err_flush(Find_Rparen, "defined-operator")) {
00525             parse_ok = FALSE;
00526             NEXT_LA_CH;         /* Pick up RPAREN */
00527          }
00528       }
00529       else {
00530          reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
00531          MATCHED_TOKEN_CLASS(Tok_Class_Id);
00532       }
00533    }
00534    else {
00535       parse_err_flush(Find_Comma, "OPERATOR or ASSIGNMENT or generic-name");
00536       parse_ok = FALSE;
00537    }
00538 
00539    TRACE (Func_Exit, "parse_generic_spec", NULL);
00540    return(parse_ok);
00541 
00542 }  /* parse_generic_spec */
00543 
00544 
00545 /******************************************************************************\
00546 |*                                                                            *|
00547 |* Description:                                                               *|
00548 |*      BNF       - intent-spec   is  IN  or  OUT  or INOUT                   *|
00549 |*                                                                            *|
00550 |* Input parameters:                                                          *|
00551 |*      NONE                                                                  *|
00552 |*                                                                            *|
00553 |* Output parameters:                                                         *|
00554 |*      NONE                                                                  *|
00555 |*                                                                            *|
00556 |* Returns:                                                                   *|
00557 |*      intent_type - Returns the INTENT value.  Default is Intent_Inout if   *|
00558 |*                    there is an error.  Otherwise it's whatever was parsed. *|
00559 |*                                                                            *|
00560 \******************************************************************************/
00561 
00562 intent_type     parse_intent_spec()
00563 
00564 {
00565    char         *err_str        = NULL;
00566    intent_type   intent         = Intent_Inout;
00567 
00568 
00569    TRACE (Func_Entry, "parse_intent_spec", NULL);
00570 
00571    if (LA_CH_VALUE != LPAREN) {
00572       err_str = "(";
00573    }
00574    else {
00575       NEXT_LA_CH;                       /* Skip Lparen */
00576 
00577       if (matched_specific_token(Tok_Kwd_In, Tok_Class_Keyword)) {
00578 
00579          if (!matched_specific_token(Tok_Kwd_Out, Tok_Class_Keyword)) {
00580             intent = Intent_In;
00581          }
00582       }
00583       else if (matched_specific_token(Tok_Kwd_Out, Tok_Class_Keyword)) {
00584          intent = Intent_Out;
00585       }
00586       else {
00587          parse_err_flush(Find_Rparen, "IN or OUT or INOUT");
00588          intent = Intent_Unseen;        /* Signal parse error */
00589       }
00590 
00591       if (LA_CH_VALUE == RPAREN) {
00592          NEXT_LA_CH;                    /* Skip Rparen */
00593       }
00594       else {
00595          err_str = ")";
00596       }
00597    }
00598 
00599    if (err_str != NULL) {
00600       parse_err_flush(Find_Rparen, err_str);
00601       matched_specific_token(Tok_Punct_Rparen, Tok_Class_Punct);
00602       intent = Intent_Unseen;
00603    }
00604 
00605    TRACE (Func_Exit, "parse_intent_spec", NULL);
00606 
00607    return(intent);
00608 
00609 }  /* parse_intent_spec */
00610 
00611 
00612 /******************************************************************************\
00613 |*                                                                            *|
00614 |* Description:                                                               *|
00615 |*      BNF       - ([KIND =] scalar-int-initialization-expr)                 *|
00616 |*      Position  - entry - Token before start of expression                  *|
00617 |*                  exit  - Token at end of expression                        *|
00618 |*                                                                            *|
00619 |*      QUESTIONS:  Need to know what the expression parser is going to do,   *|
00620 |*                  if it hits an error?   Need to advance to the end of the  *|
00621 |*                  specification expression.                                 *|
00622 |*                                                                            *|
00623 |* Input parameters:                                                          *|
00624 |*      NONE                                                                  *|
00625 |*                                                                            *|
00626 |* Output parameters:                                                         *|
00627 |*      NONE                                                                  *|
00628 |*                                                                            *|
00629 |* Returns:                                                                   *|
00630 |*      NOTHING                                                               *|
00631 |*                                                                            *|
00632 \******************************************************************************/
00633  
00634 static  void    parse_kind_selector(void)
00635 
00636 {
00637    int          al_idx;
00638    fld_type     field_type;
00639    long         kind_idx;
00640    opnd_type    opnd;
00641 
00642 
00643    TRACE (Func_Entry, "parse_kind_selector", NULL);
00644 
00645    if (matched_specific_token(Tok_Kwd_Kind, Tok_Class_Keyword) &&
00646        !matched_specific_token(Tok_Punct_Eq, Tok_Class_Punct)) {
00647       reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
00648    }
00649 
00650    OPND_LINE_NUM(opnd)  = LA_CH_LINE;
00651    OPND_COL_NUM(opnd)   = LA_CH_COLUMN;
00652 
00653    /* Always FOLD - These should be constants.  If not - it's fatal error. */
00654 
00655    parsing_kind_selector = TRUE;
00656    kind0seen = FALSE;
00657    kind0E0seen = FALSE;
00658    kind0D0seen = FALSE;
00659    kindconstseen = FALSE;
00660 
00661    if (parse_int_spec_expr(&kind_idx, &field_type, TRUE, FALSE)) {
00662       OPND_FLD(opnd)            = field_type;
00663       OPND_IDX(opnd)            = kind_idx;
00664 
00665       if (!kind_to_linear_type(&opnd,
00666                                AT_WORK_IDX,
00667                                kind0seen,
00668                                kind0E0seen,
00669                                kind0D0seen,
00670                                kindconstseen)) {
00671          AT_DCL_ERR(AT_WORK_IDX)        = TRUE;
00672       }
00673 
00674 # if !defined(_TARGET_OS_MAX)
00675 
00676       if (!on_off_flags.enable_double_precision &&
00677           (TYP_TYPE(ATD_TYPE_IDX(AT_WORK_IDX)) == Complex ||
00678            TYP_TYPE(ATD_TYPE_IDX(AT_WORK_IDX)) == Real) &&
00679           TYP_DCL_VALUE(ATD_TYPE_IDX(AT_WORK_IDX)) == 16) {
00680          PRINTMSG(OPND_LINE_NUM(opnd), 586, Warning, OPND_COL_NUM(opnd));
00681       }
00682 # endif
00683 
00684 #if 0 /*works well for source-level translation ----fzhao*/
00685 # if defined(_TARGET_OS_LINUX)
00686       if ((TYP_TYPE(ATD_TYPE_IDX(AT_WORK_IDX)) == Complex ||
00687            TYP_TYPE(ATD_TYPE_IDX(AT_WORK_IDX)) == Real) &&
00688           TYP_DCL_VALUE(ATD_TYPE_IDX(AT_WORK_IDX)) == 16) {
00689          PRINTMSG(OPND_LINE_NUM(opnd), 541, Error, OPND_COL_NUM(opnd));
00690       }
00691 # endif
00692 #endif
00693       if (field_type == AT_Tbl_Idx) {
00694 
00695          /* Mark tmp not referenced and remove it from the tmp list.  This */
00696          /* tmp was not shared when it was entered into the bounds list.   */
00697 
00698          AT_REFERENCED(kind_idx)        = Not_Referenced;
00699          al_idx                         = SCP_TMP_FW_IDX(curr_scp_idx);
00700          SCP_TMP_FW_IDX(curr_scp_idx)   = AL_NEXT_IDX(al_idx);
00701       }
00702    }
00703 
00704    parsing_kind_selector = FALSE;
00705 
00706    TRACE (Func_Exit, "parse_kind_selector", NULL);
00707 
00708    return;
00709 
00710 }  /* parse_kind_selector */
00711 
00712 
00713 /******************************************************************************\
00714 |*                                                                            *|
00715 |* Description:                                                               *|
00716 |*   If i_can_have_len_equal                                                  *|
00717 |*      BNF - [LEN =] type-param-value                                        *|
00718 |*   If !(i_can_have_len_equal)                                               *|
00719 |*      BNF - *(type-param-value)  OR *scalar-int-literal-constant            *|
00720 |*   type-param-value IS   specification-expr OR *                            *|
00721 |*                                                                            *|
00722 |*   Position  - entry - token is token following (                           *|
00723 |*                       or following LEN=                                    *|
00724 |*                       or *                                                 *|
00725 |*               exit  - LA is comma or right paren or EOS                    *|
00726 |*                                                                            *|
00727 |* Input parameters:                                                          *|
00728 |*      i_can_have_len_equal - LEN = is allowed.  See description.            *|
00729 |*      parsing_length_selector - We are parsing the length-selector on the   *|
00730 |*                              CHARACTER statement, as opposed to parsing    *|
00731 |*                              the char-length on a variable name in a list. *|
00732 |*                              This is needed for the obsolescence message.  *|
00733 |*                                                                            *|
00734 |* Output parameters:                                                         *|
00735 |*      NONE                                                                  *|
00736 |*                                                                            *|
00737 |* Returns:                                                                   *|
00738 |*      TRUE if there are no errors, else FALSE                               *|
00739 |*                                                                            *|
00740 \******************************************************************************/
00741 void    parse_length_selector(int       attr_idx,
00742                               boolean   i_can_have_len_equal,
00743                               boolean   parsing_length_selector)
00744 
00745 {
00746    type_char_type       char_class      = Unknown_Char;
00747    int                  column;
00748    fld_type             field_type;
00749    boolean              fold_it;
00750    long                 len_idx;
00751    int                  line;
00752    opnd_type            opnd;
00753    reference_type       referenced;
00754 
00755 
00756    TRACE (Func_Entry, "parse_length_selector", NULL);
00757 
00758    /* Set fold_it flag.  Will continue on and do pass2 style semantic     */
00759    /* checking and constant folding, if this is a component declaration.  */
00760   
00761    fold_it                      = (CURR_BLK == Derived_Type_Blk);
00762    referenced                   = (reference_type) AT_REFERENCED(attr_idx);
00763    AT_REFERENCED(attr_idx)      = Not_Referenced;
00764 
00765    CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
00766 
00767    if (i_can_have_len_equal) {
00768 
00769       if (matched_specific_token(Tok_Kwd_Len, Tok_Class_Keyword) &&
00770           !matched_specific_token(Tok_Punct_Eq, Tok_Class_Punct)) {
00771          reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
00772       }
00773       line              = LA_CH_LINE;
00774       column            = LA_CH_COLUMN;
00775 
00776       if (LA_CH_VALUE == STAR) {
00777          NEXT_LA_CH;
00778          len_idx        = 0;
00779          field_type     = NO_Tbl_Idx;
00780          char_class     = Assumed_Size_Char;
00781       }
00782       else {
00783 
00784          if (!parse_int_spec_expr(&len_idx, &field_type, fold_it, TRUE)) {
00785             len_idx     = CN_INTEGER_ONE_IDX;
00786             field_type  = CN_Tbl_Idx;
00787          }
00788 
00789          if (field_type != AT_Tbl_Idx) {
00790             char_class  = Const_Len_Char;
00791          }
00792       }
00793    }
00794    else {
00795       NEXT_LA_CH;                    /* Skip Star */
00796 
00797       if (LA_CH_VALUE == LPAREN) {   /*    *(*)  or *(length)   */
00798          NEXT_LA_CH;  /* Skip Lparen */
00799          line           = LA_CH_LINE;
00800          column         = LA_CH_COLUMN;
00801 
00802          if (LA_CH_VALUE == STAR) {
00803             NEXT_LA_CH;
00804             len_idx     = 0;
00805             field_type  = NO_Tbl_Idx;
00806             char_class  = Assumed_Size_Char;
00807          }
00808          else {
00809 
00810             if (!parse_int_spec_expr(&len_idx, &field_type, fold_it, TRUE)) {
00811                len_idx          = CN_INTEGER_ONE_IDX;
00812                field_type       = CN_Tbl_Idx;
00813             }
00814 
00815             if (field_type != AT_Tbl_Idx) {
00816                char_class       = Const_Len_Char;
00817             }
00818          }
00819 
00820          if (LA_CH_VALUE == RPAREN || parse_err_flush(Find_Rparen, ")")) {
00821             NEXT_LA_CH;                 /* Skip Rparen */
00822          }
00823       }
00824       else if (MATCHED_TOKEN_CLASS(Tok_Class_Int_Spec)) {
00825          len_idx        = TOKEN_CONST_TBL_IDX(token);
00826          field_type     = CN_Tbl_Idx;
00827          char_class     = Const_Len_Char;
00828          line           = TOKEN_LINE(token);
00829          column         = TOKEN_COLUMN(token);
00830 
00831          if (parsing_length_selector) {
00832             PRINTMSG(line, 1563, Comment, column); /* Obsolescent */
00833          }
00834       }
00835       else {
00836          line           = LA_CH_LINE;
00837          column         = LA_CH_COLUMN;
00838          len_idx        = CN_INTEGER_ONE_IDX;
00839          field_type     = CN_Tbl_Idx;
00840          char_class     = Const_Len_Char;
00841          parse_err_flush(Find_None, "scalar-int-literal-constant or (");
00842       }
00843    }
00844 
00845    if (char_class == Assumed_Size_Char && CURR_BLK == Derived_Type_Blk) {
00846 
00847       /* Components cannot be assumed size character. */
00848       
00849       PRINTMSG(line, 191, Error, column);
00850       char_class        = Const_Len_Char;
00851       len_idx           = CN_INTEGER_ONE_IDX;
00852       field_type        = CN_Tbl_Idx;
00853    }
00854   
00855    if (AT_REFERENCED(attr_idx) > Not_Referenced) {
00856 
00857       /* The attr was referenced in the dimension bound describing the attr. */
00858       /* Find the reference to the attr, so that we can issue a really good  */
00859       /* error message.  It's a little compile time, but it's a fatal error. */
00860 
00861       AT_DCL_ERR(attr_idx)      = TRUE;
00862 
00863       if (field_type == AT_Tbl_Idx &&
00864           ATD_FLD(len_idx) == IR_Tbl_Idx &&
00865           find_attr_in_ir(attr_idx, ATD_TMP_IDX(len_idx), &opnd)) {
00866          PRINTMSG(OPND_LINE_NUM(opnd), 1035, Error,
00867                   OPND_COL_NUM(opnd),
00868                   AT_OBJ_NAME_PTR(attr_idx));
00869          len_idx        = CN_INTEGER_ONE_IDX;
00870          field_type     = CN_Tbl_Idx;
00871       }
00872    }
00873 
00874    if (AT_REFERENCED(attr_idx) < referenced) {
00875       AT_REFERENCED(attr_idx)   = referenced;
00876    }
00877 
00878    TYP_TYPE(TYP_WORK_IDX)               = Character;
00879    TYP_LINEAR(TYP_WORK_IDX)             = CHARACTER_DEFAULT_TYPE;
00880    TYP_CHAR_CLASS(TYP_WORK_IDX)         = char_class;
00881    TYP_FLD(TYP_WORK_IDX)                = field_type;
00882    TYP_IDX(TYP_WORK_IDX)                = len_idx;
00883 
00884    TRACE (Func_Exit, "parse_length_selector", NULL);
00885 
00886    return;
00887 
00888 }  /* parse_length_selector */
00889 
00890 /******************************************************************************\
00891 |*                                                                            *|
00892 |* Description:                                                               *|
00893 |*                                                                            *|
00894 |*      BNF    - is INTEGER [kind-selector]                                   *|
00895 |*               or REAL    [kind-selector]                                   *|
00896 |*               or COMPLEX [kind-selector]                                   *|
00897 |*               or LOGICAL [kind-selector]                                   *|
00898 |*               or TYPE(type-name)                                           *|
00899 |*               or DOUBLE PRECISION                                          *|
00900 |*               or DOUBLE COMPLEX                                            *|
00901 |*               CHARACTER [char-selector]                                    *|
00902 |*                         where char_selector is                             *|
00903 |*               * (type-param-value)                                         *|
00904 |*               * scalar-int-literal-constant                                *|
00905 |*               ([LEN=] type-param-value)                                    *|
00906 |*               (LEN=type-param-value,KIND=scalar-int-initialization-exp)    *|
00907 |*               (type-param-value, [KIND=] scalar-int-initialization-exp)    *|
00908 |*               (KIND=scalar-int-initialization-exp [,LEN=type-param-value]) *|
00909 |*                                                                            *|
00910 |* Input parameters:                                                          *|
00911 |*      chk_kind - TRUE if check for kind (or kind/len for character) on type *|
00912 |*                      spec                                                  *|
00913 |*                                                                            *|
00914 |* Output parameters:                                                         *|
00915 |*      NONE                                                                  *|
00916 |*                                                                            *|
00917 |* Returns:                                                                   *|
00918 |*      TRUE is statement parsed okay.  (There may be fatal errors. )         *|
00919 |*      FALSE if first token is not INTEGER, REAL, COMPLEX, LOGICAL, TYPE     *|
00920 |*            DOUBLE or CHARACTER.  ATD_TYPE_IDX will be NULL??               *|
00921 |*      FALSE if this is found to be an assignment statement.                 *|
00922 |*      Note: In case of error and stmt_type is known, the only searching     *|
00923 |*            will be for a right paren, if a left one has been found.        *|
00924 |*                                                                            *|
00925 \******************************************************************************/
00926 
00927 boolean parse_type_spec(boolean         chk_kind)
00928 
00929 {
00930    int                   al_idx;
00931    int                   attr_idx;
00932    int                   column;
00933    boolean               do_kind_first;
00934    boolean               double_precision       = FALSE;
00935    int                   host_attr_idx;
00936    int                   host_name_idx;
00937    int                   line;
00938    linear_type_type      linear_type;
00939    int                   name_idx;
00940    long                  num;
00941    boolean               parse_err              = FALSE;
00942    boolean               save_err               = FALSE;
00943    boolean               type_done              = FALSE;
00944    int                   type_idx;
00945    char                 *type_str;
00946 
00947 
00948    TRACE (Func_Entry, "parse_type_spec", NULL);
00949    
00950    if (SH_ERR_FLG(curr_stmt_sh_idx)) {
00951       SH_ERR_FLG(curr_stmt_sh_idx)      = FALSE;
00952       save_err                          = TRUE;
00953    }
00954 
00955    CLEAR_ATTR_NTRY(AT_WORK_IDX);
00956 
00957    switch (TOKEN_VALUE(token)) {
00958    case Tok_Kwd_Byte:
00959       PRINTMSG(TOKEN_LINE(token), 1253, Ansi, TOKEN_COLUMN(token), "BYTE");
00960       ATD_TYPE_IDX(AT_WORK_IDX) = Integer_1;
00961       break;
00962 
00963    case Tok_Kwd_Integer:
00964       ATD_TYPE_IDX(AT_WORK_IDX) = INTEGER_DEFAULT_TYPE;
00965       break;
00966 
00967    case Tok_Kwd_Real:
00968       ATD_TYPE_IDX(AT_WORK_IDX) = REAL_DEFAULT_TYPE;
00969       break;
00970 
00971    case Tok_Kwd_Complex:
00972       ATD_TYPE_IDX(AT_WORK_IDX) = COMPLEX_DEFAULT_TYPE;
00973       break;
00974 
00975    case Tok_Kwd_Logical:
00976       ATD_TYPE_IDX(AT_WORK_IDX) = LOGICAL_DEFAULT_TYPE;
00977       break;
00978 
00979    case Tok_Kwd_Character:
00980       line                      = TOKEN_LINE(token);
00981       column                    = TOKEN_COLUMN(token);
00982       ATD_TYPE_IDX(AT_WORK_IDX) = CHARACTER_DEFAULT_TYPE;
00983 
00984       if (LA_CH_VALUE == LPAREN) {
00985 
00986          if (chk_kind) {
00987             NEXT_LA_CH;                         /* Skip LPAREN */
00988             do_kind_first = FALSE;
00989 
00990             if (LA_CH_VALUE == 'K' &&
00991                 matched_specific_token(Tok_Kwd_Kind, Tok_Class_Keyword)) {
00992 
00993                if (LA_CH_VALUE == EQUAL) {
00994                   do_kind_first = TRUE;
00995                }
00996                reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
00997             }
00998 
00999             if (do_kind_first) {
01000                parse_kind_selector();
01001 
01002                if (LA_CH_VALUE == COMMA) {
01003                   NEXT_LA_CH;                   /* Skip comma */
01004 
01005                   /* We can have length equal and we are parsing the */
01006                   /* length selector.  Hence  TRUE, TRUE.            */
01007 
01008                   parse_length_selector(AT_WORK_IDX, TRUE, TRUE);
01009                   TYP_DCL_VALUE(TYP_WORK_IDX)   = TYP_DCL_VALUE(ATD_TYPE_IDX(
01010                                                                 AT_WORK_IDX));
01011                   TYP_DESC(TYP_WORK_IDX) = TYP_DESC(ATD_TYPE_IDX(AT_WORK_IDX));
01012                   ATD_TYPE_IDX(AT_WORK_IDX) = ntr_type_tbl();
01013                }
01014             }
01015             else {
01016 
01017                /* We can have length equal and we are parsing the */
01018                /* length selector.  Hence  TRUE, TRUE.            */
01019 
01020                parse_length_selector(AT_WORK_IDX, TRUE, TRUE);
01021                ATD_TYPE_IDX(AT_WORK_IDX)        = ntr_type_tbl();
01022 
01023                if (LA_CH_VALUE == COMMA) {
01024                   NEXT_LA_CH;                   /* Skip comma */
01025                   parse_kind_selector();
01026                }
01027             }
01028 
01029             if (LA_CH_VALUE == RPAREN || parse_err_flush(Find_Rparen, ")")) {
01030                NEXT_LA_CH;                      /* Skip Rparen */
01031             }
01032          }
01033       }
01034       else if (LA_CH_VALUE == STAR) {
01035 
01036          /* This can't have LEN =, so pass FALSE */
01037          /* TRUE means this is a length-selector */
01038 
01039          parse_length_selector(AT_WORK_IDX, FALSE, TRUE);
01040          ATD_TYPE_IDX(AT_WORK_IDX)      = ntr_type_tbl();
01041       }
01042 
01043       type_done = TRUE;
01044       break;
01045 
01046 
01047    case Tok_Kwd_Double:
01048       line      = TOKEN_LINE(token);
01049       column    = TOKEN_COLUMN(token);
01050 
01051       if (LA_CH_VALUE == 'C' &&
01052           matched_specific_token(Tok_Kwd_Complex, Tok_Class_Keyword)) {
01053 
01054 # if defined(_TARGET_OS_MAX)
01055 
01056          if (!on_off_flags.enable_double_precision) {
01057             PRINTMSG(line, 20, Ansi, column);
01058          }
01059          else if (cmd_line_flags.s_default32) {
01060 
01061             /* Use DOUBLE COMPLEX because -sdefault32 is built into the macro.*/
01062 
01063             PRINTMSG(line, 20, Ansi, column);
01064          }
01065          else {
01066             PRINTMSG(line, 702, Error, column);
01067          }
01068 # else
01069          PRINTMSG(line, 20, Ansi, column);
01070 # endif
01071 
01072          ATD_TYPE_IDX(AT_WORK_IDX)      = DOUBLE_COMPLEX_TYPE_IDX;
01073          type_done                      = TRUE;
01074       }
01075       else if (LA_CH_VALUE == 'P' &&
01076                matched_specific_token(Tok_Kwd_Precision, Tok_Class_Keyword)) {
01077 
01078          ATD_TYPE_IDX(AT_WORK_IDX)      = DOUBLE_PRECISION_TYPE_IDX;
01079 
01080 # ifdef _TARGET_OS_MAX
01081 
01082          if (! cmd_line_flags.s_default32 &&
01083              on_off_flags.enable_double_precision) {
01084             PRINTMSG(line, 1110, Warning, column);
01085             ATD_TYPE_IDX(AT_WORK_IDX)   = REAL_DEFAULT_TYPE;
01086          }
01087 # endif
01088 
01089          double_precision               = TRUE;
01090 
01091          if (LA_CH_VALUE != STAR) {     /* Kind is not allowed */
01092             type_done                   = TRUE;
01093          }
01094       }
01095       else {
01096          type_done                      = TRUE;
01097          ATD_TYPE_IDX(AT_WORK_IDX)      = DOUBLE_PRECISION_TYPE_IDX;
01098          parse_err_flush(Find_None, "COMPLEX or PRECISION");
01099       }
01100       break;
01101 
01102 
01103    case Tok_Kwd_Type:
01104 
01105       if (LA_CH_VALUE != LPAREN) {
01106          parse_err_flush(Find_None, "(");
01107          ATD_TYPE_IDX(AT_WORK_IDX) = TYPELESS_DEFAULT_TYPE;
01108       }
01109       else {
01110          NEXT_LA_CH;                            /* Skip Lparen */
01111 
01112          if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
01113             parse_err_flush(Find_Rparen, "type-name");
01114          }
01115          else if (LA_CH_VALUE == RPAREN) {
01116             attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token),
01117                                     &name_idx);
01118 
01119             if (attr_idx == NULL_IDX) {       /* search host sym table */
01120                host_attr_idx = srch_host_sym_tbl(TOKEN_STR(token),
01121                                                  TOKEN_LEN(token),
01122                                                  &host_name_idx,
01123                                                  FALSE);
01124 
01125                if (host_attr_idx == NULL_IDX) {
01126                   attr_idx                      = ntr_sym_tbl(&token, name_idx);
01127                   AT_OBJ_CLASS(attr_idx)        = Derived_Type;
01128                   AT_LOCKED_IN(attr_idx)        = TRUE;
01129                   ATT_STRUCT_BIT_LEN_FLD(attr_idx)      = CN_Tbl_Idx;
01130                   ATT_STRUCT_BIT_LEN_IDX(attr_idx)      = CN_INTEGER_ZERO_IDX;
01131                }
01132                else if (stmt_type == Implicit_Stmt ||
01133                         stmt_type == Function_Stmt) {
01134 
01135                   /* Enter into the local scope, and link to the host's    */
01136                   /* attr.  Cannot lock in on this, because it may be      */
01137                   /* defined later in this scope.  Cannot issue error if   */
01138                   /* it's not a derived type for the same reason.          */
01139                   /* Catch AT_NOT_VISIBLE stuff when this is resolved.     */
01140 
01141                   /* ntr_host_in_sym_tbl just makes a new empty attr and   */
01142                   /* attr links it to the host_attr_idx.                   */
01143 
01144                   attr_idx = ntr_host_in_sym_tbl(&token,
01145                                                  name_idx,
01146                                                  host_attr_idx,
01147                                                  host_name_idx,
01148                                                  TRUE);
01149 
01150                   if (AT_OBJ_CLASS(host_attr_idx) == Derived_Type) {
01151                      COPY_ATTR_NTRY(attr_idx, host_attr_idx);
01152                      AT_CIF_SYMBOL_ID(attr_idx) = 0;
01153                      AT_DEF_LINE(attr_idx)      = TOKEN_LINE(token);
01154                      AT_DEF_COLUMN(attr_idx)    = TOKEN_COLUMN(token);
01155                      AT_LOCKED_IN(attr_idx)     = FALSE;
01156                      AT_ATTR_LINK(attr_idx)     = host_attr_idx;
01157                   }
01158                   else {
01159                      AT_OBJ_CLASS(attr_idx)             = Derived_Type;
01160                      ATT_STRUCT_BIT_LEN_FLD(attr_idx)   = CN_Tbl_Idx;
01161                      ATT_STRUCT_BIT_LEN_IDX(attr_idx)   = CN_INTEGER_ZERO_IDX;
01162                   }
01163                }
01164                else if (AT_OBJ_CLASS(host_attr_idx) == Derived_Type &&
01165                         !AT_NOT_VISIBLE(host_attr_idx)) {
01166 
01167                   /* Lock into using the host definition */
01168 
01169                   attr_idx = ntr_host_in_sym_tbl(&token,
01170                                                  name_idx,
01171                                                  host_attr_idx,
01172                                                  host_name_idx,
01173                                                  TRUE);
01174 
01175                   COPY_ATTR_NTRY(attr_idx, host_attr_idx);
01176                   AT_CIF_SYMBOL_ID(attr_idx)    = 0;
01177                   AT_DEF_LINE(attr_idx)         = TOKEN_LINE(token);
01178                   AT_DEF_COLUMN(attr_idx)       = TOKEN_COLUMN(token);
01179                   AT_ATTR_LINK(attr_idx)        = host_attr_idx;
01180                   AT_LOCKED_IN(attr_idx)        = TRUE;
01181                }
01182                else if (!fnd_semantic_err(Obj_Use_Derived_Type, 
01183                                           TOKEN_LINE(token),
01184                                           TOKEN_COLUMN(token),
01185                                           host_attr_idx,
01186                                           TRUE)) {
01187 
01188                   /* Has just PUBLIC or PRIVATE set.  Lock into using the  */
01189                   /* host definition.                                      */
01190 
01191                   attr_idx = ntr_host_in_sym_tbl(&token,
01192                                                  name_idx,
01193                                                  host_attr_idx,
01194                                                  host_name_idx,
01195                                                  TRUE);
01196 
01197                   AT_DEF_LINE(attr_idx)         = TOKEN_LINE(token);
01198                   AT_DEF_COLUMN(attr_idx)       = TOKEN_COLUMN(token);
01199                   AT_LOCKED_IN(attr_idx)        = TRUE;
01200                }
01201                else {  /* Lock into this use.  Issue error - create new    */
01202                        /* local attr to hopefully prevent error escalation.*/
01203                        /* Need to make this a better msg, because it comes */
01204                        /* from the host.                                   */
01205 
01206                   attr_idx                      = ntr_sym_tbl(&token, name_idx);
01207                   AT_OBJ_CLASS(attr_idx)        = Derived_Type;
01208                   AT_DCL_ERR(attr_idx)          = TRUE;
01209                   AT_LOCKED_IN(attr_idx)        = TRUE;
01210                   ATT_STRUCT_BIT_LEN_FLD(attr_idx)      = CN_Tbl_Idx;
01211                   ATT_STRUCT_BIT_LEN_IDX(attr_idx)      = CN_INTEGER_ZERO_IDX;
01212                }
01213             }
01214             else if (AT_OBJ_CLASS(attr_idx) == Derived_Type &&
01215                      !AT_NOT_VISIBLE(attr_idx)) {
01216                AT_LOCKED_IN(attr_idx)   = TRUE;
01217             }
01218             else if (AT_ATTR_LINK(attr_idx) != NULL_IDX) {
01219                host_attr_idx = AT_ATTR_LINK(attr_idx);
01220 
01221                while (AT_ATTR_LINK(host_attr_idx) != NULL_IDX) {
01222                   host_attr_idx = AT_ATTR_LINK(host_attr_idx);
01223                }
01224 
01225                if (AT_OBJ_CLASS(host_attr_idx) == Derived_Type) {
01226                   CLEAR_VARIANT_ATTR_INFO(attr_idx, Derived_Type);
01227                   ATT_STRUCT_BIT_LEN_FLD(attr_idx)      = CN_Tbl_Idx;
01228                   ATT_STRUCT_BIT_LEN_IDX(attr_idx)      = CN_INTEGER_ZERO_IDX;
01229                   AT_LOCKED_IN(attr_idx)        = TRUE;
01230                }
01231                else {
01232                   PRINTMSG(TOKEN_LINE(token), 956, Error, 
01233                            TOKEN_COLUMN(token),
01234                            AT_OBJ_NAME_PTR(attr_idx));
01235                   CREATE_ERR_ATTR(attr_idx, TOKEN_LINE(token),
01236                                             TOKEN_COLUMN(token),
01237                                             Derived_Type);
01238                   ATT_STRUCT_BIT_LEN_FLD(attr_idx)      = CN_Tbl_Idx;
01239                   ATT_STRUCT_BIT_LEN_IDX(attr_idx)      = CN_INTEGER_ZERO_IDX;
01240 
01241                   /* Switch the name table to use the new attr, to limit      */
01242                   /* cascading errors for derived type definitions.           */
01243 
01244                   LN_ATTR_IDX(name_idx)         = attr_idx;
01245                   LN_NAME_IDX(name_idx)         = AT_NAME_IDX(attr_idx);
01246                   AT_LOCKED_IN(attr_idx)        = TRUE;
01247                }
01248             }
01249             else if (!fnd_semantic_err(Obj_Use_Derived_Type,
01250                                        TOKEN_LINE(token),
01251                                        TOKEN_COLUMN(token),
01252                                        attr_idx,
01253                                        TRUE)) {
01254 
01255                /* Has just PUBLIC or PRIVATE set */
01256 
01257                CLEAR_VARIANT_ATTR_INFO(attr_idx, Derived_Type);
01258                ATT_STRUCT_BIT_LEN_FLD(attr_idx) = CN_Tbl_Idx;
01259                ATT_STRUCT_BIT_LEN_IDX(attr_idx) = CN_INTEGER_ZERO_IDX;
01260                AT_LOCKED_IN(attr_idx)   = TRUE;
01261             }
01262             else {
01263                CREATE_ERR_ATTR(attr_idx, TOKEN_LINE(token),
01264                                          TOKEN_COLUMN(token), 
01265                                          Derived_Type);
01266                ATT_STRUCT_BIT_LEN_FLD(attr_idx) = CN_Tbl_Idx;
01267                ATT_STRUCT_BIT_LEN_IDX(attr_idx) = CN_INTEGER_ZERO_IDX;
01268 
01269                /* Add replaced attr to cif error list, so it gets a cif rec */
01270                /* Switch the name table to use the new attr, to limit       */
01271                /* cascading errors for derived type definitions.            */
01272 
01273                NTR_ATTR_LIST_TBL(al_idx);
01274                AL_ATTR_IDX(al_idx)      = LN_ATTR_IDX(name_idx);
01275                AL_NEXT_IDX(al_idx)      = SCP_CIF_ERR_LIST(curr_scp_idx);
01276                SCP_CIF_ERR_LIST(curr_scp_idx)   = al_idx;
01277 
01278                LN_ATTR_IDX(name_idx)    = attr_idx;
01279                LN_NAME_IDX(name_idx)    = AT_NAME_IDX(attr_idx);
01280                AT_LOCKED_IN(attr_idx)   = TRUE;
01281 
01282             }
01283 
01284             if ((cif_flags & XREF_RECS) != 0) {
01285       
01286                if (AT_ATTR_LINK(attr_idx) == NULL_IDX) {
01287                   host_attr_idx = attr_idx;
01288                }
01289                else {
01290                   host_attr_idx = AT_ATTR_LINK(attr_idx);
01291 
01292                   while (AT_ATTR_LINK(host_attr_idx) != NULL_IDX) {
01293                      host_attr_idx = AT_ATTR_LINK(host_attr_idx);
01294                   }
01295                }
01296 
01297                cif_usage_rec(host_attr_idx, 
01298                              AT_Tbl_Idx,
01299                              TOKEN_LINE(token),
01300                              TOKEN_COLUMN(token),
01301                              CIF_Derived_Type_Name_Reference);
01302             }
01303             
01304             CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
01305             TYP_TYPE(TYP_WORK_IDX)      = Structure;
01306             TYP_LINEAR(TYP_WORK_IDX)    = Structure_Type;
01307             TYP_IDX(TYP_WORK_IDX)       = attr_idx;
01308 
01309             ATD_TYPE_IDX(AT_WORK_IDX)   = ntr_type_tbl();
01310  
01311             ATT_TY_IDX(attr_idx) = ATD_TYPE_IDX(AT_WORK_IDX); 
01312 
01313             NEXT_LA_CH;                 /* Skip Rparen */
01314          }
01315          else {
01316             ATD_TYPE_IDX(AT_WORK_IDX) = TYPELESS_DEFAULT_TYPE;
01317             parse_err_flush(Find_Rparen, ")");
01318          }
01319       }
01320 
01321       type_done = TRUE;
01322       break;
01323 
01324 
01325    default:
01326       ATD_TYPE_IDX(AT_WORK_IDX) = TYPELESS_DEFAULT_TYPE;
01327       type_done                 = TRUE;
01328       PRINTMSG(TOKEN_LINE(token), 197, Error, TOKEN_COLUMN(token),
01329                "INTEGER, REAL, DOUBLE, COMPLEX, LOGICAL, CHARACTER or TYPE",
01330                TOKEN_STR(token));
01331       break;
01332 
01333    }  /* end switch */
01334             
01335    AT_TYPED(AT_WORK_IDX) = TRUE;
01336 
01337    if (!type_done) {
01338 
01339       if (chk_kind && LA_CH_VALUE == LPAREN) {
01340            
01341          NEXT_LA_CH;                    /* Skip Lparen */
01342          parse_kind_selector();
01343 
01344          if (LA_CH_VALUE == RPAREN || parse_err_flush(Find_Rparen,  ")")) {
01345             NEXT_LA_CH;                 /* Skip Rparen */
01346          }
01347       }
01348       else if (LA_CH_VALUE == STAR) {
01349          NEXT_LA_CH;                    /* Skip Star */
01350 
01351          if (MATCHED_TOKEN_CLASS(Tok_Class_Int_Spec)) {
01352             num         = (long) CN_INT_TO_C(TOKEN_CONST_TBL_IDX(token));
01353             linear_type = Err_Res;
01354             type_idx    = ATD_TYPE_IDX(AT_WORK_IDX);
01355             type_str    = basic_type_str[TYP_TYPE(type_idx)];
01356 
01357             switch (TYP_TYPE(type_idx)) {
01358 
01359             case Integer:
01360                   
01361                switch (num) {
01362 
01363                case 1:
01364                   linear_type = (cmd_line_flags.s_cf77types) ?
01365                                 INTEGER_DEFAULT_TYPE : Integer_1;
01366                   break;
01367 
01368                case 2:
01369                   linear_type = (cmd_line_flags.s_cf77types) ?
01370                                 INTEGER_DEFAULT_TYPE : Integer_2;
01371                   break;
01372 
01373                case 4:
01374                   linear_type = (cmd_line_flags.s_cf77types) ?
01375                                 INTEGER_DEFAULT_TYPE : Integer_4;
01376                   break;
01377 
01378                case 8:
01379                   linear_type = (cmd_line_flags.s_cf77types) ?
01380                                 INTEGER_DEFAULT_TYPE : Integer_8;
01381                   break;
01382 
01383                };
01384 
01385             break;
01386 
01387 
01388             case Real:
01389 
01390                if (double_precision) {
01391                   type_str      = "DOUBLE PRECISION";
01392 
01393                   if (num == 16) {
01394 
01395 # ifdef _TARGET_OS_MAX /* Msg was issued when DOUBLE PRECISION was parsed.*/
01396                      linear_type = Real_8;
01397 /* works well for source-level translation--fzhao
01398 # elif defined(_TARGET_OS_LINUX)
01399                      PRINTMSG(TOKEN_LINE(token), 541, Error, 
01400                               TOKEN_COLUMN(token));
01401 */
01402 # else
01403                      linear_type = Real_16;
01404 
01405                      if (!on_off_flags.enable_double_precision) {
01406                         PRINTMSG(TOKEN_LINE(token), 710, Warning, 
01407                                  TOKEN_COLUMN(token),
01408                                  type_str,
01409                                  num);
01410                      }
01411 # endif
01412                   }
01413                }
01414                else {
01415                   switch (num) {
01416 
01417                   case 4:
01418                      linear_type = (cmd_line_flags.s_cf77types) ?
01419                                    REAL_DEFAULT_TYPE : Real_4;
01420                      break;
01421 
01422                   case 8:
01423                      linear_type = (cmd_line_flags.s_cf77types) ?
01424                                    REAL_DEFAULT_TYPE : Real_8;
01425                      break;
01426 
01427                   case 16:
01428 
01429 # ifdef _TARGET_OS_MAX
01430                      PRINTMSG(TOKEN_LINE(token), 391, Warning,
01431                               TOKEN_COLUMN(token),
01432                               type_str, num, type_str, 8);
01433                      linear_type = Real_8;
01434 
01435 /* works well for source level translation---fzhao
01436 # elif defined(_TARGET_OS_LINUX)
01437                      PRINTMSG(TOKEN_LINE(token), 541, Error, 
01438                               TOKEN_COLUMN(token));
01439 */
01440 # else
01441                      linear_type = Real_16;
01442 
01443                      if (!on_off_flags.enable_double_precision) {
01444                         PRINTMSG(TOKEN_LINE(token), 710, Warning, 
01445                                  TOKEN_COLUMN(token),
01446                                  type_str,
01447                                  num);
01448                      }
01449 # endif
01450                      break;
01451                   };
01452                }
01453 
01454                break;
01455 
01456 
01457             case Complex:
01458 
01459                switch (num) {
01460 
01461                case 8:
01462                   linear_type = (cmd_line_flags.s_cf77types) ?
01463                                 COMPLEX_DEFAULT_TYPE : Complex_4;
01464                   break;
01465 
01466                case 16:
01467                   linear_type = Complex_8;
01468                   break;
01469 
01470                case 32:
01471 
01472 # ifdef _TARGET_OS_MAX
01473                   PRINTMSG(TOKEN_LINE(token), 391, Warning, 
01474                            TOKEN_COLUMN(token),
01475                            type_str, num, type_str, 16);
01476                   linear_type = Complex_8;
01477 
01478 /* works well for source-level translation---fzhao
01479  *# elif defined(_TARGET_OS_LINUX)
01480  *                     PRINTMSG(TOKEN_LINE(token), 541, Error, 
01481  *                              TOKEN_COLUMN(token));
01482 */
01483 # else
01484                   linear_type = Complex_16;
01485 
01486                   if (!on_off_flags.enable_double_precision) {
01487                      PRINTMSG(TOKEN_LINE(token), 710, Warning, 
01488                               TOKEN_COLUMN(token),
01489                               type_str,
01490                               num);
01491                   }
01492 # endif
01493                   break;
01494                };
01495 
01496                break;
01497 
01498 
01499             case Logical:
01500 
01501                switch (num) {
01502 
01503                case 1:
01504                   linear_type = (cmd_line_flags.s_cf77types) ?
01505                                 LOGICAL_DEFAULT_TYPE : Logical_1;
01506                   break;
01507 
01508                case 2:
01509                   linear_type = (cmd_line_flags.s_cf77types) ?
01510                                 LOGICAL_DEFAULT_TYPE : Logical_2;
01511                   break;
01512 
01513                case 4:
01514                   linear_type = (cmd_line_flags.s_cf77types) ?
01515                                 LOGICAL_DEFAULT_TYPE : Logical_4;
01516                   break;
01517 
01518                case 8:
01519                   linear_type = (cmd_line_flags.s_cf77types) ?
01520                                 LOGICAL_DEFAULT_TYPE : Logical_8;
01521                   break;
01522 
01523                };  /* end switch */
01524 
01525                break;
01526 
01527             }  /* end switch */
01528 
01529 
01530             if (linear_type == Err_Res) {
01531                PRINTMSG(TOKEN_LINE(token), 125, Error,
01532                         TOKEN_COLUMN(token),
01533                         num,
01534                         type_str);
01535             }
01536             else {
01537                CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
01538                TYP_TYPE(TYP_WORK_IDX)           = TYP_TYPE(type_idx);
01539                TYP_LINEAR(TYP_WORK_IDX)         = linear_type;
01540                TYP_DCL_VALUE(TYP_WORK_IDX)      = num;
01541                TYP_DESC(TYP_WORK_IDX)           = Star_Typed;
01542                ATD_TYPE_IDX(AT_WORK_IDX)        = ntr_type_tbl();
01543 
01544                PRINTMSG(TOKEN_LINE(token), 124, Ansi, 
01545                         TOKEN_COLUMN(token),
01546                         type_str,
01547                         num);
01548 
01549             }
01550          }
01551          else { /* Cannot search - because of IMPLICIT calls */
01552             parse_err_flush(Find_None, "scalar-int-literal-constant");
01553          }
01554       }
01555    }
01556 
01557 
01558 #if 0
01559 
01560    /* LRR    2 Feb 1996                                                       */
01561    /* I turned off the following code in response to an email direction to do */
01562    /* so from Peggy Boike.  I did not remove the code due to the belief that  */
01563    /* we just might need to turn it back on.  If some months go by, and the   */
01564    /* libraries really can handle this, then the code should be safe to       */
01565    /* actually be removed.                                                    */
01566 
01567    if ((target_triton  &&  target_ieee)   &&
01568        (TYP_LINEAR(ATD_TYPE_IDX(AT_WORK_IDX)) == Real_16  ||
01569        TYP_LINEAR(ATD_TYPE_IDX(AT_WORK_IDX)) == Complex_16)) {
01570 
01571       /* Temporary warning because PRECISION may not be as high as requested */
01572 
01573       PRINTMSG(TOKEN_LINE(token), 1145, Warning, 0);
01574       SET_MSG_SUPPRESS_TBL(1145);  /* Issue once per compilation unit */
01575    }
01576 
01577 #endif
01578 
01579 
01580    parse_err                    = SH_ERR_FLG(curr_stmt_sh_idx);
01581    SH_ERR_FLG(curr_stmt_sh_idx) = save_err || parse_err;
01582 
01583    TRACE (Func_Exit, "parse_type_spec", NULL);
01584 
01585    return (!parse_err);
01586 
01587 }  /* parse_type_spec */
01588 
01589 
01590 /******************************************************************************\
01591 |*                                                                            *|
01592 |* Description:                                                               *|
01593 |*      Add the PUBLIC or PRIVATE attribute to an attr.                       *|
01594 |*                                                                            *|
01595 |* Input parameters:                                                          *|
01596 |*      attr_idx -> Attr index to add the PUBLIC or PRIVATE access to.        *|
01597 |*      line     -> The line number of the object to add the attribute to     *|
01598 |*      column   -> The line number of the object to add the attribute to     *|
01599 |*      access   -> Public or Private                                         *|
01600 |*                                                                            *|
01601 |* Output parameters:                                                         *|
01602 |*      NONE                                                                  *|
01603 |*                                                                            *|
01604 |* Returns:                                                                   *|
01605 |*      TRUE if successful merge.                                             *|
01606 |*                                                                            *|
01607 \******************************************************************************/
01608 
01609 boolean merge_access(int                attr_idx,
01610                      int                line,
01611                      int                column,
01612                      access_type        access)
01613 
01614 {
01615    boolean      err_found;
01616    int          sn_idx;
01617 
01618 
01619    TRACE (Func_Entry, "merge_access", NULL);
01620 
01621    /* Error if access is already set, or if it is host associated */
01622 
01623    err_found = ((AT_ACCESS_SET(attr_idx) && access != AT_PRIVATE(attr_idx)) ||
01624                  AT_NOT_VISIBLE(attr_idx) ||
01625                 (AT_ATTR_LINK(attr_idx) != NULL_IDX));
01626 
01627    switch (AT_OBJ_CLASS(attr_idx)) {
01628       case Data_Obj:
01629 
01630          if (ATD_SYMBOLIC_CONSTANT(attr_idx)) {
01631             err_found = TRUE;
01632          }
01633          break;
01634 
01635       case Pgm_Unit:
01636          if (ATP_PROC(attr_idx) == Intrin_Proc ||
01637              ATP_PGM_UNIT(attr_idx) == Program ||
01638              ATP_PGM_UNIT(attr_idx) == Module ||
01639              ATP_PGM_UNIT(attr_idx) == Blockdata) {
01640             err_found = TRUE;
01641          }
01642          break;
01643 
01644       case Interface:
01645          break;
01646 
01647       case Stmt_Func:
01648          err_found = TRUE;
01649          break;
01650 
01651       case Label:
01652          err_found = TRUE;
01653          break;
01654 
01655       default:
01656          break;
01657 
01658    }  /* end switch */
01659 
01660 
01661 # ifdef _DEBUG
01662 
01663    /* Check to make sure that this routine is catching everything in the  */
01664    /* semantic tables, because it only calls fnd_semantic_err if it finds */
01665    /* an error.                                                           */
01666 
01667    if (!err_found &&
01668        fnd_semantic_err(((access == Public) ? Obj_Public : Obj_Private),
01669                         line, 
01670                         column,
01671                         attr_idx,
01672                         TRUE)) {
01673       PRINTMSG(line, 655, Internal, column, "merge_access");
01674    }
01675 # endif
01676 
01677    if (err_found) {
01678       fnd_semantic_err(((access == Public) ? Obj_Public : Obj_Private),
01679                        line,
01680                        column,
01681                        attr_idx,
01682                        TRUE);
01683    }
01684    else {
01685 
01686       if (AT_ACCESS_SET(attr_idx)) {  /* Duplicate declaration */
01687          PRINTMSG(line, 1259, Ansi, column,
01688                   AT_OBJ_NAME_PTR(attr_idx),
01689                   (access == Public) ? "PUBLIC":"PRIVATE");
01690       }
01691 
01692       AT_PRIVATE(attr_idx)      = access;
01693       AT_ACCESS_SET(attr_idx)   = TRUE;
01694 
01695       if (AT_OBJ_CLASS(attr_idx) == Interface) { 
01696 
01697          if (AT_IS_INTRIN(attr_idx)) {
01698             sn_idx      = ATI_FIRST_SPECIFIC_IDX(attr_idx);
01699 
01700             while (sn_idx != NULL_IDX) {
01701 
01702                if (AT_IS_INTRIN(SN_ATTR_IDX(sn_idx))) {
01703                   AT_PRIVATE(SN_ATTR_IDX(sn_idx))       = access;
01704                   AT_ACCESS_SET(SN_ATTR_IDX(sn_idx))    = TRUE;
01705                }
01706                sn_idx = SN_SIBLING_LINK(sn_idx);
01707             }
01708          }
01709          else if (ATI_PROC_IDX(attr_idx) != NULL_IDX) {
01710             AT_PRIVATE(ATI_PROC_IDX(attr_idx))          = access;
01711             AT_ACCESS_SET(ATI_PROC_IDX(attr_idx))       = TRUE;
01712          }
01713       }
01714    }
01715 
01716    TRACE (Func_Exit, "merge_access", NULL);
01717 
01718    return(!err_found);
01719 
01720 }  /* merge_access */
01721 
01722 
01723 /******************************************************************************\
01724 |*                                                                            *|
01725 |* Description:                                                               *|
01726 |*      Add the ALLOCATABLE attribute to an attr.                             *|
01727 |*                                                                            *|
01728 |* Input parameters:                                                          *|
01729 |*      chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
01730 |*                       is FALSE, just add the attribute to the attr.        *|
01731 |*      line     -> The line number of the object to add the attribute to     *|
01732 |*      column   -> The line number of the object to add the attribute to     *|
01733 |*      attr_idx -> Attr index to add the ALLOCATABLE attribute to.           *|
01734 |*                                                                            *|
01735 |* Output parameters:                                                         *|
01736 |*      NONE                                                                  *|
01737 |*                                                                            *|
01738 |* Returns:                                                                   *|
01739 |*      TRUE if successful merge.                                             *|
01740 |*                                                                            *|
01741 \******************************************************************************/
01742 
01743 boolean merge_allocatable(boolean chk_semantics,
01744                           int     line,
01745                           int     column,
01746                           int     attr_idx)
01747 
01748 {
01749    boolean      fnd_err         = FALSE;
01750 
01751 
01752    TRACE (Func_Entry, "merge_allocatable", NULL);
01753 
01754    if (chk_semantics) {
01755       fnd_err = fnd_semantic_err(Obj_Allocatable,
01756                                  line,
01757                                  column,
01758                                  attr_idx,
01759                                  TRUE);
01760       if (!fnd_err) {
01761 
01762          if (ATD_ALLOCATABLE(attr_idx)) {
01763             PRINTMSG(line, 1259, Ansi, column,
01764                      AT_OBJ_NAME_PTR(attr_idx),
01765                      "ALLOCATABLE");
01766          }
01767          ATD_ALLOCATABLE(attr_idx) = TRUE;
01768 /*          ATD_IM_A_DOPE(attr_idx)   = TRUE; */
01769       }
01770    }
01771    else {
01772       SET_IMPL_TYPE(attr_idx);
01773       ATD_ALLOCATABLE(attr_idx) = TRUE;
01774 /*      ATD_IM_A_DOPE(attr_idx)   = TRUE; */
01775    }
01776 
01777 
01778    TRACE (Func_Exit, "merge_allocatable", NULL);
01779 
01780    return(!fnd_err);
01781 
01782 }  /* merge_allocatable */
01783 
01784 
01785 
01786 /******************************************************************************\
01787 |*                                                                            *|
01788 |* Description:                                                               *|
01789 |*      Add the AUTOMATIC attribute to an attr.                               *|
01790 |*                                                                            *|
01791 |* Input parameters:                                                          *|
01792 |*      chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
01793 |*                       is FALSE, just add the attribute to the attr.        *|
01794 |*      line     -> The line number of the object to add the attribute to     *|
01795 |*      column   -> The line number of the object to add the attribute to     *|
01796 |*      attr_idx -> Attr index to add the AUTOMATIC attribute to.             *|
01797 |*                                                                            *|
01798 |* Output parameters:                                                         *|
01799 |*      NONE                                                                  *|
01800 |*                                                                            *|
01801 |* Returns:                                                                   *|
01802 |*      TRUE if successful merge.                                             *|
01803 |*                                                                            *|
01804 \******************************************************************************/
01805 
01806 boolean merge_automatic(boolean         chk_semantics,
01807                         int             line,
01808                         int             column,
01809                         int             attr_idx)
01810 
01811 {
01812    boolean      fnd_err         = FALSE;
01813    int          rslt_idx;
01814 
01815 
01816    TRACE (Func_Entry, "merge_automatic", NULL);
01817 
01818    if (chk_semantics) {
01819       fnd_err = fnd_semantic_err(Obj_Automatic,
01820                                  line,
01821                                  column,
01822                                  attr_idx,
01823                                  TRUE);
01824 
01825       if (!fnd_err && AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {
01826 
01827          if (ATP_RSLT_IDX(attr_idx) == NULL_IDX) {
01828             CREATE_FUNC_RSLT(attr_idx, rslt_idx);
01829             ATP_PGM_UNIT(attr_idx)      = Function;
01830             SET_IMPL_TYPE(rslt_idx);
01831             attr_idx                    = rslt_idx;
01832          }
01833          else {
01834             attr_idx = ATP_RSLT_IDX(attr_idx);
01835             fnd_err  = fnd_semantic_err(Obj_Automatic, 
01836                                         line,
01837                                         column,
01838                                         attr_idx,
01839                                         TRUE);
01840          }
01841       }
01842 
01843       if (!fnd_err && ATD_CLASS(attr_idx) == Function_Result &&
01844           (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character ||
01845            TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure ||
01846            ATD_ARRAY_IDX(attr_idx) != NULL_IDX ||
01847            ATD_POINTER(attr_idx))) {
01848          AT_DCL_ERR(attr_idx)   = TRUE;
01849          fnd_err                        = TRUE;
01850          PRINTMSG(line, 1255, Error, column, AT_OBJ_NAME_PTR(attr_idx));
01851       }
01852 
01853       if (!fnd_err) {
01854 
01855          if (ATD_STACK(attr_idx)) {
01856             PRINTMSG(line, 1259, Ansi, column,
01857                      AT_OBJ_NAME_PTR(attr_idx),
01858                      "AUTOMATIC");
01859          }
01860          ATD_STACK(attr_idx) = TRUE;
01861       }
01862    }
01863    else {
01864       SET_IMPL_TYPE(attr_idx);
01865       ATD_STACK(attr_idx) = TRUE;
01866    }
01867 
01868    TRACE (Func_Exit, "merge_automatic", NULL);
01869 
01870    return(!fnd_err);
01871 
01872 }  /* merge_automatic */
01873 
01874 
01875 /******************************************************************************\
01876 |*                                                                            *|
01877 |* Description:                                                               *|
01878 |*      Add the DIMENSION attribute to an attr.                               *|
01879 |*                                                                            *|
01880 |* Input parameters:                                                          *|
01881 |*      attr_idx -> Attr index to add the ALLOCATABLE attribute to.           *|
01882 |*      line     -> The line number of the object to add the attribute to     *|
01883 |*      column   -> The line number of the object to add the attribute to     *|
01884 |*      array_idx-> The index of the bounds table index to add to the attr.   *|
01885 |*                                                                            *|
01886 |* Output parameters:                                                         *|
01887 |*      NONE                                                                  *|
01888 |*                                                                            *|
01889 |* Returns:                                                                   *|
01890 |*      TRUE if successful merge.                                             *|
01891 |*                                                                            *|
01892 \******************************************************************************/
01893 
01894 boolean merge_dimension(int     attr_idx,
01895                         int     line,
01896                         int     column,
01897                         int     array_idx)
01898 
01899 {
01900    obj_type             dcl_type;
01901    boolean              err_fnd;
01902    int                  i;
01903    int                  old_bd_idx;
01904    int                  rslt_idx;
01905    boolean              same;
01906 
01907 
01908    TRACE (Func_Entry, "merge_dimension", NULL);
01909 
01910    if (BD_DCL_ERR(array_idx)) {  /* Don't try if bad array declaration */
01911       AT_DCL_ERR(attr_idx)      = TRUE;
01912       err_fnd                   = TRUE;
01913       goto EXIT;
01914    }
01915        
01916    switch (BD_ARRAY_CLASS(array_idx)) {
01917 
01918       case Explicit_Shape:
01919          dcl_type = Obj_Expl_Shp_Arr;
01920          break;
01921 
01922       case Deferred_Shape:
01923          dcl_type = Obj_Defrd_Shp_Arr;
01924          break;
01925 
01926       case Assumed_Size:
01927          dcl_type = Obj_Assum_Size_Arr;
01928          break;
01929 
01930       case Assumed_Shape:
01931          dcl_type = Obj_Assum_Shp_Arr;
01932          break;
01933 
01934    }  /* End switch */
01935 
01936    if (AT_OBJ_CLASS(attr_idx) == Interface && 
01937        ATI_PROC_IDX(attr_idx) != NULL_IDX) {
01938        attr_idx = ATI_PROC_IDX(attr_idx);
01939    }
01940 
01941    if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit && ATP_PGM_UNIT(attr_idx) != Module) {
01942       rslt_idx = ATP_RSLT_IDX(attr_idx);
01943 
01944       if (rslt_idx != NULL_IDX) {       /* Has a function result already */
01945 
01946          if (ATP_RSLT_NAME(attr_idx) && !AT_NOT_VISIBLE(attr_idx)) {
01947             PRINTMSG(line, 27, Error, column, AT_OBJ_NAME_PTR(attr_idx),
01948                      AT_OBJ_NAME_PTR(rslt_idx));
01949             AT_DCL_ERR(attr_idx)        = TRUE;
01950             AT_DCL_ERR(rslt_idx)        = TRUE;
01951          }
01952          else {
01953 
01954             if (AT_REFERENCED(attr_idx) > Not_Referenced &&
01955                 is_attr_referenced_in_bound(array_idx, attr_idx)) {
01956                err_fnd  = TRUE;
01957             }
01958             else {
01959                err_fnd = fnd_semantic_err(dcl_type,
01960                                           line,
01961                                           column,
01962                                           attr_idx,
01963                                           TRUE);
01964             }
01965 
01966             if (!err_fnd) {
01967 
01968                if (ATD_ARRAY_IDX(rslt_idx) != NULL_IDX) {
01969 
01970                   /* This has an array declaration already.  Is it the same? */
01971 
01972                   old_bd_idx    = ATD_ARRAY_IDX(rslt_idx);
01973                   same          = (old_bd_idx == array_idx);
01974 
01975                   if (!same && 
01976                       BD_ARRAY_CLASS(old_bd_idx)==BD_ARRAY_CLASS(array_idx)&&
01977                       BD_RANK(old_bd_idx) == BD_RANK(array_idx) &&
01978                       BD_ARRAY_SIZE(old_bd_idx) == BD_ARRAY_SIZE(array_idx)){
01979 
01980                      if (BD_ARRAY_CLASS(array_idx) != Deferred_Shape) {
01981                         same    = TRUE;
01982 
01983                         for (i = 1; i <= BD_RANK(array_idx); i++) {
01984 
01985                            if (BD_UB_FLD(old_bd_idx,i)!=BD_UB_FLD(array_idx,i)||
01986                                (BD_UB_FLD(old_bd_idx,i) == AT_Tbl_Idx &&
01987                               BD_UB_IDX(old_bd_idx,i)!=BD_UB_IDX(array_idx,i))||
01988                                (BD_UB_FLD(old_bd_idx,i) == CN_Tbl_Idx &&
01989                                 fold_relationals(BD_UB_IDX(old_bd_idx,i),
01990                                                  BD_UB_IDX(array_idx,i),
01991                                                  Ne_Opr)) ||
01992                                BD_LB_FLD(old_bd_idx,i)!=BD_LB_FLD(array_idx,i)||
01993                                (BD_LB_FLD(old_bd_idx,i) == AT_Tbl_Idx &&
01994                               BD_LB_IDX(old_bd_idx,i)!=BD_LB_IDX(array_idx,i))||
01995                                (BD_LB_FLD(old_bd_idx,i) == CN_Tbl_Idx &&
01996                                 fold_relationals(BD_LB_IDX(old_bd_idx,i),
01997                                                  BD_LB_IDX(array_idx,i),
01998                                                  Ne_Opr))) {
01999                               same      = FALSE;
02000                               break;
02001                            }
02002                         }
02003                      }
02004                   }
02005 
02006                   if (same) {
02007                      PRINTMSG(line, 1259, Ansi, column, 
02008                               AT_OBJ_NAME_PTR(rslt_idx), "DIMENSION");
02009                   }
02010                   else {
02011                      PRINTMSG(line, 554, Error, column, 
02012                               AT_OBJ_NAME_PTR(rslt_idx), "DIMENSION",
02013                               "DIMENSION");
02014                   }
02015                }
02016                else {
02017                   ATD_ARRAY_IDX(rslt_idx) = array_idx;
02018                }
02019             }
02020 
02021             if (ATP_RECURSIVE(attr_idx) && !on_off_flags.recursive) {
02022                PRINTMSG(line, 184, Caution, column, AT_OBJ_NAME_PTR(attr_idx));
02023             }
02024          }
02025       }
02026       else {
02027 
02028          if (AT_REFERENCED(attr_idx) > Not_Referenced &&
02029              is_attr_referenced_in_bound(array_idx, attr_idx)) {
02030             err_fnd     = TRUE;
02031          }
02032          else {
02033             err_fnd = fnd_semantic_err(dcl_type,
02034                                        line,
02035                                        column,
02036                                        attr_idx,
02037                                        TRUE);
02038          }
02039 
02040          /* This must be a Function if it's legal */
02041 
02042          if (!err_fnd) {
02043             CREATE_FUNC_RSLT(attr_idx, rslt_idx);
02044             ATP_PGM_UNIT(attr_idx)      = Function;
02045             ATD_ARRAY_IDX(rslt_idx)     = array_idx;
02046             SET_IMPL_TYPE(rslt_idx);
02047          }
02048       }
02049    }
02050    else {
02051       if (AT_REFERENCED(attr_idx) > Not_Referenced &&
02052           is_attr_referenced_in_bound(array_idx, attr_idx)) {
02053          err_fnd        = TRUE;
02054       }
02055       else {
02056          err_fnd = fnd_semantic_err(dcl_type,
02057                                     line,
02058                                     column,
02059                                     attr_idx,
02060                                     TRUE);
02061       }
02062          
02063       if (!err_fnd) {
02064 
02065          if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
02066 
02067             /* This has an array declaration already.  Is it the same? */
02068 
02069             old_bd_idx  = ATD_ARRAY_IDX(attr_idx);
02070             same        = (old_bd_idx == array_idx);
02071 
02072             if (!same && 
02073                 BD_ARRAY_CLASS(old_bd_idx) == BD_ARRAY_CLASS(array_idx) &&
02074                 BD_RANK(old_bd_idx) == BD_RANK(array_idx) &&
02075                 BD_ARRAY_SIZE(old_bd_idx) == BD_ARRAY_SIZE(array_idx)) {
02076 
02077                if (BD_ARRAY_CLASS(array_idx) != Deferred_Shape) {
02078                   same  = TRUE;
02079 
02080                   for (i = 1; i <= BD_RANK(array_idx); i++) {
02081 
02082                      if (BD_UB_FLD(old_bd_idx,i) != BD_UB_FLD(array_idx,i)||
02083                          (BD_UB_FLD(old_bd_idx,i) == AT_Tbl_Idx &&
02084                           BD_UB_IDX(old_bd_idx,i) != BD_UB_IDX(array_idx,i))||
02085                          (BD_UB_FLD(old_bd_idx,i) == CN_Tbl_Idx &&
02086                           fold_relationals(BD_UB_IDX(old_bd_idx,i),
02087                                            BD_UB_IDX(array_idx,i),
02088                                            Ne_Opr)) ||
02089                          BD_LB_FLD(old_bd_idx,i) != BD_LB_FLD(array_idx,i)||
02090                          (BD_LB_FLD(old_bd_idx,i) == AT_Tbl_Idx &&
02091                           BD_LB_IDX(old_bd_idx,i) != BD_LB_IDX(array_idx,i))||
02092                          (BD_LB_FLD(old_bd_idx,i) == CN_Tbl_Idx &&
02093                           fold_relationals(BD_LB_IDX(old_bd_idx,i),
02094                                            BD_LB_IDX(array_idx,i),
02095                                            Ne_Opr))) {
02096 
02097                         same    = FALSE;
02098                         break;
02099                      }
02100                   }
02101                }
02102             }
02103 
02104             if (same) {
02105                PRINTMSG(line, 1259, Ansi, column, 
02106                         AT_OBJ_NAME_PTR(attr_idx), "DIMENSION");
02107             }
02108             else {
02109                PRINTMSG(line, 554, Error, column, 
02110                         AT_OBJ_NAME_PTR(attr_idx), "DIMENSION", "DIMENSION");
02111             }
02112          }
02113          else {
02114             ATD_ARRAY_IDX(attr_idx)     = array_idx;
02115 
02116             if (BD_ARRAY_CLASS(array_idx) == Assumed_Shape ||
02117                 BD_ARRAY_CLASS(array_idx) == Deferred_Shape) {
02118 
02119             }
02120          }
02121       }
02122    }
02123 
02124 EXIT:
02125 
02126    TRACE (Func_Exit, "merge_dimension", NULL);
02127 
02128    return(!err_fnd);
02129 
02130 }  /* merge_dimension */
02131 
02132 /******************************************************************************\
02133 |*                                                                            *|
02134 |* Description:                                                               *|
02135 |*      Add the DATA or initialization attribute to an Attr.                  *|
02136 |*      As long as we're here, also mark the Attr as being defined.           *|
02137 |*                                                                            *|
02138 |* Input parameters:                                                          *|
02139 |*      chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
02140 |*                       is FALSE, just add the attribute to the Attr.        *|
02141 |*      line     -> The line number of the object to add the attribute to.    *|
02142 |*      column   -> The line number of the object to add the attribute to.    *|
02143 |*      attr_idx -> Attr index to add the DATA attribute to.                  *|
02144 |*                                                                            *|
02145 |* Output parameters:                                                         *|
02146 |*      NONE                                                                  *|
02147 |*                                                                            *|
02148 |* Returns:                                                                   *|
02149 |*      TRUE if successful merge.                                             *|
02150 |*                                                                            *|
02151 \******************************************************************************/
02152 
02153 boolean merge_data(boolean      chk_semantics,
02154                    int          line,
02155                    int          column,
02156                    int          attr_idx)
02157 
02158 {
02159    boolean      fnd_err         = FALSE;
02160 
02161 
02162    TRACE (Func_Entry, "merge_data", NULL);
02163    
02164    if (chk_semantics) {
02165       fnd_err = fnd_semantic_err(Obj_Data_Init,
02166                                  line,
02167                                  column,
02168                                  attr_idx,
02169                                  TRUE);
02170    }
02171 
02172    if (!fnd_err) {
02173       AT_DEFINED(attr_idx)    = TRUE;
02174       ATD_DATA_INIT(attr_idx) = TRUE;
02175       ATD_CLASS(attr_idx)     = Variable;
02176    }
02177 
02178    TRACE (Func_Exit, "merge_data", NULL);
02179 
02180    return(!fnd_err);
02181 
02182 }  /* merge_data */
02183 
02184 
02185 
02186 /******************************************************************************\
02187 |*                                                                            *|
02188 |* Description:                                                               *|
02189 |*      Add the EXTERNAL attribute to an attr.                                *|
02190 |*                                                                            *|
02191 |* Input parameters:                                                          *|
02192 |*      chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
02193 |*                       is FALSE, just add the attribute to the attr.        *|
02194 |*      line     -> The line number of the object to add the attribute to     *|
02195 |*      column   -> The line number of the object to add the attribute to     *|
02196 |*      attr_idx -> Attr index to add the EXTERNAL attribute to.              *|
02197 |*                                                                            *|
02198 |* Output parameters:                                                         *|
02199 |*      NONE                                                                  *|
02200 |*                                                                            *|
02201 |* Returns:                                                                   *|
02202 |*      TRUE if successful merge.                                             *|
02203 |*                                                                            *|
02204 \******************************************************************************/
02205 
02206 boolean merge_external(boolean  chk_semantics,
02207                        int      line,
02208                        int      column,
02209                        int      attr_idx)
02210 
02211 {
02212    long         chk_err         = FALSE;
02213 
02214 
02215    TRACE (Func_Entry, "merge_external", NULL);
02216 
02217    if (AT_OBJ_CLASS(attr_idx) == Interface && 
02218        !AT_IS_INTRIN(attr_idx) &&               /* JBL  - this is a kludge */
02219        ATI_PROC_IDX(attr_idx) != NULL_IDX) {
02220        attr_idx = ATI_PROC_IDX(attr_idx);
02221    }
02222 
02223    if (chk_semantics && fnd_semantic_err(Obj_Dcl_Extern,
02224                                          line,
02225                                          column,
02226                                          attr_idx,
02227                                          TRUE)) {
02228       chk_err = TRUE;
02229    }
02230    else {
02231 
02232       if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
02233 
02234          /* By passing Pgm_Unknown, chg_data_obj_to_pgm_unit will decide */
02235          /* if this attr, should become a Function or a Pgm_Unknown.     */
02236 
02237          chg_data_obj_to_pgm_unit(attr_idx, 
02238                                   Pgm_Unknown,
02239                                   Extern_Proc);
02240       }
02241       else {
02242 
02243          if (ATP_DCL_EXTERNAL(attr_idx)) {
02244             PRINTMSG(line, 1259, Ansi, column, 
02245                      AT_OBJ_NAME_PTR(attr_idx),
02246                      "EXTERNAL");
02247          }
02248 
02249          if (ATP_PROC(attr_idx) == Unknown_Proc) {
02250             ATP_PROC(attr_idx) = Extern_Proc;
02251          }
02252 
02253          if (attr_idx == SCP_ATTR_IDX(curr_scp_idx)) {
02254 
02255             /* SUBROUTINE JOE(); EXTERNAL JOE   is non-standard. */
02256    
02257             PRINTMSG(line, 279, Ansi, column, AT_OBJ_NAME_PTR(attr_idx));
02258          }
02259       }
02260 
02261       ATP_DCL_EXTERNAL(attr_idx)        = TRUE;
02262       ATP_SCP_IDX(attr_idx)             = curr_scp_idx;
02263    }
02264 
02265    TRACE (Func_Exit, "merge_external", NULL);
02266 
02267    return(!chk_err);
02268 
02269 }  /* merge_external */
02270 
02271 
02272 /******************************************************************************\
02273 |*                                                                            *|
02274 |* Description:                                                               *|
02275 |*      Add the INTENT attribute to an attr.                                  *|
02276 |*      NOTE:  The intent to add is picked up from a global variable, called  *|
02277 |*             new_intent.                                                    *|
02278 |*                                                                            *|
02279 |* Input parameters:                                                          *|
02280 |*      chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
02281 |*                       is FALSE, just add the attribute to the attr.        *|
02282 |*      line     -> The line number of the object to add the attribute to     *|
02283 |*      column   -> The line number of the object to add the attribute to     *|
02284 |*      attr_idx -> Attr index to add the EXTERNAL attribute to.              *|
02285 |*                                                                            *|
02286 |* Output parameters:                                                         *|
02287 |*      NONE                                                                  *|
02288 |*                                                                            *|
02289 |* Returns:                                                                   *|
02290 |*      TRUE if successful merge.                                             *|
02291 |*                                                                            *|
02292 \******************************************************************************/
02293 
02294 boolean merge_intent(boolean            chk_semantics,
02295                      int                line,
02296                      int                column,
02297                      int                attr_idx)
02298 
02299 {
02300    boolean      fnd_err         = FALSE;
02301 
02302 
02303    TRACE (Func_Entry, "merge_intent", NULL);
02304 
02305    if (AT_OBJ_CLASS(attr_idx) == Interface && 
02306        ATI_PROC_IDX(attr_idx) != NULL_IDX) {
02307        attr_idx = ATI_PROC_IDX(attr_idx);
02308    }
02309    
02310    if (chk_semantics) {
02311       fnd_err = fnd_semantic_err(Obj_Intent,
02312                                  line,
02313                                  column,
02314                                  attr_idx,
02315                                  TRUE);
02316 
02317       if (!fnd_err) {
02318 
02319          if (ATD_INTENT(attr_idx) != Intent_Unseen) {
02320 
02321             if (ATD_INTENT(attr_idx) == new_intent) {
02322                PRINTMSG(line, 1259, Ansi, column, AT_OBJ_NAME_PTR(attr_idx),
02323                         "INTENT");
02324             }
02325             else {  /* The intent is different */
02326                PRINTMSG(line, 554, Error, column, AT_OBJ_NAME_PTR(attr_idx),
02327                         "INTENT", "INTENT");
02328             }
02329          }
02330       }
02331    }
02332    else {
02333       SET_IMPL_TYPE(attr_idx);
02334    }
02335 
02336    if (!fnd_err) {
02337       ATD_CLASS(attr_idx)       = Dummy_Argument;
02338       ATD_INTENT(attr_idx)      = new_intent;
02339    }
02340 
02341    TRACE (Func_Exit, "merge_intent", NULL);
02342 
02343    return(!fnd_err);
02344 
02345 }  /* merge_intent */
02346 
02347 
02348 /******************************************************************************\
02349 |*                                                                            *|
02350 |* Description:                                                               *|
02351 |*      Add the INTRINSIC attribute to an attr.                               *|
02352 |*                                                                            *|
02353 |* Input parameters:                                                          *|
02354 |*      chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
02355 |*                       is FALSE, just add the attribute to the attr.        *|
02356 |*      line     -> The line number of the object to add the attribute to     *|
02357 |*      column   -> The line number of the object to add the attribute to     *|
02358 |*      attr_idx -> Attr index to add the EXTERNAL attribute to.              *|
02359 |*                                                                            *|
02360 |* Output parameters:                                                         *|
02361 |*      NONE                                                                  *|
02362 |*                                                                            *|
02363 |* Returns:                                                                   *|
02364 |*      TRUE if successful merge.                                             *|
02365 |*                                                                            *|
02366 \******************************************************************************/
02367 
02368 boolean merge_intrinsic(boolean chk_semantics,
02369                         int     line,
02370                         int     column,
02371                         int     attr_idx)
02372 
02373 {
02374    boolean      found_error     = FALSE;
02375    int          save_curr_scp_idx;
02376    int          host_name_idx;
02377    int          host_attr_idx;
02378    int          sn_idx;
02379    int          type_idx;
02380 
02381 
02382    TRACE (Func_Entry, "merge_intrinsic", NULL);
02383 
02384    if (chk_semantics && fnd_semantic_err(Obj_Dcl_Intrin, 
02385                                          line, 
02386                                          column, 
02387                                          attr_idx,
02388                                          TRUE)) {
02389       found_error = TRUE;
02390    }
02391    else if (AT_IS_INTRIN(attr_idx) && AT_OBJ_CLASS(attr_idx) == Interface) {
02392 
02393       if (ATI_DCL_INTRINSIC(attr_idx)) {
02394          PRINTMSG(line, 1259, Ansi, column, AT_OBJ_NAME_PTR(attr_idx),
02395                   "INTRINSIC");
02396       }
02397       ATI_DCL_INTRINSIC(attr_idx) = TRUE;
02398    }
02399    else {
02400 
02401       /* The INTRINSIC has not been copied down yet. - So copy it. */
02402 
02403 # if 0 /* keep intrinsic function has an attribut table entry,don't merge with 
02404         * user defined interface attribute entry
02405         */
02406 
02407       host_attr_idx = srch_host_sym_tbl(AT_OBJ_NAME_PTR(attr_idx),
02408                                         AT_NAME_LEN(attr_idx),
02409                                         &host_name_idx,
02410                                         TRUE);
02411       if (host_attr_idx != NULL_IDX) {
02412 
02413          /* go directly to the INTRINSIC scope if not interface */
02414          /* or if it is not the name of a specific intrinsic.   */
02415 
02416          if (AT_OBJ_CLASS(host_attr_idx) != Interface ||
02417              !ATI_GENERIC_INTRINSIC(host_attr_idx)) {
02418 
02419 #endif
02420             save_curr_scp_idx = curr_scp_idx;
02421             curr_scp_idx = INTRINSIC_SCP_IDX;
02422             host_attr_idx = srch_sym_tbl(AT_OBJ_NAME_PTR(attr_idx),
02423                                          AT_NAME_LEN(attr_idx),
02424                                          &host_name_idx);
02425             curr_scp_idx = save_curr_scp_idx;
02426 
02427 /*         } */
02428 
02429          if (host_attr_idx != NULL_IDX &&
02430              AT_IS_INTRIN(host_attr_idx) &&
02431              ATI_FIRST_SPECIFIC_IDX(host_attr_idx) == NULL_IDX) {
02432             complete_intrinsic_definition(host_attr_idx);
02433          }
02434 
02435 /*      } */
02436 
02437       if (host_attr_idx == NULL_IDX) {
02438 
02439          /* Error - Couldn't find the intrinsic.  Set implicit type.  */
02440 
02441          PRINTMSG(line, 701, Error, column, AT_OBJ_NAME_PTR(attr_idx));
02442          found_error = TRUE;
02443 
02444          if (AT_OBJ_CLASS(attr_idx) == Data_Obj && !AT_TYPED(attr_idx)) {
02445             SET_IMPL_TYPE(attr_idx);
02446          }
02447          else {
02448 
02449             if (AT_OBJ_CLASS(attr_idx) == Interface && 
02450                 ATI_PROC_IDX(attr_idx) != NULL_IDX) {
02451                attr_idx = ATI_PROC_IDX(attr_idx);
02452             }
02453 
02454             if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit && 
02455                 ATP_PGM_UNIT(attr_idx) == Function &&
02456                !AT_TYPED(ATP_RSLT_IDX(attr_idx))) {
02457                SET_IMPL_TYPE(ATP_RSLT_IDX(attr_idx));
02458             }
02459          }
02460       }
02461       else if (AT_OBJ_CLASS(attr_idx) == Interface) {
02462 
02463          /* Both are interfaces.   Add these specific intrinsics behind     */
02464          /* any user declared specifics that have previously been declared. */
02465 
02466          AT_IS_INTRIN(attr_idx)         = TRUE;
02467          ATI_DCL_INTRINSIC(attr_idx)    = TRUE;
02468          ATI_NUM_SPECIFICS(attr_idx)   += ATI_NUM_SPECIFICS(host_attr_idx);
02469 
02470          sn_idx = ATI_FIRST_SPECIFIC_IDX(attr_idx);
02471 
02472          if (sn_idx == NULL_IDX) {
02473             ATI_FIRST_SPECIFIC_IDX(attr_idx) = 
02474                                           ATI_FIRST_SPECIFIC_IDX(host_attr_idx);
02475          }
02476          else {
02477             while (SN_SIBLING_LINK(sn_idx) != NULL_IDX) {
02478                sn_idx = SN_SIBLING_LINK(sn_idx);
02479             }
02480             SN_SIBLING_LINK(sn_idx) = ATI_FIRST_SPECIFIC_IDX(host_attr_idx);
02481          }
02482       }
02483       else {
02484 
02485          if (ATI_INTERFACE_CLASS(host_attr_idx) == 
02486                                                 Generic_Subroutine_Interface) {
02487 
02488             if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {
02489 
02490                if (ATP_RSLT_IDX(attr_idx) != NULL_IDX && 
02491                    AT_TYPED(ATP_RSLT_IDX(attr_idx))) {
02492                   PRINTMSG(line, 869, Error, column,
02493                            AT_OBJ_NAME_PTR(attr_idx));
02494                   found_error = TRUE;
02495                }
02496    
02497                ATP_RSLT_IDX(attr_idx) = NULL_IDX;
02498             }
02499             else if (AT_OBJ_CLASS(attr_idx) == Data_Obj && AT_TYPED(attr_idx)){
02500                PRINTMSG(line, 869, Error, column, AT_OBJ_NAME_PTR(attr_idx));
02501                found_error = TRUE;
02502             }
02503          }
02504 
02505          type_idx = NULL_IDX;
02506 
02507          if (AT_TYPED(attr_idx)) {
02508 
02509             if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
02510                type_idx = ATD_TYPE_IDX(attr_idx);
02511             }
02512             else if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit &&
02513                      ATP_RSLT_IDX(attr_idx) != NULL_IDX) {
02514                type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx));
02515             }
02516          }
02517          COPY_VARIANT_ATTR_INFO(host_attr_idx,
02518                                 attr_idx, 
02519                                 Interface);
02520 
02521          AT_ELEMENTAL_INTRIN(attr_idx)  = AT_ELEMENTAL_INTRIN(host_attr_idx);
02522          AT_IS_INTRIN(attr_idx)         = TRUE;
02523          ATD_TYPE_IDX(attr_idx)         = type_idx;
02524          ATI_DCL_INTRINSIC(attr_idx)    = TRUE;
02525       }
02526    }
02527 
02528    TRACE (Func_Exit, "merge_intrinsic", NULL);
02529 
02530    return(!found_error);
02531 
02532 }  /* merge_intrinsic */
02533 
02534 
02535 /******************************************************************************\
02536 |*                                                                            *|
02537 |* Description:                                                               *|
02538 |*      NOTES: The object must be a dummy argument.             (p5-2,17-18)  *|
02539 |*             The object must be in a subpgm or interface blk  (5.2.2)       *|
02540 |*             The stmt must not be declared in a blockdata pgm (p11-6,31-33) *|
02541 |*             If in an ASSIGNMENT or an OPERATOR interface     (p12-6,1-4)   *|
02542 |*                cannot specify optional                                     *|
02543 |*             Must not be specified in a main program          (p11-1,33-36) *|
02544 |*                                                                            *|
02545 |*  END of declaration:                                                       *|
02546 |*         If allocatable - it must be a deferred-shape array.                *|
02547 |*                                                                            *|
02548 |* Input parameters:                                                          *|
02549 |*      chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
02550 |*                       is FALSE, just add the attribute to the attr.        *|
02551 |*      line     -> The line number of the object to add the attribute to     *|
02552 |*      column   -> The line number of the object to add the attribute to     *|
02553 |*      attr_idx -> Attr index to add the EXTERNAL attribute to.              *|
02554 |*                                                                            *|
02555 |* Output parameters:                                                         *|
02556 |*      NONE                                                                  *|
02557 |*                                                                            *|
02558 |* Returns:                                                                   *|
02559 |*      TRUE if successful merge                                              *|
02560 |*                                                                            *|
02561 \******************************************************************************/
02562 
02563 boolean merge_optional (boolean chk_semantics,
02564                         int     line,
02565                         int     column,
02566                         int     attr_idx)
02567 
02568 {
02569    boolean      chk_err         = FALSE;
02570 
02571 
02572    TRACE (Func_Entry, "merge_optional", NULL);
02573 
02574    if (chk_semantics) {
02575       chk_err = fnd_semantic_err(Obj_Optional,
02576                                  line,
02577                                  column,
02578                                  attr_idx,
02579                                  TRUE);
02580 
02581       if (!chk_err && AT_OPTIONAL(attr_idx)) {
02582          PRINTMSG(line, 1259, Ansi, column, AT_OBJ_NAME_PTR(attr_idx),
02583                   "OPTIONAL");
02584       }
02585    }
02586    else {
02587       SET_IMPL_TYPE(attr_idx);
02588    }
02589 
02590    if (!chk_err) {
02591 
02592       if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
02593          ATD_CLASS(attr_idx)    = Dummy_Argument;
02594       }
02595       else {
02596          ATP_PROC(attr_idx)     = Dummy_Proc;
02597       }
02598       AT_OPTIONAL(attr_idx)     = TRUE;
02599    }
02600 
02601    TRACE (Func_Exit, "merge_optional", NULL);
02602 
02603    return(!chk_err);
02604 
02605 }  /* merge_optional */
02606 
02607 /******************************************************************************\
02608 |*                                                                            *|
02609 |* Description:                                                               *|
02610 |*      Add the POINTER attribute to an attr.                                 *|
02611 |*                                                                            *|
02612 |* Input parameters:                                                          *|
02613 |*      chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
02614 |*                       is FALSE, just add the attribute to the attr.        *|
02615 |*      line     -> The line number of the object to add the attribute to     *|
02616 |*      column   -> The line number of the object to add the attribute to     *|
02617 |*      attr_idx -> Attr index to add the POINTER attribute to.               *|
02618 |*                                                                            *|
02619 |* Output parameters:                                                         *|
02620 |*      NONE                                                                  *|
02621 |*                                                                            *|
02622 |* Returns:                                                                   *|
02623 |*      TRUE if successful merge.                                             *|
02624 |*                                                                            *|
02625 \******************************************************************************/
02626 
02627 boolean merge_pointer(boolean   chk_semantics,
02628                       int       line,
02629                       int       column,
02630                       int       attr_idx)
02631 
02632 {
02633    boolean      fnd_err         = FALSE;
02634    int          rslt_idx;
02635 
02636 
02637    TRACE (Func_Entry, "merge_pointer", NULL);
02638 
02639    if (AT_OBJ_CLASS(attr_idx) == Interface && 
02640        ATI_PROC_IDX(attr_idx) != NULL_IDX) {
02641        attr_idx = ATI_PROC_IDX(attr_idx);
02642    }
02643 
02644    if (chk_semantics) {
02645 
02646       if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit && ATP_RSLT_NAME(attr_idx)) {
02647          PRINTMSG(line, 36, Error, column, AT_OBJ_NAME_PTR(attr_idx),
02648                   AT_OBJ_NAME_PTR(ATP_RSLT_IDX(attr_idx)));
02649          fnd_err                = TRUE;
02650          AT_DCL_ERR(attr_idx)   = TRUE;
02651       }
02652       else {
02653          fnd_err = fnd_semantic_err(Obj_Pointer,
02654                                     line,
02655                                     column,
02656                                     attr_idx,
02657                                     TRUE);
02658       }
02659 
02660       if (!fnd_err && AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {
02661 
02662          if (ATP_RSLT_IDX(attr_idx) == NULL_IDX) {
02663             CREATE_FUNC_RSLT(attr_idx, rslt_idx);
02664             ATP_PGM_UNIT(attr_idx)      = Function;
02665             SET_IMPL_TYPE(rslt_idx);
02666             attr_idx                    = rslt_idx;
02667          }
02668          else {
02669             attr_idx = ATP_RSLT_IDX(attr_idx);
02670             fnd_err  = fnd_semantic_err(Obj_Pointer, 
02671                                         line,
02672                                         column,
02673                                         attr_idx,
02674                                         TRUE);
02675          }
02676       }
02677 
02678       if (!fnd_err) {
02679 
02680          if (ATD_POINTER(attr_idx)) {
02681             PRINTMSG(line, 1259, Ansi, column, AT_OBJ_NAME_PTR(attr_idx),
02682                      "POINTER");
02683          }
02684          ATD_POINTER(attr_idx)   = TRUE;
02685       }
02686    }
02687    else {
02688       SET_IMPL_TYPE(attr_idx);
02689       ATD_POINTER(attr_idx)   = TRUE;
02690    }
02691 
02692    TRACE (Func_Exit, "merge_pointer", NULL);
02693 
02694    return(!fnd_err);
02695 
02696 }  /* merge_pointer */
02697 
02698 
02699 /******************************************************************************\
02700 |*                                                                            *|
02701 |* Description:                                                               *|
02702 |*      Add the SAVE attribute to an attr.                                    *|
02703 |*                                                                            *|
02704 |* Input parameters:                                                          *|
02705 |*      chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
02706 |*                       is FALSE, just add the attribute to the attr.        *|
02707 |*      line     -> The line number of the object to add the attribute to     *|
02708 |*      column   -> The line number of the object to add the attribute to     *|
02709 |*      attr_idx -> Attr index to add the EXTERNAL attribute to.              *|
02710 |*                                                                            *|
02711 |* Output parameters:                                                         *|
02712 |*      NONE                                                                  *|
02713 |*                                                                            *|
02714 |* Returns:                                                                   *|
02715 |*      TRUE if successful merge.                                             *|
02716 |*                                                                            *|
02717 \******************************************************************************/
02718 
02719 boolean merge_save(boolean      chk_semantics,
02720                    int          line,
02721                    int          column,
02722                    int          attr_idx)
02723 
02724 {
02725    boolean      fnd_err         = FALSE;
02726 
02727 
02728    TRACE (Func_Entry, "merge_save", NULL);
02729 
02730    if (chk_semantics) {
02731       fnd_err = fnd_semantic_err(Obj_Saved, line, column, attr_idx, TRUE);
02732 
02733       if (!fnd_err && ATD_SAVED(attr_idx)) {
02734          PRINTMSG(line, 1259, Ansi, column, AT_OBJ_NAME_PTR(attr_idx), "SAVE");
02735       }
02736    }
02737    else {
02738       SET_IMPL_TYPE(attr_idx);
02739    }
02740 
02741    if (!fnd_err) {
02742       ATD_SAVED(attr_idx) = TRUE;
02743       ATD_CLASS(attr_idx) = Variable;
02744    }
02745 
02746    TRACE (Func_Exit, "merge_save", NULL);
02747 
02748    return(!fnd_err);
02749 
02750 }  /* merge_save */
02751 
02752 
02753 /******************************************************************************\
02754 |*                                                                            *|
02755 |* Description:                                                               *|
02756 |*      Add the TARGET attribute to an attr.                                  *|
02757 |*                                                                            *|
02758 |* Input parameters:                                                          *|
02759 |*      chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
02760 |*                       is FALSE, just add the attribute to the attr.        *|
02761 |*      line     -> The line number of the object to add the attribute to     *|
02762 |*      column   -> The line number of the object to add the attribute to     *|
02763 |*      attr_idx -> Attr index to add the TARGET attribute to.                *|
02764 |*                                                                            *|
02765 |* Output parameters:                                                         *|
02766 |*      NONE                                                                  *|
02767 |*                                                                            *|
02768 |* Returns:                                                                   *|
02769 |*      TRUE if successful merge.                                             *|
02770 |*                                                                            *|
02771 \******************************************************************************/
02772 
02773 boolean merge_target(boolean    chk_semantics,
02774                      int        line,
02775                      int        column,
02776                      int        attr_idx)
02777 
02778 {
02779    boolean      fnd_err         = FALSE;
02780    int          rslt_idx;
02781 
02782 
02783    TRACE (Func_Entry, "merge_target", NULL);
02784 
02785    if (AT_OBJ_CLASS(attr_idx) == Interface && 
02786        ATI_PROC_IDX(attr_idx) != NULL_IDX) {
02787        attr_idx = ATI_PROC_IDX(attr_idx);
02788    }
02789 
02790    if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit && ATP_RSLT_NAME(attr_idx)) {
02791       PRINTMSG(line, 132, Error, column, AT_OBJ_NAME_PTR(attr_idx),
02792                AT_OBJ_NAME_PTR(ATP_RSLT_IDX(attr_idx)));
02793       fnd_err                   = TRUE;
02794       AT_DCL_ERR(attr_idx)      = TRUE;
02795    }
02796    else if (chk_semantics) {
02797       fnd_err = fnd_semantic_err(Obj_Target, line, column, attr_idx, TRUE);
02798    }
02799    else {
02800       SET_IMPL_TYPE(attr_idx);
02801    }
02802 
02803    if (!fnd_err && AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {
02804 
02805       if (ATP_RSLT_IDX(attr_idx) == NULL_IDX) {
02806          CREATE_FUNC_RSLT(attr_idx, rslt_idx);
02807          ATP_PGM_UNIT(attr_idx) = Function;
02808          SET_IMPL_TYPE(rslt_idx);
02809          attr_idx = rslt_idx;
02810       } 
02811       else {
02812          attr_idx = ATP_RSLT_IDX(attr_idx);
02813          fnd_err  = fnd_semantic_err(Obj_Target,
02814                                      line,
02815                                      column,
02816                                      attr_idx,
02817                                      TRUE);
02818       }
02819    }
02820 
02821    if (!fnd_err) {
02822 
02823       if (!fnd_err && ATD_TARGET(attr_idx)) {
02824          PRINTMSG(line, 1259, Ansi, column, AT_OBJ_NAME_PTR(attr_idx),"TARGET");
02825       }
02826       ATD_TARGET(attr_idx) = TRUE;
02827    }
02828 
02829    TRACE (Func_Exit, "merge_target", NULL);
02830 
02831    return(!fnd_err);
02832 
02833 }  /* merge_target */
02834 
02835 /******************************************************************************\
02836 |*                                                                            *|
02837 |* Description:                                                               *|
02838 |*      This routine parses integer specification expressions.  It is used by *|
02839 |*      the parsing routines for array boundaries, character lengths, and     *|
02840 |*      kind type parameters.  It takes a shortcut if there is just a literal *|
02841 |*      integer constant like B(10).  It would pick this up itself without    *|
02842 |*      calling the expression parser.  Expression semantics is called only   *|
02843 |*      if input fold_it tells it do it.  This is because kind type parameters*|
02844 |*      can be folded right away, but array and character bounds must wait    *|
02845 |*      until the end of pass1.  If this doesn't come out to be a constant    *|
02846 |*      value, tmp = is generated and the tmp is added to the bounds list.    *|
02847 |*                                                                            *|
02848 |* Input parameters:                                                          *|
02849 |*      fold_it          -> A flag that tells this routine whether to try to  *|
02850 |*                          fold this value or not.                           *|
02851 |*      kind_type        -> A flag that tells this routine is being called    *|
02852 |*                          to process kind type or not.                      *|
02853 |*                                                                            *|
02854 |* Output parameters:                                                         *|
02855 |*      len_idx     -> This is a ptr to a table index.  field_type tells what *|
02856 |*                     kind of index this is.                                 *|
02857 |*      field_type  -> This is a ptr to what kind of table index this is.  It *|
02858 |*                     contains the fld_type enum. (AT_Tbl_Idx, IR_Tbl_Idx ect*|
02859 |*                                                                            *|
02860 |* Returns:                                                                   *|
02861 |*      Returns TRUE if it parsed okay.                                       *|
02862 |*                                                                            *|
02863 \******************************************************************************/
02864 static boolean  parse_int_spec_expr(long                *len_idx,
02865                                     fld_type            *field_type,
02866                                     boolean              fold_it,
02867                                     boolean              char_len)
02868 
02869 {
02870    int                  column;
02871    expr_arg_type        expr_desc;
02872    opnd_type            len_opnd;
02873    int                  line;
02874    boolean              parse_ok;
02875    expr_mode_type       save_expr_mode  = expr_mode;
02876    int                  type_idx;
02877 
02878 # if defined(GENERATE_WHIRL)
02879    int                  cvrt_idx;
02880    int                  new_type;
02881 # endif
02882 
02883 
02884    TRACE (Func_Entry, "parse_int_spec_expr", NULL);
02885 
02886    xref_state           = CIF_Symbol_Reference;
02887    *field_type          = CN_Tbl_Idx;
02888    *len_idx             = CN_INTEGER_ONE_IDX;
02889    expr_mode            = fold_it ? Initialization_Expr : Specification_Expr;
02890    line                 = LA_CH_LINE;
02891    column               = LA_CH_COLUMN;
02892    expr_desc            = init_exp_desc;
02893 
02894    if (!parse_expr(&len_opnd)) {
02895       parse_ok  = FALSE;
02896       goto EXIT;
02897    }
02898 
02899 
02900    if (fold_it) {
02901 
02902       expr_desc.rank = 0;
02903 
02904       if (!expr_semantics(&len_opnd, &expr_desc)) {
02905          parse_ok       = FALSE;
02906          goto EXIT;
02907       }
02908 
02909       if (expr_desc.rank != 0) {
02910          PRINTMSG(line, 907, Error, column);
02911          parse_ok       = FALSE;
02912          goto EXIT;
02913       }
02914 
02915       if (OPND_FLD(len_opnd) != CN_Tbl_Idx) {
02916          PRINTMSG(line, 1531, Error, column);
02917          parse_ok       = FALSE;
02918          goto EXIT;
02919       }
02920 
02921       if (parsing_kind_selector) {
02922          if (expr_desc.kind0seen) {
02923             kind0seen = TRUE;
02924          }
02925          else if (expr_desc.kind0E0seen) {
02926             kind0E0seen = TRUE;
02927          }
02928          else if (expr_desc.kind0D0seen) {
02929             kind0D0seen = TRUE;
02930          }
02931          else if (! expr_desc.kindnotconst) {
02932             kindconstseen = TRUE;
02933          }
02934       }
02935    }
02936 
02937    parse_ok = TRUE;
02938 
02939    if (OPND_FLD(len_opnd) == CN_Tbl_Idx) {
02940       type_idx  = CN_TYPE_IDX(OPND_IDX(len_opnd));
02941 
02942       if (TYP_TYPE(type_idx) != Integer) {
02943     
02944          if (TYP_TYPE(type_idx) == Typeless) {
02945 
02946             if (TYP_LINEAR(type_idx) == Short_Typeless_Const) {
02947                PRINTMSG(line, 221, Ansi, column);
02948 
02949                OPND_IDX(len_opnd) = cast_typeless_constant(OPND_IDX(len_opnd),
02950                                                            INTEGER_DEFAULT_TYPE,
02951                                                            line, 
02952                                                            column);
02953                type_idx = INTEGER_DEFAULT_TYPE;
02954             }
02955             else { /* hollerith too long */
02956                PRINTMSG(line, 1133, Error, column);
02957                parse_ok = FALSE;
02958             }
02959          }
02960          else {
02961             PRINTMSG(line, 488, Error, column,
02962                      get_basic_type_str(type_idx));
02963             parse_ok    = FALSE;
02964          }
02965       }
02966 
02967       *len_idx          = (long) OPND_IDX(len_opnd);
02968       *field_type       = CN_Tbl_Idx;
02969 
02970 # if defined(GENERATE_WHIRL)
02971 
02972       if (!parsing_kind_selector) {
02973          new_type       = NULL_IDX;
02974 
02975          if (char_len) {     /* All char lens must be integer_4 */
02976 
02977             if (TYP_LINEAR(CN_TYPE_IDX(OPND_IDX(len_opnd))) != Integer_4) {
02978                new_type = Integer_4;
02979             }
02980          }
02981          else if (cmd_line_flags.s_pointer8 &&
02982                   TYP_LINEAR(CN_TYPE_IDX(OPND_IDX(len_opnd))) !=
02983                              SA_INTEGER_DEFAULT_TYPE) {
02984                new_type = SA_INTEGER_DEFAULT_TYPE;
02985          }
02986          else if (TYP_LINEAR(CN_TYPE_IDX(OPND_IDX(len_opnd))) <
02987                              SA_INTEGER_DEFAULT_TYPE) {
02988 
02989             /* Bump up integer*1 and integer*2 to avoid overflows KAY  */
02990 
02991             new_type    = SA_INTEGER_DEFAULT_TYPE;
02992          }
02993 
02994          if (new_type != NULL_IDX) {
02995             NTR_IR_TBL(cvrt_idx);
02996             IR_OPR(cvrt_idx)            = Cvrt_Opr;
02997             IR_TYPE_IDX(cvrt_idx)       = new_type;
02998             IR_LINE_NUM(cvrt_idx)       = line;
02999             IR_COL_NUM(cvrt_idx)        = column;
03000 
03001             COPY_OPND(IR_OPND_L(cvrt_idx), len_opnd);
03002 
03003             OPND_IDX(len_opnd)          = cvrt_idx;
03004             OPND_FLD(len_opnd)          = IR_Tbl_Idx;
03005 
03006             if (fold_it) {
03007                expr_desc.rank = 0;
03008 
03009                if (!expr_semantics(&len_opnd, &expr_desc)) {
03010                   parse_ok      = FALSE;
03011                   goto EXIT;
03012                }
03013 
03014                *len_idx         = (long) OPND_IDX(len_opnd); 
03015                *field_type      = CN_Tbl_Idx;
03016             }
03017             else {
03018 # if 0 
03019                *field_type                      = AT_Tbl_Idx;
03020                *len_idx                         = ntr_bnds_tmp_list(&len_opnd);
03021                ATD_TMP_HAS_CVRT_OPR(*len_idx)   = TRUE;
03022 # endif
03023             }
03024          }
03025          else {
03026             *len_idx    = (long) OPND_IDX(len_opnd); 
03027             *field_type = CN_Tbl_Idx;
03028          }
03029       }
03030 
03031 # endif
03032 
03033    }
03034    else {
03035 
03036 # if defined(GENERATE_WHIRL)
03037       new_type  = NULL_IDX;
03038 
03039       if (!parsing_kind_selector) { 
03040 
03041          if (char_len) {     /* All char lens must be integer_4 */
03042             new_type    = Integer_4;
03043          }
03044          else if (cmd_line_flags.s_pointer8) { 
03045             new_type    = SA_INTEGER_DEFAULT_TYPE;
03046          }
03047 
03048          if (new_type != NULL_IDX) {
03049             NTR_IR_TBL(cvrt_idx);
03050             IR_OPR(cvrt_idx)            = Cvrt_Opr;
03051             IR_TYPE_IDX(cvrt_idx)       = new_type;
03052             IR_LINE_NUM(cvrt_idx)       = line;
03053             IR_COL_NUM(cvrt_idx)        = column;
03054 
03055             COPY_OPND(IR_OPND_L(cvrt_idx), len_opnd);
03056 
03057             OPND_IDX(len_opnd)          = cvrt_idx;
03058             OPND_FLD(len_opnd)          = IR_Tbl_Idx;
03059 
03060             if (fold_it) {
03061                expr_desc.rank = 0;
03062 
03063                if (!expr_semantics(&len_opnd, &expr_desc)) {
03064                   parse_ok      = FALSE;
03065                   goto EXIT;
03066                }
03067             }
03068          }
03069       }
03070 
03071 /* # if 0 fzhao May*/
03072       *field_type       = AT_Tbl_Idx;
03073       *len_idx          = ntr_bnds_tmp_list(&len_opnd);
03074       ATD_TMP_SEMANTICS_DONE(*len_idx) = fold_it;
03075       if (new_type != NULL_IDX) {
03076          ATD_TMP_HAS_CVRT_OPR(*len_idx) = TRUE;
03077       }
03078 /* # endif  may */
03079 
03080 # else
03081       *field_type       = AT_Tbl_Idx;
03082       *len_idx          = ntr_bnds_tmp_list(&len_opnd);
03083 
03084       ATD_TMP_SEMANTICS_DONE(*len_idx) = fold_it;
03085 # endif
03086 
03087    }
03088 
03089 EXIT:
03090 
03091    expr_mode = save_expr_mode;
03092 
03093    TRACE (Func_Exit, "parse_int_spec_expr", NULL);
03094 
03095    return(parse_ok);
03096 
03097 }  /* parse_int_spec_expr */
03098 
03099 /******************************************************************************\
03100 |*                                                                            *|
03101 |* Description:                                                               *|
03102 |*      This routine takes a bounds ir stream, and searches the bounds tmp    *|
03103 |*      list for a match.  If a match is found, it returns the attr_idx of    *|
03104 |*      the matched bound.  If there is no match, a compiler temp is          *|
03105 |*      generated and added to the end of the bounds tmp list.   This assumes *|
03106 |*      that the ir pointed to by ATD_TMP_IDX is always of the form           *|
03107 |*      TMP = ir_stream, so it passes to compare_ir the right operand of      *|
03108 |*      the compiler temp.  And then if a new temp is needed, this routine    *|
03109 |*      generates the TMP =.                                                  *|
03110 |*                                                                            *|
03111 |* Input parameters:                                                          *|
03112 |*      opnd   A pointer to an operand pointing to the attribute or ir stream *|
03113 |*             that needs a temp.  This should NOT have TMP = generated yet.  *|
03114 |*                                                                            *|
03115 |* Output parameters:                                                         *|
03116 |*       NONE                                                                 *|
03117 |*                                                                            *|
03118 |* Returns:                                                                   *|
03119 |*      attr_idx  Index to attr table for this temp.                          *|
03120 |*                                                                            *|
03121 \******************************************************************************/
03122 static int ntr_bnds_tmp_list (opnd_type *opnd)
03123 
03124 {
03125    int          al_idx;
03126    int          attr_idx;
03127    int          cif_attr        = NULL_IDX;
03128    int          column;
03129    int          ir_idx;
03130    int          line;
03131    int          prev_al         = NULL_IDX;
03132 
03133 
03134    TRACE (Func_Entry, "ntr_bnds_tmp_list", NULL);
03135 
03136    al_idx       = SCP_TMP_FW_IDX(curr_scp_idx);
03137    attr_idx     = NULL_IDX;
03138 
03139    while (al_idx != NULL_IDX) {
03140       attr_idx  = AL_ATTR_IDX(al_idx);
03141 
03142       if (ATD_CLASS(attr_idx) == Constant) {
03143          
03144          /* This tmp has resolved to a constant, because it has gone   */
03145          /* thru expr_semantics already.  Remove it from the tmp list. */
03146          /* A tmp may go through expr_semantics early, if the item     */
03147          /* needs to be folded because it is referenced in a bound of  */
03148          /* a component declaration.  prev_al stays the same.          */
03149 
03150          al_idx = AL_NEXT_IDX(al_idx);
03151 
03152          if (prev_al == NULL_IDX) {
03153             SCP_TMP_FW_IDX(curr_scp_idx) = al_idx;
03154          }
03155          else {
03156             AL_NEXT_IDX(prev_al)         = al_idx;
03157          }
03158          continue;
03159       }
03160 
03161       /* Okay to pass a pointer to the operand here, because it should */
03162       /* not move.  This is only a call to compare operands.           */
03163 
03164       if (compare_opnds(opnd, &(IR_OPND_R(ATD_TMP_IDX(attr_idx)))) ) {
03165 
03166          /* If this is CIF - retain the IR, even though the tmp gets shared */
03167 
03168          if ((cif_flags & XREF_RECS) != 0) {
03169 
03170             if (cif_attr == NULL_IDX) {
03171                cif_attr = attr_idx;
03172             }
03173          }
03174          else {
03175 
03176             if (OPND_FLD((*opnd)) == IR_Tbl_Idx) { 
03177                free_ir_stream(OPND_IDX((*opnd)));
03178             }
03179             goto EXIT;
03180          }
03181       }
03182 
03183       prev_al   = al_idx;
03184       al_idx    = AL_NEXT_IDX(al_idx);
03185    }
03186 
03187    /* Each new bound has to be added at the end of the list. */
03188 
03189    NTR_ATTR_LIST_TBL(al_idx);
03190 
03191    if (prev_al == NULL_IDX) {
03192       SCP_TMP_FW_IDX(curr_scp_idx)      = al_idx;
03193    }
03194    else {
03195       AL_NEXT_IDX(prev_al)              = al_idx;
03196    }
03197    find_opnd_line_and_column(opnd, &line, &column);
03198 
03199    GEN_COMPILER_TMP_ASG(ir_idx, 
03200                         attr_idx,
03201                         FALSE,          /* Tmp should go through semantics */
03202                         line,
03203                         column,
03204                         INTEGER_DEFAULT_TYPE,
03205                         Priv);
03206 
03207    AL_ATTR_IDX(al_idx)          = attr_idx;
03208 
03209    COPY_OPND(IR_OPND_R(ir_idx), (*opnd));       /* IR_OPND_R = *opnd  */
03210 
03211    if (cif_attr != NULL_IDX) {
03212 
03213       /* This tmp is only being kept for CIF - Return the tmp to be shared. */
03214 
03215       AT_REFERENCED(attr_idx)   = Not_Referenced;
03216       attr_idx                  = cif_attr;
03217    }
03218 
03219 EXIT:
03220 
03221    TRACE (Func_Exit, "ntr_bnds_tmp_list", NULL);
03222 
03223    return (attr_idx);
03224 
03225 }  /* ntr_bnds_tmp_list */
03226 
03227 /******************************************************************************\
03228 |*                                                                            *|
03229 |* Description:                                                               *|
03230 |*      Parse a POSSIBLE generic spec.  If OPERATOR(operator) or ASSIGNMENT   *|
03231 |*        (=) is found, search for (create if necessary)  an attr entry.      *|
03232 |*        If identifier found, return attr index if found, else 0.            *|
03233 |*                                                                            *|
03234 |* Input parameters:                                                          *|
03235 |*      NONE                                                                  *|
03236 |*                                                                            *|
03237 |* Output parameters:                                                         *|
03238 |*      NONE                                                                  *|
03239 |*                                                                            *|
03240 |* Returns:                                                                   *|
03241 |*      attr index of new attribute.                                          *|
03242 |*                                                                            *|
03243 \******************************************************************************/
03244 
03245 int     generic_spec_semantics(void) 
03246 
03247 {
03248    int          attr_idx;
03249    boolean      generic_name;
03250    int          host_attr_idx;
03251    int          host_name_idx;
03252    int          name_idx;
03253    boolean      new_attr        = FALSE;
03254    int          new_attr_idx;
03255    int          scp_idx;
03256    int          type_idx;
03257 
03258 
03259    TRACE (Func_Entry, "generic_spec_semantics", NULL);
03260 
03261    generic_name = TOKEN_VALUE(token) == Tok_Id;
03262    attr_idx     = srch_sym_tbl(TOKEN_STR(token),
03263                                TOKEN_LEN(token),
03264                                &name_idx);
03265 
03266    if (stmt_type == Interface_Stmt) {
03267 
03268       if (attr_idx == NULL_IDX) {  /* Didn't find entry in local scope */
03269          host_attr_idx = srch_host_sym_tbl(TOKEN_STR(token), 
03270                                            TOKEN_LEN(token),
03271                                            &host_name_idx,
03272                                            TRUE);
03273 
03274          if (host_attr_idx == NULL_IDX ||
03275             AT_OBJ_CLASS(host_attr_idx) != Interface) {
03276 
03277             /* The only host association in this situation, is if the   */
03278             /* host is an INTERFACE.  If it is not, make a LN_DEF_LOC   */
03279             /* interface entry in the local scope.                      */
03280 
03281             attr_idx                    = ntr_sym_tbl(&token, name_idx);
03282             AT_OBJ_CLASS(attr_idx)      = Interface;
03283             LN_DEF_LOC(name_idx)        = TRUE;
03284             new_attr                    = TRUE;
03285 
03286             if (generic_name) {
03287                ATI_INTERFACE_CLASS(attr_idx) = Generic_Unknown_Interface;
03288             }
03289          }
03290          else if (AT_NOT_VISIBLE(host_attr_idx)) {
03291             PRINTMSG(TOKEN_LINE(token), 486, Error,
03292                      TOKEN_COLUMN(token),
03293                      AT_OBJ_NAME_PTR(host_attr_idx),
03294                      AT_OBJ_NAME_PTR(AT_MODULE_IDX((host_attr_idx))));
03295             attr_idx                    = ntr_sym_tbl(&token, name_idx);
03296             AT_OBJ_CLASS(attr_idx)      = Interface;
03297             LN_DEF_LOC(name_idx)        = TRUE;
03298             new_attr                    = TRUE;
03299 
03300             if (generic_name) {
03301                ATI_INTERFACE_CLASS(attr_idx) = Generic_Unknown_Interface;
03302             }
03303          }
03304          else { /* Found interface in host.  Make a new entry in the local   */
03305                 /* scp and copy the attr.  LN_DEF_LOC gets set in local scp. */
03306 
03307             if (AT_IS_INTRIN(host_attr_idx) &&
03308                 ATI_FIRST_SPECIFIC_IDX(host_attr_idx) == NULL_IDX) {
03309                complete_intrinsic_definition(host_attr_idx);
03310                attr_idx = srch_sym_tbl(TOKEN_STR(token), 
03311                                        TOKEN_LEN(token), 
03312                                        &name_idx);
03313             }
03314 
03315             attr_idx = ntr_host_in_sym_tbl(&token, 
03316                                            name_idx,
03317                                            host_attr_idx,
03318                                            host_name_idx,
03319                                            TRUE);
03320 
03321             type_idx = (AT_TYPED(host_attr_idx)) ? ATD_TYPE_IDX(host_attr_idx) :
03322                                                    NULL_IDX;
03323 
03324             COPY_VARIANT_ATTR_INFO(host_attr_idx, attr_idx, Interface);
03325 
03326             LN_DEF_LOC(name_idx)          = TRUE;
03327             AT_ATTR_LINK(attr_idx)        = NULL_IDX;
03328             AT_IS_INTRIN(attr_idx)        = AT_IS_INTRIN(host_attr_idx);
03329             AT_ELEMENTAL_INTRIN(attr_idx) = AT_ELEMENTAL_INTRIN(host_attr_idx);
03330             ATD_TYPE_IDX(attr_idx)        = type_idx;
03331             AT_DEF_LINE(attr_idx)         = TOKEN_LINE(token);
03332             AT_DEF_COLUMN(attr_idx)       = TOKEN_COLUMN(token);
03333          }
03334       }
03335       else if ((!AT_USE_ASSOCIATED(attr_idx) ||
03336                  AT_OBJ_CLASS(attr_idx) != Pgm_Unit ||
03337                  ATP_PROC(attr_idx) != Module_Proc) &&
03338                fnd_semantic_err(Obj_Generic_Interface,
03339                                 TOKEN_LINE(token),
03340                                 TOKEN_COLUMN(token),
03341                                 attr_idx,
03342                                 TRUE)) {
03343          CREATE_ERR_ATTR(attr_idx, TOKEN_LINE(token),
03344                                    TOKEN_COLUMN(token), Interface);
03345          AT_OBJ_CLASS(attr_idx) = Interface;
03346       }
03347       else if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {
03348 
03349          /* Must be a function or subroutine */
03350 
03351          NTR_ATTR_TBL(new_attr_idx);
03352          COPY_COMMON_ATTR_INFO(attr_idx, new_attr_idx, Interface);
03353          AT_DEF_LINE(new_attr_idx)      = TOKEN_LINE(token);
03354          AT_DEF_COLUMN(new_attr_idx)    = TOKEN_COLUMN(token);
03355          ATI_PROC_IDX(new_attr_idx)     = attr_idx;
03356          LN_ATTR_IDX(name_idx)          = new_attr_idx;
03357          LN_NAME_IDX(name_idx)          = AT_NAME_IDX(new_attr_idx);
03358 
03359          if (ATP_RSLT_IDX(attr_idx) != NULL_IDX && 
03360              AT_TYPED(ATP_RSLT_IDX(attr_idx))) {
03361             ATD_TYPE_IDX(new_attr_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx));
03362          }
03363 
03364          attr_idx                       = new_attr_idx;
03365 
03366          if (generic_name) {
03367             ATI_INTERFACE_CLASS(attr_idx) = Generic_Unknown_Interface;
03368          }
03369       }
03370       else if (AT_OBJ_CLASS(attr_idx) != Interface) {
03371          scp_idx                = curr_scp_idx;
03372          curr_scp_idx           = INTRINSIC_SCP_IDX;
03373          host_attr_idx          = srch_sym_tbl(TOKEN_STR(token), 
03374                                                TOKEN_LEN(token),
03375                                                &host_name_idx);
03376          curr_scp_idx           = scp_idx;
03377 
03378          if (host_attr_idx == NULL_IDX) {
03379             CLEAR_VARIANT_ATTR_INFO(attr_idx, Interface);
03380             type_idx            = NULL_IDX;
03381          }
03382          else {  /* It is an intrinsic */
03383             complete_intrinsic_definition(host_attr_idx);
03384             COPY_VARIANT_ATTR_INFO(host_attr_idx, attr_idx, Interface);
03385             AT_ATTR_LINK(attr_idx)        = NULL_IDX;
03386             AT_IS_INTRIN(attr_idx)        = AT_IS_INTRIN(host_attr_idx);
03387             AT_ELEMENTAL_INTRIN(attr_idx) = AT_ELEMENTAL_INTRIN(host_attr_idx);
03388             type_idx                      = ATD_TYPE_IDX(host_attr_idx);
03389          }
03390 
03391          ATD_TYPE_IDX(attr_idx)           = type_idx;
03392          AT_DEF_LINE(attr_idx)            = TOKEN_LINE(token);
03393          AT_DEF_COLUMN(attr_idx)          = TOKEN_COLUMN(token);
03394       }
03395    }
03396    else if (CURR_BLK == Module_Blk) {           /* Public/Private statement */
03397 
03398       if (attr_idx == NULL_IDX) {
03399          attr_idx               = ntr_sym_tbl(&token, name_idx);
03400          LN_DEF_LOC(name_idx)   = TRUE;
03401          new_attr               = TRUE;
03402 
03403          if (generic_name) {
03404             SET_IMPL_TYPE(attr_idx);
03405          }
03406          else {
03407             AT_OBJ_CLASS(attr_idx)      = Interface;
03408          }
03409       }  /* NOT_VISIBLE and other semantics are done by the caller */
03410    }
03411    else if (attr_idx == NULL_IDX) {
03412       attr_idx                  = ntr_sym_tbl(&token, name_idx);
03413       LN_DEF_LOC(name_idx)      = TRUE;
03414       new_attr                  = TRUE;
03415 
03416       if (generic_name) {
03417          SET_IMPL_TYPE(attr_idx);
03418       }
03419       else {
03420          AT_OBJ_CLASS(attr_idx) = Interface;
03421       }
03422    }
03423    else if (AT_REFERENCED(attr_idx) == Char_Rslt_Bound_Ref) {
03424       AT_ATTR_LINK(attr_idx)   = NULL_IDX;
03425       LN_DEF_LOC(name_idx)     = TRUE;
03426    }
03427 
03428 
03429    /* CIF processing uses ATI_USER_SPECIFIED and AT_IS_INTRINSIC to determine */
03430    /* that an intrinsic procedure name is being overloaded.  Must check that  */
03431    /* the current statement is an interface block statement because this      */
03432    /* routine is also called to parse the generic name in a PUBLIC/PRIVATE    */
03433    /* statement.                                                              */
03434 
03435    if (stmt_type == Interface_Stmt  && 
03436        AT_OBJ_CLASS(attr_idx) == Interface  &&  generic_name) {
03437       ATI_USER_SPECIFIED(attr_idx) = TRUE;
03438    }
03439 
03440 
03441    if (new_attr && !generic_name) {
03442 
03443       switch (TOKEN_VALUE(token)) {
03444       case Tok_Op_Add :
03445          ATI_DEFINED_OPR(attr_idx)     = Plus_Opr;
03446          ATI_INTERFACE_CLASS(attr_idx) = Defined_Unary_Or_Binary_Interface;
03447          break;
03448 
03449       case Tok_Op_Div :
03450          ATI_DEFINED_OPR(attr_idx)     = Div_Opr;
03451          ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
03452          break;
03453 
03454       case Tok_Op_Mult :
03455          ATI_DEFINED_OPR(attr_idx)     = Mult_Opr;
03456          ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
03457          break;
03458 
03459       case Tok_Op_Power :
03460          ATI_DEFINED_OPR(attr_idx)     = Power_Opr;
03461          ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
03462          break;
03463 
03464       case Tok_Op_Sub :
03465          ATI_DEFINED_OPR(attr_idx)     = Minus_Opr;
03466          ATI_INTERFACE_CLASS(attr_idx) = Defined_Unary_Or_Binary_Interface;
03467          break;
03468 
03469       case Tok_Op_Concat :
03470          ATI_DEFINED_OPR(attr_idx)     = Concat_Opr;
03471          ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
03472          break;
03473 
03474       case Tok_Op_Eq :
03475          ATI_DEFINED_OPR(attr_idx)     = Eq_Opr;
03476          ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
03477          break;
03478 
03479       case Tok_Op_Ge :
03480          ATI_DEFINED_OPR(attr_idx)     = Ge_Opr;
03481          ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
03482          break;
03483 
03484       case Tok_Op_Gt :
03485          ATI_DEFINED_OPR(attr_idx)     = Gt_Opr;
03486          ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
03487          break;
03488 
03489       case Tok_Op_Le :
03490          ATI_DEFINED_OPR(attr_idx)     = Le_Opr;
03491          ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
03492          break;
03493 
03494       case Tok_Op_Lt :
03495          ATI_DEFINED_OPR(attr_idx)     = Lt_Opr;
03496          ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
03497          break;
03498 
03499       case Tok_Op_Ne :
03500          ATI_DEFINED_OPR(attr_idx)     = Ne_Opr;
03501          ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
03502          break;
03503 
03504       case Tok_Op_Lg :
03505          ATI_DEFINED_OPR(attr_idx)     = Lg_Opr;
03506          ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
03507          break;
03508 
03509       case Tok_Op_And :
03510          ATI_DEFINED_OPR(attr_idx)     = And_Opr;
03511          ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
03512          break;
03513 
03514       case Tok_Op_Eqv :
03515          ATI_DEFINED_OPR(attr_idx)     = Eqv_Opr;
03516          ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
03517          break;
03518 
03519       case Tok_Op_Neqv :
03520          ATI_DEFINED_OPR(attr_idx)     = Neqv_Opr;
03521          ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
03522          break;
03523 
03524       case Tok_Op_Not :
03525          ATI_DEFINED_OPR(attr_idx)     = Not_Opr;
03526          ATI_INTERFACE_CLASS(attr_idx) = Defined_Unary_Interface;
03527          break;
03528 
03529       case Tok_Op_Or :
03530          ATI_DEFINED_OPR(attr_idx)     = Or_Opr;
03531          ATI_INTERFACE_CLASS(attr_idx) = Defined_Binary_Interface;
03532          break;
03533 
03534       case Tok_Op_Assign :
03535          ATI_DEFINED_OPR(attr_idx)     = Asg_Opr;
03536          ATI_INTERFACE_CLASS(attr_idx) = Defined_Assign_Interface;
03537          break;
03538 
03539       case Tok_Op_Defined :
03540          ATI_DEFINED_OPR(attr_idx)     = Null_Opr;
03541          ATI_INTERFACE_CLASS(attr_idx) = Defined_Unary_Or_Binary_Interface;
03542          break;
03543       }
03544    }
03545 
03546    if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
03547       ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE;
03548    }
03549 
03550    if ((cif_flags & XREF_RECS) != 0) {
03551       cif_usage_rec(attr_idx, 
03552                     AT_Tbl_Idx,
03553                     TOKEN_LINE(token),
03554                     TOKEN_COLUMN(token),
03555                     CIF_Symbol_Declaration);
03556    }
03557 
03558    TRACE (Func_Exit, "generic_spec_semantics", NULL);
03559 
03560    return(attr_idx);
03561 
03562 }  /* generic_spec_semantics */
03563 
03564 /******************************************************************************\
03565 |*                                                                            *|
03566 |* Description:                                                               *|
03567 |*      Check to see if attr was used to declare its own bounds.   An object  *|
03568 |*      cannot be dimensioned after it is referenced, so an error situation   *|
03569 |*      definitely exists.  This is a bit of compile time to check, but we    *|
03570 |*      are in an error situation anyway.  This searches the bounds looking   *|
03571 |*      for a reference to the attr in the bounds for the array.              *|
03572 |*                                                                            *|
03573 |* Input parameters:                                                          *|
03574 |*      attr index to look for                                                *|
03575 |*      bd index of dimension to searh                                        *|
03576 |*                                                                            *|
03577 |* Output parameters:                                                         *|
03578 |*      NONE                                                                  *|
03579 |*                                                                            *|
03580 |* Returns:                                                                   *|
03581 |*      TRUE if an error is issued.                                           *|
03582 |*                                                                            *|
03583 \******************************************************************************/
03584 
03585 static boolean  is_attr_referenced_in_bound(int         bd_idx,
03586                                             int         attr_idx) 
03587 
03588 {
03589    boolean      error           = FALSE;
03590    opnd_type    opnd;
03591    int          rank;
03592 
03593 
03594    TRACE (Func_Entry, "is_attr_referenced_in_bound", NULL);
03595 
03596    if (BD_ARRAY_CLASS(bd_idx) != Deferred_Shape) {
03597 
03598       for (rank = BD_RANK(bd_idx); rank >0; rank--) {
03599 
03600          if (BD_LB_FLD(bd_idx, rank) == AT_Tbl_Idx &&
03601              ATD_FLD(BD_LB_IDX(bd_idx, rank)) == IR_Tbl_Idx &&
03602              find_attr_in_ir(attr_idx, 
03603                              ATD_TMP_IDX(BD_LB_IDX(bd_idx, rank)),
03604                              &opnd)) {
03605             AT_DCL_ERR(attr_idx)        = TRUE;
03606             BD_DCL_ERR(bd_idx)          = TRUE;
03607             error                       = TRUE;
03608             PRINTMSG(OPND_LINE_NUM(opnd), 1036, Error,
03609                      OPND_COL_NUM(opnd),
03610                      AT_OBJ_NAME_PTR(attr_idx));
03611             break;
03612          }
03613 
03614          if (BD_UB_FLD(bd_idx, rank) == AT_Tbl_Idx &&
03615              ATD_FLD(BD_UB_IDX(bd_idx, rank)) == IR_Tbl_Idx &&
03616              find_attr_in_ir(attr_idx, 
03617                              ATD_TMP_IDX(BD_UB_IDX(bd_idx, rank)),
03618                              &opnd)) {
03619             AT_DCL_ERR(attr_idx)        = TRUE;
03620             BD_DCL_ERR(bd_idx)          = TRUE;
03621             error                       = TRUE;
03622             PRINTMSG(OPND_LINE_NUM(opnd), 1036, Error,
03623                      OPND_COL_NUM(opnd),
03624                      AT_OBJ_NAME_PTR(attr_idx));
03625             break;
03626          }
03627       }
03628    }
03629 
03630    TRACE (Func_Exit, "is_attr_referenced_in_bound", NULL);
03631 
03632    return(error);
03633 
03634 }  /* is_attr_referenced_in_bound */
03635 
03636 /******************************************************************************\
03637 |*                                                                            *|
03638 |* Description:                                                               *|
03639 |*      Parses the pe array_spec for declarations (F--)                       *|
03640 |*             array_spec is explicit-shape-spec-list                         *|
03641 |*                            is [lower-bound :]upper-bound                   *|
03642 |*                               [specification-expr :] specification-expr    *|
03643 |*                       is assumed-size-spec                                 *|
03644 |*                          is [explicit-shape-spec-list,] [lower-bound:]*    *|
03645 |*                                                                            *|
03646 |*       Position  - entry - token is open brkt                               *|
03647 |*                   exit  - token is verified close brkt                     *|
03648 |*                           if close brkt is missing.  LA_CH is set to       *|
03649 |*                           colon-colon, or EOS                              *|
03650 |*                                                                            *|
03651 |* Returns:                                                                   *|
03652 |*      NONE                                                                  *|
03653 |*                                                                            *|
03654 \******************************************************************************/
03655 int     parse_pe_array_spec(int    attr_idx)
03656 
03657 {
03658    int                  bd_idx;
03659    int                  column;
03660    boolean              fold_it;
03661    boolean              found_end               = FALSE;
03662    boolean              found_error             = FALSE;
03663    fld_type             lb_fld;
03664    long                 lb_len_idx;
03665    int                  line;
03666    boolean              lower_bound_found;
03667    boolean              non_constant_size       = FALSE;
03668    int                  rank                    = 1;
03669    reference_type       referenced;
03670    fld_type             ub_fld;
03671    long                 ub_len_idx;
03672 
03673 
03674    TRACE (Func_Entry, "parse_pe_array_spec", NULL);
03675 
03676 # ifdef _DEBUG
03677    if (LA_CH_VALUE != LBRKT) {
03678       PRINTMSG(LA_CH_LINE, 295, Internal, LA_CH_COLUMN,
03679                "parse_pe_array_spec", "LBRKT");
03680    }
03681 # endif
03682 
03683    NEXT_LA_CH;                                               /* Skip Lbrkt   */
03684    bd_idx                       = reserve_array_ntry(7);
03685    referenced                   = (reference_type) AT_REFERENCED(attr_idx);
03686    AT_REFERENCED(attr_idx)      = Not_Referenced;
03687    BD_LINE_NUM(bd_idx)          = LA_CH_LINE;
03688    BD_COLUMN_NUM(bd_idx)        = LA_CH_COLUMN;
03689 
03690    /* If LA_CH is RBRKT, there is no dimension, so default to a rank 1       */
03691    /* constant sized array of length 1 and return.                            */
03692 
03693    if (LA_CH_VALUE == RBRKT) {
03694       parse_err_flush(Find_None, "dimension-spec");
03695       BD_ARRAY_CLASS(bd_idx)    = Explicit_Shape;
03696       BD_ARRAY_SIZE(bd_idx)     = Constant_Size;
03697       BD_DCL_ERR(bd_idx)        = TRUE;
03698       BD_RANK(bd_idx)           = 1;
03699       BD_LB_FLD(bd_idx, 1)      = CN_Tbl_Idx;
03700       BD_LB_IDX(bd_idx, 1)      = CN_INTEGER_ONE_IDX;
03701       BD_UB_FLD(bd_idx, 1)      = CN_Tbl_Idx;
03702       BD_UB_IDX(bd_idx, 1)      = CN_INTEGER_ONE_IDX;
03703       NEXT_LA_CH;
03704       goto EXIT;
03705    }
03706 
03707    /* Set fold_it flag.  Will continue on and do pass2 style semantic     */
03708    /* checking and constant folding, if this is a component declaration.  */
03709 
03710    fold_it = (CURR_BLK == Derived_Type_Blk);
03711 
03712    do {  /* Process each dimension of the array */
03713       lower_bound_found         = FALSE;
03714       lb_len_idx                = CN_INTEGER_ONE_IDX;
03715       lb_fld                    = CN_Tbl_Idx;
03716       ub_len_idx                = NULL_IDX;
03717       ub_fld                    = NO_Tbl_Idx;
03718 
03719       if (LA_CH_VALUE != COLON && LA_CH_VALUE != STAR) {
03720          line           = LA_CH_LINE;
03721          column         = LA_CH_COLUMN;
03722 
03723          /* If LA_CH isn't a COLON or a STAR, then this must be an expression.*/
03724          /* Get the expression and determine if it is a lower or upper bound. */
03725          /* If there is a parse error, a constant one is returned.            */
03726 
03727          if (!parse_int_spec_expr(&ub_len_idx, &ub_fld, fold_it, FALSE)) {
03728             ub_len_idx          = CN_INTEGER_ONE_IDX;
03729             ub_fld              = CN_Tbl_Idx;
03730             BD_DCL_ERR(bd_idx)  = TRUE;
03731          }
03732 
03733          if (ub_fld != CN_Tbl_Idx) {
03734             non_constant_size   = TRUE;
03735          }
03736 
03737          if (LA_CH_VALUE == COLON) {                   /* This is lower bound */
03738             lower_bound_found           = TRUE;
03739             lb_len_idx                  = ub_len_idx;
03740             lb_fld                      = ub_fld;
03741             ub_len_idx                  = NULL_IDX;
03742             ub_fld                      = NO_Tbl_Idx;
03743          }
03744          else {
03745             BD_ARRAY_CLASS(bd_idx)      = Explicit_Shape;
03746          }
03747       }
03748 
03749       /* Now the parser is in one of 3 states. (1) Lower bound found, upper   */
03750       /* bound = NULL, LA_CH must be COLON. (2) Lower bound not found, so it  */
03751       /* is set to a default of 1, upper bound is found and LA_CH is COMMA or */
03752       /* RBRKT.   (LA_CH must be COLON.) (3) Neither lower bound or upper    */
03753       /* bound have been seen, they are set to defaults of lb=1, ub=NULL.     */
03754       /* LA_CH is COLON or STAR.  If the LA_CH is COLON, this is either a     */
03755       /* Deferred-Shape spec or it is followed by the upper bound for an      */
03756       /* Explicit-Shape spec.  NOTE: LA_CH may be EOS - this is parse error.  */
03757 
03758       if (LA_CH_VALUE == COLON) {
03759          line           = LA_CH_LINE;
03760          column         = LA_CH_COLUMN;
03761          NEXT_LA_CH;                            /* Skip COLON */
03762 
03763          if (LA_CH_VALUE == COMMA || LA_CH_VALUE == RBRKT) {
03764 
03765             /* Have one of two cases  1)  ARRAY(1:)  - This is an assumed     */
03766             /* shape spec which is classed as a Deferred-Shape, or 2) ARRAY(:)*/
03767             /* which is a deferred-Shape spec.   Issue an error if this array */
03768             /* has already been classified as an Explicit_Shape array.        */
03769 
03770             if (BD_ARRAY_CLASS(bd_idx) == Explicit_Shape) {
03771                PRINTMSG(line, 115, Error, column);
03772                BD_DCL_ERR(bd_idx)       = TRUE;
03773             }
03774             else {  /* Must be Deferred-Shape spec */
03775                BD_ARRAY_CLASS(bd_idx)   = Deferred_Shape;
03776             }
03777          }
03778          else {
03779 
03780             /* Have one of two cases  1)  ARRAY (1:10) - legal - pick up upper*/
03781             /* bound expression.  Err if array is already set to Deferred-    */
03782             /* Shape spec.  2) ARRAY (:10) - illegal - issue error.           */
03783             /* If the upper bound is a STAR, pick it up in the next section.  */
03784 
03785             if (!lower_bound_found) {                   /* A(:10) - illegal   */
03786                PRINTMSG(LA_CH_LINE, 119, Error, LA_CH_COLUMN, &LA_CH_VALUE);
03787                BD_DCL_ERR(bd_idx)       = TRUE;
03788             }
03789 
03790             if (LA_CH_VALUE != STAR) {
03791                line     = LA_CH_LINE;
03792                column   = LA_CH_COLUMN;
03793 
03794                if (!parse_int_spec_expr(&ub_len_idx, &ub_fld, fold_it, FALSE)) {
03795 
03796                   /* Expression parser recovers LA_CH to : ) , or EOS */
03797 
03798                   BD_DCL_ERR(bd_idx)    = TRUE;
03799                   ub_len_idx            = CN_INTEGER_ONE_IDX;
03800                   ub_fld                = CN_Tbl_Idx;
03801                }
03802 
03803                if (ub_fld != CN_Tbl_Idx) {
03804                   non_constant_size     = TRUE;
03805                }
03806 
03807                BD_ARRAY_CLASS(bd_idx)= Explicit_Shape;
03808             }
03809          }
03810       }
03811 
03812       /* The parser may be:  1)  ARRAY(*) - lb=1, ub=NULL_IDX.  2) ARR(10:*)  */
03813       /* lb is set, and ub=NULL_IDX.  3)  ARRAY(:*) - illegal -error already  */
03814       /* issued.  You could not have picked up a lower bound and/or an upper  */
03815       /* bound and got to this position, because a * is part of an expression.*/
03816       /* The expression parser stops at COLON, COMMA, RBRKT or EOS.          */
03817 
03818       if (LA_CH_VALUE == STAR) {
03819          line   = LA_CH_LINE;
03820          column = LA_CH_COLUMN;
03821          NEXT_LA_CH;                            /* Skip STAR */
03822 
03823          BD_ARRAY_CLASS(bd_idx)      = Assumed_Size;
03824          ub_len_idx                  = lb_len_idx;
03825          ub_fld                      = lb_fld;
03826 
03827          if (LA_CH_VALUE != RBRKT) {
03828 
03829             /* The assumed-size specifier * must be in the last dimension. */
03830 
03831             BD_DCL_ERR(bd_idx)       = TRUE;
03832             PRINTMSG(line, 116, Error, column);
03833             parse_err_flush(Find_Rparen, NULL);
03834          }
03835       }
03836 
03837       BD_LB_IDX(bd_idx, rank)   = lb_len_idx;
03838       BD_LB_FLD(bd_idx, rank)   = lb_fld;
03839       BD_UB_IDX(bd_idx, rank)   = ub_len_idx;
03840       BD_UB_FLD(bd_idx, rank)   = ub_fld;
03841 
03842       if (LA_CH_VALUE == COMMA) {
03843 
03844          if (rank++ == 7) {          /* issue error - too many ranks */
03845             found_end           = TRUE;
03846             BD_DCL_ERR(bd_idx)  = TRUE;
03847             PRINTMSG(LA_CH_LINE, 117, Error, LA_CH_COLUMN);
03848             parse_err_flush(Find_Rparen, NULL);
03849          }
03850          else {
03851             NEXT_LA_CH;
03852          }
03853       }
03854       else {
03855          found_end = TRUE;
03856       }
03857 
03858       found_error = BD_DCL_ERR(bd_idx) | found_error;
03859    }
03860    while (!found_end);
03861 
03862    if (LA_CH_VALUE == RBRKT ||
03863        parse_err_flush(Find_EOS, (found_error) ? NULL : ", or )")) {
03864 
03865       NEXT_LA_CH;               /* Skip RBRKT */
03866    }
03867 
03868    if (!non_constant_size) {
03869       BD_ARRAY_SIZE(bd_idx) = Constant_Size;
03870    }
03871 
03872    BD_RANK(bd_idx) = rank;
03873 
03874 # ifdef _DEBUG
03875    if (BD_ARRAY_CLASS(bd_idx) == Unknown_Array) {
03876 
03877       /* There is a parsing problem here.  This must never be Unknown_Array */
03878 
03879       PRINTMSG(LA_CH_LINE, 178, Internal, LA_CH_COLUMN);
03880    }
03881 # endif
03882 
03883 EXIT:
03884 
03885    if (AT_REFERENCED(attr_idx) > Not_Referenced) {
03886       is_attr_referenced_in_bound(bd_idx, attr_idx);
03887    }
03888 
03889    if (AT_REFERENCED(attr_idx) < referenced) {
03890       AT_REFERENCED(attr_idx)   = referenced;
03891    }
03892 
03893    bd_idx = ntr_array_in_bd_tbl(bd_idx);
03894 
03895    TRACE (Func_Exit, "parse_pe_array_spec", NULL);
03896 
03897    return(bd_idx);
03898 
03899 }  /* parse_pe_array_spec */
03900 
03901 /******************************************************************************\
03902 |*                                                                            *|
03903 |* Description:                                                               *|
03904 |*      Add the co-array attribute to the attr.                               *|
03905 |*                                                                            *|
03906 |* Input parameters:                                                          *|
03907 |*      chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
03908 |*                       is FALSE, just add the attribute to the Attr.        *|
03909 |*      line          -> The line number of the object.                       *|
03910 |*      column        -> The column number of the object.                     *|
03911 |*      attr_idx      -> Attr index to add the co-array attribute to.         *|
03912 |*      pe_array_idx  -> bounds table index describing the co-array.          *|
03913 |*                                                                            *|
03914 |* Output parameters:                                                         *|
03915 |*      NONE                                                                  *|
03916 |*                                                                            *|
03917 |* Returns:                                                                   *|
03918 |*      TRUE if successful merge.                                             *|
03919 |*                                                                            *|
03920 \******************************************************************************/
03921 
03922 boolean merge_co_array(boolean  chk_semantics,
03923                    int          line,
03924                    int          column,
03925                    int          attr_idx,
03926                    int          pe_array_idx)
03927 {
03928    boolean      fnd_err;
03929 
03930 
03931    TRACE (Func_Entry, "merge_co_array", NULL);
03932    
03933    if (!chk_semantics || !fnd_semantic_err(Obj_Co_Array,
03934                                            line,
03935                                            column,
03936                                            attr_idx,
03937                                            TRUE)) {
03938       ATD_PE_ARRAY_IDX(attr_idx) = pe_array_idx;
03939       fnd_err   = FALSE;
03940    }
03941    else {
03942       fnd_err   = TRUE;
03943    }
03944 
03945    TRACE (Func_Exit, "merge_co_array", NULL);
03946 
03947    return(!fnd_err);
03948 
03949 }  /* merge_co_array */
03950 
03951 /******************************************************************************\
03952 |*                                                                            *|
03953 |* Description:                                                               *|
03954 |*      Add the SAVE attribute to an attr.                                    *|
03955 |*                                                                            *|
03956 |* Input parameters:                                                          *|
03957 |*      chk_semantics -> TRUE if semantic checking needs to be done.  If this *|
03958 |*                       is FALSE, just add the attribute to the attr.        *|
03959 |*      line     -> The line number of the object to add the attribute to     *|
03960 |*      column   -> The line number of the object to add the attribute to     *|
03961 |*      attr_idx -> Attr index to add the EXTERNAL attribute to.              *|
03962 |*                                                                            *|
03963 |* Output parameters:                                                         *|
03964 |*      NONE                                                                  *|
03965 |*                                                                            *|
03966 |* Returns:                                                                   *|
03967 |*      TRUE if successful merge.                                             *|
03968 |*                                                                            *|
03969 \******************************************************************************/
03970 
03971 boolean merge_volatile(boolean  chk_semantics,
03972                        int              line,
03973                        int              column,
03974                        int              attr_idx)
03975 
03976 {
03977    boolean      fnd_err         = FALSE;
03978 
03979 
03980    TRACE (Func_Entry, "merge_volatile", NULL);
03981 
03982    if (chk_semantics) {
03983       fnd_err = fnd_semantic_err(Obj_Volatile, line, column, attr_idx, TRUE);
03984 
03985       if (!fnd_err && ATD_VOLATILE(attr_idx)) {
03986          PRINTMSG(line, 1259, Ansi, column, AT_OBJ_NAME_PTR(attr_idx), 
03987                   "VOLATILE");
03988       }
03989    }
03990    else {
03991       SET_IMPL_TYPE(attr_idx);
03992    }
03993 
03994    if (!fnd_err) {
03995       ATD_VOLATILE(attr_idx)    = TRUE;
03996    }
03997 
03998    TRACE (Func_Exit, "merge_volatile", NULL);
03999 
04000    return(!fnd_err);
04001 
04002 }  /* merge_volatile */