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_end.c 5.7 09/01/99 09:11:00\n"; 00038 00039 # include "defines.h" /* Machine dependent ifdefs */ 00040 00041 # include "host.m" /* Host machine dependent macros.*/ 00042 # include "host.h" /* Host machine dependent header.*/ 00043 # include "target.m" /* Target machine dependent macros.*/ 00044 # include "target.h" /* Target machine dependent header.*/ 00045 00046 # include "globals.m" 00047 # include "tokens.m" 00048 # include "sytb.m" 00049 # include "p_globals.m" 00050 # include "debug.m" 00051 00052 # include "globals.h" 00053 # include "tokens.h" 00054 # include "sytb.h" 00055 # include "p_globals.h" 00056 # include "p_end.h" 00057 00058 00059 /*****************************************************************\ 00060 |* Function prototypes of static functions declared in this file *| 00061 \*****************************************************************/ 00062 00063 /* The prototypes for the end_.. routines are in p_end.h. They are needed */ 00064 /* there so that the end routine calling table can be initialized. */ 00065 00066 static char *blk_desc_str(int); 00067 static boolean end_task_do_blk(void); 00068 static void finish_cdir_id(void); 00069 static void loop_end_processing(void); 00070 00071 # if defined(GENERATE_WHIRL) 00072 static void check_loop_bottom_nesting(void); 00073 # endif 00074 00075 00076 /******************************************************************************\ 00077 |* *| 00078 |* Description: *| 00079 |* If there were CDIR ID directives in the program unit, terminate the *| 00080 |* USMID string with a null character. *| 00081 |* *| 00082 |* Here's how this works. Each !DIR$ ID line is assigned its own *| 00083 |* compiler temp. The size of the temp is the number or chars in the *| 00084 |* string. There is no null character at the end of the string. For *| 00085 |* instance if !DIR$ ID="hello", at temp is created of type CHAR*5. *| 00086 |* This routine is called after all !DIR$ ID's have been parsed (at the *| 00087 |* END statement. Another temp is created whose length is at least one *| 00088 |* character with the size such that the whole block is word aligned. *| 00089 |* All the temps are in the same storage block and their offsets are *| 00090 |* such that all the temps are concatenated together with the NULL at *| 00091 |* the end of the last temp. *| 00092 |* *| 00093 |* Input parameters: *| 00094 |* NONE *| 00095 |* *| 00096 |* Output parameters: *| 00097 |* NONE *| 00098 |* *| 00099 |* Returns: *| 00100 |* NONE *| 00101 |* *| 00102 \******************************************************************************/ 00103 00104 static void finish_cdir_id(void) 00105 { 00106 00107 size_offset_type aligned_length; 00108 int column; 00109 int init_idx; 00110 size_offset_type length; 00111 int line; 00112 int list_idx; 00113 id_str_type name; 00114 int new_str_idx; 00115 opnd_type opnd; 00116 int prog_unit_has_id_line; 00117 int tmp_idx; 00118 int type_idx; 00119 00120 00121 TRACE (Func_Entry, "finish_cdir_id", NULL); 00122 00123 CREATE_ID(name, sb_name[What_Blk], sb_len[What_Blk]); 00124 00125 prog_unit_has_id_line = srch_stor_blk_tbl(name.string, 00126 sb_len[What_Blk], 00127 curr_scp_idx); 00128 00129 if (prog_unit_has_id_line != NULL_IDX) { 00130 00131 /* Must have an ID string. Get a temp, initialize to null characters, */ 00132 /* then put into named static block. */ 00133 00134 line = curr_glb_line; 00135 column = 0; 00136 tmp_idx = gen_compiler_tmp(line, column, Shared, TRUE); 00137 ATD_STOR_BLK_IDX(tmp_idx) = prog_unit_has_id_line; 00138 ATD_TMP_SEMANTICS_DONE(tmp_idx) = TRUE; 00139 ATD_OFFSET_ASSIGNED(tmp_idx) = TRUE; 00140 00141 # if defined(_DEBUG) 00142 00143 /* Must be a constant length. */ 00144 00145 if (SB_LEN_FLD(ATD_STOR_BLK_IDX(tmp_idx)) != CN_Tbl_Idx) { 00146 PRINTMSG(line, 1201, Internal, column, 00147 SB_NAME_PTR(ATD_STOR_BLK_IDX(tmp_idx))); 00148 } 00149 # endif 00150 00151 length.idx = SB_LEN_IDX(ATD_STOR_BLK_IDX(tmp_idx)); 00152 length.fld = SB_LEN_FLD(ATD_STOR_BLK_IDX(tmp_idx)); 00153 ATD_OFFSET_IDX(tmp_idx) = length.idx; 00154 ATD_OFFSET_FLD(tmp_idx) = length.fld; 00155 aligned_length.idx = CN_INTEGER_CHAR_BIT_IDX; 00156 aligned_length.fld = CN_Tbl_Idx; 00157 00158 if (!size_offset_binary_calc(&length, &aligned_length, Plus_Opr, 00159 &aligned_length)) { 00160 AT_DCL_ERR(tmp_idx) = TRUE; 00161 } 00162 00163 align_bit_length(&aligned_length, TARGET_BITS_PER_WORD); 00164 00165 if (!size_offset_binary_calc(&aligned_length,&length,Minus_Opr,&length)) { 00166 AT_DCL_ERR(tmp_idx) = TRUE; 00167 } 00168 00169 if (aligned_length.fld == NO_Tbl_Idx) { 00170 aligned_length.fld = CN_Tbl_Idx; 00171 aligned_length.idx = ntr_const_tbl(aligned_length.type_idx, 00172 FALSE, 00173 aligned_length.constant); 00174 } 00175 00176 SB_LEN_FLD(ATD_STOR_BLK_IDX(tmp_idx)) = aligned_length.fld; 00177 SB_LEN_IDX(ATD_STOR_BLK_IDX(tmp_idx)) = aligned_length.idx; 00178 00179 /* We now have the length in bits of the null temp in length. */ 00180 /* This needs to be translated to # of chars for character length. */ 00181 00182 aligned_length.fld = CN_Tbl_Idx; 00183 aligned_length.idx = CN_INTEGER_CHAR_BIT_IDX; 00184 00185 if (!size_offset_binary_calc(&length, &aligned_length, Div_Opr, &length)){ 00186 AT_DCL_ERR(tmp_idx) = TRUE; 00187 } 00188 00189 if (length.fld == NO_Tbl_Idx) { 00190 length.fld = CN_Tbl_Idx; 00191 length.idx = ntr_const_tbl(length.type_idx, 00192 FALSE, 00193 length.constant); 00194 } 00195 00196 OPND_FLD(opnd) = AT_Tbl_Idx; 00197 OPND_IDX(opnd) = tmp_idx; 00198 OPND_LINE_NUM(opnd) = line; 00199 OPND_COL_NUM(opnd) = column; 00200 00201 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 00202 TYP_TYPE(TYP_WORK_IDX) = Character; 00203 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 00204 TYP_DESC(TYP_WORK_IDX) = Default_Typed; 00205 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char; 00206 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx; 00207 TYP_IDX(TYP_WORK_IDX) = length.idx; 00208 type_idx = ntr_type_tbl(); 00209 00210 /* Call ntr_const_tbl with NULL for the incoming constant so it */ 00211 /* will just allocate the amount of space needed. ntr_const_tbl does */ 00212 /* zero out the memory. */ 00213 00214 new_str_idx = ntr_const_tbl(type_idx, TRUE, NULL); 00215 00216 ATD_TYPE_IDX(tmp_idx) = CN_TYPE_IDX(new_str_idx); 00217 00218 gen_whole_substring(&opnd, 0); 00219 00220 /* Initialize the temp. */ 00221 00222 NTR_IR_TBL(init_idx); 00223 IR_OPR(init_idx) = Init_Opr; 00224 # if defined(GENERATE_WHIRL) 00225 IR_OPR(init_idx) = Null_Opr; 00226 # endif 00227 00228 /* Must have a type idx. */ 00229 00230 IR_TYPE_IDX(init_idx) = ATD_TYPE_IDX(tmp_idx); 00231 IR_LINE_NUM(init_idx) = line; 00232 IR_COL_NUM(init_idx) = column; 00233 IR_LINE_NUM_R(init_idx) = line; 00234 IR_COL_NUM_R(init_idx) = column; 00235 COPY_OPND(IR_OPND_L(init_idx), opnd); 00236 00237 NTR_IR_LIST_TBL(list_idx); 00238 IR_FLD_R(init_idx) = IL_Tbl_Idx; 00239 IR_IDX_R(init_idx) = list_idx; 00240 IR_LIST_CNT_R(init_idx) = 3; 00241 IL_IDX(IR_IDX_R(init_idx))= new_str_idx; 00242 00243 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 00244 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 00245 IL_FLD(list_idx) = CN_Tbl_Idx; 00246 IL_IDX(list_idx) = new_str_idx; 00247 IL_LINE_NUM(list_idx) = line; 00248 IL_COL_NUM(list_idx) = column; 00249 00250 list_idx = IL_NEXT_LIST_IDX(list_idx); 00251 00252 IL_FLD(list_idx) = CN_Tbl_Idx; 00253 IL_IDX(list_idx) = CN_INTEGER_ONE_IDX; 00254 IL_LINE_NUM(list_idx) = line; 00255 IL_COL_NUM(list_idx) = column; 00256 00257 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 00258 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 00259 list_idx = IL_NEXT_LIST_IDX(list_idx); 00260 00261 IL_FLD(list_idx) = CN_Tbl_Idx; 00262 IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX; 00263 IL_LINE_NUM(list_idx) = line; 00264 IL_COL_NUM(list_idx) = column; 00265 00266 gen_sh(Before, Assignment_Stmt, line, column, 00267 FALSE, FALSE, TRUE); 00268 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = init_idx; 00269 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 00270 00271 } 00272 00273 TRACE (Func_Exit, "finish_cdir_id", NULL); 00274 00275 } /* finish_cdir_id */ 00276 00277 /******************************************************************************\ 00278 |* *| 00279 |* Description: *| 00280 |* Parse the END statement, find out what kind of end it is, check for *| 00281 |* block errors, and call the particular end processing routine. *| 00282 |* *| 00283 |* Input parameters: *| 00284 |* NONE *| 00285 |* *| 00286 |* Output parameters: *| 00287 |* NONE *| 00288 |* *| 00289 |* Returns: *| 00290 |* NONE *| 00291 |* *| 00292 \******************************************************************************/ 00293 00294 void parse_end_stmt (void) 00295 00296 { 00297 int blk_idx; 00298 int buf_idx; 00299 boolean found_name; 00300 token_values_type keyword; 00301 boolean match_name = TRUE; 00302 boolean msg_issued; 00303 int stmt_num; 00304 00305 00306 TRACE (Func_Entry, "parse_end_stmt", NULL); 00307 00308 end_of_contains = FALSE; 00309 00310 if (LA_CH_VALUE == EOS) { 00311 00312 /* If the END stmt is the action-stmt of a logical IF, don't parse it. */ 00313 00314 if (if_stmt_lbl_idx != NULL_IDX) { 00315 NEXT_LA_CH; 00316 goto EXIT; 00317 } 00318 00319 check_for_vestigial_task_blks(); 00320 00321 if (CURR_BLK == Contains_Blk) { 00322 end_contains(FALSE); 00323 } 00324 00325 if (stmt_label_idx != NULL_IDX) { 00326 gen_attr_and_IR_for_lbl(FALSE); 00327 } 00328 00329 blk_idx = blk_stk_idx; 00330 00331 if (CURR_BLK > Interface_Body_Blk) { 00332 00333 /* Search for the nearest program unit block if it's just an END */ 00334 /* stmt or if the current block was a popped CONTAINS block. If */ 00335 /* there is a parse error, then just pop the current block. Have */ 00336 /* end_of_contains check, because if a CONTAINS block is popped, */ 00337 /* then need to pop a program unit block. */ 00338 00339 # ifdef _DEBUG 00340 if (blk_stk_idx == NULL_IDX) { 00341 PRINTMSG(stmt_start_line, 160, Internal, stmt_start_col, NULL_IDX); 00342 } 00343 # endif 00344 00345 if (stmt_label_idx == NULL_IDX) { 00346 00347 for (blk_idx = blk_stk_idx; 00348 BLK_TYPE(blk_idx) > Interface_Body_Blk; 00349 blk_idx--); 00350 } 00351 else { 00352 00353 /* If this END statement is the termination statement for a DO */ 00354 /* loop, issue an error message and pop the DO block. */ 00355 00356 msg_issued = FALSE; 00357 blk_idx = blk_stk_idx; 00358 00359 while (BLK_TYPE(blk_idx) > Module_Proc_Blk) { 00360 00361 if (stmt_label_idx == BLK_LABEL(blk_idx)) { 00362 00363 if (! msg_issued) { 00364 PRINTMSG(stmt_start_line, 244, Error, stmt_start_col, 00365 stmt_type_str[stmt_type]); 00366 msg_issued = TRUE; 00367 } 00368 00369 if (blk_idx != blk_stk_idx) { 00370 pop_and_err_blk_stk(blk_idx, FALSE); 00371 } 00372 00373 move_blk_to_end(blk_idx); 00374 00375 POP_BLK_STK; 00376 } 00377 --blk_idx; 00378 } 00379 } 00380 blk_idx = blk_match_err(BLK_TYPE(blk_idx), FALSE, FALSE); 00381 } 00382 } 00383 else if (MATCHED_TOKEN_CLASS (Tok_Class_Keyword)) { 00384 keyword = TOKEN_VALUE(token); 00385 buf_idx = TOKEN_BUF_IDX(token); 00386 stmt_num = TOKEN_STMT_NUM(token); 00387 00388 check_for_vestigial_task_blks(); 00389 00390 if (keyword == Tok_Kwd_File) { 00391 stmt_type = Endfile_Stmt; 00392 SH_STMT_TYPE(curr_stmt_sh_idx) = Endfile_Stmt; 00393 00394 if (stmt_label_idx != NULL_IDX) { 00395 gen_attr_and_IR_for_lbl(FALSE); 00396 } 00397 00398 parse_endfile_stmt(); 00399 goto EXIT; 00400 } 00401 00402 /* If the END stmt is the action-stmt of a logical IF, don't parse it. */ 00403 00404 if (if_stmt_lbl_idx != NULL_IDX) { 00405 parse_err_flush(Find_EOS, NULL); 00406 NEXT_LA_CH; 00407 goto EXIT; 00408 } 00409 00410 if (keyword == Tok_Kwd_Block && 00411 !matched_specific_token(Tok_Kwd_Data, Tok_Class_Keyword)) { 00412 reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token)); 00413 keyword = Tok_Id; /* Force to default clause for error */ 00414 } 00415 00416 found_name = MATCHED_TOKEN_CLASS(Tok_Class_Id); 00417 00418 if (CURR_BLK == Contains_Blk && 00419 (keyword == Tok_Kwd_Module || keyword == Tok_Kwd_Program || 00420 keyword == Tok_Kwd_Function || keyword == Tok_Kwd_Subroutine || 00421 keyword == Tok_Kwd_CoFunction || keyword == Tok_Kwd_CoSubroutine || 00422 keyword == Tok_Kwd_Block)) { 00423 00424 /* Because a contains may happen in a BLOCKDATA unit (an error is */ 00425 /* issued), it must be popped off at the end of the blockdata. */ 00426 00427 end_contains(FALSE); 00428 } 00429 00430 if (found_name) { 00431 match_name = (CURR_BLK_NAME != NULL_IDX) ? 00432 (compare_names(TOKEN_ID(token).words, 00433 TOKEN_LEN(token), 00434 AT_OBJ_NAME_LONG(CURR_BLK_NAME), 00435 AT_NAME_LEN(CURR_BLK_NAME)) == 0) : 00436 FALSE; 00437 } 00438 00439 if (stmt_label_idx != NULL_IDX && keyword != Tok_Kwd_Type) { 00440 gen_attr_and_IR_for_lbl(FALSE); 00441 } 00442 00443 blk_idx = blk_stk_idx; 00444 00445 switch (keyword) { 00446 00447 case Tok_Kwd_Block: 00448 stmt_type = End_Blockdata_Stmt; 00449 SH_STMT_TYPE(curr_stmt_sh_idx) = End_Blockdata_Stmt; 00450 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 00451 00452 00453 /* Issue any deferred src_input messages. */ 00454 00455 issue_deferred_msgs(); 00456 00457 00458 if (CURR_BLK != Blockdata_Blk || !match_name) { 00459 blk_idx = blk_match_err(Blockdata_Blk, found_name, FALSE); 00460 00461 if (CURR_BLK != Blockdata_Blk) { 00462 SCP_IN_ERR(curr_scp_idx) = TRUE; 00463 } 00464 } 00465 00466 break; 00467 00468 00469 case Tok_Kwd_Module: 00470 stmt_type = End_Module_Stmt; 00471 SH_STMT_TYPE(curr_stmt_sh_idx) = End_Module_Stmt; 00472 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 00473 00474 00475 /* Issue any deferred src_input messages. */ 00476 00477 issue_deferred_msgs(); 00478 00479 00480 if (CURR_BLK != Module_Blk || !match_name) { 00481 blk_idx = blk_match_err(Module_Blk, found_name, FALSE); 00482 00483 if (CURR_BLK != Module_Blk) { 00484 SCP_IN_ERR(curr_scp_idx) = TRUE; 00485 } 00486 } 00487 00488 break; 00489 00490 00491 case Tok_Kwd_Program: 00492 stmt_type = End_Program_Stmt; 00493 SH_STMT_TYPE(curr_stmt_sh_idx) = End_Program_Stmt; 00494 00495 if (stmt_label_idx != NULL_IDX) { 00496 end_labeled_do(); 00497 blk_idx = blk_stk_idx; /* end_labeled_do may have popped stk.*/ 00498 } 00499 00500 00501 /* Issue any deferred src_input messages. */ 00502 00503 issue_deferred_msgs(); 00504 00505 00506 if (CURR_BLK != Program_Blk || !match_name) { 00507 blk_idx = blk_match_err(Program_Blk, found_name, FALSE); 00508 00509 if (CURR_BLK != Program_Blk) { 00510 SCP_IN_ERR(curr_scp_idx) = TRUE; 00511 } 00512 } 00513 00514 break; 00515 00516 00517 case Tok_Kwd_Subroutine: 00518 case Tok_Kwd_CoSubroutine: 00519 00520 stmt_type = End_Subroutine_Stmt; 00521 SH_STMT_TYPE(curr_stmt_sh_idx) = End_Subroutine_Stmt; 00522 00523 if (stmt_label_idx != NULL_IDX) { 00524 end_labeled_do(); 00525 blk_idx = blk_stk_idx; /* end_labeled_do may have popped stk.*/ 00526 } 00527 00528 00529 /* Issue any deferred src_input messages. */ 00530 00531 issue_deferred_msgs(); 00532 00533 00534 if (STMT_CANT_BE_IN_BLK(End_Subroutine_Stmt, CURR_BLK) || 00535 !match_name || ATP_PGM_UNIT(CURR_BLK_NAME) != Subroutine) { 00536 blk_idx = blk_match_err(Subroutine_Blk, found_name, FALSE); 00537 SCP_IN_ERR(curr_scp_idx) = TRUE; 00538 } 00539 00540 break; 00541 00542 00543 case Tok_Kwd_Function: 00544 case Tok_Kwd_CoFunction: 00545 stmt_type = End_Function_Stmt; 00546 SH_STMT_TYPE(curr_stmt_sh_idx) = End_Function_Stmt; 00547 00548 if (stmt_label_idx != NULL_IDX) { 00549 end_labeled_do(); 00550 blk_idx = blk_stk_idx; /* end_labeled_do may have popped stk.*/ 00551 } 00552 00553 00554 /* Issue any deferred src_input messages. */ 00555 00556 issue_deferred_msgs(); 00557 00558 00559 if (STMT_CANT_BE_IN_BLK(End_Function_Stmt, CURR_BLK) || 00560 !match_name || ATP_PGM_UNIT(CURR_BLK_NAME) != Function) { 00561 blk_idx = blk_match_err(Function_Blk, found_name, FALSE); 00562 SCP_IN_ERR(curr_scp_idx) = TRUE; 00563 } 00564 00565 break; 00566 00567 00568 case Tok_Kwd_Interface: 00569 00570 stmt_type = End_Interface_Stmt; 00571 SH_STMT_TYPE(curr_stmt_sh_idx) = End_Interface_Stmt; 00572 00573 if (CURR_BLK != Interface_Blk || !match_name) { 00574 blk_idx = blk_match_err(Interface_Blk, found_name, FALSE); 00575 } 00576 00577 if (blk_idx != NULL_IDX) { 00578 curr_stmt_category = Declaration_Stmt_Cat; 00579 } 00580 00581 break; 00582 00583 00584 case Tok_Kwd_Type: 00585 00586 stmt_type = End_Type_Stmt; 00587 SH_STMT_TYPE(curr_stmt_sh_idx) = End_Type_Stmt; 00588 00589 if (CURR_BLK != Derived_Type_Blk || !match_name) { 00590 blk_idx = blk_match_err(Derived_Type_Blk, found_name, FALSE); 00591 } 00592 00593 if (blk_idx != NULL_IDX) { 00594 curr_stmt_category = Declaration_Stmt_Cat; 00595 } 00596 00597 break; 00598 00599 00600 case Tok_Kwd_If: 00601 stmt_type = End_If_Stmt; 00602 SH_STMT_TYPE(curr_stmt_sh_idx) = End_If_Stmt; 00603 00604 00605 /* The END IF stmt must have a construct name if the */ 00606 /* corresponding IF stmt has a construct name. The names must */ 00607 /* be the same, of course. */ 00608 00609 if (CURR_BLK_NAME != NULL_IDX && ! found_name) { 00610 match_name = FALSE; 00611 } 00612 00613 if (STMT_CANT_BE_IN_BLK(End_If_Stmt, CURR_BLK) || ! match_name) { 00614 blk_idx = blk_match_err(If_Blk, found_name, TRUE); 00615 } 00616 00617 if ((cif_flags & XREF_RECS) && found_name && match_name) { 00618 00619 /* There are 3 cases to consider at this point: */ 00620 /* - The construct-name on the END IF matches the construct- */ 00621 /* name on the current IF construct. */ 00622 /* - The construct-name on the END IF matches the construct- */ 00623 /* name on some other IF construct. */ 00624 /* - No matching construct-name on an IF construct was found */ 00625 /* but the current block is an IF construct with a */ 00626 /* construct-name. */ 00627 /* The result of each of these cases is that the current Block */ 00628 /* Stack frame has a nonnull BLK_NAME. There is no way to tell*/ 00629 /* whether or not the construct-name matches the END IF */ 00630 /* construct-name other than by comparing the strings. */ 00631 /* We also must ensure that CURR_BLK_NAME is not null (this */ 00632 /* happens if no match was found and the top Block Stack frame */ 00633 /* has no name). */ 00634 /* We can not call cif_usage_rec unless we find a matching */ 00635 /* name because an Attr only exists if the name is defined */ 00636 /* somewhere (and we need the Attr to hold the CIF symbol id). */ 00637 00638 cif_usage_rec(CURR_BLK_NAME, 00639 AT_Tbl_Idx, 00640 TOKEN_LINE(token), 00641 TOKEN_COLUMN(token), 00642 CIF_Construct_Name_Reference); 00643 } 00644 00645 break; 00646 00647 00648 case Tok_Kwd_Do: 00649 stmt_type = End_Do_Stmt; 00650 SH_STMT_TYPE(curr_stmt_sh_idx) = End_Do_Stmt; 00651 00652 00653 /* The END DO stmt must have a construct name if the */ 00654 /* corresponding DO stmt has a construct name. The names must */ 00655 /* be the same, of course. */ 00656 00657 if (CURR_BLK_NAME != NULL_IDX && ! found_name) { 00658 match_name = FALSE; 00659 } 00660 00661 if (STMT_CANT_BE_IN_BLK(End_Do_Stmt, CURR_BLK) || !match_name) { 00662 blk_idx = blk_match_err(Do_Blk, found_name, TRUE); 00663 } 00664 00665 if ((cif_flags & XREF_RECS) && found_name && match_name) { 00666 00667 /* See the comment block in the END IF code above for the */ 00668 /* cases that must be considered. */ 00669 00670 cif_usage_rec(CURR_BLK_NAME, 00671 AT_Tbl_Idx, 00672 TOKEN_LINE(token), 00673 TOKEN_COLUMN(token), 00674 CIF_Construct_Name_Reference); 00675 } 00676 00677 break; 00678 00679 00680 case Tok_Kwd_Select: 00681 stmt_type = End_Select_Stmt; 00682 SH_STMT_TYPE(curr_stmt_sh_idx) = End_Select_Stmt; 00683 00684 00685 /* The END SELECT stmt must have a construct name if the */ 00686 /* corresponding SELECT CASE stmt has a construct name. The */ 00687 /* names must be the same, of course. */ 00688 00689 if (CURR_BLK_NAME != NULL_IDX && ! found_name) { 00690 match_name = FALSE; 00691 } 00692 00693 if (STMT_CANT_BE_IN_BLK(End_Select_Stmt, CURR_BLK) || !match_name) { 00694 blk_idx = blk_match_err(Select_Blk, found_name, TRUE); 00695 } 00696 00697 00698 if ((cif_flags & XREF_RECS) && found_name && match_name) { 00699 00700 /* See the comment block in the END IF code above for the */ 00701 /* cases that must be considered. */ 00702 00703 cif_usage_rec(CURR_BLK_NAME, 00704 AT_Tbl_Idx, 00705 TOKEN_LINE(token), 00706 TOKEN_COLUMN(token), 00707 CIF_Construct_Name_Reference); 00708 } 00709 00710 break; 00711 00712 case Tok_Kwd_Forall: 00713 00714 stmt_type = End_Forall_Stmt; 00715 SH_STMT_TYPE(curr_stmt_sh_idx) = End_Forall_Stmt; 00716 00717 /* The END FORALL stmt must have a construct name if the */ 00718 /* corresponding FORALL stmt has a construct name. The names must*/ 00719 /* be the same, of course. */ 00720 00721 if (CURR_BLK_NAME != NULL_IDX && ! found_name) { 00722 match_name = FALSE; 00723 } 00724 00725 if (STMT_CANT_BE_IN_BLK(End_Forall_Stmt, CURR_BLK) || !match_name){ 00726 blk_idx = blk_match_err(Forall_Blk, found_name, TRUE); 00727 } 00728 00729 break; 00730 00731 case Tok_Kwd_Where: 00732 00733 stmt_type = End_Where_Stmt; 00734 SH_STMT_TYPE(curr_stmt_sh_idx) = End_Where_Stmt; 00735 00736 /* The END WHERE stmt must have a construct name if the */ 00737 /* corresponding WHERE stmt has a construct name. The names must */ 00738 /* be the same, of course. */ 00739 00740 if (CURR_BLK_NAME != NULL_IDX && ! found_name) { 00741 match_name = FALSE; 00742 } 00743 00744 if (STMT_CANT_BE_IN_BLK(End_Where_Stmt, CURR_BLK) || !match_name) { 00745 blk_idx = blk_match_err(Where_Then_Blk, found_name, TRUE); 00746 } 00747 00748 break; 00749 00750 00751 default: 00752 reset_lex(buf_idx, stmt_num); 00753 MATCHED_TOKEN_CLASS(Tok_Class_Id); 00754 00755 /* Msg is expecting END, for whatever is the CURRENT block. If */ 00756 /* the current block is a CONTAINS block, pop it and we'll assume */ 00757 /* this is supposed to be a END PROGRAM, END MODULE, END FUNCTION */ 00758 /* or END SUBROUTINE statement. The SELECT CASE construct is */ 00759 /* weird because its END statement does not make use of both of */ 00760 /* the construct keywords SELECT and CASE. */ 00761 00762 if (CURR_BLK == Contains_Blk) { 00763 end_contains(FALSE); 00764 } 00765 00766 PRINTMSG(TOKEN_LINE(token), 186, Error, TOKEN_COLUMN(token), 00767 (CURR_BLK == Select_Blk) ? "SELECT" : 00768 blk_desc_str(blk_stk_idx), 00769 TOKEN_STR(token)); 00770 00771 /* Do not POP the block - but mark it in error - (like popping) */ 00772 00773 CURR_BLK_ERR = TRUE; 00774 SH_ERR_FLG(curr_stmt_sh_idx) = TRUE; 00775 blk_idx = NULL_IDX; 00776 parse_err_flush(Find_EOS, NULL); 00777 break; 00778 00779 } /* switch */ 00780 00781 if (LA_CH_VALUE != EOS) { 00782 parse_err_flush(Find_EOS, EOS_STR); 00783 } 00784 00785 } 00786 else { /* Didn't find EOS and didn't find keyword. */ 00787 PRINTMSG(LA_CH_LINE, 769, Error, LA_CH_COLUMN, 00788 (CURR_BLK == Select_Blk) ? "SELECT" : blk_desc_str(blk_stk_idx), 00789 LA_CH_VALUE); 00790 00791 parse_err_flush(Find_EOS, NULL); 00792 00793 /* Do not POP the block - but mark it in error - (like popping) */ 00794 00795 if (if_stmt_lbl_idx == NULL_IDX) { 00796 CURR_BLK_ERR = TRUE; 00797 } 00798 00799 blk_idx = NULL_IDX; 00800 } 00801 00802 00803 if (blk_idx != NULL_IDX) { /* call the END routine for block */ 00804 00805 /* Finish up any CDIR$ ID strings. */ 00806 00807 if ( (BLK_TYPE(blk_idx) >= Blockdata_Blk) && 00808 (BLK_TYPE(blk_idx) <= Subroutine_Blk) ) { 00809 finish_cdir_id(); 00810 } 00811 00812 (*end_blocks[BLK_TYPE(blk_idx)]) (FALSE); 00813 } 00814 00815 /* We should be sitting at EOS. Check to see if this is a continued END */ 00816 /* statement. If it is, issue an ANSI. stmt_line_idx is from src_input */ 00817 00818 if (LA_CH_VALUE == EOS && stmt_line_idx > 1) { 00819 PRINTMSG(LA_CH_LINE, 1640, Ansi, LA_CH_COLUMN); 00820 } 00821 00822 /* Save the line and column of the EOS (which tells us where the END stmt */ 00823 /* really ends). Eat the EOS. If we are not at the end of the file, then */ 00824 /* the next program unit either starts on the current line or the line */ 00825 /* immediately following. */ 00826 00827 cif_end_unit_line = LA_CH_LINE; 00828 cif_end_unit_column = LA_CH_COLUMN - 1; 00829 00830 NEXT_LA_CH; 00831 00832 if (EOPU_encountered && LA_CH_CLASS != Ch_Class_EOF) { 00833 cif_pgm_unit_start_line = 00834 (LA_CH_LINE == cif_end_unit_line) ? cif_end_unit_line : 00835 cif_end_unit_line + 1; 00836 } 00837 00838 EXIT: 00839 00840 TRACE (Func_Exit, "parse_end_stmt", NULL); 00841 00842 return; 00843 00844 } /* parse_end_stmt */ 00845 00846 00847 /******************************************************************************\ 00848 |* *| 00849 |* Description: *| 00850 |* Complete the processing of the END statement for a main program. *| 00851 |* *| 00852 |* Input parameters: *| 00853 |* err_call => Boolean - TRUE if this is called from an error situation. *| 00854 |* This means the compiler is trying to clean up the block *| 00855 |* stack and do error recovery. *| 00856 |* *| 00857 |* Output parameters: *| 00858 |* NONE *| 00859 |* *| 00860 |* Returns: *| 00861 |* NONE *| 00862 |* *| 00863 \******************************************************************************/ 00864 00865 static void end_program_unit(boolean err_call) 00866 00867 { 00868 int ir_idx; 00869 int glb_idx; 00870 int rtn_idx; 00871 int act_file_line; 00872 00873 00874 TRACE (Func_Entry, "end_program_unit", NULL); 00875 00876 00877 do_cmic_blk_checks(); 00878 00879 if (glb_tbl_idx[End_Attr_Idx] == NULL_IDX) { 00880 glb_tbl_idx[End_Attr_Idx] = create_lib_entry_attr(END_LIB_ENTRY, 00881 END_NAME_LEN, 00882 TOKEN_LINE(token), 00883 TOKEN_COLUMN(token)); 00884 ATP_NOSIDE_EFFECTS(glb_tbl_idx[End_Attr_Idx]) = TRUE; 00885 } 00886 00887 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[End_Attr_Idx]); 00888 00889 NTR_IR_TBL(ir_idx); 00890 IR_OPR(ir_idx) = Call_Opr; 00891 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 00892 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token); 00893 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token); 00894 00895 GLOBAL_LINE_TO_FILE_LINE(TOKEN_LINE(token), glb_idx, act_file_line); 00896 GL_SOURCE_LINES(global_line_tbl_idx) = act_file_line; 00897 set_related_gl_source_lines(global_line_tbl_idx); 00898 00899 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 00900 IR_IDX_L(ir_idx) = glb_tbl_idx[End_Attr_Idx]; 00901 IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx); 00902 IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx); 00903 00904 if (err_call) { /* This is an error situation */ 00905 gen_sh(Before, End_Program_Stmt, stmt_start_line, stmt_start_col, 00906 TRUE, FALSE, FALSE); 00907 00908 SCP_LAST_SH_IDX(curr_scp_idx) = SH_PREV_IDX(curr_stmt_sh_idx); 00909 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 00910 SCP_IN_ERR(curr_scp_idx) = TRUE; 00911 } 00912 else { 00913 SCP_LAST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx; 00914 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 00915 00916 NTR_IR_TBL(rtn_idx); 00917 IR_TYPE_IDX(rtn_idx) = TYPELESS_DEFAULT_TYPE; 00918 IR_OPR(rtn_idx) = Return_Opr; 00919 IR_LINE_NUM(rtn_idx) = IR_LINE_NUM(ir_idx); 00920 IR_COL_NUM(rtn_idx) = IR_COL_NUM(ir_idx); 00921 gen_sh(After, 00922 Return_Stmt, 00923 IR_LINE_NUM(ir_idx), 00924 IR_COL_NUM(ir_idx), 00925 FALSE, 00926 TRUE, 00927 TRUE); 00928 SH_IR_IDX(curr_stmt_sh_idx) = rtn_idx; 00929 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 00930 00931 if (stmt_label_idx != NULL_IDX && !err_call) { 00932 ATL_CLASS(stmt_label_idx) = Lbl_User; 00933 ATL_DEBUG_CLASS(stmt_label_idx) = Ldbg_User_Lbl; 00934 ATL_EXECUTABLE(stmt_label_idx) = TRUE; 00935 00936 if (!AT_DEFINED(stmt_label_idx) && 00937 ATL_FWD_REF_IDX(stmt_label_idx) != NULL_IDX) { 00938 resolve_fwd_lbl_refs(); 00939 } 00940 00941 stmt_label_idx = NULL_IDX; 00942 } 00943 00944 if (cmd_line_flags.debug_lvl == Debug_Lvl_0) { /* -ed -G0 */ 00945 00946 gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Stmt_Lbl, NULL_IDX); 00947 } 00948 else if (cmd_line_flags.debug_lvl == Debug_Lvl_1) { /* -ez -G1 */ 00949 gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Start_Epilogue, NULL_IDX); 00950 } 00951 } 00952 00953 EOPU_encountered = TRUE; 00954 curr_stmt_category = Init_Stmt_Cat; 00955 00956 if (cif_flags & MISC_RECS) { 00957 cif_stmt_type_rec(TRUE, CIF_End_Program_Stmt, statement_number); 00958 } 00959 00960 if (cif_flags & BASIC_RECS) { 00961 cif_end_scope_rec(); 00962 } 00963 00964 if (err_call && ! clearing_blk_stk) { 00965 00966 /* Needed for both CIF and buffered message file. */ 00967 00968 if (cif_flags & BASIC_RECS) { 00969 cif_send_attr(SCP_ATTR_IDX(curr_scp_idx), NULL_IDX); 00970 } 00971 cif_end_unit_rec(AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx))); 00972 } 00973 00974 ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx)) = FALSE; 00975 00976 POP_BLK_STK; 00977 PRINT_SCP_TBL; 00978 PRINT_EQV_TBL; 00979 00980 TRACE (Func_Exit, "end_program_unit", NULL); 00981 00982 return; 00983 00984 } /* end_program_unit */ 00985 00986 00987 /******************************************************************************\ 00988 |* *| 00989 |* Description: *| 00990 |* Complete the processing of the END statement for a FUNCTION program. *| 00991 |* This is for external FUNCTIONS only. Internal, module, and interface *| 00992 |* FUNCTIONS have their own end routines. *| 00993 |* *| 00994 |* Input parameters: *| 00995 |* err_call => Boolean - TRUE if this is called from an error situation. *| 00996 |* This means the compiler is trying to clean up the block *| 00997 |* stack and do error recovery. *| 00998 |* *| 00999 |* Output parameters: *| 01000 |* NONE *| 01001 |* *| 01002 |* Returns: *| 01003 |* NONE *| 01004 |* *| 01005 \******************************************************************************/ 01006 01007 static void end_function(boolean err_call) 01008 { 01009 int idx; 01010 int ir_idx; 01011 int glb_idx; 01012 int act_file_line; 01013 01014 01015 TRACE (Func_Entry, "end_function", NULL); 01016 01017 do_cmic_blk_checks(); 01018 01019 NTR_IR_TBL(ir_idx); 01020 01021 IR_OPR(ir_idx) = Return_Opr; 01022 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 01023 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token); 01024 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token); 01025 01026 GLOBAL_LINE_TO_FILE_LINE(TOKEN_LINE(token), glb_idx, act_file_line); 01027 GL_SOURCE_LINES(global_line_tbl_idx) = act_file_line; 01028 set_related_gl_source_lines(global_line_tbl_idx); 01029 01030 if (err_call) { /* This is an error situation */ 01031 gen_sh(Before, End_Function_Stmt, stmt_start_line, stmt_start_col, 01032 TRUE, FALSE, FALSE); 01033 01034 SCP_LAST_SH_IDX(curr_scp_idx) = SH_PREV_IDX(curr_stmt_sh_idx); 01035 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 01036 SCP_IN_ERR(curr_scp_idx) = TRUE; 01037 } 01038 else { 01039 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 01040 SCP_LAST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx; 01041 SH_STMT_TYPE(curr_stmt_sh_idx) = End_Function_Stmt; 01042 01043 if (stmt_label_idx != NULL_IDX) { 01044 ATL_CLASS(stmt_label_idx) = Lbl_User; 01045 ATL_DEBUG_CLASS(stmt_label_idx) = Ldbg_User_Lbl; 01046 ATL_EXECUTABLE(stmt_label_idx) = TRUE; 01047 01048 if (!AT_DEFINED(stmt_label_idx) && 01049 ATL_FWD_REF_IDX(stmt_label_idx) != NULL_IDX) { 01050 resolve_fwd_lbl_refs(); 01051 } 01052 01053 stmt_label_idx = NULL_IDX; 01054 } 01055 01056 if (cmd_line_flags.debug_lvl == Debug_Lvl_0) { /* -ed -G0 */ 01057 gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Stmt_Lbl, NULL_IDX); 01058 } 01059 else if (cmd_line_flags.debug_lvl == Debug_Lvl_1) { /* -ez -G1 */ 01060 gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Start_Epilogue, NULL_IDX); 01061 } 01062 } 01063 01064 EOPU_encountered = TRUE; 01065 curr_stmt_category = Init_Stmt_Cat; 01066 01067 /* Entry points are linked thru the current scopes SCP_ENTRY_IDX. This */ 01068 /* points to the attr list table, which contains a list of all entry pts. */ 01069 01070 if (cif_flags & MISC_RECS) { 01071 cif_stmt_type_rec(TRUE, CIF_End_Function_Stmt, statement_number); 01072 } 01073 01074 if (cif_flags & BASIC_RECS) { 01075 cif_end_scope_rec(); 01076 } 01077 01078 if (err_call && ! clearing_blk_stk) { 01079 01080 /* Needed for both CIF and buffered message file. */ 01081 01082 if (cif_flags & BASIC_RECS) { 01083 cif_send_attr(SCP_ATTR_IDX(curr_scp_idx), NULL_IDX); 01084 } 01085 cif_end_unit_rec(AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx))); 01086 01087 ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx)) = FALSE; 01088 idx = SCP_ENTRY_IDX(curr_scp_idx); 01089 01090 while (idx != NULL_IDX) { 01091 01092 if (cif_flags & BASIC_RECS) { 01093 cif_send_attr(AL_ATTR_IDX(idx), NULL_IDX); 01094 } 01095 ATP_SCP_ALIVE(AL_ATTR_IDX(idx)) = FALSE; 01096 idx = AL_NEXT_IDX(idx); 01097 } 01098 } 01099 else { 01100 01101 ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx)) = FALSE; 01102 idx = SCP_ENTRY_IDX(curr_scp_idx); 01103 01104 while (idx != NULL_IDX) { 01105 ATP_SCP_ALIVE(AL_ATTR_IDX(idx)) = FALSE; 01106 idx = AL_NEXT_IDX(idx); 01107 } 01108 } 01109 01110 POP_BLK_STK; 01111 PRINT_SCP_TBL; 01112 PRINT_EQV_TBL; 01113 01114 TRACE (Func_Exit, "end_function", NULL); 01115 01116 return; 01117 01118 } /* end_function */ 01119 01120 01121 /******************************************************************************\ 01122 |* *| 01123 |* Description: *| 01124 |* Complete the processing of the END statement for a SUBROUTINE program.*| 01125 |* This is for external SUBROUTINES only. Internal, module, and *| 01126 |* interface SUBROUTINES have their own end routines. *| 01127 |* *| 01128 |* Input parameters: *| 01129 |* err_call => Boolean - TRUE if this is called from an error situation. *| 01130 |* This means the compiler is trying to clean up the block *| 01131 |* stack and do error recovery. *| 01132 |* *| 01133 |* Output parameters: *| 01134 |* NONE *| 01135 |* *| 01136 |* Returns: *| 01137 |* NONE *| 01138 |* *| 01139 \******************************************************************************/ 01140 01141 static void end_subroutine(boolean err_call) 01142 01143 { 01144 int idx; 01145 int ir_idx; 01146 int glb_idx; 01147 int act_file_line; 01148 01149 01150 TRACE (Func_Entry, "end_subroutine", NULL); 01151 01152 do_cmic_blk_checks(); 01153 01154 NTR_IR_TBL(ir_idx); 01155 01156 IR_OPR(ir_idx) = Return_Opr; 01157 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 01158 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token); 01159 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token); 01160 01161 GLOBAL_LINE_TO_FILE_LINE(TOKEN_LINE(token), glb_idx, act_file_line); 01162 GL_SOURCE_LINES(global_line_tbl_idx) = act_file_line; 01163 set_related_gl_source_lines(global_line_tbl_idx); 01164 01165 if (ATP_HAS_ALT_RETURN(SCP_ATTR_IDX(curr_scp_idx))) { 01166 /* if no alt return spec was specified, supply zero */ 01167 IR_FLD_L(ir_idx) = CN_Tbl_Idx; 01168 IR_IDX_L(ir_idx) = CN_INTEGER_ZERO_IDX; 01169 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token); 01170 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token); 01171 } 01172 01173 if (err_call) { /* This is an error situation */ 01174 gen_sh(Before, End_Subroutine_Stmt, stmt_start_line, stmt_start_col, 01175 TRUE, FALSE, FALSE); 01176 01177 SCP_LAST_SH_IDX(curr_scp_idx) = SH_PREV_IDX(curr_stmt_sh_idx); 01178 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 01179 SCP_IN_ERR(curr_scp_idx) = TRUE; 01180 } 01181 else { 01182 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 01183 SCP_LAST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx; 01184 01185 if (stmt_label_idx != NULL_IDX) { 01186 ATL_CLASS(stmt_label_idx) = Lbl_User; 01187 ATL_DEBUG_CLASS(stmt_label_idx) = Ldbg_User_Lbl; 01188 ATL_EXECUTABLE(stmt_label_idx) = TRUE; 01189 01190 if (!AT_DEFINED(stmt_label_idx) && 01191 ATL_FWD_REF_IDX(stmt_label_idx) != NULL_IDX) { 01192 resolve_fwd_lbl_refs(); 01193 } 01194 01195 end_labeled_do(); 01196 stmt_label_idx = NULL_IDX; 01197 } 01198 01199 if (cmd_line_flags.debug_lvl == Debug_Lvl_0) { /* -ed -G0 */ 01200 gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Stmt_Lbl, NULL_IDX); 01201 } 01202 else if (cmd_line_flags.debug_lvl == Debug_Lvl_1) { /* -ez -G1 */ 01203 gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Start_Epilogue, NULL_IDX); 01204 } 01205 } 01206 01207 EOPU_encountered = TRUE; 01208 curr_stmt_category = Init_Stmt_Cat; 01209 01210 /* Entry points are linked thru the current scopes SCP_ENTRY_IDX. This */ 01211 /* points to the attr list table, which contains a list of all entry pts. */ 01212 01213 if (cif_flags & MISC_RECS) { 01214 cif_stmt_type_rec(TRUE, CIF_End_Subroutine_Stmt, statement_number); 01215 } 01216 01217 if (cif_flags & BASIC_RECS) { 01218 cif_end_scope_rec(); 01219 } 01220 01221 if (err_call && ! clearing_blk_stk) { 01222 01223 /* Needed for both CIF and buffered message file. */ 01224 01225 if (cif_flags & BASIC_RECS) { 01226 cif_send_attr(SCP_ATTR_IDX(curr_scp_idx), NULL_IDX); 01227 } 01228 cif_end_unit_rec(AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx))); 01229 01230 ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx)) = FALSE; 01231 idx = SCP_ENTRY_IDX(curr_scp_idx); 01232 01233 while (idx != NULL_IDX) { 01234 01235 if (cif_flags & BASIC_RECS) { 01236 cif_send_attr(AL_ATTR_IDX(idx), NULL_IDX); 01237 } 01238 ATP_SCP_ALIVE(AL_ATTR_IDX(idx)) = FALSE; 01239 idx = AL_NEXT_IDX(idx); 01240 } 01241 } 01242 else { 01243 ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx)) = FALSE; 01244 idx = SCP_ENTRY_IDX(curr_scp_idx); 01245 01246 while (idx != NULL_IDX) { 01247 ATP_SCP_ALIVE(AL_ATTR_IDX(idx)) = FALSE; 01248 idx = AL_NEXT_IDX(idx); 01249 } 01250 } 01251 01252 POP_BLK_STK; 01253 PRINT_SCP_TBL; 01254 PRINT_EQV_TBL; 01255 01256 TRACE (Func_Exit, "end_subroutine", NULL); 01257 01258 return; 01259 01260 } /* end_subroutine */ 01261 01262 01263 /******************************************************************************\ 01264 |* *| 01265 |* Description: *| 01266 |* Complete the processing of the END statement for a MODULE program. *| 01267 |* *| 01268 |* Input parameters: *| 01269 |* err_call => Boolean - TRUE if this is called from an error situation. *| 01270 |* This means the compiler is trying to clean up the block *| 01271 |* stack and do error recovery. *| 01272 |* *| 01273 |* Output parameters: *| 01274 |* NONE *| 01275 |* *| 01276 |* Returns: *| 01277 |* NONE *| 01278 |* *| 01279 \******************************************************************************/ 01280 01281 static void end_module(boolean err_call) 01282 { 01283 01284 int act_file_line; 01285 int glb_idx; 01286 01287 01288 TRACE (Func_Entry, "end_module", NULL); 01289 01290 GLOBAL_LINE_TO_FILE_LINE(stmt_start_line, glb_idx, act_file_line); 01291 GL_SOURCE_LINES(global_line_tbl_idx) = act_file_line; 01292 set_related_gl_source_lines(global_line_tbl_idx); 01293 01294 if (err_call) { /* This is an error situation */ 01295 gen_sh(Before, End_Module_Stmt, stmt_start_line, stmt_start_col, 01296 TRUE, FALSE, FALSE); 01297 SCP_LAST_SH_IDX(curr_scp_idx) = SH_PREV_IDX(curr_stmt_sh_idx); 01298 SCP_IN_ERR(curr_scp_idx) = TRUE; 01299 } 01300 else { 01301 SCP_LAST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx; 01302 01303 if (stmt_label_idx != NULL_IDX && !err_call) { 01304 ATL_CLASS(stmt_label_idx) = Lbl_User; 01305 ATL_DEBUG_CLASS(stmt_label_idx) = Ldbg_User_Lbl; 01306 ATL_EXECUTABLE(stmt_label_idx) = TRUE; 01307 01308 if (!AT_DEFINED(stmt_label_idx) && 01309 ATL_FWD_REF_IDX(stmt_label_idx) != NULL_IDX) { 01310 resolve_fwd_lbl_refs(); 01311 } 01312 stmt_label_idx = NULL_IDX; 01313 } 01314 } 01315 01316 EOPU_encountered = TRUE; 01317 curr_stmt_category = Init_Stmt_Cat; 01318 01319 if (cif_flags & MISC_RECS) { 01320 cif_stmt_type_rec(TRUE, CIF_End_Module_Stmt, statement_number); 01321 } 01322 01323 if (cif_flags & BASIC_RECS) { 01324 cif_end_scope_rec(); 01325 } 01326 01327 if (err_call && ! clearing_blk_stk) { 01328 01329 /* Needed for both CIF and buffered message file. */ 01330 01331 if (cif_flags & BASIC_RECS) { 01332 cif_send_attr(SCP_ATTR_IDX(curr_scp_idx), NULL_IDX); 01333 } 01334 cif_end_unit_rec(AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx))); 01335 } 01336 01337 ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx)) = FALSE; 01338 01339 POP_BLK_STK; 01340 PRINT_SCP_TBL; 01341 PRINT_EQV_TBL; 01342 01343 TRACE (Func_Exit, "end_module", NULL); 01344 01345 return; 01346 01347 } /* end_module */ 01348 01349 01350 /******************************************************************************\ 01351 |* *| 01352 |* Description: *| 01353 |* Complete the processing of the END statement for a BLOCKDATA program. *| 01354 |* *| 01355 |* Input parameters: *| 01356 |* err_call => Boolean - TRUE if this is called from an error situation. *| 01357 |* This means the compiler is trying to clean up the block *| 01358 |* stack and do error recovery. *| 01359 |* *| 01360 |* Output parameters: *| 01361 |* NONE *| 01362 |* *| 01363 |* Returns: *| 01364 |* NONE *| 01365 |* *| 01366 \******************************************************************************/ 01367 01368 static void end_blockdata(boolean err_call) 01369 { 01370 01371 int glb_idx; 01372 int act_file_line; 01373 01374 TRACE (Func_Entry, "end_blockdata", NULL); 01375 01376 GLOBAL_LINE_TO_FILE_LINE(stmt_start_line, glb_idx, act_file_line); 01377 GL_SOURCE_LINES(global_line_tbl_idx) = act_file_line; 01378 set_related_gl_source_lines(global_line_tbl_idx); 01379 01380 if (err_call) { /* This is an error situation */ 01381 gen_sh(Before, End_Blockdata_Stmt, stmt_start_line, stmt_start_col, 01382 TRUE, FALSE, FALSE); 01383 SCP_LAST_SH_IDX(curr_scp_idx) = SH_PREV_IDX(curr_stmt_sh_idx); 01384 SCP_IN_ERR(curr_scp_idx) = TRUE; 01385 } 01386 else { 01387 SCP_LAST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx; 01388 01389 if (stmt_label_idx != NULL_IDX && !err_call) { 01390 ATL_CLASS(stmt_label_idx) = Lbl_User; 01391 ATL_DEBUG_CLASS(stmt_label_idx) = Ldbg_User_Lbl; 01392 ATL_EXECUTABLE(stmt_label_idx) = TRUE; 01393 01394 if (!AT_DEFINED(stmt_label_idx) && 01395 ATL_FWD_REF_IDX(stmt_label_idx) != NULL_IDX) { 01396 resolve_fwd_lbl_refs(); 01397 } 01398 stmt_label_idx = NULL_IDX; 01399 } 01400 } 01401 01402 EOPU_encountered = TRUE; 01403 curr_stmt_category = Init_Stmt_Cat; 01404 ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx)) = FALSE; 01405 01406 if (cif_flags & MISC_RECS) { 01407 cif_stmt_type_rec(TRUE, CIF_End_Block_Data_Stmt, statement_number); 01408 } 01409 01410 if (cif_flags & BASIC_RECS) { 01411 cif_end_scope_rec(); 01412 } 01413 01414 if (err_call && ! clearing_blk_stk) { 01415 01416 /* Needed for both CIF and buffered message file. */ 01417 01418 if (cif_flags & BASIC_RECS) { 01419 cif_send_attr(SCP_ATTR_IDX(curr_scp_idx), NULL_IDX); 01420 } 01421 cif_end_unit_rec(AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx))); 01422 } 01423 01424 ATP_SCP_ALIVE(SCP_ATTR_IDX(curr_scp_idx)) = FALSE; 01425 01426 POP_BLK_STK; 01427 PRINT_SCP_TBL; 01428 PRINT_EQV_TBL; 01429 01430 TRACE (Func_Exit, "end_blockdata", NULL); 01431 01432 return; 01433 01434 } /* end_blockdata */ 01435 01436 01437 /******************************************************************************\ 01438 |* *| 01439 |* Description: *| 01440 |* Complete the processing of the END statement for an internal procedure*| 01441 |* *| 01442 |* Input parameters: *| 01443 |* err_call => Boolean - TRUE if this is called from an error situation. *| 01444 |* This means the compiler is trying to clean up the block *| 01445 |* stack and do error recovery. *| 01446 |* *| 01447 |* Output parameters: *| 01448 |* NONE *| 01449 |* *| 01450 |* Returns: *| 01451 |* NONE *| 01452 |* *| 01453 \******************************************************************************/ 01454 01455 static void end_internal_proc(boolean err_call) 01456 01457 { 01458 int attr_idx; 01459 int ir_idx; 01460 01461 01462 TRACE (Func_Entry, "end_internal_proc", NULL); 01463 01464 do_cmic_blk_checks(); 01465 01466 NTR_IR_TBL(ir_idx); 01467 01468 IR_OPR(ir_idx) = Return_Opr; 01469 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 01470 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token); 01471 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token); 01472 attr_idx = SCP_ATTR_IDX(curr_scp_idx); 01473 01474 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Subroutine && 01475 ATP_HAS_ALT_RETURN(SCP_ATTR_IDX(curr_scp_idx))) { 01476 /* if no alt return spec was specified, supply zero */ 01477 IR_FLD_L(ir_idx) = CN_Tbl_Idx; 01478 IR_IDX_L(ir_idx) = CN_INTEGER_ZERO_IDX; 01479 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token); 01480 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token); 01481 } 01482 01483 if (err_call) { /* This is an error situation */ 01484 gen_sh(Before, 01485 stmt_type, 01486 stmt_start_line, 01487 stmt_start_col, 01488 TRUE, 01489 FALSE, 01490 FALSE); 01491 01492 SCP_LAST_SH_IDX(curr_scp_idx) = SH_PREV_IDX(curr_stmt_sh_idx); 01493 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 01494 SCP_IN_ERR(curr_scp_idx) = TRUE; 01495 } 01496 else { 01497 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 01498 SCP_LAST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx; 01499 01500 if (stmt_label_idx != NULL_IDX) { 01501 ATL_CLASS(stmt_label_idx) = Lbl_User; 01502 ATL_DEBUG_CLASS(stmt_label_idx) = Ldbg_User_Lbl; 01503 ATL_EXECUTABLE(stmt_label_idx) = TRUE; 01504 01505 if (!AT_DEFINED(stmt_label_idx) && 01506 ATL_FWD_REF_IDX(stmt_label_idx) != NULL_IDX) { 01507 resolve_fwd_lbl_refs(); 01508 } 01509 stmt_label_idx = NULL_IDX; 01510 } 01511 01512 if (cmd_line_flags.debug_lvl == Debug_Lvl_0) { /* -ed -G0 */ 01513 gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Stmt_Lbl, NULL_IDX); 01514 } 01515 else if (cmd_line_flags.debug_lvl == Debug_Lvl_1) { /* -ez -G1 */ 01516 gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Start_Epilogue, NULL_IDX); 01517 } 01518 } 01519 01520 if (cif_flags & BASIC_RECS) { 01521 cif_end_scope_rec(); 01522 } 01523 01524 if (cif_flags & MISC_RECS) { 01525 cif_stmt_type_rec(TRUE, (ATP_PGM_UNIT(attr_idx) == Function) ? 01526 CIF_End_Function_Stmt : CIF_End_Subroutine_Stmt, 01527 statement_number); 01528 } 01529 01530 if (stmt_type == End_Stmt) { 01531 PRINTMSG(stmt_start_line, 86, Error, stmt_start_col, 01532 "internal-procedure", 01533 (ATP_PGM_UNIT(attr_idx) == Function) ? "FUNCTION" : 01534 "SUBROUTINE"); 01535 } 01536 01537 curr_stmt_category = Sub_Func_Stmt_Cat; 01538 ATP_SCP_ALIVE(attr_idx) = FALSE; 01539 curr_scp_idx = SCP_PARENT_IDX(curr_scp_idx); 01540 01541 /* SH_NEXT_IDX of curr_stmt_sh_idx is NULL_IDX and will stay that way, */ 01542 /* because if there are SH's for the parent, curr_stmt_sh_idx will be */ 01543 /* set to the last of them. If there are no stmt headers for the parent */ 01544 /* a new statement header will be generated. The only way there should */ 01545 /* be no SH's for the parent is if the parent is an interface block. If */ 01546 /* this is true, we're in a scoping error situation, because internal */ 01547 /* procedures cannot be in an interface block. We check for this to */ 01548 /* prevent aborts and other bad things, if we're in an error situation. */ 01549 01550 if (SCP_LAST_SH_IDX(curr_scp_idx) == NULL_IDX) { /* No IR for parent scp */ 01551 curr_stmt_sh_idx = ntr_sh_tbl(); 01552 SCP_FIRST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx; 01553 need_new_sh = FALSE; /* Use this SH */ 01554 } 01555 else { 01556 curr_stmt_sh_idx = SCP_LAST_SH_IDX(curr_scp_idx); 01557 } 01558 01559 POP_BLK_STK; 01560 PRINT_SCP_TBL; 01561 PRINT_EQV_TBL; 01562 01563 TRACE (Func_Exit, "end_internal_proc", NULL); 01564 01565 return; 01566 01567 } /* end_internal_proc */ 01568 01569 01570 /******************************************************************************\ 01571 |* *| 01572 |* Description: *| 01573 |* Complete the processing of the END statement for a module procedure. *| 01574 |* *| 01575 |* Input parameters: *| 01576 |* err_call => Boolean - TRUE if this is called from an error situation. *| 01577 |* This means the compiler is trying to clean up the block *| 01578 |* stack and do error recovery. *| 01579 |* *| 01580 |* Output parameters: *| 01581 |* NONE *| 01582 |* *| 01583 |* Returns: *| 01584 |* NONE *| 01585 |* *| 01586 \******************************************************************************/ 01587 01588 static void end_module_proc(boolean err_call) 01589 01590 { 01591 int attr_idx; 01592 int idx; 01593 int ir_idx; 01594 01595 01596 TRACE (Func_Entry, "end_module_proc", NULL); 01597 01598 do_cmic_blk_checks(); 01599 01600 NTR_IR_TBL(ir_idx); 01601 01602 IR_OPR(ir_idx) = Return_Opr; 01603 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 01604 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token); 01605 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token); 01606 attr_idx = SCP_ATTR_IDX(curr_scp_idx); 01607 01608 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Subroutine && 01609 ATP_HAS_ALT_RETURN(SCP_ATTR_IDX(curr_scp_idx))) { 01610 /* if no alt return spec was specified, supply zero */ 01611 IR_FLD_L(ir_idx) = CN_Tbl_Idx; 01612 IR_IDX_L(ir_idx) = CN_INTEGER_ZERO_IDX; 01613 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token); 01614 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token); 01615 } 01616 01617 if (err_call) { /* This is an error situation */ 01618 gen_sh(Before, 01619 stmt_type, 01620 stmt_start_line, 01621 stmt_start_col, 01622 TRUE, 01623 FALSE, 01624 FALSE); 01625 01626 SCP_LAST_SH_IDX(curr_scp_idx) = SH_PREV_IDX(curr_stmt_sh_idx); 01627 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 01628 SCP_IN_ERR(curr_scp_idx) = TRUE; 01629 } 01630 else { 01631 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 01632 SCP_LAST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx; 01633 01634 if (stmt_label_idx != NULL_IDX) { 01635 ATL_CLASS(stmt_label_idx) = Lbl_User; 01636 ATL_DEBUG_CLASS(stmt_label_idx) = Ldbg_User_Lbl; 01637 ATL_EXECUTABLE(stmt_label_idx) = TRUE; 01638 01639 if (!AT_DEFINED(stmt_label_idx) && 01640 ATL_FWD_REF_IDX(stmt_label_idx) != NULL_IDX) { 01641 resolve_fwd_lbl_refs(); 01642 } 01643 01644 stmt_label_idx = NULL_IDX; 01645 } 01646 01647 if (cmd_line_flags.debug_lvl == Debug_Lvl_0) { /* -ed -G0 */ 01648 gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Stmt_Lbl, NULL_IDX); 01649 } 01650 else if (cmd_line_flags.debug_lvl == Debug_Lvl_1) { /* -ez -G1 */ 01651 gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Start_Epilogue, NULL_IDX); 01652 } 01653 } 01654 01655 if (cif_flags & BASIC_RECS) { 01656 cif_end_scope_rec(); 01657 } 01658 01659 if (cif_flags & MISC_RECS) { 01660 cif_stmt_type_rec(TRUE, (ATP_PGM_UNIT(CURR_BLK_NAME) == Function) ? 01661 CIF_End_Function_Stmt : CIF_End_Subroutine_Stmt, 01662 statement_number); 01663 } 01664 01665 if (stmt_type == End_Stmt) { 01666 PRINTMSG(stmt_start_line, 86, Error, 01667 stmt_start_col, 01668 "module-procedure", 01669 (ATP_PGM_UNIT(CURR_BLK_NAME) == Function) ? "FUNCTION" : 01670 "SUBROUTINE"); 01671 } 01672 01673 ATP_SCP_ALIVE(attr_idx) = FALSE; 01674 01675 /* Entry points are linked thru the current scopes SCP_ENTRY_IDX. This */ 01676 /* points to the attr list table, which contains a list of all entry pts. */ 01677 01678 idx = SCP_ENTRY_IDX(curr_scp_idx); 01679 01680 while (idx != NULL_IDX) { 01681 ATP_SCP_ALIVE(AL_ATTR_IDX(idx)) = FALSE; 01682 idx = AL_NEXT_IDX(idx); 01683 } 01684 01685 curr_stmt_category = Sub_Func_Stmt_Cat; 01686 curr_scp_idx = SCP_PARENT_IDX(curr_scp_idx); 01687 01688 /* SH_NEXT_IDX of curr_stmt_sh_idx is NULL_IDX and will stay that way, */ 01689 /* because if there are SH's for the parent, curr_stmt_sh_idx will be */ 01690 /* set to the last of them. If there are no stmt headers for the parent */ 01691 /* a new statement header will be generated. The only way there should */ 01692 /* be no SH's for the parent is if the parent is an interface block. If */ 01693 /* this is true, we're in a scoping error situation, because internal */ 01694 /* procedures cannot be in an interface block. We check for this to */ 01695 /* prevent aborts and other bad things, if we're in an error situation. */ 01696 01697 01698 if (SCP_LAST_SH_IDX(curr_scp_idx) == NULL_IDX) { /* No IR for parent scp */ 01699 curr_stmt_sh_idx = ntr_sh_tbl(); 01700 SCP_FIRST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx; 01701 need_new_sh = FALSE; /* Use this SH */ 01702 } 01703 else { 01704 curr_stmt_sh_idx = SCP_LAST_SH_IDX(curr_scp_idx); 01705 } 01706 01707 POP_BLK_STK; 01708 PRINT_SCP_TBL; 01709 PRINT_EQV_TBL; 01710 01711 TRACE (Func_Exit, "end_module_proc", NULL); 01712 01713 return; 01714 01715 } /* end_module_proc */ 01716 01717 01718 /******************************************************************************\ 01719 |* *| 01720 |* Description: *| 01721 |* Complete the processing of the END statement for an interface body. *| 01722 |* *| 01723 |* Input parameters: *| 01724 |* err_call => Boolean - TRUE if this is called from an error situation. *| 01725 |* This means the compiler is trying to clean up the block *| 01726 |* stack and do error recovery. *| 01727 |* *| 01728 |* Output parameters: *| 01729 |* NONE *| 01730 |* *| 01731 |* Returns: *| 01732 |* NONE *| 01733 |* *| 01734 \******************************************************************************/ 01735 01736 static void end_interface_body(boolean err_call) 01737 01738 { 01739 int interface_idx; 01740 int parent_idx; 01741 int save_curr_scp_idx; 01742 int sibling_idx; 01743 01744 01745 TRACE (Func_Entry, "end_interface_body", NULL); 01746 01747 if (cif_flags & BASIC_RECS) { 01748 cif_scope_info_rec(); 01749 cif_end_scope_rec(); 01750 } 01751 01752 if (cif_flags & MISC_RECS) { 01753 cif_stmt_type_rec(TRUE, 01754 (ATP_PGM_UNIT(CURR_BLK_NAME) == Function) ? 01755 CIF_End_Function_Stmt : CIF_End_Subroutine_Stmt, 01756 statement_number); 01757 } 01758 01759 curr_stmt_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx); 01760 stmt_start_line = SH_GLB_LINE(curr_stmt_sh_idx); 01761 stmt_start_col = SH_COL_NUM(curr_stmt_sh_idx); 01762 need_new_sh = TRUE; 01763 01764 interface_semantics_pass_driver(); 01765 01766 parent_idx = SCP_PARENT_IDX(curr_scp_idx); 01767 01768 free_attr_list(SCP_TMP_FW_IDX2(curr_scp_idx)); 01769 free_attr_list(SCP_TMP_FW_IDX(curr_scp_idx)); 01770 free_attr_list(SCP_ENTRY_IDX(curr_scp_idx)); 01771 free_attr_list(SCP_TMP_LIST(curr_scp_idx)); 01772 free_attr_list(SCP_ATTR_LIST(curr_scp_idx)); 01773 01774 SCP_ATTR_LIST(curr_scp_idx) = NULL_IDX; 01775 SCP_TMP_FW_IDX2(curr_scp_idx) = NULL_IDX; 01776 SCP_TMP_FW_IDX(curr_scp_idx) = NULL_IDX; 01777 SCP_ENTRY_IDX(curr_scp_idx) = NULL_IDX; 01778 SCP_TMP_LIST(curr_scp_idx) = NULL_IDX; 01779 01780 remove_hidden_name_tbl(curr_scp_idx); 01781 01782 if (!SCP_IN_ERR(curr_scp_idx) && 01783 BLK_TYPE(blk_stk_idx - 1) == Interface_Blk) { 01784 blk_stk_idx--; 01785 interface_idx = (BLK_NAME(blk_stk_idx) == NULL_IDX) ? 01786 BLK_UNNAMED_INTERFACE(blk_stk_idx) : 01787 BLK_NAME(blk_stk_idx); 01788 01789 if ((ATI_NUM_SPECIFICS(interface_idx) % 8) == 0 && 01790 !AT_DCL_ERR(interface_idx) && ATI_HAS_NON_MOD_PROC(interface_idx)) { 01791 save_curr_scp_idx = curr_scp_idx; 01792 curr_scp_idx = parent_idx; 01793 collapse_interface_blk(interface_idx); 01794 ATI_HAS_NON_MOD_PROC(interface_idx) = FALSE; 01795 BLK_AT_IDX(blk_stk_idx) = NULL_IDX; 01796 BLK_BD_IDX(blk_stk_idx) = NULL_IDX; 01797 BLK_CN_IDX(blk_stk_idx) = NULL_IDX; 01798 BLK_CP_IDX(blk_stk_idx) = NULL_IDX; 01799 BLK_NP_IDX(blk_stk_idx) = NULL_IDX; 01800 BLK_SB_IDX(blk_stk_idx) = NULL_IDX; 01801 BLK_SN_IDX(blk_stk_idx) = NULL_IDX; 01802 BLK_TYP_IDX(blk_stk_idx) = NULL_IDX; 01803 curr_scp_idx = save_curr_scp_idx; 01804 } 01805 blk_stk_idx++; 01806 } 01807 01808 if (SCP_FIRST_CHILD_IDX(curr_scp_idx) == NULL_IDX) { 01809 01810 if (SCP_SIBLING_IDX(curr_scp_idx) == NULL_IDX) { 01811 01812 /* NO block errors - so reuse loc name table space */ 01813 01814 loc_name_tbl_idx = SCP_LN_FW_IDX(curr_scp_idx) - 1; 01815 } 01816 scp_tbl_idx = curr_scp_idx - 1; 01817 01818 if (SCP_NUM_CHILDREN(parent_idx) == 1) { /* only one child */ 01819 SCP_FIRST_CHILD_IDX(parent_idx) = NULL_IDX; 01820 SCP_LAST_CHILD_IDX(parent_idx) = NULL_IDX; 01821 SCP_NUM_CHILDREN(parent_idx) = 0; 01822 } 01823 else { /* find next to last sibling scp */ 01824 sibling_idx = SCP_FIRST_CHILD_IDX(parent_idx); 01825 01826 while (SCP_SIBLING_IDX(sibling_idx) != curr_scp_idx) { 01827 sibling_idx = SCP_SIBLING_IDX(sibling_idx); 01828 } 01829 01830 SCP_SIBLING_IDX(sibling_idx) = NULL_IDX; 01831 SCP_LAST_CHILD_IDX(parent_idx) = sibling_idx; 01832 (SCP_NUM_CHILDREN(parent_idx))--; 01833 } 01834 } 01835 else { /* There are one or more block errors, so remove this interface */ 01836 /* body carefully. Merge the interface's sibling list with the */ 01837 /* interface's child's sibling list. Then curr_scp_idx becomes */ 01838 /* inaccessible, because it is out of the scope table link. */ 01839 01840 SCP_PARENT_IDX(SCP_FIRST_CHILD_IDX(curr_scp_idx)) = parent_idx; 01841 01842 sibling_idx = SCP_FIRST_CHILD_IDX(curr_scp_idx); 01843 01844 while (SCP_SIBLING_IDX(sibling_idx) != NULL_IDX) { 01845 sibling_idx = SCP_SIBLING_IDX(sibling_idx); 01846 SCP_PARENT_IDX(sibling_idx) = parent_idx; 01847 } 01848 01849 if (SCP_NUM_CHILDREN(parent_idx) == 1) { /* only one child */ 01850 SCP_FIRST_CHILD_IDX(parent_idx) = SCP_FIRST_CHILD_IDX(curr_scp_idx); 01851 SCP_LAST_CHILD_IDX(parent_idx) = SCP_LAST_CHILD_IDX(curr_scp_idx); 01852 SCP_NUM_CHILDREN(parent_idx) = SCP_NUM_CHILDREN(curr_scp_idx); 01853 } 01854 else { /* find next to last sibling scp */ 01855 sibling_idx = SCP_FIRST_CHILD_IDX(parent_idx); 01856 01857 while (SCP_SIBLING_IDX(sibling_idx) != curr_scp_idx) { 01858 sibling_idx = SCP_SIBLING_IDX(sibling_idx); 01859 } 01860 01861 SCP_SIBLING_IDX(sibling_idx) = SCP_FIRST_CHILD_IDX(curr_scp_idx); 01862 SCP_LAST_CHILD_IDX(parent_idx) = SCP_LAST_CHILD_IDX(curr_scp_idx); 01863 SCP_NUM_CHILDREN(parent_idx) = SCP_NUM_CHILDREN(parent_idx) - 1 + 01864 SCP_NUM_CHILDREN(curr_scp_idx); 01865 } 01866 } 01867 01868 curr_scp_idx = parent_idx; 01869 curr_stmt_category = Sub_Func_Stmt_Cat; 01870 01871 /* If there are no stmt headers for the parent, always reuse curr_stmt_sh */ 01872 /* _idx because even if this statement is labeled, it doesn't need a SH. */ 01873 /* The only IR that can be generated for this interface body is labels. */ 01874 /* These can never be referenced, because you can't jump from one scope */ 01875 /* to another, and you can't have a goto inside an interface body. */ 01876 /* There will be no SH's for the parent if the parent is an interface */ 01877 /* block. This is perfectly legal. */ 01878 01879 if (SCP_LAST_SH_IDX(curr_scp_idx) == NULL_IDX) { /* No IR for parent scp */ 01880 SCP_FIRST_SH_IDX(curr_scp_idx) = curr_stmt_sh_idx; 01881 SH_PREV_IDX(curr_stmt_sh_idx) = NULL_IDX; 01882 need_new_sh = FALSE; 01883 } 01884 else { 01885 curr_stmt_sh_idx = SCP_LAST_SH_IDX(curr_scp_idx); 01886 need_new_sh = TRUE; 01887 } 01888 01889 POP_BLK_STK; 01890 PRINT_SCP_TBL; 01891 PRINT_EQV_TBL; 01892 01893 TRACE (Func_Exit, "end_interface_body", NULL); 01894 01895 return; 01896 01897 } /* end_interface_body */ 01898 01899 01900 /******************************************************************************\ 01901 |* *| 01902 |* Description: *| 01903 |* Complete the processing of the END FORALL statement. *| 01904 |* *| 01905 |* Input parameters: *| 01906 |* err_call => Boolean - TRUE if this is called from an error situation. *| 01907 |* This means the compiler is trying to clean up the block *| 01908 |* stack and do error recovery. *| 01909 |* *| 01910 |* Output parameters: *| 01911 |* NONE *| 01912 |* *| 01913 |* Returns: *| 01914 |* NONE *| 01915 |* *| 01916 \******************************************************************************/ 01917 01918 static void end_forall_blk(boolean err_call) 01919 01920 { 01921 TRACE (Func_Entry, "end_forall_blk", NULL); 01922 01923 if (cmd_line_flags.debug_lvl <= Debug_Lvl_1 && ! err_call) { 01924 01925 /*-ez -ed -G0 -G1*/ 01926 01927 gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Stmt_Lbl, NULL_IDX); 01928 } 01929 01930 if (cif_flags & MISC_RECS) { 01931 cif_stmt_type_rec(TRUE, CIF_End_Forall_Stmt, statement_number); 01932 } 01933 01934 SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX; 01935 01936 IR_FLD_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = SH_Tbl_Idx; 01937 IR_IDX_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = curr_stmt_sh_idx; 01938 IR_LINE_NUM_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = 01939 SH_GLB_LINE(CURR_BLK_FIRST_SH_IDX); 01940 IR_COL_NUM_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = 01941 SH_COL_NUM(CURR_BLK_FIRST_SH_IDX); 01942 01943 /* LRR: Before popping the Blocking Stmt stack, need to use it to get to */ 01944 /* the FORALL SH to get to each of the index name Attrs and clear the flag */ 01945 /* that says it's alive. */ 01946 01947 POP_BLK_STK; 01948 01949 TRACE (Func_Exit, "end_forall_blk", NULL); 01950 01951 return; 01952 01953 } /* end_forall_blk */ 01954 01955 01956 /******************************************************************************\ 01957 |* *| 01958 |* Description: *| 01959 |* Complete the processing of the END WHERE statement. *| 01960 |* *| 01961 |* Input parameters: *| 01962 |* err_call => Boolean - TRUE if this is called from an error situation. *| 01963 |* This means the compiler is trying to clean up the block *| 01964 |* stack and do error recovery. *| 01965 |* *| 01966 |* Output parameters: *| 01967 |* NONE *| 01968 |* *| 01969 |* Returns: *| 01970 |* NONE *| 01971 |* *| 01972 \******************************************************************************/ 01973 01974 static void end_where_blk(boolean err_call) 01975 01976 { 01977 int sh_idx; 01978 01979 TRACE (Func_Entry, "end_where_blk", NULL); 01980 01981 if (cmd_line_flags.debug_lvl <= Debug_Lvl_1 && !err_call) { 01982 /*-ez -ed -G0 -G1*/ 01983 gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Stmt_Lbl, NULL_IDX); 01984 } 01985 01986 if (cif_flags & MISC_RECS) { 01987 cif_stmt_type_rec(TRUE, CIF_End_Where_Stmt, statement_number); 01988 } 01989 01990 if (CURR_BLK == Where_Then_Blk || 01991 CURR_BLK == Where_Else_Blk || 01992 CURR_BLK == Where_Else_Mask_Blk) { 01993 01994 SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX; 01995 01996 sh_idx = SH_PARENT_BLK_IDX(curr_stmt_sh_idx); 01997 while (sh_idx != NULL_IDX && 01998 SH_STMT_TYPE(sh_idx) != Where_Cstrct_Stmt) { 01999 02000 sh_idx = SH_PARENT_BLK_IDX(sh_idx); 02001 } 02002 02003 if (sh_idx != NULL_IDX) { 02004 IR_FLD_R(SH_IR_IDX(sh_idx)) = SH_Tbl_Idx; 02005 IR_IDX_R(SH_IR_IDX(sh_idx)) = curr_stmt_sh_idx; 02006 } 02007 } 02008 02009 POP_BLK_STK; 02010 02011 TRACE (Func_Exit, "end_where_blk", NULL); 02012 02013 return; 02014 02015 } /* end_where_blk */ 02016 02017 02018 /******************************************************************************\ 02019 |* *| 02020 |* Description: *| 02021 |* Complete the processing of the END statement for a SELECT construct. *| 02022 |* *| 02023 |* Input parameters: *| 02024 |* err_call => Boolean - TRUE if this is called from an error situation. *| 02025 |* This means the compiler is trying to clean up the block *| 02026 |* stack and do error recovery. *| 02027 |* *| 02028 |* Output parameters: *| 02029 |* NONE *| 02030 |* *| 02031 |* Returns: *| 02032 |* NONE *| 02033 |* *| 02034 \******************************************************************************/ 02035 02036 static void end_select_blk(boolean err_call) 02037 02038 { 02039 int blk_idx; 02040 int il_idx_1; 02041 int il_idx_2; 02042 int name_idx; 02043 long num_cases_value; 02044 int ir_idx; 02045 int save_curr_stmt_sh_idx; 02046 int sh_idx; 02047 02048 02049 TRACE (Func_Entry, "end_select_blk", NULL); 02050 02051 if (err_call) { /* This is an error situation */ 02052 gen_sh(Before, End_Select_Stmt, stmt_start_line, stmt_start_col, 02053 TRUE, FALSE, FALSE); 02054 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 02055 } 02056 02057 if (CURR_BLK == Case_Blk) { 02058 POP_BLK_STK; 02059 } 02060 02061 if (CURR_BLK == Select_Blk) { 02062 02063 if (CURR_BLK_ERR) { 02064 goto EXIT; 02065 } 02066 02067 /* Generate a CONTINUE stmt before the END SELECT stmt to define the */ 02068 /* branch-around label. If the END SELECT stmt already has a user */ 02069 /* label, insert the CONTINUE stmt ahead of the Label_Def SH. */ 02070 02071 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 02072 02073 if (SH_LABELED(curr_stmt_sh_idx)) { 02074 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 02075 } 02076 02077 gen_sh(Before, Continue_Stmt, stmt_start_line, stmt_start_col, 02078 FALSE, TRUE, TRUE); 02079 02080 02081 sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 02082 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 02083 02084 if (cmd_line_flags.debug_lvl == Debug_Lvl_0) { /* -ed -G0 */ 02085 gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Stmt_Lbl, NULL_IDX); 02086 } 02087 02088 NTR_IR_TBL(ir_idx); 02089 SH_IR_IDX(sh_idx) = ir_idx; 02090 IR_OPR(ir_idx) = Label_Opr; 02091 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 02092 IR_LINE_NUM(ir_idx) = stmt_start_line; 02093 IR_COL_NUM(ir_idx) = stmt_start_col; 02094 IR_LINE_NUM_L(ir_idx) = stmt_start_line; 02095 IR_COL_NUM_L(ir_idx) = stmt_start_col; 02096 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 02097 IR_IDX_L(ir_idx) = CURR_BLK_LABEL; 02098 02099 /* CURR_BLK_LABEL is an internal label generated by the select stmt */ 02100 02101 AT_DEFINED(CURR_BLK_LABEL) = TRUE; 02102 AT_DEF_LINE(CURR_BLK_LABEL) = stmt_start_line; 02103 ATL_DEF_STMT_IDX(CURR_BLK_LABEL) = sh_idx; 02104 02105 if (cmd_line_flags.debug_lvl == Debug_Lvl_1) { /* -ez -G1 */ 02106 ATL_DEBUG_CLASS(CURR_BLK_LABEL) = Ldbg_Stmt_Lbl; 02107 } 02108 02109 /* Now go back to the Select IR and generate the ILs to hold the number */ 02110 /* of cases, the branch-around label, and (if it exists) the CASE */ 02111 /* DEFAULT label. */ 02112 02113 ir_idx = IR_IDX_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)); 02114 02115 NTR_IR_LIST_TBL(il_idx_1); 02116 IR_FLD_R(ir_idx) = IL_Tbl_Idx; 02117 IR_IDX_R(ir_idx) = il_idx_1; 02118 IL_FLD(il_idx_1) = CN_Tbl_Idx; 02119 num_cases_value = (long) BLK_NUM_CASES(blk_stk_idx); 02120 IL_IDX(il_idx_1) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num_cases_value); 02121 IL_LINE_NUM(il_idx_1) = stmt_start_line; 02122 IL_COL_NUM(il_idx_1) = stmt_start_col; 02123 02124 NTR_IR_LIST_TBL(il_idx_2); 02125 IL_NEXT_LIST_IDX(il_idx_1) = il_idx_2; 02126 IL_PREV_LIST_IDX(il_idx_2) = il_idx_1; 02127 IL_LINE_NUM(il_idx_2) = stmt_start_line; 02128 IL_COL_NUM(il_idx_2) = stmt_start_col; 02129 IL_FLD(il_idx_2) = AT_Tbl_Idx; 02130 IL_IDX(il_idx_2) = CURR_BLK_LABEL; 02131 02132 if (BLK_CASE_DEFAULT_LBL_FLD(blk_stk_idx) == NO_Tbl_Idx) { 02133 IR_LIST_CNT_R(ir_idx) = 2; 02134 } 02135 else { 02136 IR_LIST_CNT_R(ir_idx) = 3; 02137 il_idx_1 = il_idx_2; 02138 02139 NTR_IR_LIST_TBL(il_idx_2); 02140 IL_NEXT_LIST_IDX(il_idx_1) = il_idx_2; 02141 IL_PREV_LIST_IDX(il_idx_2) = il_idx_1; 02142 COPY_OPND(IL_OPND(il_idx_2), BLK_CASE_DEFAULT_LBL_OPND(blk_stk_idx)); 02143 } 02144 02145 } 02146 else { 02147 02148 /* Error blocks got in the way - try to find the Select_Blk. */ 02149 02150 name_idx = BLK_NAME(blk_stk_idx + 1); 02151 02152 for (blk_idx = blk_stk_idx; blk_idx > 0; --blk_idx) { 02153 02154 if (BLK_TYPE(blk_idx) == Select_Blk && 02155 BLK_NAME(blk_idx) == name_idx) { 02156 blk_idx = move_blk_to_end(blk_idx); 02157 break; 02158 } 02159 } 02160 } 02161 02162 02163 EXIT: 02164 02165 SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX; 02166 02167 if (cif_flags & MISC_RECS) { 02168 cif_stmt_type_rec(TRUE, CIF_End_Select_Stmt, statement_number); 02169 } 02170 02171 02172 /* Check before popping it because the program could be really messed up */ 02173 /* which would cause the Block Stack to be equally messed up. */ 02174 02175 if (CURR_BLK == Select_Blk) { 02176 POP_BLK_STK; 02177 } 02178 02179 02180 if (err_call) { 02181 curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx); 02182 } 02183 02184 TRACE (Func_Exit, "end_select_blk", NULL); 02185 02186 return; 02187 02188 } /* end_select_blk */ 02189 02190 02191 /******************************************************************************\ 02192 |* *| 02193 |* Description: *| 02194 |* This procedure is called from the main parse driver and the "end *| 02195 |* program unit" routines in this file when the current statement is *| 02196 |* labeled. It determines whether or not the labeled statement is *| 02197 |* terminating one or more DO loops. *| 02198 |* *| 02199 |* Input parameters: *| 02200 |* NONE *| 02201 |* *| 02202 |* Output parameters: *| 02203 |* NONE *| 02204 |* *| 02205 |* Returns: *| 02206 |* NONE *| 02207 |* *| 02208 \******************************************************************************/ 02209 02210 void end_labeled_do() 02211 02212 { 02213 int blk_idx; 02214 boolean error_flag; 02215 int fake_blk_stk_idx; 02216 int loop_num = 0; 02217 boolean msg_issued; 02218 int save_blk_stk_idx; 02219 int save_sh_err_flg; 02220 02221 02222 TRACE (Func_Entry, "end_labeled_do", NULL); 02223 02224 02225 if (stmt_label_idx == NULL_IDX) { 02226 return; /* This requires that stmt_label_idx be valid */ 02227 } 02228 02229 /* Does this statement label terminate a DO loop? */ 02230 02231 if (stmt_label_idx == CURR_BLK_LABEL) { 02232 blk_idx = blk_stk_idx; 02233 } 02234 else { 02235 02236 if (blk_stk_idx > 1) { 02237 blk_idx = blk_stk_idx - 1; 02238 02239 while (BLK_TYPE(blk_idx) > Module_Proc_Blk) { 02240 02241 if (stmt_label_idx == BLK_LABEL(blk_idx)) { 02242 goto FOUND_DO_BLK; 02243 } 02244 --blk_idx; 02245 } 02246 } 02247 02248 goto EXIT; 02249 } 02250 02251 02252 /* Verify that the termination statement is acceptable. */ 02253 02254 FOUND_DO_BLK: 02255 02256 if (cmd_line_flags.debug_lvl == Debug_Lvl_0) { /* -ed -G0 */ 02257 gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Stmt_Lbl, NULL_IDX); 02258 } 02259 02260 if (stmt_type != End_Do_Stmt && BLK_NAME(blk_idx) != NULL_IDX) { 02261 PRINTMSG(stmt_start_line, 669, Error, stmt_start_col); 02262 } 02263 02264 switch (stmt_type) { 02265 02266 case Continue_Stmt: 02267 if (BLK_LOOP_NUM(blk_idx) > 1) { 02268 PRINTMSG(stmt_start_line, 241, Comment, stmt_start_col); 02269 } 02270 02271 break; 02272 02273 case End_Do_Stmt: 02274 break; 02275 02276 case Goto_Stmt: 02277 if (IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) == Br_Uncond_Opr) { 02278 PRINTMSG(stmt_start_line, 242, Error, stmt_start_col); 02279 } 02280 else if (IR_OPR(SH_IR_IDX(curr_stmt_sh_idx)) == Br_Asg_Opr) { 02281 PRINTMSG(stmt_start_line, 243, Error, stmt_start_col); 02282 } 02283 else { 02284 PRINTMSG(stmt_start_line, 241, Comment, stmt_start_col); 02285 } 02286 02287 break; 02288 02289 case Outmoded_If_Stmt: 02290 PRINTMSG(stmt_start_line, 246, Error, stmt_start_col); 02291 break; 02292 02293 case Do_Iterative_Stmt: 02294 case Do_While_Stmt: 02295 case Do_Infinite_Stmt: 02296 case If_Cstrct_Stmt: 02297 case Select_Stmt: 02298 case Where_Cstrct_Stmt: 02299 msg_issued = FALSE; 02300 save_sh_err_flg = SH_ERR_FLG(curr_stmt_sh_idx); 02301 02302 if (stmt_type == If_Cstrct_Stmt) { 02303 blk_idx = blk_stk_idx - 2; 02304 fake_blk_stk_idx = blk_stk_idx - 2; 02305 } 02306 else { 02307 blk_idx = blk_stk_idx - 1; 02308 fake_blk_stk_idx = blk_stk_idx - 1; 02309 } 02310 02311 while (BLK_TYPE(blk_idx) > Module_Proc_Blk) { 02312 02313 if (stmt_label_idx == BLK_LABEL(blk_idx)) { 02314 02315 if (! msg_issued) { 02316 PRINTMSG(stmt_start_line, 244, Error, stmt_start_col, 02317 stmt_type_str[stmt_type]); 02318 msg_issued = TRUE; 02319 } 02320 02321 if (blk_idx != fake_blk_stk_idx) { 02322 save_blk_stk_idx = blk_stk_idx; 02323 blk_stk_idx = fake_blk_stk_idx; 02324 error_flag = pop_and_err_blk_stk(blk_idx, FALSE); 02325 blk_stk_idx = save_blk_stk_idx; 02326 } 02327 02328 move_blk_to_end(blk_idx); 02329 02330 if (msg_issued || error_flag) { 02331 SH_ERR_FLG(CURR_BLK_FIRST_SH_IDX) = TRUE; 02332 } 02333 POP_BLK_STK; 02334 02335 if (CURR_BLK == Doall_Blk) { 02336 POP_BLK_STK; 02337 cdir_switches.doall_region = FALSE; 02338 CLEAR_DIRECTIVE_STATE(Doall_Region); 02339 } 02340 else if (CURR_BLK == SGI_Parallel_Do_Blk) { 02341 POP_BLK_STK; 02342 CLEAR_DIRECTIVE_STATE(Parallel_Do_Region); 02343 } 02344 else if (CURR_BLK == SGI_Doacross_Blk) { 02345 POP_BLK_STK; 02346 CLEAR_DIRECTIVE_STATE(Doacross_Region); 02347 } 02348 02349 --fake_blk_stk_idx; 02350 } 02351 02352 --blk_idx; 02353 } 02354 02355 SH_ERR_FLG(curr_stmt_sh_idx) = save_sh_err_flg; 02356 goto EXIT; 02357 02358 case End_Stmt: 02359 case End_Function_Stmt: 02360 case End_Program_Stmt: 02361 case End_Subroutine_Stmt: 02362 msg_issued = FALSE; 02363 blk_idx = blk_stk_idx; 02364 02365 while (BLK_TYPE(blk_idx) > Module_Proc_Blk) { 02366 02367 if (stmt_label_idx == BLK_LABEL(blk_idx)) { 02368 PRINTMSG(stmt_start_line, 244, Error, stmt_start_col, 02369 stmt_type_str[stmt_type]); 02370 msg_issued = TRUE; 02371 break; 02372 } 02373 02374 --blk_idx; 02375 } 02376 02377 if (msg_issued) { 02378 break; 02379 } 02380 else { 02381 goto EXIT; 02382 } 02383 02384 case Arith_If_Stmt: 02385 case Cycle_Stmt: 02386 case Exit_Stmt: 02387 case Return_Stmt: 02388 case Stop_Stmt: 02389 PRINTMSG(stmt_start_line, 244, Error, stmt_start_col, 02390 stmt_type_str[stmt_type]); 02391 break; 02392 02393 case End_If_Stmt: 02394 case End_Select_Stmt: 02395 case End_Where_Stmt: 02396 case Case_Stmt: 02397 case Else_Stmt: 02398 case Else_If_Stmt: 02399 case Else_Where_Stmt: 02400 PRINTMSG(stmt_start_line, 244, Error, stmt_start_col, 02401 stmt_type_str[stmt_type]); 02402 02403 blk_idx = blk_stk_idx; 02404 02405 while (BLK_TYPE(blk_idx) > Module_Proc_Blk) { 02406 02407 if (stmt_label_idx == BLK_LABEL(blk_idx)) { 02408 02409 if (blk_idx != blk_stk_idx) { 02410 move_blk_to_end(blk_idx); 02411 } 02412 02413 SH_ERR_FLG(CURR_BLK_FIRST_SH_IDX) = TRUE; 02414 POP_BLK_STK; 02415 02416 if (CURR_BLK == Doall_Blk) { 02417 POP_BLK_STK; 02418 cdir_switches.doall_region = FALSE; 02419 CLEAR_DIRECTIVE_STATE(Doall_Region); 02420 } 02421 else if (CURR_BLK == SGI_Parallel_Do_Blk) { 02422 POP_BLK_STK; 02423 CLEAR_DIRECTIVE_STATE(Parallel_Do_Region); 02424 } 02425 else if (CURR_BLK == SGI_Doacross_Blk) { 02426 POP_BLK_STK; 02427 CLEAR_DIRECTIVE_STATE(Doacross_Region); 02428 } 02429 } 02430 02431 --blk_idx; 02432 } 02433 02434 goto EXIT; 02435 02436 default: 02437 if (ATL_EXECUTABLE(stmt_label_idx)) { 02438 PRINTMSG(stmt_start_line, 241, Comment, stmt_start_col); 02439 } 02440 else { 02441 PRINTMSG(stmt_start_line, 544, Error, stmt_start_col); 02442 } 02443 } 02444 02445 /* remove any Do Parallel blocks that are above the do block */ 02446 02447 blk_idx = blk_stk_idx; 02448 02449 while (BLK_TYPE(blk_idx) > Module_Proc_Blk) { 02450 02451 if (BLK_TYPE(blk_idx) == Do_Parallel_Blk || 02452 BLK_TYPE(blk_idx) == SGI_Pdo_Blk || 02453 BLK_TYPE(blk_idx) == Open_Mp_Do_Blk || 02454 BLK_TYPE(blk_idx) == Open_Mp_Parallel_Do_Blk) { 02455 02456 if (BLK_TYPE(blk_idx) == Do_Parallel_Blk) { 02457 CLEAR_DIRECTIVE_STATE(Do_Parallel_Region); 02458 } 02459 else if (BLK_TYPE(blk_idx) == SGI_Pdo_Blk) { 02460 CLEAR_DIRECTIVE_STATE(Pdo_Region); 02461 } 02462 else if (BLK_TYPE(blk_idx) == Open_Mp_Do_Blk) { 02463 CLEAR_DIRECTIVE_STATE(Open_Mp_Do_Region); 02464 } 02465 else if (BLK_TYPE(blk_idx) == Open_Mp_Parallel_Do_Blk) { 02466 CLEAR_DIRECTIVE_STATE(Open_Mp_Parallel_Do_Region); 02467 } 02468 02469 move_blk_to_end(blk_idx); 02470 POP_BLK_STK; 02471 blk_idx--; 02472 continue; 02473 } 02474 02475 if (stmt_label_idx == BLK_LABEL(blk_idx)) { 02476 break; 02477 } 02478 --blk_idx; 02479 } 02480 02481 /* Now close all loops this statement terminates. */ 02482 02483 blk_idx = blk_stk_idx; 02484 02485 while (BLK_TYPE(blk_idx) > Module_Proc_Blk) { 02486 02487 if (stmt_label_idx == BLK_LABEL(blk_idx)) { 02488 02489 if (blk_idx != blk_stk_idx) { 02490 error_flag = pop_and_err_blk_stk(blk_idx, FALSE); 02491 move_blk_to_end(blk_idx); 02492 02493 if (error_flag) { 02494 SH_ERR_FLG(CURR_BLK_FIRST_SH_IDX) = TRUE; 02495 } 02496 } 02497 02498 if (! SH_ERR_FLG(curr_stmt_sh_idx) && 02499 ! SH_ERR_FLG(CURR_BLK_FIRST_SH_IDX)) { 02500 loop_end_processing(); 02501 loop_num = BLK_LOOP_NUM(blk_idx); 02502 } 02503 02504 POP_BLK_STK; 02505 02506 if (CURR_BLK == Doall_Blk) { 02507 POP_BLK_STK; 02508 cdir_switches.doall_region = FALSE; 02509 CLEAR_DIRECTIVE_STATE(Doall_Region); 02510 } 02511 else if (CURR_BLK == SGI_Parallel_Do_Blk) { 02512 POP_BLK_STK; 02513 CLEAR_DIRECTIVE_STATE(Parallel_Do_Region); 02514 } 02515 else if (CURR_BLK == SGI_Doacross_Blk) { 02516 POP_BLK_STK; 02517 CLEAR_DIRECTIVE_STATE(Doacross_Region); 02518 } 02519 } 02520 else if (loop_num > 1 && 02521 end_task_do_blk ()) { 02522 POP_BLK_STK; 02523 } 02524 02525 --blk_idx; 02526 } 02527 02528 EXIT: 02529 02530 (void) end_task_do_blk(); 02531 02532 TRACE (Func_Exit, "end_labeled_do", NULL); 02533 02534 return; 02535 02536 } /* end_labeled_do */ 02537 02538 /******************************************************************************\ 02539 |* *| 02540 |* Description: *| 02541 |* <description> *| 02542 |* *| 02543 |* Input parameters: *| 02544 |* NONE *| 02545 |* *| 02546 |* Output parameters: *| 02547 |* NONE *| 02548 |* *| 02549 |* Returns: *| 02550 |* NOTHING *| 02551 |* *| 02552 \******************************************************************************/ 02553 02554 static boolean end_task_do_blk(void) 02555 02556 { 02557 int ir_idx; 02558 boolean left_on_stk = FALSE; 02559 02560 TRACE (Func_Entry, "end_task_do_blk", NULL); 02561 02562 if (CURR_BLK == Do_Parallel_Blk && 02563 BLK_ENDDO_PARALLEL_SH_IDX(blk_stk_idx) == NULL_IDX) { 02564 02565 left_on_stk = TRUE; 02566 02567 /* insert enddo parallel statement after */ 02568 need_new_sh = TRUE; 02569 02570 gen_sh(After, End_Do_Parallel_Stmt, stmt_start_line, stmt_start_col, 02571 FALSE, FALSE, TRUE); 02572 02573 NTR_IR_TBL(ir_idx); 02574 IR_OPR(ir_idx) = Enddo_Cmic_Opr; 02575 02576 /* must have a type idx */ 02577 02578 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 02579 IR_LINE_NUM(ir_idx) = stmt_start_line; 02580 IR_COL_NUM(ir_idx) = stmt_start_col; 02581 02582 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 02583 02584 BLK_ENDDO_PARALLEL_SH_IDX(blk_stk_idx) = curr_stmt_sh_idx; 02585 } 02586 else if ((CURR_BLK == SGI_Pdo_Blk || 02587 CURR_BLK == Open_Mp_Do_Blk || 02588 CURR_BLK == Open_Mp_Parallel_Do_Blk) && 02589 BLK_ENDPDO_SH_IDX(blk_stk_idx) == NULL_IDX) { 02590 02591 02592 /* insert endpdo statement after */ 02593 need_new_sh = TRUE; 02594 02595 02596 NTR_IR_TBL(ir_idx); 02597 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 02598 IR_LINE_NUM(ir_idx) = stmt_start_line; 02599 IR_COL_NUM(ir_idx) = stmt_start_col; 02600 02601 IR_LINE_NUM_R(ir_idx) = stmt_start_line; 02602 IR_COL_NUM_R(ir_idx) = stmt_start_col; 02603 IR_FLD_R(ir_idx) = SH_Tbl_Idx; 02604 IR_IDX_R(ir_idx) = CURR_BLK_FIRST_SH_IDX; 02605 02606 switch (CURR_BLK) { 02607 case SGI_Pdo_Blk: 02608 IR_OPR(ir_idx) = End_Pdo_Par_Opr; 02609 gen_sh(After, SGI_End_Pdo_Stmt, stmt_start_line, stmt_start_col, 02610 FALSE, FALSE, TRUE); 02611 CLEAR_DIRECTIVE_STATE(Pdo_Region); 02612 POP_BLK_STK; 02613 break; 02614 02615 case Open_Mp_Do_Blk: 02616 IR_OPR(ir_idx) = Enddo_Open_Mp_Opr; 02617 gen_sh(After, Open_MP_End_Do_Stmt, stmt_start_line, stmt_start_col, 02618 FALSE, FALSE, TRUE); 02619 CLEAR_DIRECTIVE_STATE(Open_Mp_Do_Region); 02620 POP_BLK_STK; 02621 break; 02622 02623 case Open_Mp_Parallel_Do_Blk: 02624 IR_OPR(ir_idx) = Endparalleldo_Open_Mp_Opr; 02625 gen_sh(After, Open_MP_End_Do_Stmt, stmt_start_line, stmt_start_col, 02626 FALSE, FALSE, TRUE); 02627 CLEAR_DIRECTIVE_STATE(Open_Mp_Parallel_Do_Region); 02628 POP_BLK_STK; 02629 break; 02630 } 02631 02632 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 02633 } 02634 02635 02636 TRACE (Func_Exit, "end_task_do_blk", NULL); 02637 02638 return(left_on_stk); 02639 02640 } /* end_task_do_blk */ 02641 02642 02643 /******************************************************************************\ 02644 |* *| 02645 |* Description: *| 02646 |* Complete the processing of the END DO statement. *| 02647 |* *| 02648 |* Input parameters: *| 02649 |* err_call => Boolean - TRUE if this is called from an error situation. *| 02650 |* This means the compiler is trying to clean up the block *| 02651 |* stack and do error recovery. *| 02652 |* *| 02653 |* Output parameters: *| 02654 |* NONE *| 02655 |* *| 02656 |* Returns: *| 02657 |* NONE *| 02658 |* *| 02659 \******************************************************************************/ 02660 02661 static void end_do_blk(boolean err_call) 02662 02663 { 02664 int blk_idx; 02665 boolean loop_end_ir_gend = FALSE; 02666 boolean msg_issued; 02667 boolean no_err = TRUE; 02668 int unlabeled_do_idx; 02669 02670 02671 TRACE (Func_Entry, "end_do_blk", NULL); 02672 02673 /* If err_call is TRUE, it means this procedure is being called due to a */ 02674 /* blocking stmt mismatch to close out the current Block Stack frame. Pop */ 02675 /* the Block Stack. */ 02676 02677 if (err_call) { 02678 POP_BLK_STK; 02679 if (CURR_BLK == Doall_Blk) { 02680 POP_BLK_STK; 02681 cdir_switches.doall_region = FALSE; 02682 CLEAR_DIRECTIVE_STATE(Doall_Region); 02683 } 02684 else if (CURR_BLK == SGI_Parallel_Do_Blk) { 02685 POP_BLK_STK; 02686 CLEAR_DIRECTIVE_STATE(Parallel_Do_Region); 02687 } 02688 else if (CURR_BLK == SGI_Doacross_Blk) { 02689 POP_BLK_STK; 02690 CLEAR_DIRECTIVE_STATE(Doacross_Region); 02691 } 02692 02693 goto EXIT; 02694 } 02695 02696 /* Remove any Do Parallel blocks that are above the DO block. */ 02697 02698 blk_idx = blk_stk_idx; 02699 02700 while (BLK_TYPE(blk_idx) > Module_Proc_Blk) { 02701 02702 if (BLK_TYPE(blk_idx) == Do_Parallel_Blk || 02703 BLK_TYPE(blk_idx) == SGI_Pdo_Blk || 02704 BLK_TYPE(blk_idx) == Open_Mp_Do_Blk || 02705 BLK_TYPE(blk_idx) == Open_Mp_Parallel_Do_Blk) { 02706 02707 if (BLK_TYPE(blk_idx) == Do_Parallel_Blk) { 02708 CLEAR_DIRECTIVE_STATE(Do_Parallel_Region); 02709 } 02710 else if (BLK_TYPE(blk_idx) == SGI_Pdo_Blk) { 02711 CLEAR_DIRECTIVE_STATE(Pdo_Region); 02712 } 02713 else if (BLK_TYPE(blk_idx) == Open_Mp_Do_Blk) { 02714 CLEAR_DIRECTIVE_STATE(Open_Mp_Do_Region); 02715 } 02716 else if (BLK_TYPE(blk_idx) == Open_Mp_Parallel_Do_Blk) { 02717 CLEAR_DIRECTIVE_STATE(Open_Mp_Parallel_Do_Region); 02718 } 02719 02720 move_blk_to_end(blk_idx); 02721 POP_BLK_STK; 02722 blk_idx--; 02723 continue; 02724 } 02725 else if (BLK_TYPE(blk_idx) == Do_Blk) { 02726 break; 02727 } 02728 02729 --blk_idx; 02730 } 02731 02732 02733 if (cmd_line_flags.debug_lvl == Debug_Lvl_0) { /* -ed -G0 */ 02734 gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Stmt_Lbl, NULL_IDX); 02735 } 02736 02737 if (cif_flags & MISC_RECS) { 02738 cif_stmt_type_rec(TRUE, CIF_End_Do_Stmt, statement_number); 02739 } 02740 02741 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 02742 02743 if (stmt_label_idx == NULL_IDX) { 02744 blk_idx = blk_stk_idx; 02745 02746 /* Must search back through the Block Stack because there could be */ 02747 /* labeled DOs between this unlabeled END DO and an unlabeled DO. */ 02748 02749 while (BLK_TYPE(blk_idx) > Module_Proc_Blk) { 02750 02751 if (BLK_TYPE(blk_idx) == Do_Blk && BLK_LABEL(blk_idx) == NULL_IDX) { 02752 02753 if (blk_idx == blk_stk_idx) { 02754 02755 if (! SH_ERR_FLG(CURR_BLK_FIRST_SH_IDX)) { 02756 loop_end_processing(); 02757 loop_end_ir_gend = TRUE; 02758 } 02759 02760 } 02761 else { 02762 pop_and_err_blk_stk(blk_idx, FALSE); 02763 move_blk_to_end(blk_idx); 02764 } 02765 02766 POP_BLK_STK; 02767 02768 if (CURR_BLK == Doall_Blk) { 02769 POP_BLK_STK; 02770 cdir_switches.doall_region = FALSE; 02771 CLEAR_DIRECTIVE_STATE(Doall_Region); 02772 } 02773 else if (CURR_BLK == SGI_Parallel_Do_Blk) { 02774 POP_BLK_STK; 02775 CLEAR_DIRECTIVE_STATE(Parallel_Do_Region); 02776 } 02777 else if (CURR_BLK == SGI_Doacross_Blk) { 02778 POP_BLK_STK; 02779 CLEAR_DIRECTIVE_STATE(Doacross_Region); 02780 } 02781 02782 goto EXIT; 02783 } 02784 02785 --blk_idx; 02786 } 02787 02788 PRINTMSG(stmt_start_line, 289, Error, stmt_start_col, "END DO", "DO"); 02789 } 02790 else { 02791 unlabeled_do_idx = NULL_IDX; 02792 blk_idx = blk_stk_idx; 02793 msg_issued = FALSE; 02794 02795 while (BLK_TYPE(blk_idx) > Module_Proc_Blk) { 02796 02797 if (BLK_TYPE(blk_idx) == Do_Blk) { 02798 02799 if (BLK_LABEL(blk_idx) != NULL_IDX) { 02800 02801 if (BLK_LABEL(blk_idx) == stmt_label_idx) { 02802 02803 if (blk_idx == blk_stk_idx) { 02804 02805 if (BLK_LOOP_NUM(blk_stk_idx) > 1) { 02806 02807 if (! msg_issued) { 02808 PRINTMSG(stmt_start_line, 735, Ansi, stmt_start_col); 02809 msg_issued = TRUE; 02810 } 02811 } 02812 02813 if (! SH_ERR_FLG(CURR_BLK_FIRST_SH_IDX)) { 02814 loop_end_processing(); 02815 loop_end_ir_gend = TRUE; 02816 } 02817 else { 02818 no_err = FALSE; 02819 } 02820 } 02821 else { 02822 pop_and_err_blk_stk(blk_idx, FALSE); 02823 move_blk_to_end(blk_idx); 02824 no_err = FALSE; 02825 } 02826 02827 POP_BLK_STK; 02828 02829 if (CURR_BLK == Doall_Blk) { 02830 POP_BLK_STK; 02831 cdir_switches.doall_region = FALSE; 02832 CLEAR_DIRECTIVE_STATE(Doall_Region); 02833 } 02834 else if (CURR_BLK == SGI_Parallel_Do_Blk) { 02835 POP_BLK_STK; 02836 CLEAR_DIRECTIVE_STATE(Parallel_Do_Region); 02837 } 02838 else if (CURR_BLK == SGI_Doacross_Blk) { 02839 POP_BLK_STK; 02840 CLEAR_DIRECTIVE_STATE(Doacross_Region); 02841 } 02842 } 02843 } 02844 else if (unlabeled_do_idx == NULL_IDX) { 02845 unlabeled_do_idx = blk_idx; 02846 } 02847 } 02848 02849 --blk_idx; 02850 } 02851 02852 02853 /* If the end-of-loop IR has not been generated, it means we didn't */ 02854 /* find a DO stmt with a matching label or there was something else */ 02855 /* wrong with the loop. If we didn't find any UNlabeled DO stmts */ 02856 /* either, issue an error. Otherwise, use the END DO to match the */ 02857 /* unlabeled DO. */ 02858 02859 if (! loop_end_ir_gend && no_err) { 02860 02861 if (unlabeled_do_idx == NULL_IDX) { 02862 PRINTMSG(stmt_start_line, 289, Error, stmt_start_col, 02863 "END DO", "DO"); 02864 } 02865 else { 02866 02867 if (unlabeled_do_idx == blk_stk_idx) { 02868 02869 if (! SH_ERR_FLG(CURR_BLK_FIRST_SH_IDX)) { 02870 loop_end_processing(); 02871 } 02872 } 02873 else { 02874 pop_and_err_blk_stk(blk_idx, FALSE); 02875 move_blk_to_end(blk_idx); 02876 } 02877 02878 POP_BLK_STK; 02879 02880 if (CURR_BLK == Doall_Blk) { 02881 POP_BLK_STK; 02882 cdir_switches.doall_region = FALSE; 02883 CLEAR_DIRECTIVE_STATE(Doall_Region); 02884 } 02885 else if (CURR_BLK == SGI_Parallel_Do_Blk) { 02886 POP_BLK_STK; 02887 CLEAR_DIRECTIVE_STATE(Parallel_Do_Region); 02888 } 02889 else if (CURR_BLK == SGI_Doacross_Blk) { 02890 POP_BLK_STK; 02891 CLEAR_DIRECTIVE_STATE(Doacross_Region); 02892 } 02893 } 02894 } 02895 } 02896 02897 02898 EXIT: 02899 02900 (void) end_task_do_blk(); 02901 02902 TRACE (Func_Exit, "end_do_blk", NULL); 02903 02904 return; 02905 02906 } /* end_do_blk */ 02907 02908 02909 /******************************************************************************\ 02910 |* *| 02911 |* Description: *| 02912 |* Complete the processing of the END IF statement for an IF construct. *| 02913 |* *| 02914 |* Input parameters: *| 02915 |* err_call => Boolean - TRUE if this is called from an error situation. *| 02916 |* This means the compiler is trying to clean up the block *| 02917 |* stack and do error recovery. *| 02918 |* *| 02919 |* Output parameters: *| 02920 |* NONE *| 02921 |* *| 02922 |* Returns: *| 02923 |* NONE *| 02924 |* *| 02925 \******************************************************************************/ 02926 02927 static void end_if_blk(boolean err_call) 02928 02929 { 02930 int blk_idx; 02931 boolean error; 02932 int name_idx; 02933 02934 # ifdef _HIGH_LEVEL_IF_FORM 02935 int curr_sh; 02936 int ir_idx; 02937 # endif 02938 02939 # if 0 02940 int sh_idx; 02941 # endif 02942 02943 02944 TRACE (Func_Entry, "end_if_blk", NULL); 02945 02946 if (err_call) { /* This is an error situation */ 02947 gen_sh(Before, End_If_Stmt, stmt_start_line, stmt_start_col, 02948 TRUE, FALSE, FALSE); 02949 curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 02950 } 02951 else { 02952 02953 #ifdef _HIGH_LEVEL_IF_FORM 02954 02955 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 02956 curr_sh = curr_stmt_sh_idx; 02957 02958 NTR_IR_TBL(ir_idx); 02959 IR_OPR(ir_idx) = Endif_Opr; 02960 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 02961 IR_LINE_NUM(ir_idx) = stmt_start_line; 02962 IR_COL_NUM(ir_idx) = stmt_start_col; 02963 02964 SH_IR_IDX(curr_sh) = ir_idx; 02965 #endif 02966 02967 if (cmd_line_flags.debug_lvl <= Debug_Lvl_1) { /* -ez -ed -G0 -G1 */ 02968 gen_debug_lbl_stmt(curr_stmt_sh_idx, Ldbg_Stmt_Lbl, NULL_IDX); 02969 } 02970 } 02971 02972 error = err_call || CURR_BLK_ERR || SH_ERR_FLG(CURR_BLK_FIRST_SH_IDX); 02973 02974 if (cif_flags & MISC_RECS) { 02975 cif_stmt_type_rec(TRUE, CIF_End_If_Stmt, statement_number); 02976 } 02977 02978 02979 #if 0 02980 /* If the last clause of the IF construct is an ELSE IF, generate a */ 02981 /* CONTINUE statement to define its branch-around label. */ 02982 02983 if (CURR_BLK == If_Else_If_Blk && !error) { 02984 gen_sh(Before, Continue_Stmt, stmt_start_line, stmt_start_col, 02985 FALSE, TRUE, TRUE); 02986 02987 sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 02988 NTR_IR_TBL(ir_idx); 02989 SH_IR_IDX(sh_idx) = ir_idx; 02990 IR_OPR(ir_idx) = Label_Opr; 02991 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 02992 IR_LINE_NUM(ir_idx) = stmt_start_line; 02993 IR_COL_NUM(ir_idx) = stmt_start_col; 02994 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 02995 IR_IDX_L(ir_idx) = CURR_BLK_LABEL; 02996 IR_LINE_NUM_L(ir_idx) = stmt_start_line; 02997 IR_COL_NUM_L(ir_idx) = stmt_start_col; 02998 02999 AT_DEFINED(CURR_BLK_LABEL) = TRUE; 03000 AT_DEF_LINE(CURR_BLK_LABEL) = stmt_start_line; 03001 ATL_DEF_STMT_IDX(CURR_BLK_LABEL) = sh_idx; 03002 AT_REFERENCED(CURR_BLK_LABEL) = Referenced; 03003 } 03004 #endif 03005 03006 03007 if (CURR_BLK == If_Else_If_Blk || CURR_BLK == If_Else_Blk) { 03008 SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX; 03009 } 03010 03011 POP_BLK_STK; /* Pop the Then, Else, or Else if */ 03012 03013 if (CURR_BLK != If_Blk) { 03014 03015 /* Error blocks got in the way - try to find the If_Blk. */ 03016 03017 name_idx = BLK_NAME(blk_stk_idx + 1); 03018 03019 for (blk_idx = blk_stk_idx; blk_idx > 0; --blk_idx) { 03020 03021 if (BLK_TYPE(blk_idx) == If_Blk && BLK_NAME(blk_idx) == name_idx) { 03022 blk_idx = move_blk_to_end(blk_idx); 03023 break; 03024 } 03025 } 03026 } 03027 03028 03029 /* Before popping the If_Blk, make sure that if the IF-THEN stmt is */ 03030 /* marked in error, the END IF is too. */ 03031 03032 SH_ERR_FLG(curr_stmt_sh_idx) = error; 03033 03034 03035 #if 0 03036 /* Generate a CONTINUE statement to define the "end IF" label. */ 03037 03038 if (! error) { 03039 gen_sh(Before, Continue_Stmt, stmt_start_line, stmt_start_col, 03040 FALSE, TRUE, TRUE); 03041 03042 sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 03043 NTR_IR_TBL(ir_idx); 03044 SH_IR_IDX(sh_idx) = ir_idx; 03045 IR_OPR(ir_idx) = Label_Opr; 03046 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 03047 IR_LINE_NUM(ir_idx) = stmt_start_line; 03048 IR_COL_NUM(ir_idx) = stmt_start_col; 03049 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 03050 IR_IDX_L(ir_idx) = CURR_BLK_LABEL; 03051 IR_LINE_NUM_L(ir_idx) = stmt_start_line; 03052 IR_COL_NUM_L(ir_idx) = stmt_start_col; 03053 03054 AT_DEFINED(CURR_BLK_LABEL) = TRUE; 03055 AT_DEF_LINE(CURR_BLK_LABEL) = stmt_start_line; 03056 ATL_DEF_STMT_IDX(CURR_BLK_LABEL) = sh_idx; 03057 AT_REFERENCED(CURR_BLK_LABEL) = Referenced; 03058 } 03059 #endif 03060 03061 /* Check before popping it because the program could be really messed up */ 03062 /* which would cause the Block Stack to be equally messed up. */ 03063 03064 if (CURR_BLK == If_Blk) { 03065 03066 if (SH_PARENT_BLK_IDX(curr_stmt_sh_idx) == NULL_IDX) { 03067 SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX; 03068 } 03069 03070 #ifdef _HIGH_LEVEL_IF_FORM 03071 if (! error) { 03072 /* set the right opnd of the Br_True_Opr of the If to point */ 03073 /* to point to curr stmt. */ 03074 03075 # if defined(_DEBUG) 03076 if (IR_OPR(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) != Br_True_Opr) { 03077 PRINTMSG(stmt_start_line, 626, Internal, stmt_start_col, 03078 "Br_True_Opr", "end_if_blk"); 03079 } 03080 # endif 03081 03082 IR_FLD_R(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = SH_Tbl_Idx; 03083 IR_IDX_R(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = curr_sh; 03084 03085 /* have the left opnd of the Endif_Opr point to the If stmt */ 03086 IR_FLD_L(SH_IR_IDX(curr_sh)) = SH_Tbl_Idx; 03087 IR_IDX_L(SH_IR_IDX(curr_sh)) = CURR_BLK_FIRST_SH_IDX; 03088 } 03089 # endif 03090 POP_BLK_STK; 03091 } 03092 03093 03094 TRACE (Func_Exit, "end_if_blk", NULL); 03095 03096 return; 03097 03098 } /* end_if_blk */ 03099 03100 03101 /******************************************************************************\ 03102 |* *| 03103 |* Description: *| 03104 |* Complete the processing of the END statement for an INTERFACE block. *| 03105 |* *| 03106 |* Input parameters: *| 03107 |* err_call => Boolean - TRUE if this is called from an error situation. *| 03108 |* This means the compiler is trying to clean up the block *| 03109 |* stack and do error recovery. *| 03110 |* *| 03111 |* Output parameters: *| 03112 |* NONE *| 03113 |* *| 03114 |* Returns: *| 03115 |* NONE *| 03116 |* *| 03117 \******************************************************************************/ 03118 03119 static void end_interface_blk(boolean err_call) 03120 03121 { 03122 int attr_idx; 03123 boolean found; 03124 int interface_idx; 03125 int sn_idx; 03126 03127 03128 TRACE (Func_Entry, "end_interface_blk", NULL); 03129 03130 /* Do not need to mess with scope here, because we are in the parent's */ 03131 /* scope. The INTERFACE and the END INTERFACE routines do not cause */ 03132 /* a new scope to be entered. It is the FUNCTION/END FUNCTION and the */ 03133 /* SUBROUTINE/END SUBROUTINE that cause new scopes and delete old */ 03134 /* interface scopes. */ 03135 03136 /* Make sure that if the interface block shares a name with a pgm unit */ 03137 /* that the pgm unit is in the generic interface. */ 03138 03139 if (CURR_BLK_NAME != NULL_IDX && 03140 ATI_PROC_IDX(CURR_BLK_NAME) != NULL_IDX && 03141 !AT_DCL_ERR(ATI_PROC_IDX(CURR_BLK_NAME)) && !err_call) { 03142 attr_idx = ATI_PROC_IDX(CURR_BLK_NAME); 03143 found = FALSE; 03144 sn_idx = ATI_FIRST_SPECIFIC_IDX(CURR_BLK_NAME); 03145 03146 while (sn_idx != NULL_IDX) { 03147 03148 if (attr_idx == SN_ATTR_IDX(sn_idx)) { 03149 found = TRUE; 03150 break; 03151 } 03152 03153 sn_idx = SN_SIBLING_LINK(sn_idx); 03154 } 03155 03156 if (!found) { 03157 AT_DCL_ERR(attr_idx) = TRUE; 03158 AT_DCL_ERR(CURR_BLK_NAME) = TRUE; 03159 PRINTMSG(AT_DEF_LINE(attr_idx), 713, Error, AT_DEF_COLUMN(attr_idx), 03160 AT_OBJ_NAME_PTR(attr_idx), 03161 AT_OBJ_NAME_PTR(attr_idx)); 03162 } 03163 } 03164 03165 if (!SCP_IN_ERR(curr_scp_idx)) { 03166 interface_idx = (BLK_NAME(blk_stk_idx) == NULL_IDX) ? 03167 BLK_UNNAMED_INTERFACE(blk_stk_idx):BLK_NAME(blk_stk_idx); 03168 03169 if (!AT_DCL_ERR(interface_idx) && ATI_HAS_NON_MOD_PROC(interface_idx) && 03170 BLK_AT_IDX(blk_stk_idx) != NULL_IDX) { 03171 collapse_interface_blk(interface_idx); 03172 ATI_HAS_NON_MOD_PROC(interface_idx) = FALSE; 03173 } 03174 } 03175 03176 if (cif_flags & BASIC_RECS) { 03177 cif_end_scope_rec(); 03178 } 03179 03180 if (cif_flags & MISC_RECS) { 03181 cif_stmt_type_rec(TRUE, CIF_End_Interface_Stmt, statement_number); 03182 } 03183 03184 POP_BLK_STK; 03185 03186 TRACE (Func_Exit, "end_interface_blk", NULL); 03187 03188 return; 03189 03190 } /* end_interface_blk */ 03191 03192 03193 /******************************************************************************\ 03194 |* *| 03195 |* Description: *| 03196 |* Complete the processing of the END statement for a contains block. *| 03197 |* *| 03198 |* Input parameters: *| 03199 |* err_call => Boolean - TRUE if this is called from an error situation. *| 03200 |* This means the compiler is trying to clean up the block *| 03201 |* stack and do error recovery. *| 03202 |* *| 03203 |* Output parameters: *| 03204 |* NONE *| 03205 |* *| 03206 |* Returns: *| 03207 |* NONE *| 03208 |* *| 03209 \******************************************************************************/ 03210 03211 static void end_contains(boolean err_call) 03212 03213 { 03214 TRACE (Func_Entry, "end_contains", NULL); 03215 03216 POP_BLK_STK; /* Pop the contains */ 03217 03218 /* Illegal to have a CONTAINS with nothing in it. The only way this */ 03219 /* check will not work, is if there have been previous block, scoping */ 03220 /* errors with an interface block. If that happens, the program is so */ 03221 /* messed up, this check wouldn't matter much. In all valid cases, */ 03222 /* SCP_FIRST_CHILD_IDX will be clear at the CONTAINS statement, and */ 03223 /* must be set by having a least one routine inside the CONTAINS block.*/ 03224 03225 if (SCP_FIRST_CHILD_IDX(curr_scp_idx) == NULL_IDX && 03226 !SCP_IN_ERR(curr_scp_idx)) { 03227 PRINTMSG(stmt_start_line, 387, Error, stmt_start_col); 03228 } 03229 03230 end_of_contains = TRUE; 03231 03232 TRACE (Func_Exit, "end_contains", NULL); 03233 03234 return; 03235 03236 } /* end_contains */ 03237 03238 03239 /******************************************************************************\ 03240 |* *| 03241 |* Description: *| 03242 |* Complete the processing of the END statement for an TYPE block. *| 03243 |* *| 03244 |* Input parameters: *| 03245 |* err_call => Boolean - TRUE if this is called from an error situation. *| 03246 |* This means the compiler is trying to clean up the block *| 03247 |* stack and do error recovery. *| 03248 |* *| 03249 |* Output parameters: *| 03250 |* NONE *| 03251 |* *| 03252 |* Returns: *| 03253 |* NONE *| 03254 |* *| 03255 \******************************************************************************/ 03256 03257 static void end_type_blk(boolean err_call) 03258 03259 { 03260 boolean aligned; 03261 size_offset_type bit_len; 03262 03263 # if defined(_TARGET_DOUBLE_ALIGN) 03264 int i; 03265 int sn_idx; 03266 # endif 03267 03268 03269 TRACE (Func_Entry, "end_type_blk", NULL); 03270 03271 if (err_call) { 03272 03273 /* Intentionally blank. */ 03274 } 03275 else if (ATT_NUM_CPNTS(CURR_BLK_NAME) == 0) { 03276 PRINTMSG(CURR_BLK_DEF_LINE, 290, Error, CURR_BLK_DEF_COLUMN, 03277 AT_OBJ_NAME_PTR(CURR_BLK_NAME)); 03278 } 03279 else { 03280 03281 # ifdef _DEBUG 03282 if (!ATT_CHAR_CPNT(CURR_BLK_NAME) & 03283 !ATT_NUMERIC_CPNT(CURR_BLK_NAME) & 03284 !ATT_POINTER_CPNT(CURR_BLK_NAME)) { 03285 PRINTMSG(stmt_start_line, 193, Internal, stmt_start_col, 03286 FALSE, 03287 "ATT_CHAR_CPNT, ATT_NUMERIC_CPNT, ATT_POINTER_CPNT", 03288 CURR_BLK_NAME); 03289 } 03290 # endif 03291 03292 ATT_CHAR_SEQ(CURR_BLK_NAME) = !ATT_NUMERIC_CPNT(CURR_BLK_NAME) && 03293 !ATT_POINTER_CPNT(CURR_BLK_NAME) && 03294 ATT_SEQUENCE_SET(CURR_BLK_NAME); 03295 03296 ATT_DCL_NUMERIC_SEQ(CURR_BLK_NAME) = !ATT_POINTER_CPNT(CURR_BLK_NAME) && 03297 !ATT_CHAR_CPNT(CURR_BLK_NAME) && 03298 ATT_SEQUENCE_SET(CURR_BLK_NAME); 03299 03300 # if defined(_TARGET_DOUBLE_ALIGN) 03301 03302 if (!cmd_line_flags.dalign && 03303 ATT_DCL_NUMERIC_SEQ(CURR_BLK_NAME) && 03304 ATT_DALIGN_ME(CURR_BLK_NAME)) { 03305 03306 /* These components have been daligned, but cannot be because */ 03307 /* this is a numeric sequence derived type and -a dalign has */ 03308 /* not been specified on the commandline. Clear the block */ 03309 /* length and reassign offsets to all the components. */ 03310 03311 ATT_DALIGN_ME(CURR_BLK_NAME) = FALSE; 03312 ATT_STRUCT_BIT_LEN_FLD(CURR_BLK_NAME) = CN_Tbl_Idx; 03313 ATT_STRUCT_BIT_LEN_IDX(CURR_BLK_NAME) = CN_INTEGER_ZERO_IDX; 03314 sn_idx = ATT_FIRST_CPNT_IDX(CURR_BLK_NAME); 03315 03316 for (i = 0; i < ATT_NUM_CPNTS(CURR_BLK_NAME); i++) { 03317 ATD_CPNT_OFFSET_IDX(SN_ATTR_IDX(sn_idx)) = CN_INTEGER_ZERO_IDX; 03318 ATD_OFFSET_FLD(SN_ATTR_IDX(sn_idx)) = CN_Tbl_Idx; 03319 assign_offset(SN_ATTR_IDX(sn_idx)); /* reassign to components */ 03320 sn_idx = SN_SIBLING_LINK(sn_idx); 03321 } 03322 } 03323 # endif 03324 03325 if (ATT_NUMERIC_CPNT(CURR_BLK_NAME) || ATT_POINTER_CPNT(CURR_BLK_NAME)) { 03326 bit_len.fld = ATT_STRUCT_BIT_LEN_FLD(CURR_BLK_NAME); 03327 bit_len.idx = ATT_STRUCT_BIT_LEN_IDX(CURR_BLK_NAME); 03328 aligned = FALSE; 03329 03330 # if defined(_TARGET_PACK_HALF_WORD_TYPES) 03331 03332 # ifdef _WHIRL_HOST64_TARGET64 03333 { 03334 /* check to see if all components have alignment restrictions 03335 * less than or equal to Align_32. 03336 * If they do, then change alignment of structure to 32 03337 * bits. 03338 */ 03339 03340 int i; 03341 int sn_idx; 03342 boolean use_align_32 = TRUE; 03343 03344 sn_idx = ATT_FIRST_CPNT_IDX(CURR_BLK_NAME); 03345 03346 for (i = 0; i < ATT_NUM_CPNTS(CURR_BLK_NAME); i++) { 03347 if (ATD_ALIGNMENT(SN_ATTR_IDX(sn_idx)) > Align_32) { 03348 use_align_32 = FALSE; 03349 break; 03350 } 03351 sn_idx = SN_SIBLING_LINK(sn_idx); 03352 } 03353 03354 if (use_align_32) 03355 ATT_ALIGNMENT(CURR_BLK_NAME) = Align_32; 03356 } 03357 # endif /* _WHIRL_HOST64_TARGET64 */ 03358 03359 if (!aligned && ATT_ALIGNMENT(CURR_BLK_NAME) == Align_32) { 03360 03361 /* This structure contains all 32 bit components */ 03362 /* or structures made up of 32 bit components. */ 03363 03364 align_bit_length(&bit_len, TARGET_BITS_PER_WORD/2); 03365 aligned = TRUE; 03366 } 03367 # endif 03368 03369 if (!aligned) { 03370 03371 # if defined(GENERATE_WHIRL) 03372 03373 switch(ATT_ALIGNMENT(CURR_BLK_NAME)) { 03374 case Align_Bit: 03375 break; /* Should not see character here */ 03376 03377 /* For the forseeable future we are going to pad integer(kind=1) and */ 03378 /* integer(kind=2) to full words. */ 03379 03380 case Align_8: 03381 case Align_16: 03382 align_bit_length(&bit_len, TARGET_BITS_PER_WORD); 03383 break; 03384 03385 case Align_32: 03386 align_bit_length(&bit_len, 32); 03387 break; 03388 03389 case Align_64: 03390 align_bit_length(&bit_len, 64); 03391 break; 03392 03393 case Align_Double: 03394 case Align_128: 03395 align_bit_length(&bit_len, 128); 03396 break; 03397 } 03398 # else 03399 align_bit_length(&bit_len, TARGET_BITS_PER_WORD); 03400 # endif 03401 } 03402 03403 if (bit_len.fld == NO_Tbl_Idx) { 03404 ATT_STRUCT_BIT_LEN_FLD(CURR_BLK_NAME) = CN_Tbl_Idx; 03405 ATT_STRUCT_BIT_LEN_IDX(CURR_BLK_NAME) = ntr_const_tbl( 03406 bit_len.type_idx, 03407 FALSE, 03408 bit_len.constant); 03409 } 03410 else { 03411 ATT_STRUCT_BIT_LEN_FLD(CURR_BLK_NAME) = bit_len.fld; 03412 ATT_STRUCT_BIT_LEN_IDX(CURR_BLK_NAME) = bit_len.idx; 03413 } 03414 } 03415 03416 # if defined(_TARGET_DOUBLE_ALIGN) 03417 03418 if (ATT_DALIGN_ME(CURR_BLK_NAME)) { 03419 03420 /* This structure has been daligned. Make sure the total */ 03421 /* length is a double length, so that elements of arrays of */ 03422 /* this structure are double aligned. */ 03423 03424 bit_len.fld = ATT_STRUCT_BIT_LEN_FLD(CURR_BLK_NAME); 03425 bit_len.idx = ATT_STRUCT_BIT_LEN_IDX(CURR_BLK_NAME); 03426 03427 align_bit_length(&bit_len, (TARGET_BITS_PER_WORD * 2)); 03428 03429 if (bit_len.fld == NO_Tbl_Idx) { 03430 ATT_STRUCT_BIT_LEN_FLD(CURR_BLK_NAME) = CN_Tbl_Idx; 03431 ATT_STRUCT_BIT_LEN_IDX(CURR_BLK_NAME) = ntr_const_tbl( 03432 bit_len.type_idx, 03433 FALSE, 03434 bit_len.constant); 03435 } 03436 else { 03437 ATT_STRUCT_BIT_LEN_FLD(CURR_BLK_NAME) = bit_len.fld; 03438 ATT_STRUCT_BIT_LEN_IDX(CURR_BLK_NAME) = bit_len.idx; 03439 } 03440 } 03441 # endif 03442 03443 } 03444 03445 /* Note that no Attr entry is created for the label (if any) on an END */ 03446 /* TYPE statement here because check_for_dup_derived_type_lbl in */ 03447 /* p_driver.c makes sure that the label on the END TYPE statement does */ 03448 /* not duplicate any other label in the derived type and creates the Attr */ 03449 /* entry for the label. */ 03450 03451 03452 if (cif_flags & MISC_RECS) { 03453 cif_stmt_type_rec(TRUE, CIF_End_Type_Stmt, statement_number); 03454 } 03455 03456 POP_BLK_STK; 03457 03458 TRACE (Func_Exit, "end_type_blk", NULL); 03459 03460 return; 03461 03462 } /* end_type_blk */ 03463 03464 03465 /******************************************************************************\ 03466 |* *| 03467 |* Description: *| 03468 |* Perform tasks that must be done at the end of a loop. This *| 03469 |* procedure is called by both end_do_blk and end_labeled_do. *| 03470 |* *| 03471 |* Input parameters: *| 03472 |* NONE *| 03473 |* *| 03474 |* Output parameters: *| 03475 |* NONE *| 03476 |* *| 03477 |* Returns: *| 03478 |* NONE *| 03479 |* *| 03480 \******************************************************************************/ 03481 03482 static void loop_end_processing() 03483 03484 { 03485 int attr_idx; 03486 int ir_idx; 03487 int save_curr_stmt_sh_idx; 03488 int sh_idx; 03489 03490 # if defined(GENERATE_WHIRL) 03491 int blk_idx; 03492 # endif 03493 03494 03495 TRACE (Func_Entry, "loop_end_processing", NULL); 03496 03497 03498 # if defined(GENERATE_WHIRL) 03499 03500 /* If the current loop is in a loop nest preceded by a BLOCKABLE directive,*/ 03501 /* make sure all the loops in the DO-variable list of the directive are */ 03502 /* accounted for. This means if this is the first loop ending, the value */ 03503 /* of BLK_BLOCKABLE_NUM_LCVS in the current Block Stack entry had better */ 03504 /* 1. If not, issue an error, and clear all knowledge that the loop nest */ 03505 /* was subject to a BLOCKABLE directive so that no other processing will */ 03506 /* take place. */ 03507 03508 if (BLK_BLOCKABLE_NUM_LCVS(blk_stk_idx) == 1) { 03509 03510 for (blk_idx = blk_stk_idx; blk_idx > 1; --blk_idx) { 03511 03512 if (BLK_BLOCKABLE_DIR_SH_IDX(blk_idx) != NULL_IDX) { 03513 BLK_BLOCKABLE_NEST_OK(blk_idx) = TRUE; 03514 break; 03515 } 03516 } 03517 } 03518 else if (BLK_BLOCKABLE_NUM_LCVS(blk_stk_idx) > 1) { 03519 03520 for (blk_idx = blk_stk_idx; blk_idx > 1; --blk_idx) { 03521 03522 if (BLK_BLOCKABLE_DIR_SH_IDX(blk_idx) != NULL_IDX) { 03523 break; 03524 } 03525 } 03526 03527 if (! BLK_BLOCKABLE_NEST_OK(blk_idx)) { 03528 PRINTMSG(stmt_start_line, 1389, Error, 0); 03529 03530 for (blk_idx = blk_stk_idx; blk_idx > 1; --blk_idx) { 03531 BLK_BLOCKABLE_NUM_LCVS(blk_idx) = 0; 03532 03533 if (BLK_BLOCKABLE_DIR_SH_IDX(blk_idx) != NULL_IDX) { 03534 SH_ERR_FLG(BLK_BLOCKABLE_DIR_SH_IDX(blk_idx)) = TRUE; 03535 BLK_BLOCKABLE_DIR_SH_IDX(blk_idx) = NULL_IDX; 03536 break; 03537 } 03538 } 03539 } 03540 } 03541 03542 # endif 03543 03544 03545 /* If we're generating the Loop Definition record, output a */ 03546 /* Statement_Num_Stmt SH because we need to put the statement number of */ 03547 /* loop ending statement in the Loop Definition record for Apprentice's */ 03548 /* use. */ 03549 /* SLEAZY TRICK ALERT!! */ 03550 /* The statement number is stored in the SH_PARENT_BLK_IDX field. */ 03551 /* */ 03552 /* If the statement is labeled and it's not an END DO stmt, it has been */ 03553 /* completely processed by the time we get here which means its EOS has */ 03554 /* been eaten which means statement_number has been incremented already. */ 03555 /* If the loop-ending stmt is an END DO, this procedure is called before */ 03556 /* the EOS is eaten, so the current statement_number can be used. */ 03557 /* As this code stands right now, the Statement_Num SH will be inserted */ 03558 /* between the statement's SH and its Label_Def SH. If proves to be a */ 03559 /* problem, then insert code to search back to find the Label_Def SH and */ 03560 /* insert the Statement_Num SH ahead of it. */ 03561 /* We also use the Statement_Num_Stmt SH to hold the position of the very */ 03562 /* last character of the DO loop (used in the Loop Definition record). */ 03563 03564 if (cif_flags & MISC_RECS) { 03565 save_curr_stmt_sh_idx = 0; 03566 03567 if (SH_COMPILER_GEN(curr_stmt_sh_idx)) { 03568 03569 /* The current SH is compiler-generated so it means the loop-ending */ 03570 /* statement is labeled and that compiler-generated SH's were */ 03571 /* produced to represent the current statement. We need to back up */ 03572 /* to the statement's actual SH and insert the Statement_Num SH */ 03573 /* ahead of it. Otherwise, the Statement_Num SH would get buried */ 03574 /* among the compiler-generated SH's and possibly get unlinked */ 03575 /* (tossed) later. */ 03576 03577 sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 03578 03579 while (! SH_LABELED(sh_idx)) { 03580 sh_idx = SH_PREV_IDX(sh_idx); 03581 } 03582 03583 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 03584 curr_stmt_sh_idx = sh_idx; 03585 } 03586 03587 if (SH_LABELED(curr_stmt_sh_idx) && stmt_type != End_Do_Stmt) { 03588 gen_sh(Before, Statement_Num_Stmt, stmt_end_line, stmt_end_col, 03589 FALSE, FALSE, TRUE); 03590 SH_PARENT_BLK_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = 03591 statement_number - 1; 03592 } 03593 else { 03594 gen_sh(Before, Statement_Num_Stmt, LA_CH_LINE, LA_CH_COLUMN - 1, 03595 FALSE, FALSE, TRUE); 03596 SH_PARENT_BLK_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = statement_number; 03597 } 03598 03599 if (save_curr_stmt_sh_idx != 0) { 03600 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 03601 } 03602 } 03603 03604 03605 /* If a CYCLE exists that references the name of the current loop, */ 03606 /* generate a CONTINUE statement to define the CYCLE point label. */ 03607 /* Note: Obtaining the label would be quicker (but at the expense of a */ 03608 /* larger Block Stack entry) if the label was generated and its index */ 03609 /* saved in the Block Stack entry when the CYCLE statement is parsed. */ 03610 /* Another alternative is to just always generate the label (don't even */ 03611 /* have a flag in the Block Stack entry). */ 03612 03613 if (BLK_CYCLE_STMT(blk_stk_idx)) { 03614 attr_idx = gen_loop_lbl_name(blk_stk_idx, Cycle_Lbl); 03615 03616 gen_sh(After, Continue_Stmt, stmt_start_line, stmt_start_col, 03617 FALSE, TRUE, TRUE); 03618 03619 NTR_IR_TBL(ir_idx); 03620 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 03621 IR_OPR(ir_idx) = Label_Opr; 03622 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 03623 IR_LINE_NUM(ir_idx) = stmt_start_line; 03624 IR_COL_NUM(ir_idx) = stmt_start_col; 03625 IR_LINE_NUM_L(ir_idx) = stmt_start_line; 03626 IR_COL_NUM_L(ir_idx) = stmt_start_col; 03627 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 03628 IR_IDX_L(ir_idx) = attr_idx; 03629 03630 AT_DEFINED(attr_idx) = TRUE; 03631 AT_DEF_LINE(attr_idx) = stmt_start_line; 03632 AT_REFERENCED(attr_idx) = Referenced; 03633 ATL_DEF_STMT_IDX(attr_idx) = curr_stmt_sh_idx; 03634 ATL_CYCLE_LBL(attr_idx) = TRUE; 03635 } 03636 03637 03638 # ifdef _HIGH_LEVEL_DO_LOOP_FORM 03639 03640 gen_sh(After, Continue_Stmt, stmt_start_line, stmt_start_col, 03641 FALSE, /* Set SH_ERR_FLAG to this value. */ 03642 FALSE, /* Not labeled. */ 03643 TRUE); /* Compiler-generated. */ 03644 03645 NTR_IR_TBL(ir_idx); 03646 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 03647 SH_LOOP_END(curr_stmt_sh_idx) = TRUE; 03648 IR_OPR(ir_idx) = Loop_End_Opr; 03649 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 03650 IR_LINE_NUM(ir_idx) = stmt_start_line; 03651 IR_COL_NUM(ir_idx) = stmt_start_col; 03652 03653 SH_LOOP_END(curr_stmt_sh_idx) = TRUE; 03654 SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX; 03655 03656 IR_FLD_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = SH_Tbl_Idx; 03657 IR_IDX_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = curr_stmt_sh_idx; 03658 03659 03660 # endif 03661 03662 03663 # if defined(GENERATE_WHIRL) 03664 03665 /* If the current loop is in a loop nest preceded by an INTERCHANGE, */ 03666 /* PDO, PARALLELDO, or DOACROSS directive, check to see if the current */ 03667 /* loop ending is perfectly nested in its containing loop. */ 03668 03669 if (BLK_INTERCHANGE_NUM_LCVS(blk_stk_idx) > 1 || 03670 BLK_DIR_NEST_CHECK_NUM_LCVS(blk_stk_idx) > 1) { 03671 check_loop_bottom_nesting(); 03672 } 03673 03674 # endif 03675 03676 03677 /* If an EXIT exists that references the name of the current loop, */ 03678 /* generate a CONTINUE statement to define the EXIT point label. */ 03679 /* Note: Obtaining the label would be quicker (but at the expense of a */ 03680 /* larger Block Stack entry) if the label was generated and its index */ 03681 /* saved in the Block Stack entry when the EXIT statement is parsed. */ 03682 /* Another alternative is to just always generate the label (don't even */ 03683 /* have a flag in the Block Stack entry). */ 03684 03685 if (BLK_EXIT_STMT(blk_stk_idx)) { 03686 attr_idx = gen_loop_lbl_name(blk_stk_idx, Exit_Lbl); 03687 03688 gen_sh(After, Continue_Stmt, stmt_start_line, stmt_start_col, 03689 FALSE, TRUE, TRUE); 03690 03691 #ifndef _HIGH_LEVEL_DO_LOOP_FORM 03692 03693 /* (For a high level iterative DO IR form, these links are on the */ 03694 /* Loop_End SH). */ 03695 03696 SH_LOOP_END(curr_stmt_sh_idx) = TRUE; 03697 SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX; 03698 03699 IR_FLD_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = SH_Tbl_Idx; 03700 IR_IDX_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = curr_stmt_sh_idx; 03701 03702 #endif 03703 03704 NTR_IR_TBL(ir_idx); 03705 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 03706 IR_OPR(ir_idx) = Label_Opr; 03707 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 03708 IR_LINE_NUM(ir_idx) = stmt_start_line; 03709 IR_COL_NUM(ir_idx) = stmt_start_col; 03710 IR_LINE_NUM_L(ir_idx) = stmt_start_line; 03711 IR_COL_NUM_L(ir_idx) = stmt_start_col; 03712 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 03713 IR_IDX_L(ir_idx) = attr_idx; 03714 03715 AT_DEFINED(attr_idx) = TRUE; 03716 AT_DEF_LINE(attr_idx) = stmt_start_line; 03717 AT_REFERENCED(attr_idx) = Referenced; 03718 ATL_DEF_STMT_IDX(attr_idx) = curr_stmt_sh_idx; 03719 } 03720 03721 03722 /* When generating IR for low-level DO loop forms, always generate a */ 03723 /* CONTINUE statement to define the end of the loop (even if the loop is */ 03724 /* an infinite DO or "one-trip" DO loops were specified). We need this */ 03725 /* SH to find the actual end of the loop because if a loop ends with an */ 03726 /* executable stmt, that stmt may get expanded into multiple SH's. This */ 03727 /* CONTINUE statement can also be used to define the branch-around label. */ 03728 03729 # ifndef _HIGH_LEVEL_DO_LOOP_FORM 03730 03731 gen_sh(After, Continue_Stmt, stmt_start_line, stmt_start_col, 03732 FALSE, /* Set SH_ERR_FLAG to this value. */ 03733 TRUE, /* Labeled. */ 03734 TRUE); /* Compiler-generated. */ 03735 03736 if (BLK_DO_TYPE(blk_stk_idx) != Infinite_Loop) { 03737 NTR_IR_TBL(ir_idx); 03738 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 03739 IR_OPR(ir_idx) = Label_Opr; 03740 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 03741 IR_LINE_NUM(ir_idx) = stmt_start_line; 03742 IR_COL_NUM(ir_idx) = stmt_start_col; 03743 IR_LINE_NUM_L(ir_idx) = stmt_start_line; 03744 IR_COL_NUM_L(ir_idx) = stmt_start_col; 03745 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 03746 IR_IDX_L(ir_idx) = BLK_SKIP_LBL_IDX(blk_stk_idx); 03747 AT_DEFINED(BLK_SKIP_LBL_IDX(blk_stk_idx)) = TRUE; 03748 AT_DEF_LINE(BLK_SKIP_LBL_IDX(blk_stk_idx)) = stmt_start_line; 03749 AT_REFERENCED(BLK_SKIP_LBL_IDX(blk_stk_idx)) = Referenced; 03750 ATL_DEF_STMT_IDX(BLK_SKIP_LBL_IDX(blk_stk_idx)) = curr_stmt_sh_idx; 03751 } 03752 03753 if (! BLK_EXIT_STMT(blk_stk_idx)) { 03754 SH_LOOP_END(curr_stmt_sh_idx) = TRUE; 03755 SH_PARENT_BLK_IDX(curr_stmt_sh_idx) = CURR_BLK_FIRST_SH_IDX; 03756 03757 IR_FLD_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = SH_Tbl_Idx; 03758 IR_IDX_L(SH_IR_IDX(CURR_BLK_FIRST_SH_IDX)) = curr_stmt_sh_idx; 03759 } 03760 03761 # endif 03762 03763 03764 TRACE (Func_Exit, "loop_end_processing", NULL); 03765 03766 return; 03767 03768 } /* loop_end_processing */ 03769 03770 03771 /******************************************************************************\ 03772 |* *| 03773 |* Description: *| 03774 |* Called if bad block is found on the block stack. *| 03775 |* Issues internal error message and aborts compilation. *| 03776 |* *| 03777 |* Input parameters: *| 03778 |* err_call => Boolean - TRUE if this is called from an error situation. *| 03779 |* This means the compiler is trying to clean up the block *| 03780 |* stack and do error recovery. *| 03781 |* *| 03782 |* Output parameters: *| 03783 |* NONE *| 03784 |* *| 03785 |* Returns: *| 03786 |* NONE *| 03787 |* *| 03788 \******************************************************************************/ 03789 03790 static void end_internal_err(boolean err_call) 03791 03792 { 03793 TRACE (Func_Entry, "end_internal_err", NULL); 03794 03795 PRINTMSG(stmt_start_line, 160, Internal, stmt_start_col); 03796 03797 TRACE (Func_Exit, "end_internal_err", NULL); 03798 03799 return; 03800 03801 } /* end_internal_err */ 03802 03803 03804 /******************************************************************************\ 03805 |* *| 03806 |* Description: *| 03807 |* Sets char ptrs for issuing meaningful end block error msgs. *| 03808 |* *| 03809 |* Input parameters: *| 03810 |* NONE *| 03811 |* *| 03812 |* Output parameters: *| 03813 |* NONE *| 03814 |* *| 03815 |* Returns: *| 03816 |* NONE *| 03817 |* *| 03818 \******************************************************************************/ 03819 03820 static char *blk_desc_str(int blk_idx) 03821 { 03822 char *blk_stmt_str; 03823 int idx; 03824 03825 TRACE (Func_Entry, "blk_desc_str", NULL); 03826 03827 /* The cases in the following switch statement are in the same order as */ 03828 /* the values in blk_cntxt_values in p_globals.h. */ 03829 03830 switch (BLK_TYPE(blk_idx)) { 03831 03832 case Unknown_Blk: 03833 PRINTMSG(stmt_start_line, 160, Internal, stmt_start_col); 03834 break; 03835 03836 case Blockdata_Blk: 03837 blk_stmt_str = "BLOCKDATA"; 03838 break; 03839 03840 case Module_Blk: 03841 blk_stmt_str = "MODULE"; 03842 break; 03843 03844 case Program_Blk: 03845 blk_stmt_str = "PROGRAM"; 03846 break; 03847 03848 case Function_Blk: 03849 blk_stmt_str = "FUNCTION"; 03850 break; 03851 03852 case Subroutine_Blk: 03853 blk_stmt_str = "SUBROUTINE"; 03854 break; 03855 03856 case Internal_Blk: 03857 case Module_Proc_Blk: 03858 case Interface_Body_Blk: 03859 blk_stmt_str = (ATP_PGM_UNIT(BLK_NAME(blk_idx)) == Function) ? 03860 "FUNCTION" : "SUBROUTINE"; 03861 break; 03862 03863 case Do_Blk: 03864 blk_stmt_str = "DO"; 03865 break; 03866 03867 case Forall_Blk: 03868 blk_stmt_str = "FORALL"; 03869 break; 03870 03871 case If_Blk: 03872 case If_Then_Blk: 03873 case If_Else_If_Blk: 03874 case If_Else_Blk: 03875 blk_stmt_str = "IF"; 03876 break; 03877 03878 case Select_Blk: 03879 case Case_Blk: 03880 blk_stmt_str = "SELECT CASE"; 03881 break; 03882 03883 case Where_Then_Blk: 03884 case Where_Else_Blk: 03885 case Where_Else_Mask_Blk: 03886 blk_stmt_str = "WHERE"; 03887 break; 03888 03889 case Parallel_Blk: 03890 blk_stmt_str = "PARALLEL"; 03891 break; 03892 03893 case Doall_Blk: 03894 blk_stmt_str = "DOALL"; 03895 break; 03896 03897 case Do_Parallel_Blk: 03898 blk_stmt_str = "DO PARALLEL"; 03899 break; 03900 03901 case Guard_Blk: 03902 blk_stmt_str = "GUARD"; 03903 break; 03904 03905 case Parallel_Case_Blk: 03906 blk_stmt_str = "CASE"; 03907 break; 03908 03909 case Wait_Blk: 03910 blk_stmt_str = "WAIT"; 03911 break; 03912 03913 case SGI_Doacross_Blk: 03914 blk_stmt_str = "DOACROSS"; 03915 break; 03916 03917 case SGI_Psection_Blk: 03918 blk_stmt_str = "PSECTION"; 03919 break; 03920 03921 case SGI_Section_Blk: 03922 blk_stmt_str = "SECTION"; 03923 break; 03924 03925 case SGI_Pdo_Blk: 03926 blk_stmt_str = "PDO"; 03927 break; 03928 03929 case SGI_Parallel_Do_Blk: 03930 blk_stmt_str = "PARALLEL DO"; 03931 break; 03932 03933 case SGI_Parallel_Blk: 03934 blk_stmt_str = "PARALLEL"; 03935 break; 03936 03937 case SGI_Critical_Section_Blk: 03938 blk_stmt_str = "CRITICAL SECTION"; 03939 break; 03940 03941 case SGI_Single_Process_Blk: 03942 blk_stmt_str = "SINGLE PROCESS"; 03943 break; 03944 03945 case SGI_Region_Blk: 03946 blk_stmt_str = "REGION"; 03947 break; 03948 03949 case Open_Mp_Parallel_Blk: 03950 blk_stmt_str = "!$OMP PARALLEL"; 03951 break; 03952 03953 case Open_Mp_Do_Blk: 03954 blk_stmt_str = "!$OMP DO"; 03955 break; 03956 03957 case Open_Mp_Parallel_Sections_Blk: 03958 blk_stmt_str = "!$OMP PARALLEL SECTIONS"; 03959 break; 03960 03961 case Open_Mp_Sections_Blk: 03962 blk_stmt_str = "!$OMP SECTIONS"; 03963 break; 03964 03965 case Open_Mp_Section_Blk: 03966 blk_stmt_str = "!$OMP SECTION"; 03967 break; 03968 03969 case Open_Mp_Single_Blk: 03970 blk_stmt_str = "!$OMP SINGLE"; 03971 break; 03972 03973 case Open_Mp_Parallel_Do_Blk: 03974 blk_stmt_str = "!$OMP PARALLEL DO"; 03975 break; 03976 03977 case Open_Mp_Master_Blk: 03978 blk_stmt_str = "!$OMP MASTER"; 03979 break; 03980 03981 case Open_Mp_Critical_Blk: 03982 blk_stmt_str = "!$OMP CRITICAL"; 03983 break; 03984 03985 case Open_Mp_Ordered_Blk: 03986 blk_stmt_str = "!$OMP ORDERED"; 03987 break; 03988 03989 case Open_Mp_Parallel_Workshare_Blk: 03990 blk_stmt_str = "!$OMP PARALLEL WORKSHARE"; 03991 break; 03992 03993 case Open_Mp_Workshare_Blk: 03994 blk_stmt_str = "!$OMP WORKSHARE"; 03995 break; 03996 03997 case Contains_Blk: 03998 for (idx = blk_idx; 03999 idx > NULL_IDX && (BLK_TYPE(idx) > Blockdata_Blk); 04000 idx--); 04001 04002 /* First entry will always be at least $MAIN */ 04003 04004 blk_stmt_str = blk_desc_str(idx); 04005 break; 04006 04007 case Interface_Blk: 04008 blk_stmt_str = "INTERFACE"; 04009 break; 04010 04011 case Derived_Type_Blk: 04012 blk_stmt_str = "TYPE"; 04013 break; 04014 04015 } /* End switch */ 04016 04017 TRACE (Func_Exit, "blk_desc_str", NULL); 04018 return(blk_stmt_str); 04019 04020 } /* blk_desc_str */ 04021 04022 04023 /******************************************************************************\ 04024 |* *| 04025 |* Description: *| 04026 |* This issues the error message if there is a block matching error. *| 04027 |* *| 04028 |* Input parameters: *| 04029 |* NONE *| 04030 |* *| 04031 |* Output parameters: *| 04032 |* NONE *| 04033 |* *| 04034 |* Returns: *| 04035 |* NOTHING *| 04036 |* *| 04037 \******************************************************************************/ 04038 04039 int blk_match_err(blk_cntxt_type blk_type, 04040 boolean has_name, 04041 boolean all_match) 04042 04043 { 04044 int blk_idx; 04045 boolean name_err = FALSE; 04046 pgm_unit_type pgm_type; 04047 04048 04049 TRACE (Func_Entry, "blk_match_err", NULL); 04050 04051 if (stmt_type == End_Subroutine_Stmt || stmt_type == End_Function_Stmt) { 04052 04053 /* Need to search for Internal_Blk, Module_Proc_Blk, Interface_Body_Blk */ 04054 /* Subroutine_Blk or Function_Blk */ 04055 04056 pgm_type = (stmt_type == End_Function_Stmt) ? Function : Subroutine; 04057 04058 /* Check to see if this matchs the first block. If it does, then only */ 04059 /* the name is in error. */ 04060 04061 name_err = (STMT_LEGAL_IN_BLK(stmt_type, CURR_BLK) && 04062 ATP_PGM_UNIT(CURR_BLK_NAME) == pgm_type); 04063 04064 for (blk_idx = blk_stk_idx; blk_idx > NULL_IDX; blk_idx--) { 04065 04066 if (STMT_LEGAL_IN_BLK(stmt_type, BLK_TYPE(blk_idx)) && 04067 ATP_PGM_UNIT(BLK_NAME(blk_idx)) == pgm_type) { 04068 04069 if (!has_name || 04070 (compare_names(TOKEN_ID(token).words, 04071 TOKEN_LEN(token), 04072 AT_OBJ_NAME_LONG(BLK_NAME(blk_idx)), 04073 AT_NAME_LEN(BLK_NAME(blk_idx))) == 0)) { 04074 break; /* Found the match */ 04075 } 04076 } 04077 } 04078 } 04079 else { 04080 name_err = STMT_LEGAL_IN_BLK(stmt_type, CURR_BLK); 04081 04082 for (blk_idx = blk_stk_idx; blk_idx > NULL_IDX; blk_idx--) { 04083 04084 if (STMT_LEGAL_IN_BLK(stmt_type, BLK_TYPE(blk_idx))) { 04085 04086 if (stmt_type == Else_If_Stmt || stmt_type == Else_Stmt || 04087 stmt_type == Case_Stmt) { 04088 name_err = FALSE; 04089 04090 if (has_name) { 04091 04092 if (BLK_NAME(blk_idx) == NULL_IDX) { 04093 PRINTMSG(TOKEN_LINE(token), 285, Error, 04094 TOKEN_COLUMN(token), 04095 blk_desc_str(blk_idx), 04096 stmt_type_str[stmt_type]); 04097 } 04098 else if (compare_names(TOKEN_ID(token).words, 04099 TOKEN_LEN(token), 04100 AT_OBJ_NAME_LONG(BLK_NAME(blk_idx)), 04101 AT_NAME_LEN(BLK_NAME(blk_idx))) != 0) { 04102 PRINTMSG(TOKEN_LINE(token), 284, Error, 04103 TOKEN_COLUMN(token), 04104 blk_desc_str(blk_idx), 04105 AT_OBJ_NAME_PTR(BLK_NAME(blk_idx)), 04106 stmt_type_str[stmt_type]); 04107 } 04108 } 04109 04110 break; 04111 } 04112 else { 04113 04114 if (!has_name) { 04115 04116 /* If all_match is set, then if the block has a name, the */ 04117 /* thing that's looking for the match must have the same */ 04118 /* name. */ 04119 04120 if (!all_match || BLK_NAME(blk_idx) == NULL_IDX) { 04121 break; 04122 } 04123 } 04124 else if (BLK_NAME(blk_idx) != NULL_IDX && 04125 (compare_names(TOKEN_ID(token).words, 04126 TOKEN_LEN(token), 04127 AT_OBJ_NAME_LONG(BLK_NAME(blk_idx)), 04128 AT_NAME_LEN(BLK_NAME(blk_idx))) == 0)) { 04129 break; 04130 } 04131 } 04132 } 04133 } 04134 } 04135 04136 if (blk_idx == NULL_IDX && name_err) { 04137 04138 /* Didn't find a match on the block, so if the statement fits in the */ 04139 /* current block, assume there is just a name error and issue it. */ 04140 04141 /* Possible combinations: */ 04142 /* CURR_BLK_NAME has_name stmt_type */ 04143 /* NULL_IDX TRUE all stmts */ 04144 /* NULL_IDX FALSE Won't be here. This is a match. */ 04145 /* have name TRUE Must be name mismatch */ 04146 /* have name FALSE Only err for END of IF, DO, SELCT */ 04147 04148 switch (stmt_type) { 04149 case End_If_Stmt: 04150 case End_Do_Stmt: 04151 case End_Select_Stmt: 04152 case Else_If_Stmt: 04153 case Else_Stmt: 04154 case Then_Stmt: 04155 case Case_Stmt: 04156 case End_Forall_Stmt: 04157 case Else_Where_Stmt: 04158 case Else_Where_Mask_Stmt: 04159 case End_Where_Stmt: 04160 if (CURR_BLK_NAME == NULL_IDX) { 04161 PRINTMSG(TOKEN_LINE(token), 285, Error, TOKEN_COLUMN(token), 04162 blk_desc_str(blk_stk_idx), stmt_type_str[stmt_type]); 04163 } 04164 else { 04165 PRINTMSG((has_name) ? TOKEN_LINE(token) : stmt_start_line, 04166 284, Error, 04167 (has_name) ? TOKEN_COLUMN(token) : stmt_start_col, 04168 blk_desc_str(blk_stk_idx), 04169 AT_OBJ_NAME_PTR(CURR_BLK_NAME), 04170 stmt_type_str[stmt_type]); 04171 } 04172 break; 04173 04174 case End_Blockdata_Stmt: 04175 case End_Program_Stmt: 04176 if (CURR_BLK_NAME == NULL_IDX) { 04177 04178 if (stmt_type == End_Blockdata_Stmt) { /* No BLOCKDATA name */ 04179 PRINTMSG(TOKEN_LINE(token), 158, Error, 04180 TOKEN_COLUMN(token)); 04181 } 04182 else { /* No PROGRAM statement */ 04183 PRINTMSG(TOKEN_LINE(token), 40, Error, 04184 TOKEN_COLUMN(token)); 04185 } 04186 04187 /* We've found an END BLOCK DATA or (more likely) END PROGRAM */ 04188 /* stmt that has no matching BLOCK DATA or (more likely) */ 04189 /* PROGRAM stmt. blk_match_err is going to call the */ 04190 /* appropriate end-of-program unit routine which will produce */ 04191 /* the CIF End Scope and End Unit records. They will go in */ 04192 /* the temporary CIF. When control returns to p_driver.c, it */ 04193 /* will think a new program unit is beginning so it will call */ 04194 /* cif_unit_rec which will produce the Unit record then copy */ 04195 /* the temporary CIF to the actual CIF. This means that the */ 04196 /* End Scope and End Unit will get copied to the actual CIF. */ 04197 /* THEN p_driver.c will call cif_scope_rec to issue the Begin */ 04198 /* Scope record, which will, of course, now be out of order. */ 04199 /* (Not to mention that the end-of-program unit routine has */ 04200 /* reset blk_stk_idx to 0 which means the CIF routines will */ 04201 /* be accessing the 0th (bad) Block Stack entry. To recover */ 04202 /* from this weird case, set cif_pgm_unit_error_recovery to */ 04203 /* TRUE here. When cif_unit_rec sees it is TRUE, it won't */ 04204 /* copy the temporary CIF to the actual CIF. When p_driver.c */ 04205 /* sees its TRUE, it'll produce the Begin Scope record, THEN */ 04206 /* copy the temporary CIF to the actual CIF. */ 04207 04208 cif_pgm_unit_error_recovery = TRUE; 04209 04210 break; 04211 } 04212 04213 /* Break intentionally not here. Should fall through. */ 04214 04215 case End_Module_Stmt: 04216 case End_Function_Stmt: 04217 case End_Subroutine_Stmt: 04218 case End_Interface_Stmt: 04219 case End_Type_Stmt: /* These must have a CURR_BLK_NAME */ 04220 PRINTMSG(TOKEN_LINE(token), 283, Error, TOKEN_COLUMN(token), 04221 stmt_type_str[stmt_type], 04222 blk_desc_str(blk_stk_idx), 04223 AT_OBJ_NAME_PTR(CURR_BLK_NAME)); 04224 break; 04225 # ifdef _DEBUG 04226 default: 04227 PRINTMSG(stmt_start_line, 179, Internal, 04228 stmt_start_col, "blk_match_err"); 04229 break; 04230 # endif 04231 } /* End switch */ 04232 SH_ERR_FLG(curr_stmt_sh_idx) = TRUE; 04233 blk_idx = blk_stk_idx; 04234 } 04235 else if ((stmt_type == Else_Stmt && CURR_BLK == If_Else_Blk) || 04236 (stmt_type == Else_Where_Stmt && CURR_BLK == Where_Else_Blk) ) { 04237 04238 /* An IF construct may contain only a single ELSE block and a WHERE */ 04239 /* construct may contain only a single ELSEWHERE block. */ 04240 04241 PRINTMSG(stmt_start_line, 43, Error, stmt_start_col, 04242 stmt_type_str[stmt_type], blk_desc_str(blk_stk_idx)); 04243 } 04244 else if (stmt_type == Else_If_Stmt && CURR_BLK == If_Else_Blk) { 04245 04246 /* An ELSE IF block must not follow an ELSE block. */ 04247 04248 PRINTMSG(stmt_start_line, 1158, Error, stmt_start_col); 04249 } 04250 else if (stmt_type == Else_Where_Mask_Stmt && CURR_BLK == Where_Else_Blk) { 04251 04252 /* An ELSE WHERE (mask) block must not follow an ELSE WHERE block. */ 04253 04254 PRINTMSG(stmt_start_line, 1609, Error, stmt_start_col); 04255 } 04256 else if (blk_idx == NULL_IDX) { 04257 04258 /* Push the blk_type on the stack, so blk_desc_str can describe it for */ 04259 /* the error message. Then POP it. It is only needed for the message. */ 04260 04261 PUSH_BLK_STK(blk_type); 04262 PRINTMSG(stmt_start_line, 289, Error, stmt_start_col, 04263 stmt_type_str[stmt_type], blk_desc_str(blk_stk_idx)); 04264 POP_BLK_STK; 04265 04266 SH_ERR_FLG(curr_stmt_sh_idx) = TRUE; 04267 } 04268 else { /* Have a match, but not to the current block. */ 04269 04270 pop_and_err_blk_stk(blk_idx, (BLK_TYPE(blk_idx) <= Interface_Body_Blk)); 04271 04272 if (BLK_TYPE(blk_idx) > Interface_Body_Blk && 04273 BLK_TYPE(blk_idx) != Select_Blk) { 04274 blk_idx = move_blk_to_end(blk_idx); 04275 } 04276 } 04277 04278 TRACE (Func_Exit, "blk_match_err", NULL); 04279 04280 return(blk_idx); 04281 04282 } /* blk_match_err */ 04283 04284 04285 /******************************************************************************\ 04286 |* *| 04287 |* Description: *| 04288 |* Go through the blk_stk until match_idx is reached. For each blk, *| 04289 |* passed up; issue a missing end err if the err is not already set; *| 04290 |* call the appropriate end routine for the block, and then pop it. *| 04291 |* When the matched item is reached, just leave it and don't pop it. *| 04292 |* It is the responsibility of the calling routine to handle the *| 04293 |* match block. *| 04294 |* *| 04295 |* Input parameters: *| 04296 |* NONE *| 04297 |* *| 04298 |* Output parameters: *| 04299 |* NONE *| 04300 |* *| 04301 |* Returns: *| 04302 |* TRUE - if error was issued, else FALSE *| 04303 |* *| 04304 \******************************************************************************/ 04305 04306 boolean pop_and_err_blk_stk(int match_idx, 04307 boolean pop_the_blks) 04308 04309 { 04310 int blk_idx; 04311 int blk_line_idx; 04312 boolean issued_error = FALSE; 04313 boolean save_sh_err_flg; 04314 int sh_idx; 04315 04316 04317 TRACE (Func_Entry, "pop_and_err_blk_stk", NULL); 04318 04319 blk_idx = blk_stk_idx; 04320 04321 while (blk_idx > match_idx) { 04322 04323 if (BLK_TYPE(blk_idx) == Do_Parallel_Blk || 04324 BLK_TYPE(blk_idx) == SGI_Pdo_Blk || 04325 BLK_TYPE(blk_idx) == Open_Mp_Do_Blk || 04326 BLK_TYPE(blk_idx) == Open_Mp_Parallel_Do_Blk) { 04327 04328 if (BLK_TYPE(blk_idx) == Do_Parallel_Blk) { 04329 CLEAR_DIRECTIVE_STATE(Do_Parallel_Region); 04330 } 04331 else if (BLK_TYPE(blk_idx) == SGI_Pdo_Blk) { 04332 CLEAR_DIRECTIVE_STATE(Pdo_Region); 04333 } 04334 else if (BLK_TYPE(blk_idx) == Open_Mp_Do_Blk) { 04335 CLEAR_DIRECTIVE_STATE(Open_Mp_Do_Region); 04336 } 04337 else if (BLK_TYPE(blk_idx) == Open_Mp_Parallel_Do_Blk) { 04338 CLEAR_DIRECTIVE_STATE(Open_Mp_Parallel_Do_Region); 04339 } 04340 04341 move_blk_to_end(blk_idx); 04342 POP_BLK_STK; 04343 blk_idx--; 04344 continue; 04345 } 04346 04347 /* Issue missing end msg if it doesn't already have a msg issued for */ 04348 /* it. (blk_err=TRUE). Also, don't issue msgs for contains blocks. */ 04349 04350 if (!BLK_ERR(blk_idx) && 04351 BLK_TYPE(blk_idx) != Contains_Blk) { 04352 04353 if (BLK_TYPE(blk_idx) != Program_Blk) { 04354 04355 save_sh_err_flg = SH_ERR_FLG(curr_stmt_sh_idx); 04356 04357 /* Missing termination or END statement. */ 04358 04359 if (BLK_TYPE(blk_idx) == Do_Blk) { 04360 04361 if (stmt_label_idx == NULL_IDX || 04362 stmt_label_idx != BLK_LABEL(blk_idx)) { 04363 PRINTMSG(BLK_DEF_LINE(blk_idx), 288, Error, 04364 BLK_DEF_COLUMN(blk_idx)); 04365 issued_error = TRUE; 04366 SH_ERR_FLG(BLK_FIRST_SH_IDX(blk_idx)) = TRUE; 04367 } 04368 } 04369 else if (BLK_TYPE(blk_idx) == Parallel_Blk) { 04370 PRINTMSG(BLK_DEF_LINE(blk_idx), 1217, Error, 04371 BLK_DEF_COLUMN(blk_idx), 04372 "END PARALLEL","PARALLEL"); 04373 issued_error = TRUE; 04374 SH_ERR_FLG(BLK_FIRST_SH_IDX(blk_idx)) = TRUE; 04375 } 04376 else if (BLK_TYPE(blk_idx) == Guard_Blk) { 04377 PRINTMSG(BLK_DEF_LINE(blk_idx), 1217, Error, 04378 BLK_DEF_COLUMN(blk_idx), 04379 "END GUARD","GUARD"); 04380 issued_error = TRUE; 04381 SH_ERR_FLG(BLK_FIRST_SH_IDX(blk_idx)) = TRUE; 04382 } 04383 else if (BLK_TYPE(blk_idx) == Parallel_Case_Blk) { 04384 PRINTMSG(BLK_DEF_LINE(blk_idx), 1217, Error, 04385 BLK_DEF_COLUMN(blk_idx), 04386 "END CASE","CASE"); 04387 issued_error = TRUE; 04388 SH_ERR_FLG(BLK_FIRST_SH_IDX(blk_idx)) = TRUE; 04389 } 04390 else if (BLK_TYPE(blk_idx) == Wait_Blk) { 04391 PRINTMSG(BLK_DEF_LINE(blk_idx), 1217, Error, 04392 BLK_DEF_COLUMN(blk_idx), 04393 "SEND","WAIT"); 04394 issued_error = TRUE; 04395 SH_ERR_FLG(BLK_FIRST_SH_IDX(blk_idx)) = TRUE; 04396 } 04397 else { 04398 blk_line_idx = blk_idx; 04399 04400 if (BLK_TYPE(blk_idx) == Case_Blk) { 04401 for (; BLK_TYPE(blk_line_idx) != Select_Blk; blk_line_idx--); 04402 } 04403 else if (BLK_TYPE(blk_idx) == If_Then_Blk || 04404 BLK_TYPE(blk_idx) == If_Else_If_Blk || 04405 BLK_TYPE(blk_idx) == If_Else_Blk) { 04406 do { 04407 04408 if (BLK_TYPE(blk_line_idx) == If_Then_Blk || 04409 BLK_TYPE(blk_line_idx) == If_Else_If_Blk || 04410 BLK_TYPE(blk_line_idx) == If_Else_Blk) { 04411 BLK_ERR(blk_line_idx) = TRUE; 04412 SH_ERR_FLG(BLK_FIRST_SH_IDX(blk_line_idx)) = TRUE; 04413 } 04414 blk_line_idx--; 04415 } while (BLK_TYPE(blk_line_idx) != If_Blk); 04416 } 04417 04418 if (!BLK_ERR(blk_line_idx)) { /* Prevent duplicate errors */ 04419 PRINTMSG(BLK_DEF_LINE(blk_line_idx), 291, Error, 04420 BLK_DEF_COLUMN(blk_line_idx), 04421 blk_desc_str(blk_idx)); 04422 issued_error = TRUE; 04423 BLK_ERR(blk_line_idx) = TRUE; 04424 SH_ERR_FLG(BLK_FIRST_SH_IDX(blk_line_idx)) = TRUE; 04425 } 04426 } 04427 04428 SH_ERR_FLG(curr_stmt_sh_idx) = save_sh_err_flg; 04429 04430 } 04431 else { /* Main program unit is missing its END statement. */ 04432 04433 if (SCP_ATTR_IDX(curr_scp_idx) == glb_tbl_idx[Main_Attr_Idx]) { 04434 04435 /* This is $MAIN. Make sure this isn't just a bad end stmt */ 04436 /* that results from an earlier mess, the compiler is trying */ 04437 /* to clean up. If so, do not issue an error. */ 04438 04439 if (!AT_DCL_ERR(glb_tbl_idx[Main_Attr_Idx]) && 04440 !SCP_IN_ERR(curr_scp_idx)) { 04441 PRINTMSG(BLK_DEF_LINE(blk_idx), 293, Error, 04442 BLK_DEF_COLUMN(blk_idx)); 04443 issued_error = TRUE; 04444 } 04445 } 04446 else { 04447 PRINTMSG(BLK_DEF_LINE(blk_idx), 955, Error, 04448 BLK_DEF_COLUMN(blk_idx), 04449 AT_OBJ_NAME_PTR(CURR_BLK_NAME)); 04450 issued_error = TRUE; 04451 } 04452 04453 if (need_new_sh) { 04454 sh_idx = curr_stmt_sh_idx; 04455 curr_stmt_sh_idx = ntr_sh_tbl(); 04456 SH_NEXT_IDX(sh_idx) = curr_stmt_sh_idx; 04457 SH_PREV_IDX(curr_stmt_sh_idx) = sh_idx; 04458 } 04459 04460 SH_GLB_LINE(curr_stmt_sh_idx) = stmt_start_line; 04461 SH_COL_NUM(curr_stmt_sh_idx) = stmt_start_col; 04462 SH_STMT_TYPE(curr_stmt_sh_idx) = End_Stmt; 04463 } 04464 } 04465 04466 BLK_ERR(blk_idx) = TRUE; 04467 04468 if (pop_the_blks) { /* Call the end routine for each block to pop. */ 04469 04470 if (BLK_TYPE(blk_idx) == Case_Blk || 04471 BLK_TYPE(blk_idx) == If_Then_Blk || 04472 BLK_TYPE(blk_idx) == If_Else_If_Blk || 04473 BLK_TYPE(blk_idx) == If_Else_Blk) { 04474 (*end_blocks[BLK_TYPE(blk_idx)]) (TRUE); /* Pop 2 blocks */ 04475 blk_idx--; 04476 } 04477 else { 04478 (*end_blocks[BLK_TYPE(blk_idx)]) (TRUE); 04479 } 04480 } 04481 04482 /* Always pop the Where_Else_Blk and If_Else_Blk, if another Where_Else */ 04483 /* _Blk or If_Else_Blk follows it, to prevent multiple Else_Blks from */ 04484 /* getting on the stack. */ 04485 04486 else if (BLK_TYPE(blk_idx) == Where_Else_Blk && 04487 (stmt_type == Else_Where_Stmt || 04488 stmt_type == Else_Where_Mask_Stmt)) { 04489 move_blk_to_end(blk_idx); 04490 POP_BLK_STK; 04491 } 04492 else if (BLK_TYPE(blk_idx) == If_Else_Blk && 04493 (stmt_type == Else_Stmt || stmt_type == Else_If_Stmt)) { 04494 move_blk_to_end(blk_idx); 04495 POP_BLK_STK; 04496 } 04497 04498 blk_idx--; 04499 } /* End while */ 04500 04501 TRACE (Func_Exit, "pop_and_err_blk_stk", NULL); 04502 04503 return(issued_error); 04504 04505 } /* pop_and_err_blk_stk */ 04506 04507 04508 /******************************************************************************\ 04509 |* *| 04510 |* Description: *| 04511 |* This procedure moves a block to the end of a block stack. It's used *| 04512 |* for popping bad blocks. *| 04513 |* *| 04514 |* Input parameters: *| 04515 |* NONE *| 04516 |* *| 04517 |* Output parameters: *| 04518 |* NONE *| 04519 |* *| 04520 |* Returns: *| 04521 |* NONE *| 04522 |* *| 04523 \******************************************************************************/ 04524 04525 int move_blk_to_end(int blk_idx) 04526 04527 { 04528 int new_idx; 04529 04530 TRACE (Func_Entry, "move_blk_to_end", NULL); 04531 04532 if (blk_idx != blk_stk_idx) { 04533 04534 PUSH_BLK_STK(BLK_TYPE(blk_idx)); /* Make a spot for blk*/ 04535 blk_stk[blk_stk_idx] = blk_stk[blk_idx]; /* Copy block to end */ 04536 04537 if (BLK_TYPE(blk_idx) == Do_Blk && 04538 BLK_TYPE(blk_idx - 1) == Doall_Blk) { 04539 04540 for (new_idx = blk_idx - 1; new_idx < blk_stk_idx - 1; new_idx++) { 04541 blk_stk[new_idx] = blk_stk[new_idx + 2]; 04542 } 04543 04544 POP_BLK_STK; 04545 POP_BLK_STK; 04546 cdir_switches.doall_region = FALSE; 04547 } 04548 else { 04549 for (new_idx = blk_idx; new_idx < blk_stk_idx; new_idx++) { 04550 blk_stk[new_idx] = blk_stk[new_idx + 1]; 04551 } 04552 04553 POP_BLK_STK; 04554 } 04555 } 04556 04557 TRACE (Func_Exit, "move_blk_to_end", NULL); 04558 04559 return(blk_stk_idx); 04560 04561 } /* move_blk_to_end */ 04562 04563 /******************************************************************************\ 04564 |* *| 04565 |* Description: *| 04566 |* <description> *| 04567 |* *| 04568 |* Input parameters: *| 04569 |* NONE *| 04570 |* *| 04571 |* Output parameters: *| 04572 |* NONE *| 04573 |* *| 04574 |* Returns: *| 04575 |* NOTHING *| 04576 |* *| 04577 \******************************************************************************/ 04578 04579 void end_parallel_blk(boolean err_call) 04580 04581 { 04582 04583 TRACE (Func_Entry, "end_parallel_blk", NULL); 04584 04585 if (CURR_BLK == Do_Parallel_Blk) { 04586 /* just pop it */ 04587 POP_BLK_STK; 04588 CLEAR_DIRECTIVE_STATE(Do_Parallel_Region); 04589 } 04590 04591 if (CURR_BLK == SGI_Pdo_Blk) { 04592 /* just pop it */ 04593 POP_BLK_STK; 04594 CLEAR_DIRECTIVE_STATE(Pdo_Region); 04595 } 04596 04597 if (! err_call) { 04598 04599 if (cdir_switches.dopar_sh_idx != NULL_IDX) { 04600 PRINTMSG(SH_GLB_LINE(cdir_switches.dopar_sh_idx), 1219, Error, 04601 SH_COL_NUM(cdir_switches.dopar_sh_idx), 04602 "DO PARALLEL"); 04603 cdir_switches.dopar_sh_idx = NULL_IDX; 04604 } 04605 04606 if (STMT_CANT_BE_IN_BLK(End_Parallel_Stmt, CURR_BLK)) { 04607 blk_match_err(Parallel_Blk, FALSE, FALSE); 04608 } 04609 04610 if (CURR_BLK == Parallel_Blk) { 04611 POP_BLK_STK; 04612 } 04613 } 04614 else { 04615 POP_BLK_STK; 04616 } 04617 04618 TRACE (Func_Exit, "end_parallel_blk", NULL); 04619 04620 return; 04621 04622 } /* end_parallel_blk */ 04623 04624 /******************************************************************************\ 04625 |* *| 04626 |* Description: *| 04627 |* <description> *| 04628 |* *| 04629 |* Input parameters: *| 04630 |* NONE *| 04631 |* *| 04632 |* Output parameters: *| 04633 |* NONE *| 04634 |* *| 04635 |* Returns: *| 04636 |* NOTHING *| 04637 |* *| 04638 \******************************************************************************/ 04639 04640 void end_doall_blk(boolean err_call) 04641 04642 { 04643 04644 TRACE (Func_Entry, "end_doall_blk", NULL); 04645 04646 POP_BLK_STK; 04647 04648 TRACE (Func_Exit, "end_doall_blk", NULL); 04649 04650 return; 04651 04652 } /* end_doall_blk */ 04653 04654 /******************************************************************************\ 04655 |* *| 04656 |* Description: *| 04657 |* <description> *| 04658 |* *| 04659 |* Input parameters: *| 04660 |* NONE *| 04661 |* *| 04662 |* Output parameters: *| 04663 |* NONE *| 04664 |* *| 04665 |* Returns: *| 04666 |* NOTHING *| 04667 |* *| 04668 \******************************************************************************/ 04669 04670 void end_wait_blk(boolean err_call) 04671 04672 { 04673 04674 TRACE (Func_Entry, "end_wait_blk", NULL); 04675 04676 /* NOTE - This routine should never be called. Everything is handled */ 04677 /* in directive.c under the SEND directive. */ 04678 04679 POP_BLK_STK; 04680 04681 TRACE (Func_Exit, "end_wait_blk", NULL); 04682 04683 return; 04684 04685 } /* end_wait_blk */ 04686 04687 /******************************************************************************\ 04688 |* *| 04689 |* Description: *| 04690 |* <description> *| 04691 |* *| 04692 |* Input parameters: *| 04693 |* NONE *| 04694 |* *| 04695 |* Output parameters: *| 04696 |* NONE *| 04697 |* *| 04698 |* Returns: *| 04699 |* NOTHING *| 04700 |* *| 04701 \******************************************************************************/ 04702 04703 void end_do_parallel_blk(boolean err_call) 04704 04705 { 04706 int sh_idx; 04707 04708 04709 TRACE (Func_Entry, "end_do_parallel_blk", NULL); 04710 04711 if (! err_call) { 04712 04713 if (STMT_CANT_BE_IN_BLK(End_Do_Parallel_Stmt, CURR_BLK)) { 04714 04715 if (cdir_switches.dopar_sh_idx != NULL_IDX) { 04716 PRINTMSG(SH_GLB_LINE(cdir_switches.dopar_sh_idx), 1219, Error, 04717 SH_COL_NUM(cdir_switches.dopar_sh_idx), 04718 "DO PARALLEL"); 04719 cdir_switches.dopar_sh_idx = NULL_IDX; 04720 } 04721 else { 04722 blk_match_err(Do_Parallel_Blk, FALSE, FALSE); 04723 } 04724 } 04725 04726 if (CURR_BLK == Do_Parallel_Blk) { 04727 04728 /* remove the enddo statement that was generated at the */ 04729 /* end of the Do Blk. This one supersedes it. */ 04730 04731 if (BLK_ENDDO_PARALLEL_SH_IDX(blk_stk_idx) != NULL_IDX) { 04732 sh_idx = BLK_ENDDO_PARALLEL_SH_IDX(blk_stk_idx); 04733 SH_PREV_IDX(SH_NEXT_IDX(sh_idx)) = SH_PREV_IDX(sh_idx); 04734 SH_NEXT_IDX(SH_PREV_IDX(sh_idx)) = SH_NEXT_IDX(sh_idx); 04735 04736 FREE_IR_NODE(SH_IR_IDX(sh_idx)); 04737 FREE_SH_NODE(sh_idx); 04738 } 04739 04740 POP_BLK_STK; 04741 } 04742 } 04743 else { 04744 POP_BLK_STK; 04745 } 04746 04747 TRACE (Func_Exit, "end_do_parallel_blk", NULL); 04748 04749 return; 04750 04751 } /* end_do_parallel_blk */ 04752 04753 /******************************************************************************\ 04754 |* *| 04755 |* Description: *| 04756 |* <description> *| 04757 |* *| 04758 |* Input parameters: *| 04759 |* NONE *| 04760 |* *| 04761 |* Output parameters: *| 04762 |* NONE *| 04763 |* *| 04764 |* Returns: *| 04765 |* NOTHING *| 04766 |* *| 04767 \******************************************************************************/ 04768 04769 void end_pdo_blk(boolean err_call) 04770 04771 { 04772 int sh_idx; 04773 04774 04775 TRACE (Func_Entry, "end_pdo_blk", NULL); 04776 04777 if (! err_call) { 04778 04779 if (STMT_CANT_BE_IN_BLK(SGI_End_Pdo_Stmt, CURR_BLK)) { 04780 04781 if (cdir_switches.pdo_sh_idx != NULL_IDX) { 04782 PRINTMSG(SH_GLB_LINE(cdir_switches.pdo_sh_idx), 1219, Error, 04783 SH_COL_NUM(cdir_switches.pdo_sh_idx), 04784 "PDO"); 04785 cdir_switches.pdo_sh_idx = NULL_IDX; 04786 } 04787 else { 04788 blk_match_err(SGI_Pdo_Blk, FALSE, FALSE); 04789 } 04790 } 04791 04792 if (CURR_BLK == SGI_Pdo_Blk) { 04793 /* remove the enddo statement that was generated at the */ 04794 /* end of the Do Blk. This one supersedes it. */ 04795 04796 if (BLK_ENDPDO_SH_IDX(blk_stk_idx) != NULL_IDX) { 04797 sh_idx = BLK_ENDPDO_SH_IDX(blk_stk_idx); 04798 SH_PREV_IDX(SH_NEXT_IDX(sh_idx)) = SH_PREV_IDX(sh_idx); 04799 SH_NEXT_IDX(SH_PREV_IDX(sh_idx)) = SH_NEXT_IDX(sh_idx); 04800 04801 FREE_IR_NODE(SH_IR_IDX(sh_idx)); 04802 FREE_SH_NODE(sh_idx); 04803 } 04804 04805 IR_LINE_NUM_R(SH_IR_IDX(curr_stmt_sh_idx)) = stmt_start_line; 04806 IR_COL_NUM_R(SH_IR_IDX(curr_stmt_sh_idx)) = stmt_start_col; 04807 IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx; 04808 IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX; 04809 04810 POP_BLK_STK; 04811 } 04812 } 04813 else { 04814 POP_BLK_STK; 04815 } 04816 04817 TRACE (Func_Exit, "end_pdo_blk", NULL); 04818 04819 return; 04820 04821 } /* end_pdo_blk */ 04822 04823 /******************************************************************************\ 04824 |* *| 04825 |* Description: *| 04826 |* <description> *| 04827 |* *| 04828 |* Input parameters: *| 04829 |* NONE *| 04830 |* *| 04831 |* Output parameters: *| 04832 |* NONE *| 04833 |* *| 04834 |* Returns: *| 04835 |* NOTHING *| 04836 |* *| 04837 \******************************************************************************/ 04838 04839 void end_guard_blk(boolean err_call) 04840 04841 { 04842 TRACE (Func_Entry, "end_guard_blk", NULL); 04843 04844 if (CURR_BLK == Do_Parallel_Blk) { 04845 /* just pop it */ 04846 POP_BLK_STK; 04847 CLEAR_DIRECTIVE_STATE(Do_Parallel_Region); 04848 } 04849 04850 if (CURR_BLK == SGI_Pdo_Blk) { 04851 /* just pop it */ 04852 POP_BLK_STK; 04853 CLEAR_DIRECTIVE_STATE(Pdo_Region); 04854 } 04855 04856 if (! err_call) { 04857 04858 if (STMT_CANT_BE_IN_BLK(End_Guard_Stmt, CURR_BLK)) { 04859 blk_match_err(Guard_Blk, FALSE, FALSE); 04860 } 04861 04862 if (CURR_BLK == Guard_Blk) { 04863 POP_BLK_STK; 04864 } 04865 } 04866 else { 04867 POP_BLK_STK; 04868 } 04869 04870 TRACE (Func_Exit, "end_guard_blk", NULL); 04871 04872 return; 04873 04874 } /* end_guard_blk */ 04875 04876 /******************************************************************************\ 04877 |* *| 04878 |* Description: *| 04879 |* <description> *| 04880 |* *| 04881 |* Input parameters: *| 04882 |* NONE *| 04883 |* *| 04884 |* Output parameters: *| 04885 |* NONE *| 04886 |* *| 04887 |* Returns: *| 04888 |* NOTHING *| 04889 |* *| 04890 \******************************************************************************/ 04891 04892 void end_parallel_case_blk(boolean err_call) 04893 04894 { 04895 TRACE (Func_Entry, "end_parallel_case_blk", NULL); 04896 04897 if (CURR_BLK == Do_Parallel_Blk) { 04898 /* just pop it */ 04899 POP_BLK_STK; 04900 CLEAR_DIRECTIVE_STATE(Do_Parallel_Region); 04901 } 04902 04903 if (CURR_BLK == SGI_Pdo_Blk) { 04904 /* just pop it */ 04905 POP_BLK_STK; 04906 CLEAR_DIRECTIVE_STATE(Pdo_Region); 04907 } 04908 04909 if (! err_call) { 04910 04911 if (STMT_CANT_BE_IN_BLK(stmt_type, CURR_BLK)) { 04912 blk_match_err(Parallel_Case_Blk, FALSE, FALSE); 04913 } 04914 04915 if (CURR_BLK == Parallel_Case_Blk) { 04916 POP_BLK_STK; 04917 } 04918 } 04919 else { 04920 POP_BLK_STK; 04921 } 04922 04923 TRACE (Func_Exit, "end_parallel_case_blk", NULL); 04924 04925 return; 04926 04927 } /* end_parallel_case_blk */ 04928 04929 /******************************************************************************\ 04930 |* *| 04931 |* Description: *| 04932 |* <description> *| 04933 |* *| 04934 |* Input parameters: *| 04935 |* NONE *| 04936 |* *| 04937 |* Output parameters: *| 04938 |* NONE *| 04939 |* *| 04940 |* Returns: *| 04941 |* NOTHING *| 04942 |* *| 04943 \******************************************************************************/ 04944 04945 void end_SGI_parallel_blk(boolean err_call) 04946 04947 { 04948 TRACE (Func_Entry, "end_SGI_parallel_blk", NULL); 04949 04950 while (blk_stk_idx > 0 && 04951 (CURR_BLK == Do_Parallel_Blk || 04952 CURR_BLK == SGI_Pdo_Blk || 04953 CURR_BLK == SGI_Psection_Blk || 04954 CURR_BLK == SGI_Section_Blk || 04955 CURR_BLK == SGI_Single_Process_Blk || 04956 CURR_BLK == SGI_Critical_Section_Blk)) { 04957 04958 switch (CURR_BLK) { 04959 case Do_Parallel_Blk: 04960 CLEAR_DIRECTIVE_STATE(Do_Parallel_Region); 04961 break; 04962 04963 case SGI_Pdo_Blk: 04964 CLEAR_DIRECTIVE_STATE(Pdo_Region); 04965 break; 04966 04967 case SGI_Psection_Blk: 04968 CLEAR_DIRECTIVE_STATE(Parallel_Section_Region); 04969 break; 04970 04971 case SGI_Section_Blk: 04972 CLEAR_DIRECTIVE_STATE(Parallel_Section_Region); 04973 break; 04974 04975 case SGI_Single_Process_Blk: 04976 CLEAR_DIRECTIVE_STATE(Single_Process_Region); 04977 break; 04978 04979 case SGI_Critical_Section_Blk: 04980 CLEAR_DIRECTIVE_STATE(Critical_Section_Region); 04981 break; 04982 } 04983 04984 /* just pop it */ 04985 POP_BLK_STK; 04986 } 04987 04988 if (! err_call) { 04989 04990 if (cdir_switches.pdo_sh_idx != NULL_IDX) { 04991 PRINTMSG(SH_GLB_LINE(cdir_switches.pdo_sh_idx), 1219, Error, 04992 SH_COL_NUM(cdir_switches.pdo_sh_idx), 04993 "PDO"); 04994 cdir_switches.pdo_sh_idx = NULL_IDX; 04995 } 04996 04997 if (STMT_CANT_BE_IN_BLK(SGI_End_Parallel_Stmt, CURR_BLK)) { 04998 blk_match_err(SGI_Parallel_Blk, FALSE, FALSE); 04999 } 05000 05001 if (CURR_BLK == SGI_Parallel_Blk) { 05002 /* point to the PARALLEL directive */ 05003 IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx; 05004 IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX; 05005 05006 POP_BLK_STK; 05007 } 05008 } 05009 else { 05010 POP_BLK_STK; 05011 } 05012 05013 TRACE (Func_Exit, "end_SGI_parallel_blk", NULL); 05014 05015 return; 05016 05017 } /* end_SGI_parallel_blk */ 05018 05019 /******************************************************************************\ 05020 |* *| 05021 |* Description: *| 05022 |* <description> *| 05023 |* *| 05024 |* Input parameters: *| 05025 |* NONE *| 05026 |* *| 05027 |* Output parameters: *| 05028 |* NONE *| 05029 |* *| 05030 |* Returns: *| 05031 |* NOTHING *| 05032 |* *| 05033 \******************************************************************************/ 05034 05035 void end_doacross_blk(boolean err_call) 05036 05037 { 05038 05039 TRACE (Func_Entry, "end_doacross_blk", NULL); 05040 05041 POP_BLK_STK; 05042 05043 TRACE (Func_Exit, "end_doacross_blk", NULL); 05044 05045 return; 05046 05047 } /* end_doacross_blk */ 05048 05049 /******************************************************************************\ 05050 |* *| 05051 |* Description: *| 05052 |* <description> *| 05053 |* *| 05054 |* Input parameters: *| 05055 |* NONE *| 05056 |* *| 05057 |* Output parameters: *| 05058 |* NONE *| 05059 |* *| 05060 |* Returns: *| 05061 |* NOTHING *| 05062 |* *| 05063 \******************************************************************************/ 05064 05065 void end_critical_section_blk(boolean err_call) 05066 05067 { 05068 TRACE (Func_Entry, "end_critical_section_blk", NULL); 05069 05070 if (CURR_BLK == Do_Parallel_Blk) { 05071 /* just pop it */ 05072 POP_BLK_STK; 05073 CLEAR_DIRECTIVE_STATE(Do_Parallel_Region); 05074 } 05075 05076 if (CURR_BLK == SGI_Pdo_Blk) { 05077 /* just pop it */ 05078 POP_BLK_STK; 05079 CLEAR_DIRECTIVE_STATE(Pdo_Region); 05080 } 05081 05082 if (! err_call) { 05083 05084 if (STMT_CANT_BE_IN_BLK(SGI_End_Critical_Section_Stmt, CURR_BLK)) { 05085 blk_match_err(SGI_Critical_Section_Blk, FALSE, FALSE); 05086 } 05087 05088 if (CURR_BLK == SGI_Critical_Section_Blk) { 05089 POP_BLK_STK; 05090 } 05091 } 05092 else { 05093 POP_BLK_STK; 05094 } 05095 05096 TRACE (Func_Exit, "end_critical_section_blk", NULL); 05097 05098 return; 05099 05100 } /* end_critical_section_blk */ 05101 05102 /******************************************************************************\ 05103 |* *| 05104 |* Description: *| 05105 |* <description> *| 05106 |* *| 05107 |* Input parameters: *| 05108 |* NONE *| 05109 |* *| 05110 |* Output parameters: *| 05111 |* NONE *| 05112 |* *| 05113 |* Returns: *| 05114 |* NOTHING *| 05115 |* *| 05116 \******************************************************************************/ 05117 05118 void end_psection_blk(boolean err_call) 05119 05120 { 05121 TRACE (Func_Entry, "end_psection_blk", NULL); 05122 05123 if (CURR_BLK == Do_Parallel_Blk) { 05124 /* just pop it */ 05125 POP_BLK_STK; 05126 CLEAR_DIRECTIVE_STATE(Do_Parallel_Region); 05127 } 05128 05129 if (CURR_BLK == SGI_Pdo_Blk) { 05130 /* just pop it */ 05131 POP_BLK_STK; 05132 CLEAR_DIRECTIVE_STATE(Pdo_Region); 05133 } 05134 05135 if (! err_call) { 05136 05137 if (STMT_CANT_BE_IN_BLK(SGI_End_Psection_Stmt, CURR_BLK)) { 05138 blk_match_err(SGI_Section_Blk, FALSE, FALSE); 05139 } 05140 05141 if (CURR_BLK == SGI_Section_Blk) { 05142 POP_BLK_STK; 05143 } 05144 } 05145 else { 05146 POP_BLK_STK; 05147 } 05148 05149 if (CURR_BLK == SGI_Psection_Blk) { 05150 /* point to the PSECTION directive */ 05151 IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx; 05152 IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX; 05153 05154 POP_BLK_STK; 05155 } 05156 05157 TRACE (Func_Exit, "end_psection_blk", NULL); 05158 05159 return; 05160 05161 } /* end_psection_blk */ 05162 05163 /******************************************************************************\ 05164 |* *| 05165 |* Description: *| 05166 |* <description> *| 05167 |* *| 05168 |* Input parameters: *| 05169 |* NONE *| 05170 |* *| 05171 |* Output parameters: *| 05172 |* NONE *| 05173 |* *| 05174 |* Returns: *| 05175 |* NOTHING *| 05176 |* *| 05177 \******************************************************************************/ 05178 05179 void end_single_process_blk(boolean err_call) 05180 05181 { 05182 TRACE (Func_Entry, "end_single_process_blk", NULL); 05183 05184 if (CURR_BLK == Do_Parallel_Blk) { 05185 /* just pop it */ 05186 POP_BLK_STK; 05187 CLEAR_DIRECTIVE_STATE(Do_Parallel_Region); 05188 } 05189 05190 if (CURR_BLK == SGI_Pdo_Blk) { 05191 /* just pop it */ 05192 POP_BLK_STK; 05193 CLEAR_DIRECTIVE_STATE(Pdo_Region); 05194 } 05195 05196 if (! err_call) { 05197 05198 if (STMT_CANT_BE_IN_BLK(SGI_End_Single_Process_Stmt, CURR_BLK)) { 05199 blk_match_err(SGI_Single_Process_Blk, FALSE, FALSE); 05200 } 05201 05202 if (CURR_BLK == SGI_Single_Process_Blk) { 05203 /* point to the SINGLE PROCESS directive */ 05204 IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx; 05205 IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX; 05206 05207 POP_BLK_STK; 05208 } 05209 } 05210 else { 05211 POP_BLK_STK; 05212 } 05213 05214 TRACE (Func_Exit, "end_single_process_blk", NULL); 05215 05216 return; 05217 05218 } /* end_single_process_blk */ 05219 05220 /******************************************************************************\ 05221 |* *| 05222 |* Description: *| 05223 |* <description> *| 05224 |* *| 05225 |* Input parameters: *| 05226 |* NONE *| 05227 |* *| 05228 |* Output parameters: *| 05229 |* NONE *| 05230 |* *| 05231 |* Returns: *| 05232 |* NOTHING *| 05233 |* *| 05234 \******************************************************************************/ 05235 05236 void end_region_blk(boolean err_call) 05237 05238 { 05239 TRACE (Func_Entry, "end_region_blk", NULL); 05240 05241 if (CURR_BLK == Do_Parallel_Blk) { 05242 /* just pop it */ 05243 POP_BLK_STK; 05244 CLEAR_DIRECTIVE_STATE(Do_Parallel_Region); 05245 } 05246 05247 if (CURR_BLK == SGI_Pdo_Blk) { 05248 /* just pop it */ 05249 POP_BLK_STK; 05250 CLEAR_DIRECTIVE_STATE(Pdo_Region); 05251 } 05252 05253 if (! err_call) { 05254 05255 if (STMT_CANT_BE_IN_BLK(SGI_Region_End_Stmt, CURR_BLK)) { 05256 blk_match_err(SGI_Region_Blk, FALSE, FALSE); 05257 } 05258 05259 if (CURR_BLK == SGI_Region_Blk) { 05260 POP_BLK_STK; 05261 } 05262 } 05263 else { 05264 POP_BLK_STK; 05265 } 05266 05267 TRACE (Func_Exit, "end_region_blk", NULL); 05268 05269 return; 05270 05271 } /* end_region_blk */ 05272 05273 /******************************************************************************\ 05274 |* *| 05275 |* Description: *| 05276 |* <description> *| 05277 |* *| 05278 |* Input parameters: *| 05279 |* NONE *| 05280 |* *| 05281 |* Output parameters: *| 05282 |* NONE *| 05283 |* *| 05284 |* Returns: *| 05285 |* NOTHING *| 05286 |* *| 05287 \******************************************************************************/ 05288 05289 void end_open_mp_parallel_blk(boolean err_call) 05290 05291 { 05292 TRACE (Func_Entry, "end_open_mp_parallel_blk", NULL); 05293 05294 if (CURR_BLK == Open_Mp_Do_Blk) { 05295 /* just pop it */ 05296 POP_BLK_STK; 05297 CLEAR_DIRECTIVE_STATE(Open_Mp_Do_Region); 05298 } 05299 05300 if (CURR_BLK == Open_Mp_Parallel_Do_Blk) { 05301 /* just pop it */ 05302 POP_BLK_STK; 05303 CLEAR_DIRECTIVE_STATE(Open_Mp_Parallel_Do_Region); 05304 } 05305 05306 05307 if (! err_call) { 05308 05309 if (STMT_CANT_BE_IN_BLK(Open_MP_End_Parallel_Stmt, CURR_BLK)) { 05310 blk_match_err(Open_Mp_Parallel_Blk, FALSE, FALSE); 05311 } 05312 05313 if (CURR_BLK == Open_Mp_Parallel_Blk) { 05314 /* point to the PARALLEL directive */ 05315 IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx; 05316 IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX; 05317 05318 POP_BLK_STK; 05319 } 05320 } 05321 else { 05322 POP_BLK_STK; 05323 } 05324 05325 TRACE (Func_Exit, "end_open_mp_parallel_blk", NULL); 05326 05327 return; 05328 05329 } /* end_open_mp_parallel_blk */ 05330 05331 /******************************************************************************\ 05332 |* *| 05333 |* Description: *| 05334 |* <description> *| 05335 |* *| 05336 |* Input parameters: *| 05337 |* NONE *| 05338 |* *| 05339 |* Output parameters: *| 05340 |* NONE *| 05341 |* *| 05342 |* Returns: *| 05343 |* NOTHING *| 05344 |* *| 05345 \******************************************************************************/ 05346 05347 void end_open_mp_do_blk(boolean err_call) 05348 05349 { 05350 int sh_idx; 05351 05352 05353 TRACE (Func_Entry, "end_open_mp_do_blk", NULL); 05354 05355 if (! err_call) { 05356 05357 if (STMT_CANT_BE_IN_BLK(Open_MP_End_Do_Stmt, CURR_BLK)) { 05358 blk_match_err(Open_Mp_Do_Blk, FALSE, FALSE); 05359 } 05360 05361 if (CURR_BLK == Open_Mp_Do_Blk) { 05362 /* remove the enddo statement that was generated at the */ 05363 /* end of the Do Blk. This one supersedes it. */ 05364 05365 if (BLK_ENDPDO_SH_IDX(blk_stk_idx) != NULL_IDX) { 05366 sh_idx = BLK_ENDPDO_SH_IDX(blk_stk_idx); 05367 SH_PREV_IDX(SH_NEXT_IDX(sh_idx)) = SH_PREV_IDX(sh_idx); 05368 SH_NEXT_IDX(SH_PREV_IDX(sh_idx)) = SH_NEXT_IDX(sh_idx); 05369 05370 FREE_IR_NODE(SH_IR_IDX(sh_idx)); 05371 FREE_SH_NODE(sh_idx); 05372 } 05373 05374 IR_LINE_NUM_R(SH_IR_IDX(curr_stmt_sh_idx)) = stmt_start_line; 05375 IR_COL_NUM_R(SH_IR_IDX(curr_stmt_sh_idx)) = stmt_start_col; 05376 IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx; 05377 IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX; 05378 05379 POP_BLK_STK; 05380 } 05381 } 05382 else { 05383 POP_BLK_STK; 05384 } 05385 05386 TRACE (Func_Exit, "end_open_mp_do_blk", NULL); 05387 05388 return; 05389 05390 } /* end_open_mp_do_blk */ 05391 05392 /******************************************************************************\ 05393 |* *| 05394 |* Description: *| 05395 |* <description> *| 05396 |* *| 05397 |* Input parameters: *| 05398 |* NONE *| 05399 |* *| 05400 |* Output parameters: *| 05401 |* NONE *| 05402 |* *| 05403 |* Returns: *| 05404 |* NOTHING *| 05405 |* *| 05406 \******************************************************************************/ 05407 05408 void end_open_mp_parallel_sections_blk(boolean err_call) 05409 05410 { 05411 TRACE (Func_Entry, "end_open_mp_parallel_sections_blk", NULL); 05412 05413 if (! err_call) { 05414 05415 if (STMT_CANT_BE_IN_BLK(Open_MP_End_Parallel_Sections_Stmt, CURR_BLK)) { 05416 blk_match_err(Open_Mp_Parallel_Sections_Blk, FALSE, FALSE); 05417 } 05418 05419 if (CURR_BLK == Open_Mp_Parallel_Sections_Blk) { 05420 /* point to the PARALLEL SECTIONS directive */ 05421 IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx; 05422 IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX; 05423 05424 POP_BLK_STK; 05425 } 05426 } 05427 else { 05428 POP_BLK_STK; 05429 } 05430 05431 TRACE (Func_Exit, "end_open_mp_parallel_sections_blk", NULL); 05432 05433 return; 05434 05435 } /* end_open_mp_parallel_sections_blk */ 05436 05437 /******************************************************************************\ 05438 |* *| 05439 |* Description: *| 05440 |* <description> *| 05441 |* *| 05442 |* Input parameters: *| 05443 |* NONE *| 05444 |* *| 05445 |* Output parameters: *| 05446 |* NONE *| 05447 |* *| 05448 |* Returns: *| 05449 |* NOTHING *| 05450 |* *| 05451 \******************************************************************************/ 05452 05453 void end_open_mp_parallel_workshare_blk(boolean err_call) 05454 05455 { 05456 TRACE (Func_Entry, "end_open_mp_parallel_workshare_blk", NULL); 05457 05458 if (! err_call) { 05459 05460 if (STMT_CANT_BE_IN_BLK(Open_MP_End_Parallel_Workshare_Stmt, CURR_BLK)) { 05461 blk_match_err(Open_Mp_Parallel_Workshare_Blk, FALSE, FALSE); 05462 } 05463 05464 if (CURR_BLK == Open_Mp_Parallel_Workshare_Blk) { 05465 /* point to the PARALLEL WORKSHARE directive */ 05466 IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx; 05467 IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX; 05468 05469 POP_BLK_STK; 05470 } 05471 } 05472 else { 05473 POP_BLK_STK; 05474 } 05475 05476 TRACE (Func_Exit, "end_open_mp_parallel_workshare_blk", NULL); 05477 05478 return; 05479 05480 } /* end_open_mp_parallel_workshare_blk */ 05481 05482 /******************************************************************************\ 05483 |* *| 05484 |* Description: *| 05485 |* <description> *| 05486 |* *| 05487 |* Input parameters: *| 05488 |* NONE *| 05489 |* *| 05490 |* Output parameters: *| 05491 |* NONE *| 05492 |* *| 05493 |* Returns: *| 05494 |* NOTHING *| 05495 |* *| 05496 \******************************************************************************/ 05497 05498 void end_open_mp_sections_blk(boolean err_call) 05499 05500 { 05501 TRACE (Func_Entry, "end_open_mp_sections_blk", NULL); 05502 05503 if (! err_call) { 05504 05505 if (STMT_CANT_BE_IN_BLK(Open_MP_End_Sections_Stmt, CURR_BLK)) { 05506 blk_match_err(Open_Mp_Sections_Blk, FALSE, FALSE); 05507 } 05508 05509 if (CURR_BLK == Open_Mp_Sections_Blk) { 05510 /* point to the SECTIONS directive */ 05511 IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx; 05512 IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX; 05513 05514 POP_BLK_STK; 05515 } 05516 } 05517 else { 05518 POP_BLK_STK; 05519 } 05520 05521 TRACE (Func_Exit, "end_open_mp_sections_blk", NULL); 05522 05523 return; 05524 05525 } /* end_open_mp_sections_blk */ 05526 05527 /******************************************************************************\ 05528 |* *| 05529 |* Description: *| 05530 |* <description> *| 05531 |* *| 05532 |* Input parameters: *| 05533 |* NONE *| 05534 |* *| 05535 |* Output parameters: *| 05536 |* NONE *| 05537 |* *| 05538 |* Returns: *| 05539 |* NOTHING *| 05540 |* *| 05541 \******************************************************************************/ 05542 05543 void end_open_mp_section_blk(boolean err_call) 05544 05545 { 05546 TRACE (Func_Entry, "end_open_mp_section_blk", NULL); 05547 05548 if (! err_call) { 05549 05550 if (STMT_CANT_BE_IN_BLK(Open_MP_End_Section_Stmt, CURR_BLK)) { 05551 blk_match_err(Open_Mp_Section_Blk, FALSE, FALSE); 05552 } 05553 05554 if (CURR_BLK == Open_Mp_Section_Blk) { 05555 POP_BLK_STK; 05556 } 05557 } 05558 else { 05559 POP_BLK_STK; 05560 } 05561 05562 TRACE (Func_Exit, "end_open_mp_section_blk", NULL); 05563 05564 return; 05565 05566 } /* end_open_mp_section_blk */ 05567 05568 /******************************************************************************\ 05569 |* *| 05570 |* Description: *| 05571 |* <description> *| 05572 |* *| 05573 |* Input parameters: *| 05574 |* NONE *| 05575 |* *| 05576 |* Output parameters: *| 05577 |* NONE *| 05578 |* *| 05579 |* Returns: *| 05580 |* NOTHING *| 05581 |* *| 05582 \******************************************************************************/ 05583 05584 void end_open_mp_single_blk(boolean err_call) 05585 05586 { 05587 TRACE (Func_Entry, "end_open_mp_single_blk", NULL); 05588 05589 if (! err_call) { 05590 05591 if (STMT_CANT_BE_IN_BLK(Open_MP_End_Single_Stmt, CURR_BLK)) { 05592 blk_match_err(Open_Mp_Single_Blk, FALSE, FALSE); 05593 } 05594 05595 if (CURR_BLK == Open_Mp_Single_Blk) { 05596 /* point to the SINGLE directive */ 05597 IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx; 05598 IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX; 05599 05600 POP_BLK_STK; 05601 } 05602 } 05603 else { 05604 POP_BLK_STK; 05605 } 05606 05607 TRACE (Func_Exit, "end_open_mp_single_blk", NULL); 05608 05609 return; 05610 05611 } /* end_open_mp_single_blk */ 05612 05613 /******************************************************************************\ 05614 |* *| 05615 |* Description: *| 05616 |* <description> *| 05617 |* *| 05618 |* Input parameters: *| 05619 |* NONE *| 05620 |* *| 05621 |* Output parameters: *| 05622 |* NONE *| 05623 |* *| 05624 |* Returns: *| 05625 |* NOTHING *| 05626 |* *| 05627 \******************************************************************************/ 05628 05629 void end_open_mp_parallel_do_blk(boolean err_call) 05630 05631 { 05632 int sh_idx; 05633 05634 05635 TRACE (Func_Entry, "end_open_mp_parallel_do_blk", NULL); 05636 05637 if (! err_call) { 05638 05639 if (STMT_CANT_BE_IN_BLK(Open_MP_End_Parallel_Do_Stmt, CURR_BLK)) { 05640 blk_match_err(Open_Mp_Parallel_Do_Blk, FALSE, FALSE); 05641 } 05642 05643 if (CURR_BLK == Open_Mp_Parallel_Do_Blk) { 05644 /* remove the enddo statement that was generated at the */ 05645 /* end of the Do Blk. This one supersedes it. */ 05646 05647 if (BLK_ENDPDO_SH_IDX(blk_stk_idx) != NULL_IDX) { 05648 sh_idx = BLK_ENDPDO_SH_IDX(blk_stk_idx); 05649 SH_PREV_IDX(SH_NEXT_IDX(sh_idx)) = SH_PREV_IDX(sh_idx); 05650 SH_NEXT_IDX(SH_PREV_IDX(sh_idx)) = SH_NEXT_IDX(sh_idx); 05651 05652 FREE_IR_NODE(SH_IR_IDX(sh_idx)); 05653 FREE_SH_NODE(sh_idx); 05654 } 05655 05656 IR_LINE_NUM_R(SH_IR_IDX(curr_stmt_sh_idx)) = stmt_start_line; 05657 IR_COL_NUM_R(SH_IR_IDX(curr_stmt_sh_idx)) = stmt_start_col; 05658 IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx; 05659 IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX; 05660 05661 POP_BLK_STK; 05662 } 05663 } 05664 else { 05665 POP_BLK_STK; 05666 } 05667 05668 TRACE (Func_Exit, "end_open_mp_parallel_do_blk", NULL); 05669 05670 return; 05671 } 05672 05673 /******************************************************************************\ 05674 |* *| 05675 |* Description: *| 05676 |* <description> *| 05677 |* *| 05678 |* Input parameters: *| 05679 |* NONE *| 05680 |* *| 05681 |* Output parameters: *| 05682 |* NONE *| 05683 |* *| 05684 |* Returns: *| 05685 |* NOTHING *| 05686 |* *| 05687 \******************************************************************************/ 05688 05689 void end_open_mp_master_blk(boolean err_call) 05690 05691 { 05692 TRACE (Func_Entry, "end_open_mp_master_blk", NULL); 05693 05694 if (! err_call) { 05695 05696 if (STMT_CANT_BE_IN_BLK(Open_MP_End_Master_Stmt, CURR_BLK)) { 05697 blk_match_err(Open_Mp_Master_Blk, FALSE, FALSE); 05698 } 05699 05700 if (CURR_BLK == Open_Mp_Master_Blk) { 05701 POP_BLK_STK; 05702 } 05703 } 05704 else { 05705 POP_BLK_STK; 05706 } 05707 05708 TRACE (Func_Exit, "end_open_mp_master_blk", NULL); 05709 05710 return; 05711 05712 } /* end_open_mp_master_blk */ 05713 05714 /******************************************************************************\ 05715 |* *| 05716 |* Description: *| 05717 |* <description> *| 05718 |* *| 05719 |* Input parameters: *| 05720 |* NONE *| 05721 |* *| 05722 |* Output parameters: *| 05723 |* NONE *| 05724 |* *| 05725 |* Returns: *| 05726 |* NOTHING *| 05727 |* *| 05728 \******************************************************************************/ 05729 05730 void end_open_mp_critical_blk(boolean err_call) 05731 05732 { 05733 TRACE (Func_Entry, "end_open_mp_critical_blk", NULL); 05734 05735 if (! err_call) { 05736 05737 if (STMT_CANT_BE_IN_BLK(Open_MP_End_Critical_Stmt, CURR_BLK)) { 05738 blk_match_err(Open_Mp_Critical_Blk, FALSE, FALSE); 05739 } 05740 05741 if (CURR_BLK == Open_Mp_Critical_Blk) { 05742 POP_BLK_STK; 05743 } 05744 } 05745 else { 05746 POP_BLK_STK; 05747 } 05748 05749 TRACE (Func_Exit, "end_open_mp_critical_blk", NULL); 05750 05751 return; 05752 05753 } /* end_open_mp_critical_blk */ 05754 05755 /******************************************************************************\ 05756 |* *| 05757 |* Description: *| 05758 |* <description> *| 05759 |* *| 05760 |* Input parameters: *| 05761 |* NONE *| 05762 |* *| 05763 |* Output parameters: *| 05764 |* NONE *| 05765 |* *| 05766 |* Returns: *| 05767 |* NOTHING *| 05768 |* *| 05769 \******************************************************************************/ 05770 05771 void end_open_mp_ordered_blk(boolean err_call) 05772 05773 { 05774 TRACE (Func_Entry, "end_open_mp_ordered_blk", NULL); 05775 05776 if (! err_call) { 05777 05778 if (STMT_CANT_BE_IN_BLK(Open_MP_End_Ordered_Stmt, CURR_BLK)) { 05779 blk_match_err(Open_Mp_Ordered_Blk, FALSE, FALSE); 05780 } 05781 05782 if (CURR_BLK == Open_Mp_Ordered_Blk) { 05783 POP_BLK_STK; 05784 } 05785 } 05786 else { 05787 POP_BLK_STK; 05788 } 05789 05790 TRACE (Func_Exit, "end_open_mp_ordered_blk", NULL); 05791 05792 return; 05793 05794 } /* end_open_mp_ordered_blk */ 05795 05796 /******************************************************************************\ 05797 |* *| 05798 |* Description: *| 05799 |* <description> *| 05800 |* *| 05801 |* Input parameters: *| 05802 |* NONE *| 05803 |* *| 05804 |* Output parameters: *| 05805 |* NONE *| 05806 |* *| 05807 |* Returns: *| 05808 |* NOTHING *| 05809 |* *| 05810 \******************************************************************************/ 05811 05812 void end_open_mp_workshare_blk(boolean err_call) 05813 05814 { 05815 TRACE (Func_Entry, "end_open_mp_workshare_blk", NULL); 05816 05817 if (! err_call) { 05818 05819 if (STMT_CANT_BE_IN_BLK(Open_MP_End_Workshare_Stmt, CURR_BLK)) { 05820 blk_match_err(Open_Mp_Workshare_Blk, FALSE, FALSE); 05821 } 05822 05823 if (CURR_BLK == Open_Mp_Workshare_Blk) { 05824 /* point to the WORKSHARE directive */ 05825 IR_FLD_R(SH_IR_IDX(curr_stmt_sh_idx)) = SH_Tbl_Idx; 05826 IR_IDX_R(SH_IR_IDX(curr_stmt_sh_idx)) = CURR_BLK_FIRST_SH_IDX; 05827 05828 POP_BLK_STK; 05829 } 05830 } 05831 else { 05832 POP_BLK_STK; 05833 } 05834 05835 TRACE (Func_Exit, "end_open_mp_workshare_blk", NULL); 05836 05837 return; 05838 05839 } /* end_open_mp_workshare_blk */ 05840 05841 /******************************************************************************\ 05842 |* *| 05843 |* Description: *| 05844 |* Look for Do_Parallel_Blk's on the block stack. If we are outside the *| 05845 |* associated Do_Blk, remove the Do_Parallel_Blk. If we are inside the *| 05846 |* associated Do_Blk, and cannot_nest is true, issue an error. *| 05847 |* *| 05848 |* Input parameters: *| 05849 |* NONE *| 05850 |* *| 05851 |* Output parameters: *| 05852 |* NONE *| 05853 |* *| 05854 |* Returns: *| 05855 |* NOTHING *| 05856 |* *| 05857 \******************************************************************************/ 05858 05859 boolean remove_do_parallel_blk(boolean cannot_nest, 05860 char *str, 05861 int line, 05862 int col) 05863 05864 05865 { 05866 int blk_idx; 05867 boolean err = FALSE; 05868 05869 TRACE (Func_Entry, "remove_do_parallel_blk", NULL); 05870 05871 blk_idx = blk_stk_idx; 05872 05873 while (BLK_TYPE(blk_idx) > Module_Proc_Blk) { 05874 05875 if (BLK_TYPE(blk_idx) == Do_Parallel_Blk) { 05876 if (blk_idx < blk_stk_idx && 05877 BLK_TYPE(blk_idx + 1) == Do_Blk && 05878 BLK_DEF_LINE(blk_idx) == BLK_DEF_LINE(blk_idx + 1)) { 05879 05880 /* inside the do block for the do parallel */ 05881 if (cannot_nest) { 05882 PRINTMSG(line, 1289, Error, col, str); 05883 err = TRUE; 05884 } 05885 else { 05886 /* intentionally blank, just leave as is */ 05887 } 05888 } 05889 else { 05890 /* outside the do block for the do parallel */ 05891 /* just remove the do parallal blk */ 05892 05893 move_blk_to_end(blk_idx); 05894 CLEAR_DIRECTIVE_STATE(Do_Parallel_Region); 05895 POP_BLK_STK; 05896 } 05897 } 05898 05899 blk_idx--; 05900 } 05901 05902 TRACE (Func_Exit, "remove_do_parallel_blk", NULL); 05903 05904 return(err); 05905 05906 } /* remove_do_parallel_blk */ 05907 05908 /******************************************************************************\ 05909 |* *| 05910 |* Description: *| 05911 |* Look for SGI_Pdo_Blk's on the block stack. If we are outside the *| 05912 |* associated Do_Blk, remove the SGI_Pdo_Blk. If we are inside the *| 05913 |* associated Do_Blk, and cannot_nest is true, issue an error. *| 05914 |* *| 05915 |* Input parameters: *| 05916 |* NONE *| 05917 |* *| 05918 |* Output parameters: *| 05919 |* NONE *| 05920 |* *| 05921 |* Returns: *| 05922 |* NOTHING *| 05923 |* *| 05924 \******************************************************************************/ 05925 05926 boolean remove_pdo_blk(boolean cannot_nest, 05927 char *str, 05928 int line, 05929 int col) 05930 05931 05932 { 05933 int blk_idx; 05934 boolean err = FALSE; 05935 05936 TRACE (Func_Entry, "remove_pdo_blk", NULL); 05937 05938 blk_idx = blk_stk_idx; 05939 05940 while (BLK_TYPE(blk_idx) > Module_Proc_Blk) { 05941 05942 if (BLK_TYPE(blk_idx) == SGI_Pdo_Blk) { 05943 if (blk_idx < blk_stk_idx && 05944 BLK_TYPE(blk_idx + 1) == Do_Blk && 05945 BLK_DEF_LINE(blk_idx) == BLK_DEF_LINE(blk_idx + 1)) { 05946 05947 /* inside the do block for the pdo */ 05948 if (cannot_nest) { 05949 /* need new message BHJ */ 05950 PRINTMSG(line, 1289, Error, col, str); 05951 err = TRUE; 05952 } 05953 else { 05954 /* intentionally blank, just leave as is */ 05955 } 05956 } 05957 else { 05958 /* outside the do block for the pdo */ 05959 /* just remove the pdo blk */ 05960 05961 move_blk_to_end(blk_idx); 05962 CLEAR_DIRECTIVE_STATE(Pdo_Region); 05963 POP_BLK_STK; 05964 } 05965 } 05966 05967 blk_idx--; 05968 } 05969 05970 TRACE (Func_Exit, "remove_pdo_blk", NULL); 05971 05972 return(err); 05973 05974 } /* remove_pdo_blk */ 05975 05976 05977 # if defined(GENERATE_WHIRL) 05978 05979 05980 /******************************************************************************\ 05981 |* *| 05982 |* Description: *| 05983 |* Check to see if the current iterative DO ending statement immediately *| 05984 |* follows a preceding iterative DO ending statement. That is, check to *| 05985 |* see if the bottom of the current loop is perfectly nested within its *| 05986 |* containing iterative DO loop. *| 05987 |* *| 05988 |* Input parameters: *| 05989 |* NONE *| 05990 |* *| 05991 |* Output parameters: *| 05992 |* NONE *| 05993 |* *| 05994 |* Returns: *| 05995 |* TRUE if the current DO ending statement immediately follows a *| 05996 |* preceding iterative DO ending statement. *| 05997 |* *| 05998 \******************************************************************************/ 05999 06000 static void check_loop_bottom_nesting(void) 06001 06002 { 06003 int blk_idx; 06004 boolean perfectly_nested = FALSE; 06005 int sh_idx; 06006 char str[80]; 06007 06008 06009 TRACE (Func_Entry, "check_loop_bottom_nesting", NULL); 06010 06011 /* Look back through the SH's to find the loop ending IR for the next */ 06012 /* inner loop. The following SH types can occur between the current loop */ 06013 /* ending IR and the inner loop ending IR: */ 06014 /* */ 06015 /* * Anything that is compiler-generated (we're looking for the compiler- */ 06016 /* generated Loop_End IR). */ 06017 /* */ 06018 /* * END DO statements. A nest of loops that end with END DO's looks like:*/ 06019 /* SH: End_Do_Stmt */ 06020 /* SH: CG Continue (Loop_End) */ 06021 /* SH: End_Do_Stmt */ 06022 /* SH: CG Continue (Loop_End) */ 06023 /* So, if we're at the second Loop_End, it's OK to pass through the */ 06024 /* End_Do above it to get to the next Loop_End. */ 06025 /* */ 06026 /* * The IR that represents a labeled stmt that terminates the loop. An */ 06027 /* example: */ 06028 /* */ 06029 /* C*$* INTERCHANGE(m, i, n) */ 06030 /* */ 06031 /* DO 30, i = 1, 3 */ 06032 /* DO 30, m = 1, 3 */ 06033 /* DO n = 1, 3 */ 06034 /* PRINT *, 'In innermost loop', n */ 06035 /* END DO */ 06036 /* 30 array2(i,m) = m + i */ 06037 /* */ 06038 /* produces the IR: */ 06039 /* SH: End_Do */ 06040 /* SH: CG CONTINUE (Loop_End) */ 06041 /* SH: Label_Def (30) */ 06042 /* SH: Assignment */ 06043 /* SH: CG CONTINUE (Loop_End) */ 06044 /* SH: CG CONTINUE (Loop_End) */ 06045 /* */ 06046 /* So when the middle Loop_End is the current loop being ended, we need */ 06047 /* to be able to pass through the labeled stmt to make sure the inner */ 06048 /* loop is perfectly nested in the middle loop. We can tell this */ 06049 /* labeled stmt is OK because if stmt_label_idx is not null, it means */ 06050 /* the labeled stmt is still being worked on which means the labeled */ 06051 /* stmt is the loop ending stmt. */ 06052 06053 sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 06054 06055 while (SH_COMPILER_GEN(sh_idx) || 06056 SH_STMT_TYPE(sh_idx) == End_Do_Stmt || 06057 (stmt_label_idx != NULL_IDX && 06058 (SH_LABELED(sh_idx) || SH_STMT_TYPE(sh_idx) == Label_Def))) { 06059 06060 if (SH_LOOP_END(sh_idx)) { 06061 perfectly_nested = TRUE; 06062 break; 06063 } 06064 else { 06065 sh_idx = SH_PREV_IDX(sh_idx); 06066 } 06067 } 06068 06069 if (! perfectly_nested) { 06070 06071 if (SH_LOOP_END(sh_idx)) { 06072 perfectly_nested = TRUE; 06073 } 06074 } 06075 06076 06077 /* The loop inside the current loop is not perfectly nested. Find the */ 06078 /* statement that interrupted the nesting and issue an error message. */ 06079 /* The search starts with the Loop_End IR. The previous SH could be for */ 06080 /* an END DO (the actual end of the current loop) so pass through it (and */ 06081 /* its label if it has one) to get to the offending statement. */ 06082 /* Use "DO" as the default insert in the message. Fill in the correct */ 06083 /* insert as the type of directive is determined. */ 06084 06085 if (! perfectly_nested) { 06086 06087 if (BLK_HAS_NESTED_LOOP(blk_stk_idx)) { 06088 sh_idx = SH_PREV_IDX(curr_stmt_sh_idx); 06089 06090 while (SH_COMPILER_GEN(sh_idx) || 06091 SH_STMT_TYPE(sh_idx) == End_Do_Stmt || 06092 SH_STMT_TYPE(sh_idx) == Label_Def) { 06093 sh_idx = SH_PREV_IDX(sh_idx); 06094 } 06095 06096 } 06097 06098 strcpy(str, "DO"); 06099 06100 for (blk_idx = blk_stk_idx; blk_idx > 1; --blk_idx) { 06101 06102 if (BLK_TYPE(blk_idx) == Do_Blk) { 06103 06104 if (BLK_DIR_NEST_CHECK_SH_IDX(blk_idx) != NULL_IDX) { 06105 06106 switch (IR_OPR(SH_IR_IDX(BLK_DIR_NEST_CHECK_SH_IDX(blk_idx)))) { 06107 06108 case Pdo_Par_Opr: 06109 strcpy(str, "PDO"); 06110 break; 06111 06112 case Parallel_Do_Par_Opr: 06113 strcpy(str, "PARALLEL DO"); 06114 break; 06115 06116 case Doacross_Dollar_Opr: 06117 strcpy(str, "DOACROSS"); 06118 break; 06119 06120 default: 06121 strcpy(str, "DO"); 06122 break; 06123 } 06124 06125 break; 06126 } 06127 else if (BLK_INTERCHANGE_DIR_SH_IDX(blk_idx) != NULL_IDX) { 06128 strcpy(str,"INTERCHANGE"); 06129 break; 06130 } 06131 } 06132 } 06133 06134 PRINTMSG(SH_GLB_LINE(sh_idx), 1380, Error, SH_COL_NUM(sh_idx), 06135 str); 06136 06137 for (blk_idx = blk_stk_idx; blk_idx > 1; --blk_idx) { 06138 06139 if (BLK_TYPE(blk_idx) == Do_Blk) { 06140 BLK_INTERCHANGE_NUM_LCVS(blk_idx) = 0; 06141 BLK_DIR_NEST_CHECK_NUM_LCVS(blk_idx) = 0; 06142 BLK_HAS_NESTED_LOOP(blk_idx) = FALSE; 06143 06144 if (BLK_DIR_NEST_CHECK_SH_IDX(blk_idx) != NULL_IDX) { 06145 SH_ERR_FLG(BLK_DIR_NEST_CHECK_SH_IDX(blk_idx)) = TRUE; 06146 BLK_DIR_NEST_CHECK_SH_IDX(blk_idx) = NULL_IDX; 06147 } 06148 06149 if (BLK_INTERCHANGE_DIR_SH_IDX(blk_idx) != NULL_IDX) { 06150 SH_ERR_FLG(BLK_INTERCHANGE_DIR_SH_IDX(blk_idx)) = TRUE; 06151 BLK_INTERCHANGE_DIR_SH_IDX(blk_idx) = NULL_IDX; 06152 break; 06153 } 06154 } 06155 } 06156 } 06157 06158 TRACE (Func_Exit, "loop_bottom_is_perfectly_nested", NULL); 06159 06160 return; 06161 06162 } /* check_loop_bottom_nesting */ 06163 06164 # endif 06165 06166 # if defined(_EXPRESSION_EVAL) 06167 06168 /******************************************************************************\ 06169 |* *| 06170 |* Description: *| 06171 |* Simulate an END statement. *| 06172 |* *| 06173 |* Input parameters: *| 06174 |* NONE *| 06175 |* *| 06176 |* Output parameters: *| 06177 |* NONE *| 06178 |* *| 06179 |* Returns: *| 06180 |* NONE *| 06181 |* *| 06182 \******************************************************************************/ 06183 06184 void expression_eval_end (void) 06185 { 06186 06187 TRACE (Func_Entry, "expression_eval_end", NULL); 06188 06189 end_of_contains = FALSE; 06190 stmt_type = End_Program_Stmt; 06191 SH_STMT_TYPE(curr_stmt_sh_idx) = End_Program_Stmt; 06192 06193 if (stmt_label_idx != NULL_IDX) { 06194 end_labeled_do(); 06195 } 06196 06197 /* Issue any deferred src_input messages. */ 06198 06199 issue_deferred_msgs(); 06200 06201 if (CURR_BLK != Program_Blk) { 06202 SCP_IN_ERR(curr_scp_idx) = TRUE; 06203 } 06204 06205 end_program_unit(FALSE); 06206 06207 /* Save the line and column of the EOS (which tells us where the END stmt */ 06208 /* really ends). */ 06209 06210 cif_end_unit_line = LA_CH_LINE; 06211 cif_end_unit_column = LA_CH_COLUMN - 1; 06212 06213 TRACE (Func_Exit, "expression_eval_end", NULL); 06214 06215 return; 06216 06217 } /* expression_eval_end */ 06218 06219 # endif