|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
00001 /* 00002 00003 Copyright (C) 2000, 2001 Silicon Graphics, Inc. All Rights Reserved. 00004 00005 This program is free software; you can redistribute it and/or modify it 00006 under the terms of version 2 of the GNU General Public License as 00007 published by the Free Software Foundation. 00008 00009 This program is distributed in the hope that it would be useful, but 00010 WITHOUT ANY WARRANTY; without even the implied warranty of 00011 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00012 00013 Further, this software is distributed without any warranty that it is 00014 free of the rightful claim of any third person regarding infringement 00015 or the like. Any license provided herein, whether implied or 00016 otherwise, applies only to this software file. Patent licenses, if 00017 any, provided herein do not apply to combinations of this program with 00018 other software, or any other product whatsoever. 00019 00020 You should have received a copy of the GNU General Public License along 00021 with this program; if not, write the Free Software Foundation, Inc., 59 00022 Temple Place - Suite 330, Boston MA 02111-1307, USA. 00023 00024 Contact information: Silicon Graphics, Inc., 1600 Amphitheatre Pky, 00025 Mountain View, CA 94043, or: 00026 00027 http://www.sgi.com 00028 00029 For further information regarding this notice, see: 00030 00031 http://oss.sgi.com/projects/GenInfo/NoticeExplan 00032 00033 */ 00034 00035 00036 00037 static char USMID[] = "\n@(#)5.0_pl/sources/p_dcls.c 5.10 10/08/99 08:26:21\n"; 00038 00039 # include "defines.h" /* Machine dependent ifdefs */ 00040 00041 # include "host.m" /* Host machine dependent macros.*/ 00042 # include "host.h" /* Host machine dependent header.*/ 00043 # include "target.m" /* Target machine dependent macros.*/ 00044 # include "target.h" /* Target machine dependent header.*/ 00045 00046 # include "globals.m" 00047 # include "tokens.m" 00048 # include "sytb.m" 00049 # include "p_globals.m" 00050 # include "debug.m" 00051 00052 # include "globals.h" 00053 # include "tokens.h" 00054 # include "sytb.h" 00055 # include "p_globals.h" 00056 # include "p_dcls.h" 00057 00058 00059 /*****************************************************************\ 00060 |* function prototypes of static functions declared in this file *| 00061 \*****************************************************************/ 00062 00063 static void issue_attr_blk_err(char *); 00064 static void issue_attr_err(attr_type, long); 00065 static void merge_parameter(boolean, int, int, int, opnd_type *, 00066 expr_arg_type *, int, int); 00067 static void merge_type(int, int, int, int); 00068 static void parse_cpnt_dcl_stmt(void); 00069 static long parse_attr_spec(int *, boolean *); 00070 static boolean parse_data_imp_do(opnd_type *); 00071 static void parse_derived_type_stmt(void); 00072 static boolean parse_initializer(int); 00073 static void parse_only_spec(int); 00074 static void retype_attr(int); 00075 00076 00077 /******************************************************************************\ 00078 |* *| 00079 |* Description: *| 00080 |* COMMON [/[common-block-name]/] common-block-object-list [[,] *| 00081 |* /[common-block-name]/ common-block-object-list]... *| 00082 |* common-block-object IS variable-name [(explicit-shape-spec-list)] *| 00083 |* *| 00084 |* Input parameters: *| 00085 |* NONE *| 00086 |* *| 00087 |* Output parameters: *| 00088 |* NONE *| 00089 |* *| 00090 |* Returns: *| 00091 |* NONE *| 00092 |* *| 00093 \******************************************************************************/ 00094 00095 void parse_common_stmt (void) 00096 00097 { 00098 int array_idx; 00099 int attr_idx; 00100 boolean blank_common = FALSE; 00101 boolean blk_err = FALSE; 00102 int column; 00103 int line; 00104 int name_idx; 00105 int new_sb_idx; 00106 int last_attr_idx; 00107 boolean parse_err = FALSE; 00108 token_type save_token; 00109 int sb_idx = NULL_IDX; 00110 00111 00112 TRACE (Func_Entry, "parse_common_stmt", NULL); 00113 00114 if (stmt_type == Task_Common_Stmt) { 00115 00116 if (!matched_specific_token(Tok_Kwd_Common, Tok_Class_Keyword)) { 00117 parse_err_flush(Find_Comma_Slash, "COMMON"); 00118 blk_err = TRUE; 00119 } 00120 00121 # if !defined(_TASK_COMMON_EXTENSION) 00122 PRINTMSG(stmt_start_line, 1118, Error, stmt_start_col); 00123 # else 00124 00125 /* ANSI message, Task common statements are extensions */ 00126 00127 PRINTMSG(stmt_start_line, 46, Ansi, stmt_start_col); 00128 # endif 00129 } 00130 00131 if ((STMT_OUT_OF_ORDER(curr_stmt_category, stmt_type) || 00132 STMT_CANT_BE_IN_BLK(stmt_type, CURR_BLK)) && iss_blk_stk_err()) { 00133 blk_err = TRUE; /* Block error issued */ 00134 } 00135 else { 00136 curr_stmt_category = Declaration_Stmt_Cat; 00137 } 00138 00139 do { 00140 if (sb_idx == NULL_IDX || LA_CH_VALUE == SLASH) { 00141 parse_err = blk_err; /* New common block list */ 00142 blank_common = FALSE; 00143 last_attr_idx = NULL_IDX; 00144 00145 if (LA_CH_VALUE != SLASH) { 00146 CREATE_ID(TOKEN_ID(token), 00147 BLANK_COMMON_NAME, 00148 BLANK_COMMON_NAME_LEN); 00149 TOKEN_LEN(token) = BLANK_COMMON_NAME_LEN; 00150 TOKEN_VALUE(token) = Tok_Id; 00151 TOKEN_LINE(token) = LA_CH_LINE; 00152 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00153 blank_common = TRUE; 00154 00155 if (stmt_type == Task_Common_Stmt) { /* Task can't be blank */ 00156 PRINTMSG(LA_CH_LINE, 109, Error, LA_CH_COLUMN); 00157 } 00158 } 00159 else { 00160 NEXT_LA_CH; 00161 00162 if (LA_CH_VALUE == SLASH) { 00163 CREATE_ID(TOKEN_ID(token), 00164 BLANK_COMMON_NAME, 00165 BLANK_COMMON_NAME_LEN); 00166 TOKEN_LEN(token) = BLANK_COMMON_NAME_LEN; 00167 TOKEN_VALUE(token) = Tok_Id; 00168 TOKEN_LINE(token) = LA_CH_LINE; 00169 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00170 blank_common = TRUE; 00171 00172 if (stmt_type == Task_Common_Stmt) { /* Task can't be blank */ 00173 PRINTMSG(LA_CH_LINE, 109, Error, LA_CH_COLUMN); 00174 } 00175 NEXT_LA_CH; 00176 } 00177 else if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 00178 00179 if (LA_CH_VALUE == SLASH) { 00180 NEXT_LA_CH; 00181 } 00182 else { 00183 parse_err = TRUE; 00184 save_token = token; /* parse_err_flush destroys token */ 00185 00186 if (parse_err_flush(Find_Comma_Slash, "/") && 00187 LA_CH_VALUE == SLASH) { 00188 NEXT_LA_CH; 00189 } 00190 token = save_token; /* Restore common block name */ 00191 } 00192 } 00193 else { 00194 line = LA_CH_LINE; 00195 column = LA_CH_COLUMN; 00196 00197 if (parse_err_flush(Find_Comma_Slash, "common-block-name or /")&& 00198 LA_CH_VALUE == SLASH) { 00199 NEXT_LA_CH; 00200 } 00201 00202 CREATE_ID(TOKEN_ID(token), "//", 2); 00203 TOKEN_LEN(token) = 2; 00204 TOKEN_VALUE(token) = Tok_Id; 00205 TOKEN_LINE(token) = line; 00206 TOKEN_COLUMN(token) = column; 00207 parse_err = TRUE; 00208 00209 } 00210 } 00211 00212 sb_idx = srch_stor_blk_tbl(TOKEN_STR(token), 00213 TOKEN_LEN(token), 00214 curr_scp_idx); 00215 00216 if (sb_idx == NULL_IDX) { 00217 sb_idx = ntr_stor_blk_tbl(TOKEN_STR(token), 00218 TOKEN_LEN(token), 00219 TOKEN_LINE(token), 00220 TOKEN_COLUMN(token), 00221 Common); 00222 SB_BLANK_COMMON(sb_idx) = blank_common; 00223 SB_COMMON_NEEDS_OFFSET(sb_idx) = TRUE; 00224 } 00225 else if (SB_USE_ASSOCIATED(sb_idx) || SB_HOST_ASSOCIATED(sb_idx)) { 00226 00227 /* Common block has been use or host associated into this scope. */ 00228 /* Make an entry for this block and hide the associated block */ 00229 /* storage_blk_resolution will resolve the blocks. */ 00230 00231 new_sb_idx = ntr_stor_blk_tbl(TOKEN_STR(token), 00232 TOKEN_LEN(token), 00233 TOKEN_LINE(token), 00234 TOKEN_COLUMN(token), 00235 Common); 00236 SB_BLANK_COMMON(new_sb_idx) = blank_common; 00237 SB_COMMON_NEEDS_OFFSET(new_sb_idx) = TRUE; 00238 SB_HIDDEN(sb_idx) = TRUE; 00239 SB_DEF_MULT_SCPS(sb_idx) = TRUE; 00240 SB_MERGED_BLK_IDX(sb_idx) = new_sb_idx; 00241 sb_idx = new_sb_idx; 00242 } 00243 else if (SB_FIRST_ATTR_IDX(sb_idx) != NULL_IDX) { 00244 last_attr_idx = SB_FIRST_ATTR_IDX(sb_idx); 00245 00246 while (ATD_NEXT_MEMBER_IDX(last_attr_idx) != NULL_IDX) { 00247 last_attr_idx = ATD_NEXT_MEMBER_IDX(last_attr_idx); 00248 } 00249 } 00250 # if 0 00251 /* we want to allow THREADPRIVATE before the common stmt. */ 00252 /* I'm leaving this in for now. BHJ */ 00253 00254 else if (SB_BLK_TYPE(sb_idx) == Threadprivate && !SB_DCL_ERR(sb_idx)) { 00255 00256 /* Must be declared completely before THREADPRIVATE */ 00257 00258 PRINTMSG(TOKEN_LINE(token), 1479, Error, TOKEN_COLUMN(token), 00259 SB_NAME_PTR(sb_idx)); 00260 } 00261 # endif 00262 00263 if ((cif_flags & XREF_RECS) != 0) { 00264 cif_sb_usage_rec(sb_idx, 00265 TOKEN_LINE(token), 00266 TOKEN_COLUMN(token), 00267 CIF_Symbol_Declaration); 00268 } 00269 00270 if (stmt_type == Task_Common_Stmt) { 00271 00272 /* A common block may be specified, multiple times. If any */ 00273 /* specifications are task common, then they all are. */ 00274 00275 SB_BLK_TYPE(sb_idx) = Task_Common; 00276 SB_RUNTIME_INIT(sb_idx) = FALSE; 00277 SB_IS_COMMON(sb_idx) = TRUE; 00278 } 00279 00280 if (parse_err) { 00281 SB_DCL_ERR(sb_idx) = TRUE; 00282 } 00283 00284 if (LA_CH_CLASS == Ch_Class_Letter) { 00285 continue; /* Get first object in common list */ 00286 } 00287 else { 00288 /* There must be a common object name following. If LA_CH is EOS */ 00289 /* this will just fall out of the while. If it's slash, it will */ 00290 /* pick up another common block name. And a comma is usually */ 00291 /* expected. */ 00292 00293 if (!parse_err) { 00294 parse_err_flush(Find_Comma_Slash, "common-block-object"); 00295 parse_err = TRUE; 00296 } 00297 SB_DCL_ERR(sb_idx) = TRUE; 00298 } 00299 } 00300 else if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 00301 line = TOKEN_LINE(token); 00302 column = TOKEN_COLUMN(token); 00303 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), 00304 &name_idx); 00305 00306 if (attr_idx == NULL_IDX) { 00307 attr_idx = ntr_sym_tbl(&token, name_idx); 00308 LN_DEF_LOC(name_idx) = TRUE; 00309 AT_DCL_ERR(attr_idx) = parse_err; 00310 AT_OBJ_CLASS(attr_idx) = Data_Obj; 00311 ATD_CLASS(attr_idx) = Variable; 00312 ATD_IN_COMMON(attr_idx) = TRUE; 00313 ATD_STOR_BLK_IDX(attr_idx) = sb_idx; 00314 SET_IMPL_TYPE(attr_idx); 00315 } 00316 else if (!fnd_semantic_err(Obj_Common_Obj,line,column,attr_idx,TRUE)) { 00317 00318 if (AT_REFERENCED(attr_idx) == Char_Rslt_Bound_Ref) { 00319 AT_ATTR_LINK(attr_idx) = NULL_IDX; 00320 LN_DEF_LOC(name_idx) = TRUE; 00321 } 00322 00323 if (AT_ATTR_LINK(attr_idx) != NULL_IDX) { 00324 AT_ATTR_LINK(attr_idx) = NULL_IDX; 00325 AT_HOST_ASSOCIATED(attr_idx) = FALSE; 00326 LN_DEF_LOC(name_idx) = TRUE; 00327 SET_IMPL_TYPE(attr_idx); 00328 } 00329 00330 ATD_IN_COMMON(attr_idx) = TRUE; 00331 ATD_STOR_BLK_IDX(attr_idx) = sb_idx; 00332 ATD_CLASS(attr_idx) = Variable; 00333 AT_DCL_ERR(attr_idx) = parse_err || AT_DCL_ERR(attr_idx); 00334 00335 if (ATD_AUXILIARY(attr_idx)) { 00336 SB_AUXILIARY(sb_idx) = TRUE; 00337 } 00338 } 00339 00340 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 00341 ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE; 00342 } 00343 00344 if ((cif_flags & XREF_RECS) != 0) { 00345 cif_usage_rec(attr_idx, 00346 AT_Tbl_Idx, 00347 line, 00348 column, 00349 CIF_Symbol_Declaration); 00350 } 00351 00352 if (!AT_DCL_ERR(attr_idx)) { 00353 00354 if (last_attr_idx == NULL_IDX) { 00355 SB_FIRST_ATTR_IDX(sb_idx) = attr_idx; 00356 } 00357 else { 00358 ATD_NEXT_MEMBER_IDX(last_attr_idx) = attr_idx; 00359 } 00360 00361 last_attr_idx = attr_idx; 00362 } 00363 else { 00364 SB_DCL_ERR(sb_idx) = TRUE; 00365 } 00366 00367 if (LA_CH_VALUE == LPAREN) { /* Array specifier follows */ 00368 array_idx = parse_array_spec(attr_idx); 00369 00370 if (BD_ARRAY_CLASS(array_idx) == Deferred_Shape) { 00371 00372 /* Arrays specified on a COMMON list must be */ 00373 /* explicit-shape-specs. Common can have a */ 00374 /* deferred-shape-spec specified, but it has to */ 00375 /* be on a seperate DIMENSION statement. */ 00376 00377 PRINTMSG(BD_LINE_NUM(array_idx), 372, Error, 00378 BD_COLUMN_NUM(array_idx)); 00379 AT_DCL_ERR(attr_idx) = TRUE; 00380 } 00381 merge_dimension(attr_idx, line, column, array_idx); 00382 } 00383 00384 # ifdef COARRAY_FORTRAN 00385 if (LA_CH_VALUE == LBRKT && 00386 cmd_line_flags.co_array_fortran) { 00387 ATD_PE_ARRAY_IDX(attr_idx) = parse_pe_array_spec(attr_idx); 00388 } 00389 # endif 00390 } 00391 else { /* Problem with common block name. Default to blank common name */ 00392 line = LA_CH_LINE; 00393 column = LA_CH_COLUMN; 00394 00395 parse_err_flush(Find_Comma_Slash, "common-block-object or /"); 00396 00397 if (sb_idx == NULL_IDX) { 00398 CREATE_ID(TOKEN_ID(token), "//", 2); 00399 TOKEN_LEN(token) = 2; 00400 TOKEN_VALUE(token) = Tok_Id; 00401 TOKEN_LINE(token) = line; 00402 TOKEN_COLUMN(token) = column; 00403 parse_err = TRUE; 00404 00405 sb_idx = srch_stor_blk_tbl(TOKEN_STR(token), 00406 TOKEN_LEN(token), 00407 curr_scp_idx); 00408 00409 if (sb_idx == NULL_IDX) { 00410 sb_idx = ntr_stor_blk_tbl(TOKEN_STR(token), 00411 TOKEN_LEN(token), 00412 TOKEN_LINE(token), 00413 TOKEN_COLUMN(token), 00414 Common); 00415 SB_COMMON_NEEDS_OFFSET(sb_idx) = TRUE; 00416 } 00417 else if (SB_USE_ASSOCIATED(sb_idx) || SB_HOST_ASSOCIATED(sb_idx)) { 00418 00419 /* Common block has been use or host associated into this scp. */ 00420 /* Make an entry for this block and hide the associated block. */ 00421 /* storage_blk_resolution will resolve the blocks. */ 00422 00423 new_sb_idx = ntr_stor_blk_tbl(TOKEN_STR(token), 00424 TOKEN_LEN(token), 00425 TOKEN_LINE(token), 00426 TOKEN_COLUMN(token), 00427 Common); 00428 SB_COMMON_NEEDS_OFFSET(new_sb_idx) = TRUE; 00429 SB_HIDDEN(sb_idx) = TRUE; 00430 SB_DEF_MULT_SCPS(sb_idx) = TRUE; 00431 sb_idx = new_sb_idx; 00432 } 00433 } 00434 SB_DCL_ERR(sb_idx) = TRUE; 00435 } 00436 00437 if (LA_CH_VALUE != COMMA && LA_CH_VALUE != SLASH && LA_CH_VALUE != EOS) { 00438 parse_err_flush(Find_Comma_Slash, "/ or, or " EOS_STR); 00439 parse_err = TRUE; 00440 } 00441 00442 if (LA_CH_VALUE == COMMA) { 00443 NEXT_LA_CH; 00444 00445 if (LA_CH_VALUE == EOS) { /* ,, case */ 00446 parse_err_flush(Find_None, "common-block-object or /"); 00447 } 00448 } 00449 } 00450 while (LA_CH_VALUE != EOS); 00451 00452 NEXT_LA_CH; 00453 00454 TRACE (Func_Exit, "parse_common_stmt", NULL); 00455 00456 return; 00457 00458 } /* parse_common_stmt */ 00459 00460 00461 /******************************************************************************\ 00462 |* *| 00463 |* Description: *| 00464 |* BNF is CONTAINS *| 00465 |* *| 00466 |* Input parameters: *| 00467 |* NONE *| 00468 |* *| 00469 |* Output parameters: *| 00470 |* NONE *| 00471 |* *| 00472 |* Returns: *| 00473 |* NONE *| 00474 |* *| 00475 \******************************************************************************/ 00476 00477 void parse_contains_stmt (void) 00478 00479 { 00480 boolean have_blk_err = FALSE; 00481 00482 00483 TRACE (Func_Entry, "parse_contains_stmt", NULL); 00484 00485 do_cmic_blk_checks(); 00486 00487 if (LA_CH_VALUE == EOS) { 00488 00489 if (STMT_CANT_BE_IN_BLK(Contains_Stmt, CURR_BLK) && iss_blk_stk_err()) { 00490 have_blk_err = TRUE; 00491 } 00492 else { 00493 curr_stmt_category = Sub_Func_Stmt_Cat; 00494 } 00495 00496 if (CURR_BLK != Interface_Blk) { 00497 00498 /* If this were an Interface_Blk, this is an error situation. */ 00499 /* We don't want to push the contains blk, because it creates */ 00500 /* havoc with interface block compressing. */ 00501 00502 PUSH_BLK_STK(Contains_Blk); 00503 CURR_BLK_NO_EXEC = TRUE; 00504 CURR_BLK_ERR = have_blk_err; 00505 00506 if (cif_flags) { 00507 cif_module_proc_start_line = LA_CH_LINE; 00508 cif_internal_proc_start_line = LA_CH_LINE; 00509 BLK_CIF_SCOPE_ID(blk_stk_idx) = BLK_CIF_SCOPE_ID(blk_stk_idx - 1); 00510 } 00511 } 00512 else { 00513 CURR_BLK_ERR = TRUE; 00514 } 00515 } 00516 else { 00517 parse_err_flush(Find_EOS, EOS_STR); 00518 } 00519 00520 NEXT_LA_CH; /* Skip EOS */ 00521 00522 TRACE (Func_Exit, "parse_contains_stmt", NULL); 00523 00524 return; 00525 00526 } /* parse_contains_stmt */ 00527 00528 /******************************************************************************\ 00529 |* *| 00530 |* Description: *| 00531 |* BNF component-def-stmt *| 00532 |* type-spec [[,component-attr-spec-list]::] component-decl-list *| 00533 |* Notes - This routine is only entered if in a derived type statement. *| 00534 |* *| 00535 |* Input parameters: *| 00536 |* NONE *| 00537 |* *| 00538 |* Output parameters: *| 00539 |* NONE *| 00540 |* *| 00541 |* Returns: *| 00542 |* NONE *| 00543 |* *| 00544 \******************************************************************************/ 00545 00546 static void parse_cpnt_dcl_stmt() 00547 00548 { 00549 int alignment; 00550 int array_column; 00551 int array_line; 00552 int attr_idx; 00553 int bd_idx; 00554 int dt_idx; 00555 boolean found_colon; 00556 boolean GT_encountered; 00557 boolean have_attr_list = FALSE; 00558 int idx; 00559 int init_ir_idx; 00560 opnd_type init_opnd; 00561 boolean junk; 00562 int np_idx; 00563 int old_bd_idx; 00564 int save_column; 00565 int save_line; 00566 int sn_idx; 00567 int stmt_number; 00568 boolean type_err; 00569 int type_idx; 00570 00571 00572 TRACE (Func_Entry, "parse_cpnt_dcl_stmt", NULL); 00573 00574 found_colon = FALSE; 00575 colon_recovery = TRUE; /* Can recover at :: */ 00576 type_err = !parse_type_spec(TRUE); /* Get KIND */ 00577 type_idx = ATD_TYPE_IDX(AT_WORK_IDX); 00578 AT_DCL_ERR(AT_WORK_IDX) = type_err; 00579 stmt_number = statement_number; 00580 00581 if (TYP_TYPE(type_idx) == Character) { /* Must be const len char */ 00582 ATT_CHAR_CPNT(CURR_BLK_NAME) = TRUE; 00583 00584 if (fold_relationals(TYP_IDX(type_idx), CN_INTEGER_ZERO_IDX, Lt_Opr)) { 00585 00586 /* Zero Length character */ 00587 00588 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 00589 TYP_TYPE(TYP_WORK_IDX) = Character; 00590 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 00591 TYP_DESC(TYP_WORK_IDX) = TYP_DESC(type_idx); 00592 TYP_DCL_VALUE(TYP_WORK_IDX) = TYP_DCL_VALUE(type_idx); 00593 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char; 00594 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx; 00595 TYP_IDX(TYP_WORK_IDX) = CN_INTEGER_ZERO_IDX; 00596 type_idx = ntr_type_tbl(); 00597 ATD_TYPE_IDX(AT_WORK_IDX) = type_idx; 00598 } 00599 } 00600 else if (TYP_TYPE(type_idx) != Structure) { 00601 ATT_NUMERIC_CPNT(CURR_BLK_NAME) = TRUE; 00602 } 00603 00604 if (TYP_DESC(type_idx) == Default_Typed || 00605 TYP_LINEAR(type_idx) == INTEGER_DEFAULT_TYPE || 00606 TYP_LINEAR(type_idx) == LOGICAL_DEFAULT_TYPE || 00607 TYP_LINEAR(type_idx) == REAL_DEFAULT_TYPE || 00608 TYP_LINEAR(type_idx) == DOUBLE_DEFAULT_TYPE || 00609 TYP_LINEAR(type_idx) == COMPLEX_DEFAULT_TYPE) { 00610 00611 /* Intentionally blank */ 00612 } 00613 else { 00614 ATT_NON_DEFAULT_CPNT(CURR_BLK_NAME) = TRUE; 00615 } 00616 00617 /* Assume all type errors issued - la_ch is comma, ::, or id */ 00618 00619 while (LA_CH_VALUE == COMMA) { 00620 NEXT_LA_CH; /* Skip Comma */ 00621 00622 if (MATCHED_TOKEN_CLASS(Tok_Class_Keyword)) { 00623 00624 switch (TOKEN_VALUE(token)) { 00625 00626 case Tok_Kwd_Pointer: 00627 00628 if (ATD_POINTER(AT_WORK_IDX)) { /* duplicate error msg */ 00629 PRINTMSG (TOKEN_LINE(token), 273, Error, 00630 TOKEN_COLUMN(token), "POINTER"); 00631 } 00632 00633 have_attr_list = TRUE; 00634 ATD_POINTER(AT_WORK_IDX) = TRUE; 00635 /* keep array form,don't generate dope vector */ 00636 /* ATD_IM_A_DOPE(AT_WORK_IDX) = TRUE; */ 00637 ATT_POINTER_CPNT(CURR_BLK_NAME) = TRUE; 00638 ATT_NUMERIC_CPNT(CURR_BLK_NAME) = TRUE; 00639 00640 break; 00641 00642 case Tok_Kwd_Dimension: 00643 00644 if (ATD_ARRAY_IDX(AT_WORK_IDX) != NULL_IDX) { /* Duplicate err */ 00645 PRINTMSG (TOKEN_LINE(token), 273, Error, 00646 TOKEN_COLUMN(token), "DIMENSION"); 00647 } 00648 00649 have_attr_list = TRUE; 00650 00651 if (LA_CH_VALUE == LPAREN) { 00652 array_line = TOKEN_LINE(token); 00653 array_column = TOKEN_COLUMN(token); 00654 idx = parse_array_spec(AT_WORK_IDX); 00655 ATD_ARRAY_IDX(AT_WORK_IDX) = idx; 00656 } 00657 # ifdef COARRAY_FORTRAN 00658 else if (!cmd_line_flags.co_array_fortran || 00659 LA_CH_VALUE != LBRKT) 00660 # else 00661 else 00662 # endif 00663 { /* DIMENSION attribute must have an array spec */ 00664 00665 parse_err_flush(Find_Comma, "("); 00666 AT_DCL_ERR(AT_WORK_IDX) = TRUE; 00667 } 00668 00669 # ifdef COARRAY_FORTRAN 00670 if (LA_CH_VALUE == LBRKT && cmd_line_flags.co_array_fortran) { 00671 ATD_PE_ARRAY_IDX(AT_WORK_IDX) = 00672 parse_pe_array_spec(AT_WORK_IDX); 00673 } 00674 # endif 00675 00676 break; 00677 00678 default: /* POINTER and/or DIMENSION must follow the first comma */ 00679 PRINTMSG(TOKEN_LINE(token), 197, Error, TOKEN_COLUMN(token), 00680 "POINTER or DIMENSION", TOKEN_STR(token)); 00681 parse_err_flush(Find_Comma, NULL); 00682 AT_DCL_ERR(AT_WORK_IDX) = TRUE; 00683 break; 00684 00685 } /* switch */ 00686 } 00687 else { 00688 parse_err_flush(Find_Comma, "POINTER or DIMENSION"); 00689 } 00690 } /* end while */ 00691 00692 found_colon = matched_specific_token(Tok_Punct_Colon_Colon, Tok_Class_Punct); 00693 00694 if (!found_colon && have_attr_list) { 00695 PRINTMSG (LA_CH_LINE, 187, Error, LA_CH_COLUMN); 00696 } 00697 00698 colon_recovery = FALSE; /* Past :: */ 00699 00700 if (TYP_TYPE(type_idx) == Structure) { 00701 00702 if (!ATD_POINTER(AT_WORK_IDX)) { 00703 dt_idx = TYP_IDX(type_idx); 00704 00705 if (CURR_BLK_NAME == dt_idx) { /* Points to itself */ 00706 PRINTMSG(TOKEN_LINE(token), 33, Error, TOKEN_COLUMN(token)); 00707 ATT_NUMERIC_CPNT(CURR_BLK_NAME) = TRUE; 00708 AT_DCL_ERR(AT_WORK_IDX) = TRUE; 00709 AT_DCL_ERR(CURR_BLK_NAME) = TRUE; 00710 } 00711 else if (!AT_DEFINED(dt_idx)) { 00712 ATT_NUMERIC_CPNT(CURR_BLK_NAME) = TRUE; 00713 00714 if (!AT_DCL_ERR(AT_WORK_IDX)) { 00715 AT_DCL_ERR(AT_WORK_IDX) = TRUE; 00716 00717 /* Must have components declared before they are used. */ 00718 00719 if (!AT_DCL_ERR(dt_idx)) { 00720 issue_undefined_type_msg(dt_idx, 00721 TOKEN_LINE(token), 00722 TOKEN_COLUMN(token)); 00723 } 00724 } 00725 } 00726 else { /* This type must be defined by this point */ 00727 ATT_CHAR_CPNT(CURR_BLK_NAME) |= ATT_CHAR_CPNT(dt_idx); 00728 ATT_NUMERIC_CPNT(CURR_BLK_NAME) |= ATT_NUMERIC_CPNT(dt_idx); 00729 ATT_POINTER_CPNT(CURR_BLK_NAME) |= ATT_POINTER_CPNT(dt_idx); 00730 ATT_NON_DEFAULT_CPNT(CURR_BLK_NAME) |= ATT_NON_DEFAULT_CPNT(dt_idx); 00731 ATT_DEFAULT_INITIALIZED(CURR_BLK_NAME) |= 00732 ATT_DEFAULT_INITIALIZED(dt_idx); 00733 } 00734 } 00735 } 00736 00737 alignment = WORD_ALIGN; 00738 00739 if (ATD_POINTER(AT_WORK_IDX)) { 00740 00741 if (cmd_line_flags.s_pointer8) { 00742 alignment = Align_64; 00743 } 00744 else { 00745 alignment = WORD_ALIGN; 00746 } 00747 } 00748 else if (TYP_TYPE(type_idx) == Structure) { 00749 alignment = ATT_ALIGNMENT(TYP_IDX(type_idx)); 00750 } 00751 else if (TYP_TYPE(type_idx) == Character) { 00752 00753 # if defined(_CHAR_IS_ALIGN_8) 00754 alignment = Align_8; 00755 # else 00756 alignment = Align_Bit; 00757 # endif 00758 } 00759 00760 # if defined(_ALIGN_REAL16_TO_16_BYTES) 00761 00762 else if (TYP_LINEAR(type_idx) == Complex_16 || 00763 TYP_LINEAR(type_idx) == Real_16) { 00764 alignment = Align_128; 00765 } 00766 # endif 00767 00768 # if defined(_TARGET_PACK_HALF_WORD_TYPES) 00769 00770 else if (dump_flags.pack_half_word && 00771 PACK_HALF_WORD_TEST_CONDITION(type_idx)) { 00772 alignment = Align_32; 00773 } 00774 # endif 00775 00776 # if defined(_HOST32) 00777 00778 else if (DALIGN_TEST_CONDITION(type_idx)) { 00779 alignment = Align_64; 00780 } 00781 # endif 00782 00783 # if defined(_INTEGER_1_AND_2) 00784 00785 else if (on_off_flags.integer_1_and_2 && 00786 PACK_8_BIT_TEST_CONDITION(type_idx)) { 00787 alignment = Align_8; 00788 } 00789 else if (on_off_flags.integer_1_and_2 && 00790 PACK_16_BIT_TEST_CONDITION(type_idx)){ 00791 alignment = Align_16; 00792 } 00793 00794 # endif 00795 00796 if (ATT_ALIGNMENT(CURR_BLK_NAME) < alignment) { 00797 ATT_ALIGNMENT(CURR_BLK_NAME) = alignment; 00798 } 00799 00800 do { 00801 if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 00802 parse_err_flush(Find_Comma, "component-name"); 00803 continue; 00804 } 00805 00806 sn_idx = ATT_FIRST_CPNT_IDX(CURR_BLK_NAME); 00807 attr_idx = srch_linked_sn(TOKEN_STR(token), 00808 TOKEN_LEN(token), 00809 &sn_idx); 00810 00811 if (attr_idx == NULL_IDX) { 00812 NTR_SN_TBL(sn_idx); 00813 NTR_NAME_POOL(TOKEN_ID(token).words, TOKEN_LEN(token), np_idx); 00814 NTR_ATTR_TBL(attr_idx); 00815 AT_DEF_LINE(attr_idx) = TOKEN_LINE(token); 00816 AT_DEF_COLUMN(attr_idx) = TOKEN_COLUMN(token); 00817 AT_NAME_LEN(attr_idx) = TOKEN_LEN(token); 00818 AT_NAME_IDX(attr_idx) = np_idx; 00819 SN_NAME_LEN(sn_idx) = TOKEN_LEN(token); 00820 SN_NAME_IDX(sn_idx) = np_idx; 00821 SN_ATTR_IDX(sn_idx) = attr_idx; 00822 00823 if (BLK_LAST_CPNT_IDX(blk_stk_idx) == NULL_IDX) { 00824 ATT_FIRST_CPNT_IDX(CURR_BLK_NAME) = sn_idx; 00825 ATT_NUM_CPNTS(CURR_BLK_NAME) = 1; 00826 } 00827 else { 00828 ATT_NUM_CPNTS(CURR_BLK_NAME) += 1; 00829 SN_SIBLING_LINK(BLK_LAST_CPNT_IDX(blk_stk_idx)) = sn_idx; 00830 } 00831 BLK_LAST_CPNT_IDX(blk_stk_idx) = sn_idx; 00832 } 00833 else { /* Error - Duplicate component names for this derived type */ 00834 PRINTMSG (TOKEN_LINE(token), 188, Error, TOKEN_COLUMN(token), 00835 AT_OBJ_NAME_PTR(attr_idx)); 00836 AT_DCL_ERR(attr_idx) = TRUE; 00837 } 00838 00839 /* Mark semantics done, so it doesn't go thru declaration semantics */ 00840 00841 AT_SEMANTICS_DONE(attr_idx) = TRUE; 00842 ATD_CLASS(attr_idx) = Struct_Component; 00843 ATD_DERIVED_TYPE_IDX(attr_idx) = CURR_BLK_NAME; 00844 ATD_ARRAY_IDX(attr_idx) = ATD_ARRAY_IDX(AT_WORK_IDX); 00845 ATD_PE_ARRAY_IDX(attr_idx) = ATD_PE_ARRAY_IDX(AT_WORK_IDX); 00846 ATD_POINTER(attr_idx) = ATD_POINTER(AT_WORK_IDX); 00847 /* ATD_IM_A_DOPE(attr_idx) = ATD_IM_A_DOPE(AT_WORK_IDX); */ 00848 save_line = array_line; 00849 save_column = array_column; 00850 AT_TYPED(attr_idx) = AT_TYPED(AT_WORK_IDX); 00851 AT_DCL_ERR(attr_idx) = AT_DCL_ERR(AT_WORK_IDX); 00852 00853 if (type_err) { 00854 SET_IMPL_TYPE(attr_idx); 00855 } 00856 else { 00857 ATD_TYPE_IDX(attr_idx) = type_idx; 00858 } 00859 00860 if ((cif_flags & XREF_RECS) != 0) { 00861 cif_usage_rec(attr_idx, 00862 AT_Tbl_Idx, 00863 TOKEN_LINE(token), 00864 TOKEN_COLUMN(token), 00865 CIF_Symbol_Declaration); 00866 } 00867 00868 if (LA_CH_VALUE == LPAREN) { 00869 save_line = TOKEN_LINE(token); 00870 save_column = TOKEN_COLUMN(token); 00871 idx = parse_array_spec(attr_idx); 00872 ATD_ARRAY_IDX(attr_idx) = idx; 00873 } 00874 00875 # ifdef COARRAY_FORTRAN 00876 if (LA_CH_VALUE == LBRKT && cmd_line_flags.co_array_fortran) { 00877 ATD_PE_ARRAY_IDX(attr_idx) = parse_pe_array_spec(attr_idx); 00878 } 00879 # endif 00880 00881 bd_idx = ATD_ARRAY_IDX(attr_idx); 00882 00883 if (bd_idx != NULL_IDX) { /* Array declared */ 00884 AT_DCL_ERR(attr_idx) = BD_DCL_ERR(bd_idx) | AT_DCL_ERR(attr_idx); 00885 00886 if (ATD_POINTER(attr_idx)) { 00887 00888 if (BD_ARRAY_CLASS(bd_idx) != Deferred_Shape && 00889 BD_ARRAY_CLASS(bd_idx) != Deferred_Shape1 ) { 00890 PRINTMSG(save_line, 189, Error, save_column, 00891 AT_OBJ_NAME_PTR(attr_idx)); 00892 AT_DCL_ERR(attr_idx) = TRUE; 00893 } 00894 } 00895 else if (BD_ARRAY_CLASS(bd_idx) != Explicit_Shape || 00896 BD_ARRAY_SIZE(bd_idx) != Constant_Size) { 00897 PRINTMSG(save_line, 190, Error, save_column, 00898 AT_OBJ_NAME_PTR(attr_idx)); 00899 AT_DCL_ERR(attr_idx) = TRUE; 00900 } 00901 } 00902 00903 if (LA_CH_VALUE == STAR) { 00904 save_line = LA_CH_LINE; 00905 save_column = LA_CH_COLUMN; 00906 00907 /* Pick up character length. LEN = is not allowed here (FALSE) */ 00908 /* We are not parsing the character* part of the line, so this */ 00909 /* is not the length_selector. It is the char-length on the name */ 00910 00911 parse_length_selector(attr_idx, FALSE, FALSE); 00912 00913 TYP_DCL_VALUE(TYP_WORK_IDX) = TYP_DCL_VALUE(type_idx); 00914 TYP_DESC(TYP_WORK_IDX) = TYP_DESC(type_idx); 00915 00916 if (TYP_TYPE(type_idx) != Character) { 00917 PRINTMSG(save_line, 192, Error, save_column); 00918 AT_DCL_ERR(attr_idx) = TRUE; 00919 } 00920 else if (TYP_CHAR_CLASS(TYP_WORK_IDX) == Const_Len_Char) { 00921 00922 if (fold_relationals(TYP_IDX(TYP_WORK_IDX), 00923 CN_INTEGER_ZERO_IDX, 00924 Le_Opr)) { 00925 TYP_IDX(TYP_WORK_IDX) = CN_INTEGER_ZERO_IDX; 00926 } 00927 00928 ATD_TYPE_IDX(attr_idx) = ntr_type_tbl(); 00929 } 00930 else if (!AT_DCL_ERR(attr_idx)) { 00931 00932 /* Must be a constant length char */ 00933 00934 PRINTMSG(save_line, 191, Error, save_column); 00935 00936 ATD_TYPE_IDX(attr_idx) = CHARACTER_DEFAULT_TYPE; 00937 AT_DCL_ERR(attr_idx) = TRUE; 00938 } 00939 00940 /* Have a different character length than the one specified on the */ 00941 /* CHARACTER component statement. (ie: CHARACTER*(2) :: A*(10),B) */ 00942 /* If this is an array, it may need a seperate bounds table entry if */ 00943 /* this is a shared array entry. The stride multiplier is kept in */ 00944 /* the bounds table and is dependent on type. Therefore, if two */ 00945 /* items have seperate types, they must have seperate bounds entries.*/ 00946 /* Ex: CHARACTER*(2), DIMENSION(100) :: A*(10), B ! A and B need */ 00947 /* seperate bounds entries. */ 00948 /* CHARACTER*(2), DIMENSION(100) :: A(20)*(10), B ! They */ 00949 /* already have seperate bounds entries, because */ 00950 /* they have seperate dimensions. */ 00951 /* CHARACTER*(2), DIMENSION(100) :: A,B ! They have the same */ 00952 /* type, so they can share a bound entry. */ 00953 00954 old_bd_idx = ATD_ARRAY_IDX(attr_idx); 00955 00956 if (old_bd_idx != NULL_IDX && 00957 old_bd_idx == ATD_ARRAY_IDX(AT_WORK_IDX) ){ /* && */ 00958 /* BD_ARRAY_CLASS(old_bd_idx) != Deferred_Shape) { &*/ 00959 bd_idx = reserve_array_ntry(BD_RANK(old_bd_idx)); 00960 COPY_BD_NTRY(bd_idx, old_bd_idx); 00961 ATD_ARRAY_IDX(attr_idx) = ntr_array_in_bd_tbl(bd_idx); 00962 } 00963 } 00964 00965 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 00966 bd_idx = ATD_ARRAY_IDX(attr_idx); 00967 00968 if (BD_RESOLVED(bd_idx) ) { /* || */ 00969 # if 0 /*keep deferred shape array form */ 00970 BD_ARRAY_CLASS(bd_idx) == Deferred_Shape || 00971 BD_ARRAY_CLASS(bd_idx) == Assumed_Shape) { 00972 # endif 00973 } 00974 else { 00975 00976 /* All the array bounds must be constants. parse_array_spec */ 00977 /* calls parse_int_spec_expr, which guarantees these to be */ 00978 /* constants if CURR_BLK == Derived_Type_Blk. */ 00979 00980 if (BD_ARRAY_CLASS(bd_idx) == Assumed_Size) { 00981 00982 /* A component cannot be assumed size. So copy the array */ 00983 /* entry and make the last dimension have a upper bound equal */ 00984 /* to the lower bound. Can't just make the upper bound be 1, */ 00985 /* because it could end up being a zero-sized array. */ 00986 00987 old_bd_idx = bd_idx; 00988 bd_idx = reserve_array_ntry(BD_RANK(old_bd_idx)); 00989 COPY_BD_NTRY(bd_idx, old_bd_idx); 00990 BD_UB_IDX(bd_idx, BD_RANK(bd_idx)) = BD_LB_IDX(bd_idx, 00991 BD_RANK(bd_idx)); 00992 BD_UB_FLD(bd_idx, BD_RANK(bd_idx)) = BD_LB_FLD(bd_idx, 00993 BD_RANK(bd_idx)); 00994 BD_ARRAY_CLASS(bd_idx) = Explicit_Shape; 00995 BD_DCL_ERR(bd_idx) = TRUE; 00996 ATD_ARRAY_IDX(attr_idx) = ntr_array_in_bd_tbl(bd_idx); 00997 } 00998 array_bounds_resolution(attr_idx, &junk); 00999 } 01000 } 01001 01002 if (ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX) { 01003 PRINTMSG(BD_LINE_NUM(ATD_PE_ARRAY_IDX(attr_idx)), 1579, Error, 01004 BD_COLUMN_NUM(ATD_PE_ARRAY_IDX(attr_idx)), 01005 AT_OBJ_NAME_PTR(attr_idx), 01006 AT_OBJ_NAME_PTR(CURR_BLK_NAME)); 01007 AT_DCL_ERR(attr_idx) = TRUE; 01008 ATD_PE_ARRAY_IDX(attr_idx) = NULL_IDX; 01009 } 01010 01011 if (LA_CH_VALUE == EQUAL) { 01012 NEXT_LA_CH; 01013 save_line = LA_CH_LINE; 01014 save_column = LA_CH_COLUMN; 01015 01016 if (LA_CH_VALUE == GT) { 01017 NEXT_LA_CH; 01018 save_line = LA_CH_LINE; 01019 save_column = LA_CH_COLUMN; 01020 GT_encountered = TRUE; 01021 } 01022 else { 01023 GT_encountered = FALSE; 01024 } 01025 01026 if (parse_expr(&init_opnd)) { 01027 01028 if (!found_colon) { 01029 PRINTMSG(save_line, 121, Error, save_column); 01030 AT_DCL_ERR(attr_idx) = TRUE; 01031 } 01032 01033 NTR_IR_TBL(init_ir_idx); 01034 ATD_CPNT_INIT_IDX(attr_idx) = init_ir_idx; 01035 ATD_FLD(attr_idx) = IR_Tbl_Idx; 01036 ATT_DEFAULT_INITIALIZED(CURR_BLK_NAME) = TRUE; 01037 01038 if (OPND_FLD(init_opnd) == IR_Tbl_Idx && 01039 IR_OPR(OPND_IDX(init_opnd)) == Call_Opr && 01040 AT_IS_INTRIN(IR_IDX_L(OPND_IDX(init_opnd))) && 01041 strcmp(AT_OBJ_NAME_PTR(IR_IDX_L(OPND_IDX(init_opnd))), 01042 "NULL") == 0) { 01043 01044 if (IR_IDX_R(OPND_IDX(init_opnd)) != NULL_IDX) { 01045 PRINTMSG(IR_LINE_NUM(OPND_IDX(init_opnd)), 1573, Error, 01046 IR_COL_NUM(OPND_IDX(init_opnd))); 01047 AT_DCL_ERR(attr_idx) = TRUE; 01048 ATD_CPNT_INIT_IDX(attr_idx) = NULL_IDX; 01049 ATD_FLD(attr_idx) = NO_Tbl_Idx; 01050 } 01051 01052 IR_OPR(init_ir_idx) = Null_Opr; 01053 01054 if (!GT_encountered) { 01055 PRINTMSG(TOKEN_LINE(token), 1562, Error, TOKEN_COLUMN(token)); 01056 AT_DCL_ERR(attr_idx) = TRUE; 01057 ATD_CPNT_INIT_IDX(attr_idx) = NULL_IDX; 01058 ATD_FLD(attr_idx) = NO_Tbl_Idx; 01059 } 01060 } 01061 else { 01062 IR_OPR(init_ir_idx) = Init_Opr; 01063 01064 if (GT_encountered) { 01065 PRINTMSG(TOKEN_LINE(token), 1562, Error, TOKEN_COLUMN(token)); 01066 AT_DCL_ERR(attr_idx) = TRUE; 01067 ATD_CPNT_INIT_IDX(attr_idx) = NULL_IDX; 01068 ATD_FLD(attr_idx) = NO_Tbl_Idx; 01069 } 01070 } 01071 01072 if (ATD_CPNT_INIT_IDX(attr_idx) != NULL_IDX) { 01073 IR_TYPE_IDX(init_ir_idx) = TYPELESS_DEFAULT_TYPE; 01074 IR_LINE_NUM(init_ir_idx) = AT_DEF_LINE(attr_idx); 01075 IR_COL_NUM(init_ir_idx) = AT_DEF_COLUMN(attr_idx); 01076 IR_LINE_NUM_L(init_ir_idx) = AT_DEF_LINE(attr_idx); 01077 IR_COL_NUM_L(init_ir_idx) = AT_DEF_COLUMN(attr_idx); 01078 IR_FLD_L(init_ir_idx) = AT_Tbl_Idx; 01079 IR_IDX_L(init_ir_idx) = attr_idx; 01080 01081 COPY_OPND(IR_OPND_R(init_ir_idx), init_opnd); 01082 } 01083 } 01084 else { /* error from parse_expr */ 01085 AT_DCL_ERR(attr_idx) = TRUE; 01086 } 01087 } 01088 01089 if (!AT_DCL_ERR(attr_idx)) { 01090 assign_offset(attr_idx); /* Assign offsets to components */ 01091 } 01092 else { 01093 ATD_CPNT_OFFSET_IDX(attr_idx) = CN_INTEGER_ZERO_IDX; 01094 ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx; 01095 } 01096 01097 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 01098 AT_DCL_ERR(CURR_BLK_NAME) = AT_DCL_ERR(CURR_BLK_NAME) || 01099 AT_DCL_ERR(attr_idx); 01100 01101 } /* Do while */ 01102 while (LA_CH_VALUE == COMMA && 01103 matched_specific_token(Tok_Punct_Comma, Tok_Class_Punct)); 01104 01105 if (LA_CH_VALUE != EOS) { 01106 parse_err_flush(Find_EOS, ", or " EOS_STR); 01107 } 01108 01109 if (cif_flags & MISC_RECS) { 01110 cif_stmt_type_rec(TRUE, CIF_Type_Declaration_Stmt, stmt_number); 01111 } 01112 01113 NEXT_LA_CH; /* Skip EOS */ 01114 01115 TRACE (Func_Exit, "parse_cpnt_dcl_stmt", NULL); 01116 01117 return; 01118 01119 } /* parse_cpnt_dcl_stmt */ 01120 01121 01122 /******************************************************************************\ 01123 |* *| 01124 |* Description: *| 01125 |* Parse the DATA statement. *| 01126 |* *| 01127 |* Input parameters: *| 01128 |* NONE *| 01129 |* *| 01130 |* Output parameters: *| 01131 |* NONE *| 01132 |* *| 01133 |* Returns: *| 01134 |* NONE *| 01135 |* *| 01136 \******************************************************************************/ 01137 01138 void parse_data_stmt (void) 01139 01140 { 01141 int attr_idx; 01142 boolean found_attr; 01143 boolean found_comma = FALSE; 01144 int il_idx; 01145 int init_ir_idx; 01146 int name_column; 01147 int name_idx; 01148 int name_line; 01149 int obj_chain_end; 01150 opnd_type opnd; 01151 01152 01153 TRACE (Func_Entry, "parse_data_stmt", NULL); 01154 01155 if ((STMT_OUT_OF_ORDER(curr_stmt_category, Data_Stmt) || 01156 STMT_CANT_BE_IN_BLK(Data_Stmt, CURR_BLK)) && 01157 iss_blk_stk_err()) { 01158 01159 /* Issued block error - intentionally blank. */ 01160 01161 } 01162 else if (curr_stmt_category < Declaration_Stmt_Cat) { 01163 curr_stmt_category = Declaration_Stmt_Cat; 01164 } 01165 else if (curr_stmt_category > Declaration_Stmt_Cat) { 01166 PRINTMSG(TOKEN_LINE(token), 1571, Comment, /* Obsolescent */ 01167 TOKEN_COLUMN(token)); 01168 } 01169 01170 DATA_STMT_SET: 01171 01172 obj_chain_end = NULL_IDX; 01173 TOKEN_VALUE(token) = Tok_Const_False; 01174 01175 NTR_IR_TBL(init_ir_idx); 01176 SH_IR_IDX(curr_stmt_sh_idx) = init_ir_idx; 01177 IR_OPR(init_ir_idx) = Init_Opr; 01178 IR_TYPE_IDX(init_ir_idx) = TYPELESS_DEFAULT_TYPE; 01179 IR_LINE_NUM(init_ir_idx) = LA_CH_LINE; 01180 IR_COL_NUM(init_ir_idx) = LA_CH_COLUMN; 01181 01182 while (MATCHED_TOKEN_CLASS(Tok_Class_Id) || LA_CH_VALUE == LPAREN) { 01183 01184 found_comma = FALSE; 01185 01186 if (TOKEN_VALUE(token) != Tok_Const_False) { 01187 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx); 01188 01189 if (attr_idx == NULL_IDX) { 01190 found_attr = FALSE; 01191 attr_idx = ntr_sym_tbl(&token, name_idx); 01192 LN_DEF_LOC(name_idx) = TRUE; 01193 SET_IMPL_TYPE(attr_idx); 01194 } 01195 else { 01196 found_attr = TRUE; 01197 01198 if (AT_REFERENCED(attr_idx) == Char_Rslt_Bound_Ref) { 01199 AT_ATTR_LINK(attr_idx) = NULL_IDX; 01200 LN_DEF_LOC(name_idx) = TRUE; 01201 } 01202 } 01203 01204 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 01205 ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE; 01206 } 01207 01208 01209 name_line = TOKEN_LINE(token); 01210 name_column = TOKEN_COLUMN(token); 01211 01212 /* Note: If a cross reference was requested, the Usage record for the*/ 01213 /* target will be produced by the Semantics Pass so that expr_ */ 01214 /* semantics can produce a "modification" record for the target and */ 01215 /* "reference" records for any subscripts, substring expressions, */ 01216 /* etc. */ 01217 01218 if (LA_CH_VALUE == LPAREN || LA_CH_VALUE == PERCENT) { 01219 01220 if (parse_deref(&opnd, NULL_IDX)) { 01221 01222 if (OPND_FLD(opnd) == IR_Tbl_Idx && 01223 IR_OPR(OPND_IDX(opnd)) == Call_Opr) { 01224 PRINTMSG(name_line, 699, Error, name_column); 01225 parse_err_flush(Find_EOS, NULL); 01226 goto EXIT; 01227 } 01228 } 01229 else { 01230 parse_err_flush(Find_EOS, NULL); 01231 goto EXIT; 01232 } 01233 } 01234 else { 01235 OPND_LINE_NUM(opnd) = TOKEN_LINE(token); 01236 OPND_COL_NUM(opnd) = TOKEN_COLUMN(token); 01237 OPND_FLD(opnd) = AT_Tbl_Idx; 01238 OPND_IDX(opnd) = attr_idx; 01239 } 01240 01241 if (! merge_data(found_attr, name_line, name_column, attr_idx)) { 01242 parse_err_flush(Find_EOS, NULL); 01243 goto EXIT; 01244 } 01245 } 01246 else { 01247 01248 if (! parse_data_imp_do(&opnd)) { 01249 parse_err_flush(Find_EOS, NULL); 01250 goto EXIT; 01251 } 01252 } 01253 01254 NTR_IR_LIST_TBL(il_idx); 01255 COPY_OPND(IL_OPND(il_idx), opnd); 01256 01257 switch (IL_FLD(il_idx)) { 01258 01259 case AT_Tbl_Idx: 01260 IL_LINE_NUM(il_idx) = TOKEN_LINE(token); 01261 IL_COL_NUM(il_idx) = TOKEN_COLUMN(token); 01262 break; 01263 01264 case IR_Tbl_Idx: 01265 IL_LINE_NUM(il_idx) = IR_LINE_NUM(IL_IDX(il_idx)); 01266 IL_COL_NUM(il_idx) = IR_COL_NUM(IL_IDX(il_idx)); 01267 break; 01268 01269 default: 01270 PRINTMSG(stmt_start_line, 179, Internal, stmt_start_col, 01271 "parse_data_stmt"); 01272 } 01273 01274 if (obj_chain_end == NULL_IDX) { 01275 IR_FLD_L(init_ir_idx) = IL_Tbl_Idx; 01276 IR_IDX_L(init_ir_idx) = il_idx; 01277 } 01278 else { 01279 IL_NEXT_LIST_IDX(obj_chain_end) = il_idx; 01280 IL_PREV_LIST_IDX(il_idx) = obj_chain_end; 01281 } 01282 01283 obj_chain_end = il_idx; 01284 ++IR_LIST_CNT_L(init_ir_idx); 01285 01286 TOKEN_VALUE(token) = Tok_Const_False; 01287 01288 if (LA_CH_VALUE == COMMA) { 01289 found_comma = TRUE; 01290 NEXT_LA_CH; 01291 } 01292 else if (LA_CH_VALUE != SLASH) { 01293 parse_err_flush(Find_EOS, "comma or /"); 01294 goto EXIT; 01295 } 01296 01297 } /* End while */ 01298 01299 01300 /* We have just found a token that does not belong in the data-stmt-object */ 01301 /* list. At this point, we could be processing either the first target */ 01302 /* list or trying to process a target list following a value list. */ 01303 /* Have we actually seen any targets in the current list we're trying to */ 01304 /* parse? */ 01305 /* Y: Was the last token a comma? */ 01306 /* Y: Error. The comma must be followed by an id or implied-DO. */ 01307 /* N: OK. Go see if the next token is a '/'. */ 01308 /* N: Are we trying to parse the first target list? */ 01309 /* Y: Error. The first thing must be an id or an implied-DO. */ 01310 /* N: Was the last token a comma? */ 01311 /* Y: Error. The comma must be followed by an id or implied- */ 01312 /* DO. */ 01313 /* N: Error. The next token must be a target, comma, or EOS. */ 01314 01315 if (IR_IDX_L(init_ir_idx) != NULL_IDX) { 01316 01317 if (found_comma) { 01318 parse_err_flush(Find_EOS, "data-stmt-object"); 01319 goto EXIT; 01320 } 01321 } 01322 else { 01323 01324 if (! SH_COMPILER_GEN(curr_stmt_sh_idx)) { 01325 parse_err_flush(Find_EOS, "data-stmt-object"); 01326 goto EXIT; 01327 } 01328 else { 01329 01330 if (found_comma) { 01331 parse_err_flush(Find_EOS, "data-stmt-object"); 01332 goto EXIT; 01333 } 01334 else { 01335 parse_err_flush(Find_EOS, "comma, data-stmt-object, or EOS"); 01336 goto EXIT; 01337 } 01338 } 01339 } 01340 01341 if (LA_CH_VALUE == SLASH) { 01342 NEXT_LA_CH; 01343 01344 if (!parse_initializer(init_ir_idx)) { 01345 goto EXIT; 01346 } 01347 01348 if (LA_CH_VALUE == COMMA) { 01349 found_comma = TRUE; 01350 NEXT_LA_CH; 01351 } 01352 else { 01353 found_comma = FALSE; 01354 } 01355 01356 if (LA_CH_VALUE != EOS) { 01357 gen_sh(After, Data_Stmt, LA_CH_LINE, LA_CH_COLUMN, FALSE, FALSE, TRUE); 01358 goto DATA_STMT_SET; 01359 } 01360 else if (found_comma) { 01361 parse_err_flush(Find_EOS, "data-stmt-object"); 01362 } 01363 } 01364 else { 01365 parse_err_flush(Find_EOS, "/"); 01366 } 01367 01368 EXIT: 01369 01370 NEXT_LA_CH; 01371 strcpy(parse_operand_insert, "operand"); 01372 01373 TRACE (Func_Exit, "parse_data_stmt", NULL); 01374 01375 return; 01376 01377 } /* parse_data_stmt */ 01378 01379 01380 /******************************************************************************\ 01381 |* *| 01382 |* Description: *| 01383 |* BNF - TYPE [[,access_spec]::type-name *| 01384 |* *| 01385 |* Input parameters: *| 01386 |* NONE *| 01387 |* *| 01388 |* Output parameters: *| 01389 |* NONE *| 01390 |* *| 01391 |* Returns: *| 01392 |* NONE *| 01393 |* *| 01394 \******************************************************************************/ 01395 01396 static void parse_derived_type_stmt() 01397 01398 { 01399 access_type access; 01400 boolean access_set = FALSE; 01401 int dt_idx = NULL_IDX; 01402 boolean err; 01403 int name_idx; 01404 char *str; 01405 01406 01407 TRACE (Func_Entry, "parse_derived_type_stmt", NULL); 01408 01409 access = (access_type) AT_PRIVATE(SCP_ATTR_IDX(curr_scp_idx)); 01410 01411 if (LA_CH_VALUE == COMMA) { 01412 colon_recovery = TRUE; /* Can recover at :: */ 01413 NEXT_LA_CH; /* Skip COMMA */ 01414 01415 if (matched_specific_token(Tok_Kwd_Private, Tok_Class_Keyword) || 01416 matched_specific_token(Tok_Kwd_Public, Tok_Class_Keyword)) { 01417 access = TOKEN_VALUE(token) == Tok_Kwd_Private ? Private : Public; 01418 access_set = TRUE; 01419 01420 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Module) { 01421 str = access == Private ? "PRIVATE" : "PUBLIC"; 01422 PRINTMSG(TOKEN_LINE(token), 596, Error, TOKEN_COLUMN(token), str); 01423 access_set = FALSE; 01424 } 01425 01426 if (!matched_specific_token(Tok_Punct_Colon_Colon, Tok_Class_Punct)) { 01427 parse_err_flush(Find_None, "::"); 01428 } 01429 } 01430 else { 01431 parse_err_flush(Find_None, "PUBLIC or PRIVATE"); 01432 /* Bypass ::, just in case it's there */ 01433 matched_specific_token(Tok_Punct_Colon_Colon, Tok_Class_Punct); 01434 } 01435 colon_recovery = FALSE; 01436 } 01437 else { /* Colon Colon is optional here */ 01438 matched_specific_token(Tok_Punct_Colon_Colon, Tok_Class_Punct); 01439 } 01440 01441 01442 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 01443 01444 if (LA_CH_VALUE != EOS) { 01445 parse_err_flush(Find_EOS, EOS_STR); 01446 } 01447 01448 err = FALSE; 01449 01450 switch (TOKEN_STR(token)[0]) { 01451 case 'C': 01452 err = (strcmp(TOKEN_STR(token), "CHARACTER") == 0) || 01453 (strcmp(TOKEN_STR(token), "COMPLEX") == 0); 01454 break; 01455 case 'D': 01456 err = (strcmp(TOKEN_STR(token), "DOUBLEPRECISION") == 0); 01457 break; 01458 case 'I': 01459 err = (strcmp(TOKEN_STR(token), "INTEGER") == 0); 01460 break; 01461 case 'L': 01462 err = (strcmp(TOKEN_STR(token), "LOGICAL") == 0); 01463 break; 01464 case 'R': 01465 err = (strcmp(TOKEN_STR(token), "REAL") == 0); 01466 break; 01467 } /* end switch */ 01468 01469 if (err) { /* Issue msg - but allow name to be used */ 01470 PRINTMSG (TOKEN_LINE(token), 286, Error, TOKEN_COLUMN(token), 01471 TOKEN_STR(token)); 01472 } 01473 01474 dt_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx); 01475 01476 if (dt_idx == NULL_IDX) { 01477 dt_idx = ntr_sym_tbl(&token, name_idx); 01478 AT_OBJ_CLASS(dt_idx) = Derived_Type; 01479 ATT_STRUCT_BIT_LEN_FLD(dt_idx) = CN_Tbl_Idx; 01480 ATT_STRUCT_BIT_LEN_IDX(dt_idx) = CN_INTEGER_ZERO_IDX; 01481 ATT_SCP_IDX(dt_idx) = curr_scp_idx; 01482 } 01483 else if (AT_NOT_VISIBLE(dt_idx)) { 01484 PRINTMSG(TOKEN_LINE(token), 486, Error, 01485 TOKEN_COLUMN(token), 01486 AT_OBJ_NAME_PTR(dt_idx), 01487 AT_OBJ_NAME_PTR(AT_MODULE_IDX(dt_idx))); 01488 CREATE_ERR_ATTR(dt_idx, 01489 TOKEN_LINE(token), 01490 TOKEN_COLUMN(token), 01491 Derived_Type); 01492 ATT_STRUCT_BIT_LEN_FLD(dt_idx) = CN_Tbl_Idx; 01493 ATT_STRUCT_BIT_LEN_IDX(dt_idx) = CN_INTEGER_ZERO_IDX; 01494 ATT_SCP_IDX(dt_idx) = curr_scp_idx; 01495 } 01496 else if (AT_ATTR_LINK(dt_idx) != NULL_IDX) { 01497 AT_DEF_LINE(dt_idx) = TOKEN_LINE(token); 01498 AT_DEF_COLUMN(dt_idx) = TOKEN_COLUMN(token); 01499 AT_ATTR_LINK(dt_idx) = NULL_IDX; 01500 CLEAR_VARIANT_ATTR_INFO(dt_idx, Derived_Type); 01501 ATT_STRUCT_BIT_LEN_FLD(dt_idx) = CN_Tbl_Idx; 01502 ATT_STRUCT_BIT_LEN_IDX(dt_idx) = CN_INTEGER_ZERO_IDX; 01503 ATT_SCP_IDX(dt_idx) = curr_scp_idx; 01504 01505 if (AT_LOCKED_IN(dt_idx)) { 01506 PRINTMSG(TOKEN_LINE(token), 390, Error, TOKEN_COLUMN(token), 01507 AT_OBJ_NAME_PTR(dt_idx)); 01508 AT_DCL_ERR(dt_idx) = TRUE; 01509 } 01510 } 01511 else if (AT_OBJ_CLASS(dt_idx) == Derived_Type) { 01512 ATT_SCP_IDX(dt_idx) = curr_scp_idx; 01513 01514 if (AT_DEFINED(dt_idx)) { 01515 AT_DCL_ERR(dt_idx) = TRUE; 01516 PRINTMSG(TOKEN_LINE(token), 123, Error, TOKEN_COLUMN(token), 01517 AT_OBJ_NAME_PTR(dt_idx)); 01518 } 01519 } 01520 else if (fnd_semantic_err(Obj_Derived_Type, 01521 TOKEN_LINE(token), 01522 TOKEN_COLUMN(token), 01523 dt_idx, 01524 TRUE)) { 01525 01526 /* Create an error attr - but leave LN pointing to the original one. */ 01527 01528 CREATE_ERR_ATTR(dt_idx, 01529 TOKEN_LINE(token), 01530 TOKEN_COLUMN(token), 01531 Derived_Type); 01532 ATT_STRUCT_BIT_LEN_FLD(dt_idx) = CN_Tbl_Idx; 01533 ATT_STRUCT_BIT_LEN_IDX(dt_idx) = CN_INTEGER_ZERO_IDX; 01534 ATT_SCP_IDX(dt_idx) = curr_scp_idx; 01535 } 01536 else { /* Can only have been specified in an access statement */ 01537 01538 CLEAR_VARIANT_ATTR_INFO(dt_idx, Derived_Type); 01539 ATT_STRUCT_BIT_LEN_FLD(dt_idx) = CN_Tbl_Idx; 01540 ATT_STRUCT_BIT_LEN_IDX(dt_idx) = CN_INTEGER_ZERO_IDX; 01541 ATT_SCP_IDX(dt_idx) = curr_scp_idx; 01542 } 01543 01544 if (CURR_BLK != Interface_Body_Blk) { 01545 01546 /* Interface_Body_Blk stuff is counted during interface collapse. */ 01547 01548 num_of_derived_types++; 01549 } 01550 01551 if ((cif_flags & XREF_RECS) != 0) { 01552 cif_usage_rec(dt_idx, 01553 AT_Tbl_Idx, 01554 TOKEN_LINE(token), 01555 TOKEN_COLUMN(token), 01556 CIF_Derived_Type_Name_Definition); 01557 } 01558 01559 LN_DEF_LOC(name_idx) = TRUE; 01560 AT_DEFINED(dt_idx) = TRUE; 01561 AT_LOCKED_IN(dt_idx) = TRUE; 01562 01563 if (AT_ACCESS_SET(dt_idx)) { 01564 01565 if (access_set) { 01566 AT_DCL_ERR(dt_idx) = TRUE; 01567 PRINTMSG (TOKEN_LINE(token), 275, Error, TOKEN_COLUMN(token), 01568 AT_OBJ_NAME_PTR(dt_idx)); 01569 } 01570 } 01571 else { 01572 AT_PRIVATE(dt_idx) = access; 01573 AT_ACCESS_SET(dt_idx) = access_set; 01574 } 01575 } 01576 else { 01577 parse_err_flush(Find_EOS, "type-name"); 01578 } 01579 01580 stmt_type = Derived_Type_Stmt; 01581 SH_STMT_TYPE(curr_stmt_sh_idx) = Derived_Type_Stmt; 01582 01583 if ((STMT_OUT_OF_ORDER(curr_stmt_category, Derived_Type_Stmt) || 01584 STMT_CANT_BE_IN_BLK(Derived_Type_Stmt, CURR_BLK)) && 01585 iss_blk_stk_err()) { 01586 PUSH_BLK_STK(Derived_Type_Blk); 01587 CURR_BLK_ERR = TRUE; 01588 } 01589 else { 01590 PUSH_BLK_STK(Derived_Type_Blk); 01591 curr_stmt_category = Declaration_Stmt_Cat; 01592 } 01593 01594 CURR_BLK_NO_EXEC = TRUE; 01595 CURR_BLK_NAME = dt_idx; 01596 01597 NEXT_LA_CH; /* Skip EOS */ 01598 01599 TRACE (Func_Exit, "parse_derived_type_stmt", NULL); 01600 01601 return; 01602 01603 } /* parse_derived_type_stmt */ 01604 01605 01606 /******************************************************************************\ 01607 |* *| 01608 |* Description: *| 01609 |* Parse the EQUIVALENCE statement. *| 01610 |* *| 01611 |* Input parameters: *| 01612 |* NONE *| 01613 |* *| 01614 |* Output parameters: *| 01615 |* NONE *| 01616 |* *| 01617 |* Returns: *| 01618 |* NONE *| 01619 |* *| 01620 \******************************************************************************/ 01621 01622 void parse_equivalence_stmt (void) 01623 01624 { 01625 int al_idx; 01626 int attr_idx; 01627 int column; 01628 int eq_idx; 01629 boolean fnd_attr; 01630 int group; 01631 boolean have_array; 01632 int items_in_list; 01633 int line; 01634 int list_idx; 01635 int list2_idx; 01636 int name_idx; 01637 opnd_type opnd; 01638 boolean parsed_ok = TRUE; 01639 int rank; 01640 opnd_type result_opnd; 01641 int subs_idx = NULL_IDX; 01642 boolean substring; 01643 int substring_idx; 01644 01645 01646 TRACE (Func_Entry, "parse_equivalence_stmt", NULL); 01647 01648 if (LA_CH_VALUE == LPAREN) { 01649 01650 NTR_EQ_TBL(eq_idx); 01651 01652 while (LA_CH_VALUE == LPAREN) { 01653 NEXT_LA_CH; /* eat the ( */ 01654 01655 EQ_NEXT_EQUIV_GRP(eq_idx) = SCP_FIRST_EQUIV_GRP(curr_scp_idx); 01656 SCP_FIRST_EQUIV_GRP(curr_scp_idx) = eq_idx; 01657 group = eq_idx; 01658 items_in_list = 0; 01659 01660 do { 01661 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 01662 attr_idx = srch_sym_tbl(TOKEN_STR(token), 01663 TOKEN_LEN(token), 01664 &name_idx); 01665 fnd_attr = attr_idx; 01666 line = TOKEN_LINE(token); 01667 column = TOKEN_COLUMN(token); 01668 EQ_LINE_NUM(eq_idx) = line; 01669 EQ_COLUMN_NUM(eq_idx) = column; 01670 items_in_list = items_in_list + 1; 01671 01672 if (attr_idx == NULL_IDX) { 01673 attr_idx = ntr_sym_tbl(&token, name_idx); 01674 LN_DEF_LOC(name_idx) = TRUE; 01675 SET_IMPL_TYPE(attr_idx); 01676 AT_OBJ_CLASS(attr_idx) = Data_Obj; 01677 ATD_CLASS(attr_idx) = Variable; 01678 } 01679 else if (AT_REFERENCED(attr_idx) == Char_Rslt_Bound_Ref) { 01680 AT_ATTR_LINK(attr_idx) = NULL_IDX; 01681 LN_DEF_LOC(name_idx) = TRUE; 01682 } 01683 01684 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 01685 ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE; 01686 } 01687 01688 if ((cif_flags & XREF_RECS) != 0) { 01689 cif_usage_rec(attr_idx, 01690 AT_Tbl_Idx, 01691 line, 01692 column, 01693 CIF_Symbol_Declaration); 01694 } 01695 01696 if (group != eq_idx) { 01697 EQ_NEXT_EQUIV_OBJ(EQ_GRP_END_IDX(group)) = eq_idx; 01698 } 01699 01700 if (!fnd_attr || !fnd_semantic_err(Obj_Equiv, 01701 line, 01702 column, 01703 attr_idx, 01704 TRUE)) { 01705 01706 NTR_ATTR_LIST_TBL(al_idx); 01707 01708 AL_IDX_IS_EQ(al_idx) = TRUE; 01709 AL_NEXT_IDX(al_idx) = ATD_EQUIV_LIST(attr_idx); 01710 AL_EQ_IDX(al_idx) = eq_idx; 01711 ATD_CLASS(attr_idx) = Variable; 01712 ATD_EQUIV(attr_idx) = TRUE; 01713 ATD_EQUIV_LIST(attr_idx) = al_idx; 01714 ATD_DCL_EQUIV(attr_idx) = TRUE; 01715 } 01716 EQ_ATTR_IDX(eq_idx) = attr_idx; 01717 EQ_GRP_IDX(eq_idx) = group; 01718 EQ_GRP_END_IDX(group) = eq_idx; 01719 01720 if (LA_CH_VALUE == LPAREN) { /* Array and/or substring */ 01721 expr_mode = Initialization_Expr; 01722 OPND_FLD(result_opnd) = AT_Tbl_Idx; 01723 OPND_IDX(result_opnd) = attr_idx; 01724 OPND_LINE_NUM(result_opnd) = TOKEN_LINE(token); 01725 OPND_COL_NUM(result_opnd) = TOKEN_COLUMN(token); 01726 substring = is_substring_ref(); 01727 have_array = (ATD_ARRAY_IDX(attr_idx) != NULL_IDX); 01728 01729 if (have_array && substring) { 01730 PRINTMSG(TOKEN_LINE(token), 250,Error,TOKEN_COLUMN(token)); 01731 } 01732 01733 if (!substring) { 01734 rank = 0; 01735 NTR_IR_TBL(subs_idx); 01736 01737 /* copy the attr_idx */ 01738 01739 COPY_OPND(IR_OPND_L(subs_idx), result_opnd); 01740 01741 /* put subs_idx into result opnd for now */ 01742 01743 OPND_FLD(result_opnd) = IR_Tbl_Idx; 01744 OPND_IDX(result_opnd) = subs_idx; 01745 01746 /* LA_CH is '(' */ 01747 IR_LINE_NUM(subs_idx) = LA_CH_LINE; 01748 IR_COL_NUM(subs_idx) = LA_CH_COLUMN; 01749 IR_OPR(subs_idx) = Subscript_Opr; 01750 IR_FLD_R(subs_idx) = IL_Tbl_Idx; 01751 list_idx = NULL_IDX; 01752 01753 do { 01754 NEXT_LA_CH; 01755 01756 if (list_idx == NULL_IDX) { 01757 NTR_IR_LIST_TBL(list_idx); 01758 IR_IDX_R(subs_idx) = list_idx; 01759 } 01760 else { 01761 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 01762 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = 01763 list_idx; 01764 list_idx = IL_NEXT_LIST_IDX(list_idx); 01765 } 01766 01767 if (LA_CH_VALUE != COLON) { 01768 parsed_ok = parse_expr(&opnd) && parsed_ok; 01769 COPY_OPND(IL_OPND(list_idx), opnd); 01770 } 01771 rank++; 01772 } 01773 while (LA_CH_VALUE == COMMA); 01774 01775 if (! matched_specific_token(Tok_Punct_Rparen, 01776 Tok_Class_Punct)) { 01777 parse_err_flush(Find_EOS, ")"); 01778 parsed_ok = FALSE; 01779 expr_mode = Regular_Expr; 01780 goto EXIT; 01781 } 01782 01783 IR_LIST_CNT_R(subs_idx) = rank; 01784 01785 } /* if (array) */ 01786 01787 /* now check for possible substring reference */ 01788 01789 if (LA_CH_VALUE == LPAREN && is_substring_ref()) { 01790 EQ_SUBSTRINGED(eq_idx) = TRUE; 01791 NTR_IR_TBL(substring_idx); 01792 IR_OPR(substring_idx) = Substring_Opr; 01793 IR_LINE_NUM(substring_idx) = LA_CH_LINE; 01794 IR_COL_NUM(substring_idx) = LA_CH_COLUMN; 01795 01796 COPY_OPND(IR_OPND_L(substring_idx), result_opnd); 01797 01798 /* put substring idx into result_opnd */ 01799 01800 OPND_FLD(result_opnd) = IR_Tbl_Idx; 01801 OPND_IDX(result_opnd) = substring_idx; 01802 IR_FLD_R(substring_idx) = IL_Tbl_Idx; 01803 IR_LIST_CNT_R(substring_idx) = 2; 01804 NTR_IR_LIST_TBL(list_idx); 01805 NTR_IR_LIST_TBL(list2_idx); 01806 IR_IDX_R(substring_idx) = list_idx; 01807 IL_NEXT_LIST_IDX(list_idx) = list2_idx; 01808 IL_PREV_LIST_IDX(list2_idx) = list_idx; 01809 01810 NEXT_LA_CH; /* consume ( */ 01811 01812 if (LA_CH_VALUE != COLON) { 01813 parsed_ok = parse_expr(&opnd) && parsed_ok; 01814 COPY_OPND(IL_OPND(list_idx), opnd); 01815 } 01816 01817 if (LA_CH_VALUE != COLON) { 01818 01819 if (parse_err_flush(Find_EOS, ":")) { 01820 NEXT_LA_CH; 01821 } 01822 01823 parsed_ok = FALSE; 01824 expr_mode = Regular_Expr; 01825 goto EXIT; 01826 } 01827 01828 NEXT_LA_CH; /* consume : */ 01829 01830 if (LA_CH_VALUE != RPAREN) { 01831 parsed_ok = parse_expr(&opnd) && parsed_ok; 01832 COPY_OPND(IL_OPND(list2_idx), opnd); 01833 } 01834 01835 if (LA_CH_VALUE != RPAREN) { 01836 01837 if (parse_err_flush(Find_EOS, ")")) { 01838 NEXT_LA_CH; 01839 } 01840 parsed_ok = FALSE; 01841 expr_mode = Regular_Expr; 01842 goto EXIT; 01843 } 01844 NEXT_LA_CH; /* Consume rparen */ 01845 } /* substring reference */ 01846 01847 expr_mode = Regular_Expr; 01848 EQ_OPND_FLD(eq_idx) = OPND_FLD(result_opnd); 01849 EQ_OPND_IDX(eq_idx) = OPND_IDX(result_opnd); 01850 } 01851 NTR_EQ_TBL(eq_idx); 01852 01853 # ifdef COARRAY_FORTRAN 01854 01855 if (LA_CH_VALUE == LBRKT && cmd_line_flags.co_array_fortran) { 01856 PRINTMSG(LA_CH_LINE, 1578, Error, LA_CH_COLUMN, 01857 AT_OBJ_NAME_PTR(attr_idx), "EQUIVALENCE"); 01858 01859 /* Disregard the list_idx. It's just a place holder */ 01860 /* so that we can parse correctly. */ 01861 01862 list2_idx = parse_pe_array_spec(attr_idx); 01863 } 01864 # endif 01865 } 01866 else { 01867 parse_err_flush(Find_Comma_Rparen, "equivalence-object"); 01868 } 01869 01870 if (LA_CH_VALUE != COMMA && LA_CH_VALUE != RPAREN) { 01871 parse_err_flush(Find_EOS, ", or )"); 01872 goto EXIT; 01873 } 01874 01875 if (LA_CH_VALUE == COMMA) { 01876 NEXT_LA_CH; /* eat the , */ 01877 } 01878 else { 01879 break; 01880 } 01881 01882 } /* End while */ 01883 while (TRUE); 01884 01885 if (items_in_list < 2) { 01886 PRINTMSG(LA_CH_LINE, 137, Error, LA_CH_COLUMN); 01887 } 01888 01889 if (LA_CH_VALUE != RPAREN) { 01890 parse_err_flush(Find_EOS, ")"); 01891 goto EXIT; 01892 } 01893 NEXT_LA_CH; /* eat the ) */ 01894 01895 if (LA_CH_VALUE != COMMA && LA_CH_VALUE != EOS) { 01896 parse_err_flush(Find_EOS, ", or " EOS_STR); 01897 goto EXIT; 01898 } 01899 01900 if (LA_CH_VALUE == COMMA) { 01901 NEXT_LA_CH; /* eat the , */ 01902 } 01903 } /* End while */ 01904 01905 if ((STMT_OUT_OF_ORDER(curr_stmt_category, Equivalence_Stmt) || 01906 STMT_CANT_BE_IN_BLK(Equivalence_Stmt, CURR_BLK)) && 01907 iss_blk_stk_err()) { 01908 /* Issued block stack error - intentionally left blank */ 01909 } 01910 else { 01911 curr_stmt_category = Declaration_Stmt_Cat; 01912 } 01913 } 01914 else { 01915 parse_err_flush(Find_EOS, "("); 01916 goto EXIT; 01917 } 01918 01919 if (LA_CH_VALUE != EOS) { 01920 parse_err_flush(Find_EOS, EOS_STR); 01921 } 01922 01923 EXIT: 01924 01925 NEXT_LA_CH; /* eat the EOS */ 01926 01927 TRACE (Func_Exit, "parse_equivalence_stmt", NULL); 01928 01929 return; 01930 01931 } /* parse_equivalence_stmt */ 01932 01933 /******************************************************************************\ 01934 |* *| 01935 |* Description: *| 01936 |* This function parses the implicit statement. If the statement is an *| 01937 |* IMPLICIT NONE statement, stmt_type is changed to reflect the fact. *| 01938 |* The syntax that is parsed is a follows: *| 01939 |* *| 01940 |* implicit-stmt => IMPLICIT implicit-spec-list | IMPLICIT NONE *| 01941 |* implicit-spec => type-spec ( letter-spec-list ) *| 01942 |* letter-spec => letter [- letter] *| 01943 |* *| 01944 |* This routine also parses and extension -> IMPLICIT UNDEFINED *| 01945 |* This is the same as IMPLICIT NONE. *| 01946 |* *| 01947 |* Input parameters: *| 01948 |* NONE *| 01949 |* *| 01950 |* Output parameters: *| 01951 |* NONE *| 01952 |* *| 01953 |* Returns: *| 01954 |* NONE *| 01955 |* *| 01956 \******************************************************************************/ 01957 01958 void parse_implicit_stmt (void) 01959 01960 { 01961 int al_idx; 01962 int attr_idx; 01963 boolean end_found = FALSE; 01964 int end_idx; 01965 int err_idx; 01966 char err_str[80]; 01967 boolean found_type; 01968 boolean have_kind; 01969 int idx; 01970 boolean implicit_undefined; 01971 int name_idx; 01972 char start_char; 01973 int start_idx; 01974 int stmt_number; 01975 int storage; 01976 boolean type_err; 01977 int type_idx; 01978 01979 01980 TRACE (Func_Entry, "parse_implicit_stmt", NULL); 01981 01982 stmt_number = statement_number; 01983 implicit_undefined = FALSE; 01984 01985 if (LA_CH_VALUE == 'U' && 01986 matched_specific_token(Tok_Kwd_Undefined, Tok_Class_Keyword)) { 01987 implicit_undefined = TRUE; 01988 PRINTMSG(stmt_start_line, 1253, Ansi, stmt_start_col, 01989 "IMPLICIT UNDEFINED"); 01990 } 01991 01992 if (implicit_undefined || 01993 (LA_CH_VALUE == 'N' && 01994 matched_specific_token(Tok_Kwd_None, Tok_Class_Keyword))) { 01995 01996 if (LA_CH_VALUE == EOS) { 01997 stmt_type = Implicit_None_Stmt; 01998 SH_STMT_TYPE(curr_stmt_sh_idx) = Implicit_None_Stmt; 01999 02000 if (cif_flags & MISC_RECS) { 02001 cif_stmt_type_rec(TRUE, CIF_Implicit_None_Stmt, stmt_number); 02002 } 02003 02004 if ((STMT_OUT_OF_ORDER(curr_stmt_category, Implicit_None_Stmt) || 02005 STMT_CANT_BE_IN_BLK(Implicit_None_Stmt, CURR_BLK)) && 02006 iss_blk_stk_err()) { 02007 /* Intentionally left blank */ 02008 } 02009 else { 02010 curr_stmt_category = Implicit_None_Stmt_Cat; 02011 } 02012 02013 if (SCP_IMPL_NONE(curr_scp_idx)) { /* IMPLICIT NONE already in scope */ 02014 PRINTMSG(stmt_start_line, 298, Error, stmt_start_col); 02015 } 02016 02017 SCP_IMPL_NONE(curr_scp_idx) = TRUE; 02018 } 02019 else { 02020 parse_err_flush(Find_EOS, EOS_STR); 02021 } 02022 02023 goto EXIT; 02024 } 02025 02026 if (cif_flags & MISC_RECS) { 02027 cif_stmt_type_rec(TRUE, CIF_Implicit_Stmt, stmt_number); 02028 } 02029 02030 if ((STMT_OUT_OF_ORDER(curr_stmt_category, Implicit_Stmt) || 02031 STMT_CANT_BE_IN_BLK(Implicit_Stmt, CURR_BLK)) && 02032 iss_blk_stk_err()) { 02033 /* Issued block stack error - intentionally left blank */ 02034 } 02035 else { 02036 curr_stmt_category = Implicit_Stmt_Cat; 02037 } 02038 02039 found_type = FALSE; 02040 02041 do { 02042 02043 if (!MATCHED_TOKEN_CLASS (Tok_Class_Keyword)) { 02044 02045 /* We could also have AUTOMATIC or STATIC but they are not */ 02046 /* included in the list because this is an old MIPS */ 02047 /* extension and we do not want to encourage this use. */ 02048 02049 if (!parse_err_flush(Find_Comma, "INTEGER, REAL, DOUBLE, COMPLEX," 02050 " LOGICAL, CHARACTER or TYPE")) { 02051 goto EXIT; /* Didn't find a comma */ 02052 } 02053 NEXT_LA_CH; 02054 continue; 02055 } 02056 02057 if (TOKEN_VALUE(token) == Tok_Kwd_Automatic) { 02058 storage = Impl_Automatic_Storage; 02059 } 02060 else if (TOKEN_VALUE(token) == Tok_Kwd_Static) { 02061 storage = Impl_Static_Storage; 02062 } 02063 else { 02064 storage = Impl_Default_Storage; 02065 02066 found_type = TRUE; 02067 02068 /* Set have_kind if there is more than one paren group following the */ 02069 /* implicit type keyword. If there is only one paren group, that */ 02070 /* means, that the paren group is the letter(s) for the implict type */ 02071 02072 have_kind = (LA_CH_VALUE == LPAREN && 02073 TOKEN_VALUE(token) != Tok_Kwd_Type && 02074 ch_after_paren_grp() == LPAREN); 02075 02076 type_err = !parse_type_spec(have_kind); 02077 type_idx = ATD_TYPE_IDX(AT_WORK_IDX); 02078 02079 if (type_err) { /* No valid type keyword */ 02080 02081 if (!parse_err_flush(Find_Comma, NULL)) { 02082 goto EXIT; /* Didn't find a comma */ 02083 } 02084 NEXT_LA_CH; 02085 continue; 02086 } 02087 02088 if (TYP_TYPE(type_idx) == Character && 02089 TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char) { 02090 02091 /* implicit character *(*) is not allowed */ 02092 02093 PRINTMSG(TOKEN_LINE(token), 32, Error, TOKEN_COLUMN(token)); 02094 02095 if (!parse_err_flush(Find_Comma, NULL)) { 02096 goto EXIT; /* Didn't find a comma */ 02097 } 02098 NEXT_LA_CH; 02099 continue; 02100 } 02101 } 02102 02103 if (LA_CH_VALUE != LPAREN) { 02104 02105 if (!parse_err_flush(Find_Comma, "(")) { 02106 goto EXIT; 02107 } 02108 NEXT_LA_CH; 02109 continue; 02110 } 02111 02112 do { 02113 NEXT_LA_CH; 02114 02115 if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 02116 parse_err_flush(Find_Comma_Rparen, 02117 "A,B,C,D,E,F,G,H,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y or Z"); 02118 continue; 02119 } 02120 02121 if (TOKEN_LEN(token) > 1) { 02122 PRINTMSG(TOKEN_LINE(token), 197, Error, TOKEN_COLUMN(token), 02123 "A,B,C,D,E,F,G,H,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y or Z", 02124 TOKEN_STR(token)); 02125 parse_err_flush(Find_Comma_Rparen, NULL); 02126 continue; 02127 } 02128 02129 start_char = TOKEN_STR(token)[0]; 02130 start_idx = IMPL_IDX(start_char); 02131 end_idx = start_idx; 02132 02133 if (LA_CH_VALUE == DASH) { 02134 NEXT_LA_CH; 02135 02136 if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 02137 parse_err_flush(Find_Comma_Rparen, 02138 "A,B,C,D,E,F,G,H,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y or Z"); 02139 continue; 02140 } 02141 02142 if (TOKEN_LEN(token) > 1) { 02143 PRINTMSG(TOKEN_LINE(token), 197, Error,TOKEN_COLUMN(token), 02144 "B,C,D,E,F,G,H,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y or Z", 02145 TOKEN_STR(token)); 02146 parse_err_flush(Find_Comma_Rparen, NULL); 02147 continue; 02148 } 02149 end_idx = IMPL_IDX(TOKEN_STR(token)[0]); 02150 02151 if (start_idx > end_idx) { /* start range exceeds end */ 02152 PRINTMSG(TOKEN_LINE(token), 175, Error,TOKEN_COLUMN(token), 02153 start_char, TOKEN_STR(token)[0]); 02154 } 02155 } 02156 02157 err_idx = NULL_IDX; 02158 02159 if (storage == Impl_Default_Storage) { /* Implicit type statement */ 02160 02161 for (idx = start_idx; idx <= end_idx; idx++) { 02162 02163 if (IM_SET(curr_scp_idx, idx)) { 02164 err_str[err_idx++] = COMMA; 02165 err_str[err_idx++] = ' '; 02166 err_str[err_idx++] = idx + 'A'; 02167 } 02168 else { 02169 IM_SET(curr_scp_idx, idx) = TRUE; 02170 IM_TYPE_IDX(curr_scp_idx, idx) = type_idx; 02171 } 02172 } 02173 02174 if (err_idx != NULL_IDX) { 02175 err_str[err_idx] = EOS; 02176 PRINTMSG(TOKEN_LINE(token), 1629, Error, TOKEN_COLUMN(token), 02177 "type", 02178 &err_str[2]); /* Skip first , blank in string */ 02179 } 02180 } 02181 else { 02182 for (idx = start_idx; idx <= end_idx; idx++) { 02183 02184 if (IM_STORAGE(curr_scp_idx, idx) != Impl_Default_Storage) { 02185 err_str[err_idx++] = COMMA; 02186 err_str[err_idx++] = ' '; 02187 err_str[err_idx++] = idx + 'A'; 02188 } 02189 else { 02190 IM_STORAGE(curr_scp_idx, idx) = storage; 02191 } 02192 } 02193 02194 if (err_idx != NULL_IDX) { 02195 err_str[err_idx] = EOS; 02196 PRINTMSG(TOKEN_LINE(token), 1629, Error, TOKEN_COLUMN(token), 02197 "storage", 02198 &err_str[2]); /* Skip first , blank in string */ 02199 } 02200 } 02201 02202 if (LA_CH_VALUE != COMMA && LA_CH_VALUE != RPAREN) { 02203 parse_err_flush(Find_Comma_Rparen, ", or )"); 02204 } 02205 02206 } /* End while */ 02207 while (LA_CH_VALUE == COMMA); 02208 02209 if (LA_CH_VALUE == RPAREN) { 02210 NEXT_LA_CH; 02211 } 02212 02213 if (LA_CH_VALUE == EOS || (LA_CH_VALUE != COMMA && 02214 !parse_err_flush(Find_Comma, ", or " EOS_STR))){ 02215 end_found = TRUE; 02216 } 02217 else { 02218 NEXT_LA_CH; 02219 } 02220 } /* while */ 02221 while (!end_found); 02222 02223 if (SCP_IMPL_NONE(curr_scp_idx) && found_type) { 02224 02225 /* IMPLICIT NONE already set in scope */ 02226 02227 PRINTMSG (stmt_start_line, 176, Error, stmt_start_col); 02228 parse_err_flush(Find_EOS, NULL); 02229 goto EXIT; 02230 } 02231 02232 for (name_idx = SCP_LN_FW_IDX(curr_scp_idx) + 1; 02233 name_idx < SCP_LN_LW_IDX(curr_scp_idx); name_idx++) { 02234 02235 attr_idx = LN_ATTR_IDX(name_idx); 02236 02237 if (AT_ATTR_LINK(attr_idx) == NULL_IDX && !AT_USE_ASSOCIATED(attr_idx)) { 02238 retype_attr(attr_idx); 02239 } 02240 } 02241 02242 al_idx = SCP_ATTR_LIST(curr_scp_idx); 02243 02244 while (al_idx != NULL_IDX) { 02245 02246 if (AT_ATTR_LINK(AL_ATTR_IDX(al_idx)) == NULL_IDX && 02247 !AT_USE_ASSOCIATED(AL_ATTR_IDX(al_idx))) { 02248 retype_attr(AL_ATTR_IDX(al_idx)); 02249 } 02250 al_idx = AL_NEXT_IDX(al_idx); 02251 } 02252 02253 EXIT: 02254 02255 NEXT_LA_CH; 02256 02257 TRACE (Func_Exit, "parse_implicit_stmt", NULL); 02258 02259 return; 02260 02261 } /* parse_implicit_stmt */ 02262 02263 /******************************************************************************\ 02264 |* *| 02265 |* Description: *| 02266 |* *| 02267 |* Input parameters: *| 02268 |* NONE *| 02269 |* *| 02270 |* Output parameters: *| 02271 |* NONE *| 02272 |* *| 02273 |* Returns: *| 02274 |* NONE *| 02275 |* *| 02276 \******************************************************************************/ 02277 02278 static void retype_attr(int attr_idx) 02279 02280 { 02281 int old_type_idx; 02282 02283 02284 TRACE (Func_Entry, "retype_attr", NULL); 02285 02286 /* Retype possible function name, dummy args, and any thing used in */ 02287 /* a bounds expression for character. Special case for N$PES. */ 02288 02289 switch (AT_OBJ_CLASS(attr_idx)) { 02290 02291 case Data_Obj: 02292 02293 if (!AT_TYPED(attr_idx) && !ATD_SYMBOLIC_CONSTANT(attr_idx)) { 02294 02295 if (ATD_CLASS(attr_idx) == Constant) { 02296 old_type_idx = ATD_TYPE_IDX(attr_idx); 02297 SET_IMPL_TYPE(attr_idx); 02298 02299 if (old_type_idx != ATD_TYPE_IDX(attr_idx)) { 02300 PRINTMSG(AT_DEF_LINE(attr_idx), 238, Error, 02301 AT_DEF_COLUMN(attr_idx), 02302 AT_OBJ_NAME_PTR(attr_idx), 02303 get_basic_type_str(old_type_idx)); 02304 ATD_TYPE_IDX(attr_idx) = old_type_idx; 02305 } 02306 } 02307 else if (ATD_CLASS(attr_idx) != Compiler_Tmp) { 02308 02309 if (AT_REFERENCED(attr_idx) > Not_Referenced) { 02310 old_type_idx = ATD_TYPE_IDX(attr_idx); 02311 SET_IMPL_TYPE(attr_idx); 02312 02313 if (old_type_idx != ATD_TYPE_IDX(attr_idx)) { 02314 ATD_TYPE_IDX(attr_idx) = old_type_idx; 02315 AT_DCL_ERR(attr_idx) = TRUE; 02316 PRINTMSG(AT_DEF_LINE(attr_idx), 827, Error, 02317 AT_DEF_COLUMN(attr_idx), 02318 AT_OBJ_NAME_PTR(attr_idx), 02319 get_basic_type_str(old_type_idx)); 02320 } 02321 } 02322 else { 02323 SET_IMPL_TYPE(attr_idx); 02324 } 02325 } 02326 } 02327 break; 02328 02329 case Pgm_Unit: 02330 02331 if (ATP_PGM_UNIT(attr_idx) == Function && 02332 !ATP_RSLT_NAME(attr_idx) && /* Will catch with own name */ 02333 !AT_TYPED(ATP_RSLT_IDX(attr_idx))) { 02334 SET_IMPL_TYPE(ATP_RSLT_IDX(attr_idx)); 02335 } 02336 break; 02337 02338 default: /* Any stmt_functions would be host associated */ 02339 break; 02340 02341 } /* End switch */ 02342 02343 TRACE (Func_Exit, "retype_attr", NULL); 02344 02345 return; 02346 02347 } /* retype_attr */ 02348 02349 /******************************************************************************\ 02350 |* *| 02351 |* Description: *| 02352 |* BNF is INTERFACE [ generic spec ] *| 02353 |* *| 02354 |* Input parameters: *| 02355 |* NONE *| 02356 |* *| 02357 |* Output parameters: *| 02358 |* NONE *| 02359 |* *| 02360 |* Returns: *| 02361 |* NONE *| 02362 |* Notes: *| 02363 |* *| 02364 |* From interp 99: *| 02365 |* If two or more generic interfaces that are accessible in a scoping *| 02366 |* unit have the same name, ..., they are interpreted as a single *| 02367 |* generic interface. *| 02368 |* *| 02369 |* *| 02370 \******************************************************************************/ 02371 02372 void parse_interface_stmt (void) 02373 02374 { 02375 int attr_idx = NULL_IDX; 02376 id_str_type name; 02377 int stmt_number; 02378 02379 02380 TRACE (Func_Entry, "parse_interface_stmt", NULL); 02381 02382 stmt_number = statement_number; 02383 02384 if (LA_CH_VALUE != EOS) { 02385 02386 if (parse_generic_spec()) { 02387 attr_idx = generic_spec_semantics(); 02388 02389 /* Even if this interface came from a module, it is being extended */ 02390 /* in this program unit, so it is not the exact same as the one */ 02391 /* from the module. */ 02392 02393 AT_MODULE_IDX(attr_idx) = NULL_IDX; 02394 02395 /* CIF usage record is generated by generic_spec_semantics */ 02396 02397 if (LA_CH_VALUE != EOS) { 02398 parse_err_flush(Find_EOS, EOS_STR); 02399 } 02400 else { 02401 02402 if ((cif_flags & MISC_RECS) && attr_idx != NULL_IDX) { 02403 02404 if (TOKEN_VALUE(token) == Tok_Id) { 02405 cif_stmt_type_rec(TRUE, 02406 CIF_Interface_Generic_Stmt, 02407 stmt_number); 02408 } 02409 else if (TOKEN_VALUE(token) == Tok_Op_Assign) { 02410 cif_stmt_type_rec(TRUE, 02411 CIF_Interface_Assignment_Stmt, 02412 stmt_number); 02413 } 02414 else { 02415 cif_stmt_type_rec(TRUE, 02416 CIF_Interface_Operator_Stmt, 02417 stmt_number); 02418 } 02419 } 02420 } 02421 } 02422 else { 02423 CREATE_ID(name, "unnamed interface", 17); 02424 attr_idx = ntr_local_attr_list(name.string, 02425 17, 02426 TOKEN_LINE(token), 02427 TOKEN_COLUMN(token)); 02428 AT_OBJ_CLASS(attr_idx) = Interface; 02429 ATI_UNNAMED_INTERFACE(attr_idx) = TRUE; 02430 AT_DCL_ERR(attr_idx) = TRUE; 02431 parse_err_flush(Find_EOS, NULL); 02432 } 02433 } 02434 else { 02435 02436 /* Generate an unnamed attr entry for this interface. It is used */ 02437 /* for collapsing the individual interface bodies at one time. */ 02438 02439 CREATE_ID(name, "unnamed interface", 17); 02440 attr_idx = ntr_local_attr_list(name.string, 02441 17, 02442 TOKEN_LINE(token), 02443 TOKEN_COLUMN(token)); 02444 AT_OBJ_CLASS(attr_idx) = Interface; 02445 ATI_UNNAMED_INTERFACE(attr_idx) = TRUE; 02446 02447 if (cif_flags & MISC_RECS) { 02448 cif_stmt_type_rec(TRUE, CIF_Interface_Explicit_Stmt, stmt_number); 02449 } 02450 } 02451 02452 if ((STMT_OUT_OF_ORDER(curr_stmt_category, Interface_Stmt) || 02453 STMT_CANT_BE_IN_BLK(Interface_Stmt, CURR_BLK)) && 02454 iss_blk_stk_err()) { 02455 PUSH_BLK_STK(Interface_Blk); 02456 CURR_BLK_ERR = TRUE; 02457 } 02458 else { 02459 PUSH_BLK_STK(Interface_Blk); 02460 curr_stmt_category = Sub_Func_Stmt_Cat; 02461 } 02462 02463 CURR_BLK_NO_EXEC = TRUE; 02464 02465 /* Save the unnamed interface attr in the blk stack, but not in */ 02466 /* CURR_BLK_NAME. If it is in CURR_BLK_NAME, there are too many */ 02467 /* ways the block stack can get messed up. */ 02468 02469 if (attr_idx != NULL_IDX && ATI_UNNAMED_INTERFACE(attr_idx)) { 02470 BLK_UNNAMED_INTERFACE(blk_stk_idx) = attr_idx; 02471 attr_idx = NULL_IDX; 02472 } 02473 02474 CURR_BLK_NAME = attr_idx; 02475 NEXT_LA_CH; /* Pick up EOS */ 02476 02477 if (cif_flags & BASIC_RECS) { 02478 cif_begin_scope_rec(); 02479 02480 if (attr_idx != NULL_IDX) { 02481 ATI_CIF_SCOPE_ID(attr_idx) = BLK_CIF_SCOPE_ID(blk_stk_idx); 02482 } 02483 else if (BLK_UNNAMED_INTERFACE(blk_stk_idx) != NULL_IDX) { 02484 ATI_CIF_SCOPE_ID(BLK_UNNAMED_INTERFACE(blk_stk_idx)) = 02485 BLK_CIF_SCOPE_ID(blk_stk_idx); 02486 } 02487 } 02488 02489 TRACE (Func_Exit, "parse_interface_stmt", NULL); 02490 02491 return; 02492 02493 } /* parse_interface_stmt */ 02494 02495 02496 /******************************************************************************\ 02497 |* *| 02498 |* Description: *| 02499 |* Parse the NAMELIST statement. BNF is: *| 02500 |* *| 02501 |* NAMELIST /namelist-group-name/ namelist-group-object-list *| 02502 |* [[,] /namelist-group-name/ namelist-group-object-list]... *| 02503 |* *| 02504 |* Input parameters: *| 02505 |* NONE *| 02506 |* *| 02507 |* Output parameters: *| 02508 |* NONE *| 02509 |* *| 02510 |* Returns: *| 02511 |* NONE *| 02512 |* *| 02513 \******************************************************************************/ 02514 02515 void parse_namelist_stmt (void) 02516 02517 { 02518 int attr_idx; 02519 boolean end_grp_list =FALSE; 02520 int grp_attr; 02521 int host_attr_idx; 02522 int host_name_idx; 02523 int name_idx; 02524 int sn_idx; 02525 02526 02527 TRACE (Func_Entry, "parse_namelist_stmt", NULL); 02528 02529 if ((STMT_OUT_OF_ORDER(curr_stmt_category, Namelist_Stmt) || 02530 STMT_CANT_BE_IN_BLK(Namelist_Stmt, CURR_BLK)) && iss_blk_stk_err()) { 02531 /* Issued block stack error - intentionally left blank */ 02532 } 02533 else if (curr_stmt_category < Declaration_Stmt_Cat) { 02534 curr_stmt_category = Declaration_Stmt_Cat; 02535 } 02536 else if (curr_stmt_category == Executable_Stmt_Cat) { 02537 PRINTMSG(stmt_start_line, 265, Ansi, stmt_start_col); 02538 } 02539 02540 if (LA_CH_VALUE != SLASH) { 02541 parse_err_flush (Find_EOS,"/"); 02542 } 02543 02544 /* Will always have a Slash or an EOS at this point. */ 02545 while (LA_CH_VALUE == SLASH) { 02546 NEXT_LA_CH; /* Consume the slash */ 02547 02548 if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 02549 parse_err_flush (Find_EOS, "namelist-group-name"); 02550 goto EXIT; 02551 } 02552 02553 /* At this point have a namelist group name. Enter it into the */ 02554 /* symbol table. */ 02555 02556 grp_attr = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx); 02557 02558 if (grp_attr == NULL_IDX) { 02559 grp_attr = ntr_sym_tbl(&token, name_idx); 02560 LN_DEF_LOC(name_idx) = TRUE; 02561 AT_OBJ_CLASS(grp_attr) = Namelist_Grp; 02562 } 02563 else if (!fnd_semantic_err(Obj_Namelist_Grp, 02564 TOKEN_LINE(token), 02565 TOKEN_COLUMN(token), 02566 grp_attr, 02567 TRUE)) { 02568 02569 if (AT_REFERENCED(grp_attr) == Referenced) { 02570 PRINTMSG(TOKEN_LINE(token), 39, Error, TOKEN_COLUMN(token), 02571 AT_OBJ_NAME_PTR(grp_attr)); 02572 } 02573 02574 AT_OBJ_CLASS(grp_attr) = Namelist_Grp; 02575 } 02576 else { 02577 parse_err_flush(Find_EOS, NULL); 02578 goto EXIT; 02579 } 02580 02581 if ((cif_flags & XREF_RECS) != 0) { 02582 cif_usage_rec(grp_attr, 02583 AT_Tbl_Idx, 02584 TOKEN_LINE(token), 02585 TOKEN_COLUMN(token), 02586 CIF_Symbol_Declaration); 02587 } 02588 02589 if (LA_CH_VALUE != SLASH) { 02590 parse_err_flush (Find_EOS, "/"); 02591 goto EXIT; 02592 } 02593 02594 /* Have a matching set of slashes, now parse group object list */ 02595 NEXT_LA_CH; /* Consume slash */ 02596 02597 while (!end_grp_list) { 02598 02599 if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 02600 parse_err_flush(Find_EOS, "namelist-group-object"); 02601 AT_DCL_ERR(grp_attr) = TRUE; 02602 goto EXIT; 02603 } 02604 02605 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), 02606 &name_idx); 02607 02608 if (attr_idx == NULL_IDX) { /* search host sym tab */ 02609 host_attr_idx = srch_host_sym_tbl(TOKEN_STR(token), 02610 TOKEN_LEN(token), 02611 &host_name_idx, 02612 FALSE); /* Don't srch INTRINSIC*/ 02613 02614 /* Because of forward referencing - NOT_VISIBLE gets checked when */ 02615 /* the rest of the namelist objects semantics are done. */ 02616 02617 if (host_attr_idx != NULL_IDX) { 02618 attr_idx = ntr_host_in_sym_tbl(&token, name_idx, 02619 host_attr_idx, host_name_idx, 02620 TRUE); 02621 } 02622 else { 02623 attr_idx = ntr_sym_tbl(&token, name_idx); 02624 SET_IMPL_TYPE(attr_idx); 02625 } 02626 } 02627 02628 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 02629 ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE; 02630 } 02631 02632 02633 if ((cif_flags & XREF_RECS) != 0) { 02634 cif_usage_rec(attr_idx, 02635 AT_Tbl_Idx, 02636 TOKEN_LINE(token), 02637 TOKEN_COLUMN(token), 02638 CIF_Symbol_Declaration); 02639 } 02640 02641 AT_NAMELIST_OBJ(attr_idx) = TRUE; 02642 02643 NTR_SN_TBL(sn_idx); 02644 02645 SN_ATTR_IDX(sn_idx) = attr_idx; 02646 SN_NAME_LEN(sn_idx) = AT_NAME_LEN(attr_idx); 02647 SN_NAME_IDX(sn_idx) = AT_NAME_IDX(attr_idx); 02648 SN_LINE_NUM(sn_idx) = TOKEN_LINE(token); 02649 SN_COLUMN_NUM(sn_idx) = TOKEN_COLUMN(token); 02650 02651 if (ATN_FIRST_NAMELIST_IDX(grp_attr) == NULL_IDX) { 02652 ATN_FIRST_NAMELIST_IDX(grp_attr) = sn_idx; 02653 } 02654 else { 02655 SN_SIBLING_LINK(ATN_LAST_NAMELIST_IDX(grp_attr)) = sn_idx; 02656 } 02657 02658 ATN_LAST_NAMELIST_IDX(grp_attr) = sn_idx; 02659 ATN_NUM_NAMELIST(grp_attr) += 1; 02660 02661 if (LA_CH_VALUE != COMMA && 02662 LA_CH_VALUE != SLASH && 02663 LA_CH_VALUE != EOS) { 02664 parse_err_flush(Find_EOS, "/ or, or " EOS_STR); 02665 AT_DCL_ERR(grp_attr) = TRUE; 02666 goto EXIT; 02667 } 02668 02669 /* At this point la will be comma, slash or eos. */ 02670 02671 if (LA_CH_VALUE == COMMA) { 02672 NEXT_LA_CH; 02673 02674 if (LA_CH_VALUE == SLASH) { 02675 /* have start of new group */ 02676 end_grp_list = TRUE; 02677 } 02678 } 02679 else { 02680 end_grp_list = TRUE; 02681 } 02682 } /* while */ 02683 02684 end_grp_list = FALSE; 02685 } /* end while groups*/ 02686 02687 EXIT: 02688 02689 if (LA_CH_VALUE != EOS) { 02690 parse_err_flush(Find_EOS, EOS_STR); 02691 } 02692 02693 NEXT_LA_CH; 02694 02695 TRACE (Func_Exit, "parse_namelist_stmt", NULL); 02696 02697 return; 02698 02699 } /* parse_namelist_stmt */ 02700 02701 /******************************************************************************\ 02702 |* *| 02703 |* Description: *| 02704 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 02705 |* *| 02706 |* Input parameters: *| 02707 |* NONE *| 02708 |* *| 02709 |* Output parameters: *| 02710 |* NONE *| 02711 |* *| 02712 |* Returns: *| 02713 |* NONE *| 02714 |* *| 02715 \******************************************************************************/ 02716 02717 void parse_parameter_stmt (void) 02718 02719 { 02720 int attr_idx; 02721 int column; 02722 int const_column; 02723 int const_line; 02724 expr_arg_type exp_desc; 02725 boolean fnd_attr; 02726 opnd_type init_opnd; 02727 int line; 02728 int name_idx; 02729 02730 02731 TRACE (Func_Entry, "parse_parameter_stmt", NULL); 02732 02733 /* NOTE: CFT77 does allow a PARAMETER stmt to preceed an IMPLICIT */ 02734 /* NONE stmt but there isn't a way to do it without getting */ 02735 /* an error later down the line...the IMPLICIT NONE is */ 02736 /* imposed on the PARAMETER stmt and is therefore typeless */ 02737 /* and an is generated. */ 02738 02739 if (LA_CH_VALUE != LPAREN) { 02740 parse_err_flush(Find_EOS, "("); 02741 goto EXIT; 02742 } 02743 02744 if ((STMT_OUT_OF_ORDER(curr_stmt_category, Parameter_Stmt) || 02745 STMT_CANT_BE_IN_BLK(Parameter_Stmt,CURR_BLK)) && iss_blk_stk_err()) { 02746 /* Block error - intentionally blank */ 02747 } 02748 else if (curr_stmt_category <= Implicit_Stmt_Cat) { 02749 curr_stmt_category = Implicit_Stmt_Cat; 02750 } 02751 else { 02752 curr_stmt_category = Declaration_Stmt_Cat; 02753 } 02754 02755 do { 02756 NEXT_LA_CH; /* Skip first Lparen, and then skips the commas */ 02757 02758 if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 02759 parse_err_flush(Find_Comma_Rparen, "named-constant"); 02760 continue; 02761 } 02762 02763 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx); 02764 fnd_attr = attr_idx; 02765 line = TOKEN_LINE(token); 02766 column = TOKEN_COLUMN(token); 02767 02768 if (attr_idx == NULL_IDX) { 02769 attr_idx = ntr_sym_tbl(&token, name_idx); 02770 LN_DEF_LOC(name_idx) = TRUE; 02771 SET_IMPL_TYPE(attr_idx); 02772 } 02773 else if (AT_REFERENCED(attr_idx) == Char_Rslt_Bound_Ref) { 02774 AT_ATTR_LINK(attr_idx) = NULL_IDX; 02775 LN_DEF_LOC(name_idx) = TRUE; 02776 } 02777 02778 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 02779 ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE; 02780 } 02781 02782 if (LA_CH_VALUE != EQUAL) { 02783 parse_err_flush(Find_Comma_Rparen, "="); 02784 continue; 02785 } 02786 02787 NEXT_LA_CH; /* Skip = */ 02788 const_line = LA_CH_LINE; 02789 const_column = LA_CH_COLUMN; 02790 02791 if (parse_expr(&init_opnd)) { 02792 exp_desc.rank = 0; 02793 expr_mode = Initialization_Expr; 02794 xref_state = CIF_Symbol_Reference; 02795 02796 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 02797 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character && 02798 TYP_CHAR_CLASS(ATD_TYPE_IDX(attr_idx)) == Unknown_Char) { 02799 02800 char_bounds_resolution(attr_idx, 02801 &fnd_attr); 02802 } 02803 02804 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && ATD_ARRAY_IDX(attr_idx)) { 02805 array_bounds_resolution(attr_idx, &fnd_attr); 02806 } 02807 02808 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 02809 02810 if (ATD_ARRAY_IDX(attr_idx)) { 02811 target_array_idx = ATD_ARRAY_IDX(attr_idx); 02812 } 02813 02814 switch (TYP_TYPE(ATD_TYPE_IDX(attr_idx))) { 02815 case Integer: 02816 case Real: 02817 case Complex: 02818 check_type_conversion = TRUE; 02819 target_type_idx = ATD_TYPE_IDX(attr_idx); 02820 break; 02821 02822 case Character: 02823 02824 if (TYP_CHAR_CLASS(ATD_TYPE_IDX(attr_idx)) == Const_Len_Char) { 02825 check_type_conversion = TRUE; 02826 target_type_idx = Character_1; 02827 target_char_len_idx = TYP_IDX(ATD_TYPE_IDX(attr_idx)); 02828 } 02829 break; 02830 } 02831 } 02832 02833 /* set comp_gen_expr to TRUE. This forces the fold of REAL */ 02834 /* constant expressions. When -Oieeeconform is specified, */ 02835 /* the folding of Real and Complex expressions is prevented. */ 02836 02837 comp_gen_expr = TRUE; 02838 02839 if (expr_semantics(&init_opnd, &exp_desc)) { 02840 check_type_conversion = FALSE; 02841 target_array_idx = NULL_IDX; 02842 expr_mode = Regular_Expr; 02843 merge_parameter(fnd_attr, 02844 attr_idx, 02845 line, 02846 column, 02847 &init_opnd, 02848 &exp_desc, 02849 const_line, 02850 const_column); 02851 02852 if ((cif_flags & XREF_RECS) != 0) { 02853 cif_usage_rec(attr_idx, 02854 AT_Tbl_Idx, 02855 line, 02856 column, 02857 CIF_Symbol_Declaration); 02858 } 02859 } 02860 else { 02861 check_type_conversion = FALSE; 02862 target_array_idx = NULL_IDX; 02863 expr_mode = Regular_Expr; 02864 AT_DCL_ERR(attr_idx) = TRUE; 02865 } 02866 02867 /* reset comp_gen_expr to FALSE. end of compiler generated expr */ 02868 comp_gen_expr = FALSE; 02869 } 02870 else { 02871 /* error from parse_expr */ 02872 AT_DCL_ERR(attr_idx) = TRUE; 02873 } 02874 02875 if (LA_CH_VALUE != COMMA && LA_CH_VALUE != RPAREN) { 02876 parse_err_flush(Find_Comma_Rparen, ", or )"); 02877 } 02878 } 02879 while (LA_CH_VALUE == COMMA); 02880 02881 if (LA_CH_VALUE == RPAREN) { 02882 NEXT_LA_CH; 02883 } 02884 02885 EXIT: 02886 02887 NEXT_LA_CH; /* Pick up EOS */ 02888 02889 TRACE (Func_Exit, "parse_parameter_stmt", NULL); 02890 02891 return; 02892 02893 } /* parse_parameter_stmt */ 02894 02895 /******************************************************************************\ 02896 |* *| 02897 |* Description: *| 02898 |* BNF SEQUENCE *| 02899 |* *| 02900 |* Input parameters: *| 02901 |* NONE *| 02902 |* *| 02903 |* Output parameters: *| 02904 |* NONE *| 02905 |* *| 02906 |* Returns: *| 02907 |* NONE *| 02908 |* *| 02909 \******************************************************************************/ 02910 02911 void parse_sequence_stmt (void) 02912 02913 { 02914 TRACE (Func_Entry, "parse_sequence_stmt", NULL); 02915 02916 if (CURR_BLK == Derived_Type_Blk) { 02917 02918 if (LA_CH_VALUE == EOS) { 02919 02920 if (ATT_SEQUENCE_SET(CURR_BLK_NAME)) { 02921 PRINTMSG (TOKEN_LINE(token), 41, Error, 02922 TOKEN_COLUMN(token), "SEQUENCE", 02923 AT_OBJ_NAME_PTR(CURR_BLK_NAME)); 02924 } 02925 02926 if (ATT_FIRST_CPNT_IDX(CURR_BLK_NAME) != NULL_IDX) { 02927 PRINTMSG(TOKEN_LINE(token), 8, Error, TOKEN_COLUMN(token), 02928 "SEQUENCE", AT_OBJ_NAME_PTR(CURR_BLK_NAME)); 02929 } 02930 02931 ATT_SEQUENCE_SET(CURR_BLK_NAME) = TRUE; 02932 } 02933 else { 02934 parse_err_flush(Find_EOS, EOS_STR); 02935 } 02936 } 02937 else { 02938 parse_err_flush(Find_EOS, NULL); 02939 iss_blk_stk_err(); /* Not assignment statement */ 02940 } 02941 02942 NEXT_LA_CH; /* Skip EOS */ 02943 02944 TRACE (Func_Exit, "parse_sequence_stmt", NULL); 02945 02946 return; 02947 02948 } /* parse_sequence_stmt */ 02949 02950 /******************************************************************************\ 02951 |* *| 02952 |* Description: *| 02953 |* This parses a statement function. Unlike other stmt parsers, this *| 02954 |* routine is called from parse_assignment_stmt, not from the stmt table.*| 02955 |* At entry the name of the statement function has been entered into the.*| 02956 |* attr table. *| 02957 |* *| 02958 |* Input parameters: *| 02959 |* NONE *| 02960 |* *| 02961 |* Output parameters: *| 02962 |* NONE *| 02963 |* *| 02964 |* Returns: *| 02965 |* NONE *| 02966 |* *| 02967 \******************************************************************************/ 02968 02969 void parse_stmt_func_stmt(int sf_attr_idx, 02970 int sf_name_idx) 02971 02972 { 02973 int attr_idx; 02974 int count; 02975 int first_idx; 02976 boolean found_end = FALSE; 02977 int i; 02978 int name_idx; 02979 int new_attr_idx; 02980 opnd_type opnd; 02981 int sn_idx; 02982 int sn_attr_idx; 02983 int stmt_number; 02984 02985 02986 TRACE (Func_Entry, "parse_stmt_func_stmt", NULL); 02987 02988 stmt_type = Stmt_Func_Stmt; 02989 stmt_number = statement_number; 02990 02991 if ((STMT_OUT_OF_ORDER(curr_stmt_category, Stmt_Func_Stmt) || 02992 STMT_CANT_BE_IN_BLK(Stmt_Func_Stmt, CURR_BLK)) && iss_blk_stk_err()) { 02993 /* Issued block error - intentionally left blank */ 02994 } 02995 else { 02996 curr_stmt_category = Declaration_Stmt_Cat; 02997 } 02998 02999 if (!fnd_semantic_err(Obj_Stmt_Func, 03000 TOKEN_LINE(token), 03001 TOKEN_COLUMN(token), 03002 sf_attr_idx, 03003 TRUE)) { 03004 03005 if (AT_REFERENCED(sf_attr_idx) == Char_Rslt_Bound_Ref) { 03006 AT_ATTR_LINK(sf_attr_idx) = NULL_IDX; 03007 LN_DEF_LOC(sf_name_idx) = TRUE; 03008 } 03009 03010 /* MUST be a data object - has been implicitly typed already */ 03011 03012 AT_OBJ_CLASS(sf_attr_idx) = Stmt_Func; 03013 LN_DEF_LOC(sf_name_idx) = TRUE; 03014 } 03015 else { 03016 CREATE_ERR_ATTR(sf_attr_idx, 03017 TOKEN_LINE(token), 03018 TOKEN_COLUMN(token), 03019 Stmt_Func); 03020 } 03021 03022 if ((cif_flags & XREF_RECS) != 0) { 03023 cif_usage_rec(sf_attr_idx, 03024 AT_Tbl_Idx, 03025 TOKEN_LINE(token), 03026 TOKEN_COLUMN(token), 03027 CIF_Symbol_Declaration); 03028 } 03029 03030 NEXT_LA_CH; /* Must be Lparen to be here - Consume Lparen */ 03031 03032 if (LA_CH_VALUE == RPAREN) { 03033 goto DONE; 03034 } 03035 03036 do { 03037 03038 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 03039 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx); 03040 03041 if (attr_idx == NULL_IDX) { 03042 attr_idx = ntr_sym_tbl(&token, name_idx); 03043 LN_DEF_LOC(name_idx) = TRUE; 03044 AT_OBJ_CLASS(attr_idx) = Data_Obj; 03045 ATD_CLASS(attr_idx) = Dummy_Argument; 03046 SET_IMPL_TYPE(attr_idx); 03047 AT_IS_DARG(attr_idx) = TRUE; 03048 ATD_SF_DARG(attr_idx) = TRUE; 03049 } 03050 else { 03051 03052 if (fnd_semantic_err(Obj_Sf_Darg, 03053 TOKEN_LINE(token), 03054 TOKEN_COLUMN(token), 03055 attr_idx, 03056 TRUE)) { 03057 03058 AT_DCL_ERR(sf_attr_idx) = TRUE; 03059 } 03060 03061 NTR_ATTR_TBL(new_attr_idx); 03062 COPY_COMMON_ATTR_INFO(attr_idx, new_attr_idx, Data_Obj); 03063 AT_OBJ_CLASS(new_attr_idx) = Data_Obj; 03064 ATD_CLASS(new_attr_idx) = Dummy_Argument; 03065 AT_IS_DARG(new_attr_idx) = TRUE; 03066 AT_IS_INTRIN(new_attr_idx) = FALSE; 03067 AT_ELEMENTAL_INTRIN(new_attr_idx) = FALSE; 03068 ATD_SF_DARG(new_attr_idx) = TRUE; 03069 03070 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 03071 AT_TYPED(new_attr_idx) = AT_TYPED(attr_idx); 03072 ATD_TYPE_IDX(new_attr_idx) = ATD_TYPE_IDX(attr_idx); 03073 } 03074 else { 03075 SET_IMPL_TYPE(new_attr_idx); 03076 } 03077 ATD_SF_LINK(new_attr_idx) = attr_idx; 03078 LN_ATTR_IDX(name_idx) = new_attr_idx; 03079 attr_idx = new_attr_idx; 03080 } 03081 03082 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 03083 ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE; 03084 } 03085 03086 03087 if ((cif_flags & XREF_RECS) != 0) { 03088 cif_usage_rec(attr_idx, 03089 AT_Tbl_Idx, 03090 TOKEN_LINE(token), 03091 TOKEN_COLUMN(token), 03092 CIF_Symbol_Is_Dummy_Arg); 03093 } 03094 03095 /* Enter into secondary name table */ 03096 03097 sn_attr_idx = srch_kwd_name(TOKEN_STR(token), 03098 TOKEN_LEN(token), 03099 sf_attr_idx, 03100 &sn_idx); 03101 03102 if (sn_attr_idx != NULL_IDX) { /* Have duplicate dummy arg */ 03103 PRINTMSG(TOKEN_LINE(token), 10, Error, TOKEN_COLUMN(token), 03104 TOKEN_STR(token)); 03105 AT_DCL_ERR(sf_attr_idx) = TRUE; 03106 } 03107 else { 03108 NTR_SN_TBL(sn_idx); 03109 SN_ATTR_IDX(sn_idx) = attr_idx; 03110 SN_NAME_LEN(sn_idx) = AT_NAME_LEN(attr_idx); 03111 SN_NAME_IDX(sn_idx) = AT_NAME_IDX(attr_idx); 03112 SN_LINE_NUM(sn_idx) = TOKEN_LINE(token); 03113 SN_COLUMN_NUM(sn_idx) = TOKEN_COLUMN(token); 03114 03115 if (ATP_FIRST_IDX(sf_attr_idx) == NULL_IDX) { 03116 ATP_FIRST_IDX(sf_attr_idx) = sn_idx; 03117 } 03118 ATP_NUM_DARGS(sf_attr_idx) += 1; 03119 } 03120 } 03121 else { 03122 03123 AT_DCL_ERR(sf_attr_idx) = TRUE; 03124 03125 if (!parse_err_flush(Find_Comma_Rparen, "dummy-arg-name")) { 03126 goto EXIT; 03127 } 03128 } 03129 03130 if (LA_CH_VALUE != RPAREN && LA_CH_VALUE != COMMA) { 03131 03132 AT_DCL_ERR(sf_attr_idx) = TRUE; 03133 03134 if (!parse_err_flush(Find_Comma_Rparen, ", or )")) { 03135 goto EXIT; 03136 } 03137 } 03138 03139 if (LA_CH_VALUE == COMMA) { 03140 NEXT_LA_CH; 03141 } 03142 else { 03143 found_end = TRUE; 03144 } 03145 03146 } /* end do while */ 03147 while (!found_end); 03148 03149 DONE: 03150 03151 NEXT_LA_CH; /* Consume RPAREN */ 03152 03153 if (matched_specific_token(Tok_Punct_Eq, Tok_Class_Punct)) { 03154 expr_mode = Stmt_Func_Expr; 03155 03156 if (parse_expr(&opnd)) { 03157 ATS_SF_FLD(sf_attr_idx) = OPND_FLD(opnd); 03158 ATS_SF_IDX(sf_attr_idx) = OPND_IDX(opnd); 03159 } 03160 else { 03161 AT_DCL_ERR(sf_attr_idx) = TRUE; 03162 } 03163 03164 expr_mode = Regular_Expr; 03165 03166 if (cif_flags & MISC_RECS) { 03167 cif_stmt_type_rec(TRUE, CIF_Statement_Function_Stmt, stmt_number); 03168 } 03169 } 03170 else { 03171 AT_DCL_ERR(sf_attr_idx) = TRUE; 03172 parse_err_flush(Find_EOS, "="); 03173 } 03174 03175 first_idx = ATP_FIRST_IDX(sf_attr_idx); 03176 count = ATP_NUM_DARGS(sf_attr_idx); 03177 03178 /* Remove the dargs from the local name table */ 03179 03180 for (i = first_idx; i < (first_idx + count); i++) { 03181 attr_idx = SN_ATTR_IDX(i); 03182 srch_sym_tbl(AT_OBJ_NAME_PTR(attr_idx), AT_NAME_LEN(attr_idx), &name_idx); 03183 03184 if (ATD_SF_LINK(attr_idx) != NULL_IDX) { 03185 LN_ATTR_IDX(name_idx) = ATD_SF_LINK(attr_idx); 03186 } 03187 else { 03188 remove_ln_ntry(name_idx); 03189 } 03190 } 03191 03192 if (LA_CH_VALUE != EOS) { 03193 AT_DCL_ERR(sf_attr_idx) = TRUE; 03194 parse_err_flush(Find_EOS, EOS_STR); 03195 } 03196 03197 EXIT: 03198 03199 TRACE (Func_Exit, "parse_stmt_func_stmt", NULL); 03200 03201 return; 03202 03203 } /* parse_stmt_func_stmt */ 03204 03205 /******************************************************************************\ 03206 |* *| 03207 |* Description: *| 03208 |* Parses the type declaration statement *| 03209 |* *| 03210 |* BNF type_spec[[,attr_spec]...::]entity-decl-list *| 03211 |* type-spec is INTEGER [kind-selector] *| 03212 |* REAL [kind-selector] *| 03213 |* DOUBLE PRECISION *| 03214 |* COMPLEX [kind-selector] *| 03215 |* CHARACTER [char-selector] *| 03216 |* LOGICAL [kind-selector] *| 03217 |* TYPE (type-name) *| 03218 |* BYTE *| 03219 |* entity_dcl_list is *| 03220 |* object-name[(array-spec)][*char-length][=initialization-expr] *| 03221 |* attr_spec is done in parse_attr_spec *| 03222 |* *| 03223 \******************************************************************************/ 03224 03225 void parse_type_dcl_stmt (void) 03226 03227 { 03228 int array_idx; 03229 int attr_idx; 03230 long attr_list = 0; 03231 int buf_idx; 03232 boolean check_char_comma; 03233 boolean GT_encountered = FALSE; 03234 boolean chk_semantics; 03235 expr_arg_type exp_desc; 03236 boolean found_colon; 03237 boolean found_end; 03238 boolean has_parameter = FALSE; 03239 int id_column; 03240 int id_line; 03241 int il_idx; 03242 int init_ir_idx; 03243 opnd_type init_opnd; 03244 int name_idx; 03245 boolean need_new_array; 03246 int new_array_idx; 03247 int new_pe_array_idx = NULL_IDX; 03248 boolean new_attr; 03249 int old_array_idx; 03250 int pe_array_idx = NULL_IDX; 03251 boolean possible_func; 03252 int save_column; 03253 int save_line; 03254 int stmt_number; 03255 int stmt_num; 03256 boolean type_err; 03257 int type_idx; 03258 int usage_code; 03259 03260 03261 TRACE (Func_Entry, "parse_type_dcl_stmt", NULL); 03262 03263 colon_recovery = TRUE; /* Can recover to :: */ 03264 stmt_number = statement_number; 03265 03266 if (TOKEN_VALUE(token) == Tok_Kwd_Type && LA_CH_VALUE != LPAREN) { 03267 03268 if (LA_CH_VALUE == EOS) { 03269 03270 /* Expecting either a TYPE statement or a derived type statement. */ 03271 03272 parse_err_flush(Find_EOS, "( or , or :: or type-name"); 03273 NEXT_LA_CH; /* Skip EOS */ 03274 goto EXIT; 03275 } 03276 03277 /* Allows for nested derived types. The block stack will allow for */ 03278 /* this. Context/block checking catches and issues the error. */ 03279 03280 parse_derived_type_stmt(); 03281 03282 if (cif_flags & MISC_RECS) { 03283 cif_stmt_type_rec(TRUE, CIF_Type_Stmt, stmt_number); 03284 } 03285 03286 goto EXIT; 03287 } 03288 03289 if (CURR_BLK == Derived_Type_Blk) { 03290 stmt_type = Cpnt_Decl_Stmt; 03291 parse_cpnt_dcl_stmt(); 03292 goto EXIT; 03293 } 03294 03295 if (curr_stmt_category == Sub_Func_Stmt_Cat) { 03296 03297 /* In contains or Interface block - must be function statement. */ 03298 /* DO NOT end curr_stmt_category == Init_Stmt_Cat thru here, because it */ 03299 /* may not be a FUNCTION statement. The following is a legal type dcl */ 03300 /* stmt: INTEGER FUNCTION A(10) in fixed format. */ 03301 03302 CLEAR_ATTR_NTRY(AT_WORK_IDX); /* Used for AT_TYPED */ 03303 parse_typed_function_stmt(); 03304 goto EXIT; 03305 } 03306 03307 check_char_comma = (TOKEN_VALUE(token) == Tok_Kwd_Character && 03308 LA_CH_VALUE == STAR); 03309 found_colon = FALSE; 03310 found_end = FALSE; 03311 type_err = !parse_type_spec(TRUE); 03312 AT_DCL_ERR(AT_WORK_IDX) = type_err; 03313 type_idx = ATD_TYPE_IDX(AT_WORK_IDX); 03314 array_idx = NULL_IDX; 03315 03316 03317 if (LA_CH_VALUE == COMMA && (!check_char_comma || stmt_has_double_colon())) { 03318 03319 if ((STMT_OUT_OF_ORDER(curr_stmt_category, Type_Decl_Stmt) || 03320 STMT_CANT_BE_IN_BLK(Type_Decl_Stmt, CURR_BLK)) && iss_blk_stk_err()){ 03321 /* Block error - intentionally left blank */ 03322 } 03323 else { 03324 curr_stmt_category = Declaration_Stmt_Cat; 03325 } 03326 03327 /* Check that type is defined before it is used. */ 03328 03329 if (TYP_TYPE(type_idx) == Structure && 03330 !AT_DEFINED(TYP_IDX(type_idx)) && !AT_DCL_ERR(TYP_IDX(type_idx))) { 03331 issue_undefined_type_msg(TYP_IDX(type_idx), 03332 TOKEN_LINE(token), 03333 TOKEN_COLUMN(token)); 03334 } 03335 03336 /* Attr_list contains a bit vector of which attrs are specified. */ 03337 /* array_idx contains the index of the array spec, if DIMESION is */ 03338 /* specified. AT_WORK_IDX does not get updated with it, because */ 03339 /* it has to be updated later in case the variable is followed */ 03340 /* by its own dimension. ie: REAL,DIMENSION(5),POINTER :: B(:) */ 03341 /* is legal. Dimension cannot be merged until B is processed. */ 03342 03343 new_intent = Intent_Unseen; 03344 attr_list = parse_attr_spec(&array_idx, &has_parameter); 03345 03346 # ifdef COARRAY_FORTRAN 03347 if (AT_OBJ_CLASS(AT_WORK_IDX) == Data_Obj) { 03348 pe_array_idx = ATD_PE_ARRAY_IDX(AT_WORK_IDX); 03349 } 03350 # endif 03351 found_colon = TRUE; 03352 colon_recovery = FALSE; /* Past :: */ 03353 } 03354 else { /* Not followed by a COMMA or CHARACTER*8, */ 03355 colon_recovery = FALSE; /* No error recovery attempted before :: */ 03356 03357 if (curr_stmt_category == Init_Stmt_Cat) { 03358 03359 /* Check to see if this is a FUNCTION statement. Have to go as */ 03360 /* far as the dummy arg list, because the following is a legal */ 03361 /* type dcl statement: INTEGER FUNCTION A(10) */ 03362 03363 save_line = LA_CH_LINE; 03364 save_column = LA_CH_COLUMN; 03365 buf_idx = LA_CH_BUF_IDX; 03366 stmt_num = LA_CH_STMT_NUM; 03367 possible_func = TRUE; 03368 03369 while (MATCHED_TOKEN_CLASS(Tok_Class_Keyword) && possible_func) { 03370 03371 switch(TOKEN_VALUE(token)) { 03372 case Tok_Kwd_Recursive: 03373 case Tok_Kwd_Elemental: 03374 case Tok_Kwd_Pure: 03375 break; 03376 03377 case Tok_Kwd_Function: 03378 03379 if (MATCHED_TOKEN_CLASS(Tok_Class_Id) && LA_CH_VALUE == LPAREN) { 03380 NEXT_LA_CH; 03381 03382 if (LA_CH_VALUE == RPAREN || LA_CH_CLASS == Ch_Class_Letter) { 03383 03384 /* TRUE = type-spec is parsed - type is in AT_WORK_IDX */ 03385 /* Reset to pick up recursive, pure and elemental and */ 03386 /* the function name. This will isolated semantics. */ 03387 03388 reset_lex(buf_idx, stmt_num); 03389 AT_DCL_ERR(AT_WORK_IDX) = SH_ERR_FLG(curr_stmt_sh_idx); 03390 parse_typed_function_stmt(); 03391 goto EXIT; 03392 } 03393 } 03394 possible_func = FALSE; 03395 break; 03396 03397 default: /* Tok_Kwd_Id */ 03398 possible_func = FALSE; 03399 break; 03400 } 03401 } 03402 03403 /* Actually had a match and need to reset and clear attr */ 03404 /* INTEGER FUNCTION A(10) in fixed form would get here. */ 03405 03406 if (LA_CH_LINE != save_line || LA_CH_COLUMN != save_column) { 03407 reset_lex(buf_idx, stmt_num); 03408 } 03409 } 03410 03411 if (LA_CH_VALUE == COMMA) { 03412 NEXT_LA_CH; 03413 } 03414 03415 found_colon = matched_specific_token(Tok_Punct_Colon_Colon, 03416 Tok_Class_Punct); 03417 03418 if ((STMT_OUT_OF_ORDER(curr_stmt_category, Type_Decl_Stmt) || 03419 STMT_CANT_BE_IN_BLK(Type_Decl_Stmt, CURR_BLK)) && iss_blk_stk_err()){ 03420 /* Block error - intentionally left blank */ 03421 } 03422 else { 03423 curr_stmt_category = Declaration_Stmt_Cat; 03424 } 03425 03426 if (TYP_TYPE(type_idx) == Structure && !AT_DEFINED(TYP_IDX(type_idx)) && 03427 !AT_DCL_ERR(TYP_IDX(type_idx))) { 03428 issue_undefined_type_msg(TYP_IDX(type_idx), 03429 AT_DEF_LINE(TYP_IDX(type_idx)), 03430 AT_DEF_COLUMN(TYP_IDX(type_idx))); 03431 } 03432 } 03433 03434 AT_DCL_ERR(AT_WORK_IDX) = SH_ERR_FLG(curr_stmt_sh_idx); 03435 03436 do { 03437 if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 03438 found_end = !parse_err_flush(Find_Comma, "object-name"); 03439 NEXT_LA_CH; 03440 continue; 03441 } 03442 03443 type_idx = ATD_TYPE_IDX(AT_WORK_IDX); 03444 attr_idx = srch_sym_tbl(TOKEN_STR(token), 03445 TOKEN_LEN(token), &name_idx); 03446 id_line = TOKEN_LINE(token); 03447 id_column = TOKEN_COLUMN(token); 03448 new_attr = FALSE; 03449 new_array_idx = array_idx; 03450 new_pe_array_idx = pe_array_idx; 03451 03452 /* If the type is assumed size character, we cannot share array bounds */ 03453 /* because each object may assume a different size upon entry. */ 03454 03455 need_new_array = (TYP_TYPE(type_idx) == Character && 03456 TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char); 03457 03458 if (attr_idx == NULL_IDX) { 03459 attr_idx = ntr_sym_tbl(&token, name_idx); 03460 LN_DEF_LOC(name_idx) = TRUE; 03461 new_attr = TRUE; 03462 AT_NAME_LEN(AT_WORK_IDX) = AT_NAME_LEN(attr_idx); 03463 AT_NAME_IDX(AT_WORK_IDX) = AT_NAME_IDX(attr_idx); 03464 AT_DEF_LINE(AT_WORK_IDX) = AT_DEF_LINE(attr_idx); 03465 AT_DEF_COLUMN(AT_WORK_IDX) = AT_DEF_COLUMN(attr_idx); 03466 COPY_ATTR_NTRY(attr_idx, AT_WORK_IDX); 03467 AT_CIF_SYMBOL_ID(attr_idx) = 0; 03468 03469 if (type_err) { 03470 SET_IMPL_TYPE(attr_idx); 03471 } 03472 } 03473 else if (AT_REFERENCED(attr_idx) == Char_Rslt_Bound_Ref) { 03474 AT_ATTR_LINK(attr_idx) = NULL_IDX; 03475 LN_DEF_LOC(name_idx) = TRUE; 03476 } 03477 03478 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 03479 ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE; 03480 } 03481 03482 /* Have to merge the intrinsic now, because the INTRINSIC scope has to */ 03483 /* be searched and the INTRINSIC attr copied down. Then all the other */ 03484 /* things declared on this line, are added to this the attr. Check */ 03485 /* semantics if this isn't a new attr. If this is an INTRINSIC subrtn */ 03486 /* the error will be issued from merge_intrinsic whether other */ 03487 /* semantics checking is done or not. */ 03488 03489 if (attr_list & (1 << Intrinsic_Attr)) { 03490 merge_intrinsic(!new_attr, id_line, id_column, attr_idx); 03491 } 03492 03493 /* Always have to merge_external, because it has to be switched to a */ 03494 /* program unit. Do semantic checking if this isn't a new attr. */ 03495 03496 if (attr_list & (1 << External_Attr)) { 03497 merge_external(!new_attr, id_line, id_column, attr_idx); 03498 } 03499 03500 if (LA_CH_VALUE == LPAREN) { 03501 03502 /* If LA_CH is left paren, then a dimension spec is specified on */ 03503 /* the variable name. This overrides the specification on the */ 03504 /* dimension attribute. */ 03505 03506 new_array_idx = parse_array_spec(attr_idx); 03507 need_new_array = FALSE; 03508 } 03509 03510 # ifdef COARRAY_FORTRAN 03511 03512 if (LA_CH_VALUE == LBRKT && cmd_line_flags.co_array_fortran) { 03513 new_pe_array_idx = parse_pe_array_spec(attr_idx); 03514 } 03515 # endif 03516 03517 if (LA_CH_VALUE == STAR) { /* Pick up char len. LEN = not allowed here */ 03518 03519 /* We are not parsing the character* part of the line, so this */ 03520 /* is not the length_selector. It is the char-length on the name */ 03521 03522 parse_length_selector(attr_idx, FALSE, FALSE); 03523 03524 if (TYP_TYPE(type_idx) == Character) { 03525 TYP_DESC(TYP_WORK_IDX) = TYP_DESC(type_idx); 03526 TYP_DCL_VALUE(TYP_WORK_IDX) = TYP_DCL_VALUE(type_idx); 03527 type_idx = ntr_type_tbl(); 03528 03529 if (TYP_CHAR_CLASS(type_idx) != Assumed_Size_Char) { 03530 need_new_array = FALSE; 03531 } 03532 03533 if (new_attr) { 03534 switch (AT_OBJ_CLASS(attr_idx)) { 03535 case Data_Obj: 03536 case Interface: 03537 ATD_TYPE_IDX(attr_idx) = type_idx; 03538 break; 03539 03540 case Pgm_Unit: 03541 ATD_TYPE_IDX(ATP_RSLT_IDX(attr_idx)) = type_idx; 03542 break; 03543 } 03544 } 03545 } 03546 else { /* This must be a CHARACTER stmt to have * length. */ 03547 PRINTMSG(TOKEN_LINE(token), 192, Error, TOKEN_COLUMN(token)); 03548 AT_DCL_ERR(attr_idx) = TRUE; 03549 } 03550 03551 /* Have a different character length than the one specified on the */ 03552 /* CHARACTER component statement. (ie: CHARACTER*(2) :: A*(10),B) */ 03553 /* If this is an array, it may need a seperate bounds table entry if */ 03554 /* this is a shared array entry. The stride multiplier is kept in */ 03555 /* the bounds table and is dependent on type. Therefore, if two */ 03556 /* items have seperate types, they must have seperate bounds entries.*/ 03557 /* Ex: CHARACTER*(2), DIMENSION(100) :: A*(10), B ! A and B need */ 03558 /* seperate bounds entries. */ 03559 /* CHARACTER*(2), DIMENSION(100) :: A(20)*(10), B ! They */ 03560 /* already have seperate bounds entries, because */ 03561 /* they have seperate dimensions. */ 03562 /* CHARACTER*(2), DIMENSION(100) :: A,B ! They have the same */ 03563 /* type, so they can share a bound entry. */ 03564 03565 if (new_array_idx != NULL_IDX && new_array_idx == array_idx && 03566 BD_ARRAY_CLASS(new_array_idx) != Deferred_Shape) { 03567 old_array_idx = new_array_idx; 03568 new_array_idx = reserve_array_ntry(BD_RANK(old_array_idx)); 03569 COPY_BD_NTRY(new_array_idx, old_array_idx); 03570 new_array_idx = ntr_array_in_bd_tbl(new_array_idx); 03571 } 03572 } 03573 03574 /* Always have to merge in the type if it is character, because the */ 03575 /* length may have referenced, the thing being declared. */ 03576 03577 if (!new_attr || TYP_TYPE(type_idx) == Character) { 03578 03579 if (new_attr) { 03580 03581 if (AT_OBJ_CLASS(attr_idx) == Data_Obj || 03582 AT_OBJ_CLASS(attr_idx) == Interface) { 03583 AT_TYPED(attr_idx) = FALSE; 03584 } 03585 else if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit) { 03586 AT_TYPED(ATP_RSLT_IDX(attr_idx)) = FALSE; 03587 } 03588 } 03589 03590 merge_type(attr_idx, 03591 type_idx, 03592 id_line, 03593 id_column); 03594 } 03595 03596 03597 /* Always have to merge in dimension, even if it's a new attribute, */ 03598 /* because the dimension may not semantically agree with the type. */ 03599 03600 if (new_array_idx != NULL_IDX) { 03601 03602 if (need_new_array && BD_ARRAY_CLASS(array_idx) != Deferred_Shape) { 03603 03604 /* This cannot share a bounds entry, because the type is *(*), */ 03605 /* which means that at execution time, each object may have a */ 03606 /* different type, so create a new bd idx to be used. */ 03607 /* Deferred shape array entries are allowed to share. */ 03608 03609 new_array_idx = reserve_array_ntry(BD_RANK(array_idx)); 03610 COPY_BD_NTRY(new_array_idx, array_idx); 03611 new_array_idx = ntr_array_in_bd_tbl(new_array_idx); 03612 } 03613 03614 merge_dimension(attr_idx, id_line, id_column, new_array_idx); 03615 } 03616 03617 if (attr_list && !new_attr) { 03618 03619 if (attr_list & (1 << Allocatable_Attr)) { 03620 merge_allocatable(TRUE, id_line, id_column, attr_idx); 03621 } 03622 03623 if (attr_list & (1 << Automatic_Attr)) { 03624 merge_automatic(TRUE, id_line, id_column, attr_idx); 03625 } 03626 03627 if (attr_list & (1 << Public_Attr)) { 03628 merge_access(attr_idx, id_line, id_column, Public); 03629 } 03630 else if (attr_list & (1 << Private_Attr)) { 03631 merge_access(attr_idx, id_line, id_column, Private); 03632 } 03633 03634 if (attr_list & (1 << Optional_Attr)) { 03635 merge_optional(TRUE, id_line, id_column, attr_idx); 03636 } 03637 03638 if (attr_list & (1 << Pointer_Attr)) { 03639 merge_pointer(TRUE, id_line, id_column, attr_idx); 03640 } 03641 03642 if (attr_list & (1 << Save_Attr)) { 03643 merge_save(TRUE, id_line, id_column, attr_idx); 03644 } 03645 03646 if (attr_list & (1 << Target_Attr)) { 03647 merge_target(TRUE, id_line, id_column, attr_idx); 03648 } 03649 03650 if (attr_list & (1 << Volatile_Attr)) { 03651 merge_volatile(TRUE, id_line, id_column, attr_idx); 03652 } 03653 03654 if (attr_list & (1 << Intent_Attr)) { 03655 merge_intent(TRUE, id_line, id_column, attr_idx); 03656 } 03657 } 03658 03659 if ((new_pe_array_idx != NULL_IDX) && 03660 (!new_attr || (!(attr_list & (1 << Co_Array_Attr))))) { 03661 merge_co_array(TRUE, id_line, id_column, attr_idx,new_pe_array_idx); 03662 } 03663 03664 usage_code = CIF_Symbol_Declaration; 03665 03666 if (LA_CH_VALUE == SLASH) { 03667 PRINTMSG(LA_CH_LINE, 1662, Ansi, LA_CH_COLUMN); 03668 03669 if (has_parameter) { 03670 PRINTMSG(LA_CH_LINE, 1663, Error, LA_CH_COLUMN); 03671 } 03672 NEXT_LA_CH; 03673 03674 if (merge_data(TRUE, id_line, id_column, attr_idx)) { 03675 03676 if (SH_STMT_TYPE(curr_stmt_sh_idx) == Type_Decl_Stmt) { 03677 SH_STMT_TYPE(curr_stmt_sh_idx) = Data_Stmt; 03678 SH_COMPILER_GEN(curr_stmt_sh_idx) = TRUE; 03679 SH_GLB_LINE(curr_stmt_sh_idx) = id_line; 03680 SH_COL_NUM(curr_stmt_sh_idx) = id_column; 03681 } 03682 else { 03683 gen_sh(After, Data_Stmt, id_line, id_column, 03684 FALSE, FALSE, TRUE); 03685 } 03686 03687 stmt_type = Data_Stmt; 03688 03689 NTR_IR_TBL(init_ir_idx); 03690 SH_IR_IDX(curr_stmt_sh_idx) = init_ir_idx; 03691 03692 IR_OPR(init_ir_idx) = Init_Opr; 03693 03694 IR_TYPE_IDX(init_ir_idx) = TYPELESS_DEFAULT_TYPE; 03695 IR_LINE_NUM(init_ir_idx) = id_line; 03696 IR_COL_NUM(init_ir_idx) = id_column; 03697 NTR_IR_LIST_TBL(il_idx); 03698 IR_FLD_L(init_ir_idx) = IL_Tbl_Idx; 03699 IR_IDX_L(init_ir_idx) = il_idx; 03700 IR_LIST_CNT_L(init_ir_idx) = 1; 03701 IL_FLD(il_idx) = AT_Tbl_Idx; 03702 IL_IDX(il_idx) = attr_idx; 03703 IL_LINE_NUM(il_idx) = id_line; 03704 IL_COL_NUM(il_idx) = id_column; 03705 03706 parse_initializer(init_ir_idx); 03707 03708 /* The item is being initialized, so flag this by adding */ 03709 /* 200 to the CIF "modification" value. */ 03710 03711 usage_code = CIF_Symbol_Modification + 200; 03712 } 03713 } 03714 else if (LA_CH_VALUE == EQUAL) { 03715 NEXT_LA_CH; 03716 save_line = LA_CH_LINE; 03717 save_column = LA_CH_COLUMN; 03718 03719 if (LA_CH_VALUE == GT) { 03720 NEXT_LA_CH; 03721 save_line = LA_CH_LINE; 03722 save_column = LA_CH_COLUMN; 03723 GT_encountered = TRUE; 03724 } 03725 03726 if (!found_colon) { 03727 PRINTMSG(save_line, 121, Error, save_column); 03728 AT_DCL_ERR(attr_idx) = TRUE; 03729 } 03730 03731 /* (Re)set stmt_type to Type_Decl_Stmt in case this is the second or */ 03732 /* later initialization for this stmt. On the first pass through */ 03733 /* here, stmt_type is set to (CG) Data_Stmt so that the SH won't be */ 03734 /* thrown away. stmt_type needs to be Type_Decl_Stmt at this point */ 03735 /* so parse_expr will issue an Ansi message if the initialization */ 03736 /* value is a BOZ constant. */ 03737 03738 stmt_type = Type_Decl_Stmt; 03739 03740 if (parse_expr(&init_opnd)) { 03741 03742 if (has_parameter) { 03743 03744 /* Only check semantics if this is not a new attribute */ 03745 /* ATD_CLASS does not get set to Constant until here. If */ 03746 /* this is a new attribute, merge_dimension actually gets */ 03747 /* called before ATD_CLASS is set. This will work, because */ 03748 /* all the kinds of arrays that cannot be parameters are */ 03749 /* caught by related attributes of these arrays, so we do not */ 03750 /* have to check the parameter attribute against the kind of */ 03751 /* dimension. All other attributes are checked against */ 03752 /* PARAMETER by parse_attr_spec. If this isn't a new */ 03753 /* attribute, then merge_parameter does semantic checking. */ 03754 /* All this is done to prevent an ordering problem with arrays */ 03755 /* and parameters. To be correct the array attribute must be */ 03756 /* added before the dimension attribute. (See parse_attr_spec */ 03757 /* under Parameter for more details.) */ 03758 03759 chk_semantics = !new_attr; 03760 03761 # if defined(COARRAY_FORTRAN) 03762 03763 if (pe_array_idx == NULL_IDX && new_pe_array_idx != NULL_IDX) { 03764 03765 /* A co-array was specified with the variable, */ 03766 /* but not with the DIMENSION attribute word. */ 03767 03768 chk_semantics = TRUE; 03769 } 03770 # endif 03771 03772 03773 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 03774 type_idx = ATD_TYPE_IDX(attr_idx); 03775 03776 if (TYP_TYPE(type_idx) == Character && 03777 TYP_CHAR_CLASS(type_idx) == Unknown_Char) { 03778 03779 char_bounds_resolution(attr_idx, 03780 &chk_semantics); 03781 } 03782 03783 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 03784 array_bounds_resolution(attr_idx, 03785 &chk_semantics); 03786 03787 target_array_idx = ATD_ARRAY_IDX(attr_idx); 03788 } 03789 03790 type_idx = ATD_TYPE_IDX(attr_idx); 03791 03792 switch (TYP_TYPE(type_idx)) { 03793 case Integer: 03794 case Real: 03795 case Complex: 03796 check_type_conversion = TRUE; 03797 target_type_idx = type_idx; 03798 break; 03799 03800 case Character: 03801 03802 if (TYP_CHAR_CLASS(type_idx) == Const_Len_Char) { 03803 check_type_conversion = TRUE; 03804 target_type_idx = Character_1; 03805 target_char_len_idx = TYP_IDX(type_idx); 03806 } 03807 break; 03808 } 03809 } 03810 03811 exp_desc.rank = 0; 03812 expr_mode = Initialization_Expr; 03813 xref_state = CIF_Symbol_Reference; 03814 03815 03816 /* set comp_gen_expr to TRUE. This forces the fold of REAL */ 03817 /* constant expressions. When -Oieeeconform is specified, */ 03818 /* the folding of Real and Complex expressions is prevented. */ 03819 03820 comp_gen_expr = TRUE; 03821 03822 if (expr_semantics(&init_opnd, &exp_desc)) { 03823 check_type_conversion = FALSE; 03824 target_array_idx = NULL_IDX; 03825 expr_mode = Regular_Expr; 03826 03827 /* There is an error with the PARAMETER attribute if */ 03828 /* Parameter_Attr is not set, but has_parameter is. If */ 03829 /* there is an error, do not try to merge_parameter. */ 03830 03831 if (attr_list & (1 << Parameter_Attr)) { 03832 merge_parameter(chk_semantics, 03833 attr_idx, 03834 id_line, 03835 id_column, 03836 &init_opnd, 03837 &exp_desc, 03838 save_line, 03839 save_column); 03840 } 03841 } 03842 else { 03843 check_type_conversion = FALSE; 03844 target_array_idx = NULL_IDX; 03845 expr_mode = Regular_Expr; 03846 AT_DCL_ERR(attr_idx) = TRUE; 03847 } 03848 03849 /* reset comp_gen_expr to FALSE. end of compiler gen'ed expr */ 03850 comp_gen_expr = FALSE; 03851 } 03852 else { 03853 03854 if (merge_data(TRUE, id_line, id_column, attr_idx)) { 03855 03856 if (SH_STMT_TYPE(curr_stmt_sh_idx) == Type_Decl_Stmt) { 03857 SH_STMT_TYPE(curr_stmt_sh_idx) = Type_Init_Stmt; 03858 SH_COMPILER_GEN(curr_stmt_sh_idx) = TRUE; 03859 SH_GLB_LINE(curr_stmt_sh_idx) = id_line; 03860 SH_COL_NUM(curr_stmt_sh_idx) = id_column; 03861 } 03862 else { 03863 gen_sh(After, Type_Init_Stmt, id_line, id_column, 03864 FALSE, FALSE, TRUE); 03865 } 03866 03867 stmt_type = Type_Init_Stmt; 03868 03869 NTR_IR_TBL(init_ir_idx); 03870 SH_IR_IDX(curr_stmt_sh_idx) = init_ir_idx; 03871 03872 if (OPND_FLD(init_opnd) == IR_Tbl_Idx && 03873 IR_OPR(OPND_IDX(init_opnd)) == Call_Opr && 03874 AT_IS_INTRIN(IR_IDX_L(OPND_IDX(init_opnd))) && 03875 strcmp(AT_OBJ_NAME_PTR(IR_IDX_L(OPND_IDX(init_opnd))), 03876 "NULL") == 0) { 03877 if (IR_IDX_R(OPND_IDX(init_opnd)) != NULL_IDX) { 03878 PRINTMSG(IR_LINE_NUM(OPND_IDX(init_opnd)), 1573, Error, 03879 IR_COL_NUM(OPND_IDX(init_opnd))); 03880 } 03881 IR_OPR(init_ir_idx) = Null_Opr; 03882 if (!GT_encountered) { 03883 PRINTMSG(TOKEN_LINE(token), 1562, Error, 03884 TOKEN_COLUMN(token)); 03885 } 03886 } 03887 else { 03888 IR_OPR(init_ir_idx) = Init_Opr; 03889 if (GT_encountered) { 03890 PRINTMSG(TOKEN_LINE(token), 1562, Error, 03891 TOKEN_COLUMN(token)); 03892 } 03893 } 03894 IR_TYPE_IDX(init_ir_idx) = TYPELESS_DEFAULT_TYPE; 03895 IR_LINE_NUM(init_ir_idx) = id_line; 03896 IR_COL_NUM(init_ir_idx) = id_column; 03897 IR_LINE_NUM_L(init_ir_idx) = id_line; 03898 IR_COL_NUM_L(init_ir_idx) = id_column; 03899 IR_FLD_L(init_ir_idx) = AT_Tbl_Idx; 03900 IR_IDX_L(init_ir_idx) = attr_idx; 03901 03902 COPY_OPND(IR_OPND_R(init_ir_idx), init_opnd); 03903 03904 /* The item is being initialized, so flag this by adding */ 03905 /* 200 to the CIF "modification" value. */ 03906 03907 usage_code = CIF_Symbol_Modification + 200; 03908 } 03909 } 03910 } 03911 else { 03912 /* error from parse_expr */ 03913 AT_DCL_ERR(attr_idx) = TRUE; 03914 } 03915 03916 } 03917 else if (has_parameter) { 03918 AT_DCL_ERR(attr_idx) = TRUE; 03919 PRINTMSG(LA_CH_LINE, 111, Error, LA_CH_COLUMN, 03920 AT_OBJ_NAME_PTR(attr_idx)); 03921 } 03922 03923 AT_DCL_ERR(attr_idx) = AT_DCL_ERR(AT_WORK_IDX) || AT_DCL_ERR(attr_idx); 03924 03925 if ((cif_flags & XREF_RECS) != 0) { 03926 cif_usage_rec(attr_idx, 03927 AT_Tbl_Idx, 03928 id_line, 03929 id_column, 03930 usage_code); 03931 } 03932 03933 if (LA_CH_VALUE == COMMA || 03934 (LA_CH_VALUE != EOS && 03935 parse_err_flush(Find_Comma, ", or " EOS_STR))) { 03936 03937 /* Intentionally left blank. */ 03938 03939 } 03940 else { 03941 found_end = TRUE; 03942 } 03943 NEXT_LA_CH; 03944 } 03945 while (!found_end); 03946 03947 if (cif_flags & MISC_RECS) { 03948 cif_stmt_type_rec(TRUE, CIF_Type_Declaration_Stmt, stmt_number); 03949 } 03950 03951 EXIT: 03952 03953 TRACE (Func_Exit, "parse_type_dcl_stmt", NULL); 03954 03955 return; 03956 03957 } /* parse_type_dcl_stmt */ 03958 03959 03960 /******************************************************************************\ 03961 |* *| 03962 |* Description: *| 03963 |* Parses the use statement *| 03964 |* BNF USE module-name [,rename-list] *| 03965 |* or USE module-name, ONLY:[only-list] *| 03966 |* rename is local-name => use-name *| 03967 |* only is access-id *| 03968 |* or [local-name =>] use-name *| 03969 |* *| 03970 |* Input parameters: *| 03971 |* NONE *| 03972 |* *| 03973 |* Output parameters: *| 03974 |* NONE *| 03975 |* *| 03976 |* Returns: *| 03977 |* NONE *| 03978 |* *| 03979 \******************************************************************************/ 03980 void parse_use_stmt (void) 03981 03982 { 03983 int attr_idx; 03984 boolean found_end = TRUE; 03985 int list_idx; 03986 int name_idx; 03987 int new_name_idx; 03988 use_type_type prev_use = Use_Not; 03989 int ro_idx; 03990 int use_ir_idx; 03991 03992 03993 TRACE (Func_Entry, "parse_use_stmt", NULL); 03994 03995 if ((STMT_OUT_OF_ORDER(curr_stmt_category, Use_Stmt) || 03996 STMT_CANT_BE_IN_BLK(Use_Stmt, CURR_BLK)) && iss_blk_stk_err()) { 03997 /* Block error - intentionally left blank */ 03998 } 03999 else { 04000 curr_stmt_category = Use_Stmt_Cat; 04001 } 04002 04003 if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 04004 parse_err_flush(Find_EOS, "module-name"); 04005 goto EXIT; 04006 } 04007 04008 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx); 04009 04010 if (attr_idx != NULL_IDX) { /* Name exists in symbol table already */ 04011 04012 if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit && 04013 ATP_PGM_UNIT(attr_idx) == Module) { 04014 04015 /* The only way this could be here, is if it */ 04016 /* is specified in a previous USE statement. */ 04017 04018 prev_use = (use_type_type) ATP_USE_TYPE(attr_idx); 04019 list_idx = SCP_USED_MODULE_LIST(curr_scp_idx); 04020 04021 while (list_idx != NULL_IDX) { 04022 04023 if (AL_ATTR_IDX(list_idx) == attr_idx) { 04024 break; 04025 } 04026 list_idx = AL_NEXT_IDX(list_idx); 04027 } 04028 04029 if (list_idx == NULL_IDX) { 04030 04031 /* Found end of module list. The attr is not */ 04032 /* in the list. Add the attr to the list. */ 04033 04034 NTR_ATTR_LIST_TBL(list_idx); 04035 AL_ATTR_IDX(list_idx) = attr_idx; 04036 AL_PREV_MODULE_IDX(SCP_USED_MODULE_LIST(curr_scp_idx)) = list_idx; 04037 AL_NEXT_IDX(list_idx) = SCP_USED_MODULE_LIST(curr_scp_idx); 04038 SCP_USED_MODULE_LIST(curr_scp_idx) = list_idx; 04039 AT_USE_ASSOCIATED(attr_idx) = TRUE; 04040 AT_MODULE_IDX(attr_idx) = attr_idx; 04041 prev_use = Use_Not; 04042 } 04043 } 04044 else { /* This is already something else in this scope. */ 04045 PRINTMSG(TOKEN_LINE(token), 791, Error, 04046 TOKEN_COLUMN(token), 04047 AT_OBJ_NAME_PTR(attr_idx)); 04048 04049 CREATE_ERR_ATTR(attr_idx, 04050 TOKEN_LINE(token), 04051 TOKEN_COLUMN(token), 04052 Pgm_Unit); 04053 ATP_PGM_UNIT(attr_idx) = Module; 04054 ATP_SCP_IDX(attr_idx) = curr_scp_idx; 04055 NTR_ATTR_LIST_TBL(list_idx); 04056 AL_ATTR_IDX(list_idx) = attr_idx; 04057 AL_PREV_MODULE_IDX(SCP_USED_MODULE_LIST(curr_scp_idx)) = list_idx; 04058 AL_NEXT_IDX(list_idx) = SCP_USED_MODULE_LIST(curr_scp_idx); 04059 SCP_USED_MODULE_LIST(curr_scp_idx)= list_idx; 04060 AT_USE_ASSOCIATED(attr_idx) = TRUE; 04061 AT_MODULE_IDX(attr_idx) = attr_idx; 04062 MAKE_EXTERNAL_NAME(attr_idx, 04063 AT_NAME_IDX(attr_idx), 04064 AT_NAME_LEN(attr_idx)); 04065 } 04066 } 04067 else { 04068 attr_idx = ntr_sym_tbl(&token, name_idx); 04069 AT_OBJ_CLASS(attr_idx) = Pgm_Unit; 04070 ATP_PGM_UNIT(attr_idx) = Module; 04071 ATP_SCP_IDX(attr_idx) = curr_scp_idx; 04072 MAKE_EXTERNAL_NAME(attr_idx, 04073 AT_NAME_IDX(attr_idx), 04074 AT_NAME_LEN(attr_idx)); 04075 NTR_ATTR_LIST_TBL(list_idx); 04076 AL_ATTR_IDX(list_idx) = attr_idx; 04077 AL_PREV_MODULE_IDX(SCP_USED_MODULE_LIST(curr_scp_idx)) = list_idx; 04078 AL_NEXT_IDX(list_idx) = SCP_USED_MODULE_LIST(curr_scp_idx); 04079 SCP_USED_MODULE_LIST(curr_scp_idx)= list_idx; 04080 AT_USE_ASSOCIATED(attr_idx) = TRUE; 04081 AT_MODULE_IDX(attr_idx) = attr_idx; 04082 LN_DEF_LOC(name_idx) = TRUE; 04083 } 04084 04085 if (AT_ORIG_NAME_IDX(attr_idx) == NULL_IDX) { 04086 AT_ORIG_NAME_IDX(attr_idx) = AT_NAME_IDX(attr_idx); 04087 AT_ORIG_NAME_LEN(attr_idx) = AT_NAME_LEN(attr_idx); 04088 } 04089 04090 if (ATP_GLOBAL_ATTR_IDX(attr_idx) == NULL_IDX) { 04091 04092 /* This searches to see if there are other references/defines to this */ 04093 /* global name. It issues an error if this name has been used as a */ 04094 /* common block or non-module name. This returns the global name tbl */ 04095 /* index. If this module has been referenced previously, we will have */ 04096 /* the file path table index with the file name and an index to the */ 04097 /* start of this module information table in that file. If GAP_FP_IDX */ 04098 /* is blank, we will have to search for the file in use_stmt_semantics.*/ 04099 04100 AT_REFERENCED(attr_idx) = Referenced; 04101 name_idx = check_global_pgm_unit(attr_idx); 04102 ATP_MODULE_STR_IDX(attr_idx) = GN_NAME_IDX(name_idx); 04103 } 04104 04105 if ((cif_flags & XREF_RECS) != 0) { 04106 cif_usage_rec(attr_idx, 04107 AT_Tbl_Idx, 04108 TOKEN_LINE(token), 04109 TOKEN_COLUMN(token), 04110 CIF_Symbol_Reference); 04111 } 04112 04113 if (LA_CH_VALUE == COMMA) { 04114 NEXT_LA_CH; /* Consume comma */ 04115 04116 if (!MATCHED_TOKEN_CLASS(Tok_Class_Keyword)) { 04117 parse_err_flush(Find_EOS, "ONLY or use-name"); 04118 } 04119 else if (TOKEN_VALUE(token) == Tok_Kwd_Only && LA_CH_VALUE == COLON) { 04120 NEXT_LA_CH; /* Colon */ 04121 04122 if (LA_CH_VALUE != EOS) { 04123 parse_only_spec(attr_idx); 04124 } 04125 04126 /* Check for error here - if interpretation makes it. This must */ 04127 /* always be used as ONLY: */ 04128 04129 if (prev_use == Use_Not || prev_use == Use_Only) { 04130 ATP_USE_TYPE(attr_idx) = Use_Only; 04131 } 04132 04133 goto EXIT; 04134 } 04135 else { 04136 reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token)); 04137 found_end = FALSE; 04138 } 04139 } 04140 else if (LA_CH_VALUE != EOS) { 04141 parse_err_flush(Find_EOS, ", or " EOS_STR); 04142 } 04143 04144 while (!found_end) { 04145 04146 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 04147 new_name_idx = make_ro_entry(attr_idx, 04148 NULL_IDX, 04149 TRUE); /* New name - do not order */ 04150 04151 if (matched_specific_token(Tok_Punct_Rename, Tok_Class_Punct)) { 04152 04153 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 04154 ro_idx = make_ro_entry(attr_idx, 04155 NULL_IDX, 04156 FALSE); /* order */ 04157 RO_RENAME_IDX(ro_idx) = new_name_idx; 04158 check_for_duplicate_renames(new_name_idx); 04159 } 04160 else { 04161 parse_err_flush(Find_Comma, NULL); 04162 } 04163 } 04164 else { 04165 parse_err_flush(Find_Comma, "=>"); 04166 } 04167 } 04168 else { 04169 parse_err_flush(Find_Comma, "use-name"); 04170 } 04171 04172 if (LA_CH_VALUE != COMMA && LA_CH_VALUE != EOS) { 04173 parse_err_flush(Find_Comma, ", or " EOS_STR); 04174 } 04175 04176 if (LA_CH_VALUE == COMMA) { 04177 NEXT_LA_CH; /* Pick up comma */ 04178 } 04179 else if (LA_CH_VALUE == EOS) { 04180 found_end = TRUE; 04181 } 04182 } /* End while */ 04183 04184 ATP_USE_TYPE(attr_idx) = (ATP_USE_LIST(attr_idx) == NULL_IDX) ? Use_All : 04185 Use_Renamed; 04186 04187 EXIT: 04188 04189 /* Generate IR for this USE statement. Need to keep the attr so that it */ 04190 /* can be passed thru the PDGCS interface during IR conversion. Do not */ 04191 /* need pass2 semantics for this statement. */ 04192 04193 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 04194 NTR_IR_TBL(use_ir_idx); 04195 IR_OPR(use_ir_idx) = Use_Opr; 04196 IR_TYPE_IDX(use_ir_idx) = TYPELESS_DEFAULT_TYPE; 04197 IR_LINE_NUM(use_ir_idx) = stmt_start_line; 04198 IR_COL_NUM(use_ir_idx) = stmt_start_col; 04199 IR_IDX_L(use_ir_idx) = attr_idx; 04200 IR_FLD_L(use_ir_idx) = AT_Tbl_Idx; 04201 IR_LINE_NUM_L(use_ir_idx) = stmt_start_line; 04202 IR_COL_NUM_L(use_ir_idx) = stmt_start_col; 04203 SH_IR_IDX(curr_stmt_sh_idx) = use_ir_idx; 04204 04205 NEXT_LA_CH; 04206 04207 TRACE (Func_Exit, "parse_use_stmt", NULL); 04208 04209 return; 04210 04211 } /* parse_use_stmt */ 04212 04213 /******************************************************************************\ 04214 |* *| 04215 |* Description: *| 04216 |* Parses the ONLY portion of the USE statement. *| 04217 |* BNF only is access-id *| 04218 |* or [local-name =>] use-name *| 04219 |* *| 04220 |* Input parameters: *| 04221 |* NONE *| 04222 |* *| 04223 |* Output parameters: *| 04224 |* NONE *| 04225 |* *| 04226 |* Returns: *| 04227 |* NONE *| 04228 |* *| 04229 \******************************************************************************/ 04230 static void parse_only_spec(int module_attr_idx) 04231 { 04232 int first_name_idx; 04233 boolean found_end = FALSE; 04234 int ro_idx; 04235 04236 04237 TRACE (Func_Entry, "parse_only_spec", NULL); 04238 04239 do { 04240 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 04241 first_name_idx = make_ro_entry(module_attr_idx, 04242 NULL_IDX, 04243 TRUE); /* New name - do not order */ 04244 04245 if (LA_CH_VALUE == EQUAL) { /* Rename */ 04246 04247 if (!matched_specific_token(Tok_Punct_Rename, Tok_Class_Punct)) { 04248 parse_err_flush(Find_Comma, "=>"); 04249 goto ERR_EXIT; 04250 } 04251 04252 if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 04253 parse_err_flush(Find_Comma, NULL); 04254 goto ERR_EXIT; 04255 } 04256 ro_idx = make_ro_entry(module_attr_idx, 04257 NULL_IDX, 04258 FALSE); 04259 RO_RENAME_IDX(ro_idx) = first_name_idx; 04260 check_for_duplicate_renames(first_name_idx); 04261 04262 } 04263 else if (LA_CH_VALUE == LPAREN) { /* Possible generic spec */ 04264 reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token)); 04265 04266 if (!parse_generic_spec()) { 04267 parse_err_flush(Find_Comma, NULL); 04268 goto ERR_EXIT; 04269 } 04270 04271 rename_only_tbl_idx--; /* Reuse the entry just made. */ 04272 04273 ro_idx = make_ro_entry(module_attr_idx, 04274 NULL_IDX, /* Get a new ro entry */ 04275 FALSE); /* Order it */ 04276 } 04277 else { 04278 04279 /* If this is not renamed - the ro entry is in first_name_idx. */ 04280 /* This is not a linked entry yet, because when we created it, we */ 04281 /* didn't know if it was a local name or the original name. The */ 04282 /* original names are linked together in alphabetical order. */ 04283 /* Pass in first_name_idx and make_ro_entry will insert it into */ 04284 /* the list in correct order. */ 04285 04286 ro_idx = make_ro_entry(module_attr_idx, 04287 first_name_idx, 04288 FALSE); 04289 } 04290 } 04291 else { 04292 parse_err_flush(Find_Comma, "use-name"); 04293 } 04294 04295 ERR_EXIT: 04296 04297 if (LA_CH_VALUE != COMMA && LA_CH_VALUE != EOS) { 04298 parse_err_flush(Find_Comma, ", or " EOS_STR); 04299 } 04300 04301 if (LA_CH_VALUE == COMMA) { 04302 NEXT_LA_CH; /* Pick up comma */ 04303 } 04304 else if (LA_CH_VALUE == EOS) { 04305 found_end = TRUE; 04306 } 04307 } /* End while */ 04308 while (!found_end); 04309 04310 TRACE (Func_Exit, "parse_only_spec", NULL); 04311 04312 return; 04313 04314 } /* parse_only_spec */ 04315 04316 /******************************************************************************\ 04317 |* *| 04318 |* Description: *| 04319 |* Parses the attr_spec in the type declaration statement *| 04320 |* BNF type_spec[[,attr_spec]...::]entity-decl-list *| 04321 |* attr_spec is PARAMETER *| 04322 |* or access_spec is PUBLIC or PRIVATE *| 04323 |* or ALLOCATABLE *| 04324 |* or DIMENSION(array-spec) *| 04325 |* or EXTERNAL *| 04326 |* or INTENT(intent-spec) *| 04327 |* or INTRINSIC *| 04328 |* or OPTIONAL *| 04329 |* or POINTER *| 04330 |* or SAVE *| 04331 |* or TARGET *| 04332 |* *| 04333 |* Input parameters: *| 04334 |* attr_list --> A bit vector specifying which attrs have been *| 04335 |* specified already. *| 04336 |* *| 04337 |* Output parameters: *| 04338 |* NONE *| 04339 |* *| 04340 |* Returns: *| 04341 |* NONE *| 04342 |* *| 04343 \******************************************************************************/ 04344 static long parse_attr_spec(int *array_idx, 04345 boolean *has_parameter) 04346 04347 { 04348 long attr_list = 0; 04349 long err_in_list; 04350 long err_list = 0; 04351 int pe_array_idx; 04352 04353 04354 TRACE (Func_Entry, "parse_attr_spec", NULL); 04355 04356 /* At entry, LA_CH_VALUE must be comma. */ 04357 04358 *has_parameter = FALSE; 04359 04360 do { 04361 if (LA_CH_VALUE == EOS) { /* Missing id list */ 04362 break; 04363 } 04364 04365 if (LA_CH_VALUE != COMMA) { 04366 parse_err_flush(Find_Comma, ", or ::"); 04367 continue; 04368 } 04369 04370 NEXT_LA_CH; 04371 04372 if (!MATCHED_TOKEN_CLASS(Tok_Class_Keyword)) { 04373 parse_err_flush(Find_Comma, "ALLOCATABLE, DIMENSION, EXTERNAL, " 04374 "INTENT, INTRINSIC, OPTIONAL, PARAMETER, POINTER, " 04375 "PRIVATE, PUBLIC, SAVE or TARGET"); 04376 continue; 04377 } 04378 04379 switch (TOKEN_VALUE(token)) { 04380 04381 case Tok_Kwd_Parameter: 04382 04383 /* merge_parameter will actually set this to Constant */ 04384 /* Do not set it here, because if this is an array, it */ 04385 /* must be set as an array first. It is okay to set */ 04386 /* the dimension first and then add the parameter to */ 04387 /* it. Wrong arrays will get caught as follows: */ 04388 /* If the array is adjustable or automatic, this is */ 04389 /* determined at end_pass1. The attribute is already */ 04390 /* a parameter, so it's caught there. Assumed_Size */ 04391 /* and Assumed_Shape arrays will get caught because */ 04392 /* by definition they must be dummy arguments and a */ 04393 /* parameter is not allowed to be a dummy argument. */ 04394 /* Deferred_Shape arrays are caught, because they must */ 04395 /* be ALLOCATABLE or POINTER. The parameter is caught */ 04396 /* because a parameter can't be allocatable or a pointer.*/ 04397 /* Parameter is returned as set, whether there is an */ 04398 /* error or not. */ 04399 04400 err_in_list = err_attrs[Parameter_Attr] & attr_list; 04401 attr_list = attr_list | (1 << Parameter_Attr); 04402 *has_parameter = TRUE; 04403 04404 if (err_in_list) { 04405 issue_attr_err(Parameter_Attr, err_in_list); 04406 err_list = err_list | (1 << Parameter_Attr); 04407 } 04408 break; 04409 04410 04411 case Tok_Kwd_Public: 04412 04413 if (CURR_BLK != Module_Blk) { 04414 issue_attr_blk_err("PUBLIC"); 04415 } 04416 else { 04417 err_in_list = err_attrs[Public_Attr] & attr_list; 04418 attr_list = attr_list | (1 << Public_Attr); 04419 04420 if (err_in_list) { 04421 issue_attr_err(Public_Attr, err_in_list); 04422 err_list = err_list | (1 << Public_Attr); 04423 } 04424 else { 04425 AT_ACCESS_SET(AT_WORK_IDX) = TRUE; 04426 AT_PRIVATE(AT_WORK_IDX) = FALSE; 04427 } 04428 } 04429 break; 04430 04431 04432 case Tok_Kwd_Private: 04433 04434 if (CURR_BLK != Module_Blk) { 04435 issue_attr_blk_err("PRIVATE"); 04436 } 04437 else { 04438 err_in_list = err_attrs[Private_Attr] & attr_list; 04439 attr_list = attr_list | (1 << Private_Attr); 04440 04441 if (err_in_list) { 04442 issue_attr_err(Private_Attr, err_in_list); 04443 err_list = err_list | (1 << Private_Attr); 04444 } 04445 else { 04446 AT_ACCESS_SET(AT_WORK_IDX) = TRUE; 04447 AT_PRIVATE(AT_WORK_IDX) = TRUE; 04448 } 04449 } 04450 break; 04451 04452 04453 case Tok_Kwd_Allocatable: 04454 04455 if (STMT_CANT_BE_IN_BLK(Allocatable_Stmt, CURR_BLK)) { 04456 issue_attr_blk_err("ALLOCATABLE"); 04457 } 04458 else { 04459 err_in_list = err_attrs[Allocatable_Attr] & attr_list; 04460 attr_list = attr_list | (1 << Allocatable_Attr); 04461 04462 if (err_in_list) { 04463 issue_attr_err(Allocatable_Attr, err_in_list); 04464 err_list = err_list | (1 << Allocatable_Attr); 04465 } 04466 else { 04467 ATD_ALLOCATABLE(AT_WORK_IDX) = TRUE; 04468 /* keep array form do not generate dope vector */ 04469 /* ATD_IM_A_DOPE(AT_WORK_IDX) = TRUE; */ 04470 } 04471 } 04472 break; 04473 04474 04475 case Tok_Kwd_Automatic: 04476 04477 if (STMT_CANT_BE_IN_BLK(Automatic_Stmt, CURR_BLK)) { 04478 issue_attr_blk_err("AUTOMATIC"); 04479 } 04480 else { 04481 PRINTMSG(TOKEN_LINE(token), 1254, Ansi, 04482 TOKEN_COLUMN(token), 04483 "AUTOMATIC"); 04484 err_in_list = err_attrs[Automatic_Attr] & attr_list; 04485 attr_list = attr_list | (1 << Automatic_Attr); 04486 04487 if (err_in_list) { 04488 issue_attr_err(Automatic_Attr, err_in_list); 04489 err_list = err_list | (1 << Automatic_Attr); 04490 } 04491 else { 04492 ATD_STACK(AT_WORK_IDX) = TRUE; 04493 } 04494 } 04495 break; 04496 04497 04498 /* External and intrinsic will get switched to program units */ 04499 /* when the names are processed. */ 04500 04501 case Tok_Kwd_External: 04502 04503 if (STMT_CANT_BE_IN_BLK(External_Stmt, CURR_BLK)) { 04504 issue_attr_blk_err("EXTERNAL"); 04505 } 04506 else { 04507 err_in_list = err_attrs[External_Attr] & attr_list; 04508 attr_list = attr_list | (1 << External_Attr); 04509 04510 if (err_in_list) { 04511 issue_attr_err(External_Attr, err_in_list); 04512 err_list = err_list | (1 << External_Attr); 04513 } 04514 } 04515 break; 04516 04517 04518 case Tok_Kwd_Intrinsic: 04519 04520 err_in_list = err_attrs[Intrinsic_Attr] & attr_list; 04521 attr_list = attr_list | (1 << Intrinsic_Attr); 04522 04523 if (err_in_list) { 04524 issue_attr_err(Intrinsic_Attr, err_in_list); 04525 err_list = err_list | (1 << Intrinsic_Attr); 04526 } 04527 break; 04528 04529 04530 case Tok_Kwd_Optional: 04531 04532 if (STMT_CANT_BE_IN_BLK(Optional_Stmt, CURR_BLK)) { 04533 issue_attr_blk_err("OPTIONAL"); 04534 } 04535 else { 04536 err_in_list = err_attrs[Optional_Attr] & attr_list; 04537 attr_list = attr_list | (1 << Optional_Attr); 04538 04539 if (err_in_list) { 04540 issue_attr_err(Optional_Attr, err_in_list); 04541 err_list = err_list | (1 << Optional_Attr); 04542 } 04543 else { 04544 if (AT_OBJ_CLASS(AT_WORK_IDX) == Data_Obj) { 04545 ATD_CLASS(AT_WORK_IDX) = Dummy_Argument; 04546 } 04547 04548 AT_OPTIONAL(AT_WORK_IDX) = TRUE; 04549 } 04550 } 04551 break; 04552 04553 04554 case Tok_Kwd_Pointer: 04555 04556 err_in_list = err_attrs[Pointer_Attr] & attr_list; 04557 attr_list = attr_list | (1 << Pointer_Attr); 04558 04559 if (err_in_list) { 04560 issue_attr_err(Pointer_Attr, err_in_list); 04561 err_list = err_list | (1 << Pointer_Attr); 04562 } 04563 else { /* EXTERNAL, INTRINSIC are illegal, so can't be pgm_unit */ 04564 ATD_POINTER(AT_WORK_IDX) = TRUE; 04565 /* keep array form don't generate dope vector */ 04566 /* ATD_IM_A_DOPE(AT_WORK_IDX) = TRUE; */ 04567 } 04568 break; 04569 04570 04571 case Tok_Kwd_Save: 04572 04573 if (ATP_SAVE_ALL(SCP_ATTR_IDX(curr_scp_idx))) { 04574 PRINTMSG(TOKEN_LINE(token), 133, Ansi, TOKEN_COLUMN(token)); 04575 } 04576 04577 err_in_list = err_attrs[Save_Attr] & attr_list; 04578 attr_list = attr_list | (1 << Save_Attr); 04579 04580 if (err_in_list) { 04581 issue_attr_err(Save_Attr, err_in_list); 04582 err_list = err_list | (1 << Save_Attr); 04583 } 04584 else { 04585 ATD_SAVED(AT_WORK_IDX) = TRUE; 04586 ATD_CLASS(AT_WORK_IDX) = Variable; 04587 } 04588 break; 04589 04590 04591 case Tok_Kwd_Target: 04592 04593 err_in_list = err_attrs[Target_Attr] & attr_list; 04594 attr_list = attr_list | (1 << Target_Attr); 04595 04596 if (err_in_list) { 04597 issue_attr_err(Target_Attr, err_in_list); 04598 err_list = err_list | (1 << Target_Attr); 04599 } 04600 else { 04601 ATD_TARGET(AT_WORK_IDX) = TRUE; 04602 } 04603 break; 04604 04605 04606 case Tok_Kwd_Volatile: 04607 04608 if (STMT_CANT_BE_IN_BLK(Volatile_Stmt, CURR_BLK)) { 04609 issue_attr_blk_err("VOLATILE"); 04610 } 04611 else { 04612 PRINTMSG(TOKEN_LINE(token), 1254, Ansi, TOKEN_COLUMN(token), 04613 "VOLATILE"); 04614 err_in_list = err_attrs[Volatile_Attr] & attr_list; 04615 attr_list = attr_list | (1 << Volatile_Attr); 04616 04617 if (err_in_list) { 04618 issue_attr_err(Volatile_Attr, err_in_list); 04619 err_list = err_list | (1 << Volatile_Attr); 04620 } 04621 else { 04622 ATD_VOLATILE(AT_WORK_IDX) = TRUE; 04623 } 04624 } 04625 break; 04626 04627 04628 case Tok_Kwd_Intent: 04629 04630 if (STMT_CANT_BE_IN_BLK(Intent_Stmt, CURR_BLK)) { 04631 issue_attr_blk_err("INTENT"); 04632 parse_err_flush(Find_Comma, NULL); 04633 continue; 04634 } 04635 err_in_list = err_attrs[Intent_Attr] & attr_list; 04636 attr_list = attr_list | (1 << Intent_Attr); 04637 04638 if (err_in_list) { 04639 issue_attr_err(Intent_Attr, err_in_list); 04640 } 04641 04642 new_intent = parse_intent_spec(); 04643 ATD_CLASS(AT_WORK_IDX) = Dummy_Argument; 04644 ATD_INTENT(AT_WORK_IDX) = new_intent; 04645 break; 04646 04647 04648 case Tok_Kwd_Dimension: 04649 err_in_list = err_attrs[Dimension_Attr] & attr_list; 04650 attr_list = attr_list | (1 << Dimension_Attr); 04651 04652 if (err_in_list) { 04653 issue_attr_err(Dimension_Attr, err_in_list); 04654 err_list = err_list | (1 << Dimension_Attr); 04655 } 04656 04657 if (LA_CH_VALUE == LPAREN) { 04658 *array_idx = parse_array_spec(AT_WORK_IDX); 04659 } 04660 # ifdef COARRAY_FORTRAN 04661 else if (!cmd_line_flags.co_array_fortran || LA_CH_VALUE != LBRKT) 04662 # else 04663 else 04664 # endif 04665 { /* Looking for array specifier */ 04666 parse_err_flush(Find_Comma, "( dimension-spec )"); 04667 } 04668 04669 # ifdef COARRAY_FORTRAN 04670 04671 if (LA_CH_VALUE == LBRKT && cmd_line_flags.co_array_fortran) { 04672 err_in_list = err_attrs[Co_Array_Attr] & attr_list; 04673 attr_list = attr_list | (1 << Co_Array_Attr); 04674 04675 if (err_in_list) { 04676 issue_attr_err(Co_Array_Attr, err_in_list); 04677 err_list = err_list | (1 << Co_Array_Attr); 04678 } 04679 04680 pe_array_idx = parse_pe_array_spec(AT_WORK_IDX); 04681 04682 if (!err_in_list) { 04683 ATD_PE_ARRAY_IDX(AT_WORK_IDX) = pe_array_idx; 04684 } 04685 } 04686 # endif 04687 break; 04688 04689 04690 default: 04691 parse_err_flush(Find_Comma, "attr-spec"); 04692 break; 04693 04694 } /* end switch */ 04695 04696 } /* end while */ 04697 while (LA_CH_VALUE != COLON || 04698 !matched_specific_token(Tok_Punct_Colon_Colon, Tok_Class_Punct)); 04699 04700 /* Turn off any error bits */ 04701 04702 attr_list = attr_list^err_list; 04703 04704 TRACE (Func_Exit, "parse_attr_spec", NULL); 04705 04706 return(attr_list); 04707 04708 } /* parse_attr_spec */ 04709 04710 /******************************************************************************\ 04711 |* *| 04712 |* Description: *| 04713 |* Issues error messages for illegal combinations of attributes on *| 04714 |* the type declaration statement. *| 04715 |* *| 04716 |* Input parameters: *| 04717 |* new_attr -> The attribute being added. *| 04718 |* err_in_list -> The error list in bit vector form. *| 04719 |* *| 04720 |* Output parameters: *| 04721 |* NONE *| 04722 |* *| 04723 |* Returns: *| 04724 |* NONE *| 04725 |* *| 04726 \******************************************************************************/ 04727 04728 static void issue_attr_err(attr_type new_attr, 04729 long err_in_list) 04730 { 04731 long idx; 04732 04733 04734 TRACE (Func_Entry, "issue_attr_err", NULL); 04735 04736 for (idx = 0; idx <= End_Attr; idx++) { 04737 04738 if ((1 & err_in_list) != 0) { 04739 04740 if (idx == new_attr) { 04741 04742 /* More than one instance of this attribute in the attribute list */ 04743 04744 PRINTMSG(TOKEN_LINE(token), 424, Error, TOKEN_COLUMN(token), 04745 attr_str[new_attr]); 04746 } 04747 else { /* Invalid combination of attributes in the list. */ 04748 04749 PRINTMSG(TOKEN_LINE(token), 425, Error, TOKEN_COLUMN(token), 04750 attr_str[new_attr], attr_str[idx]); 04751 } 04752 } 04753 err_in_list = err_in_list >> 1; 04754 } 04755 04756 AT_DCL_ERR(AT_WORK_IDX) = TRUE; 04757 04758 TRACE (Func_Exit, "issue_attr_err", NULL); 04759 04760 return; 04761 04762 } /* issue_attr_err */ 04763 04764 /******************************************************************************\ 04765 |* *| 04766 |* Description: *| 04767 |* Issues error messages for illegal combinations of attributes on *| 04768 |* the type declaration statement. *| 04769 |* NOTE: If errors are added here for illegal combinations between *| 04770 |* the type and the function name, they must also be added to *| 04771 |* parse_typed_function. parse_typed_function does not call *| 04772 |* this routine. *| 04773 |* *| 04774 |* Input parameters: *| 04775 |* attr_idx -> This is the attribute that gets the new type. *| 04776 |* type_idx -> This is the new type to add to the attribute. *| 04777 |* id_line -> This is line where the item is being typed. *| 04778 |* id_column -> This is column where the item is being typed. *| 04779 |* *| 04780 |* Output parameters: *| 04781 |* NONE *| 04782 |* *| 04783 |* Returns: *| 04784 |* NONE *| 04785 |* *| 04786 \******************************************************************************/ 04787 04788 static void merge_type(int attr_idx, 04789 int type_idx, 04790 int id_line, 04791 int id_column) 04792 04793 { 04794 boolean error = FALSE; 04795 int func_idx; 04796 int msg_num; 04797 opnd_type opnd; 04798 char *ptr; 04799 char *ptr2; 04800 boolean referenced_itrfc = FALSE; 04801 int rslt_idx; 04802 obj_type sem_type = Obj_Typed; 04803 boolean set_type = FALSE; 04804 04805 04806 TRACE (Func_Entry, "merge_type", NULL); 04807 04808 if (AT_OBJ_CLASS(attr_idx) == Interface && 04809 !AT_IS_INTRIN(attr_idx) && 04810 ATI_PROC_IDX(attr_idx) != NULL_IDX) { 04811 referenced_itrfc = AT_REFERENCED(attr_idx) >= Dcl_Bound_Ref; 04812 attr_idx = ATI_PROC_IDX(attr_idx); 04813 } 04814 04815 if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit && ATP_RSLT_NAME(attr_idx)) { 04816 04817 /* Use the result name to type */ 04818 04819 PRINTMSG(id_line, 185, Error, id_column, 04820 AT_OBJ_NAME_PTR(attr_idx), 04821 AT_OBJ_NAME_PTR(ATP_RSLT_IDX(attr_idx))); 04822 AT_DCL_ERR(attr_idx) = TRUE; 04823 AT_DCL_ERR(ATP_RSLT_IDX(attr_idx)) = TRUE; 04824 goto EXIT; 04825 } 04826 04827 if (TYP_TYPE(type_idx) == Character && 04828 TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char) { 04829 sem_type = Obj_Assum_Type_Ch; 04830 error = fnd_semantic_err(sem_type, 04831 id_line, 04832 id_column, 04833 attr_idx, 04834 TRUE); 04835 } 04836 04837 # if ! defined(_EXTENDED_CRI_CHAR_POINTER) 04838 else if (TYP_TYPE(type_idx) == Character && 04839 AT_OBJ_CLASS(attr_idx) == Data_Obj && 04840 ATD_CLASS(attr_idx) == CRI__Pointee) { 04841 PRINTMSG(id_line,625,Error,id_column, 04842 AT_OBJ_NAME_PTR(attr_idx), 04843 "Cray pointee","CHARACTER*(*)"); 04844 AT_DCL_ERR(attr_idx) = TRUE; 04845 error = TRUE; 04846 } 04847 # endif 04848 else if (AT_ATTR_LINK(attr_idx) != NULL_IDX || 04849 AT_USE_ASSOCIATED(attr_idx) || 04850 AT_OBJ_CLASS(attr_idx) != Data_Obj || 04851 ATD_SYMBOLIC_CONSTANT(attr_idx) || 04852 AT_TYPED(attr_idx) ) { 04853 04854 /* Replace the message output string, with the type that is being */ 04855 /* defined for this object. Gives a more meaningful message. */ 04856 04857 /* strcpy(obj_str[Obj_Typed][0], get_basic_type_str(type_idx)); */ 04858 04859 ptr = get_basic_type_str(type_idx); 04860 (obj_str[Obj_Typed]) = ptr; 04861 04862 04863 error = fnd_semantic_err(Obj_Typed, 04864 id_line, 04865 id_column, 04866 attr_idx, 04867 TRUE); 04868 } 04869 04870 /* If this thing has been referenced or defined already, the error is */ 04871 /* caught later in this routine so that a better message can be issued*/ 04872 04873 # ifdef _DEBUG 04874 04875 /* Check to make sure that this routine is catching everything in the */ 04876 /* semantic tables, because it only calls fnd_semantic_err if it finds */ 04877 /* an error. */ 04878 04879 if (!error && fnd_semantic_err(Obj_Typed, 04880 id_line, 04881 id_column, 04882 attr_idx, 04883 TRUE)) { 04884 PRINTMSG(id_line, 655, Internal, id_column, "merge_type"); 04885 } 04886 04887 # endif 04888 04889 if (AT_ARG_TO_KIND(attr_idx)) { 04890 PRINTMSG(id_line, 1522, Error, id_column, AT_OBJ_NAME_PTR(attr_idx)); 04891 error = TRUE; 04892 } 04893 04894 if (error) { 04895 AT_DCL_ERR(attr_idx) = TRUE; 04896 goto EXIT; 04897 } 04898 04899 switch (AT_OBJ_CLASS(attr_idx)) { 04900 case Data_Obj: 04901 04902 if (ATD_CLASS(attr_idx) == CRI__Pointee) { 04903 04904 if (TYP_TYPE(type_idx) == Structure) { 04905 PRINTMSG(id_line, 650, Error, 04906 id_column, 04907 AT_OBJ_NAME_PTR(attr_idx)); 04908 AT_DCL_ERR(attr_idx) = TRUE; 04909 } 04910 } 04911 04912 if (AT_REFERENCED(attr_idx) >= Dcl_Bound_Ref || 04913 ATD_CLASS(attr_idx) == Constant || 04914 AT_NAMELIST_OBJ(attr_idx) || 04915 ATD_DATA_INIT(attr_idx)) { 04916 04917 if (TYP_LINEAR(ATD_TYPE_IDX(attr_idx)) != TYP_LINEAR(type_idx)) { 04918 04919 /* If this is character, make sure the variable is not referenced */ 04920 /* in its own character length. This is obscure, but we're in an */ 04921 /* error situation anyway - so we might as well do it right. */ 04922 04923 if (TYP_TYPE(type_idx) == Character && 04924 TYP_FLD(type_idx) == AT_Tbl_Idx && 04925 find_attr_in_ir(attr_idx, 04926 ATD_TMP_IDX(TYP_IDX(type_idx)), 04927 &opnd)) { 04928 AT_DCL_ERR(attr_idx) = TRUE; 04929 PRINTMSG(OPND_LINE_NUM(opnd), 1035, Error, 04930 OPND_COL_NUM(opnd), 04931 AT_OBJ_NAME_PTR(attr_idx)); 04932 } 04933 else if (SCP_IMPL_NONE(curr_scp_idx)) { /* IMPLICIT NONE in scope */ 04934 PRINTMSG(id_line, 1424, Error, id_column, 04935 AT_OBJ_NAME_PTR(attr_idx)); 04936 } 04937 else { 04938 04939 if (ATD_CLASS(attr_idx) == Constant) { 04940 msg_num = 238; 04941 } 04942 else if (ATD_DATA_INIT(attr_idx)) { 04943 msg_num = 239; 04944 } 04945 else if (AT_NAMELIST_OBJ(attr_idx)) { 04946 msg_num = 1002; 04947 } 04948 else { /* Ref'd in a spec expression */ 04949 msg_num = 827; 04950 } 04951 04952 if (!AT_DCL_ERR(attr_idx)) { 04953 PRINTMSG(id_line, msg_num, Error, 04954 id_column, 04955 AT_OBJ_NAME_PTR(attr_idx), 04956 get_basic_type_str(ATD_TYPE_IDX(attr_idx))); 04957 } 04958 } 04959 04960 type_idx = ATD_TYPE_IDX(attr_idx); 04961 } 04962 else if (SCP_IMPL_NONE(curr_scp_idx)) { /* IMPLICIT NONE in scope */ 04963 PRINTMSG(id_line, 1423, Ansi, id_column, 04964 AT_OBJ_NAME_PTR(attr_idx)); 04965 } 04966 } 04967 else if (sem_type == Obj_Assum_Type_Ch && 04968 ATD_CLASS(attr_idx) == Function_Result) { 04969 func_idx = ATD_FUNC_IDX(attr_idx); 04970 04971 PRINTMSG(id_line, 1565, Comment, id_column); /* Obsolescent */ 04972 04973 /* fnd_semantic_err catches everything but the current function */ 04974 04975 if (ATP_PROC(func_idx) == Intern_Proc || 04976 ATP_PROC(func_idx) == Module_Proc) { 04977 04978 /* An internal or module procedure cannot be assumed size char */ 04979 /* Allow it to be set for error recovery. */ 04980 04981 PRINTMSG(id_line, 367, Error, id_column, 04982 AT_OBJ_NAME_PTR(func_idx)); 04983 04984 AT_DCL_ERR(attr_idx) = TRUE; 04985 AT_DCL_ERR(func_idx) = TRUE; 04986 } 04987 else if (ATP_IN_INTERFACE_BLK(func_idx)) { 04988 04989 /* An interface block may be typed as assumed size character, */ 04990 /* but it must not be invoked. */ 04991 04992 PRINTMSG(id_line, 1566, Warning, id_column, 04993 AT_OBJ_NAME_PTR(func_idx)); 04994 } 04995 else if (ATP_RECURSIVE(func_idx)) { 04996 04997 /* Recursive is not allowed to be assumed size character */ 04998 /* Allow it to be set for error recovery. */ 04999 05000 PRINTMSG(id_line, 506, Error, id_column, 05001 AT_OBJ_NAME_PTR(func_idx)); 05002 05003 AT_DCL_ERR(attr_idx) = TRUE; 05004 AT_DCL_ERR(func_idx) = TRUE; 05005 } 05006 } 05007 05008 set_type = TRUE; 05009 break; 05010 05011 05012 case Pgm_Unit: 05013 05014 if (ATP_PGM_UNIT(attr_idx) != Function) { 05015 CREATE_FUNC_RSLT(attr_idx, rslt_idx); 05016 ATP_PGM_UNIT(attr_idx) = Function; 05017 } 05018 else { 05019 rslt_idx = ATP_RSLT_IDX(attr_idx); 05020 05021 if (attr_idx != SCP_ATTR_IDX(curr_scp_idx) && 05022 !ATP_ALT_ENTRY(attr_idx) && 05023 (AT_REFERENCED(rslt_idx) >= Dcl_Bound_Ref || referenced_itrfc)) { 05024 05025 /* This has been used already */ 05026 05027 if (ATD_TYPE_IDX(rslt_idx) != type_idx) { 05028 05029 /* If this is character, make sure the function is not */ 05030 /* referenced in its own character length. This is obscure, */ 05031 /* but we're in an error situation anyway - so we might as */ 05032 /* well do it right. */ 05033 05034 if (TYP_TYPE(type_idx) == Character && 05035 TYP_FLD(type_idx) == AT_Tbl_Idx && 05036 find_attr_in_ir(attr_idx, 05037 ATD_TMP_IDX(TYP_IDX(type_idx)), 05038 &opnd)) { 05039 AT_DCL_ERR(attr_idx) = TRUE; 05040 PRINTMSG(OPND_LINE_NUM(opnd), 1035, Error, 05041 OPND_COL_NUM(opnd), 05042 AT_OBJ_NAME_PTR(attr_idx)); 05043 } 05044 else { 05045 PRINTMSG(id_line, 05046 118, 05047 Error, 05048 id_column, 05049 AT_OBJ_NAME_PTR(attr_idx), 05050 get_basic_type_str(ATD_TYPE_IDX(rslt_idx))); 05051 } 05052 05053 type_idx = ATD_TYPE_IDX(rslt_idx); 05054 } 05055 } 05056 else if (sem_type == Obj_Assum_Type_Ch) { 05057 05058 /* fnd_semantic_err catches everything but current function */ 05059 05060 PRINTMSG(id_line, 1565, Comment, id_column); /* Obsolescent */ 05061 05062 if (ATP_PROC(attr_idx) == Intern_Proc || 05063 ATP_PROC(attr_idx) == Module_Proc) { 05064 05065 /* An internal or module procedure cannot be assumed size */ 05066 /* char. Allow it to be set for error recovery. */ 05067 05068 AT_DCL_ERR(attr_idx) = TRUE; 05069 AT_DCL_ERR(rslt_idx) = TRUE; 05070 PRINTMSG(id_line, 367, Error, 05071 id_column, 05072 AT_OBJ_NAME_PTR(attr_idx)); 05073 } 05074 else if (ATP_IN_INTERFACE_BLK(attr_idx)) { 05075 05076 /* An interface block may typed as assumed size */ 05077 /* character, but it cannot be invoked. */ 05078 05079 PRINTMSG(id_line, 1566, Warning, id_column, 05080 AT_OBJ_NAME_PTR(attr_idx)); 05081 } 05082 else if (ATP_RECURSIVE(attr_idx)) { 05083 05084 /* Recursive is not allowed to be assumed size character */ 05085 /* Allow it to be set for error recovery. */ 05086 05087 AT_DCL_ERR(attr_idx) = TRUE; 05088 AT_DCL_ERR(rslt_idx) = TRUE; 05089 PRINTMSG(id_line, 05090 506, 05091 Error, 05092 id_column, 05093 AT_OBJ_NAME_PTR(attr_idx)); 05094 } 05095 } 05096 } 05097 05098 set_type = TRUE; 05099 attr_idx = rslt_idx; 05100 break; 05101 05102 case Interface: 05103 05104 if (AT_REFERENCED(attr_idx) >= Dcl_Bound_Ref) { /* Used already */ 05105 05106 /* Do not use the ATD_TYPE_IDX on the interface. This is only set */ 05107 /* if the interface block has been explicitly typed via a type */ 05108 /* declaration statement. Find any implicit type given to the */ 05109 /* intrinsic, by finding the intrinsic with the same name, via */ 05110 /* ATI_PROC_IDX. */ 05111 05112 if (ATP_RSLT_IDX(SN_ATTR_IDX(ATI_FIRST_SPECIFIC_IDX(attr_idx))) != 05113 NULL_IDX && 05114 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX( 05115 SN_ATTR_IDX(ATI_FIRST_SPECIFIC_IDX(attr_idx))))) != 05116 TYP_TYPE(type_idx)) { 05117 PRINTMSG(id_line, 950, Error, id_column, 05118 AT_OBJ_NAME_PTR(attr_idx)); 05119 } 05120 } 05121 05122 set_type = TRUE; 05123 break; 05124 05125 case Stmt_Func: 05126 05127 if (AT_REFERENCED(attr_idx) >= Dcl_Bound_Ref && 05128 TYP_LINEAR(ATD_TYPE_IDX(attr_idx)) != TYP_LINEAR(type_idx)) { 05129 AT_TYPED(attr_idx) = TRUE; 05130 05131 /* If this is character, make sure the function is not */ 05132 /* referenced in its own character length. This is obscure, */ 05133 /* but we're in an error situation anyway - so we might as */ 05134 /* well do it right. */ 05135 05136 if (TYP_TYPE(type_idx) == Character && 05137 TYP_FLD(type_idx) == AT_Tbl_Idx && 05138 find_attr_in_ir(attr_idx, 05139 ATD_TMP_IDX(TYP_IDX(type_idx)), 05140 &opnd)) { 05141 AT_DCL_ERR(attr_idx) = TRUE; 05142 PRINTMSG(OPND_LINE_NUM(opnd), 1035, Error, 05143 OPND_COL_NUM(opnd), 05144 AT_OBJ_NAME_PTR(attr_idx)); 05145 } 05146 else if (SCP_IMPL_NONE(curr_scp_idx)) { /* IMPLICIT NONE in scope */ 05147 PRINTMSG(id_line, 1424, Error, id_column, 05148 AT_OBJ_NAME_PTR(attr_idx)); 05149 } 05150 else { 05151 PRINTMSG(id_line, 827, Error, 05152 id_column, 05153 AT_OBJ_NAME_PTR(attr_idx), 05154 get_basic_type_str(ATD_TYPE_IDX(attr_idx))); 05155 } 05156 } 05157 else { 05158 05159 if (SCP_IMPL_NONE(curr_scp_idx)) { /* IMPLICIT NONE in scope */ 05160 PRINTMSG(id_line, 1423, Ansi, id_column, 05161 AT_OBJ_NAME_PTR(attr_idx)); 05162 } 05163 set_type = TRUE; 05164 } 05165 break; 05166 05167 default: 05168 break; 05169 05170 } /* End switch */ 05171 05172 if (set_type) { 05173 05174 if (AT_TYPED(attr_idx)) { 05175 ptr = get_basic_type_str(type_idx); 05176 05177 if (type_idx == ATD_TYPE_IDX(attr_idx)) { 05178 PRINTMSG(id_line, 1259, Ansi, id_column, 05179 AT_OBJ_NAME_PTR(attr_idx), ptr); 05180 } 05181 else { 05182 ptr2 = get_basic_type_str(ATD_TYPE_IDX(attr_idx)); 05183 PRINTMSG(id_line, 550, Error, id_column, 05184 AT_OBJ_NAME_PTR(attr_idx), ptr2, ptr); 05185 } 05186 } 05187 else { 05188 AT_TYPED(attr_idx) = TRUE; 05189 ATD_TYPE_IDX(attr_idx) = type_idx; 05190 } 05191 } 05192 05193 EXIT: 05194 05195 TRACE (Func_Exit, "merge_type", NULL); 05196 05197 return; 05198 05199 } /* merge_type */ 05200 05201 05202 /******************************************************************************\ 05203 |* *| 05204 |* Description: *| 05205 |* Issues error 206 when an attribute is used in the wrong context. *| 05206 |* Uses the TOKEN to get the line and column number. *| 05207 |* *| 05208 |* Input parameters: *| 05209 |* attr_str -> String to go in message, with name of attribute. *| 05210 |* *| 05211 |* Output parameters: *| 05212 |* NONE *| 05213 |* *| 05214 |* Returns: *| 05215 |* NONE *| 05216 |* *| 05217 \******************************************************************************/ 05218 static void issue_attr_blk_err(char *attr_str) 05219 05220 { 05221 boolean issue_msg = TRUE; 05222 char *msg_str; 05223 05224 05225 TRACE (Func_Entry, "issue_attr_blk_err", NULL); 05226 05227 switch (CURR_BLK) { 05228 05229 case Unknown_Blk: 05230 PRINTMSG(TOKEN_LINE(token), 160, Internal, TOKEN_COLUMN(token)); 05231 break; 05232 05233 case Program_Blk: 05234 msg_str = "PROGRAM"; 05235 break; 05236 05237 case Function_Blk: 05238 msg_str = "FUNCTION"; 05239 break; 05240 05241 case Subroutine_Blk: 05242 msg_str = "SUBROUTINE"; 05243 break; 05244 05245 case Module_Blk: 05246 msg_str = "MODULE"; 05247 break; 05248 05249 case Blockdata_Blk: 05250 msg_str = "BLOCKDATA"; 05251 break; 05252 05253 case Interface_Body_Blk: 05254 case Internal_Blk: 05255 case Module_Proc_Blk: 05256 msg_str = (ATP_PGM_UNIT(CURR_BLK_NAME) == Function) ? "FUNCTION" : 05257 "SUBROUTINE"; 05258 break; 05259 05260 case Where_Then_Blk: 05261 case Where_Else_Blk: 05262 case Where_Else_Mask_Blk: 05263 case Select_Blk: 05264 case Case_Blk: 05265 case Do_Blk: 05266 case If_Blk: 05267 case If_Then_Blk: 05268 case If_Else_If_Blk: 05269 case If_Else_Blk: 05270 case Contains_Blk: 05271 case Derived_Type_Blk: 05272 case Interface_Blk: 05273 05274 /* These things are caught earlier. The type declaration statement */ 05275 /* is not allowed in any of the executable blocks, so don't print */ 05276 /* another out of context msg. If the type declaration statement */ 05277 /* is found in a contains or an interface block, a parse error is */ 05278 /* issued, because the compiler thinks this is a FUNCTION stmt. */ 05279 /* If the type declaration statement is in a Derived_Type_Blk it */ 05280 /* won't be here, because it's parsed as a component decl stmt. */ 05281 05282 issue_msg = FALSE; 05283 break; 05284 05285 05286 } /* End switch */ 05287 05288 if (issue_msg) { 05289 AT_DCL_ERR(AT_WORK_IDX) = TRUE; 05290 PRINTMSG(TOKEN_LINE(token), 595, Error, 05291 TOKEN_COLUMN(token), 05292 attr_str, 05293 msg_str); 05294 } 05295 05296 TRACE (Func_Exit, "issue_attr_blk_err", NULL); 05297 05298 return; 05299 05300 } /* issue_attr_blk_err */ 05301 05302 05303 /******************************************************************************\ 05304 |* *| 05305 |* Description: *| 05306 |* Parse DATA implied-DO loops. *| 05307 |* *| 05308 |* Input parameters: *| 05309 |* NONE *| 05310 |* *| 05311 |* Output parameters: *| 05312 |* result_opnd - opnd_type, points to root of tree returned. *| 05313 |* *| 05314 |* Returns: *| 05315 |* TRUE if parsed ok *| 05316 |* *| 05317 |* Algorithm notes: *| 05318 |* This procedure is recursive. *| 05319 |* This procedure duplicates the IR generation of parse_imp_do (which is *| 05320 |* used to parse I/O implied-DOs). *| 05321 |* *| 05322 \******************************************************************************/ 05323 05324 static boolean parse_data_imp_do(opnd_type *result_opnd) 05325 05326 { 05327 int attr_idx; 05328 int column; 05329 int expr_start_col; 05330 int expr_start_line; 05331 boolean found_attr; 05332 boolean had_equal = FALSE; 05333 int imp_do_start_col; 05334 int imp_do_start_line; 05335 int ir_idx; 05336 int line; 05337 int list_idx; 05338 int list2_idx = NULL_IDX; 05339 int name_column; 05340 int name_idx; 05341 int name_line; 05342 opnd_type opnd; 05343 boolean parsed_ok = TRUE; 05344 boolean save_in_implied_do; 05345 05346 05347 TRACE (Func_Entry, "parse_data_imp_do", NULL); 05348 05349 /* Generate the Implied_Do IR and set the result opnd to point at it. */ 05350 05351 NTR_IR_TBL(ir_idx); 05352 IR_OPR(ir_idx) = Implied_Do_Opr; 05353 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 05354 IR_LINE_NUM(ir_idx) = LA_CH_LINE; 05355 IR_COL_NUM(ir_idx) = LA_CH_COLUMN; 05356 OPND_FLD((*result_opnd)) = IR_Tbl_Idx; 05357 OPND_IDX((*result_opnd)) = ir_idx; 05358 05359 imp_do_start_line = LA_CH_LINE; 05360 imp_do_start_col = LA_CH_COLUMN; 05361 save_in_implied_do = in_implied_do; 05362 in_implied_do = TRUE; 05363 05364 /* Parse the targets. A target can be another implied-DO or a (hopefully */ 05365 /* subscripted) variable name. Recurse if the target is an implied-DO. */ 05366 /* If not an implied-DO keep going as long as we keep hitting commas. The */ 05367 /* last (hopefully UNsubscripted) item in the list should be the implied-DO*/ 05368 /* variable. */ 05369 05370 do { 05371 05372 /* Eat the left paren (if entering this loop) or comma (if continuing */ 05373 /* this loop). */ 05374 05375 NEXT_LA_CH; 05376 05377 if (LA_CH_VALUE == LPAREN) { 05378 05379 if (parsed_ok = parse_data_imp_do(&opnd)) { 05380 05381 if (LA_CH_VALUE != COMMA) { 05382 parsed_ok = FALSE; 05383 parse_err_flush(Find_Rparen, ","); 05384 continue; 05385 } 05386 } 05387 else { 05388 05389 if (LA_CH_VALUE != EOS) { 05390 parse_err_flush(Find_Rparen, NULL); 05391 NEXT_LA_CH; 05392 } 05393 05394 goto EXIT; 05395 } 05396 } 05397 else if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 05398 05399 if (LA_CH_VALUE == EQUAL) { 05400 had_equal = TRUE; 05401 05402 parsed_ok = parse_deref(&opnd, NULL_IDX) && parsed_ok; 05403 05404 if (parsed_ok) { 05405 mark_attr_defined(&opnd); 05406 } 05407 05408 if (OPND_FLD(opnd) == AT_Tbl_Idx && 05409 AT_OBJ_CLASS(OPND_IDX(opnd)) == Data_Obj) { 05410 05411 ATD_SEEN_AS_LCV(OPND_IDX(opnd)) = TRUE; 05412 05413 if (ATD_SEEN_IN_IMP_DO(OPND_IDX(opnd)) && 05414 (AT_DEF_LINE(OPND_IDX(opnd)) > imp_do_start_line || 05415 (AT_DEF_LINE(OPND_IDX(opnd)) == imp_do_start_line && 05416 AT_DEF_COLUMN(OPND_IDX(opnd)) > imp_do_start_col))) { 05417 05418 /* clear ATD_SEEN_IN_IMP_DO */ 05419 05420 ATD_SEEN_IN_IMP_DO(OPND_IDX(opnd)) = FALSE; 05421 } 05422 } 05423 05424 /* Set up right operand (the implied-DO variable) of the */ 05425 /* Implied_Do IR. The implied-DO variable must be a named */ 05426 /* variable; if it's not, the error (199) will be caught down */ 05427 /* below in target processing. */ 05428 05429 if (OPND_FLD(opnd) == AT_Tbl_Idx && 05430 AT_OBJ_CLASS(OPND_IDX(opnd)) == Data_Obj) { 05431 attr_idx = OPND_IDX(opnd); 05432 } 05433 05434 NTR_IR_LIST_TBL(list_idx); 05435 IR_FLD_R(ir_idx) = IL_Tbl_Idx; 05436 IR_IDX_R(ir_idx) = list_idx; 05437 COPY_OPND(IL_OPND(list_idx), opnd); 05438 05439 /* Eat the equal sign. */ 05440 /* Generate an IL entry to hold the loop start value and attach */ 05441 /* it to the LCV IL entry. Parse the loop start value expression.*/ 05442 05443 NEXT_LA_CH; 05444 05445 NTR_IR_LIST_TBL(list2_idx); 05446 IL_NEXT_LIST_IDX(list_idx) = list2_idx; 05447 IL_PREV_LIST_IDX(list2_idx) = list_idx; 05448 expr_start_line = LA_CH_LINE; 05449 expr_start_col = LA_CH_COLUMN; 05450 parsed_ok = parse_expr(&opnd) && parsed_ok; 05451 COPY_OPND(IL_OPND(list2_idx), opnd); 05452 IL_LINE_NUM(list2_idx) = expr_start_line; 05453 IL_COL_NUM(list2_idx) = expr_start_col; 05454 05455 if (LA_CH_VALUE != COMMA) { 05456 parsed_ok = FALSE; 05457 parse_err_flush(Find_Rparen, ","); 05458 continue; 05459 } 05460 05461 /* Eat the comma following the start value expression. */ 05462 /* Generate an IL entry to hold the loop end value and attach it */ 05463 /* to the start value IL. Parse the end value expression. */ 05464 05465 NEXT_LA_CH; 05466 05467 NTR_IR_LIST_TBL(list_idx); 05468 IL_NEXT_LIST_IDX(list2_idx) = list_idx; 05469 IL_PREV_LIST_IDX(list_idx) = list2_idx; 05470 expr_start_line = LA_CH_LINE; 05471 expr_start_col = LA_CH_COLUMN; 05472 parsed_ok = parse_expr(&opnd) && parsed_ok; 05473 COPY_OPND(IL_OPND(list_idx), opnd); 05474 IL_LINE_NUM(list_idx) = expr_start_line; 05475 IL_COL_NUM(list_idx) = expr_start_col; 05476 05477 /* If a loop increment expression exists, generate an IL entry */ 05478 /* and attach it to the loop end value IL. Parse the increment */ 05479 /* value expression. */ 05480 05481 if (LA_CH_VALUE == COMMA) { 05482 NEXT_LA_CH; 05483 NTR_IR_LIST_TBL(list2_idx); 05484 IL_NEXT_LIST_IDX(list_idx) = list2_idx; 05485 IL_PREV_LIST_IDX(list2_idx) = list_idx; 05486 expr_start_line = LA_CH_LINE; 05487 expr_start_col = LA_CH_COLUMN; 05488 parsed_ok = parse_expr(&opnd) && parsed_ok; 05489 COPY_OPND(IL_OPND(list2_idx), opnd); 05490 IL_LINE_NUM(list2_idx) = expr_start_line; 05491 IL_COL_NUM(list2_idx) = expr_start_col; 05492 IR_LIST_CNT_R(ir_idx) = 4; 05493 } 05494 else { 05495 IR_LIST_CNT_R(ir_idx) = 3; 05496 } 05497 05498 break; 05499 } 05500 else { 05501 05502 /* Search for the target's Attr. If no Attr exists in the */ 05503 /* current scope, enter one (the target is being implicitly */ 05504 /* declared by its presence in the DATA stmt). */ 05505 05506 attr_idx = 05507 srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx); 05508 05509 if (attr_idx == NULL_IDX) { 05510 found_attr = FALSE; 05511 attr_idx = ntr_sym_tbl(&token, name_idx); 05512 LN_DEF_LOC(name_idx) = TRUE; 05513 SET_IMPL_TYPE(attr_idx); 05514 } 05515 else { 05516 found_attr = TRUE; 05517 05518 if (AT_REFERENCED(attr_idx) == Char_Rslt_Bound_Ref) { 05519 AT_ATTR_LINK(attr_idx) = NULL_IDX; 05520 LN_DEF_LOC(name_idx) = TRUE; 05521 } 05522 } 05523 05524 name_line = TOKEN_LINE(token); 05525 name_column = TOKEN_COLUMN(token); 05526 05527 05528 /* The target name is followed by a left paren (which normally */ 05529 /* means it's subscripted) or a percent (component to come): */ 05530 /* Parse the full reference. */ 05531 /* If the name the form of an array element reference, but was */ 05532 /* not declared locally to be an array, it's an error. */ 05533 /* Otherwise, fake up an opnd. */ 05534 /* Use merge_data to set AT_DEFINED, ATD_DATA_INIT, and ATD_CLASS.*/ 05535 05536 if (LA_CH_VALUE == LPAREN || LA_CH_VALUE == PERCENT) { 05537 05538 if (parse_deref(&opnd, NULL_IDX)) { 05539 05540 if (OPND_FLD(opnd) == IR_Tbl_Idx && 05541 IR_OPR(OPND_IDX(opnd)) == Call_Opr) { 05542 PRINTMSG(name_line, 699, Error, name_column); 05543 parsed_ok = FALSE; 05544 } 05545 05546 if (LA_CH_VALUE == EQUAL) { 05547 find_opnd_line_and_column(&opnd, &line, &column); 05548 PRINTMSG(line, 199, Error, column); 05549 parse_err_flush(Find_Rparen, NULL_IDX); 05550 parsed_ok = FALSE; 05551 } 05552 05553 } 05554 else { 05555 parse_err_flush(Find_Rparen, NULL); 05556 parsed_ok = FALSE; 05557 } 05558 05559 } 05560 else { 05561 OPND_LINE_NUM(opnd) = TOKEN_LINE(token); 05562 OPND_COL_NUM(opnd) = TOKEN_COLUMN(token); 05563 OPND_FLD(opnd) = AT_Tbl_Idx; 05564 OPND_IDX(opnd) = attr_idx; 05565 } 05566 05567 if (parsed_ok) { 05568 05569 if (! merge_data(found_attr, name_line, name_column, attr_idx)) { 05570 parsed_ok = FALSE; 05571 } 05572 } 05573 } 05574 } 05575 else { /* Not an implied-DO and not an identifier. */ 05576 parsed_ok = FALSE; 05577 parse_err_flush(Find_Rparen, 05578 (list2_idx == NULL_IDX) ? 05579 "data-i-do-object" : 05580 "data-i-do-object or data-i-do-variable"); 05581 } 05582 05583 /* Generate an IL entry for the target and attach the IL to the left */ 05584 /* operand chain of the Implied_Do IR. */ 05585 05586 NTR_IR_LIST_TBL(list_idx); 05587 COPY_OPND(IL_OPND(list_idx), opnd); 05588 05589 if (IR_IDX_L(ir_idx) == NULL_IDX) { 05590 IR_LIST_CNT_L(ir_idx) = 1; 05591 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 05592 IR_IDX_L(ir_idx) = list_idx; 05593 } 05594 else { 05595 IL_NEXT_LIST_IDX(list2_idx) = list_idx; 05596 IL_PREV_LIST_IDX(list_idx) = list2_idx; 05597 ++IR_LIST_CNT_L(ir_idx); 05598 } 05599 05600 list2_idx = list_idx; 05601 } 05602 while (LA_CH_VALUE == COMMA); 05603 05604 in_implied_do = save_in_implied_do; 05605 05606 if (LA_CH_VALUE == RPAREN) { 05607 05608 if (! SH_ERR_FLG(curr_stmt_sh_idx) && ! had_equal) { 05609 parsed_ok = FALSE; 05610 parse_err_flush(Find_Rparen, ","); 05611 } 05612 } 05613 else { 05614 05615 if (had_equal) { 05616 parse_err_flush(Find_EOS, 05617 (IR_LIST_CNT_R(ir_idx) == 3) ? ", or )" : ")"); 05618 } 05619 else { 05620 05621 if (IL_FLD(list2_idx) == AT_Tbl_Idx) { 05622 parse_err_flush(Find_EOS, "=, comma, or '(subscript-list)'"); 05623 } 05624 else { 05625 parse_err_flush(Find_EOS, ","); 05626 } 05627 05628 } 05629 05630 parsed_ok = FALSE; 05631 goto EXIT; 05632 } 05633 05634 NEXT_LA_CH; /* Eat the right paren. */ 05635 05636 EXIT: 05637 05638 TRACE (Func_Exit, "parse_data_imp_do", NULL); 05639 05640 return(parsed_ok); 05641 05642 } /* parse_data_imp_do */ 05643 05644 05645 /******************************************************************************\ 05646 |* *| 05647 |* Description: *| 05648 |* This calls bound_semantics to resolve the character to a constant *| 05649 |* length character for parameter initialization. *| 05650 |* *| 05651 |* Input parameters: *| 05652 |* NONE *| 05653 |* *| 05654 |* Output parameters: *| 05655 |* NONE *| 05656 |* *| 05657 |* Returns: *| 05658 |* NOTHING *| 05659 |* *| 05660 \******************************************************************************/ 05661 05662 void char_bounds_resolution(int attr_idx, 05663 boolean *chk_semantics) 05664 05665 { 05666 int tmp_idx; 05667 05668 05669 TRACE (Func_Entry, "char_bounds_resolution", NULL); 05670 05671 if (TYP_FLD(ATD_TYPE_IDX(attr_idx)) == CN_Tbl_Idx) { 05672 return; 05673 } 05674 05675 tmp_idx = TYP_IDX(ATD_TYPE_IDX(attr_idx)); 05676 xref_state = CIF_Symbol_Reference; 05677 no_func_expansion = TRUE; 05678 05679 /* Call bound_semantics. No IR will be generated in a valid */ 05680 /* case, so pass FALSE. */ 05681 05682 if (ATD_CLASS(tmp_idx) != Constant) { 05683 bound_semantics(tmp_idx, FALSE); 05684 } 05685 05686 char_len_resolution(attr_idx, TRUE); /* Needs to be a constant */ 05687 05688 if (TYP_CHAR_CLASS(ATD_TYPE_IDX(attr_idx)) != Const_Len_Char) { 05689 05690 /* The variable length character cannot be a parameter error will */ 05691 /* issue in fnd_semantic_err. This will go through */ 05692 /* char_len_resolution during decl_semantics for error recovery. */ 05693 05694 *chk_semantics = TRUE; 05695 } 05696 05697 no_func_expansion = FALSE; 05698 05699 TRACE (Func_Exit, "char_bounds_resolution", NULL); 05700 05701 return; 05702 05703 } /* char_bounds_resolution */ 05704 05705 05706 /******************************************************************************\ 05707 |* *| 05708 |* Description: *| 05709 |* This calls bound_semantics to resolve an array to a constant size *| 05710 |* array for parameter initialization. *| 05711 |* *| 05712 |* Input parameters: *| 05713 |* NONE *| 05714 |* *| 05715 |* Output parameters: *| 05716 |* NONE *| 05717 |* *| 05718 |* Returns: *| 05719 |* NOTHING *| 05720 |* *| 05721 \******************************************************************************/ 05722 05723 void array_bounds_resolution(int attr_idx, 05724 boolean *chk_semantics) 05725 05726 { 05727 int bd_idx; 05728 int dim; 05729 05730 05731 TRACE (Func_Entry, "array_bounds_resolution", NULL); 05732 05733 bd_idx = ATD_ARRAY_IDX(attr_idx); 05734 05735 if (BD_RESOLVED(bd_idx)) { 05736 return; 05737 } 05738 05739 if (BD_ARRAY_CLASS(bd_idx) != Deferred_Shape) { 05740 xref_state = CIF_Symbol_Reference; 05741 no_func_expansion = TRUE; 05742 05743 /* Call bound_semantics for each bound. No IR will be generated */ 05744 /* in a valid case, so pass FALSE. */ 05745 05746 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 05747 05748 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx && 05749 ATD_CLASS(BD_LB_IDX(bd_idx, dim)) != Constant) { 05750 bound_semantics(BD_LB_IDX(bd_idx, dim), FALSE); 05751 05752 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx && 05753 ATD_CLASS(BD_LB_IDX(bd_idx, dim)) != Constant) { 05754 05755 /* This did not resolve to a constant. - May be okay */ 05756 05757 AT_REFERENCED(BD_LB_IDX(bd_idx, dim)) = Referenced; 05758 } 05759 } 05760 05761 if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx && 05762 ATD_CLASS(BD_UB_IDX(bd_idx, dim)) != Constant) { 05763 bound_semantics(BD_UB_IDX(bd_idx, dim), FALSE); 05764 05765 if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx && 05766 ATD_CLASS(BD_UB_IDX(bd_idx, dim)) != Constant) { 05767 05768 /* This did not resolve to a constant. - May be okay */ 05769 05770 AT_REFERENCED(BD_UB_IDX(bd_idx, dim)) = Referenced; 05771 } 05772 } 05773 } 05774 05775 no_func_expansion = FALSE; 05776 } 05777 05778 05779 /* TRUE means this must be a constant array. If it is not, */ 05780 /* array_dim_resolution will not set BD_RESOLVED and this */ 05781 /* array should get resolved during decl_semantics. */ 05782 05783 array_dim_resolution(attr_idx, FALSE); 05784 05785 /* Need to use ATD_ARRAY_IDX, because bd_idx may change in resolution */ 05786 05787 if (BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) != Explicit_Shape || 05788 BD_ARRAY_SIZE(ATD_ARRAY_IDX(attr_idx)) != Constant_Size) { 05789 *chk_semantics = TRUE; 05790 } 05791 05792 # ifdef COARRAY_FORTRAN 05793 bd_idx = ATD_PE_ARRAY_IDX(attr_idx); 05794 05795 if (bd_idx == NULL_IDX || 05796 BD_RESOLVED(bd_idx)) { 05797 return; 05798 } 05799 05800 if (BD_ARRAY_CLASS(bd_idx) != Deferred_Shape) { 05801 xref_state = CIF_Symbol_Reference; 05802 no_func_expansion = TRUE; 05803 05804 /* Call bound_semantics for each bound. No IR will be generated */ 05805 /* in a valid case, so pass FALSE. */ 05806 05807 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 05808 05809 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx && 05810 ATD_CLASS(BD_LB_IDX(bd_idx, dim)) != Constant) { 05811 bound_semantics(BD_LB_IDX(bd_idx, dim), FALSE); 05812 05813 if (BD_LB_FLD(bd_idx, dim) == AT_Tbl_Idx && 05814 ATD_CLASS(BD_LB_IDX(bd_idx, dim)) != Constant) { 05815 05816 /* This did not resolve to a constant. - May be okay */ 05817 05818 AT_REFERENCED(BD_LB_IDX(bd_idx, dim)) = Referenced; 05819 } 05820 } 05821 05822 if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx && 05823 ATD_CLASS(BD_UB_IDX(bd_idx, dim)) != Constant) { 05824 bound_semantics(BD_UB_IDX(bd_idx, dim), FALSE); 05825 05826 if (BD_UB_FLD(bd_idx, dim) == AT_Tbl_Idx && 05827 ATD_CLASS(BD_UB_IDX(bd_idx, dim)) != Constant) { 05828 05829 /* This did not resolve to a constant. - May be okay */ 05830 05831 AT_REFERENCED(BD_UB_IDX(bd_idx, dim)) = Referenced; 05832 } 05833 } 05834 } 05835 05836 no_func_expansion = FALSE; 05837 } 05838 05839 pe_array_dim_resolution(attr_idx); /* It must be a constant array */ 05840 05841 # endif 05842 TRACE (Func_Exit, "array_bounds_resolution", NULL); 05843 05844 return; 05845 05846 } /* array_bounds_resolution */ 05847 05848 05849 /******************************************************************************\ 05850 |* *| 05851 |* Description: *| 05852 |* Add the PARAMETER attribute to an attr. *| 05853 |* *| 05854 |* Input parameters: *| 05855 |* chk_semantics -> TRUE if semantic checking needs to be done. If this *| 05856 |* is FALSE, just add the attribute to the attr. *| 05857 |* attr_idx -> Attr index to add the EXTERNAL attribute to. *| 05858 |* line -> The line number of the object to add the attribute to *| 05859 |* column -> The column number of the object to add the attribute to *| 05860 |* opnd -> A pointer to an operand that holds the parsed constant. *| 05861 |* This routine does the semantic checking and folding of *| 05862 |* the constant. *| 05863 |* *| 05864 |* Output parameters: *| 05865 |* NONE *| 05866 |* *| 05867 |* Returns: *| 05868 |* NONE *| 05869 |* *| 05870 \******************************************************************************/ 05871 05872 static void merge_parameter(boolean chk_semantics, 05873 int attr_idx, 05874 int line, 05875 int column, 05876 opnd_type *opnd, 05877 expr_arg_type *const_exp_desc, 05878 int const_line, 05879 int const_column) 05880 05881 { 05882 int a_type_idx; 05883 int c_type_idx; 05884 char *c_char_ptr; 05885 char *char_ptr; 05886 long_type constant[MAX_WORDS_FOR_NUMERIC]; 05887 int const_idx; 05888 long64 i; 05889 char msg_str[45]; 05890 int o_column; 05891 int o_line; 05892 long_type the_constant; 05893 05894 05895 TRACE (Func_Entry, "merge_parameter", NULL); 05896 05897 if (chk_semantics) { 05898 05899 if (fnd_semantic_err(Obj_Constant, line, column, attr_idx, TRUE)) { 05900 goto EXIT; 05901 } 05902 05903 if ((AT_REFERENCED(attr_idx) >= Dcl_Bound_Ref || AT_DEFINED(attr_idx))) { 05904 AT_DCL_ERR(attr_idx) = TRUE; 05905 05906 if (ATD_CLASS(attr_idx) == Atd_Unknown) { 05907 05908 /* This was most likely referenced as a constant earlier. */ 05909 /* Issue a meaningful message and let it become a constant. */ 05910 05911 PRINTMSG(line, 1426, Error, column, 05912 AT_OBJ_NAME_PTR(attr_idx)); 05913 } 05914 else { /* This was referenced earlier and not as a constant. */ 05915 PRINTMSG(line, 559, Error, column, 05916 AT_OBJ_NAME_PTR(attr_idx), 05917 "PARAMETER"); 05918 goto EXIT; 05919 } 05920 } 05921 } 05922 05923 a_type_idx = ATD_TYPE_IDX(attr_idx); 05924 05925 if (TYP_TYPE(a_type_idx) == Structure && 05926 ATT_POINTER_CPNT(TYP_IDX(a_type_idx))) { 05927 PRINTMSG(line, 691, Error, column, 05928 AT_OBJ_NAME_PTR(attr_idx)); 05929 AT_DCL_ERR(attr_idx) = TRUE; 05930 goto EXIT; 05931 } 05932 05933 /* AT_DEFINED is set, so that parameter constants can be differentiated */ 05934 /* from compiler tmp constants. Compiler tmp constants are created by */ 05935 /* bounds resolution. They will not have AT_DEFINED set. CIF wants */ 05936 /* all parameters, whether they were referenced or not. Compiler tmps */ 05937 /* have AT_REFERENCED = Not_Referenced, but they still are Constants so */ 05938 /* they were going thru to CIF anyway. Now they don't if they don't */ 05939 /* have their AT_DEFINED flag set. */ 05940 05941 AT_DEFINED(attr_idx) = TRUE; 05942 ATD_CLASS(attr_idx) = Constant; 05943 05944 if (opnd == NULL_IDX || ! const_exp_desc->foldable) { 05945 05946 /* The initialization expression must be a constant. */ 05947 05948 find_opnd_line_and_column(opnd, &o_line, &o_column); 05949 PRINTMSG(o_line, 587, Error, o_column, 05950 AT_OBJ_NAME_PTR(attr_idx)); 05951 AT_DCL_ERR(attr_idx) = TRUE; 05952 ATD_CONST_IDX(attr_idx) = NULL_IDX; 05953 ATD_FLD(attr_idx) = NO_Tbl_Idx; 05954 goto EXIT; 05955 } 05956 05957 05958 while (OPND_FLD((*opnd)) == IR_Tbl_Idx) { 05959 COPY_OPND((*opnd), IR_OPND_L(OPND_IDX((*opnd)))); 05960 } 05961 05962 ATD_FLD(attr_idx) = OPND_FLD((*opnd)); 05963 ATD_CONST_IDX(attr_idx) = OPND_IDX((*opnd)); 05964 05965 if (OPND_FLD((*opnd)) == AT_Tbl_Idx) { 05966 05967 /* since this has a data init'd tmp it must be */ 05968 /* marked as referenced, */ 05969 AT_REFERENCED(attr_idx) = Referenced; 05970 05971 /* change the tmps name to the constants name */ 05972 AT_NAME_IDX(OPND_IDX((*opnd))) = AT_NAME_IDX(attr_idx); 05973 AT_NAME_LEN(OPND_IDX((*opnd))) = AT_NAME_LEN(attr_idx); 05974 05975 c_type_idx = const_exp_desc->type_idx; 05976 find_opnd_line_and_column(opnd, &o_line, &o_column); 05977 05978 if (TYP_LINEAR(c_type_idx) == Long_Typeless) { 05979 PRINTMSG(o_line, 1133, Error, o_column); 05980 AT_DCL_ERR(attr_idx) = TRUE; 05981 goto EXIT; 05982 } 05983 05984 if (!check_asg_semantics(a_type_idx, c_type_idx, o_line, o_column)) { 05985 msg_str[0] = '\0'; 05986 strcpy(msg_str, get_basic_type_str(a_type_idx)); 05987 05988 PRINTMSG(line, 580, Error, column, 05989 AT_OBJ_NAME_PTR(attr_idx), 05990 msg_str, 05991 get_basic_type_str(c_type_idx)); 05992 05993 AT_DCL_ERR(attr_idx) = TRUE; 05994 goto EXIT; 05995 } 05996 05997 /* check array conformance */ 05998 05999 if (const_exp_desc->rank > 0) { 06000 06001 if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) { 06002 PRINTMSG(line, 835, Error, column, 06003 AT_OBJ_NAME_PTR(attr_idx)); 06004 AT_DCL_ERR(attr_idx) = TRUE; 06005 goto EXIT; 06006 } 06007 06008 06009 if (const_exp_desc->rank == BD_RANK(ATD_ARRAY_IDX(attr_idx))) { 06010 06011 for (i = 1; i <= const_exp_desc->rank; i++) { 06012 06013 if (fold_relationals(const_exp_desc->shape[i-1].idx, 06014 BD_XT_IDX(ATD_ARRAY_IDX(attr_idx),i), 06015 Ne_Opr)) { 06016 06017 PRINTMSG(line, 834, Error, column, AT_OBJ_NAME_PTR(attr_idx)); 06018 AT_DCL_ERR(attr_idx) = TRUE; 06019 goto EXIT; 06020 } 06021 } 06022 } 06023 else { 06024 PRINTMSG(line, 834, Error, column, AT_OBJ_NAME_PTR(attr_idx)); 06025 AT_DCL_ERR(attr_idx) = TRUE; 06026 goto EXIT; 06027 } 06028 } 06029 06030 06031 if (TYP_TYPE(a_type_idx) == Character && 06032 TYP_CHAR_CLASS(a_type_idx) == Assumed_Size_Char) { 06033 06034 /* attr gets length from constant */ 06035 06036 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 06037 TYP_TYPE(TYP_WORK_IDX) = Character; 06038 TYP_LINEAR(TYP_WORK_IDX) = TYP_LINEAR(a_type_idx); 06039 TYP_DESC(TYP_WORK_IDX) = TYP_DESC(a_type_idx); 06040 TYP_DCL_VALUE(TYP_WORK_IDX) = TYP_DCL_VALUE(a_type_idx); 06041 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char; 06042 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx; 06043 TYP_IDX(TYP_WORK_IDX) = TYP_IDX(c_type_idx); 06044 ATD_TYPE_IDX(attr_idx) = ntr_type_tbl(); 06045 06046 if (ATD_ARRAY_IDX(attr_idx)) { 06047 /* stride multipliers are not done since it was assumed size */ 06048 BD_RESOLVED(ATD_ARRAY_IDX(attr_idx)) = FALSE; 06049 array_dim_resolution(attr_idx, TRUE); 06050 ATD_ARRAY_IDX(ATD_CONST_IDX(attr_idx)) = ATD_ARRAY_IDX(attr_idx); 06051 } 06052 } 06053 } 06054 else if (a_type_idx != CN_TYPE_IDX(OPND_IDX((*opnd)))) { 06055 c_type_idx = CN_TYPE_IDX(OPND_IDX((*opnd))); 06056 find_opnd_line_and_column(opnd, &o_line, &o_column); 06057 06058 if (TYP_LINEAR(c_type_idx) == Long_Typeless) { 06059 PRINTMSG(o_line, 1133, Error, o_column); 06060 AT_DCL_ERR(attr_idx) = TRUE; 06061 goto EXIT; 06062 } 06063 06064 if (!check_asg_semantics(a_type_idx, c_type_idx, o_line, o_column)) { 06065 msg_str[0] = '\0'; 06066 strcpy(msg_str, get_basic_type_str(a_type_idx)); 06067 06068 PRINTMSG(line, 580, Error, column, 06069 AT_OBJ_NAME_PTR(attr_idx), 06070 msg_str, 06071 get_basic_type_str(c_type_idx)); 06072 06073 AT_DCL_ERR(attr_idx) = TRUE; 06074 goto EXIT; 06075 } 06076 06077 switch (TYP_TYPE(a_type_idx)) { 06078 case Integer: 06079 case Real: 06080 case Complex: 06081 case Logical: 06082 06083 if (TYP_TYPE(c_type_idx) == Character) { 06084 /* change to typeless constant */ 06085 /* BRIANJ - Should we use cvrt to do this? */ 06086 the_constant = CN_CONST(OPND_IDX((*opnd))); 06087 06088 /* TYPELESS_DEFAULT_TYPE is default index for a Typeless of */ 06089 /* length equal to the number of bits in a word. */ 06090 06091 OPND_IDX((*opnd)) = ntr_const_tbl(TYPELESS_DEFAULT_TYPE, 06092 FALSE, 06093 &the_constant); 06094 c_type_idx = TYPELESS_DEFAULT_TYPE; 06095 } 06096 06097 if (TYP_LINEAR(a_type_idx) == TYP_LINEAR(c_type_idx)) { 06098 /* intentionally blank */ 06099 } 06100 else { 06101 find_opnd_line_and_column(opnd, &o_line, &o_column); 06102 06103 if (folder_driver((char *)&CN_CONST(OPND_IDX((*opnd))), 06104 c_type_idx, 06105 NULL, 06106 NULL_IDX, 06107 constant, 06108 &a_type_idx, 06109 o_line, 06110 o_column, 06111 1, 06112 Cvrt_Opr)) { 06113 06114 /* Enter with the attr's type - but make it Default_Typed */ 06115 06116 ATD_FLD(attr_idx) = CN_Tbl_Idx; 06117 ATD_CONST_IDX(attr_idx) = ntr_const_tbl(TYP_LINEAR(a_type_idx), 06118 FALSE, 06119 constant); 06120 } 06121 } 06122 break; 06123 06124 06125 case Character: 06126 06127 if (TYP_TYPE(c_type_idx) != Character && 06128 TYP_TYPE(c_type_idx) != Typeless) { 06129 06130 /* should flag error here? */ 06131 } 06132 else if (TYP_CHAR_CLASS(a_type_idx) == Assumed_Size_Char) { 06133 06134 /* attr gets length from constant */ 06135 06136 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 06137 TYP_TYPE(TYP_WORK_IDX) = Character; 06138 TYP_LINEAR(TYP_WORK_IDX) = TYP_LINEAR(a_type_idx); 06139 TYP_DESC(TYP_WORK_IDX) = TYP_DESC(a_type_idx); 06140 TYP_DCL_VALUE(TYP_WORK_IDX) = TYP_DCL_VALUE(a_type_idx); 06141 TYP_CHAR_CLASS(TYP_WORK_IDX)= Const_Len_Char; 06142 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx; 06143 TYP_IDX(TYP_WORK_IDX) = TYP_IDX(c_type_idx); 06144 ATD_TYPE_IDX(attr_idx) = ntr_type_tbl(); 06145 } 06146 else if (TYP_IDX(a_type_idx) != TYP_IDX(c_type_idx)) { 06147 06148 /* Assume that these are both CN_Tbl_Idx. Create a new constant */ 06149 /* for the right length and put the original string in it. */ 06150 /* Truncate or blank pad to fit. NULL_IDX to ntr_const_tbl */ 06151 /* that the caller will add the constant to the constant pool. */ 06152 06153 const_idx = ntr_const_tbl(a_type_idx, TRUE, NULL_IDX); 06154 06155 char_ptr = (char *)&CN_CONST(const_idx); 06156 c_char_ptr = (char *)&CN_CONST(OPND_IDX((*opnd))); 06157 06158 for (i = 0; i < CN_INT_TO_C(TYP_IDX(a_type_idx)); i++) { 06159 char_ptr[i] = (i >= CN_INT_TO_C(TYP_IDX(c_type_idx))) ? 06160 ' ' : c_char_ptr[i]; 06161 } 06162 06163 /* blank pad the new constant to a word boundary */ 06164 06165 while ((++i) % TARGET_CHARS_PER_WORD != 0) { 06166 char_ptr[i] = ' '; 06167 } 06168 06169 ATD_FLD(attr_idx) = CN_Tbl_Idx; 06170 ATD_CONST_IDX(attr_idx) = const_idx; 06171 } 06172 break; 06173 } 06174 } 06175 06176 if (cif_flags & INFO_RECS) { 06177 cif_named_constant_rec(attr_idx, const_line, const_column); 06178 } 06179 06180 EXIT: 06181 06182 TRACE (Func_Exit, "merge_parameter", NULL); 06183 06184 return; 06185 06186 } /* merge_parameter */ 06187 06188 /******************************************************************************\ 06189 |* *| 06190 |* Description: *| 06191 |* If we're going to issue a type not defined message, try to give *| 06192 |* more info to the user, by checking if this is an interface block. *| 06193 |* If it is, then check if the type is defined there. If it is, then *| 06194 |* issue a message about not being able to host associate from the *| 06195 |* parent of the interface block. *| 06196 |* *| 06197 |* Input parameters: *| 06198 |* attr_idx -> Attr index of the type. *| 06199 |* line -> Line number to issue message for *| 06200 |* column -> Column number to issue message for. *| 06201 |* *| 06202 |* Output parameters: *| 06203 |* NONE *| 06204 |* *| 06205 |* Returns: *| 06206 |* NONE *| 06207 |* *| 06208 \******************************************************************************/ 06209 06210 void issue_undefined_type_msg(int attr_idx, 06211 int line, 06212 int column) 06213 06214 { 06215 int host_attr_idx; 06216 int host_name_idx; 06217 int msg_num = 126; 06218 int save_scp_idx; 06219 06220 06221 TRACE (Func_Entry, "issue_undefined_type_msg", NULL); 06222 06223 if (SCP_IS_INTERFACE(curr_scp_idx)) { 06224 save_scp_idx = curr_scp_idx; 06225 curr_scp_idx = SCP_PARENT_IDX(curr_scp_idx); 06226 06227 host_attr_idx = srch_sym_tbl(AT_OBJ_NAME_PTR(attr_idx), 06228 AT_NAME_LEN(attr_idx), 06229 &host_name_idx); 06230 06231 curr_scp_idx = save_scp_idx; 06232 06233 if (host_attr_idx != NULL_IDX && 06234 (AT_OBJ_CLASS(host_attr_idx) == Derived_Type && 06235 (AT_USE_ASSOCIATED(host_attr_idx) && 06236 !AT_NOT_VISIBLE(host_attr_idx)) || 06237 LN_DEF_LOC(host_name_idx))) { 06238 06239 /* Attempt to give more info to the user, by assuming they are */ 06240 /* trying to host associate into an interface body. Alert them */ 06241 /* that this is not allowed in Fortran 95. */ 06242 06243 msg_num = 1420; 06244 } 06245 } 06246 06247 PRINTMSG(line, msg_num, Error, column, AT_OBJ_NAME_PTR(attr_idx)); 06248 AT_DCL_ERR(attr_idx) = TRUE; 06249 06250 TRACE (Func_Exit, "issue_undefined_type_msg", NULL); 06251 06252 return; 06253 06254 } /* issue_undefined_type_msg */ 06255 06256 /******************************************************************************\ 06257 |* *| 06258 |* Description: *| 06259 |* parse_initializer parse the initializers on a DATA statement or in *| 06260 |* the slash format (extension) on the type declaration statement. *| 06261 |* *| 06262 |* Input parameters: *| 06263 |* init_ir_idx -> IR to attach the initializer to *| 06264 |* *| 06265 |* Output parameters: *| 06266 |* NONE *| 06267 |* *| 06268 |* Returns: *| 06269 |* NONE *| 06270 |* *| 06271 \******************************************************************************/ 06272 06273 static boolean parse_initializer(int init_ir_idx) 06274 06275 { 06276 int column; 06277 boolean found_star; 06278 boolean get_init_value; 06279 int il_idx; 06280 int ir_idx; 06281 int line; 06282 boolean ok; 06283 opnd_type opnd; 06284 int uopr_ir_idx = NULL_IDX; 06285 int value_chain_end; 06286 06287 06288 TRACE (Func_Entry, "parse_initializer", NULL); 06289 06290 get_init_value = TRUE; 06291 value_chain_end = FALSE; 06292 found_star = FALSE; 06293 IR_LIST_CNT_R(init_ir_idx) = 0; 06294 06295 while (get_init_value && LA_CH_VALUE != EOS) { 06296 NTR_IR_LIST_TBL(il_idx); 06297 06298 if (value_chain_end == NULL_IDX) { 06299 IR_FLD_R(init_ir_idx) = IL_Tbl_Idx; 06300 IR_IDX_R(init_ir_idx) = il_idx; 06301 } 06302 else { 06303 IL_NEXT_LIST_IDX(value_chain_end) = il_idx; 06304 IL_PREV_LIST_IDX(il_idx) = value_chain_end; 06305 } 06306 06307 value_chain_end = il_idx; 06308 ++IR_LIST_CNT_R(init_ir_idx); 06309 06310 strcpy(parse_operand_insert, "data-stmt-repeat or data-stmt-constant"); 06311 06312 if (LA_CH_VALUE == MINUS || LA_CH_VALUE == PLUS) { 06313 NTR_IR_TBL(uopr_ir_idx); 06314 IR_OPR(uopr_ir_idx) = (LA_CH_VALUE == MINUS) ? Uminus_Opr : 06315 Uplus_Opr; 06316 IR_LINE_NUM(uopr_ir_idx) = LA_CH_LINE; 06317 IR_COL_NUM(uopr_ir_idx) = LA_CH_COLUMN; 06318 NEXT_LA_CH; 06319 } 06320 06321 if (!parse_operand(&opnd)) { 06322 parse_err_flush(Find_EOS, NULL); 06323 ok = FALSE; 06324 goto EXIT; 06325 } 06326 06327 if (OPND_FLD(opnd) == IR_Tbl_Idx && IR_OPR(OPND_IDX(opnd)) == Paren_Opr) { 06328 PRINTMSG(IR_LINE_NUM(OPND_IDX(opnd)), 197, Error, 06329 IR_COL_NUM(OPND_IDX(opnd)), 06330 "data-stmt-repeat or data-stmt-constant", "("); 06331 } 06332 06333 if (LA_CH_VALUE == STAR) { 06334 06335 /* The first was the repeat value. This should be the constant */ 06336 06337 found_star = TRUE; 06338 06339 if (uopr_ir_idx != NULL_IDX) { 06340 06341 /* Illegal to have a signed constant here. */ 06342 06343 uopr_ir_idx = NULL_IDX; 06344 find_opnd_line_and_column(&opnd, &line, &column); 06345 PRINTMSG(line, 542, Error, column); 06346 } 06347 06348 NTR_IR_TBL(ir_idx); 06349 IR_OPR(ir_idx) = Rep_Count_Opr; 06350 IR_LINE_NUM(ir_idx) = LA_CH_LINE; 06351 IR_COL_NUM(ir_idx) = LA_CH_COLUMN; 06352 06353 COPY_OPND(IR_OPND_L(ir_idx), opnd); 06354 06355 data_repeat_semantics(ir_idx); 06356 06357 NEXT_LA_CH; /* Eat the asterisk */ 06358 06359 if (LA_CH_VALUE == MINUS || LA_CH_VALUE == PLUS) { 06360 NTR_IR_TBL(uopr_ir_idx); 06361 IR_OPR(uopr_ir_idx) = (LA_CH_VALUE == MINUS) ? Uminus_Opr : 06362 Uplus_Opr; 06363 IR_LINE_NUM(uopr_ir_idx) = LA_CH_LINE; 06364 IR_COL_NUM(uopr_ir_idx) = LA_CH_COLUMN; 06365 NEXT_LA_CH; 06366 } 06367 06368 strcpy(parse_operand_insert, "data-stmt-constant"); 06369 06370 if (!parse_operand(&opnd)) { 06371 parse_err_flush(Find_EOS, NULL); 06372 goto EXIT; 06373 } 06374 06375 if (OPND_FLD(opnd) == IR_Tbl_Idx && 06376 IR_OPR(OPND_IDX(opnd)) == Paren_Opr) { 06377 PRINTMSG(IR_LINE_NUM(OPND_IDX(opnd)), 197, Error, 06378 IR_COL_NUM(OPND_IDX(opnd)), 06379 "data-stmt-constant", "("); 06380 } 06381 06382 constant_value_semantics(&opnd, uopr_ir_idx); 06383 06384 COPY_OPND(IR_OPND_R(ir_idx), opnd); 06385 06386 OPND_FLD(opnd) = IR_Tbl_Idx; 06387 OPND_IDX(opnd) = ir_idx; 06388 } 06389 else { /* Do some necessary pass 1 semantic checks for constant */ 06390 constant_value_semantics(&opnd, uopr_ir_idx); 06391 } 06392 06393 uopr_ir_idx = NULL_IDX; 06394 06395 COPY_OPND(IL_OPND(il_idx), opnd); 06396 06397 if (LA_CH_VALUE == COMMA) { 06398 NEXT_LA_CH; 06399 found_star = FALSE; 06400 } 06401 else { 06402 get_init_value = FALSE; 06403 } 06404 } /* End while */ 06405 06406 if (LA_CH_VALUE == SLASH) { 06407 NEXT_LA_CH; 06408 ok = TRUE; 06409 } 06410 else { 06411 parse_err_flush(Find_EOS, 06412 (found_star) ? "comma or /" : "comma, *, or /"); 06413 ok = FALSE; 06414 } 06415 06416 EXIT: 06417 06418 TRACE (Func_Exit, "parse_initializer", NULL); 06419 06420 return(ok); 06421 06422 } /* parse_initializer */
1.7.6.1 
