Open64: osprey/crayf90/fe90/p_dcl

00001 /*
00002  *  Copyright (C) 2006. QLogic Corporation. All Rights Reserved.
00003  */
00004 
00005 /*
00006 
00007   Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.
00008 
00009   This program is free software; you can redistribute it and/or modify it
00010   under the terms of version 2 of the GNU General Public License as
00011   published by the Free Software Foundation.
00012 
00013   This program is distributed in the hope that it would be useful, but
00014   WITHOUT ANY WARRANTY; without even the implied warranty of
00015   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  
00016 
00017   Further, this software is distributed without any warranty that it is
00018   free of the rightful claim of any third person regarding infringement 
00019   or the like.  Any license provided herein, whether implied or 
00020   otherwise, applies only to this software file.  Patent licenses, if 
00021   any, provided herein do not apply to combinations of this program with 
00022   other software, or any other product whatsoever.  
00023 
00024   You should have received a copy of the GNU General Public License along
00025   with this program; if not, write the Free Software Foundation, Inc., 59
00026   Temple Place - Suite 330, Boston MA 02111-1307, USA.
00027 
00028   Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
00029   Mountain View, CA 94043, or:
00030 
00031   http://www.sgi.com
00032 
00033   For further information regarding this notice, see:
00034 
00035   http://oss.sgi.com/projects/GenInfo/NoticeExplan
00036 
00037 */
00038 
00039 
00040 
00041 static char USMID[] = "\n@(#)5.0_pl/sources/p_dcl_attr.c  5.2 06/17/99 09:28:10\n";
00042 
00043 # include "defines.h"   /* Machine dependent ifdefs */
00044 
00045 # include "host.m"    /* Host machine dependent macros.*/
00046 # include "host.h"    /* Host machine dependent header.*/
00047 # include "target.m"    /* Target machine dependent macros.*/
00048 # include "target.h"    /* Target machine dependent header.*/
00049 
00050 # include "globals.m"
00051 # include "tokens.m"
00052 # include "sytb.m"
00053 # include "p_globals.m"
00054 # include "debug.m"
00055 
00056 # include "globals.h"
00057 # include "tokens.h"
00058 # include "sytb.h"
00059 # include "p_globals.h"
00060 
00061 
00062 /*****************************************************************\
00063 |* function prototypes of static functions declared in this file *|
00064 \*****************************************************************/
00065 #ifdef KEY /* Bug 14150 */
00066 static int parse_attrs(boolean (*func) (boolean, int, int, int));
00067 #else /* defined(BUILD_OS_DARWIN) */
00068 static void parse_attrs(boolean (*func) (boolean, int, int, int));
00069 #endif /* KEY Bug 14150 */
00070 
00071 
00072 /******************************************************************************\
00073 |*                        *|
00074 |* Description:                     *|
00075 |*      This is a generic parser, used by all the attribute statements,       *|
00076 |*      except for PUBLIC and PRIVATE.  It parses the statements, and         *|
00077 |*      calls the appropriate merge routine to update the symbol table.       *|
00078 |*                        *|
00079 |* Input parameters:                    *|
00080 |*  merge_function - pointer to the merge function to call          *|
00081 |*                        *|
00082 |* Output parameters:                   *|
00083 |*  NONE                      *|
00084 |*                        *|
00085 |* Returns:                     *|
00086 |*  NONE                      *|
00087 |*                        *|
00088 \******************************************************************************/
00089 
00090 #ifdef KEY /* Bug 14150 */
00091 static int
00092 #else /* KEY Bug 14150 */
00093 static void
00094 #endif /* KEY Bug 14150 */
00095 parse_attrs(boolean (*merge_function) ())
00096 
00097 {
00098    int    array_idx;
00099    int    attr_idx;
00100    boolean  blk_err   = FALSE;
00101    int    column;
00102    boolean  found_attr;
00103    boolean  found_end = FALSE;
00104    int    line;
00105    int    name_idx;
00106    int    new_sb_idx;
00107    int    sb_idx;
00108 #ifdef KEY /* Bug 14150 */
00109    int    count = 0;
00110 #endif /* KEY Bug 14150 */
00111 
00112 
00113    TRACE (Func_Entry, "parse_attrs", NULL);
00114 
00115    if (LA_CH_VALUE == COLON &&
00116        matched_specific_token(Tok_Punct_Colon_Colon, Tok_Class_Punct)) {
00117 
00118       /* Intentionally blank */
00119    }
00120 
00121    if ((STMT_OUT_OF_ORDER(curr_stmt_category, stmt_type) ||
00122         STMT_CANT_BE_IN_BLK(stmt_type, CURR_BLK)) && iss_blk_stk_err()) {
00123 
00124       /* block error issued by check. */
00125 
00126       blk_err = TRUE;
00127    }
00128    else {
00129       curr_stmt_category = Declaration_Stmt_Cat;
00130    }
00131 
00132    do {
00133       if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {  /* TOKEN is the id */
00134          line   = TOKEN_LINE(token);
00135          column   = TOKEN_COLUMN(token);
00136          attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token),
00137                                        &name_idx);
00138          found_attr = TRUE;
00139 
00140          if (attr_idx == NULL_IDX) {
00141             found_attr      = FALSE;
00142 #ifdef KEY /* Bug 14110 */
00143       /* Handle the case of "volatile x" when we haven't seen any other
00144        * declaration for "x" in the current scope, but there's an "x" in
00145        * the host scope. If we see no further declaration in the current
00146        * scope, then this will refer to the host-associated "x" instead
00147        * of creating a local one. */
00148       int junk_idx;
00149             if (merge_function == merge_volatile &&
00150         srch_host_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &junk_idx,
00151           FALSE) &&
00152         (LA_CH_VALUE == COMMA || LA_CH_VALUE == EOS)) {
00153         surprise_volatile(memcpy(malloc(TOKEN_LEN(token) + sizeof '\0'),
00154           TOKEN_STR(token), TOKEN_LEN(token)));
00155         int save_la_ch_value = LA_CH_VALUE;
00156         NEXT_LA_CH;
00157 
00158         if (save_la_ch_value == COMMA) {
00159     continue;
00160         }
00161         else if (save_la_ch_value == EOS) {
00162           break;
00163         }
00164       }
00165 #endif /* KEY Bug 14110 */
00166             attr_idx      = ntr_sym_tbl(&token, name_idx);
00167             LN_DEF_LOC(name_idx)  = TRUE;      /* Can't be host assoc */
00168 
00169             /* The merge functions set the implicit type - if needed */
00170          }
00171          else if (AT_REFERENCED(attr_idx) == Char_Rslt_Bound_Ref) {
00172             AT_ATTR_LINK(attr_idx)  = NULL_IDX;
00173             LN_DEF_LOC(name_idx)  = TRUE;
00174          }
00175 
00176          if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
00177             ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE;
00178          }
00179 
00180          if (LA_CH_VALUE == LPAREN) {
00181 
00182             switch (stmt_type) {
00183       
00184                case Allocatable_Stmt:
00185                case Automatic_Stmt:
00186                case Dimension_Stmt:
00187                case Pointer_Stmt:
00188                case Target_Stmt:
00189                   array_idx = parse_array_spec(attr_idx);
00190 
00191                   merge_dimension(attr_idx, line, column, array_idx);
00192 
00193                   if (!found_attr) {
00194                      SET_IMPL_TYPE(attr_idx);
00195                   }
00196                   found_attr = TRUE;  /* Have to merge with dimension */
00197                   break;
00198 
00199                default:
00200                   if (parse_err_flush(Find_Rparen, ", or " EOS_STR)) {
00201                      NEXT_LA_CH;  /* Get Rparen */
00202                   }
00203                   break;
00204 
00205             }  /* End switch */
00206          }
00207          else if (stmt_type == Dimension_Stmt) {
00208 
00209            /* DIMENSION needs dim spec */
00210 
00211 # ifdef _F_MINUS_MINUS
00212 
00213             if ((!cmd_line_flags.co_array_fortran) || LA_CH_VALUE != LBRKT) {
00214                parse_err_flush(Find_Comma, "(");
00215                AT_DCL_ERR(attr_idx) = TRUE;
00216             }
00217 # else
00218             parse_err_flush(Find_Comma, "(");
00219             AT_DCL_ERR(attr_idx) = TRUE;
00220 # endif
00221          }
00222 
00223 # ifdef _F_MINUS_MINUS
00224 
00225          if (LA_CH_VALUE == LBRKT && cmd_line_flags.co_array_fortran &&
00226              (stmt_type == Allocatable_Stmt ||
00227               stmt_type == Automatic_Stmt ||
00228               stmt_type == Dimension_Stmt ||
00229               stmt_type == Pointer_Stmt ||
00230               stmt_type == Target_Stmt)) {
00231             array_idx = parse_pe_array_spec(attr_idx);
00232             merge_co_array(found_attr, line, column, attr_idx, array_idx);
00233          }
00234 # endif
00235 
00236          if (stmt_type != Dimension_Stmt) {
00237             (*merge_function) (found_attr, line, column, attr_idx);
00238 #ifdef KEY /* Bug 14150 */
00239             count += 1;
00240 #endif /* KEY Bug 14150 */
00241          }
00242 
00243          AT_DCL_ERR(attr_idx) = AT_DCL_ERR(attr_idx) | blk_err;
00244 
00245          if ((cif_flags & XREF_RECS) != 0) {
00246             cif_usage_rec(attr_idx,
00247                           AT_Tbl_Idx,
00248                           line,
00249                           column,
00250                           CIF_Symbol_Declaration);
00251          }
00252       }
00253       else if (LA_CH_VALUE == SLASH &&
00254                (stmt_type == Save_Stmt ||
00255 #ifdef KEY /* Bug 14150 */
00256                 stmt_type == Bind_Stmt ||
00257 #endif /* KEY Bug 14150 */
00258                 stmt_type == Volatile_Stmt)) {
00259 
00260          NEXT_LA_CH;    /* Pick up slash */
00261 
00262          if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
00263             sb_idx   = srch_stor_blk_tbl(TOKEN_STR(token),
00264                                          TOKEN_LEN(token),
00265                                          curr_scp_idx);
00266 
00267             if (sb_idx == NULL_IDX) {
00268                sb_idx = ntr_stor_blk_tbl(TOKEN_STR(token),
00269                                            TOKEN_LEN(token),
00270                                            TOKEN_LINE(token),
00271                                            TOKEN_COLUMN(token),
00272                                            Common);
00273                SB_COMMON_NEEDS_OFFSET(sb_idx) = TRUE;
00274             }
00275             else if (SB_USE_ASSOCIATED(sb_idx) || SB_HOST_ASSOCIATED(sb_idx)) {
00276 
00277                /* Common block has been use or host associated into this scp. */
00278                /* Make an entry for this block and hide the associated block  */
00279                /* behind it.  storage_blk_resolution will resolve the blocks. */
00280 
00281                new_sb_idx = ntr_stor_blk_tbl(TOKEN_STR(token),
00282                                              TOKEN_LEN(token),
00283                                              TOKEN_LINE(token),
00284                                              TOKEN_COLUMN(token),
00285                                              Common);
00286                SB_MERGED_BLK_IDX(sb_idx)    = new_sb_idx;
00287                SB_COMMON_NEEDS_OFFSET(new_sb_idx) = TRUE;
00288                SB_HIDDEN(sb_idx)      = TRUE;
00289                SB_DEF_MULT_SCPS(sb_idx)     = TRUE;
00290                sb_idx         = new_sb_idx;
00291             }
00292 
00293             SB_DCL_ERR(sb_idx)  = SB_DCL_ERR(sb_idx) | blk_err;
00294 
00295             if (stmt_type == Save_Stmt) {
00296 
00297                if (SB_SAVED(sb_idx)) {
00298 
00299                    /* Cannot set SAVE twice for same common block name */
00300 
00301                   PRINTMSG(TOKEN_LINE(token), 110, Error, TOKEN_COLUMN(token),
00302                            SB_NAME_PTR(sb_idx));
00303                }
00304 
00305                SB_SAVED(sb_idx)   = TRUE;
00306             }
00307 #ifdef KEY /* Bug 14150 */
00308             else if (stmt_type == Bind_Stmt) {
00309          set_binding_label(SB_Tbl_Idx, sb_idx, &new_binding_label);
00310          count += 1;
00311          /* Make sure no common object in this block has been
00312           * equivalenced */
00313          for (int cobj_idx = SB_FIRST_ATTR_IDX(sb_idx);
00314      cobj_idx != NULL_IDX;
00315      cobj_idx = ATD_NEXT_MEMBER_IDX(cobj_idx)) {
00316      if (ATD_EQUIV(cobj_idx)) {
00317        /* Seems most useful to refer to line containing "common"
00318         * even if a declaration for the common object appeared
00319         * earlier than that */
00320        PRINTMSG(TOKEN_LINE(token), 550, Error, TOKEN_COLUMN(token),
00321          AT_OBJ_NAME_PTR(cobj_idx), "BIND", "EQUIVALENCE",
00322          SB_DEF_LINE(sb_idx));
00323      }
00324          }
00325       }
00326 #endif /* KEY Bug 14150 */
00327             else {  /* Volatile_Stmt */
00328                SB_VOLATILE(sb_idx)  = TRUE;
00329             }
00330 
00331             if ((cif_flags & XREF_RECS) != 0) {
00332                cif_sb_usage_rec(sb_idx,
00333                                 TOKEN_LINE(token),
00334                                 TOKEN_COLUMN(token),
00335                                 CIF_Symbol_Declaration);
00336             }
00337 
00338             if (LA_CH_VALUE == SLASH) {
00339                NEXT_LA_CH;    /* Pick up slash */
00340             }
00341             else {
00342                parse_err_flush(Find_Comma, "/");
00343             }
00344          }
00345          else {
00346             parse_err_flush(Find_Comma, "common-block-name");
00347          }
00348       }
00349       else {  /* Looking for id or common block name */
00350          parse_err_flush(Find_Comma, ((stmt_type == Save_Stmt ||
00351                                        stmt_type == Volatile_Stmt) ?
00352                                       "object-name or /" : "object-name"));
00353       }
00354 
00355       if (LA_CH_VALUE != COMMA && LA_CH_VALUE != EOS) {
00356          parse_err_flush(Find_Comma, ", or " EOS_STR);
00357       }
00358 
00359       if (LA_CH_VALUE == COMMA) {
00360          NEXT_LA_CH;        /* Pick up comma */
00361       }
00362       else if (LA_CH_VALUE == EOS) {
00363          found_end = TRUE;
00364          NEXT_LA_CH;        /* Pick up EOS */
00365       }
00366    }  /* End while */
00367    while (!found_end);
00368 
00369    TRACE (Func_Exit, "parse_attrs", NULL);
00370 
00371 #ifdef KEY /* Bug 14150 */
00372    return count;
00373 #else /* KEY Bug 14150 */
00374    return;
00375 #endif /* KEY Bug 14150 */
00376 
00377 
00378 }  /* parse_attrs */
00379 
00380 
00381 /******************************************************************************\
00382 |*                        *|
00383 |* Description:                     *|
00384 |*       Parse the PUBLIC and PRIVATE statements.                             *|
00385 |*       BNF  - PUBLIC  [[::] access-id-list]                                 *|
00386 |*              PRIVATE [[::] access-id-list]                                 *|
00387 |*              access-id IS use-name OR generic-spec                         *|
00388 |*                        *|
00389 |* Input parameters:                    *|
00390 |*  NONE                      *|
00391 |*                        *|
00392 |* Output parameters:                   *|
00393 |*  NONE                      *|
00394 |*                        *|
00395 |* Returns:                     *|
00396 |*  NONE                      *|
00397 |*                        *|
00398 \******************************************************************************/
00399 
00400 void parse_access_stmt()
00401 
00402 {
00403    access_type    access;
00404    int      attr_idx;
00405    boolean    found_end;
00406 
00407 
00408    TRACE (Func_Entry, "parse_access_stmt", NULL);
00409 
00410    access = (TOKEN_VALUE(token) == Tok_Kwd_Private) ? Private : Public;
00411 
00412    if (CURR_BLK == Derived_Type_Blk && access == Private) {
00413 
00414       if (LA_CH_VALUE == EOS) {
00415 
00416          if (ATT_PRIVATE_CPNT(CURR_BLK_NAME)) {
00417 
00418             /* The PRIVATE statement may only be specified once in a dt def */
00419 
00420             PRINTMSG(TOKEN_LINE(token), 41, Error, TOKEN_COLUMN(token),
00421                      "PRIVATE", AT_OBJ_NAME_PTR(CURR_BLK_NAME));
00422          }
00423          else if (ATT_FIRST_CPNT_IDX(CURR_BLK_NAME) != NULL_IDX) {
00424 
00425             /* PRIVATE must be specified before any components are */
00426 
00427             PRINTMSG(TOKEN_LINE(token), 8, Error, TOKEN_COLUMN(token),
00428                      "PRIVATE", AT_OBJ_NAME_PTR(CURR_BLK_NAME));
00429          }
00430 
00431          if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) {
00432             ATT_PRIVATE_CPNT(CURR_BLK_NAME) = TRUE;
00433          } 
00434          else {
00435             iss_blk_stk_err();
00436          }
00437       }
00438       else {
00439          parse_err_flush(Find_EOS, EOS_STR);
00440       }
00441       curr_stmt_category = Declaration_Stmt_Cat;
00442    }
00443    else {
00444 
00445       if (LA_CH_VALUE == EOS) {
00446 
00447          if (CURR_BLK == Module_Blk) {
00448 
00449             if (AT_ACCESS_SET(SCP_ATTR_IDX(curr_scp_idx))) {
00450 
00451                /* Issue error.  Don't allow access to change. */
00452 
00453                PRINTMSG(TOKEN_LINE(token), 656, Error, TOKEN_COLUMN(token),
00454                         AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));
00455                access = (access_type) AT_PRIVATE(SCP_ATTR_IDX(curr_scp_idx));
00456             }
00457 
00458             AT_ACCESS_SET(SCP_ATTR_IDX(curr_scp_idx)) = TRUE;
00459             AT_PRIVATE(SCP_ATTR_IDX(curr_scp_idx))  = access;
00460          }
00461          else {
00462             /* Intentionally blank.  If this is not a MODULE, it will be  */
00463             /* caught at the end of the routine in block checking.        */
00464          }
00465       }
00466       else {
00467          found_end  = FALSE;
00468 
00469          if (LA_CH_VALUE == COLON) {           /* Pick up optional :: */
00470             matched_specific_token(Tok_Punct_Colon_Colon, Tok_Class_Punct);
00471          }
00472 
00473          do {   /* parse_generic_spec issues CIF records */
00474             if (parse_generic_spec()) {
00475                attr_idx = generic_spec_semantics();
00476 
00477                if (CURR_BLK == Module_Blk) {
00478                   merge_access(attr_idx, TOKEN_LINE(token),
00479                                          TOKEN_COLUMN(token), access);
00480                }
00481             }
00482 
00483             if (LA_CH_VALUE != COMMA && LA_CH_VALUE != EOS) {
00484                parse_err_flush(Find_Comma, ", or " EOS_STR);
00485             }
00486 
00487             if (LA_CH_VALUE == COMMA) {
00488                NEXT_LA_CH;      /* Skip Comma */
00489             }
00490             else if (LA_CH_VALUE == EOS) {
00491                found_end = TRUE;
00492             }
00493          }  
00494          while (!found_end);
00495       }
00496 
00497       if ((CURR_BLK != Module_Blk ||
00498            STMT_OUT_OF_ORDER(curr_stmt_category, stmt_type)) &&
00499          iss_blk_stk_err()) {
00500          /* Block error - intentionally left blank */
00501       }
00502       else {
00503          curr_stmt_category = Declaration_Stmt_Cat;
00504       }
00505    }
00506    NEXT_LA_CH;          /* Always will be EOS */
00507 
00508    TRACE (Func_Exit, "parse_access_stmt", NULL);
00509    return;
00510 
00511 }  /* parse_access_stmt */
00512 
00513 
00514 /******************************************************************************\
00515 |*                        *|
00516 |* Description:                     *|
00517 |*      BNF       - ALLOCATABLE [::] array-name [(deferred-shape-spec-list)]  *|
00518 |*                               [,array-name [(deferred-shape-spec-list)]..  *|
00519 |*                        *|
00520 |* Input parameters:                    *|
00521 |*  NONE                      *|
00522 |*                        *|
00523 |* Output parameters:                   *|
00524 |*  NONE                      *|
00525 |*                        *|
00526 |* Returns:                     *|
00527 |*  NONE                      *|
00528 |*                        *|
00529 \******************************************************************************/
00530 
00531 void parse_allocatable_stmt (void)
00532 
00533 {
00534    TRACE (Func_Entry, "parse_allocatable_stmt", NULL);
00535 
00536    parse_attrs(merge_allocatable);
00537 
00538    TRACE (Func_Exit, "parse_allocatable_stmt", NULL);
00539 
00540    return;
00541 
00542 }  /* parse_allocatable_stmt */
00543 
00544 /******************************************************************************\
00545 |*                                                                            *|
00546 |* Description:                     *|
00547 |*      BNF       - AUTOMATIC [::] object-name              *|
00548 |*                                                                            *|
00549 |* Input parameters:                    *|
00550 |*  NONE                      *|
00551 |*                        *|
00552 |* Output parameters:                   *|
00553 |*  NONE                      *|
00554 |*                        *|
00555 |* Returns:                     *|
00556 |*  NONE                      *|
00557 |*                        *|
00558 \******************************************************************************/
00559 
00560 void parse_automatic_stmt (void)
00561 
00562 {
00563    TRACE (Func_Entry, "parse_automatic_stmt", NULL);
00564 
00565    PRINTMSG(stmt_start_line, 1253, Ansi, stmt_start_col, "AUTOMATIC");
00566    
00567    parse_attrs(merge_automatic);
00568 
00569    TRACE (Func_Exit, "parse_automatic_stmt", NULL);
00570 
00571    return;
00572 
00573 }  /* parse_automatic_stmt */
00574 
00575 
00576 /******************************************************************************\
00577 |*                        *|
00578 |* Description:                     *|
00579 |*      BNF       - DIMENSION [::] array-name (array-spec)                    *|
00580 |*                                 [,array-name (array_spec)]...              *|
00581 |*                        *|
00582 |* Input parameters:                    *|
00583 |*  NONE                      *|
00584 |*                        *|
00585 |* Output parameters:                   *|
00586 |*  NONE                      *|
00587 |*                        *|
00588 |* Returns:                     *|
00589 |*  NONE                      *|
00590 |*                        *|
00591 \******************************************************************************/
00592 
00593 void parse_dimension_stmt (void)
00594 
00595 {
00596    TRACE (Func_Entry, "parse_dimension_stmt", NULL);
00597 
00598    parse_attrs(NULL);
00599 
00600    TRACE (Func_Exit, "parse_dimension_stmt", NULL);
00601 
00602    return;
00603 
00604 }  /* parse_dimension_stmt */
00605 
00606 /******************************************************************************\
00607 |*                                                                            *|
00608 |* Description:                                                               *|
00609 |*      Parse the external statement                                          *|
00610 |*      BNF       - EXTERNAL external-name-list                               *|
00611 |*                                                                            *|
00612 |* Input parameters:                                                          *|
00613 |*      NONE                                                                  *|
00614 |*                                                                            *|
00615 |* Output parameters:                                                         *|
00616 |*      NONE                                                                  *|
00617 |*                                                                            *|
00618 |* Returns:                                                                   *|
00619 |*      NONE                                                                  *|
00620 |*                                                                            *|
00621 \******************************************************************************/
00622 
00623 void parse_external_stmt (void)
00624 
00625 {
00626    TRACE (Func_Entry, "parse_external_stmt", NULL);
00627 
00628    parse_attrs(merge_external);
00629 
00630    TRACE (Func_Exit, "parse_external_stmt", NULL);
00631 
00632    return;
00633 
00634 }  /* parse_external_stmt */
00635 
00636 /******************************************************************************\
00637 |*                        *|
00638 |* Description:                     *|
00639 |*      BNF    - INTENT(intent_spec) [::] dummy-arg-name-list                 *|
00640 |*                                                                            *|
00641 |* Input parameters:                    *|
00642 |*  NONE                      *|
00643 |*                        *|
00644 |* Output parameters:                   *|
00645 |*  NONE                      *|
00646 |*                        *|
00647 |* Returns:                     *|
00648 |*  NONE                      *|
00649 |*                        *|
00650 \******************************************************************************/
00651 
00652 void parse_intent_stmt (void)
00653 
00654 {
00655    int    stmt_number;
00656 
00657    TRACE (Func_Entry, "parse_intent_stmt", NULL);
00658 
00659    stmt_number = statement_number;
00660 
00661    if (LA_CH_VALUE != LPAREN) {
00662       parse_err_flush(Find_EOS, "(");
00663       NEXT_LA_CH;       /* Pick up EOS */
00664    }
00665    else {
00666       colon_recovery  = TRUE;     /* Can recover at :: */
00667       new_intent  = parse_intent_spec();
00668       colon_recovery  = FALSE;
00669 
00670       if (new_intent != Intent_Unseen) {
00671          parse_attrs(merge_intent);
00672 
00673          if (cif_flags & MISC_RECS) {
00674 
00675             if (new_intent == Intent_In) {
00676                cif_stmt_type_rec(TRUE, CIF_Intent_In_Stmt, stmt_number);
00677             }
00678             else if (new_intent == Intent_Out) {
00679                cif_stmt_type_rec(TRUE, CIF_Intent_Out_Stmt, stmt_number);
00680             }
00681             else {
00682                cif_stmt_type_rec(TRUE, CIF_Intent_Inout_Stmt, stmt_number);
00683             }
00684          }
00685       }
00686       else {
00687          parse_err_flush(Find_EOS, NULL);
00688          NEXT_LA_CH;        /* Pick up EOS */
00689       }
00690    }
00691 
00692    TRACE (Func_Exit, "parse_intent_stmt", NULL);
00693 
00694    return;
00695 
00696 }  /* parse_intent_stmt */
00697 
00698 
00699 /******************************************************************************\
00700 |*                                                                            *|
00701 |* Description:                                                               *|
00702 |*      Parse the intrinsic statement                                         *|
00703 |*      BNF       - INTRINSIC intrinsic-name-list                             *|
00704 |*                                                                            *|
00705 |* Input parameters:                                                          *|
00706 |*      NONE                                                                  *|
00707 |*                                                                            *|
00708 |* Output parameters:                                                         *|
00709 |*      NONE                                                                  *|
00710 |*                                                                            *|
00711 |* Returns:                                                                   *|
00712 |*      NONE                                                                  *|
00713 |*                                                                            *|
00714 \******************************************************************************/
00715 
00716 void parse_intrinsic_stmt (void)
00717 
00718 {
00719    TRACE (Func_Entry, "parse_intrinsic_stmt", NULL);
00720 
00721    parse_attrs(merge_intrinsic);
00722 
00723    TRACE (Func_Exit, "parse_intrinsic_stmt", NULL);
00724 
00725    return;
00726 
00727 }  /* parse_intrinsic_stmt */
00728 
00729 /******************************************************************************\
00730 |*                                                                            *|
00731 |* Description:                                                               *|
00732 |*      Parse the optional statement                                          *|
00733 |*      BNF       - OPTIONAL [::] dummy-arg-name-list                         *|
00734 |*                                                                            *|
00735 |* Input parameters:                                                          *|
00736 |*      NONE                                                                  *|
00737 |*                                                                            *|
00738 |* Output parameters:                                                         *|
00739 |*      NONE                                                                  *|
00740 |*                                                                            *|
00741 |* Returns:                                                                   *|
00742 |*      NONE                                                                  *|
00743 |*                                                                            *|
00744 \******************************************************************************/
00745 
00746 void parse_optional_stmt(void)
00747 
00748 {
00749    TRACE (Func_Entry, "parse_optional_stmt", NULL);
00750 
00751    parse_attrs(merge_optional);
00752 
00753    TRACE (Func_Exit, "parse_optional_stmt", NULL);
00754 
00755    return;
00756 
00757 }  /* parse_optional_stmt */
00758 
00759 
00760 /******************************************************************************\
00761 |*                        *|
00762 |* Description:                     *|
00763 |*      BNF       - POINTER   or  POINTER(CRI-pointer-name, CRI-pointee-name) *|
00764 |*                        *|
00765 |* Input parameters:                    *|
00766 |*  NONE                      *|
00767 |*                        *|
00768 |* Output parameters:                   *|
00769 |*  NONE                      *|
00770 |*                        *|
00771 |* Returns:                     *|
00772 |*  NONE                      *|
00773 |*                        *|
00774 \******************************************************************************/
00775 
00776 void parse_pointer_stmt (void)
00777 
00778 {
00779 #ifdef KEY /* Bug 10177 */
00780    int    array_idx = 0;
00781 #else /* KEY Bug 10177 */
00782    int    array_idx;
00783 #endif /* KEY Bug 10177 */
00784    int    attr_idx;
00785    int    name_idx;
00786    boolean  parse_err;
00787    int    pointer_idx;
00788    token_type pointee_name;
00789    token_type pointer_name;
00790    boolean  semantic_err;
00791 
00792 # if defined(_NO_CRAY_CHARACTER_PTR)
00793    int    lparen_col;
00794    int    lparen_line;
00795 # endif
00796 
00797 
00798 
00799    TRACE (Func_Entry, "parse_pointer_stmt", NULL);
00800 
00801    if (LA_CH_VALUE != LPAREN) {   /* Fortran 90 POINTER */
00802       parse_attrs(merge_pointer);
00803       goto EXIT;
00804    }
00805 
00806    /*  CRI pointer statement */
00807 
00808    if ((STMT_OUT_OF_ORDER(curr_stmt_category, Pointer_Stmt) ||
00809         STMT_CANT_BE_IN_BLK(Pointer_Stmt, CURR_BLK)) && iss_blk_stk_err()) {
00810       /* Intentionally blank */
00811    }
00812    else {
00813       curr_stmt_category = Declaration_Stmt_Cat;
00814       PRINTMSG(stmt_start_line, 134, Ansi, stmt_start_col);
00815    }
00816 
00817    do {
00818       parse_err   = FALSE;
00819       semantic_err  = FALSE;
00820 
00821       if (LA_CH_VALUE == LPAREN) {
00822 
00823 # if defined(_NO_CRAY_CHARACTER_PTR)
00824          lparen_line = LA_CH_LINE;
00825          lparen_col  = LA_CH_COLUMN; 
00826 # endif
00827 
00828          NEXT_LA_CH;        /* Skip LPAREN */
00829 
00830          if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
00831             pointer_name = token;
00832    
00833             if (LA_CH_VALUE == COMMA) {
00834                NEXT_LA_CH;      /* Skip COMMA */
00835 
00836                if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
00837                   pointee_name  = token;
00838                   array_idx = (LA_CH_VALUE == LPAREN) ? 
00839                                   parse_array_spec(AT_WORK_IDX) : NULL_IDX;
00840 
00841                   if (LA_CH_VALUE != RPAREN) {
00842                      parse_err_flush(Find_Rparen, ")");
00843                      parse_err = TRUE;
00844                   }
00845                }
00846                else {
00847                   parse_err_flush(Find_Rparen, "pointee name");
00848                   parse_err = TRUE;
00849                }
00850             }
00851             else {
00852                parse_err_flush(Find_Rparen, ",");
00853                parse_err = TRUE;
00854             }
00855          }
00856          else {
00857             parse_err_flush(Find_Rparen, "Cray pointer name");
00858             parse_err = TRUE;
00859          }
00860 
00861          if (LA_CH_VALUE == RPAREN) {
00862             NEXT_LA_CH;     /* Skip RPAREN */
00863          }
00864 
00865          if (LA_CH_VALUE != COMMA && LA_CH_VALUE != EOS) {
00866             parse_err_flush(Find_Comma, ", or " EOS_STR);
00867             parse_err = TRUE;
00868          }
00869 
00870          if (LA_CH_VALUE == COMMA) {
00871             NEXT_LA_CH;
00872          }
00873       }
00874       else {
00875          parse_err_flush(Find_Lparen, "(");
00876          parse_err = TRUE;
00877       }
00878  
00879       if (parse_err) {
00880          continue;
00881       }
00882 
00883       attr_idx = srch_sym_tbl(TOKEN_STR(pointee_name), 
00884                               TOKEN_LEN(pointee_name), &name_idx);
00885 
00886       if (attr_idx == NULL_IDX) {
00887          attr_idx     = ntr_sym_tbl(&pointee_name, name_idx);
00888          LN_DEF_LOC(name_idx)   = TRUE;      /* Can't be host assoc */
00889          SET_IMPL_TYPE(attr_idx);
00890          ATD_CLASS(attr_idx)    = CRI__Pointee;
00891       }
00892       else if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
00893                TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {
00894 
00895          if (fnd_semantic_err(Obj_Cri_Ch_Pointee,
00896                               TOKEN_LINE(pointee_name),
00897                               TOKEN_COLUMN(pointee_name),
00898                               attr_idx,
00899                               TRUE)) {
00900 
00901             semantic_err  = TRUE;
00902 
00903             CREATE_ERR_ATTR(attr_idx,
00904                             TOKEN_LINE(pointee_name),
00905                             TOKEN_COLUMN(pointee_name),
00906                             Data_Obj);
00907             SET_IMPL_TYPE(attr_idx);
00908          }
00909          else {
00910 # ifndef _EXTENDED_CRI_CHAR_POINTER
00911             if (TYP_CHAR_CLASS(ATD_TYPE_IDX(attr_idx)) != Assumed_Size_Char) {
00912                PRINTMSG(TOKEN_LINE(pointee_name), 1390, Warning,
00913                         TOKEN_COLUMN(pointee_name),
00914                         AT_OBJ_NAME_PTR(attr_idx));
00915 
00916                /* change to Assumed_Size_Char */
00917 
00918                CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
00919                TYP_TYPE(TYP_WORK_IDX)        = Character;
00920                TYP_LINEAR(TYP_WORK_IDX)      = Character_1;
00921                TYP_DESC(TYP_WORK_IDX)        = Default_Typed;
00922                TYP_DCL_VALUE(TYP_WORK_IDX)   = 0;
00923                TYP_CHAR_CLASS(TYP_WORK_IDX)  = Assumed_Size_Char;
00924                ATD_TYPE_IDX(attr_idx)        = ntr_type_tbl();
00925             }
00926 # endif
00927 
00928             if (AT_REFERENCED(attr_idx) == Char_Rslt_Bound_Ref) {
00929                AT_ATTR_LINK(attr_idx) = NULL_IDX;
00930                LN_DEF_LOC(name_idx) = TRUE;
00931             }
00932          }
00933 
00934 # if defined(_NO_CRAY_CHARACTER_PTR)
00935          PRINTMSG(lparen_line, 541, Error, lparen_col);
00936 # endif
00937 
00938       }
00939       else if (fnd_semantic_err(Obj_Cri_Pointee,
00940                                 TOKEN_LINE(pointee_name),
00941                                 TOKEN_COLUMN(pointee_name),
00942                                 attr_idx,
00943                                 TRUE)) {
00944          CREATE_ERR_ATTR(attr_idx,
00945                          TOKEN_LINE(pointee_name),
00946                          TOKEN_COLUMN(pointee_name),
00947                          Data_Obj);
00948          SET_IMPL_TYPE(attr_idx);
00949          semantic_err = TRUE;
00950       }
00951 
00952 # if !defined(_POINTEES_CAN_BE_STRUCT)
00953       else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure) {
00954          PRINTMSG (TOKEN_LINE(pointee_name), 651, Error,
00955                    TOKEN_COLUMN(pointee_name), 
00956                    AT_OBJ_NAME_PTR(attr_idx));
00957          CREATE_ERR_ATTR(attr_idx,
00958                          TOKEN_LINE(pointee_name),
00959                          TOKEN_COLUMN(pointee_name),
00960                          Data_Obj);
00961          SET_IMPL_TYPE(attr_idx);
00962          semantic_err = TRUE;
00963       }
00964 # endif
00965       else if (AT_REFERENCED(attr_idx) == Char_Rslt_Bound_Ref) {
00966          AT_ATTR_LINK(attr_idx) = NULL_IDX;
00967          LN_DEF_LOC(name_idx) = TRUE;
00968       }
00969 
00970       if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
00971          ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE;
00972       }
00973 
00974 
00975       ATD_CLASS(attr_idx)   = CRI__Pointee;
00976 
00977       if ((cif_flags & XREF_RECS) != 0) {
00978          cif_usage_rec(attr_idx,
00979                        AT_Tbl_Idx,
00980                        TOKEN_LINE(pointee_name),
00981                        TOKEN_COLUMN(pointee_name),
00982                        CIF_Symbol_Declaration);
00983       }
00984 
00985       if (array_idx != NULL_IDX) {
00986          merge_dimension(attr_idx,
00987                          TOKEN_LINE(pointee_name),
00988                          TOKEN_COLUMN(pointee_name),
00989                          array_idx);
00990       }
00991 
00992       pointer_idx = srch_sym_tbl(TOKEN_STR(pointer_name), 
00993                                  TOKEN_LEN(pointer_name), &name_idx);
00994 
00995       if (pointer_idx == NULL_IDX) {
00996          pointer_idx      = ntr_sym_tbl(&pointer_name, name_idx);
00997          LN_DEF_LOC(name_idx)   = TRUE;      /* Can't be host assoc */
00998       }
00999       else if (fnd_semantic_err(Obj_Cri_Ptr, 
01000                                 TOKEN_LINE(pointer_name),
01001                                 TOKEN_COLUMN(pointer_name),
01002                                 pointer_idx,
01003                                 TRUE)) {
01004          semantic_err = TRUE;
01005          CREATE_ERR_ATTR(pointer_idx,
01006                          TOKEN_LINE(pointer_name),
01007                          TOKEN_COLUMN(pointer_name),
01008                          Data_Obj);
01009       }
01010       else if (AT_REFERENCED(pointer_idx) == Char_Rslt_Bound_Ref) {
01011          AT_ATTR_LINK(pointer_idx)  = NULL_IDX;
01012          LN_DEF_LOC(name_idx)   = TRUE;
01013       }
01014 
01015       if (AT_OBJ_CLASS(pointer_idx) == Data_Obj) {
01016          ATD_SEEN_OUTSIDE_IMP_DO(pointer_idx) = TRUE;
01017       }
01018 
01019       if ((cif_flags & XREF_RECS) != 0) {
01020          cif_usage_rec(pointer_idx,
01021                        AT_Tbl_Idx,
01022                        TOKEN_LINE(pointer_name),
01023                        TOKEN_COLUMN(pointer_name),
01024                        CIF_Symbol_Declaration);
01025       }
01026 
01027       if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) != Character) {
01028          ATD_TYPE_IDX(pointer_idx)  = CRI_Ptr_8;
01029       }
01030       else {
01031          ATD_TYPE_IDX(pointer_idx)  = CRI_Ch_Ptr_8;
01032       }
01033 
01034       AT_TYPED(pointer_idx) = TRUE;
01035       ATD_PTR_IDX(attr_idx) = pointer_idx;
01036 
01037       if (semantic_err) {
01038          AT_DCL_ERR(pointer_idx)= TRUE;
01039          AT_DCL_ERR(attr_idx) = TRUE;
01040       }
01041    }  /* End while */
01042    while (LA_CH_VALUE != EOS); 
01043 
01044    NEXT_LA_CH;        /* Skip EOS */
01045 
01046 EXIT:
01047 
01048    TRACE (Func_Exit, "parse_pointer_stmt", NULL);
01049 
01050    return;
01051 
01052 }  /* parse_pointer_stmt */
01053 
01054 
01055 /******************************************************************************\
01056 |*                                                                            *|
01057 |* Description:                     *|
01058 |*      BNF       - SAVE [::] object-name OR /common-block-name/              *|
01059 |*                                                                            *|
01060 |* Input parameters:                    *|
01061 |*  NONE                      *|
01062 |*                        *|
01063 |* Output parameters:                   *|
01064 |*  NONE                      *|
01065 |*                        *|
01066 |* Returns:                     *|
01067 |*  NONE                      *|
01068 |*                        *|
01069 \******************************************************************************/
01070 
01071 void parse_save_stmt (void)
01072 
01073 {
01074    TRACE (Func_Entry, "parse_save_stmt", NULL);
01075 
01076    if (LA_CH_VALUE == EOS) {
01077 
01078       if ((STMT_CANT_BE_IN_BLK(Save_Stmt, CURR_BLK) ||
01079            STMT_OUT_OF_ORDER(curr_stmt_category, Save_Stmt)) && 
01080           iss_blk_stk_err()) {
01081          /* Block stack error - intentionally blank */
01082       }
01083       else {
01084          if (ATP_SAVE_ALL(SCP_ATTR_IDX(curr_scp_idx))) {
01085             PRINTMSG(TOKEN_LINE(token), 133, Ansi, TOKEN_COLUMN(token));
01086          }
01087          ATP_SAVE_ALL(SCP_ATTR_IDX(curr_scp_idx)) = TRUE;
01088          curr_stmt_category       = Declaration_Stmt_Cat;
01089 
01090          if (ATP_STACK_DIR(SCP_ATTR_IDX(curr_scp_idx))) {
01091 
01092             /* A SAVE with no save entity list has been specified in this */
01093             /* program unit.  SAVE overrides STACK.  Issue warning.       */
01094 
01095             PRINTMSG(TOKEN_LINE(token), 1144, Warning,
01096                      TOKEN_COLUMN(token),
01097                      "STACK");
01098             ATP_STACK_DIR(SCP_ATTR_IDX(curr_scp_idx)) = FALSE;
01099          }
01100       }
01101       NEXT_LA_CH;     /* Pick up EOS */
01102    }
01103    else {
01104 
01105       if (ATP_SAVE_ALL(SCP_ATTR_IDX(curr_scp_idx))) {
01106          PRINTMSG (stmt_start_line, 133, Ansi, stmt_start_col);
01107       }
01108 
01109       parse_attrs(merge_save);
01110    }
01111 
01112    TRACE (Func_Exit, "parse_save_stmt", NULL);
01113 
01114    return;
01115 
01116 }  /* parse_save_stmt */
01117 
01118 
01119 /******************************************************************************\
01120 |*                        *|
01121 |* Description:                     *|
01122 |*      BNF       - TARGET [::] object-name [(array-spec)]                    *|
01123 |*                                 [,object-name [(array_spec)]..             *|
01124 |*                        *|
01125 |* Input parameters:                    *|
01126 |*  NONE                      *|
01127 |*                        *|
01128 |* Output parameters:                   *|
01129 |*  NONE                      *|
01130 |*                        *|
01131 |* Returns:                     *|
01132 |*  NONE                      *|
01133 |*                        *|
01134 \******************************************************************************/
01135 
01136 void parse_target_stmt (void)
01137 
01138 {
01139    TRACE (Func_Entry, "parse_target_stmt", NULL);
01140 
01141    parse_attrs(merge_target);
01142 
01143    TRACE (Func_Exit, "parse_target_stmt", NULL);
01144 
01145    return;
01146 
01147 }  /* parse_target_stmt */
01148 
01149 /******************************************************************************\
01150 |*                                                                            *|
01151 |* Description:                     *|
01152 |*      BNF       - VOLATILE [::] object-name OR /common-block-name/          *|
01153 |*                                                                            *|
01154 |* Input parameters:                    *|
01155 |*  NONE                      *|
01156 |*                        *|
01157 |* Output parameters:                   *|
01158 |*  NONE                      *|
01159 |*                        *|
01160 |* Returns:                     *|
01161 |*  NONE                      *|
01162 |*                        *|
01163 \******************************************************************************/
01164 
01165 void parse_volatile_stmt (void)
01166 
01167 {
01168    TRACE (Func_Entry, "parse_volatile_stmt", NULL);
01169 
01170 #ifdef KEY /* Bug 14110 */
01171    PRINTMSG(stmt_start_line, 1685, Ansi, stmt_start_col, "VOLATILE");
01172 #else /* KEY Bug 14110 */
01173    PRINTMSG(stmt_start_line, 1253, Ansi, stmt_start_col, "VOLATILE");
01174 #endif /* KEY Bug 14110 */
01175    
01176    parse_attrs(merge_volatile);
01177 
01178    TRACE (Func_Exit, "parse_volatile_stmt", NULL);
01179 
01180    return;
01181 
01182 }  /* parse_volatile_stmt */
01183 #ifdef KEY /* Bug 14150 */
01184 /*
01185  *  BNF is
01186  *    language-binding-spec [ :: ] bind-entity-list
01187  *  where bind-entity-list contains
01188  *    entity-name
01189  *      or
01190  *    / common-block-name /
01191  */
01192 void parse_bind_stmt (void) {
01193    TRACE (Func_Entry, "parse_bind_stmt", NULL);
01194    parse_language_binding_spec(&new_binding_label);
01195 
01196    if (1 < parse_attrs(merge_bind) && BIND_SPECIFIES_NAME(new_binding_label)) {
01197      PRINTMSG(stmt_start_line, 1689, Error, stmt_start_col);
01198    }
01199 
01200    TRACE (Func_Exit, "parse_bind_stmt", NULL);
01201 
01202    return;
01203 
01204 }  /* parse_bind_stmt */
01205 
01206 void parse_value_stmt (void)
01207 
01208 {
01209    TRACE (Func_Entry, "parse_value_stmt", NULL);
01210 
01211    PRINTMSG(stmt_start_line, 1685, Ansi, stmt_start_col, "VALUE");
01212    
01213    parse_attrs(merge_value);
01214 
01215    TRACE (Func_Exit, "parse_value_stmt", NULL);
01216 
01217    return;
01218 
01219 }  /* parse_value_stmt */
01220 #endif /* KEY Bug 14150 */
osprey/crayf90/fe90/p_dcl_attr.c
