00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027
00028
00029
00030
00031
00032
00033
00034
00035
00036
00037 static char USMID[] = "\n@(#)5.0_pl/sources/p_utils.c 5.5 09/09/99 12:47:48\n";
00038
00039 # include "defines.h"
00040
00041 # include "host.m"
00042 # include "host.h"
00043 # include "target.m"
00044 # include "target.h"
00045
00046 # include "globals.m"
00047 # include "tokens.m"
00048 # include "sytb.m"
00049 # include "p_globals.m"
00050 # include "debug.m"
00051
00052 # include "globals.h"
00053 # include "tokens.h"
00054 # include "sytb.h"
00055 # include "p_globals.h"
00056
00057
00058
00059
00060
00061
00062 static boolean create_kwd_text(opnd_type *, boolean);
00063 static void check_cmic_blk_branches(int, int, int, int);
00064 static void block_err_string(operator_type, char *, int *);
00065
00066 extern boolean star_expected;
00067
00068
00069
00070
00071
00072
00073
00074
00075
00076
00077
00078
00079
00080
00081
00082
00083
00084
00085
00086 boolean matched_specific_token (token_values_type specific_token,
00087 token_class_type token_class)
00088 {
00089 boolean match = FALSE;
00090 la_type save_la;
00091 token_type save_token;
00092 boolean valid_token;
00093
00094
00095 TRACE (Func_Entry, "matched_specific_token", NULL);
00096
00097 if (LA_CH_CLASS == Ch_Class_EOS && specific_token != Tok_EOS) {
00098
00099
00100
00101
00102 match = FALSE;
00103 }
00104 else {
00105 save_token = token;
00106 save_la = la_ch;
00107 valid_token = get_token (token_class);
00108
00109 if (valid_token && TOKEN_VALUE(token) == specific_token) {
00110 match = TRUE;
00111 }
00112 else {
00113 token = save_token;
00114 la_ch = save_la;
00115 reset_src_input(LA_CH_BUF_IDX, LA_CH_STMT_NUM);
00116 }
00117 }
00118
00119 TRACE (Func_Exit, "matched_specific_token",
00120 (match ? TOKEN_STR(token) : NULL));
00121 return (match);
00122
00123 }
00124
00125
00126
00127
00128
00129
00130
00131
00132
00133
00134
00135
00136
00137
00138
00139
00140
00141
00142
00143
00144
00145
00146
00147
00148
00149
00150
00151
00152
00153
00154
00155
00156
00157
00158
00159
00160
00161
00162
00163
00164
00165
00166
00167
00168
00169
00170
00171
00172
00173
00174 boolean parse_err_flush (search_type rule,
00175 char *str)
00176
00177 {
00178 boolean found_end;
00179 char *new_str;
00180 int paren_level;
00181 boolean found;
00182
00183
00184 TRACE (Func_Entry, "parse_err_flush", search_str[rule]);
00185
00186 if (str != NULL) {
00187 LA_CH_TO_ERR_STR(new_str, la_ch);
00188 PRINTMSG(LA_CH_LINE, 197, Error, LA_CH_COLUMN, str, new_str);
00189 }
00190
00191 if (rule == Find_EOS) {
00192 flush_LA_to_EOS();
00193 found_end = TRUE;
00194 }
00195 else if (rule != Find_None) {
00196
00197
00198 paren_level = 0;
00199 found = FALSE;
00200 found_end = FALSE;
00201
00202 if (rule == Find_Ref_End) {
00203
00204 if (LA_CH_CLASS != Ch_Class_Symbol &&
00205 LA_CH_VALUE != EOS) {
00206 flush_LA_to_symbol();
00207 }
00208 paren_level = 0;
00209 }
00210
00211 do {
00212
00213 if (rule == Find_Ref_End && paren_level == 0) {
00214 found = TRUE;
00215 }
00216
00217 switch (LA_CH_VALUE) {
00218 case RPAREN:
00219 if (paren_level == 0) {
00220
00221
00222
00223
00224 if (rule == Find_Rparen || rule == Find_Comma_Rparen ||
00225 rule == Find_Expr_End) {
00226 found = TRUE;
00227 }
00228 }
00229 else {
00230 paren_level--;
00231
00232 if (paren_level == 0 && rule == Find_Matching_Rparen) {
00233 found = TRUE;
00234 }
00235 else if (rule == Find_Ref_End) {
00236 found = FALSE;
00237 }
00238 }
00239 break;
00240
00241 case LPAREN:
00242 if (rule == Find_Lparen) {
00243 found = TRUE;
00244 }
00245 else {
00246 paren_level++;
00247
00248 if (rule == Find_Ref_End) {
00249 found = FALSE;
00250 }
00251 }
00252 break;
00253
00254 case COMMA:
00255 if (paren_level == 0 && rule >= Find_Comma) {
00256 found = TRUE;
00257 }
00258 break;
00259
00260 case SLASH:
00261
00262
00263
00264 if (paren_level == 0 && rule == Find_Comma_Slash) {
00265 found = TRUE;
00266 }
00267 else if (rule == Find_Expr_End &&
00268 paren_level == 0 &&
00269 matched_specific_token(Tok_Punct_Rbrkt,
00270 Tok_Class_Punct)) {
00271 found = TRUE;
00272 reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
00273 }
00274 break;
00275
00276 case COLON:
00277 if (rule == Find_Expr_End &&
00278 matched_specific_token(Tok_Punct_Colon,
00279 Tok_Class_Punct)) {
00280 found = TRUE;
00281 reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
00282 }
00283 else if (colon_recovery &&
00284 matched_specific_token(Tok_Punct_Colon_Colon,
00285 Tok_Class_Punct)) {
00286 found = TRUE;
00287 found_end = TRUE;
00288 reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
00289 }
00290 break;
00291
00292 case EOS:
00293 found = TRUE;
00294 found_end = TRUE;
00295 break;
00296
00297 case PERCENT:
00298 case USCORE:
00299 case DOLLAR:
00300 case AT_SIGN:
00301
00302 if (rule == Find_Ref_End) {
00303 found = FALSE;
00304 }
00305 break;
00306
00307 }
00308
00309 if (!found) {
00310 flush_LA_to_symbol();
00311 }
00312 }
00313 while (!found);
00314 }
00315
00316 TRACE (Func_Exit, "parse_err_flush", &LA_CH_VALUE);
00317
00318 return(!found_end);
00319
00320 }
00321
00322
00323
00324
00325
00326
00327
00328
00329
00330
00331
00332
00333
00334
00335
00336
00337
00338
00339 static boolean create_kwd_text(opnd_type *result_opnd,
00340 boolean function_call)
00341
00342 {
00343 int attr_idx;
00344 int ir_idx;
00345 int kwd_idx;
00346 opnd_type opnd;
00347 boolean parsed_ok = TRUE;
00348 la_type save_la;
00349 int type_idx;
00350
00351
00352 TRACE (Func_Entry, "create_kwd_text", NULL);
00353
00354
00355
00356 # ifdef _DEBUG
00357 if (LA_CH_VALUE != EQUAL) {
00358 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token),
00359 "create_kwd_text", "EQUAL");
00360 }
00361 # endif
00362
00363 NTR_IR_TBL(kwd_idx);
00364 OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
00365 OPND_IDX((*result_opnd)) = kwd_idx;
00366 IR_FLD_L(kwd_idx) = CN_Tbl_Idx;
00367 IR_OPR(kwd_idx) = Kwd_Opr;
00368 IR_TYPE_IDX(kwd_idx) = TYPELESS_DEFAULT_TYPE;
00369
00370 IR_LINE_NUM(kwd_idx) = LA_CH_LINE;
00371 IR_COL_NUM(kwd_idx) = LA_CH_COLUMN;
00372
00373 IR_LINE_NUM_L(kwd_idx) = TOKEN_LINE(token);
00374 IR_COL_NUM_L(kwd_idx) = TOKEN_COLUMN(token);
00375
00376
00377
00378 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
00379 TYP_TYPE(TYP_WORK_IDX) = Character;
00380 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE;
00381 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char;
00382 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx;
00383 TYP_IDX(TYP_WORK_IDX) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
00384 TOKEN_LEN(token));
00385 type_idx = ntr_type_tbl();
00386 IR_IDX_L(kwd_idx) = ntr_const_tbl(type_idx,
00387 TRUE,
00388 (long_type *)&(TOKEN_STR_WD(token,0)));
00389
00390 NEXT_LA_CH;
00391
00392
00393
00394
00395 if (LA_CH_VALUE == STAR && !function_call) {
00396 NEXT_LA_CH;
00397
00398 if (LA_CH_CLASS == Ch_Class_Digit &&
00399 MATCHED_TOKEN_CLASS(Tok_Class_Label) &&
00400 ! TOKEN_ERR(token)) {
00401
00402 attr_idx = check_label_ref();
00403
00404 IR_FLD_R(kwd_idx) = AT_Tbl_Idx;
00405 IR_IDX_R(kwd_idx) = attr_idx;
00406 IR_LINE_NUM_R(kwd_idx) = TOKEN_LINE(token);
00407 IR_COL_NUM_R(kwd_idx) = TOKEN_COLUMN(token);
00408 }
00409 else if (TOKEN_ERR(token)) {
00410 parse_err_flush(Find_Comma_Rparen, NULL);
00411 parsed_ok = FALSE;
00412 }
00413 else {
00414 parse_err_flush(Find_Comma_Rparen, "LABEL");
00415 parsed_ok = FALSE;
00416 }
00417 }
00418 else {
00419
00420 if (LA_CH_VALUE == PERCENT) {
00421 save_la = la_ch;
00422 NEXT_LA_CH;
00423
00424 MATCHED_TOKEN_CLASS(Tok_Class_Id);
00425
00426 if (TOKEN_LEN(token) == 3 &&
00427 strncmp(TOKEN_STR(token), "VAL", 3) == 0 &&
00428 LA_CH_VALUE == LPAREN) {
00429
00430 NEXT_LA_CH;
00431
00432 NTR_IR_TBL(ir_idx);
00433 IR_OPR(ir_idx) = Percent_Val_Opr;
00434 IR_LINE_NUM(ir_idx) = save_la.line;
00435 IR_COL_NUM(ir_idx) = save_la.column;
00436 IR_FLD_R(kwd_idx) = IR_Tbl_Idx;
00437 IR_IDX_R(kwd_idx) = ir_idx;
00438
00439 parsed_ok = parse_expr(&opnd) && parsed_ok;
00440 COPY_OPND(IR_OPND_L(ir_idx), opnd);
00441
00442 if (LA_CH_VALUE != RPAREN) {
00443 parse_err_flush(Find_EOS,")");
00444 parsed_ok = FALSE;
00445 }
00446 else {
00447 NEXT_LA_CH;
00448 }
00449 }
00450 else {
00451 reset_lex(save_la.stmt_buf_idx, save_la.stmt_num);
00452 parsed_ok = parse_expr(&opnd) && parsed_ok;
00453 COPY_OPND(IR_OPND_R(kwd_idx), opnd);
00454 }
00455 }
00456 else {
00457 parsed_ok = parse_expr(&opnd) && parsed_ok;
00458 COPY_OPND(IR_OPND_R(kwd_idx), opnd);
00459 }
00460 }
00461
00462 TRACE (Func_Exit, "create_kwd_text", NULL);
00463
00464 return(parsed_ok);
00465
00466 }
00467
00468
00469
00470
00471
00472
00473
00474
00475
00476
00477
00478
00479
00480
00481
00482
00483
00484
00485
00486 boolean parse_actual_arg_spec (opnd_type *result_opnd,
00487 boolean function_call,
00488 int pgm_attr_idx)
00489
00490 {
00491 int arg_cnt = 0;
00492 int attr_idx;
00493 boolean had_keyword = FALSE;
00494 int ir_idx;
00495 boolean issued_msg_128 = FALSE;
00496 int list_idx;
00497 int list2_idx;
00498 opnd_type opnd;
00499 boolean parsed_ok = TRUE;
00500 la_type save_la;
00501
00502
00503 TRACE (Func_Entry, "parse_actual_arg_spec", NULL);
00504
00505 # ifdef _DEBUG
00506 if (LA_CH_VALUE != LPAREN) {
00507
00508 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token),
00509 "parse_actual_arg_spec", "LPAREN");
00510 }
00511 # endif
00512
00513 OPND_FLD((*result_opnd)) = IL_Tbl_Idx;
00514 OPND_IDX((*result_opnd)) = NULL_IDX;
00515 list2_idx = NULL_IDX;
00516
00517 do {
00518 NEXT_LA_CH;
00519
00520 if (LA_CH_VALUE == RPAREN && arg_cnt == 0) {
00521 break;
00522 }
00523
00524 NTR_IR_LIST_TBL(list_idx);
00525 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
00526
00527 if (list2_idx == NULL_IDX) {
00528 OPND_IDX((*result_opnd)) = list_idx;
00529 }
00530 else {
00531 IL_NEXT_LIST_IDX(list2_idx) = list_idx;
00532 }
00533 list2_idx = list_idx;
00534
00535 if (LA_CH_VALUE == STAR && !function_call) {
00536
00537 NEXT_LA_CH;
00538
00539 if (LA_CH_CLASS == Ch_Class_Digit &&
00540 MATCHED_TOKEN_CLASS(Tok_Class_Label) &&
00541 ! TOKEN_ERR(token)) {
00542
00543 attr_idx = check_label_ref();
00544 if (AT_OBJ_CLASS(pgm_attr_idx) == Pgm_Unit) {
00545 ATP_HAS_ALT_RETURN(pgm_attr_idx) = TRUE;
00546 }
00547
00548 IL_FLD(list_idx) = AT_Tbl_Idx;
00549 IL_IDX(list_idx) = attr_idx;
00550 IL_LINE_NUM(list_idx) = TOKEN_LINE(token);
00551 IL_COL_NUM(list_idx) = TOKEN_COLUMN(token);
00552 }
00553 else if (TOKEN_ERR(token)) {
00554 parse_err_flush(Find_Comma_Rparen, NULL);
00555 parsed_ok = FALSE;
00556 }
00557 else {
00558 parse_err_flush(Find_Comma_Rparen, "LABEL");
00559 parsed_ok = FALSE;
00560 }
00561 }
00562 else if (next_arg_is_kwd_equal()) {
00563 MATCHED_TOKEN_CLASS(Tok_Class_Id);
00564
00565
00566 had_keyword = TRUE;
00567
00568 parsed_ok = create_kwd_text(&opnd, function_call) && parsed_ok;
00569 COPY_OPND(IL_OPND(list_idx), opnd);
00570 }
00571 else {
00572
00573 if (had_keyword) {
00574
00575
00576 if (! issued_msg_128) {
00577 PRINTMSG(LA_CH_LINE, 128, Error,
00578 LA_CH_COLUMN,NULL);
00579 issued_msg_128 = TRUE;
00580 parsed_ok = FALSE;
00581 }
00582 }
00583
00584 if (LA_CH_VALUE == PERCENT) {
00585 save_la = la_ch;
00586 NEXT_LA_CH;
00587
00588 MATCHED_TOKEN_CLASS(Tok_Class_Id);
00589
00590 if (TOKEN_LEN(token) == 3 &&
00591 strncmp(TOKEN_STR(token), "VAL", 3) == 0 &&
00592 LA_CH_VALUE == LPAREN) {
00593
00594 NEXT_LA_CH;
00595
00596 NTR_IR_TBL(ir_idx);
00597 IR_OPR(ir_idx) = Percent_Val_Opr;
00598 IR_LINE_NUM(ir_idx) = save_la.line;
00599 IR_COL_NUM(ir_idx) = save_la.column;
00600 IL_FLD(list_idx) = IR_Tbl_Idx;
00601 IL_IDX(list_idx) = ir_idx;
00602
00603 parsed_ok = parse_expr(&opnd) && parsed_ok;
00604 COPY_OPND(IR_OPND_L(ir_idx), opnd);
00605
00606 if (LA_CH_VALUE != RPAREN) {
00607 parse_err_flush(Find_EOS,")");
00608 parsed_ok = FALSE;
00609 }
00610 else {
00611 NEXT_LA_CH;
00612 }
00613 }
00614 else {
00615 reset_lex(save_la.stmt_buf_idx, save_la.stmt_num);
00616 parsed_ok = parse_expr(&opnd) && parsed_ok;
00617 COPY_OPND(IL_OPND(list_idx), opnd);
00618 }
00619 }
00620 else {
00621 parsed_ok = parse_expr(&opnd) && parsed_ok;
00622 COPY_OPND(IL_OPND(list_idx), opnd);
00623 }
00624 }
00625
00626 arg_cnt++;
00627 }
00628 while (LA_CH_VALUE == COMMA);
00629
00630 OPND_LIST_CNT((*result_opnd)) = arg_cnt;
00631
00632
00633
00634 if (arg_cnt > max_call_list_size) {
00635 max_call_list_size = arg_cnt;
00636 }
00637
00638 if (LA_CH_VALUE != RPAREN) {
00639 parse_err_flush(Find_EOS,", or )");
00640 parsed_ok = FALSE;
00641 }
00642 else {
00643 NEXT_LA_CH;
00644 }
00645
00646 TRACE (Func_Exit, "parse_actual_arg_spec", NULL);
00647
00648 return(parsed_ok);
00649
00650 }
00651
00652
00653
00654
00655
00656
00657
00658
00659
00660
00661
00662
00663
00664
00665
00666
00667
00668
00669
00670 boolean parse_deref (opnd_type *result_opnd,
00671 int struct_type_idx)
00672
00673 {
00674
00675 boolean ambiguous_ref = FALSE;
00676 int amb_attr_idx;
00677 int array_idx;
00678 int attr_idx;
00679 token_type attr_name;
00680 int check_attr;
00681 int col;
00682 int host_attr_idx;
00683 int host_name_idx;
00684 int i;
00685 int j;
00686 int ir_idx;
00687 int line;
00688 int list_idx;
00689 int list2_idx;
00690 int list3_idx;
00691 int name_idx;
00692 int new_attr_idx;
00693 int num_dims;
00694 opnd_type opnd;
00695 boolean parsed_ok = TRUE;
00696 int rank;
00697 int rslt_idx;
00698 int save_curr_scp_idx;
00699 int sn_idx;
00700 int struct_idx = NULL_IDX;
00701 int subs_idx = NULL_IDX;
00702 int substring_idx;
00703 token_type tmp_token;
00704 int trip_idx;
00705 int type_idx;
00706
00707
00708 TRACE (Func_Entry, "parse_deref", NULL);
00709
00710 attr_name = token;
00711
00712 if (struct_type_idx) {
00713 sn_idx = ATT_FIRST_CPNT_IDX(struct_type_idx);
00714 attr_idx = srch_linked_sn(TOKEN_STR(token),
00715 TOKEN_LEN(token),
00716 &sn_idx);
00717
00718 if (attr_idx == NULL_IDX) {
00719
00720 if (!AT_DCL_ERR(struct_type_idx)) {
00721 PRINTMSG(TOKEN_LINE(token), 213, Error,
00722 TOKEN_COLUMN(token), TOKEN_STR(token),
00723 AT_OBJ_NAME_PTR(struct_type_idx));
00724 }
00725 else {
00726 SH_ERR_FLG(curr_stmt_sh_idx) = TRUE;
00727 }
00728
00729 parse_err_flush(Find_Ref_End, NULL);
00730 parsed_ok = FALSE;
00731 goto EXIT;
00732 }
00733
00734 if (AT_USE_ASSOCIATED(struct_type_idx) &&
00735 ATT_PRIVATE_CPNT(struct_type_idx)) {
00736
00737 if (!AT_DCL_ERR(struct_type_idx)) {
00738 PRINTMSG(TOKEN_LINE(token), 882, Error,
00739 TOKEN_COLUMN(token),
00740 AT_OBJ_NAME_PTR(struct_type_idx),
00741 TOKEN_STR(token));
00742 }
00743 else {
00744 SH_ERR_FLG(curr_stmt_sh_idx) = TRUE;
00745 }
00746
00747 parse_err_flush(Find_Ref_End, NULL);
00748 parsed_ok = FALSE;
00749 goto EXIT;
00750 }
00751
00752
00753
00754
00755
00756 AT_LOCKED_IN(struct_type_idx) = TRUE;
00757 amb_attr_idx = attr_idx;
00758
00759 struct_idx = OPND_IDX((*result_opnd));
00760 IR_FLD_R(struct_idx) = AT_Tbl_Idx;
00761 IR_IDX_R(struct_idx) = attr_idx;
00762 IR_LINE_NUM_R(struct_idx) = TOKEN_LINE(token);
00763 IR_COL_NUM_R(struct_idx) = TOKEN_COLUMN(token);
00764 }
00765 else {
00766 attr_idx = srch_sym_tbl(TOKEN_STR(attr_name),
00767 TOKEN_LEN(attr_name),
00768 &name_idx);
00769
00770 if (attr_idx != NULL_IDX) {
00771
00772
00773
00774 if (LA_CH_VALUE == LPAREN &&
00775 AT_REFERENCED(attr_idx) == Not_Referenced &&
00776 !AT_NAMELIST_OBJ(attr_idx) &&
00777 AT_OBJ_CLASS(attr_idx) == Data_Obj &&
00778 ATD_CLASS(attr_idx) == Atd_Unknown &&
00779 !ATD_ALLOCATABLE(attr_idx) &&
00780 !ATD_TARGET(attr_idx) &&
00781 !ATD_POINTER(attr_idx) &&
00782 ATD_ARRAY_IDX(attr_idx) == NULL_IDX &&
00783 (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) != Character ||
00784 ! is_substring_ref())) {
00785
00786
00787
00788 save_curr_scp_idx = curr_scp_idx;
00789 curr_scp_idx = INTRINSIC_SCP_IDX;
00790 host_attr_idx = srch_sym_tbl(TOKEN_STR(attr_name),
00791 TOKEN_LEN(attr_name),
00792 &host_name_idx);
00793 curr_scp_idx = save_curr_scp_idx;
00794
00795 if (host_attr_idx != NULL_IDX) {
00796
00797 if (AT_IS_INTRIN(host_attr_idx) &&
00798 ATI_FIRST_SPECIFIC_IDX(host_attr_idx) == NULL_IDX) {
00799 complete_intrinsic_definition(host_attr_idx);
00800
00801 attr_idx = srch_sym_tbl(TOKEN_STR(attr_name),
00802 TOKEN_LEN(attr_name),
00803 &name_idx);
00804 }
00805
00806 type_idx = (AT_TYPED(attr_idx)) ? ATD_TYPE_IDX(attr_idx) :
00807 NULL_IDX;
00808
00809 COPY_VARIANT_ATTR_INFO(host_attr_idx,
00810 attr_idx,
00811 AT_OBJ_CLASS(host_attr_idx));
00812
00813 ATD_TYPE_IDX(attr_idx) = type_idx;
00814 AT_IS_INTRIN(attr_idx) = AT_IS_INTRIN(host_attr_idx);
00815 AT_ELEMENTAL_INTRIN(attr_idx)=AT_ELEMENTAL_INTRIN(host_attr_idx);
00816 host_attr_idx = NULL_IDX;
00817 }
00818 }
00819
00820 amb_attr_idx = attr_idx;
00821
00822 if (!LN_DEF_LOC(name_idx)) {
00823 ambiguous_ref = TRUE;
00824
00825 while (AT_ATTR_LINK(amb_attr_idx) != NULL_IDX) {
00826 amb_attr_idx = AT_ATTR_LINK(amb_attr_idx);
00827 }
00828 }
00829 }
00830 else {
00831
00832 ambiguous_ref = TRUE;
00833
00834
00835 host_attr_idx = srch_host_sym_tbl(TOKEN_STR(attr_name),
00836 TOKEN_LEN(attr_name),
00837 &host_name_idx,
00838 TRUE);
00839
00840
00841 if (host_attr_idx != NULL_IDX && IS_STMT_ENTITY(host_attr_idx)) {
00842
00843
00844
00845 host_attr_idx = NULL_IDX;
00846 }
00847
00848
00849
00850 if (host_attr_idx != NULL_IDX) {
00851 if (LA_CH_VALUE != LPAREN &&
00852 AT_IS_INTRIN(host_attr_idx) &&
00853 AT_OBJ_CLASS(host_attr_idx) == Interface) {
00854 host_attr_idx = NULL_IDX;
00855 }
00856 }
00857
00858 if (host_attr_idx != NULL_IDX) {
00859
00860
00861
00862 attr_idx = ntr_host_in_sym_tbl(&attr_name,
00863 name_idx,
00864 host_attr_idx,
00865 host_name_idx,
00866 TRUE);
00867
00868 amb_attr_idx = host_attr_idx;
00869
00870 while (AT_ATTR_LINK(amb_attr_idx) != NULL_IDX) {
00871 amb_attr_idx = AT_ATTR_LINK(amb_attr_idx);
00872 }
00873
00874 if (LA_CH_VALUE == LPAREN &&
00875 AT_IS_INTRIN(amb_attr_idx) &&
00876 AT_OBJ_CLASS(amb_attr_idx) == Interface) {
00877
00878
00879
00880
00881 if (AT_IS_INTRIN(host_attr_idx) &&
00882 ATI_FIRST_SPECIFIC_IDX(host_attr_idx) == NULL_IDX) {
00883 complete_intrinsic_definition(host_attr_idx);
00884 }
00885 COPY_ATTR_NTRY(attr_idx, amb_attr_idx);
00886 AT_CIF_SYMBOL_ID(attr_idx) = 0;
00887 AT_ATTR_LINK(attr_idx) = NULL_IDX;
00888 host_attr_idx = NULL_IDX;
00889 amb_attr_idx = attr_idx;
00890 AT_DEF_LINE(attr_idx) = TOKEN_LINE(token);
00891 AT_DEF_COLUMN(attr_idx) = TOKEN_COLUMN(token);
00892 }
00893 }
00894 else {
00895 attr_idx = ntr_sym_tbl(&attr_name, name_idx);
00896 amb_attr_idx = attr_idx;
00897
00898 if (LA_CH_VALUE == LPAREN && ! is_substring_ref()) {
00899
00900
00901
00902 AT_OBJ_CLASS(attr_idx) = Pgm_Unit;
00903 ATP_PROC(attr_idx) = Unknown_Proc;
00904 ATP_PGM_UNIT(attr_idx) = Function;
00905 ATP_SCP_IDX(attr_idx) = curr_scp_idx;
00906 MAKE_EXTERNAL_NAME(attr_idx,
00907 AT_NAME_IDX(attr_idx),
00908 AT_NAME_LEN(attr_idx));
00909
00910 CREATE_FUNC_RSLT(attr_idx, new_attr_idx);
00911
00912 if (expr_mode == Specification_Expr ||
00913 expr_mode == Initialization_Expr ||
00914 expr_mode == Stmt_Func_Expr) {
00915 AT_REFERENCED(new_attr_idx) = Dcl_Bound_Ref;
00916 }
00917 else {
00918 AT_REFERENCED(new_attr_idx) = Referenced;
00919 }
00920 SET_IMPL_TYPE(new_attr_idx);
00921 }
00922 else {
00923 SET_IMPL_TYPE(attr_idx);
00924 }
00925 }
00926 }
00927
00928 if (AT_OBJ_CLASS(amb_attr_idx) == Interface) {
00929
00930 if (ATI_FIRST_SPECIFIC_IDX(amb_attr_idx) == NULL_IDX) {
00931 check_attr = NULL_IDX;
00932 }
00933 else {
00934 check_attr = SN_ATTR_IDX(ATI_FIRST_SPECIFIC_IDX(amb_attr_idx));
00935 }
00936 }
00937 else {
00938 check_attr = amb_attr_idx;
00939 }
00940
00941 if (check_attr != NULL_IDX &&
00942 AT_OBJ_CLASS(check_attr) == Pgm_Unit &&
00943 ATP_NON_ANSI_INTRIN(check_attr)) {
00944 PRINTMSG(TOKEN_LINE(attr_name),
00945 787,
00946 Ansi,
00947 TOKEN_COLUMN(attr_name),
00948 TOKEN_STR(attr_name));
00949 }
00950
00951
00952
00953 OPND_FLD((*result_opnd)) = AT_Tbl_Idx;
00954 OPND_IDX((*result_opnd)) = attr_idx;
00955 OPND_LINE_NUM((*result_opnd)) = TOKEN_LINE(token);
00956 OPND_COL_NUM((*result_opnd)) = TOKEN_COLUMN(token);
00957
00958 if (in_implied_do) {
00959
00960 if (IS_STMT_ENTITY(attr_idx) &&
00961 ATD_FIRST_SEEN_IL_IDX(attr_idx) == NULL_IDX) {
00962
00963
00964
00965 NTR_IR_LIST_TBL(ATD_FIRST_SEEN_IL_IDX(attr_idx));
00966 IL_LINE_NUM(ATD_FIRST_SEEN_IL_IDX(attr_idx)) = TOKEN_LINE(token);
00967 IL_COL_NUM(ATD_FIRST_SEEN_IL_IDX(attr_idx)) = TOKEN_COLUMN(token);
00968 }
00969
00970 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
00971 ATD_SEEN_IN_IMP_DO(attr_idx) = TRUE;
00972 }
00973 }
00974 else if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
00975 ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE;
00976 }
00977 }
00978
00979
00980
00981 if (AT_DCL_ERR(attr_idx)) {
00982 SH_ERR_FLG(curr_stmt_sh_idx) = TRUE;
00983
00984 parse_err_flush(Find_Ref_End, NULL);
00985 parsed_ok = FALSE;
00986 goto EXIT;
00987 }
00988
00989
00990
00991 if (! ambiguous_ref &&
00992 AT_NOT_VISIBLE(attr_idx)) {
00993
00994 PRINTMSG(TOKEN_LINE(token), 486, Error, TOKEN_COLUMN(token),
00995 AT_OBJ_NAME_PTR(attr_idx),
00996 AT_OBJ_NAME_PTR(AT_MODULE_IDX((attr_idx))));
00997 parse_err_flush(Find_Ref_End, NULL);
00998 parsed_ok = FALSE;
00999 goto EXIT;
01000 }
01001
01002
01003
01004 switch (AT_OBJ_CLASS(amb_attr_idx)) {
01005 case Data_Obj :
01006
01007 if (ATD_SYMBOLIC_CONSTANT(amb_attr_idx)) {
01008
01009 if (AT_DEF_LINE(amb_attr_idx) == 0) {
01010 AT_DEF_LINE(amb_attr_idx) = TOKEN_LINE(token);
01011 AT_DEF_COLUMN(amb_attr_idx) = TOKEN_LINE(token);
01012 }
01013 }
01014 break;
01015
01016 case Pgm_Unit :
01017
01018 if (ATP_SCP_ALIVE(amb_attr_idx) &&
01019 ATP_PGM_UNIT(amb_attr_idx) == Function) {
01020 rslt_idx = ATP_RSLT_IDX(amb_attr_idx);
01021
01022 if (ATP_RSLT_NAME(amb_attr_idx) ||
01023 (LA_CH_VALUE == LPAREN &&
01024 TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) != Structure &&
01025 ATD_ARRAY_IDX(rslt_idx) == NULL_IDX &&
01026 (TYP_TYPE(ATD_TYPE_IDX(rslt_idx)) != Character ||
01027 ! is_substring_ref()))) {
01028
01029
01030
01031 if (LA_CH_VALUE != LPAREN &&
01032 LA_CH_VALUE != PERCENT) {
01033
01034
01035 goto EXIT;
01036 }
01037 else if (LA_CH_VALUE != LPAREN) {
01038
01039
01040 PRINTMSG(TOKEN_LINE(token), 722, Error, TOKEN_COLUMN(token),
01041 AT_OBJ_NAME_PTR(attr_idx));
01042 parse_err_flush(Find_Ref_End, NULL);
01043 parsed_ok = FALSE;
01044 goto EXIT;
01045 }
01046 else {
01047 NTR_IR_TBL(ir_idx);
01048 IR_OPR(ir_idx) = Call_Opr;
01049 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
01050 IR_IDX_L(ir_idx) = attr_idx;
01051 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token);
01052 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token);
01053 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
01054 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token);
01055 OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
01056 OPND_IDX((*result_opnd)) = ir_idx;
01057
01058 parsed_ok = parse_actual_arg_spec(&opnd, TRUE, attr_idx);
01059 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01060 goto EXIT;
01061 }
01062 }
01063 else {
01064
01065 attr_idx = rslt_idx;
01066 amb_attr_idx = attr_idx;
01067 OPND_IDX((*result_opnd)) = attr_idx;
01068
01069
01070 }
01071 }
01072 else if (LA_CH_VALUE == LPAREN) {
01073
01074 if (! ambiguous_ref &&
01075 ATP_PGM_UNIT(attr_idx) == Pgm_Unknown &&
01076 ATP_DCL_EXTERNAL(attr_idx)) {
01077
01078
01079
01080
01081 ATP_PGM_UNIT(attr_idx) = Function;
01082 CREATE_FUNC_RSLT(attr_idx, new_attr_idx);
01083
01084 SET_IMPL_TYPE(new_attr_idx);
01085 }
01086
01087 NTR_IR_TBL(ir_idx);
01088 IR_OPR(ir_idx) = Call_Opr;
01089 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
01090 IR_IDX_L(ir_idx) = attr_idx;
01091 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token);
01092 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token);
01093 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
01094 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token);
01095 OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
01096 OPND_IDX((*result_opnd)) = ir_idx;
01097
01098 parsed_ok = parse_actual_arg_spec(&opnd, TRUE, attr_idx);
01099 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01100 goto EXIT;
01101 }
01102 else {
01103 goto EXIT;
01104 }
01105
01106 break;
01107
01108 case Label :
01109
01110 parsed_ok = FALSE;
01111 goto EXIT;
01112
01113 case Derived_Type :
01114
01115 if (LA_CH_VALUE == LPAREN) {
01116
01117
01118
01119
01120
01121 NTR_IR_TBL(ir_idx);
01122 IR_OPR(ir_idx) = Struct_Construct_Opr;
01123 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
01124 IR_IDX_L(ir_idx) = attr_idx;
01125 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token);
01126 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token);
01127 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
01128 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token);
01129 OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
01130 OPND_IDX((*result_opnd)) = ir_idx;
01131
01132 parsed_ok = parse_actual_arg_spec(&opnd, TRUE, attr_idx);
01133 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01134 }
01135 else if (ambiguous_ref) {
01136
01137
01138 PRINTMSG(TOKEN_LINE(token), 322, Error, TOKEN_COLUMN(token),
01139 AT_OBJ_NAME_PTR(attr_idx));
01140 parse_err_flush(Find_Ref_End, NULL);
01141 parsed_ok = FALSE;
01142 }
01143 else {
01144
01145
01146 PRINTMSG(TOKEN_LINE(token), 151, Error, TOKEN_COLUMN(token),
01147 AT_OBJ_NAME_PTR(attr_idx));
01148 parse_err_flush(Find_Ref_End, NULL);
01149 parsed_ok = FALSE;
01150 }
01151
01152 goto EXIT;
01153
01154 case Interface :
01155
01156 if (LA_CH_VALUE != LPAREN && AT_IS_INTRIN(amb_attr_idx)) {
01157
01158 if (!ATI_INTRIN_PASSABLE(amb_attr_idx)) {
01159 PRINTMSG(TOKEN_LINE(token),
01160 860,
01161 Error,
01162 TOKEN_COLUMN(token),
01163 AT_OBJ_NAME_PTR(amb_attr_idx));
01164 AT_DCL_ERR(amb_attr_idx) = TRUE;
01165 goto EXIT;
01166 }
01167
01168
01169
01170 tmp_token = initial_token;
01171 TOKEN_COLUMN(tmp_token) = 1;
01172 TOKEN_LINE(tmp_token) = 1;
01173
01174 for (i = 0; i < MAX_INTRIN_MAP_SIZE; i++) {
01175 if ((strcmp(AT_OBJ_NAME_PTR(attr_idx),
01176 (char *)&intrin_map[i].id_str) == 0)) {
01177
01178 if (INTEGER_DEFAULT_TYPE == Integer_1 ||
01179 INTEGER_DEFAULT_TYPE == Integer_2 ||
01180 INTEGER_DEFAULT_TYPE == Integer_4) {
01181 if (intrin_map[i].id_str.string[0] == 'I' ||
01182 intrin_map[i].id_str.string[0] == 'N' ||
01183 intrin_map[i].id_str.string[0] == 'M' ||
01184 intrin_map[i].id_str.string[0] == 'L') {
01185 tmp_token = initial_token;
01186 TOKEN_COLUMN(tmp_token) = 1;
01187 TOKEN_LINE(tmp_token) = 1;
01188 strcpy((char *)&(TOKEN_STR(tmp_token)[0]),
01189 (char *)&intrin_map[i].mapped_4);
01190 }
01191 }
01192
01193 if (INTEGER_DEFAULT_TYPE == Integer_8) {
01194 if (intrin_map[i].id_str.string[0] == 'I' ||
01195 intrin_map[i].id_str.string[0] == 'N' ||
01196 intrin_map[i].id_str.string[0] == 'M' ||
01197 intrin_map[i].id_str.string[0] == 'L') {
01198 tmp_token = initial_token;
01199 TOKEN_COLUMN(tmp_token) = 1;
01200 TOKEN_LINE(tmp_token) = 1;
01201 strcpy((char *)&(TOKEN_STR(tmp_token)[0]),
01202 (char *)&intrin_map[i].mapped_8);
01203 }
01204 }
01205
01206 if (REAL_DEFAULT_TYPE == Real_4) {
01207 if (strcmp(AT_OBJ_NAME_PTR(attr_idx), "DIM") == 0 ||
01208 strcmp(AT_OBJ_NAME_PTR(attr_idx), "DPROD") == 0) {
01209 tmp_token = initial_token;
01210 TOKEN_COLUMN(tmp_token) = 1;
01211 TOKEN_LINE(tmp_token) = 1;
01212 strcpy((char *)&(TOKEN_STR(tmp_token)[0]),
01213 (char *)&intrin_map[i].mapped_4);
01214 }
01215 else if (intrin_map[i].id_str.string[0] != 'I' &&
01216 intrin_map[i].id_str.string[0] != 'N' &&
01217 intrin_map[i].id_str.string[0] != 'M' &&
01218 intrin_map[i].id_str.string[0] != 'D' &&
01219 intrin_map[i].id_str.string[0] != 'L') {
01220 tmp_token = initial_token;
01221 TOKEN_COLUMN(tmp_token) = 1;
01222 TOKEN_LINE(tmp_token) = 1;
01223 strcpy((char *)&(TOKEN_STR(tmp_token)[0]),
01224 (char *)&intrin_map[i].mapped_4);
01225 }
01226 }
01227
01228 if (REAL_DEFAULT_TYPE == Real_8) {
01229 if (strcmp(AT_OBJ_NAME_PTR(attr_idx), "DIM") == 0 ||
01230 strcmp(AT_OBJ_NAME_PTR(attr_idx), "DPROD") == 0) {
01231 tmp_token = initial_token;
01232 TOKEN_COLUMN(tmp_token) = 1;
01233 TOKEN_LINE(tmp_token) = 1;
01234 strcpy((char *)&(TOKEN_STR(tmp_token)[0]),
01235 (char *)&intrin_map[i].mapped_8);
01236 }
01237 else if (intrin_map[i].id_str.string[0] != 'I' &&
01238 intrin_map[i].id_str.string[0] != 'N' &&
01239 intrin_map[i].id_str.string[0] != 'M' &&
01240 intrin_map[i].id_str.string[0] != 'D' &&
01241 intrin_map[i].id_str.string[0] != 'L') {
01242 tmp_token = initial_token;
01243 TOKEN_COLUMN(tmp_token) = 1;
01244 TOKEN_LINE(tmp_token) = 1;
01245 strcpy((char *)&(TOKEN_STR(tmp_token)[0]),
01246 (char *)&intrin_map[i].mapped_8);
01247 }
01248 }
01249
01250 if (DOUBLE_DEFAULT_TYPE == Real_8) {
01251 if (intrin_map[i].id_str.string[0] == 'D' &&
01252 strcmp(AT_OBJ_NAME_PTR(attr_idx), "DPROD") != 0 &&
01253 strcmp(AT_OBJ_NAME_PTR(attr_idx), "DIM") != 0) {
01254 tmp_token = initial_token;
01255 TOKEN_COLUMN(tmp_token) = 1;
01256 TOKEN_LINE(tmp_token) = 1;
01257 strcpy((char *)&(TOKEN_STR(tmp_token)[0]),
01258 (char *)&intrin_map[i].mapped_4);
01259 }
01260 }
01261
01262 if (DOUBLE_DEFAULT_TYPE == Real_16) {
01263 if (intrin_map[i].id_str.string[0] == 'D' &&
01264 strcmp(AT_OBJ_NAME_PTR(attr_idx), "DPROD") != 0 &&
01265 strcmp(AT_OBJ_NAME_PTR(attr_idx), "DIM") != 0) {
01266 tmp_token = initial_token;
01267 TOKEN_COLUMN(tmp_token) = 1;
01268 TOKEN_LINE(tmp_token) = 1;
01269 strcpy((char *)&(TOKEN_STR(tmp_token)[0]),
01270 (char *)&intrin_map[i].mapped_8);
01271 }
01272 }
01273
01274 break;
01275 }
01276 }
01277
01278 TOKEN_LEN(tmp_token) = strlen((char *)&(TOKEN_STR(tmp_token)[0]));
01279 TOKEN_VALUE(tmp_token) = Tok_Id;
01280
01281 attr_idx = srch_sym_tbl(TOKEN_STR(tmp_token),
01282 TOKEN_LEN(tmp_token),
01283 &name_idx);
01284
01285 if (attr_idx == NULL_IDX) {
01286 attr_idx = ntr_sym_tbl(&tmp_token, name_idx);
01287 LN_DEF_LOC(name_idx) = TRUE;
01288 }
01289
01290 AT_OBJ_CLASS(attr_idx) = Pgm_Unit;
01291 ATP_PROC(attr_idx) = Intrin_Proc;
01292 ATP_PGM_UNIT(attr_idx) = Function;
01293 ATP_SCP_IDX(attr_idx) = curr_scp_idx;
01294 AT_IS_INTRIN(attr_idx) = TRUE;
01295 MAKE_EXTERNAL_NAME(attr_idx,
01296 AT_NAME_IDX(attr_idx),
01297 AT_NAME_LEN(attr_idx));
01298 ATP_INTERFACE_IDX(attr_idx) = amb_attr_idx;
01299
01300 CREATE_FUNC_RSLT(attr_idx, rslt_idx);
01301
01302 if (AT_TYPED(amb_attr_idx)) {
01303 ATD_TYPE_IDX(rslt_idx) = ATD_TYPE_IDX(amb_attr_idx);
01304 }
01305 else {
01306 j = ATI_INTRIN_TBL_IDX(amb_attr_idx)+1;
01307
01308 if (intrin_tbl[j].data_type == Real_16 ||
01309 intrin_tbl[j].data_type == Complex_16) {
01310 if (cmd_line_flags.s_default64 ||
01311 cmd_line_flags.s_float64) {
01312
01313 }
01314 else {
01315 j = j + 1;
01316 while (intrin_tbl[j].intrin_enum == 0 &&
01317 intrin_tbl[j].external == 0) {
01318 j = j + 1;
01319 }
01320 }
01321 }
01322
01323 ATD_TYPE_IDX(rslt_idx) = intrin_tbl[j].data_type;
01324
01325 # ifdef _TARGET64
01326
01327
01328
01329
01330 switch (intrin_tbl[j].data_type) {
01331 case Real_4 :
01332 ATD_TYPE_IDX(rslt_idx) =
01333 REAL_DEFAULT_TYPE;
01334 break;
01335 case Real_8 :
01336 ATD_TYPE_IDX(rslt_idx) =
01337 DOUBLE_DEFAULT_TYPE;
01338 break;
01339 case Complex_4 :
01340 ATD_TYPE_IDX(rslt_idx) =
01341 COMPLEX_DEFAULT_TYPE;
01342 break;
01343 case Complex_8 :
01344 ATD_TYPE_IDX(rslt_idx) =
01345 DOUBLE_COMPLEX_DEFAULT_TYPE;
01346 break;
01347 case Integer_4 :
01348 ATD_TYPE_IDX(rslt_idx) =
01349 INTEGER_DEFAULT_TYPE;
01350 break;
01351 }
01352 # endif
01353
01354
01355 # ifdef _TARGET32
01356
01357 switch (intrin_tbl[j].data_type) {
01358 case Real_4 :
01359 if (REAL_DEFAULT_TYPE == Real_8) {
01360 ATD_TYPE_IDX(rslt_idx) =
01361 REAL_DEFAULT_TYPE;
01362 }
01363 break;
01364 case Real_8 :
01365 if (DOUBLE_DEFAULT_TYPE == Real_16) {
01366 ATD_TYPE_IDX(rslt_idx) =
01367 DOUBLE_DEFAULT_TYPE;
01368 }
01369 break;
01370 case Complex_4 :
01371 if (COMPLEX_DEFAULT_TYPE == Complex_8) {
01372 ATD_TYPE_IDX(rslt_idx) =
01373 COMPLEX_DEFAULT_TYPE;
01374 }
01375 break;
01376 case Complex_8 :
01377 if (COMPLEX_DEFAULT_TYPE == Complex_16) {
01378 ATD_TYPE_IDX(rslt_idx) =
01379 DOUBLE_COMPLEX_DEFAULT_TYPE;
01380 }
01381 break;
01382 case Integer_4 :
01383 if (INTEGER_DEFAULT_TYPE == Integer_8) {
01384 ATD_TYPE_IDX(rslt_idx) =
01385 INTEGER_DEFAULT_TYPE;
01386 }
01387 break;
01388 }
01389
01390
01391
01392 if ((ATD_TYPE_IDX(rslt_idx) == Real_8 ||
01393 ATD_TYPE_IDX(rslt_idx) == Complex_8 ||
01394 ATD_TYPE_IDX(rslt_idx) == Real_16 ||
01395 ATD_TYPE_IDX(rslt_idx) == Complex_16) &&
01396 !on_off_flags.enable_double_precision) {
01397 j = j + 1;
01398 while (intrin_tbl[j].intrin_enum == 0 &&
01399 intrin_tbl[j].external == 0) {
01400 j = j + 1;
01401 }
01402 ATD_TYPE_IDX(rslt_idx) = intrin_tbl[j].data_type;
01403 }
01404 # endif
01405
01406 }
01407
01408 OPND_FLD((*result_opnd)) = AT_Tbl_Idx;
01409 OPND_IDX((*result_opnd)) = attr_idx;
01410 }
01411 else if (LA_CH_VALUE == LPAREN) {
01412
01413 NTR_IR_TBL(ir_idx);
01414 IR_OPR(ir_idx) = Call_Opr;
01415 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
01416 IR_IDX_L(ir_idx) = attr_idx;
01417 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token);
01418 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token);
01419 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
01420 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token);
01421 OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
01422 OPND_IDX((*result_opnd)) = ir_idx;
01423
01424 parsed_ok = parse_actual_arg_spec(&opnd, TRUE, attr_idx);
01425 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01426
01427 }
01428 goto EXIT;
01429
01430 case Namelist_Grp :
01431
01432 if (ambiguous_ref && LA_CH_VALUE == LPAREN) {
01433 NTR_IR_TBL(ir_idx);
01434 IR_OPR(ir_idx) = Call_Opr;
01435 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
01436 IR_IDX_L(ir_idx) = attr_idx;
01437 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token);
01438 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token);
01439 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
01440 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token);
01441 OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
01442 OPND_IDX((*result_opnd)) = ir_idx;
01443
01444 parsed_ok = parse_actual_arg_spec(&opnd, TRUE, attr_idx);
01445 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01446 }
01447 else {
01448 OPND_FLD((*result_opnd)) = AT_Tbl_Idx;
01449 OPND_IDX((*result_opnd)) = attr_idx;
01450 OPND_LINE_NUM((*result_opnd)) = TOKEN_LINE(token);
01451 OPND_COL_NUM((*result_opnd)) = TOKEN_COLUMN(token);
01452 }
01453 goto EXIT;
01454
01455 case Stmt_Func :
01456
01457 if (LA_CH_VALUE == LPAREN) {
01458 NTR_IR_TBL(ir_idx);
01459 IR_OPR(ir_idx) = Stmt_Func_Call_Opr;
01460 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
01461 IR_IDX_L(ir_idx) = attr_idx;
01462 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token);
01463 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token);
01464 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
01465 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token);
01466 OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
01467 OPND_IDX((*result_opnd)) = ir_idx;
01468
01469 parsed_ok = parse_actual_arg_spec(&opnd, TRUE, attr_idx);
01470 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01471 }
01472 else {
01473 parse_err_flush(Find_Ref_End, "(");
01474 }
01475
01476 goto EXIT;
01477 }
01478
01479 # ifdef COARRAY_FORTRAN
01480 if (LA_CH_VALUE != PERCENT && LA_CH_VALUE != LPAREN &&
01481 ((!cmd_line_flags.co_array_fortran) || LA_CH_VALUE != LBRKT))
01482 # else
01483 if (LA_CH_VALUE != PERCENT && LA_CH_VALUE != LPAREN)
01484 # endif
01485 {
01486
01487
01488
01489
01490
01491 goto EXIT;
01492 }
01493
01494
01495 if (LA_CH_VALUE == LPAREN) {
01496
01497 array_idx = ATD_ARRAY_IDX(amb_attr_idx);
01498
01499 if (array_idx) {
01500
01501 rank = 0;
01502 NTR_IR_TBL(subs_idx);
01503
01504
01505
01506 COPY_OPND(IR_OPND_L(subs_idx), (*result_opnd));
01507
01508
01509 OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
01510 OPND_IDX((*result_opnd)) = subs_idx;
01511
01512
01513 IR_LINE_NUM(subs_idx) = LA_CH_LINE;
01514 IR_COL_NUM(subs_idx) = LA_CH_COLUMN;
01515
01516 IR_OPR(subs_idx) = Subscript_Opr;
01517 IR_FLD_R(subs_idx) = IL_Tbl_Idx;
01518
01519 list_idx = NULL_IDX;
01520
01521 do {
01522 NEXT_LA_CH;
01523
01524 if (ambiguous_ref) {
01525
01526 if (LA_CH_VALUE == RPAREN) {
01527
01528 break;
01529 }
01530 else if (next_arg_is_kwd_equal ()) {
01531 MATCHED_TOKEN_CLASS(Tok_Class_Id);
01532
01533 parsed_ok = create_kwd_text(&opnd, TRUE) && parsed_ok;
01534
01535 if (list_idx == NULL_IDX) {
01536 NTR_IR_LIST_TBL(list_idx);
01537 IR_IDX_R(subs_idx) = list_idx;
01538 }
01539 else {
01540 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01541 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01542 list_idx = IL_NEXT_LIST_IDX(list_idx);
01543 }
01544
01545 COPY_OPND(IL_OPND(list_idx), opnd);
01546 rank++;
01547 continue;
01548 }
01549 }
01550
01551 if (list_idx == NULL_IDX) {
01552 NTR_IR_LIST_TBL(list_idx);
01553 IR_IDX_R(subs_idx) = list_idx;
01554 }
01555 else {
01556 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01557 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01558 list_idx = IL_NEXT_LIST_IDX(list_idx);
01559 }
01560
01561 if (LA_CH_VALUE != COLON) {
01562 parsed_ok = parse_expr(&opnd) && parsed_ok;
01563 COPY_OPND(IL_OPND(list_idx), opnd);
01564 }
01565
01566
01567
01568 if (LA_CH_VALUE == COLON) {
01569
01570 NTR_IR_TBL(trip_idx);
01571 IR_LINE_NUM(trip_idx) = LA_CH_LINE;
01572 IR_COL_NUM(trip_idx) = LA_CH_COLUMN;
01573
01574 NEXT_LA_CH;
01575
01576 IR_OPR(trip_idx) = Triplet_Opr;
01577 IR_FLD_L(trip_idx) = IL_Tbl_Idx;
01578 IR_LIST_CNT_L(trip_idx) = 3;
01579 NTR_IR_LIST_TBL(list2_idx);
01580 IR_IDX_L(trip_idx) = list2_idx;
01581 IL_OPND(list2_idx) = IL_OPND(list_idx);
01582 IL_FLD(list_idx) = IR_Tbl_Idx;
01583 IL_IDX(list_idx) = trip_idx;
01584 NTR_IR_LIST_TBL(list3_idx);
01585 IL_NEXT_LIST_IDX(list2_idx) = list3_idx;
01586 IL_PREV_LIST_IDX(list3_idx) = list2_idx;
01587
01588 if (LA_CH_VALUE != COLON &&
01589 LA_CH_VALUE != COMMA &&
01590 LA_CH_VALUE != RPAREN) {
01591 parsed_ok = parse_expr(&opnd) && parsed_ok;
01592 COPY_OPND(IL_OPND(list3_idx), opnd);
01593 }
01594
01595 NTR_IR_LIST_TBL(list2_idx);
01596 IL_NEXT_LIST_IDX(list3_idx) = list2_idx;
01597 IL_PREV_LIST_IDX(list2_idx) = list3_idx;
01598
01599 if (LA_CH_VALUE == COLON) {
01600 NEXT_LA_CH;
01601 parsed_ok = parse_expr(&opnd) && parsed_ok;
01602 COPY_OPND(IL_OPND(list2_idx), opnd);
01603 }
01604 }
01605 rank++;
01606 }
01607 while (LA_CH_VALUE == COMMA);
01608
01609 if (! matched_specific_token(Tok_Punct_Rparen, Tok_Class_Punct)) {
01610 parse_err_flush(Find_Comma_Rparen, ")");
01611 parsed_ok = FALSE;
01612 goto EXIT;
01613 }
01614
01615 IR_LIST_CNT_R(subs_idx) = rank;
01616
01617 }
01618
01619
01620
01621 if (LA_CH_VALUE == LPAREN) {
01622
01623 if (is_substring_ref ()) {
01624
01625 if (TYP_TYPE(ATD_TYPE_IDX(amb_attr_idx)) != Character) {
01626 PRINTMSG(TOKEN_LINE(token), 508, Error, TOKEN_COLUMN(token));
01627 parsed_ok = FALSE;
01628 parse_err_flush(Find_Ref_End, NULL);
01629 goto EXIT;
01630 }
01631
01632 NTR_IR_TBL(substring_idx);
01633 IR_OPR(substring_idx) = Substring_Opr;
01634 IR_LINE_NUM(substring_idx) = LA_CH_LINE;
01635 IR_COL_NUM(substring_idx) = LA_CH_COLUMN;
01636
01637 COPY_OPND(IR_OPND_L(substring_idx), (*result_opnd));
01638
01639
01640 OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
01641 OPND_IDX((*result_opnd)) = substring_idx;
01642
01643 IR_FLD_R(substring_idx) = IL_Tbl_Idx;
01644 IR_LIST_CNT_R(substring_idx) = 2;
01645 NTR_IR_LIST_TBL(list_idx);
01646 NTR_IR_LIST_TBL(list2_idx);
01647 IR_IDX_R(substring_idx) = list_idx;
01648 IL_NEXT_LIST_IDX(list_idx) = list2_idx;
01649 IL_PREV_LIST_IDX(list2_idx) = list_idx;
01650
01651
01652 NEXT_LA_CH;
01653
01654 if (LA_CH_VALUE != COLON) {
01655 parsed_ok = parse_expr(&opnd) && parsed_ok;
01656 COPY_OPND(IL_OPND(list_idx), opnd);
01657 }
01658
01659 if (LA_CH_VALUE != COLON) {
01660 if (parse_err_flush(Find_Rparen, ":")) {
01661 NEXT_LA_CH;
01662 }
01663 parsed_ok = FALSE;
01664 goto EXIT;
01665 }
01666 else {
01667 NEXT_LA_CH;
01668 }
01669
01670 if (LA_CH_VALUE != RPAREN) {
01671 parsed_ok = parse_expr(&opnd) && parsed_ok;
01672 COPY_OPND(IL_OPND(list2_idx), opnd);
01673 }
01674
01675 if (LA_CH_VALUE != RPAREN) {
01676
01677 if (parse_err_flush(Find_Rparen, ")")) {
01678 NEXT_LA_CH;
01679 }
01680 parsed_ok = FALSE;
01681 goto EXIT;
01682 }
01683 else {
01684 NEXT_LA_CH;
01685 }
01686 goto EXIT;
01687 }
01688 }
01689
01690 if (LA_CH_VALUE != PERCENT) {
01691
01692 if (subs_idx ||
01693 struct_type_idx) {
01694
01695
01696 }
01697 else {
01698
01699
01700
01701 if (ambiguous_ref) {
01702
01703 NTR_IR_TBL(ir_idx);
01704 IR_OPR(ir_idx) = Call_Opr;
01705 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
01706 IR_IDX_L(ir_idx) = attr_idx;
01707 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token);
01708 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token);
01709 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
01710 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token);
01711 OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
01712 OPND_IDX((*result_opnd)) = ir_idx;
01713
01714 parsed_ok = parse_actual_arg_spec(&opnd, TRUE, attr_idx);
01715 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01716
01717 goto EXIT;
01718
01719 }
01720 else if (AT_USE_ASSOCIATED(attr_idx)) {
01721
01722 PRINTMSG(TOKEN_LINE(token), 898, Error, TOKEN_COLUMN(token),
01723 AT_OBJ_NAME_PTR(attr_idx));
01724 parse_err_flush(Find_Ref_End, NULL);
01725 parsed_ok = FALSE;
01726 goto EXIT;
01727 }
01728 else if (expr_mode == Stmt_Func_Expr &&
01729 AT_OBJ_CLASS(attr_idx) == Data_Obj &&
01730 ATD_CLASS(attr_idx) == Dummy_Argument &&
01731 ATD_SF_DARG(attr_idx)) {
01732
01733 PRINTMSG(TOKEN_LINE(token), 1094, Error, TOKEN_COLUMN(token),
01734 AT_OBJ_NAME_PTR(attr_idx));
01735 parse_err_flush(Find_Ref_End, NULL);
01736 parsed_ok = FALSE;
01737 goto EXIT;
01738 }
01739 else if (AT_REFERENCED(attr_idx) == Not_Referenced) {
01740
01741 if (!fnd_semantic_err(Obj_Use_Extern_Func,
01742 TOKEN_LINE(token),
01743 TOKEN_COLUMN(token),
01744 attr_idx,
01745 TRUE)) {
01746
01747 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
01748 PRINTMSG(AT_DEF_LINE(attr_idx), 914, Error,
01749 AT_DEF_COLUMN(attr_idx),
01750 AT_OBJ_NAME_PTR(attr_idx));
01751 AT_DCL_ERR(attr_idx) = TRUE;
01752 }
01753 else if (ATD_POINTER(attr_idx)) {
01754 PRINTMSG(AT_DEF_LINE(attr_idx), 915, Error,
01755 AT_DEF_COLUMN(attr_idx),
01756 AT_OBJ_NAME_PTR(attr_idx));
01757 AT_DCL_ERR(attr_idx) = TRUE;
01758 }
01759 else if (ATD_CLASS(attr_idx) != Dummy_Argument &&
01760 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character &&
01761 TYP_CHAR_CLASS(ATD_TYPE_IDX(attr_idx)) ==
01762 Assumed_Size_Char) {
01763 PRINTMSG(AT_DEF_LINE(attr_idx), 939, Error,
01764 AT_DEF_COLUMN(attr_idx),
01765 AT_OBJ_NAME_PTR(attr_idx));
01766 AT_DCL_ERR(attr_idx) = TRUE;
01767 }
01768
01769
01770
01771
01772 chg_data_obj_to_pgm_unit(attr_idx, Function, Extern_Proc);
01773
01774 NTR_IR_TBL(ir_idx);
01775 IR_OPR(ir_idx) = Call_Opr;
01776 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
01777 IR_IDX_L(ir_idx) = attr_idx;
01778 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token);
01779 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token);
01780 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
01781 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token);
01782 OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
01783 OPND_IDX((*result_opnd)) = ir_idx;
01784
01785 parsed_ok = parse_actual_arg_spec(&opnd, TRUE, attr_idx);
01786 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01787
01788 goto EXIT;
01789 }
01790 else {
01791 parse_err_flush(Find_Ref_End, NULL);
01792 parsed_ok = FALSE;
01793 goto EXIT;
01794 }
01795 }
01796 else {
01797
01798 goto EXIT;
01799 }
01800 }
01801 }
01802 }
01803
01804 # ifdef COARRAY_FORTRAN
01805 if (LA_CH_VALUE == LBRKT &&
01806 cmd_line_flags.co_array_fortran &&
01807 struct_type_idx == NULL_IDX &&
01808 AT_OBJ_CLASS(amb_attr_idx) == Data_Obj) {
01809
01810 if (ATD_PE_ARRAY_IDX(amb_attr_idx) == NULL_IDX) {
01811
01812 PRINTMSG(LA_CH_LINE, 1245, Error, LA_CH_COLUMN,
01813 AT_OBJ_NAME_PTR(amb_attr_idx));
01814 parsed_ok = FALSE;
01815 parse_err_flush(Find_Ref_End, NULL);
01816 goto EXIT;
01817 }
01818
01819 if (stmt_type == Data_Stmt) {
01820 PRINTMSG(LA_CH_LINE, 1578, Error, LA_CH_COLUMN,
01821 AT_OBJ_NAME_PTR(amb_attr_idx), "DATA");
01822 parsed_ok = FALSE;
01823
01824
01825 }
01826
01827 if (subs_idx == NULL_IDX) {
01828 NTR_IR_TBL(subs_idx);
01829
01830
01831 IR_LINE_NUM(subs_idx) = LA_CH_LINE;
01832 IR_COL_NUM(subs_idx) = LA_CH_COLUMN;
01833
01834 IR_OPR(subs_idx) = Subscript_Opr;
01835 IR_FLD_R(subs_idx) = IL_Tbl_Idx;
01836 IR_LIST_CNT_R(subs_idx) = 0;
01837
01838 if (OPND_FLD((*result_opnd)) == AT_Tbl_Idx) {
01839 COPY_OPND(IR_OPND_L(subs_idx), (*result_opnd));
01840
01841
01842 OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
01843 OPND_IDX((*result_opnd)) = subs_idx;
01844 }
01845 else if (OPND_FLD((*result_opnd)) == IR_Tbl_Idx &&
01846 IR_OPR(OPND_IDX((*result_opnd))) == Substring_Opr) {
01847
01848 COPY_OPND(IR_OPND_L(subs_idx), IR_OPND_L(OPND_IDX((*result_opnd))));
01849
01850 IR_FLD_L(OPND_IDX((*result_opnd))) = IR_Tbl_Idx;
01851 IR_IDX_L(OPND_IDX((*result_opnd))) = subs_idx;
01852 }
01853 # ifdef _DEBUG
01854 else {
01855 PRINTMSG(LA_CH_LINE, 626, Internal, LA_CH_COLUMN,
01856 "AT_Tbl_Idx", "parse_deref");
01857 }
01858 # endif
01859
01860 list_idx = NULL_IDX;
01861 }
01862 else {
01863
01864 list_idx = IR_IDX_R(subs_idx);
01865
01866 while (IL_NEXT_LIST_IDX(list_idx) != NULL_IDX) {
01867 list_idx = IL_NEXT_LIST_IDX(list_idx);
01868 }
01869 }
01870
01871 num_dims = 0;
01872
01873 do {
01874 NEXT_LA_CH;
01875 num_dims++;
01876
01877 if (list_idx == NULL_IDX) {
01878 NTR_IR_LIST_TBL(list_idx);
01879 IR_IDX_R(subs_idx) = list_idx;
01880 }
01881 else {
01882 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01883 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01884 list_idx = IL_NEXT_LIST_IDX(list_idx);
01885 }
01886
01887 IL_PE_SUBSCRIPT(list_idx) = TRUE;
01888
01889 if (LA_CH_VALUE != COLON &&
01890 (! star_expected || LA_CH_VALUE != STAR)) {
01891 parsed_ok = parse_expr(&opnd) && parsed_ok;
01892 COPY_OPND(IL_OPND(list_idx), opnd);
01893 }
01894
01895
01896
01897 if (LA_CH_VALUE == COLON) {
01898
01899 NTR_IR_TBL(trip_idx);
01900 IR_LINE_NUM(trip_idx) = LA_CH_LINE;
01901 IR_COL_NUM(trip_idx) = LA_CH_COLUMN;
01902
01903 NEXT_LA_CH;
01904
01905 IR_OPR(trip_idx) = Triplet_Opr;
01906 IR_FLD_L(trip_idx) = IL_Tbl_Idx;
01907 IR_LIST_CNT_L(trip_idx) = 3;
01908 NTR_IR_LIST_TBL(list2_idx);
01909 IR_IDX_L(trip_idx) = list2_idx;
01910 IL_OPND(list2_idx) = IL_OPND(list_idx);
01911 IL_FLD(list_idx) = IR_Tbl_Idx;
01912 IL_IDX(list_idx) = trip_idx;
01913 NTR_IR_LIST_TBL(list3_idx);
01914 IL_NEXT_LIST_IDX(list2_idx) = list3_idx;
01915 IL_PREV_LIST_IDX(list3_idx) = list2_idx;
01916
01917 if (star_expected &&
01918 num_dims == BD_RANK(ATD_PE_ARRAY_IDX(amb_attr_idx)) &&
01919 LA_CH_VALUE != STAR) {
01920
01921 PRINTMSG(LA_CH_LINE, 1594, Error, LA_CH_COLUMN);
01922 parsed_ok = FALSE;
01923 }
01924
01925 if (star_expected && LA_CH_VALUE == STAR) {
01926
01927
01928 if (num_dims != BD_RANK(ATD_PE_ARRAY_IDX(amb_attr_idx))) {
01929 PRINTMSG(LA_CH_LINE, 116, Error, LA_CH_COLUMN);
01930 parsed_ok = FALSE;
01931 }
01932 NEXT_LA_CH;
01933 }
01934 else if (LA_CH_VALUE != COLON &&
01935 LA_CH_VALUE != COMMA &&
01936 LA_CH_VALUE != RBRKT) {
01937 parsed_ok = parse_expr(&opnd) && parsed_ok;
01938 COPY_OPND(IL_OPND(list3_idx), opnd);
01939 }
01940
01941 NTR_IR_LIST_TBL(list2_idx);
01942 IL_NEXT_LIST_IDX(list3_idx) = list2_idx;
01943 IL_PREV_LIST_IDX(list2_idx) = list3_idx;
01944
01945 if (LA_CH_VALUE == COLON) {
01946 NEXT_LA_CH;
01947 parsed_ok = parse_expr(&opnd) && parsed_ok;
01948 COPY_OPND(IL_OPND(list2_idx), opnd);
01949 }
01950 }
01951 else if (star_expected &&
01952 num_dims == BD_RANK(ATD_PE_ARRAY_IDX(amb_attr_idx)) &&
01953 IL_FLD(list_idx) != NO_Tbl_Idx) {
01954
01955 find_opnd_line_and_column(&(IL_OPND(list_idx)), &line, &col);
01956 PRINTMSG(line, 1594, Error, col);
01957 parsed_ok = FALSE;
01958 }
01959 else if (star_expected && LA_CH_VALUE == STAR) {
01960
01961
01962 if (num_dims != BD_RANK(ATD_PE_ARRAY_IDX(amb_attr_idx))) {
01963 PRINTMSG(LA_CH_LINE, 116, Error, LA_CH_COLUMN);
01964 parsed_ok = FALSE;
01965 }
01966 NEXT_LA_CH;
01967 }
01968
01969 (IR_LIST_CNT_R(subs_idx))++;
01970 }
01971 while (LA_CH_VALUE == COMMA);
01972
01973 if (LA_CH_VALUE != RBRKT) {
01974 parse_err_flush(Find_EOS, "]");
01975 parsed_ok = FALSE;
01976 goto EXIT;
01977 }
01978 else {
01979
01980 NEXT_LA_CH;
01981 }
01982 }
01983 # endif
01984
01985 if (LA_CH_VALUE == PERCENT) {
01986
01987
01988
01989 if (TYP_TYPE(ATD_TYPE_IDX(amb_attr_idx)) != Structure) {
01990
01991 if (SCP_IMPL_NONE(curr_scp_idx) && !AT_TYPED(amb_attr_idx) &&
01992 !AT_DCL_ERR(amb_attr_idx)) {
01993 AT_DCL_ERR(amb_attr_idx) = TRUE;
01994 PRINTMSG(TOKEN_LINE(attr_name), 113, Error,
01995 TOKEN_COLUMN(attr_name),
01996 TOKEN_STR(attr_name));
01997 }
01998 else {
01999 PRINTMSG(TOKEN_LINE(attr_name), 212, Error,
02000 TOKEN_COLUMN(attr_name),
02001 TOKEN_STR(attr_name),
02002 get_basic_type_str(ATD_TYPE_IDX(amb_attr_idx)));
02003 }
02004
02005 parse_err_flush(Find_Ref_End, NULL);
02006 parsed_ok = FALSE;
02007 goto EXIT;
02008 }
02009 line = LA_CH_LINE;
02010 col = LA_CH_COLUMN;
02011 NEXT_LA_CH;
02012
02013 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
02014 NTR_IR_TBL(ir_idx);
02015 IR_OPR(ir_idx) = Struct_Opr;
02016 IR_LINE_NUM(ir_idx) = line;
02017 IR_COL_NUM(ir_idx) = col;
02018
02019 COPY_OPND(IR_OPND_L(ir_idx), (*result_opnd));
02020
02021 OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
02022 OPND_IDX((*result_opnd)) = ir_idx;
02023
02024 parsed_ok = parse_deref(result_opnd,
02025 TYP_IDX(ATD_TYPE_IDX(amb_attr_idx)));
02026 }
02027 else {
02028
02029
02030
02031 parse_err_flush(Find_Ref_End, "IDENTIFIER");
02032 parsed_ok = FALSE;
02033 }
02034 }
02035
02036 EXIT:
02037
02038 if (parsed_ok) {
02039
02040 if (ambiguous_ref &&
02041 AT_REFERENCED(attr_idx) == Not_Referenced &&
02042 AT_OBJ_CLASS(attr_idx) == Data_Obj &&
02043 OPND_FLD((*result_opnd)) == IR_Tbl_Idx &&
02044 IR_OPR(OPND_IDX((*result_opnd))) == Call_Opr) {
02045
02046
02047 chg_data_obj_to_pgm_unit(attr_idx, Function, Extern_Proc);
02048 }
02049
02050 if (stmt_type != Data_Stmt) {
02051
02052 if (expr_mode == Specification_Expr ||
02053 expr_mode == Initialization_Expr ||
02054 expr_mode == Stmt_Func_Expr) {
02055 AT_REFERENCED(attr_idx) = Dcl_Bound_Ref;
02056 }
02057 else {
02058 AT_REFERENCED(attr_idx) = Referenced;
02059 }
02060
02061 if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit &&
02062 ATP_PGM_UNIT(attr_idx) != Module &&
02063 ATP_RSLT_IDX(attr_idx) != NULL_IDX) {
02064 AT_REFERENCED(ATP_RSLT_IDX(attr_idx)) = AT_REFERENCED(attr_idx);
02065 }
02066 }
02067 }
02068
02069 TRACE (Func_Exit, "parse_deref", NULL);
02070
02071 return(parsed_ok);
02072
02073 }
02074
02075
02076
02077
02078
02079
02080
02081
02082
02083
02084
02085
02086
02087
02088
02089
02090
02091
02092 boolean parse_imp_do (opnd_type *result_opnd)
02093
02094 {
02095 int buf_idx;
02096 int col;
02097 boolean had_equal = FALSE;
02098 int imp_do_start_line;
02099 int imp_do_start_col;
02100 int ir_idx;
02101 int line;
02102 int list_idx;
02103 int list2_idx = NULL_IDX;
02104 char next_char;
02105 opnd_type opnd;
02106 int paren_level = 0;
02107 boolean parsed_ok = TRUE;
02108 boolean save_in_implied_do;
02109 int stmt_num;
02110
02111
02112 TRACE (Func_Entry, "parse_imp_do", NULL);
02113
02114 # ifdef _DEBUG
02115 if (LA_CH_VALUE != LPAREN) {
02116
02117 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token),
02118 "parse_imp_do", "LPAREN");
02119 }
02120 # endif
02121
02122 NTR_IR_TBL(ir_idx);
02123 IR_OPR(ir_idx) = Implied_Do_Opr;
02124 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
02125 IR_LINE_NUM(ir_idx) = LA_CH_LINE;
02126 IR_COL_NUM(ir_idx) = LA_CH_COLUMN;
02127 OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
02128 OPND_IDX((*result_opnd)) = ir_idx;
02129
02130
02131 imp_do_start_line = LA_CH_LINE;
02132 imp_do_start_col = LA_CH_COLUMN;
02133 save_in_implied_do = in_implied_do;
02134 in_implied_do = TRUE;
02135
02136 do {
02137 NEXT_LA_CH;
02138
02139 START:
02140
02141 if (LA_CH_VALUE == LPAREN) {
02142
02143 if (next_tok_is_paren_slash ()) {
02144
02145 parsed_ok = parse_expr(&opnd) && parsed_ok;
02146
02147 }
02148 else if (is_implied_do ()) {
02149
02150 if (! (parsed_ok = parse_imp_do(&opnd))) {
02151
02152 if (LA_CH_VALUE != EOS) {
02153 parse_err_flush(Find_Rparen, NULL);
02154 NEXT_LA_CH;
02155 }
02156
02157 goto EXIT;
02158 }
02159 }
02160 else {
02161 next_char = scan_thru_close_paren(0,0,1);
02162
02163 if (next_char == COMMA ||
02164 next_char == EOS ||
02165 next_char == RPAREN) {
02166
02167 line = LA_CH_LINE;
02168 col = LA_CH_COLUMN;
02169 buf_idx = LA_CH_BUF_IDX;
02170 stmt_num = LA_CH_STMT_NUM;
02171
02172 NEXT_LA_CH;
02173
02174 if (LA_CH_VALUE == LPAREN ||
02175 LA_CH_VALUE == RPAREN ||
02176 LA_CH_VALUE == EOS) {
02177
02178 paren_level++;
02179 goto START;
02180 }
02181 else if (paren_grp_is_cplx_const()) {
02182
02183 reset_lex(buf_idx,stmt_num);
02184 parsed_ok = parse_expr(&opnd) && parsed_ok;
02185 }
02186 else {
02187
02188 reset_lex(buf_idx,stmt_num);
02189 NEXT_LA_CH;
02190 paren_level++;
02191 goto START;
02192 }
02193 }
02194 else {
02195
02196 if (list2_idx == NULL_IDX) {
02197 strcpy(parse_operand_insert, "implied-do-object");
02198 }
02199 else {
02200 strcpy(parse_operand_insert,
02201 "implied-do-object or do-variable");
02202 }
02203
02204 parsed_ok = parse_expr(&opnd) && parsed_ok;
02205
02206 if (stmt_type == Read_Stmt ||
02207 stmt_type == Decode_Stmt ||
02208 stmt_type == Data_Stmt) {
02209
02210 mark_attr_defined(&opnd);
02211 }
02212 }
02213 }
02214 }
02215 else {
02216
02217 if (list2_idx == NULL_IDX) {
02218 strcpy(parse_operand_insert, "implied-do-object");
02219 }
02220 else {
02221 strcpy(parse_operand_insert, "implied-do-object or do-variable");
02222 }
02223
02224 parsed_ok = parse_expr(&opnd) && parsed_ok;
02225
02226 if (stmt_type == Read_Stmt ||
02227 stmt_type == Decode_Stmt ||
02228 stmt_type == Data_Stmt) {
02229 mark_attr_defined(&opnd);
02230 }
02231
02232 if (LA_CH_VALUE == EQUAL) {
02233
02234 if (IR_FLD_L(ir_idx) == NO_Tbl_Idx) {
02235 find_opnd_line_and_column(&opnd, &line, &col);
02236
02237
02238
02239 PRINTMSG(line, 872, Error, col);
02240 parsed_ok = FALSE;
02241 }
02242
02243 had_equal = TRUE;
02244
02245
02246
02247
02248 if (OPND_FLD(opnd) == IR_Tbl_Idx) {
02249 find_opnd_line_and_column(&opnd, &line, &col);
02250 PRINTMSG(line, 199, Error, col);
02251 parsed_ok = FALSE;
02252 }
02253
02254 IR_FLD_R(ir_idx) = IL_Tbl_Idx;
02255 NTR_IR_LIST_TBL(list_idx);
02256 IR_IDX_R(ir_idx) = list_idx;
02257 COPY_OPND(IL_OPND(list_idx), opnd);
02258 mark_attr_defined(&opnd);
02259
02260
02261 if (OPND_FLD(opnd) == AT_Tbl_Idx &&
02262 AT_OBJ_CLASS(OPND_IDX(opnd)) == Data_Obj) {
02263
02264 ATD_SEEN_AS_LCV(OPND_IDX(opnd)) = TRUE;
02265
02266 if (ATD_FIRST_SEEN_IL_IDX(OPND_IDX(opnd)) != NULL_IDX) {
02267
02268 if (ATD_SEEN_IN_IMP_DO(OPND_IDX(opnd)) &&
02269 (IL_LINE_NUM(ATD_FIRST_SEEN_IL_IDX(OPND_IDX(opnd)))
02270 > imp_do_start_line ||
02271 (IL_LINE_NUM(ATD_FIRST_SEEN_IL_IDX(OPND_IDX(opnd))) ==
02272 imp_do_start_line &&
02273 IL_COL_NUM(ATD_FIRST_SEEN_IL_IDX(OPND_IDX(opnd)))
02274 > imp_do_start_col))) {
02275
02276
02277
02278 ATD_SEEN_IN_IMP_DO(OPND_IDX(opnd)) = FALSE;
02279 }
02280
02281 FREE_IR_LIST_NODE(ATD_FIRST_SEEN_IL_IDX(OPND_IDX(opnd)));
02282 ATD_FIRST_SEEN_IL_IDX(OPND_IDX(opnd)) = NULL_IDX;
02283 }
02284 else if (ATD_SEEN_IN_IMP_DO(OPND_IDX(opnd)) &&
02285 (AT_DEF_LINE(OPND_IDX(opnd)) > imp_do_start_line ||
02286 (AT_DEF_LINE(OPND_IDX(opnd)) == imp_do_start_line &&
02287 AT_DEF_COLUMN(OPND_IDX(opnd)) > imp_do_start_col))) {
02288
02289
02290
02291 ATD_SEEN_IN_IMP_DO(OPND_IDX(opnd)) = FALSE;
02292 }
02293 }
02294
02295
02296
02297
02298 NTR_IR_LIST_TBL(list2_idx);
02299 IL_NEXT_LIST_IDX(list_idx) = list2_idx;
02300 IL_PREV_LIST_IDX(list2_idx) = list_idx;
02301 NEXT_LA_CH;
02302 strcpy(parse_operand_insert, "operand");
02303 parsed_ok = parse_expr(&opnd) && parsed_ok;
02304 COPY_OPND(IL_OPND(list2_idx), opnd);
02305
02306 if (LA_CH_VALUE != COMMA) {
02307 parsed_ok = FALSE;
02308 parse_err_flush(Find_Rparen, ",");
02309 continue;
02310 }
02311
02312
02313
02314
02315
02316 NEXT_LA_CH;
02317
02318 NTR_IR_LIST_TBL(list_idx);
02319 IL_NEXT_LIST_IDX(list2_idx) = list_idx;
02320 IL_PREV_LIST_IDX(list_idx) = list2_idx;
02321 parsed_ok = parse_expr(&opnd) && parsed_ok;
02322 COPY_OPND(IL_OPND(list_idx), opnd);
02323
02324
02325
02326
02327 if (LA_CH_VALUE == COMMA) {
02328 NEXT_LA_CH;
02329 NTR_IR_LIST_TBL(list2_idx);
02330 IL_NEXT_LIST_IDX(list_idx) = list2_idx;
02331 IL_PREV_LIST_IDX(list2_idx) = list_idx;
02332 parsed_ok = parse_expr(&opnd) && parsed_ok;
02333 COPY_OPND(IL_OPND(list2_idx), opnd);
02334 IR_LIST_CNT_R(ir_idx) = 4;
02335 }
02336 else {
02337 IR_LIST_CNT_R(ir_idx) = 3;
02338 }
02339
02340 break;
02341 }
02342 }
02343
02344 if (IR_IDX_L(ir_idx) == NULL_IDX) {
02345 NTR_IR_LIST_TBL(list_idx);
02346 COPY_OPND(IL_OPND(list_idx), opnd);
02347 IR_FLD_L(ir_idx) = IL_Tbl_Idx;
02348 IR_IDX_L(ir_idx) = list_idx;
02349 IR_LIST_CNT_L(ir_idx) = 1;
02350 list2_idx = list_idx;
02351 }
02352 else {
02353 NTR_IR_LIST_TBL(list_idx);
02354 IL_NEXT_LIST_IDX(list2_idx) = list_idx;
02355 IL_PREV_LIST_IDX(list_idx) = list2_idx;
02356 COPY_OPND(IL_OPND(list_idx), opnd);
02357 ++IR_LIST_CNT_L(ir_idx);
02358 list2_idx = list_idx;
02359 }
02360
02361 while (LA_CH_VALUE == RPAREN && paren_level) {
02362 NEXT_LA_CH;
02363 paren_level--;
02364 }
02365 }
02366 while (LA_CH_VALUE == COMMA);
02367
02368 in_implied_do = save_in_implied_do;
02369
02370 if (paren_level) {
02371 parse_err_flush(Find_EOS, ")");
02372 goto EXIT;
02373 }
02374 else if (LA_CH_VALUE != RPAREN) {
02375
02376 if (had_equal) {
02377 parse_err_flush(Find_EOS,
02378 (IR_LIST_CNT_R(ir_idx) == 3) ? ", or )" : ")");
02379 }
02380 else {
02381 if (IL_FLD(list2_idx) == AT_Tbl_Idx) {
02382 parse_err_flush(Find_EOS, "=, comma, or '(subscript-list)'");
02383 }
02384 else {
02385 parse_err_flush(Find_EOS, ",");
02386 }
02387 }
02388
02389 parsed_ok = FALSE;
02390 goto EXIT;
02391 }
02392
02393 NEXT_LA_CH;
02394
02395 EXIT:
02396
02397 strcpy(parse_operand_insert, "operand");
02398
02399 TRACE (Func_Exit, "parse_imp_do", NULL);
02400
02401 return(parsed_ok);
02402
02403 }
02404
02405
02406
02407
02408
02409
02410
02411
02412
02413
02414
02415
02416
02417
02418
02419
02420
02421
02422
02423
02424
02425
02426
02427
02428
02429
02430
02431
02432
02433
02434
02435
02436
02437
02438
02439
02440
02441
02442
02443
02444
02445
02446
02447
02448
02449
02450
02451
02452
02453
02454
02455
02456
02457 int check_label_ref(void)
02458
02459 {
02460 int blk_idx;
02461 int cmic_blk_sh_idx = NULL_IDX;
02462 int lbl_attr_idx;
02463 int name_idx;
02464
02465
02466 TRACE (Func_Entry, "check_label_ref", NULL);
02467
02468 lbl_attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx);
02469
02470 if (lbl_attr_idx == NULL_IDX) {
02471 lbl_attr_idx = ntr_sym_tbl(&token, name_idx);
02472 AT_REFERENCED(lbl_attr_idx) = Referenced;
02473 AT_OBJ_CLASS(lbl_attr_idx) = Label;
02474 LN_DEF_LOC(name_idx) = TRUE;
02475 }
02476
02477 if (AT_DEFINED(lbl_attr_idx)) {
02478
02479
02480
02481
02482
02483 if (stmt_label_idx != NULL_IDX &&
02484 (ATL_DEF_STMT_IDX(lbl_attr_idx) == curr_stmt_sh_idx ||
02485 if_stmt_lbl_idx != NULL_IDX)) {
02486 ATL_EXECUTABLE(lbl_attr_idx) = TRUE;
02487 }
02488
02489 if ( ! SH_ERR_FLG(curr_stmt_sh_idx) ) {
02490
02491 blk_idx = blk_stk_idx;
02492
02493 while (blk_idx > 0) {
02494 if (BLK_IS_PARALLEL_REGION(blk_idx)) {
02495 cmic_blk_sh_idx = BLK_FIRST_SH_IDX(blk_idx);
02496 break;
02497 }
02498
02499 blk_idx--;
02500 }
02501
02502 check_cmic_blk_branches(cmic_blk_sh_idx,
02503 lbl_attr_idx,
02504 TOKEN_LINE(token),
02505 TOKEN_COLUMN(token));
02506
02507 blk_idx = blk_stk_idx;
02508
02509 while (BLK_IS_PARALLEL_REGION(blk_idx) ||
02510 BLK_TYPE(blk_idx) == Do_Parallel_Blk ||
02511 BLK_TYPE(blk_idx) == Wait_Blk ||
02512 BLK_TYPE(blk_idx) == SGI_Region_Blk) {
02513
02514 blk_idx--;
02515 }
02516
02517 label_ref_semantics(lbl_attr_idx, Branch_Context,
02518 (BLK_TYPE(blk_idx) > Interface_Body_Blk) ?
02519 BLK_FIRST_SH_IDX(blk_idx) : NULL_IDX,
02520 TOKEN_LINE(token), TOKEN_COLUMN(token));
02521 }
02522 }
02523 else {
02524 build_fwd_ref_entry(lbl_attr_idx, Branch_Context);
02525 }
02526
02527 if (cif_flags & XREF_RECS) {
02528 cif_usage_rec(lbl_attr_idx, AT_Tbl_Idx,
02529 TOKEN_LINE(token), TOKEN_COLUMN(token),
02530 CIF_Label_Referenced_As_Branch_Target);
02531 }
02532
02533 TRACE (Func_Exit, "check_label_ref", NULL);
02534
02535 return(lbl_attr_idx);
02536
02537 }
02538
02539
02540
02541
02542
02543
02544
02545
02546
02547
02548
02549
02550
02551
02552
02553
02554
02555
02556
02557
02558
02559
02560
02561
02562
02563
02564
02565
02566
02567
02568 void label_ref_semantics(int attr_idx,
02569 lbl_ref_type context,
02570 int ref_blk_idx,
02571 int ref_line_num,
02572 int ref_col_num)
02573 {
02574 stmt_type_type check_stmt_type;
02575 int lbl_blk_idx;
02576 stmt_type_type lbl_stmt_type;
02577 int line_num;
02578 char stmt_str[10];
02579 boolean valid_branch_target = TRUE;
02580
02581
02582 TRACE (Func_Entry, "label_ref_semantics", NULL);
02583
02584
02585
02586
02587 if (AT_DCL_ERR(attr_idx)) {
02588 goto EXIT;
02589 }
02590
02591
02592
02593
02594
02595
02596
02597
02598
02599 if (AT_DEFINED(attr_idx)) {
02600 lbl_stmt_type = SH_STMT_TYPE(ATL_DEF_STMT_IDX(attr_idx));
02601 }
02602 else {
02603 lbl_stmt_type = stmt_type;
02604 }
02605
02606
02607
02608
02609
02610
02611
02612 if ( ! ATL_EXECUTABLE(attr_idx) ) {
02613
02614 if (context == Branch_Context) {
02615 PRINTMSG(ref_line_num, 144, Error, ref_col_num, AT_DEF_LINE(attr_idx));
02616 }
02617 else if (lbl_stmt_type != Format_Stmt) {
02618 PRINTMSG(ref_line_num, 345, Error, ref_col_num,
02619 AT_OBJ_NAME_PTR(attr_idx));
02620 }
02621
02622 goto EXIT;
02623 }
02624
02625 stmt_str[0] = '\0';
02626
02627 switch (lbl_stmt_type) {
02628 case Case_Stmt:
02629 valid_branch_target = FALSE;
02630 strcpy(stmt_str, "CASE");
02631 break;
02632
02633 case Else_Stmt:
02634 valid_branch_target = FALSE;
02635 strcpy(stmt_str, "ELSE");
02636 break;
02637
02638 case Else_If_Stmt:
02639 valid_branch_target = FALSE;
02640 strcpy(stmt_str, "ELSE IF");
02641 break;
02642
02643 case Else_Where_Stmt:
02644 valid_branch_target = FALSE;
02645 strcpy(stmt_str, "ELSEWHERE");
02646 break;
02647
02648 case End_Where_Stmt:
02649 valid_branch_target = FALSE;
02650 strcpy(stmt_str, "END WHERE");
02651 break;
02652
02653 case End_Forall_Stmt:
02654 valid_branch_target = FALSE;
02655 strcpy(stmt_str, "END FORALL");
02656 break;
02657
02658 case Then_Stmt:
02659 valid_branch_target = FALSE;
02660 strcpy(stmt_str, "THEN");
02661 break;
02662 }
02663
02664 if ( ! valid_branch_target ) {
02665 PRINTMSG(ref_line_num,
02666 (context == Branch_Context) ? 145 : 346,
02667 Error, ref_col_num, stmt_str,
02668 AT_DEF_LINE(attr_idx));
02669 goto EXIT;
02670 }
02671
02672
02673
02674
02675 if (SH_STMT_TYPE(ATL_BLK_STMT_IDX(attr_idx)) == Where_Cstrct_Stmt ||
02676 SH_STMT_TYPE(ATL_BLK_STMT_IDX(attr_idx)) == Else_Where_Stmt) {
02677
02678 if (context == Branch_Context) {
02679 PRINTMSG(ref_line_num, 147, Error, ref_col_num,
02680 SH_GLB_LINE(ATL_BLK_STMT_IDX(attr_idx)));
02681 }
02682 else {
02683 PRINTMSG(ref_line_num, 347, Warning, ref_col_num,
02684 AT_OBJ_NAME_PTR(attr_idx),
02685 SH_GLB_LINE(ATL_BLK_STMT_IDX(attr_idx)));
02686 }
02687
02688 goto EXIT;
02689 }
02690
02691
02692
02693 if (SH_STMT_TYPE(ATL_BLK_STMT_IDX(attr_idx)) == Forall_Cstrct_Stmt) {
02694
02695 if (context == Branch_Context) {
02696 PRINTMSG(ref_line_num, 1595, Error, ref_col_num,
02697 SH_GLB_LINE(ATL_BLK_STMT_IDX(attr_idx)));
02698 }
02699 else {
02700 PRINTMSG(ref_line_num, 1596, Warning, ref_col_num,
02701 AT_OBJ_NAME_PTR(attr_idx),
02702 SH_GLB_LINE(ATL_BLK_STMT_IDX(attr_idx)));
02703 }
02704
02705 goto EXIT;
02706 }
02707
02708
02709
02710
02711
02712 if (context != Branch_Context) {
02713 goto EXIT;
02714 }
02715
02716
02717
02718
02719
02720
02721
02722
02723 if (ATL_BLK_STMT_IDX(attr_idx) == NULL_IDX ||
02724 ATL_BLK_STMT_IDX(attr_idx) == ref_blk_idx) {
02725 goto EXIT;
02726 }
02727
02728
02729
02730
02731
02732
02733
02734
02735
02736
02737 lbl_blk_idx = NULL_IDX;
02738
02739 if (ref_blk_idx != NULL_IDX) {
02740 lbl_blk_idx = SH_PARENT_BLK_IDX(ref_blk_idx);
02741
02742 while (lbl_blk_idx != NULL_IDX) {
02743
02744 if (lbl_blk_idx == ATL_BLK_STMT_IDX(attr_idx)) {
02745 break;
02746 }
02747 else {
02748 lbl_blk_idx = SH_PARENT_BLK_IDX(lbl_blk_idx);
02749 }
02750 }
02751 }
02752
02753 if (lbl_blk_idx != NULL_IDX) {
02754 goto EXIT;
02755 }
02756
02757
02758
02759
02760
02761
02762
02763
02764
02765
02766 if (lbl_stmt_type == End_Do_Stmt) {
02767 PRINTMSG(ref_line_num, 150, Error, ref_col_num);
02768 goto EXIT;
02769 }
02770
02771 if (lbl_stmt_type == End_Select_Stmt) {
02772 PRINTMSG(ref_line_num, 153, Error, ref_col_num);
02773 goto EXIT;
02774 }
02775
02776 if (lbl_stmt_type == End_If_Stmt) {
02777 PRINTMSG(ref_line_num, 1567, Ansi, ref_col_num);
02778
02779 if (SH_PARENT_BLK_IDX(ATL_BLK_STMT_IDX(attr_idx)) != NULL_IDX) {
02780
02781 if (SH_PARENT_BLK_IDX(ATL_BLK_STMT_IDX(attr_idx)) != ref_blk_idx) {
02782 check_stmt_type =
02783 SH_STMT_TYPE(SH_PARENT_BLK_IDX(ATL_BLK_STMT_IDX(attr_idx)));
02784 line_num =
02785 SH_GLB_LINE(SH_PARENT_BLK_IDX(ATL_BLK_STMT_IDX(attr_idx)));
02786 }
02787 else {
02788 goto EXIT;
02789 }
02790 }
02791 else {
02792 goto EXIT;
02793 }
02794 }
02795 else {
02796 check_stmt_type = SH_STMT_TYPE(ATL_BLK_STMT_IDX(attr_idx));
02797 line_num = SH_GLB_LINE(ATL_BLK_STMT_IDX(attr_idx));
02798 }
02799
02800 switch (check_stmt_type) {
02801
02802 case Case_Stmt:
02803 PRINTMSG(ref_line_num, 148, Error, ref_col_num, line_num);
02804 goto EXIT;
02805
02806 case Do_Iterative_Stmt:
02807 case Do_While_Stmt:
02808 case Do_Infinite_Stmt:
02809 PRINTMSG(ref_line_num, 154, Warning, ref_col_num, line_num);
02810 PRINTMSG(ref_line_num, 155, Ansi, ref_col_num, line_num);
02811 goto EXIT;
02812
02813 case Else_Stmt:
02814 strcpy(stmt_str, "ELSE");
02815 break;
02816
02817 case Else_If_Stmt:
02818 strcpy(stmt_str, "ELSE IF");
02819 break;
02820
02821 case Then_Stmt:
02822 strcpy(stmt_str, "THEN");
02823 break;
02824
02825 case Directive_Stmt:
02826 case Parallel_Case_Stmt:
02827
02828 goto EXIT;
02829 }
02830
02831 PRINTMSG(ref_line_num, 156, Warning, ref_col_num, stmt_str, line_num);
02832 PRINTMSG(ref_line_num, 157, Ansi, ref_col_num, stmt_str, line_num);
02833
02834 EXIT:
02835
02836 TRACE (Func_Entry, "label_ref_semantics", NULL);
02837
02838 return;
02839
02840 }
02841
02842
02843
02844
02845
02846
02847
02848
02849
02850
02851
02852
02853
02854
02855
02856
02857
02858
02859
02860
02861
02862
02863
02864
02865
02866
02867
02868
02869
02870
02871
02872
02873
02874
02875
02876
02877
02878
02879
02880
02881
02882
02883
02884
02885
02886
02887
02888
02889
02890
02891
02892
02893
02894
02895
02896
02897
02898
02899 void build_fwd_ref_entry(int lbl_attr_idx,
02900 lbl_ref_type fwd_ref_cntxt)
02901
02902 {
02903 int blk_idx;
02904 int cmic_sh_idx = NULL_IDX;
02905 int curr_fwd_ref_idx;
02906 int fwd_ref_idx1;
02907 int fwd_ref_idx2;
02908 int new_fwd_ref_idx;
02909
02910
02911 TRACE (Func_Entry, "build_fwd_ref_entry", NULL);
02912
02913 curr_fwd_ref_idx = ATL_FWD_REF_IDX(lbl_attr_idx);
02914
02915 NTR_IR_LIST_TBL(new_fwd_ref_idx);
02916
02917 ATL_FWD_REF_IDX(lbl_attr_idx) = new_fwd_ref_idx;
02918 IL_NEXT_LIST_IDX(new_fwd_ref_idx) = curr_fwd_ref_idx;
02919
02920 if (curr_fwd_ref_idx != NULL_IDX) {
02921 IL_PREV_LIST_IDX(curr_fwd_ref_idx) = new_fwd_ref_idx;
02922 }
02923
02924 IL_LINE_NUM(new_fwd_ref_idx) = TOKEN_LINE(token);
02925 IL_COL_NUM(new_fwd_ref_idx) = TOKEN_COLUMN(token);
02926
02927
02928 switch (fwd_ref_cntxt) {
02929
02930 case Branch_Context:
02931 IL_FLD(new_fwd_ref_idx) = SH_Tbl_Idx;
02932
02933 blk_idx = blk_stk_idx;
02934
02935 while (BLK_IS_PARALLEL_REGION(blk_idx) ||
02936 BLK_TYPE(blk_idx) == Do_Parallel_Blk ||
02937 BLK_TYPE(blk_idx) == Wait_Blk ||
02938 BLK_TYPE(blk_idx) == SGI_Region_Blk) {
02939
02940 blk_idx--;
02941 }
02942
02943 if (BLK_TYPE(blk_idx) > Interface_Body_Blk) {
02944 IL_IDX(new_fwd_ref_idx) = BLK_FIRST_SH_IDX(blk_idx);
02945 }
02946
02947
02948
02949
02950 blk_idx = blk_stk_idx;
02951
02952 while (blk_idx > 0) {
02953
02954 if (BLK_IS_PARALLEL_REGION(blk_idx)) {
02955 cmic_sh_idx = BLK_FIRST_SH_IDX(blk_idx);
02956 break;
02957 }
02958
02959 blk_idx--;
02960 }
02961
02962 if (cmic_sh_idx != NULL_IDX) {
02963 NTR_IR_LIST_TBL(fwd_ref_idx1);
02964 NTR_IR_LIST_TBL(fwd_ref_idx2);
02965 IL_NEXT_LIST_IDX(fwd_ref_idx1) = fwd_ref_idx2;
02966 IL_PREV_LIST_IDX(fwd_ref_idx2) = fwd_ref_idx1;
02967 IL_LINE_NUM(fwd_ref_idx1) = TOKEN_LINE(token);
02968 IL_COL_NUM(fwd_ref_idx1) = TOKEN_COLUMN(token);
02969 IL_LINE_NUM(fwd_ref_idx2) = TOKEN_LINE(token);
02970 IL_COL_NUM(fwd_ref_idx2) = TOKEN_COLUMN(token);
02971
02972 IL_FLD(fwd_ref_idx1) = SH_Tbl_Idx;
02973 IL_FLD(fwd_ref_idx2) = SH_Tbl_Idx;
02974
02975 IL_IDX(fwd_ref_idx1) = IL_IDX(new_fwd_ref_idx);
02976 IL_IDX(fwd_ref_idx2) = cmic_sh_idx;
02977
02978 IL_FLD(new_fwd_ref_idx) = IL_Tbl_Idx;
02979 IL_LIST_CNT(new_fwd_ref_idx) = 2;
02980 IL_IDX(new_fwd_ref_idx) = fwd_ref_idx1;
02981 }
02982
02983 break;
02984
02985 case Assign_Ref:
02986 IL_FORWARD_REF(new_fwd_ref_idx) = From_Assign_Stmt;
02987 break;
02988
02989 case Do_Ref:
02990 IL_FORWARD_REF(new_fwd_ref_idx) = From_Do_Stmt;
02991 break;
02992
02993 case Format_Ref:
02994 IL_FORWARD_REF(new_fwd_ref_idx) = To_Format_Stmt;
02995 break;
02996
02997 default:
02998 PRINTMSG(stmt_start_line, 179, Internal, stmt_start_col,
02999 "build_fwd_ref_entry");
03000 }
03001
03002 TRACE (Func_Exit, "build_fwd_ref_entry", NULL);
03003
03004 }
03005
03006
03007
03008
03009
03010
03011
03012
03013
03014
03015
03016
03017
03018
03019
03020
03021
03022
03023
03024
03025
03026
03027
03028
03029
03030
03031 void resolve_fwd_lbl_refs (void)
03032
03033 {
03034 int fwd_ref_idx;
03035 int next_fwd_ref_idx;
03036
03037
03038 TRACE (Func_Entry, "resolve_fwd_lbl_refs", NULL);
03039
03040 fwd_ref_idx = ATL_FWD_REF_IDX(stmt_label_idx);
03041
03042 if ( ! AT_DCL_ERR(stmt_label_idx) ) {
03043
03044
03045
03046
03047
03048 if (stmt_type == Format_Stmt) {
03049
03050 while (fwd_ref_idx != NULL_IDX) {
03051
03052 if (IL_FLD(fwd_ref_idx) == SH_Tbl_Idx) {
03053 PRINTMSG(IL_LINE_NUM(fwd_ref_idx), 144, Error,
03054 IL_COL_NUM(fwd_ref_idx), stmt_start_line);
03055 }
03056 else if (IL_FLD(fwd_ref_idx) == IL_Tbl_Idx) {
03057 PRINTMSG(IL_LINE_NUM(IL_IDX(fwd_ref_idx)), 144, Error,
03058 IL_COL_NUM(IL_IDX(fwd_ref_idx)), stmt_start_line);
03059 }
03060
03061 next_fwd_ref_idx = IL_NEXT_LIST_IDX(fwd_ref_idx);
03062
03063 if (IL_FLD(fwd_ref_idx) == IL_Tbl_Idx) {
03064 FREE_IR_LIST_NODE(IL_NEXT_LIST_IDX(IL_IDX(fwd_ref_idx)));
03065 FREE_IR_LIST_NODE(IL_IDX(fwd_ref_idx));
03066 }
03067 FREE_IR_LIST_NODE(fwd_ref_idx);
03068 fwd_ref_idx = next_fwd_ref_idx;
03069 }
03070
03071 }
03072 else {
03073
03074 while (fwd_ref_idx != NULL_IDX) {
03075
03076 if (IL_FLD(fwd_ref_idx) == NO_Tbl_Idx) {
03077
03078 if (IL_FORWARD_REF(fwd_ref_idx) == To_Format_Stmt) {
03079 PRINTMSG(IL_LINE_NUM(fwd_ref_idx), 328, Error,
03080 IL_COL_NUM(fwd_ref_idx),
03081 AT_OBJ_NAME_PTR(stmt_label_idx));
03082 }
03083 else if (IL_FORWARD_REF(fwd_ref_idx) == From_Assign_Stmt) {
03084 label_ref_semantics(stmt_label_idx, Assign_Ref,
03085 IL_IDX(fwd_ref_idx),
03086 IL_LINE_NUM(fwd_ref_idx),
03087 IL_COL_NUM(fwd_ref_idx));
03088 }
03089 }
03090 else if (IL_FLD(fwd_ref_idx) == IL_Tbl_Idx) {
03091
03092 check_cmic_blk_branches(IL_IDX(IL_NEXT_LIST_IDX(
03093 IL_IDX(fwd_ref_idx))),
03094 stmt_label_idx,
03095 IL_LINE_NUM(IL_IDX(fwd_ref_idx)),
03096 IL_COL_NUM(IL_IDX(fwd_ref_idx)));
03097
03098 label_ref_semantics(stmt_label_idx, Branch_Context,
03099 IL_IDX(IL_IDX(fwd_ref_idx)),
03100 IL_LINE_NUM(IL_IDX(fwd_ref_idx)),
03101 IL_COL_NUM(IL_IDX(fwd_ref_idx)));
03102 }
03103 else {
03104
03105 check_cmic_blk_branches(NULL_IDX,
03106 stmt_label_idx,
03107 IL_LINE_NUM(fwd_ref_idx),
03108 IL_COL_NUM(fwd_ref_idx));
03109
03110 label_ref_semantics(stmt_label_idx, Branch_Context,
03111 IL_IDX(fwd_ref_idx),
03112 IL_LINE_NUM(fwd_ref_idx),
03113 IL_COL_NUM(fwd_ref_idx));
03114 }
03115
03116 next_fwd_ref_idx = IL_NEXT_LIST_IDX(fwd_ref_idx);
03117
03118 if (IL_FLD(fwd_ref_idx) == IL_Tbl_Idx) {
03119 FREE_IR_LIST_NODE(IL_NEXT_LIST_IDX(IL_IDX(fwd_ref_idx)));
03120 FREE_IR_LIST_NODE(IL_IDX(fwd_ref_idx));
03121 }
03122 FREE_IR_LIST_NODE(fwd_ref_idx);
03123 fwd_ref_idx = next_fwd_ref_idx;
03124 }
03125
03126 }
03127
03128 AT_DEFINED(stmt_label_idx) = TRUE;
03129 ATL_DEF_STMT_IDX(stmt_label_idx) =
03130 (SH_STMT_TYPE(curr_stmt_sh_idx) != Then_Stmt) ? curr_stmt_sh_idx :
03131 SH_PARENT_BLK_IDX(curr_stmt_sh_idx);
03132 }
03133 else {
03134
03135
03136
03137 while (fwd_ref_idx != NULL_IDX) {
03138 next_fwd_ref_idx = IL_NEXT_LIST_IDX(fwd_ref_idx);
03139
03140 if (IL_FLD(fwd_ref_idx) == IL_Tbl_Idx) {
03141 FREE_IR_LIST_NODE(IL_NEXT_LIST_IDX(IL_IDX(fwd_ref_idx)));
03142 FREE_IR_LIST_NODE(IL_IDX(fwd_ref_idx));
03143 }
03144 FREE_IR_LIST_NODE(fwd_ref_idx);
03145 fwd_ref_idx = next_fwd_ref_idx;
03146 }
03147
03148 ATL_FWD_REF_IDX(stmt_label_idx) = NULL_IDX;
03149 AT_DEFINED(stmt_label_idx) = TRUE;
03150 }
03151
03152 TRACE (Func_Exit, "resolve_fwd_lbl_refs", NULL);
03153
03154 return;
03155
03156 }
03157
03158
03159
03160
03161
03162
03163
03164
03165
03166
03167
03168
03169
03170
03171
03172
03173
03174
03175
03176
03177
03178 static void check_cmic_blk_branches(int ref_blk_sh_idx,
03179 int label_attr,
03180 int line,
03181 int col)
03182
03183 {
03184
03185 char str1[32];
03186 char str2[8];
03187 int msg_num;
03188
03189 TRACE (Func_Entry, "check_cmic_blk_branches", NULL);
03190
03191 if (ATL_CLASS(label_attr) == Lbl_User &&
03192 ref_blk_sh_idx != ATL_CMIC_BLK_STMT_IDX(label_attr)) {
03193
03194 if (ATL_CMIC_BLK_STMT_IDX(label_attr) != NULL_IDX) {
03195
03196 block_err_string(IR_OPR(SH_IR_IDX(ATL_CMIC_BLK_STMT_IDX(label_attr))),
03197 str1,
03198 &msg_num);
03199
03200 strcpy(str2, "into");
03201 }
03202 else {
03203 block_err_string(IR_OPR(SH_IR_IDX(ref_blk_sh_idx)),
03204 str1,
03205 &msg_num);
03206
03207 strcpy(str2, "out of");
03208 }
03209
03210 PRINTMSG(line, msg_num, Error, col, str2, str1);
03211 }
03212
03213 TRACE (Func_Exit, "check_cmic_blk_branches", NULL);
03214
03215 return;
03216
03217 }
03218
03219
03220
03221
03222
03223
03224
03225
03226
03227
03228
03229
03230
03231
03232
03233
03234
03235 static void block_err_string(operator_type opr,
03236 char *str,
03237 int *msg_num)
03238
03239 {
03240
03241
03242 TRACE (Func_Entry, "block_err_string", NULL);
03243 switch (opr) {
03244 case Parallel_Cmic_Opr:
03245 strcpy(str, "PARALLEL");
03246 *msg_num = 1220;
03247 break;
03248
03249 case Doall_Cmic_Opr:
03250 strcpy(str, "DOALL");
03251 *msg_num = 1220;
03252 break;
03253
03254 case Guard_Cmic_Opr:
03255 strcpy(str, "GUARD");
03256 *msg_num = 1220;
03257 break;
03258
03259 case Case_Cmic_Opr:
03260 strcpy(str, "CASE");
03261 *msg_num = 1220;
03262 break;
03263
03264 case Parallel_Open_Mp_Opr:
03265 strcpy(str, "!$OMP PARALLEL");
03266 *msg_num = 1503;
03267 break;
03268
03269 case Do_Open_Mp_Opr:
03270 strcpy(str, "!$OMP DO");
03271 *msg_num = 1503;
03272 break;
03273
03274 case Parallelsections_Open_Mp_Opr:
03275 case Sections_Open_Mp_Opr:
03276 case Section_Open_Mp_Opr:
03277 strcpy(str, "!$OMP SECTION");
03278 *msg_num = 1503;
03279 break;
03280
03281 case Single_Open_Mp_Opr:
03282 strcpy(str, "!$OMP SINGLE");
03283 *msg_num = 1503;
03284 break;
03285
03286 case Paralleldo_Open_Mp_Opr:
03287 strcpy(str, "!$OMP PARALLEL DO");
03288 *msg_num = 1503;
03289 break;
03290
03291 case Master_Open_Mp_Opr:
03292 strcpy(str, "!$OMP MASTER");
03293 *msg_num = 1503;
03294 break;
03295
03296 case Critical_Open_Mp_Opr:
03297 strcpy(str, "!$OMP CRITICAL");
03298 *msg_num = 1503;
03299 break;
03300
03301 case Ordered_Open_Mp_Opr:
03302 strcpy(str, "!$OMP ORDERED");
03303 *msg_num = 1503;
03304 break;
03305
03306 case Parallelworkshare_Open_Mp_Opr:
03307 strcpy(str, "!$OMP PARALLEL WORKSHARE");
03308 *msg_num = 1503;
03309 break;
03310
03311 case Workshare_Open_Mp_Opr:
03312 strcpy(str, "!$OMP WORKSHARE");
03313 *msg_num = 1503;
03314 break;
03315
03316 case Doacross_Dollar_Opr:
03317 strcpy(str, "!$ DOACROSS");
03318 *msg_num = 1504;
03319 break;
03320
03321 case Psection_Par_Opr:
03322 strcpy(str, "!$PAR PSECTION");
03323 *msg_num = 1504;
03324 break;
03325
03326 case Section_Par_Opr:
03327 strcpy(str, "!$PAR SECTION");
03328 *msg_num = 1504;
03329 break;
03330
03331 case Pdo_Par_Opr:
03332 strcpy(str, "!$PAR PDO");
03333 *msg_num = 1504;
03334 break;
03335
03336 case Parallel_Do_Par_Opr:
03337 strcpy(str, "!$PAR PARALLEL DO");
03338 *msg_num = 1504;
03339 break;
03340
03341 case Parallel_Par_Opr:
03342 strcpy(str, "!$PAR PARALLEL");
03343 *msg_num = 1504;
03344 break;
03345
03346 case Critical_Section_Par_Opr:
03347 strcpy(str, "!$PAR CRITICAL SECTION");
03348 *msg_num = 1504;
03349 break;
03350
03351 case Singleprocess_Par_Opr:
03352 strcpy(str, "!$PAR SINGLE PROCESS");
03353 *msg_num = 1504;
03354 break;
03355
03356 default:
03357 # ifdef _DEBUG
03358 PRINTMSG(1, 626, Internal, 1,
03359 "directive operator", "block_err_string");
03360 # endif
03361 break;
03362 }
03363
03364
03365 TRACE (Func_Exit, "block_err_string", NULL);
03366
03367 return;
03368
03369 }
03370
03371
03372
03373
03374
03375
03376
03377
03378
03379
03380
03381
03382
03383
03384
03385
03386
03387
03388
03389 void mark_attr_defined(opnd_type *opnd)
03390
03391 {
03392 opnd_type l_opnd;
03393
03394 TRACE (Func_Entry, "mark_attr_defined", NULL);
03395
03396 COPY_OPND(l_opnd, (*opnd));
03397
03398 while (OPND_FLD(l_opnd) == IR_Tbl_Idx) {
03399 COPY_OPND(l_opnd, IR_OPND_L(OPND_IDX(l_opnd)));
03400 }
03401
03402 if (OPND_FLD(l_opnd) == AT_Tbl_Idx &&
03403 AT_OBJ_CLASS(OPND_IDX(l_opnd)) == Data_Obj) {
03404
03405 AT_DEFINED(OPND_IDX(l_opnd)) = TRUE;
03406
03407 if (ATD_CLASS(OPND_IDX(l_opnd)) == Function_Result) {
03408 AT_DEFINED(ATD_FUNC_IDX(OPND_IDX(l_opnd))) = TRUE;
03409 }
03410
03411 }
03412
03413
03414 TRACE (Func_Exit, "mark_attr_defined", NULL);
03415
03416 return;
03417
03418 }
03419
03420
03421
03422
03423
03424
03425
03426
03427
03428
03429
03430
03431
03432
03433
03434
03435
03436
03437
03438
03439 boolean paren_grp_is_cplx_const(void)
03440
03441 {
03442 int cx_l = NULL_IDX;
03443 int cx_r = NULL_IDX;
03444 expr_arg_type exp_desc;
03445 boolean is_constant = FALSE;
03446 boolean parsed_ok;
03447 opnd_type the_opnd;
03448
03449
03450 TRACE (Func_Entry, "paren_grp_is_cplx_const", NULL);
03451
03452
03453
03454 if (LA_CH_VALUE == SLASH) {
03455
03456 goto EXIT;
03457 }
03458 else if (!parse_expr(&the_opnd)) {
03459 goto EXIT;
03460 }
03461 else if (LA_CH_VALUE != COMMA) {
03462 goto EXIT;
03463 }
03464
03465
03466 if (OPND_FLD(the_opnd) == CN_Tbl_Idx) {
03467 cx_l = OPND_IDX(the_opnd);
03468 }
03469 else if (OPND_FLD(the_opnd) == AT_Tbl_Idx &&
03470 AT_OBJ_CLASS(OPND_IDX(the_opnd)) == Data_Obj &&
03471 ATD_CLASS(OPND_IDX(the_opnd)) == Constant &&
03472 ATD_FLD(OPND_IDX(the_opnd)) == CN_Tbl_Idx) {
03473
03474 cx_l = ATD_CONST_IDX(OPND_IDX(the_opnd));
03475 }
03476 else if (OPND_FLD(the_opnd) == IR_Tbl_Idx &&
03477 (IR_OPR(OPND_IDX(the_opnd)) == Uplus_Opr ||
03478 IR_OPR(OPND_IDX(the_opnd)) == Uminus_Opr) &&
03479 (IR_FLD_L(OPND_IDX(the_opnd)) == CN_Tbl_Idx ||
03480 (IR_FLD_L(OPND_IDX(the_opnd)) == AT_Tbl_Idx &&
03481 AT_OBJ_CLASS(IR_IDX_L(OPND_IDX(the_opnd))) == Data_Obj &&
03482 ATD_CLASS(IR_IDX_L(OPND_IDX(the_opnd))) == Constant &&
03483 ATD_FLD(IR_IDX_L(OPND_IDX(the_opnd))) == CN_Tbl_Idx))) {
03484
03485 exp_desc.rank = 0;
03486 xref_state = CIF_No_Usage_Rec;
03487 comp_gen_expr = TRUE;
03488 parsed_ok = expr_semantics(&the_opnd, &exp_desc);
03489 comp_gen_expr = FALSE;
03490
03491 if (parsed_ok &&
03492 OPND_FLD(the_opnd) == CN_Tbl_Idx) {
03493 cx_l = OPND_IDX(the_opnd);
03494 }
03495 }
03496
03497 if (cx_l &&
03498 (TYP_TYPE(CN_TYPE_IDX(cx_l)) == Real ||
03499 TYP_TYPE(CN_TYPE_IDX(cx_l)) == Integer)) {
03500
03501
03502 NEXT_LA_CH;
03503
03504 if (!parse_expr(&the_opnd)) {
03505 goto EXIT;
03506 }
03507 else if (LA_CH_VALUE != RPAREN) {
03508 goto EXIT;
03509 }
03510 else {
03511
03512 if (OPND_FLD(the_opnd) == CN_Tbl_Idx) {
03513 cx_r = OPND_IDX(the_opnd);
03514 }
03515 else if (OPND_FLD(the_opnd) == AT_Tbl_Idx &&
03516 AT_OBJ_CLASS(OPND_IDX(the_opnd)) == Data_Obj &&
03517 ATD_CLASS(OPND_IDX(the_opnd)) == Constant &&
03518 ATD_FLD(OPND_IDX(the_opnd)) == CN_Tbl_Idx) {
03519
03520 cx_r = ATD_CONST_IDX(OPND_IDX(the_opnd));
03521 }
03522 else if (OPND_FLD(the_opnd) == IR_Tbl_Idx &&
03523 (IR_OPR(OPND_IDX(the_opnd)) == Uplus_Opr ||
03524 IR_OPR(OPND_IDX(the_opnd)) == Uminus_Opr) &&
03525 (IR_FLD_L(OPND_IDX(the_opnd)) == CN_Tbl_Idx ||
03526 (IR_FLD_L(OPND_IDX(the_opnd)) == AT_Tbl_Idx &&
03527 AT_OBJ_CLASS(IR_IDX_L(OPND_IDX(the_opnd))) == Data_Obj &&
03528 ATD_CLASS(IR_IDX_L(OPND_IDX(the_opnd))) == Constant &&
03529 ATD_FLD(IR_IDX_L(OPND_IDX(the_opnd))) == CN_Tbl_Idx))) {
03530
03531 exp_desc.rank = 0;
03532 xref_state = CIF_No_Usage_Rec;
03533 comp_gen_expr = TRUE;
03534 parsed_ok = expr_semantics(&the_opnd, &exp_desc);
03535 comp_gen_expr = FALSE;
03536
03537 if (parsed_ok &&
03538 OPND_FLD(the_opnd) == CN_Tbl_Idx) {
03539 cx_r = OPND_IDX(the_opnd);
03540 }
03541 }
03542
03543
03544 if (cx_r &&
03545 (TYP_TYPE(CN_TYPE_IDX(cx_r)) == Real ||
03546 TYP_TYPE(CN_TYPE_IDX(cx_r)) == Integer)) {
03547
03548 is_constant = TRUE;
03549 }
03550 }
03551 }
03552
03553
03554 EXIT:
03555
03556 TRACE (Func_Exit, "paren_grp_is_cplx_const", NULL);
03557
03558 return(is_constant);
03559
03560 }
03561
03562
03563
03564
03565
03566
03567
03568
03569
03570
03571
03572
03573
03574
03575
03576
03577
03578 void check_for_vestigial_task_blks(void)
03579
03580 {
03581
03582 TRACE (Func_Entry, "check_for_vestigial_task_blks", NULL);
03583
03584 while (blk_stk_idx > 1 &&
03585 (BLK_TYPE(blk_stk_idx) == Do_Parallel_Blk ||
03586 BLK_TYPE(blk_stk_idx) == SGI_Pdo_Blk ||
03587 BLK_TYPE(blk_stk_idx) == Open_Mp_Do_Blk ||
03588 BLK_TYPE(blk_stk_idx) == Open_Mp_Parallel_Do_Blk)) {
03589
03590 POP_BLK_STK;
03591
03592 switch (CURR_BLK) {
03593 case Do_Parallel_Blk:
03594 CLEAR_DIRECTIVE_STATE(Do_Parallel_Region);
03595 break;
03596
03597 case SGI_Pdo_Blk:
03598 CLEAR_DIRECTIVE_STATE(Pdo_Region);
03599 break;
03600
03601 case Open_Mp_Do_Blk:
03602 CLEAR_DIRECTIVE_STATE(Open_Mp_Do_Region);
03603 break;
03604
03605 case Open_Mp_Parallel_Do_Blk:
03606 CLEAR_DIRECTIVE_STATE(Open_Mp_Parallel_Do_Region);
03607 break;
03608
03609 }
03610 }
03611
03612 TRACE (Func_Exit, "check_for_vestigial_task_blks", NULL);
03613
03614 return;
03615
03616 }
03617
03618
03619
03620
03621
03622
03623
03624
03625
03626
03627
03628
03629
03630
03631
03632
03633
03634 void set_up_fake_dt_blk(int dt_idx)
03635
03636 {
03637
03638
03639 TRACE (Func_Entry, "set_up_fake_dt_blk", NULL);
03640
03641 if (dt_idx == NULL_IDX) {
03642 if (blk_stk_idx > 0) {
03643 POP_BLK_STK;
03644 }
03645 }
03646 else {
03647 PUSH_BLK_STK(Derived_Type_Blk);
03648 CURR_BLK_NAME = dt_idx;
03649 }
03650
03651 TRACE (Func_Exit, "set_up_fake_dt_blk", NULL);
03652
03653 return;
03654
03655 }
