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_utils.c 5.5 09/09/99 12:47:48\n"; 00038 00039 # include "defines.h" /* Machine dependent ifdefs */ 00040 00041 # include "host.m" /* Host machine dependent macros.*/ 00042 # include "host.h" /* Host machine dependent header.*/ 00043 # include "target.m" /* Target machine dependent macros.*/ 00044 # include "target.h" /* Target machine dependent header.*/ 00045 00046 # include "globals.m" 00047 # include "tokens.m" 00048 # include "sytb.m" 00049 # include "p_globals.m" 00050 # include "debug.m" 00051 00052 # include "globals.h" 00053 # include "tokens.h" 00054 # include "sytb.h" 00055 # include "p_globals.h" 00056 00057 00058 /*****************************************************************\ 00059 |* function prototypes of static functions declared in this file *| 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 |* Description: *| 00072 |* This routine calls get token to try and retrieve the specified token. *| 00073 |* *| 00074 |* Input parameters: *| 00075 |* specific_token - The token to get. *| 00076 |* token_class - The class of the token to get. *| 00077 |* *| 00078 |* Output parameters: *| 00079 |* NONE *| 00080 |* *| 00081 |* Returns: *| 00082 |* TRUE if the requested token is found. *| 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 /* this check is here because we can't consume the */ 00100 /* EOS and then back up, so it's special cased here */ 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 { /* restore things to the way they looked upon entry */ 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 } /* matched_specific_token */ 00124 00125 00126 /******************************************************************************\ 00127 |* *| 00128 |* Description: *| 00129 |* First this routine, determines if a reparse is necessary. This is *| 00130 |* done for ALL calls. Msg printing and flushing are controlled by *| 00131 |* input parameters. This routine prints a parser error message, and *| 00132 |* can flush the LA char to try to recover parsing. Input parameters *| 00133 |* control exactly what is done. (Whether to print a msg, how many args *| 00134 |* the msg is called with, whether the bad char is in token form, or *| 00135 |* only LA form, and what to flush to. Set error flag on IR statement *| 00136 |* header, if one exists and an error message is being printed. *| 00137 |* *| 00138 |* NOTE: If a flush is done, TOKEN is UNDEFINED. LA_CH is set to *| 00139 |* the item being searched for, or to EOS. *| 00140 |* *| 00141 |* Input parameters: *| 00142 |* rule -> If the parser is in recovery mode, this is what to flush *| 00143 |* the LA char to. The rules are: *| 00144 |* Find_None -> Leave LA char as is. *| 00145 |* Find_EOS -> Search so LA is EOS. *| 00146 |* Find_Rparen -> Search so LA is rparen or EOS. *| 00147 |* Find_Lparen -> Search so LA is lparen or EOS. *| 00148 |* Find_Comma -> Search so LA is comma or EOS. *| 00149 |* Find_Comma_Rparen-> Search so LA is comma, an unmatched *| 00150 |* right paren, or EOS *| 00151 |* Find_Comma_Slash -> Search so LA is comma, slash or EOS. *| 00152 |* Find_Expr_End -> Search for end of expr. ) , : or EOS. *| 00153 |* str -> Pointer to string to pass as 1st arg to PRINTMSG. *| 00154 |* NULL if NO message should be printed. *| 00155 |* *| 00156 |* Note: LA_CH is used for the description, the following is printed *| 00157 |* LA_CH_CLASS description sent to PRINTMSG *| 00158 |* Ch_Class_Letter Keyword or Identifier *| 00159 |* Ch_Class_Symbol *| 00160 |* Ch_Class_Digit The lookahead character *| 00161 |* Ch_Class_EOS End of Statement *| 00162 |* Ch_Class_Dir and Ch_Class_EOF should not be seen here. *| 00163 |* *| 00164 |* Output parameters: *| 00165 |* NONE *| 00166 |* *| 00167 |* Returns: *| 00168 |* TRUE if the item being searched for is FOUND. ie - if rule = *| 00169 |* Find_Comma, then TRUE is returned if Comma is found, else FALSE. *| 00170 |* If Colon_Recovery is on, and :: is found, will return FALSE. *| 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 /* If LA_CH is open paren - set to find matching closed paren */ 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 /* Matching rparen if looking for paren, */ 00222 /* or closing paren if looking for comma_paren */ 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 /* Check paren level to prevent picking up (/ or /) slashes */ 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 } /* End switch */ 00308 00309 if (!found) { 00310 flush_LA_to_symbol(); /* This skips char constants & hollerith */ 00311 } 00312 } 00313 while (!found); 00314 } 00315 00316 TRACE (Func_Exit, "parse_err_flush", &LA_CH_VALUE); 00317 00318 return(!found_end); 00319 00320 } /* parse_err_flush */ 00321 00322 00323 /******************************************************************************\ 00324 |* *| 00325 |* Description: *| 00326 |* Creates kwd_opr subtrees. *| 00327 |* *| 00328 |* Input parameters: *| 00329 |* NONE *| 00330 |* *| 00331 |* Output parameters: *| 00332 |* result_opnd - opnd_type, points to root of tree returned. *| 00333 |* *| 00334 |* Returns: *| 00335 |* TRUE if parsed ok *| 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 /* the kwd identifier should already be tokenized and LA should be '=' */ 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 /* put kwd identifier in constant table */ 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; /* swallow = */ 00391 00392 /* get expression for right opnd */ 00393 /* float scalarness and ambiguity */ 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; /* swallow ( */ 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 } /* create_kwd_text */ 00467 00468 00469 /******************************************************************************\ 00470 |* *| 00471 |* Description: *| 00472 |* parse_actual_arg_spec will create a call text from an actual arg *| 00473 |* list. It processes keyword arguments. *| 00474 |* *| 00475 |* Input parameters: *| 00476 |* NONE *| 00477 |* *| 00478 |* Output parameters: *| 00479 |* NONE *| 00480 |* *| 00481 |* Returns: *| 00482 |* index of call text *| 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 /* shouldn't be here */ 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 /* have keyword */ 00566 had_keyword = TRUE; 00567 /* put keyword on constant tbl */ 00568 parsed_ok = create_kwd_text(&opnd, function_call) && parsed_ok; 00569 COPY_OPND(IL_OPND(list_idx), opnd); 00570 } 00571 else { /* had id but not kwd, must reparse as expression */ 00572 00573 if (had_keyword) { 00574 /* error */ 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; /* swallow ( */ 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 /* this global variable is used to set the max size for arrays in */ 00633 /* call_list_semantics. */ 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 } /* parse_actual_arg_spec */ 00651 00652 00653 /******************************************************************************\ 00654 |* *| 00655 |* Description: *| 00656 |* Parse structure/array dereference *| 00657 |* *| 00658 |* Input parameters: *| 00659 |* struct_type_idx - idx for derived type of previous id, NULL_IDX *| 00660 |* if no previous id. *| 00661 |* *| 00662 |* Output parameters: *| 00663 |* result_opnd - opnd_type, points to root of tree returned. *| 00664 |* *| 00665 |* Returns: *| 00666 |* TRUE if parsed ok *| 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) { /* test for valid structure component */ 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 /* Reference to something of a derived type causes the derived */ 00753 /* type to be locked in. In other words, it cannot be redefined */ 00754 /* if it is host associated. */ 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) { /* the name was found locally */ 00771 00772 /* copy intrinsic attr to the local scope from the 0th scope */ 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 /* search INTRINSIC host for the INTRINSIC in question */ 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 /* any other reference is ambiguous */ 00832 ambiguous_ref = TRUE; 00833 00834 /* search host sym tab */ 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 /* do not hook up to host stmt entities */ 00844 00845 host_attr_idx = NULL_IDX; 00846 } 00847 00848 /* if we are copying info down from the host scope */ 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 /* TRUE means make a new attr and link it to the old one. */ 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 /* copy intrinsic attr to the local scope from the 0th scope */ 00879 /* and break the link to the host scope. */ 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 /* set function on attr */ 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 /* put AT in result opnd for now */ 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 /* need to keep track of line/col to determine if stmt entity */ 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 /* if there was a problem with the local attr, quit */ 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 /* if this is not ambiguous, and it is not visible, error. */ 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 /* Now lets see what this attr is */ 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 /* must be a pgm unit */ 01030 01031 if (LA_CH_VALUE != LPAREN && 01032 LA_CH_VALUE != PERCENT) { 01033 01034 /* possibly a proc actual arg */ 01035 goto EXIT; 01036 } 01037 else if (LA_CH_VALUE != LPAREN) { 01038 /* could have better message if we want. */ 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 /* have data obj ref */ 01065 attr_idx = rslt_idx; 01066 amb_attr_idx = attr_idx; 01067 OPND_IDX((*result_opnd)) = attr_idx; 01068 01069 /* continue on with further processing */ 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 /* my assumption is that this has only been seen in EXTERNAL */ 01079 /* so make into implicitly typed function. */ 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 /* shouldn't be here */ 01110 parsed_ok = FALSE; 01111 goto EXIT; 01112 01113 case Derived_Type : 01114 01115 if (LA_CH_VALUE == LPAREN) { 01116 /* This is treated as a structure constructor */ 01117 /* until further notice. If it turns out to */ 01118 /* be a function call, all the needed info is */ 01119 /* retained. */ 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 /* error */ 01137 /* must be either structure constructor or function */ 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 /* error */ 01145 /* must be structure constructor */ 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 /* generic intrinsic interface call */ 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 /* intentionally blank */ 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; /* skip over the dummy arguments */ 01319 } 01320 } 01321 } 01322 01323 ATD_TYPE_IDX(rslt_idx) = intrin_tbl[j].data_type; 01324 01325 # ifdef _TARGET64 01326 /* 01327 The intrinsic table is designed for a 32 bit machine. 01328 Sizes must be doubled. 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 /* If in Cray compatability mode, we must double the sizes. */ 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 /* If double precision is disabled, half the size. */ 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; /* skip over the dummy arguments */ 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 /* generic interface call or forward ref to function */ 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 /* return the operand that came in */ 01488 /* or the attr_idx. */ 01489 /* intentionally blank */ 01490 01491 goto EXIT; 01492 } 01493 01494 01495 if (LA_CH_VALUE == LPAREN) { 01496 /* do that array stuff */ 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 /* copy either the struct subtree that was passed in, */ 01505 /* or the attr_idx */ 01506 COPY_OPND(IR_OPND_L(subs_idx), (*result_opnd)); 01507 01508 /* put subs_idx into result opnd for now */ 01509 OPND_FLD((*result_opnd)) = IR_Tbl_Idx; 01510 OPND_IDX((*result_opnd)) = subs_idx; 01511 01512 /* LA_CH is '(' */ 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 /* could be function with no args */ 01528 break; 01529 } 01530 else if (next_arg_is_kwd_equal ()) { 01531 MATCHED_TOKEN_CLASS(Tok_Class_Id); 01532 /* could be kwd arg so lets make text for now. */ 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 /* do some text stuff here */ 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 } /* if (array_idx) */ 01618 01619 /* now check for possible substring reference */ 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 /* put substring idx into result_opnd */ 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 /* consume ( */ 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 /* intentionally blank */ 01696 } 01697 else { 01698 01699 /* By the way, LA_CH_VALUE should be LPAREN */ 01700 01701 if (ambiguous_ref) { 01702 /* host reference is scalar so might be function call */ 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 /* If this is a dummy arg, the Proc will be switched to */ 01770 /* Dummy_Proc by this routine. */ 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 { /* found error with attr */ 01791 parse_err_flush(Find_Ref_End, NULL); 01792 parsed_ok = FALSE; 01793 goto EXIT; 01794 } 01795 } 01796 else { 01797 /* pass back whatever is in result_opnd */ 01798 goto EXIT; 01799 } 01800 } 01801 } 01802 } /* if (LA_CH_VALUE == LPAREN) */ 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 /* not declared with pe dimensions */ 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 /* Let it continue to pick up the co-array subobject */ 01825 } 01826 01827 if (subs_idx == NULL_IDX) { 01828 NTR_IR_TBL(subs_idx); 01829 01830 /* LA_CH is '[' */ 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 /* put subs_idx into result opnd for now */ 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 /* do some text stuff here */ 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 /* leave list3_idx as NO_Tbl_Idx */ 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 /* leave list_idx as NO_Tbl_Idx */ 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 /* swallow ] */ 01980 NEXT_LA_CH; 01981 } 01982 } 01983 # endif 01984 01985 if (LA_CH_VALUE == PERCENT) { 01986 01987 /* first see if attr_idx is a structure */ 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 /* no ID after %, must be an error */ 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 /* change local attr to function */ 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 } /* parse_deref */ 02074 02075 /******************************************************************************\ 02076 |* *| 02077 |* Description: *| 02078 |* Parse I/O implied-DO loops. DATA implied-DOs are parsed by *| 02079 |* parse_data_imp_do in p_dcls.c. *| 02080 |* *| 02081 |* Input parameters: *| 02082 |* NONE *| 02083 |* *| 02084 |* Output parameters: *| 02085 |* result_opnd - opnd_type, points to root of tree returned. *| 02086 |* *| 02087 |* Returns: *| 02088 |* TRUE if parsed ok *| 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 /* shouldn't be here */ 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 /* this is a complex constant */ 02183 reset_lex(buf_idx,stmt_num); 02184 parsed_ok = parse_expr(&opnd) && parsed_ok; 02185 } 02186 else { 02187 /* go back and swallow beginning ( */ 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 /* no list before lcv */ 02238 02239 PRINTMSG(line, 872, Error, col); 02240 parsed_ok = FALSE; 02241 } 02242 02243 had_equal = TRUE; 02244 02245 /* Set up right child (loop control variable) of the Implied_Do */ 02246 /* IR. */ 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 /* clear ATD_SEEN_IN_IMP_DO */ 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 /* clear ATD_SEEN_IN_IMP_DO */ 02290 02291 ATD_SEEN_IN_IMP_DO(OPND_IDX(opnd)) = FALSE; 02292 } 02293 } 02294 02295 /* Create an IL to hold the start value and attach it to the LCV */ 02296 /* IL. Parse the loop start expression. */ 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 /* Eat the comma following the loop start expression. */ 02313 /* Create an IL to hold the end value and attach it to the start */ 02314 /* value IL. Parse the loop end expression. */ 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 /* If the increment expression exists, create an IL to hold it */ 02325 /* and attach it to the end value IL. Parse the inc expression. */ 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; /* swallow ) */ 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 } /* parse_imp_do */ 02404 02405 02406 /******************************************************************************\ 02407 |* *| 02408 |* Description: *| 02409 |* This procedure should be called to check a label reference in a branch *| 02410 |* context (GO TO, arithmetic IF, actual arg that is a label, etc.). *| 02411 |* *| 02412 |* Input parameters: *| 02413 |* NONE *| 02414 |* *| 02415 |* Output parameters: *| 02416 |* NONE *| 02417 |* *| 02418 |* Global data used: *| 02419 |* The data structure "token" is assumed to be the label token. *| 02420 |* The Statement Header for the statement containing the label reference *| 02421 |* is assumed to exist. *| 02422 |* *| 02423 |* Returns: *| 02424 |* The index to the label's Attribute entry. *| 02425 |* *| 02426 |* Algorithm notes: *| 02427 |* *| 02428 |* Processing of the label reference is dependent on the state of the *| 02429 |* label's Attribute entry: *| 02430 |* *| 02431 |* Case 1: It doesn't exist. *| 02432 |* This is the first reference to the label and it's a forward *| 02433 |* reference. Enter it into the symbol table and generate a Forward *| 02434 |* Ref entry. *| 02435 |* *| 02436 |* Case 2: It exists in the symbol table and is defined. *| 02437 |* This is a backward reference. Check the reference to the label. *| 02438 |* *| 02439 |* Case 3: It exists in the symbol table but is still undefined. *| 02440 |* This is another forward reference to the label. Generate a *| 02441 |* Forward Ref entry. *| 02442 |* *| 02443 |* Each new Forward Ref entry is attached to the head of the chain of *| 02444 |* Forward Ref entries attached to the label's Attribute entry via *| 02445 |* ATL_FWD_REF_IDX (when the label is encountered, the Forward Ref chain *| 02446 |* is processed, the entries are freed, and the field is set to the index *| 02447 |* of the Statement Header for the label's defining statement; the field *| 02448 |* is then referenced using ATL_DEF_STMT_IDX). *| 02449 |* *| 02450 |* Note: If the statement containing the label reference has been marked *| 02451 |* in error, the label reference semantics will not be checked. *| 02452 |* This should prevent meaningless messages from being issued for *| 02453 |* oddball cases like a GO TO existing in an interface block. *| 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 /* If the stmt contains a reference to its own label, set */ 02480 /* ATL_EXECUTABLE now so label_ref_semantics will work correctly. */ 02481 /* (Normally, ATL_EXECUTABLE is set AFTER the stmt is parsed.) */ 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 } /* check_label_ref */ 02538 02539 02540 /******************************************************************************\ 02541 |* *| 02542 |* Description: *| 02543 |* Given location information about the reference to a label and the *| 02544 |* statement defining the label, this procedure verifies that the *| 02545 |* reference to the label is valid. The essential rule for a label *| 02546 |* reference being valid is that the reference and label must be within *| 02547 |* the same block or the label must be in an outer block. It doesn't *| 02548 |* matter that the label occurs before or after the reference. Thus, *| 02549 |* this procedure may be used to check both forward and backward *| 02550 |* references (see the design paper for details). *| 02551 |* *| 02552 |* Input parameters: *| 02553 |* attr_idx : the index to the label's Attribute entry *| 02554 |* ref_blk_idx : the index to the Statement Header of the statement *| 02555 |* that begins the block containing the label *| 02556 |* reference *| 02557 |* ref_line_num : the line number of the label reference *| 02558 |* ref_col_num : the column number of the label reference *| 02559 |* *| 02560 |* Output parameters: *| 02561 |* NONE *| 02562 |* *| 02563 |* Returns: *| 02564 |* NONE *| 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 /* If something is wrong with the label (possibly because there was */ 02585 /* something wrong with its defining statement), don't do any checking. */ 02586 02587 if (AT_DCL_ERR(attr_idx)) { 02588 goto EXIT; 02589 } 02590 02591 02592 /* If this is a backward reference, AT_DEFINED is TRUE and */ 02593 /* ATL_DEF_STMT_IDX points at the label's defining statement. Otherwise, */ 02594 /* we are processing a forward reference so ATL_DEF_STMT_IDX (aka */ 02595 /* ATL_FWD_REF_IDX) is used to point at the Forward Ref chain. But */ 02596 /* processing a forward reference means we are now at the defining */ 02597 /* statement so the statement type is available from a global variable. */ 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 /* If the label is defined on a nonexecutable statement or on an */ 02608 /* executable statement that can not be a branch target, issue a message */ 02609 /* and quit. Note that if the label reference is from an ASSIGN stmt, */ 02610 /* the reference can be to a FORMAT statement. */ 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 /* A jump into a WHERE construct or a CASE block is not allowed. */ 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 /* (or FORALL construct) */ 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 /* Nothing more we can do if the reference is from an ASSIGN statement. */ 02711 02712 if (context != Branch_Context) { 02713 goto EXIT; 02714 } 02715 02716 02717 /* We have ascertained that the label is defined on a valid branch target */ 02718 /* statement. Now check that the branch is into a valid block. */ 02719 /* If the label is defined at the procedure level, the jump can't */ 02720 /* possibly be into a block. Also, if the label and reference both exist */ 02721 /* in the same block, the jump is also OK. */ 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 /* If control reaches this point, the label and reference are in */ 02730 /* different blocks. We now need to see if the label is defined in a */ 02731 /* block that is a containing block of the block containing the reference.*/ 02732 /* This is done by searching a "long-lived" block stack that is formed by */ 02733 /* parent links in Statement Headers for executable blocking statements. */ 02734 /* However, the stack need not be searched if the reference is at the */ 02735 /* procedure level because we know we have a jump into a block. */ 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 /* The jump is into a block. */ 02759 /* A jump to an END SELECT or END DO from outside the construct (or from */ 02760 /* outside the innermost block DO) is an error. */ 02761 /* A jump to an END IF from outside the construct is obsolescent. */ 02762 /* A jump to any statement in a block or nonblock DO or into an IF */ 02763 /* construct subblock (possibly from another IF subblock) is unsafe (to */ 02764 /* be compatible with CF77) and is not standard-conforming. */ 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 /* do nothing in here */ 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 } /* label_ref_semantics */ 02841 02842 02843 /******************************************************************************\ 02844 |* *| 02845 |* Description: *| 02846 |* This procedure builds a Forward Ref entry for a branch context (GO TO, *| 02847 |* arithmetic IF, actual argument for procedure call), a reference to a *| 02848 |* FORMAT statement, or a reference to a label in an ASSIGN or DO *| 02849 |* statement. *| 02850 |* *| 02851 |* Each new Forward Ref entry is attached to the head of the chain of *| 02852 |* Forward Ref entries attached to the label's Attribute entry via *| 02853 |* ATL_FWD_REF_IDX (when the label is encountered, the Forward Ref chain *| 02854 |* is processed, the entries are freed, and the field is set to the index *| 02855 |* of the Statement Header for the label's defining statement; the field *| 02856 |* is then referenced using ATL_DEF_STMT_IDX). *| 02857 |* *| 02858 |* Input parameters: *| 02859 |* lbl_attr_idx : The index of the label's Attribute entry. *| 02860 |* fwd_ref_cntxt : An enumerated list describing the label reference. *| 02861 |* *| 02862 |* Output parameters: *| 02863 |* NONE *| 02864 |* *| 02865 |* Global data used: *| 02866 |* The data structure "token" is assumed to be the label token. *| 02867 |* The Attribute entry for the label is assumed to exist. *| 02868 |* *| 02869 |* Returns: *| 02870 |* NONE *| 02871 |* *| 02872 |* Algorithm notes: *| 02873 |* - The first Forward Ref entry does NOT point back at the label's Attr *| 02874 |* entry. *| 02875 |* *| 02876 |* - The IL_FLD field is used as the indicator of the context of the *| 02877 |* Forward Ref entry. The values in IL_FLD have the following meanings: *| 02878 |* *| 02879 |* SH_Tbl_Idx : branch context (GO TO, arithmetic IF, etc.); IL_IDX *| 02880 |* points to the first stmt of the block containing *| 02881 |* the label definition or is NULL_IDX to indicate *| 02882 |* that the label is defined at the procedure level *| 02883 |* NO_Tbl_Idx : must check the "rank" field (accessed by macro *| 02884 |* IL_FORWARD_REF) to see if the ref is from an *| 02885 |* ASSIGN or DO stmt or to a FORMAT stmt *| 02886 |* *| 02887 |* DO statement entries really only exist in the chain to diagnose *| 02888 |* references to a label if the label is never defined. (See the *| 02889 |* undefined label checks in the end-pass-1-checks routine.) *| 02890 |* ASSIGN statement entries exist so that a diagnostic can be issued if *| 02891 |* the label is not defined on an executable or FORMAT statement. *| 02892 |* FORMAT statement entries exist so that if the label turns out to be *| 02893 |* defined on an executable stmt, references to it as a FORMAT stmt label *| 02894 |* can be diagnosed. (And if the label turns out to be on a FORMAT stmt *| 02895 |* and is referenced in a branch context, the misuse can be diagnosed.) *| 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 /* Check to see if this label ref is within a parallel region and */ 02948 /* save the statement header that begins the region if it is. */ 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 } /* build_fwd_ref_entry */ 03005 03006 03007 /******************************************************************************\ 03008 |* *| 03009 |* Description: *| 03010 |* This routine resolves forward references to labels that are either *| 03011 |* FORMAT labels or branch target labels. *| 03012 |* *| 03013 |* Input parameters: *| 03014 |* NONE *| 03015 |* *| 03016 |* Output parameters: *| 03017 |* NONE *| 03018 |* *| 03019 |* Returns: *| 03020 |* NOTHING *| 03021 |* *| 03022 |* Algorithm notes: *| 03023 |* The type of the forward reference is determined by IL_FLD and values *| 03024 |* in the IL operand "rank" field. If IL_FLD is SH_Tbl_Idx, the *| 03025 |* reference is due to a branch context. If IL_FLD is NO_Tbl_Idx, then *| 03026 |* the "rank" field value contains the reason for the forward reference *| 03027 |* (the "rank" field is accessed via macro IL_FORWARD_REF). *| 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 /* The label is OK. If it's defined on a FORMAT stmt, just ensure that */ 03045 /* all references are format refs. Otherwise, the label is a branch */ 03046 /* target so make sure the branch is allowed. */ 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 /* The label is bad. Abandon the forward references. */ 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 } /* resolve_fwd_lbl_refs */ 03157 03158 /******************************************************************************\ 03159 |* *| 03160 |* Description: *| 03161 |* This routine checks for branches into or out of parallel, doall, *| 03162 |* guard or case autotasking regions. *| 03163 |* *| 03164 |* Input parameters: *| 03165 |* ref_blk_sh_idx -if == NULL_IDX => the ref was not in parallel region *| 03166 |* else its the first sh in the ref's region. *| 03167 |* label_attr - label attr in question. *| 03168 |* line, col - line and column of the goto branch. *| 03169 |* *| 03170 |* Output parameters: *| 03171 |* NONE *| 03172 |* *| 03173 |* Returns: *| 03174 |* NOTHING *| 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 } /* check_cmic_blk_branches */ 03218 03219 /******************************************************************************\ 03220 |* *| 03221 |* Description: *| 03222 |* <description> *| 03223 |* *| 03224 |* Input parameters: *| 03225 |* NONE *| 03226 |* *| 03227 |* Output parameters: *| 03228 |* NONE *| 03229 |* *| 03230 |* Returns: *| 03231 |* NOTHING *| 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 } /* block_err_string */ 03370 03371 /******************************************************************************\ 03372 |* *| 03373 |* Description: *| 03374 |* Find the base attr (left-most) and set it's defined flag. *| 03375 |* If not a data object nothing is done. *| 03376 |* If data object is a function result, mark the pgm unit attr also. *| 03377 |* *| 03378 |* Input parameters: *| 03379 |* opnd - address of root opnd. *| 03380 |* *| 03381 |* Output parameters: *| 03382 |* opnd - address of root opnd. *| 03383 |* *| 03384 |* Returns: *| 03385 |* NOTHING *| 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 } /* mark_attr_defined */ 03419 03420 /******************************************************************************\ 03421 |* *| 03422 |* Description: *| 03423 |* This routine will parse ahead to see if a io list item in a paren *| 03424 |* group is a complex constant or not. This is needed because SOMEBODY *| 03425 |* thought cft77 should allow extra paren groups in io lists for *| 03426 |* clarification. *| 03427 |* *| 03428 |* Input parameters: *| 03429 |* NONE *| 03430 |* *| 03431 |* Output parameters: *| 03432 |* NONE *| 03433 |* *| 03434 |* Returns: *| 03435 |* NOTHING *| 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 /* LA_CH is char after ( */ 03453 03454 if (LA_CH_VALUE == SLASH) { 03455 /* not a complex constant, maybe a constructor */ 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 /* Assume complex constant - Try to fold */ 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 /* swallow comma */ 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 } /* "paren_grp_is_cplx_const" */ 03561 03562 /******************************************************************************\ 03563 |* *| 03564 |* Description: *| 03565 |* <description> *| 03566 |* *| 03567 |* Input parameters: *| 03568 |* NONE *| 03569 |* *| 03570 |* Output parameters: *| 03571 |* NONE *| 03572 |* *| 03573 |* Returns: *| 03574 |* NOTHING *| 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 } /* check_for_vestigial_task_blks */ 03617 03618 /******************************************************************************\ 03619 |* *| 03620 |* Description: *| 03621 |* <description> *| 03622 |* *| 03623 |* Input parameters: *| 03624 |* NONE *| 03625 |* *| 03626 |* Output parameters: *| 03627 |* NONE *| 03628 |* *| 03629 |* Returns: *| 03630 |* NOTHING *| 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 } /* set_up_fake_dt_blk */