|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
00001 /* 00002 00003 Copyright (C) 2000, 2001 Silicon Graphics, Inc. All Rights Reserved. 00004 00005 This program is free software; you can redistribute it and/or modify it 00006 under the terms of version 2 of the GNU General Public License as 00007 published by the Free Software Foundation. 00008 00009 This program is distributed in the hope that it would be useful, but 00010 WITHOUT ANY WARRANTY; without even the implied warranty of 00011 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00012 00013 Further, this software is distributed without any warranty that it is 00014 free of the rightful claim of any third person regarding infringement 00015 or the like. Any license provided herein, whether implied or 00016 otherwise, applies only to this software file. Patent licenses, if 00017 any, provided herein do not apply to combinations of this program with 00018 other software, or any other product whatsoever. 00019 00020 You should have received a copy of the GNU General Public License along 00021 with this program; if not, write the Free Software Foundation, Inc., 59 00022 Temple Place - Suite 330, Boston MA 02111-1307, USA. 00023 00024 Contact information: Silicon Graphics, Inc., 1600 Amphitheatre Pky, 00025 Mountain View, CA 94043, or: 00026 00027 http://www.sgi.com 00028 00029 For further information regarding this notice, see: 00030 00031 http://oss.sgi.com/projects/GenInfo/NoticeExplan 00032 00033 */ 00034 00035 00036 00037 static char USMID[] = "\n@(#)5.0_pl/sources/p_io.c 5.3 06/17/99 09:28:10\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 # include "p_io.m" 00052 00053 # include "globals.h" 00054 # include "tokens.h" 00055 # include "sytb.h" 00056 # include "p_globals.h" 00057 # include "p_io.h" 00058 00059 /*****************************************************************\ 00060 |* function prototypes of static functions declared in this file *| 00061 \*****************************************************************/ 00062 extern long *_fmt_parse(void (**msg_rtn)(), char *, int, long *, boolean *); 00063 void emit_format_msg(int, int, int); 00064 static int find_ciitem_idx (io_stmt_type); 00065 static boolean parse_io_control_list (opnd_type *, io_stmt_type); 00066 static int pre_parse_format(int, int); 00067 static int create_format_tmp (int); 00068 00069 00070 /******************************************************************************\ 00071 |* *| 00072 |* Description: *| 00073 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 00074 |* *| 00075 |* Input parameters: *| 00076 |* NONE *| 00077 |* *| 00078 |* Output parameters: *| 00079 |* NONE *| 00080 |* *| 00081 |* Returns: *| 00082 |* NONE *| 00083 |* *| 00084 \******************************************************************************/ 00085 void parse_backspace_stmt (void) 00086 00087 { 00088 int call_idx; 00089 int list_idx; 00090 opnd_type opnd; 00091 boolean parsed_ok = TRUE; 00092 00093 00094 TRACE (Func_Entry, "parse_backspace_stmt", NULL); 00095 00096 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) { 00097 curr_stmt_category = Executable_Stmt_Cat; 00098 } 00099 00100 if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) || 00101 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) { 00102 PRINTMSG(TOKEN_LINE(token), 1262, Error, TOKEN_COLUMN(token), 00103 stmt_type_str[stmt_type], 00104 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure" : "elemental", 00105 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx))); 00106 } 00107 00108 INSERT_IO_START; 00109 00110 NTR_IR_TBL(call_idx); 00111 SH_IR_IDX(curr_stmt_sh_idx) = call_idx; 00112 00113 IR_OPR(call_idx) = Call_Opr; 00114 IR_TYPE_IDX(call_idx) = TYPELESS_DEFAULT_TYPE; 00115 IR_COL_NUM(call_idx) = TOKEN_COLUMN(token); 00116 IR_LINE_NUM(call_idx) = TOKEN_LINE(token); 00117 00118 /* left child is $BACK attr */ 00119 00120 if (glb_tbl_idx[Backspace_Attr_Idx] == NULL_IDX) { 00121 glb_tbl_idx[Backspace_Attr_Idx] = create_lib_entry_attr( 00122 BACKSPACE_LIB_ENTRY, 00123 BACKSPACE_NAME_LEN, 00124 TOKEN_LINE(token), 00125 TOKEN_COLUMN(token)); 00126 } 00127 00128 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Backspace_Attr_Idx]); 00129 00130 IR_FLD_L(call_idx) = AT_Tbl_Idx; 00131 IR_IDX_L(call_idx) = glb_tbl_idx[Backspace_Attr_Idx]; 00132 IR_LINE_NUM_L(call_idx) = TOKEN_LINE(token); 00133 IR_COL_NUM_L(call_idx) = TOKEN_COLUMN(token); 00134 00135 if (LA_CH_VALUE == LPAREN) { 00136 parsed_ok = parse_io_control_list(&opnd, Backspace); 00137 COPY_OPND(IR_OPND_R(call_idx), opnd); 00138 } 00139 else { 00140 /* call parse_expr to get external file unit */ 00141 parsed_ok = parse_expr(&opnd); 00142 NTR_IR_LIST_TBL(list_idx); 00143 IL_ARG_DESC_VARIANT(list_idx) = TRUE; 00144 IR_FLD_R(call_idx) = IL_Tbl_Idx; 00145 IR_IDX_R(call_idx) = list_idx; 00146 COPY_OPND(IL_OPND(list_idx), opnd); 00147 IR_LIST_CNT_R(call_idx) = 3; 00148 00149 /* add the blank arguments */ 00150 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 00151 list_idx = IL_NEXT_LIST_IDX(list_idx); 00152 IL_ARG_DESC_VARIANT(list_idx) = TRUE; 00153 00154 00155 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 00156 list_idx = IL_NEXT_LIST_IDX(list_idx); 00157 IL_ARG_DESC_VARIANT(list_idx) = TRUE; 00158 } 00159 00160 if (LA_CH_VALUE != EOS) { 00161 parse_err_flush(Find_EOS, EOS_STR); 00162 parsed_ok = FALSE; 00163 } 00164 00165 matched_specific_token(Tok_EOS, Tok_Class_Punct); 00166 00167 SH_ERR_FLG(curr_stmt_sh_idx) = ! parsed_ok; 00168 00169 INSERT_IO_END; 00170 00171 TRACE (Func_Exit, "parse_backspace_stmt", NULL); 00172 00173 return; 00174 00175 } /* parse_backspace_stmt */ 00176 00177 00178 /******************************************************************************\ 00179 |* *| 00180 |* Description: *| 00181 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 00182 |* *| 00183 |* Input parameters: *| 00184 |* NONE *| 00185 |* *| 00186 |* Output parameters: *| 00187 |* NONE *| 00188 |* *| 00189 |* Returns: *| 00190 |* NONE *| 00191 |* *| 00192 \******************************************************************************/ 00193 00194 void parse_buffer_stmt (void) 00195 00196 { 00197 boolean buffer_in; 00198 int ir_idx; 00199 int list1_idx; 00200 int list2_idx; 00201 int list3_idx; 00202 int list4_idx; 00203 opnd_type opnd; 00204 boolean parsed_ok = TRUE; 00205 00206 00207 TRACE (Func_Entry, "parse_buffer_stmt", NULL); 00208 00209 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) { 00210 curr_stmt_category = Executable_Stmt_Cat; 00211 } 00212 00213 INSERT_IO_START; 00214 00215 NTR_IR_TBL(ir_idx); 00216 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 00217 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token); 00218 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token); 00219 00220 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 00221 00222 IR_OPR(ir_idx) = Call_Opr; 00223 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 00224 00225 if (strcmp(TOKEN_STR(token), "IN") == 0) { 00226 00227 buffer_in = TRUE; 00228 00229 if (glb_tbl_idx[Buffer_In_Attr_Idx] == NULL_IDX) { 00230 glb_tbl_idx[Buffer_In_Attr_Idx] = 00231 create_lib_entry_attr(BUFFER_IN_LIB_ENTRY, 00232 BUFFER_IN_NAME_LEN, 00233 TOKEN_LINE(token), 00234 TOKEN_COLUMN(token)); 00235 } 00236 00237 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Buffer_In_Attr_Idx]); 00238 00239 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 00240 IR_IDX_L(ir_idx) = glb_tbl_idx[Buffer_In_Attr_Idx]; 00241 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token); 00242 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token); 00243 } 00244 else if (strcmp(TOKEN_STR(token), "OUT") == 0) { 00245 00246 buffer_in = FALSE; 00247 00248 if (glb_tbl_idx[Buffer_Out_Attr_Idx] == NULL_IDX) { 00249 glb_tbl_idx[Buffer_Out_Attr_Idx] = 00250 create_lib_entry_attr(BUFFER_OUT_LIB_ENTRY, 00251 BUFFER_OUT_NAME_LEN, 00252 TOKEN_LINE(token), 00253 TOKEN_COLUMN(token)); 00254 } 00255 00256 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Buffer_Out_Attr_Idx]); 00257 00258 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 00259 IR_IDX_L(ir_idx) = glb_tbl_idx[Buffer_Out_Attr_Idx]; 00260 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token); 00261 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token); 00262 } 00263 else { 00264 parsed_ok = FALSE; 00265 PRINTMSG(TOKEN_LINE(token), 197, Error, TOKEN_COLUMN(token), 00266 "IN or OUT",TOKEN_STR(token)); 00267 parse_err_flush(Find_EOS, NULL); 00268 goto EXIT; 00269 } 00270 00271 if (LA_CH_VALUE != LPAREN) { 00272 parse_err_flush(Find_EOS, "("); 00273 parsed_ok = FALSE; 00274 goto EXIT; 00275 } 00276 00277 if (cif_flags & MISC_RECS) { 00278 cif_stmt_type_rec(TRUE, 00279 (buffer_in) ? 00280 CIF_Buffer_In_Stmt : CIF_Buffer_Out_Stmt, 00281 statement_number); 00282 } 00283 00284 NEXT_LA_CH; 00285 00286 NTR_IR_LIST_TBL(list1_idx); 00287 NTR_IR_LIST_TBL(list2_idx); 00288 NTR_IR_LIST_TBL(list3_idx); 00289 NTR_IR_LIST_TBL(list4_idx); 00290 IR_FLD_R(ir_idx) = IL_Tbl_Idx; 00291 IR_LIST_CNT_R(ir_idx) = 4; 00292 IR_IDX_R(ir_idx) = list1_idx; 00293 IL_NEXT_LIST_IDX(list1_idx) = list2_idx; 00294 IL_NEXT_LIST_IDX(list2_idx) = list3_idx; 00295 IL_NEXT_LIST_IDX(list3_idx) = list4_idx; 00296 00297 IL_ARG_DESC_VARIANT(list1_idx) = TRUE; 00298 IL_ARG_DESC_VARIANT(list2_idx) = TRUE; 00299 IL_ARG_DESC_VARIANT(list3_idx) = TRUE; 00300 IL_ARG_DESC_VARIANT(list4_idx) = TRUE; 00301 00302 parsed_ok = parse_expr(&opnd) && parsed_ok; 00303 COPY_OPND(IL_OPND(list1_idx), opnd); 00304 00305 if (LA_CH_VALUE != COMMA) { 00306 parse_err_flush(Find_EOS, ","); 00307 parsed_ok = FALSE; 00308 goto EXIT; 00309 } 00310 00311 NEXT_LA_CH; 00312 00313 parsed_ok = parse_expr(&opnd) && parsed_ok; 00314 COPY_OPND(IL_OPND(list2_idx), opnd); 00315 00316 if (LA_CH_VALUE != RPAREN) { 00317 parse_err_flush(Find_EOS, ")"); 00318 parsed_ok = FALSE; 00319 goto EXIT; 00320 } 00321 00322 NEXT_LA_CH; 00323 00324 if (LA_CH_VALUE != LPAREN) { 00325 parse_err_flush(Find_EOS, "("); 00326 parsed_ok = FALSE; 00327 goto EXIT; 00328 } 00329 00330 NEXT_LA_CH; 00331 00332 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 00333 parsed_ok = parse_deref(&opnd, NULL_IDX) && parsed_ok; 00334 COPY_OPND(IL_OPND(list3_idx), opnd); 00335 00336 if (buffer_in) { 00337 mark_attr_defined(&opnd); 00338 } 00339 } 00340 else { 00341 parse_err_flush(Find_EOS, "IDENTIFIER"); 00342 parsed_ok = FALSE; 00343 goto EXIT; 00344 } 00345 00346 if (LA_CH_VALUE != COMMA) { 00347 parse_err_flush(Find_EOS, ","); 00348 parsed_ok = FALSE; 00349 goto EXIT; 00350 } 00351 00352 NEXT_LA_CH; 00353 00354 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 00355 parsed_ok = parse_deref(&opnd, NULL_IDX) && parsed_ok; 00356 COPY_OPND(IL_OPND(list4_idx), opnd); 00357 00358 if (buffer_in) { 00359 mark_attr_defined(&opnd); 00360 } 00361 } 00362 else { 00363 parse_err_flush(Find_EOS, "IDENTIFIER"); 00364 parsed_ok = FALSE; 00365 goto EXIT; 00366 } 00367 00368 if (LA_CH_VALUE != RPAREN) { 00369 parse_err_flush(Find_EOS, ")"); 00370 parsed_ok = FALSE; 00371 } 00372 else { 00373 NEXT_LA_CH; 00374 } 00375 } 00376 else { 00377 parse_err_flush(Find_EOS, "IN or OUT"); 00378 parsed_ok = FALSE; 00379 } 00380 00381 EXIT: 00382 00383 if (LA_CH_VALUE != EOS) { 00384 parse_err_flush(Find_EOS, EOS_STR); 00385 parsed_ok = FALSE; 00386 } 00387 00388 NEXT_LA_CH; 00389 00390 INSERT_IO_END; 00391 00392 TRACE (Func_Exit, "parse_buffer_stmt", NULL); 00393 00394 return; 00395 00396 } /* parse_buffer_stmt */ 00397 00398 /******************************************************************************\ 00399 |* *| 00400 |* Description: *| 00401 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 00402 |* *| 00403 |* Input parameters: *| 00404 |* NONE *| 00405 |* *| 00406 |* Output parameters: *| 00407 |* NONE *| 00408 |* *| 00409 |* Returns: *| 00410 |* NONE *| 00411 |* *| 00412 \******************************************************************************/ 00413 00414 void parse_close_stmt (void) 00415 00416 { 00417 int call_idx; 00418 opnd_type opnd; 00419 boolean parsed_ok = TRUE; 00420 00421 00422 TRACE (Func_Entry, "parse_close_stmt", NULL); 00423 00424 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) { 00425 curr_stmt_category = Executable_Stmt_Cat; 00426 } 00427 00428 if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) || 00429 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) { 00430 PRINTMSG(TOKEN_LINE(token), 1262, Error, TOKEN_COLUMN(token), 00431 stmt_type_str[stmt_type], 00432 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure" : "elemental", 00433 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx))); 00434 } 00435 00436 INSERT_IO_START; 00437 00438 NTR_IR_TBL(call_idx); 00439 SH_IR_IDX(curr_stmt_sh_idx) = call_idx; 00440 00441 IR_OPR(call_idx) = Call_Opr; 00442 IR_TYPE_IDX(call_idx) = TYPELESS_DEFAULT_TYPE; 00443 IR_COL_NUM(call_idx) = TOKEN_COLUMN(token); 00444 IR_LINE_NUM(call_idx) = TOKEN_LINE(token); 00445 00446 /* left child is $CLS attr */ 00447 00448 if (glb_tbl_idx[Close_Attr_Idx] == NULL_IDX) { 00449 glb_tbl_idx[Close_Attr_Idx] = create_lib_entry_attr(CLOSE_LIB_ENTRY, 00450 CLOSE_NAME_LEN, 00451 TOKEN_LINE(token), 00452 TOKEN_COLUMN(token)); 00453 } 00454 00455 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Close_Attr_Idx]); 00456 00457 IR_FLD_L(call_idx) = AT_Tbl_Idx; 00458 IR_IDX_L(call_idx) = glb_tbl_idx[Close_Attr_Idx]; 00459 IR_LINE_NUM_L(call_idx) = TOKEN_LINE(token); 00460 IR_COL_NUM_L(call_idx) = TOKEN_COLUMN(token); 00461 00462 parsed_ok = parse_io_control_list(&opnd, Close); 00463 COPY_OPND(IR_OPND_R(call_idx), opnd); 00464 00465 if (LA_CH_VALUE != EOS) { 00466 parse_err_flush(Find_EOS, EOS_STR); 00467 parsed_ok = FALSE; 00468 } 00469 00470 matched_specific_token(Tok_EOS, Tok_Class_Punct); 00471 00472 SH_ERR_FLG(curr_stmt_sh_idx) = ! parsed_ok; 00473 00474 INSERT_IO_END; 00475 00476 TRACE (Func_Exit, "parse_close_stmt", NULL); 00477 00478 return; 00479 00480 } /* parse_close_stmt */ 00481 00482 /******************************************************************************\ 00483 |* *| 00484 |* Description: *| 00485 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 00486 |* *| 00487 |* Input parameters: *| 00488 |* NONE *| 00489 |* *| 00490 |* Output parameters: *| 00491 |* NONE *| 00492 |* *| 00493 |* Returns: *| 00494 |* NONE *| 00495 |* *| 00496 \******************************************************************************/ 00497 00498 void parse_decode_stmt (void) 00499 00500 { 00501 00502 /* This is legal code. */ 00503 /* character*8 old_char(10) */ 00504 /* encode(8, 10, char) (old_char(i),i=1,8) */ 00505 /* 10 format(a) */ 00506 /* end */ 00507 00508 int attr_idx; 00509 int buf_idx; 00510 int column; 00511 int idx; 00512 int ir_idx; 00513 int line; 00514 int list_idx; 00515 int list1_idx; 00516 int list2_idx; 00517 int list3_idx; 00518 int name_idx; 00519 opnd_type opnd; 00520 boolean parsed_ok = TRUE; 00521 int pre_parse_format_idx; 00522 00523 00524 TRACE (Func_Entry, "parse_decode_stmt", NULL); 00525 00526 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) { 00527 curr_stmt_category = Executable_Stmt_Cat; 00528 } 00529 00530 INSERT_IO_START; 00531 00532 NTR_IR_TBL(ir_idx); 00533 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 00534 00535 IR_OPR(ir_idx) = Read_Formatted_Opr; 00536 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 00537 column = TOKEN_COLUMN(token); 00538 IR_COL_NUM(ir_idx) = column; 00539 line = TOKEN_LINE(token); 00540 IR_LINE_NUM(ir_idx) = line; 00541 00542 if (LA_CH_VALUE == LPAREN) { 00543 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 00544 IR_LIST_CNT_L(ir_idx) = 3; 00545 NTR_IR_LIST_TBL(list1_idx); 00546 NTR_IR_LIST_TBL(list2_idx); 00547 NTR_IR_LIST_TBL(list3_idx); 00548 IR_IDX_L(ir_idx) = list1_idx; 00549 IL_NEXT_LIST_IDX(list1_idx) = list2_idx; 00550 IL_NEXT_LIST_IDX(list2_idx) = list3_idx; 00551 IL_PREV_LIST_IDX(list2_idx) = list1_idx; 00552 IL_PREV_LIST_IDX(list3_idx) = list2_idx; 00553 00554 NEXT_LA_CH; 00555 00556 parsed_ok = parse_expr(&opnd); 00557 COPY_OPND(IL_OPND(list1_idx), opnd); 00558 00559 if (LA_CH_VALUE != COMMA) { 00560 parse_err_flush(Find_Rparen, ","); 00561 parsed_ok = FALSE; 00562 } 00563 else { 00564 00565 NEXT_LA_CH; 00566 00567 buf_idx = LA_CH_BUF_IDX; 00568 00569 if (LA_CH_CLASS == Ch_Class_Digit && 00570 digit_is_format_label()) { 00571 00572 if (MATCHED_TOKEN_CLASS(Tok_Class_Label) && 00573 ! TOKEN_ERR(token)) { 00574 00575 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), 00576 &name_idx); 00577 00578 if (attr_idx == NULL_IDX) { 00579 attr_idx = ntr_sym_tbl(&token, name_idx); 00580 AT_OBJ_CLASS(attr_idx) = Label; 00581 LN_DEF_LOC(name_idx) = TRUE; 00582 build_fwd_ref_entry(attr_idx, Format_Ref); 00583 } 00584 else if ( ! AT_DCL_ERR(attr_idx) ) { 00585 00586 if (!AT_DEFINED(attr_idx)) { 00587 build_fwd_ref_entry(attr_idx, Format_Ref); 00588 } 00589 else if (ATL_CLASS(attr_idx) != Lbl_Format) { 00590 /* error .. label used previously as something else */ 00591 PRINTMSG(TOKEN_LINE(token), 328, Error, 00592 TOKEN_COLUMN(token), 00593 AT_OBJ_NAME_PTR(attr_idx)); 00594 parsed_ok = FALSE; 00595 } 00596 00597 } 00598 else { 00599 /* no message , at_dcl_err is set */ 00600 parsed_ok = FALSE; 00601 } 00602 00603 IL_FLD(list2_idx) = AT_Tbl_Idx; 00604 IL_IDX(list2_idx) = attr_idx; 00605 IL_LINE_NUM(list2_idx) = TOKEN_LINE(token); 00606 IL_COL_NUM(list2_idx) = TOKEN_COLUMN(token); 00607 00608 if (cif_flags & XREF_RECS) { 00609 cif_usage_rec(attr_idx, AT_Tbl_Idx, 00610 TOKEN_LINE(token), TOKEN_COLUMN(token), 00611 CIF_Label_Referenced_As_Format); 00612 } 00613 00614 } 00615 else if (TOKEN_ERR(token)) { 00616 parse_err_flush(Find_Comma, NULL); 00617 parsed_ok = FALSE; 00618 } 00619 else { 00620 parse_err_flush(Find_Comma, "LABEL"); 00621 parsed_ok = FALSE; 00622 } 00623 } 00624 else { 00625 parsed_ok = parse_expr(&opnd) && parsed_ok; 00626 COPY_OPND(IL_OPND(list2_idx), opnd); 00627 } 00628 00629 if (parsed_ok && 00630 IL_FLD(list2_idx) == CN_Tbl_Idx && 00631 TYP_TYPE(CN_TYPE_IDX(IL_IDX(list2_idx))) == Character) { 00632 00633 /* preparse format constant */ 00634 set_format_start_idx(buf_idx); 00635 00636 format_cn_idx = IL_IDX(list2_idx); 00637 # ifndef SOURCE_TO_SOURCE 00638 ignore_trailing_chars = TRUE; 00639 pre_parse_format_idx = pre_parse_format(format_cn_idx, 0); 00640 ignore_trailing_chars = FALSE; 00641 # endif 00642 00643 NTR_IR_LIST_TBL(list_idx); 00644 IL_FLD(list2_idx) = IL_Tbl_Idx; 00645 IL_IDX(list2_idx) = list_idx; 00646 IL_LIST_CNT(list2_idx) = 2; 00647 00648 IL_FLD(list_idx) = AT_Tbl_Idx; 00649 idx = create_format_tmp(format_cn_idx); 00650 IL_IDX(list_idx) = idx; 00651 IL_LINE_NUM(list_idx) = line; 00652 IL_COL_NUM(list_idx) = column; 00653 00654 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 00655 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 00656 list_idx = IL_NEXT_LIST_IDX(list_idx); 00657 00658 # ifndef SOURCE_TO_SOURCE 00659 if (pre_parse_format_idx != NULL_IDX) { 00660 IL_FLD(list_idx) = AT_Tbl_Idx; 00661 idx = create_format_tmp(pre_parse_format_idx); 00662 IL_IDX(list_idx) = idx; 00663 IL_LINE_NUM(list_idx) = line; 00664 IL_COL_NUM(list_idx) = column; 00665 } 00666 # endif 00667 00668 } 00669 00670 if (LA_CH_VALUE != COMMA) { 00671 parse_err_flush(Find_Rparen, ","); 00672 parsed_ok = FALSE; 00673 } 00674 else { 00675 NEXT_LA_CH; 00676 00677 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 00678 parsed_ok = parse_deref(&opnd, NULL_IDX) && parsed_ok; 00679 COPY_OPND(IL_OPND(list3_idx), opnd); 00680 } 00681 else { 00682 parse_err_flush(Find_Rparen, "IDENTIFIER"); 00683 parsed_ok = FALSE; 00684 } 00685 } 00686 00687 if (LA_CH_VALUE != RPAREN) { 00688 00689 if (parse_err_flush(Find_Rparen, ")")) { 00690 NEXT_LA_CH; 00691 } 00692 parsed_ok = FALSE; 00693 } 00694 else { 00695 NEXT_LA_CH; 00696 } 00697 } 00698 00699 if (LA_CH_VALUE != EOS) { 00700 00701 parsed_ok = parse_io_list(&opnd) && parsed_ok; 00702 COPY_OPND(IR_OPND_R(ir_idx), opnd); 00703 } 00704 } 00705 else { 00706 parse_err_flush(Find_EOS, "("); 00707 parsed_ok = FALSE; 00708 } 00709 00710 if (LA_CH_VALUE != EOS) { 00711 parse_err_flush(Find_EOS, EOS_STR); 00712 parsed_ok = FALSE; 00713 } 00714 00715 matched_specific_token(Tok_EOS, Tok_Class_Punct); 00716 00717 INSERT_IO_END; 00718 00719 TRACE (Func_Exit, "parse_decode_stmt", NULL); 00720 00721 return; 00722 00723 } /* parse_decode_stmt */ 00724 00725 /******************************************************************************\ 00726 |* *| 00727 |* Description: *| 00728 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 00729 |* *| 00730 |* Input parameters: *| 00731 |* NONE *| 00732 |* *| 00733 |* Output parameters: *| 00734 |* NONE *| 00735 |* *| 00736 |* Returns: *| 00737 |* NONE *| 00738 |* *| 00739 \******************************************************************************/ 00740 00741 void parse_encode_stmt (void) 00742 00743 { 00744 int attr_idx; 00745 int buf_idx; 00746 int column; 00747 int idx; 00748 int ir_idx; 00749 int line; 00750 int list_idx; 00751 int list1_idx; 00752 int list2_idx; 00753 int list3_idx; 00754 int name_idx; 00755 opnd_type opnd; 00756 boolean parsed_ok = TRUE; 00757 int pre_parse_format_idx; 00758 00759 00760 TRACE (Func_Entry, "parse_encode_stmt", NULL); 00761 00762 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) { 00763 curr_stmt_category = Executable_Stmt_Cat; 00764 } 00765 00766 INSERT_IO_START; 00767 00768 NTR_IR_TBL(ir_idx); 00769 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 00770 00771 IR_OPR(ir_idx) = Write_Formatted_Opr; 00772 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 00773 column = TOKEN_COLUMN(token); 00774 IR_COL_NUM(ir_idx) = column; 00775 line = TOKEN_LINE(token); 00776 IR_LINE_NUM(ir_idx) = line; 00777 00778 if (LA_CH_VALUE == LPAREN) { 00779 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 00780 IR_LIST_CNT_L(ir_idx) = 3; 00781 NTR_IR_LIST_TBL(list1_idx); 00782 NTR_IR_LIST_TBL(list2_idx); 00783 NTR_IR_LIST_TBL(list3_idx); 00784 IR_IDX_L(ir_idx) = list1_idx; 00785 IL_NEXT_LIST_IDX(list1_idx) = list2_idx; 00786 IL_NEXT_LIST_IDX(list2_idx) = list3_idx; 00787 IL_PREV_LIST_IDX(list2_idx) = list1_idx; 00788 IL_PREV_LIST_IDX(list3_idx) = list2_idx; 00789 00790 NEXT_LA_CH; 00791 00792 parsed_ok = parse_expr(&opnd); 00793 COPY_OPND(IL_OPND(list1_idx), opnd); 00794 00795 if (LA_CH_VALUE != COMMA) { 00796 parse_err_flush(Find_Rparen, ","); 00797 parsed_ok = FALSE; 00798 } 00799 else { 00800 00801 NEXT_LA_CH; 00802 00803 buf_idx = LA_CH_BUF_IDX; 00804 00805 if (LA_CH_CLASS == Ch_Class_Digit && 00806 digit_is_format_label()) { 00807 00808 if (MATCHED_TOKEN_CLASS(Tok_Class_Label) && 00809 ! TOKEN_ERR(token)) { 00810 00811 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), 00812 &name_idx); 00813 00814 if (attr_idx == NULL_IDX) { 00815 attr_idx = ntr_sym_tbl(&token, name_idx); 00816 AT_OBJ_CLASS(attr_idx) = Label; 00817 LN_DEF_LOC(name_idx) = TRUE; 00818 build_fwd_ref_entry(attr_idx, Format_Ref); 00819 } 00820 else if ( ! AT_DCL_ERR(attr_idx) ) { 00821 00822 if (!AT_DEFINED(attr_idx)) { 00823 build_fwd_ref_entry(attr_idx, Format_Ref); 00824 } 00825 else if (ATL_CLASS(attr_idx) != Lbl_Format) { 00826 /* error .. label used previously as something else */ 00827 PRINTMSG(TOKEN_LINE(token), 328, Error, 00828 TOKEN_COLUMN(token), 00829 AT_OBJ_NAME_PTR(attr_idx)); 00830 parsed_ok = FALSE; 00831 } 00832 00833 } 00834 else { 00835 /* no message, at_dcl_err is set */ 00836 parsed_ok = FALSE; 00837 } 00838 00839 IL_FLD(list2_idx) = AT_Tbl_Idx; 00840 IL_IDX(list2_idx) = attr_idx; 00841 IL_LINE_NUM(list2_idx) = TOKEN_LINE(token); 00842 IL_COL_NUM(list2_idx) = TOKEN_COLUMN(token); 00843 00844 if (cif_flags & XREF_RECS) { 00845 cif_usage_rec(attr_idx, AT_Tbl_Idx, 00846 TOKEN_LINE(token), TOKEN_COLUMN(token), 00847 CIF_Label_Referenced_As_Format); 00848 } 00849 } 00850 else if (TOKEN_ERR(token)) { 00851 parse_err_flush(Find_Comma, NULL); 00852 parsed_ok = FALSE; 00853 } 00854 else { 00855 parse_err_flush(Find_Comma, "LABEL"); 00856 parsed_ok = FALSE; 00857 } 00858 } 00859 else { 00860 parsed_ok = parse_expr(&opnd) && parsed_ok; 00861 COPY_OPND(IL_OPND(list2_idx), opnd); 00862 } 00863 00864 if (parsed_ok && 00865 IL_FLD(list2_idx) == CN_Tbl_Idx && 00866 TYP_TYPE(CN_TYPE_IDX(IL_IDX(list2_idx))) == Character) { 00867 00868 /* preparse format constant */ 00869 set_format_start_idx(buf_idx); 00870 00871 format_cn_idx = IL_IDX(list2_idx); 00872 # ifndef SOURCE_TO_SOURCE 00873 ignore_trailing_chars = TRUE; 00874 pre_parse_format_idx = pre_parse_format(format_cn_idx, 0); 00875 ignore_trailing_chars = FALSE; 00876 # endif 00877 00878 NTR_IR_LIST_TBL(list_idx); 00879 IL_FLD(list2_idx) = IL_Tbl_Idx; 00880 IL_IDX(list2_idx) = list_idx; 00881 IL_LIST_CNT(list2_idx) = 2; 00882 00883 IL_FLD(list_idx) = AT_Tbl_Idx; 00884 idx = create_format_tmp(format_cn_idx); 00885 IL_IDX(list_idx) = idx; 00886 IL_LINE_NUM(list_idx) = line; 00887 IL_COL_NUM(list_idx) = column; 00888 00889 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 00890 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 00891 list_idx = IL_NEXT_LIST_IDX(list_idx); 00892 # ifndef SOURCE_TO_SOURCE 00893 if (pre_parse_format_idx != NULL_IDX) { 00894 IL_FLD(list_idx) = AT_Tbl_Idx; 00895 idx = create_format_tmp(pre_parse_format_idx); 00896 IL_IDX(list_idx) = idx; 00897 IL_LINE_NUM(list_idx) = line; 00898 IL_COL_NUM(list_idx) = column; 00899 } 00900 # endif 00901 00902 } 00903 00904 if (LA_CH_VALUE != COMMA) { 00905 parse_err_flush(Find_Rparen, ","); 00906 parsed_ok = FALSE; 00907 } 00908 else { 00909 NEXT_LA_CH; 00910 00911 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 00912 parsed_ok = parse_deref(&opnd, NULL_IDX) && parsed_ok; 00913 COPY_OPND(IL_OPND(list3_idx), opnd); 00914 00915 mark_attr_defined(&opnd); 00916 } 00917 else { 00918 parse_err_flush(Find_Rparen, "IDENTIFIER"); 00919 parsed_ok = FALSE; 00920 } 00921 } 00922 00923 if (LA_CH_VALUE != RPAREN) { 00924 00925 if (parse_err_flush(Find_Rparen, ")")) { 00926 NEXT_LA_CH; 00927 } 00928 parsed_ok = FALSE; 00929 } 00930 else { 00931 NEXT_LA_CH; 00932 } 00933 } 00934 00935 if (LA_CH_VALUE != EOS) { 00936 00937 parsed_ok = parse_io_list(&opnd) && parsed_ok; 00938 COPY_OPND(IR_OPND_R(ir_idx), opnd); 00939 } 00940 } 00941 else { 00942 parse_err_flush(Find_EOS, "("); 00943 parsed_ok = FALSE; 00944 } 00945 00946 if (LA_CH_VALUE != EOS) { 00947 parse_err_flush(Find_EOS, EOS_STR); 00948 parsed_ok = FALSE; 00949 } 00950 00951 matched_specific_token(Tok_EOS, Tok_Class_Punct); 00952 00953 INSERT_IO_END; 00954 00955 TRACE (Func_Exit, "parse_encode_stmt", NULL); 00956 00957 return; 00958 00959 } /* parse_encode_stmt */ 00960 00961 00962 /******************************************************************************\ 00963 |* *| 00964 |* Description: *| 00965 |* Parses the ENDFILE statement. At entry the TOKEN is FILE. *| 00966 |* Called from parse_end_stmt. *| 00967 |* *| 00968 |* Input parameters: *| 00969 |* NONE *| 00970 |* *| 00971 |* Output parameters: *| 00972 |* NONE *| 00973 |* *| 00974 |* Returns: *| 00975 |* NONE *| 00976 |* *| 00977 \******************************************************************************/ 00978 00979 void parse_endfile_stmt (void) 00980 00981 { 00982 int call_idx; 00983 int list_idx; 00984 opnd_type opnd; 00985 boolean parsed_ok = TRUE; 00986 00987 00988 TRACE (Func_Entry, "parse_endfile_stmt", NULL); 00989 00990 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) { 00991 curr_stmt_category = Executable_Stmt_Cat; 00992 } 00993 00994 if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) || 00995 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) { 00996 PRINTMSG(TOKEN_LINE(token), 1262, Error, TOKEN_COLUMN(token), 00997 stmt_type_str[stmt_type], 00998 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure" : "elemental", 00999 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx))); 01000 } 01001 01002 if (cif_flags & MISC_RECS) { 01003 cif_stmt_type_rec(TRUE, CIF_Endfile_Stmt, statement_number); 01004 } 01005 01006 INSERT_IO_START; 01007 01008 NTR_IR_TBL(call_idx); 01009 SH_IR_IDX(curr_stmt_sh_idx) = call_idx; 01010 01011 IR_OPR(call_idx) = Call_Opr; 01012 IR_TYPE_IDX(call_idx) = TYPELESS_DEFAULT_TYPE; 01013 IR_COL_NUM(call_idx) = TOKEN_COLUMN(token); 01014 IR_LINE_NUM(call_idx) = TOKEN_LINE(token); 01015 01016 /* left child is endfile attr */ 01017 01018 if (glb_tbl_idx[Endfile_Attr_Idx] == NULL_IDX) { 01019 glb_tbl_idx[Endfile_Attr_Idx] = create_lib_entry_attr(ENDFILE_LIB_ENTRY, 01020 ENDFILE_NAME_LEN, 01021 TOKEN_LINE(token), 01022 TOKEN_COLUMN(token)); 01023 } 01024 01025 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Endfile_Attr_Idx]); 01026 01027 IR_FLD_L(call_idx) = AT_Tbl_Idx; 01028 IR_IDX_L(call_idx) = glb_tbl_idx[Endfile_Attr_Idx]; 01029 01030 IR_LINE_NUM_L(call_idx) = TOKEN_LINE(token); 01031 IR_COL_NUM_L(call_idx) = TOKEN_COLUMN(token); 01032 01033 if (LA_CH_VALUE == LPAREN) { 01034 parsed_ok = parse_io_control_list(&opnd, Endfile); 01035 COPY_OPND(IR_OPND_R(call_idx), opnd); 01036 } 01037 else { 01038 /* call parse_expr to get external file unit */ 01039 parsed_ok = parse_expr(&opnd); 01040 NTR_IR_LIST_TBL(list_idx); 01041 IL_ARG_DESC_VARIANT(list_idx) = TRUE; 01042 IR_FLD_R(call_idx) = IL_Tbl_Idx; 01043 IR_IDX_R(call_idx) = list_idx; 01044 COPY_OPND(IL_OPND(list_idx), opnd); 01045 IR_LIST_CNT_R(call_idx) = 3; 01046 01047 /* add the blank arguments */ 01048 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 01049 list_idx = IL_NEXT_LIST_IDX(list_idx); 01050 IL_ARG_DESC_VARIANT(list_idx) = TRUE; 01051 01052 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 01053 list_idx = IL_NEXT_LIST_IDX(list_idx); 01054 IL_ARG_DESC_VARIANT(list_idx) = TRUE; 01055 } 01056 01057 if (LA_CH_VALUE != EOS) { 01058 parse_err_flush(Find_EOS, EOS_STR); 01059 parsed_ok = FALSE; 01060 } 01061 01062 matched_specific_token(Tok_EOS, Tok_Class_Punct); 01063 01064 SH_ERR_FLG(curr_stmt_sh_idx) = ! parsed_ok; 01065 01066 INSERT_IO_END; 01067 01068 TRACE (Func_Exit, "parse_endfile_stmt", NULL); 01069 01070 return; 01071 01072 } /* parse_endfile_stmt */ 01073 01074 01075 /******************************************************************************\ 01076 |* *| 01077 |* Description: *| 01078 |* Parse FORMAT statement. *| 01079 |* *| 01080 |* Input parameters: *| 01081 |* NONE *| 01082 |* *| 01083 |* Output parameters: *| 01084 |* NONE *| 01085 |* *| 01086 |* Returns: *| 01087 |* NONE *| 01088 |* *| 01089 \******************************************************************************/ 01090 01091 void parse_format_stmt (void) 01092 01093 { 01094 int pre_parse_format_idx; 01095 int tmp_idx; 01096 int ir_idx; 01097 01098 01099 TRACE (Func_Entry, "parse_format_stmt", NULL); 01100 01101 if (LA_CH_VALUE == LPAREN) { 01102 01103 if (CURR_BLK_NO_EXEC && iss_blk_stk_err()) { 01104 01105 /* FORMAT statements are only allowed in contexts */ 01106 /* where executable statements are allowed. */ 01107 01108 parse_err_flush(Find_EOS, NULL); 01109 goto EXIT; 01110 } 01111 01112 if (curr_stmt_category < Implicit_None_Stmt_Cat) { 01113 curr_stmt_category = Implicit_None_Stmt_Cat; 01114 } 01115 01116 if (stmt_label_idx == NULL_IDX) { 01117 PRINTMSG(TOKEN_LINE(token), 135, Error, TOKEN_COLUMN(token)); 01118 parse_err_flush(Find_EOS, NULL); 01119 goto EXIT; 01120 } 01121 01122 ATL_CLASS(stmt_label_idx) = Lbl_Format; 01123 01124 01125 if (MATCHED_TOKEN_CLASS(Tok_Class_Format_Str)) { 01126 set_format_start_idx(TOKEN_BUF_IDX(token) - 1); 01127 format_cn_idx = TOKEN_CONST_TBL_IDX(token); 01128 01129 # ifndef SOURCE_TO_SOURCE 01130 pre_parse_format_idx = pre_parse_format(format_cn_idx, 01131 AT_NAME_LEN(stmt_label_idx)); 01132 # endif 01133 tmp_idx = create_format_tmp(format_cn_idx); 01134 01135 ATL_FORMAT_TMP(stmt_label_idx) = tmp_idx; 01136 01137 # ifndef SOURCE_TO_SOURCE 01138 if (pre_parse_format_idx != NULL_IDX) { 01139 tmp_idx = create_format_tmp(pre_parse_format_idx); 01140 ATL_PP_FORMAT_TMP(stmt_label_idx) = tmp_idx; 01141 } 01142 else { 01143 ATL_PP_FORMAT_TMP(stmt_label_idx) = NULL_IDX; 01144 } 01145 # else 01146 ATL_PP_FORMAT_TMP(stmt_label_idx) = NULL_IDX; 01147 # endif 01148 01149 if (LA_CH_VALUE != EOS) { 01150 PRINTMSG(LA_CH_LINE, 166, Error, LA_CH_COLUMN); 01151 parse_err_flush(Find_EOS, NULL); 01152 } 01153 } 01154 else { 01155 /* ERROR */ 01156 } 01157 } 01158 else { /* Not FORMAT(... */ 01159 parse_err_flush(Find_EOS, "("); 01160 } 01161 EXIT: 01162 01163 matched_specific_token(Tok_EOS, Tok_Class_Punct); 01164 TRACE (Func_Exit, "parse_format_stmt", NULL); 01165 01166 return; 01167 01168 } /* parse_format_stmt */ 01169 01170 /******************************************************************************\ 01171 |* *| 01172 |* Description: *| 01173 |* This routine is called directly by the format parser to print out *| 01174 |* format messages. (This includes ANSI's). *| 01175 |* *| 01176 |* Input parameters: *| 01177 |* msg_num -> Msg number to print out. (This is the format parser msg *| 01178 |* number. It is translated to a cft90 msg, using the *| 01179 |* msg_num_tbl in p_io.h. *| 01180 |* col -> Column number where msg is found. *| 01181 |* ed_col -> Column number where edit descriptor is found. *| 01182 |* *| 01183 |* Output parameters: *| 01184 |* NONE *| 01185 |* *| 01186 |* Returns: *| 01187 |* NONE *| 01188 |* *| 01189 \******************************************************************************/ 01190 void emit_format_msg(int msg_num, 01191 int column, 01192 int ed_column) 01193 01194 { 01195 int line; 01196 char ch; 01197 int col; 01198 int ed_idx; 01199 01200 01201 switch (msg_num) { 01202 case TRAILING_CHARS: 01203 01204 if (ignore_trailing_chars) { 01205 goto EXIT; 01206 } 01207 01208 format_line_n_col(&line, &col, ed_column); 01209 ed_idx = column; 01210 break; 01211 01212 case ANSI_EMPTY_PAREN_MSG: 01213 case MINUS_X_NON_ANSI: 01214 case H_IS_OBSOLETE_IN_F90: 01215 case EXPECTING_RIGHT_PAREN: 01216 case NON_ANSI_NULL_DESCRIPTOR: 01217 case E_WITH_D_NON_ANSI: 01218 01219 format_line_n_col(&line, &col, ed_column); 01220 ed_idx = column; 01221 break; 01222 01223 case REP_SLASH_NON_ANSI: 01224 01225 /* This is rep count on slash is not standard message. Does not */ 01226 /* apply to cft90. */ 01227 01228 goto EXIT; 01229 01230 case MISSING_WIDTH_NON_ANSI: 01231 case ZERO_WIDTH_NON_ANSI: 01232 format_line_n_col(&line, &col, ed_column); 01233 ed_idx = ed_column; 01234 break; 01235 01236 case NON_ANSI_EDIT_DESCRIPTOR: 01237 format_line_n_col(&line, &col, ed_column); 01238 ed_idx = ed_column; 01239 01240 if (stmt_type == Format_Stmt) { 01241 ch = ((char *)&CN_CONST(format_cn_idx) + 01242 AT_NAME_LEN(stmt_label_idx))[ed_idx - 1]; 01243 } 01244 else { 01245 ch = ((char *)&CN_CONST(format_cn_idx))[ed_idx - 1]; 01246 } 01247 01248 switch (ch) { 01249 case '*': 01250 case '$': 01251 case 'R': 01252 case 'r': 01253 case 'X': 01254 case 'x': 01255 break; 01256 01257 default: 01258 goto EXIT; /* B, O, Z, ", R are standard in Fortran 90 */ 01259 01260 } /* End switch */ 01261 01262 break; 01263 01264 case INVALID_REP_COUNT: 01265 format_line_n_col(&line, &col, column); 01266 ed_idx = ed_column; 01267 break; 01268 01269 default : 01270 format_line_n_col(&line, &col, column); 01271 ed_idx = column; 01272 break; 01273 } 01274 01275 switch (msg_num_tbl[msg_num].num_args) { 01276 case 0: 01277 PRINTMSG(line, 01278 msg_num_tbl[msg_num].msg_num, 01279 msg_num_tbl[msg_num].msg_severity, 01280 col); 01281 break; 01282 01283 case 1: 01284 if (stmt_type == Format_Stmt) { 01285 PRINTMSG(line, 01286 msg_num_tbl[msg_num].msg_num, 01287 msg_num_tbl[msg_num].msg_severity, 01288 col, 01289 ((char *)&CN_CONST(format_cn_idx)) 01290 [AT_NAME_LEN(stmt_label_idx) + ed_idx - 1]); 01291 } 01292 else { 01293 PRINTMSG(line, 01294 msg_num_tbl[msg_num].msg_num, 01295 msg_num_tbl[msg_num].msg_severity, 01296 col, 01297 ((char *)&CN_CONST(format_cn_idx))[ed_idx - 1]); 01298 } 01299 break; 01300 } 01301 01302 EXIT: 01303 01304 return; 01305 } 01306 01307 01308 /******************************************************************************\ 01309 |* *| 01310 |* Description: *| 01311 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 01312 |* *| 01313 |* Input parameters: *| 01314 |* NONE *| 01315 |* *| 01316 |* Output parameters: *| 01317 |* NONE *| 01318 |* *| 01319 |* Returns: *| 01320 |* NONE *| 01321 |* *| 01322 \******************************************************************************/ 01323 01324 void parse_inquire_stmt (void) 01325 01326 { 01327 int buf_idx; 01328 int call_idx; 01329 int list_idx; 01330 opnd_type opnd; 01331 boolean parsed_ok = TRUE; 01332 int stmt_num; 01333 01334 01335 TRACE (Func_Entry, "parse_inquire_stmt", NULL); 01336 01337 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) { 01338 curr_stmt_category = Executable_Stmt_Cat; 01339 } 01340 01341 if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) || 01342 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) { 01343 PRINTMSG(TOKEN_LINE(token), 1262, Error, TOKEN_COLUMN(token), 01344 stmt_type_str[stmt_type], 01345 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure" : "elemental", 01346 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx))); 01347 } 01348 01349 INSERT_IO_START; 01350 01351 NTR_IR_TBL(call_idx); 01352 SH_IR_IDX(curr_stmt_sh_idx) = call_idx; 01353 01354 IR_COL_NUM(call_idx) = TOKEN_COLUMN(token); 01355 IR_LINE_NUM(call_idx) = TOKEN_LINE(token); 01356 IR_TYPE_IDX(call_idx) = TYPELESS_DEFAULT_TYPE; 01357 01358 IR_LINE_NUM_L(call_idx) = TOKEN_LINE(token); 01359 IR_COL_NUM_L(call_idx) = TOKEN_COLUMN(token); 01360 01361 if (LA_CH_VALUE == LPAREN) { 01362 buf_idx = LA_CH_BUF_IDX; 01363 stmt_num = LA_CH_STMT_NUM; 01364 NEXT_LA_CH; 01365 01366 if (LA_CH_VALUE == 'I' && 01367 MATCHED_TOKEN_CLASS(Tok_Class_Id) && 01368 strcmp(TOKEN_STR(token),"IOLENGTH") == 0 && 01369 LA_CH_VALUE == EQUAL) { 01370 01371 IR_OPR(call_idx) = Inquire_Iolength_Opr; 01372 01373 NEXT_LA_CH; 01374 NTR_IR_LIST_TBL(list_idx); 01375 IR_FLD_L(call_idx) = IL_Tbl_Idx; 01376 IR_IDX_L(call_idx) = list_idx; 01377 IR_LIST_CNT_L(call_idx) = 1; 01378 01379 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 01380 parsed_ok = parse_deref(&opnd, NULL_IDX); 01381 COPY_OPND(IL_OPND(list_idx), opnd); 01382 01383 mark_attr_defined(&opnd); 01384 } 01385 else { 01386 parse_err_flush(Find_Rparen, "IDENTIFIER"); 01387 parsed_ok = FALSE; 01388 } 01389 01390 if (LA_CH_VALUE == RPAREN) { 01391 NEXT_LA_CH; 01392 if (LA_CH_VALUE != EOS) { 01393 parsed_ok = parse_io_list(&opnd) && parsed_ok; 01394 COPY_OPND(IR_OPND_R(call_idx), opnd); 01395 } 01396 } 01397 else { 01398 parse_err_flush(Find_EOS, ")"); 01399 parsed_ok = FALSE; 01400 } 01401 } 01402 else { 01403 reset_lex(buf_idx, stmt_num); 01404 01405 IR_OPR(call_idx) = Call_Opr; 01406 01407 /* left child is inquire attr */ 01408 01409 if (glb_tbl_idx[Inquire_Attr_Idx] == NULL_IDX) { 01410 glb_tbl_idx[Inquire_Attr_Idx] = create_lib_entry_attr( 01411 INQUIRE_LIB_ENTRY, 01412 INQUIRE_NAME_LEN, 01413 TOKEN_LINE(token), 01414 TOKEN_COLUMN(token)); 01415 } 01416 01417 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Inquire_Attr_Idx]); 01418 01419 IR_FLD_L(call_idx) = AT_Tbl_Idx; 01420 IR_IDX_L(call_idx) = glb_tbl_idx[Inquire_Attr_Idx]; 01421 IR_LINE_NUM_L(call_idx) = IR_LINE_NUM(call_idx); 01422 IR_COL_NUM_L(call_idx) = IR_COL_NUM(call_idx); 01423 01424 parsed_ok = parse_io_control_list(&opnd, Inquire); 01425 COPY_OPND(IR_OPND_R(call_idx), opnd); 01426 } 01427 } 01428 else { 01429 parse_err_flush(Find_EOS, "("); 01430 parsed_ok = FALSE; 01431 } 01432 01433 if (LA_CH_VALUE != EOS) { 01434 parse_err_flush(Find_EOS, EOS_STR); 01435 parsed_ok = FALSE; 01436 } 01437 01438 matched_specific_token(Tok_EOS, Tok_Class_Punct); 01439 01440 SH_ERR_FLG(curr_stmt_sh_idx) = ! parsed_ok; 01441 01442 INSERT_IO_END; 01443 01444 TRACE (Func_Exit, "parse_inquire_stmt", NULL); 01445 01446 return; 01447 01448 } /* parse_inquire_stmt */ 01449 01450 /******************************************************************************\ 01451 |* *| 01452 |* Description: *| 01453 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 01454 |* *| 01455 |* Input parameters: *| 01456 |* NONE *| 01457 |* *| 01458 |* Output parameters: *| 01459 |* NONE *| 01460 |* *| 01461 |* Returns: *| 01462 |* NONE *| 01463 |* *| 01464 \******************************************************************************/ 01465 01466 void parse_open_stmt (void) 01467 01468 { 01469 int call_idx; 01470 opnd_type opnd; 01471 boolean parsed_ok = TRUE; 01472 01473 01474 TRACE (Func_Entry, "parse_open_stmt", NULL); 01475 01476 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) { 01477 curr_stmt_category = Executable_Stmt_Cat; 01478 } 01479 01480 if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) || 01481 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) { 01482 PRINTMSG(TOKEN_LINE(token), 1262, Error, TOKEN_COLUMN(token), 01483 stmt_type_str[stmt_type], 01484 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure" : "elemental", 01485 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx))); 01486 } 01487 01488 INSERT_IO_START; 01489 01490 NTR_IR_TBL(call_idx); 01491 SH_IR_IDX(curr_stmt_sh_idx) = call_idx; 01492 01493 IR_OPR(call_idx) = Call_Opr; 01494 IR_TYPE_IDX(call_idx) = TYPELESS_DEFAULT_TYPE; 01495 IR_COL_NUM(call_idx) = TOKEN_COLUMN(token); 01496 IR_LINE_NUM(call_idx) = TOKEN_LINE(token); 01497 01498 /* left child is $OPN attr */ 01499 01500 if (glb_tbl_idx[Open_Attr_Idx] == NULL_IDX) { 01501 glb_tbl_idx[Open_Attr_Idx] = create_lib_entry_attr(OPEN_LIB_ENTRY, 01502 OPEN_NAME_LEN, 01503 TOKEN_LINE(token), 01504 TOKEN_COLUMN(token)); 01505 } 01506 01507 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Open_Attr_Idx]); 01508 01509 IR_FLD_L(call_idx) = AT_Tbl_Idx; 01510 IR_IDX_L(call_idx) = glb_tbl_idx[Open_Attr_Idx]; 01511 IR_COL_NUM_L(call_idx) = TOKEN_COLUMN(token); 01512 IR_LINE_NUM_L(call_idx) = TOKEN_LINE(token); 01513 01514 parsed_ok = parse_io_control_list(&opnd, Open); 01515 COPY_OPND(IR_OPND_R(call_idx), opnd); 01516 01517 if (LA_CH_VALUE != EOS) { 01518 parse_err_flush(Find_EOS, EOS_STR); 01519 parsed_ok = FALSE; 01520 } 01521 01522 matched_specific_token(Tok_EOS, Tok_Class_Punct); 01523 01524 SH_ERR_FLG(curr_stmt_sh_idx) = ! parsed_ok; 01525 01526 INSERT_IO_END; 01527 01528 TRACE (Func_Exit, "parse_open_stmt", NULL); 01529 01530 return; 01531 01532 } /* parse_open_stmt */ 01533 01534 /******************************************************************************\ 01535 |* *| 01536 |* Description: *| 01537 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 01538 |* *| 01539 |* Input parameters: *| 01540 |* NONE *| 01541 |* *| 01542 |* Output parameters: *| 01543 |* NONE *| 01544 |* *| 01545 |* Returns: *| 01546 |* NONE *| 01547 |* *| 01548 \******************************************************************************/ 01549 01550 void parse_print_stmt (void) 01551 01552 { 01553 int attr_idx; 01554 int buf_idx; 01555 int column; 01556 int i; 01557 int idx; 01558 int ir_idx; 01559 int line; 01560 int list_idx; 01561 int list2_idx; 01562 int name_idx; 01563 opnd_type opnd; 01564 boolean parsed_ok = TRUE; 01565 int pre_parse_format_idx; 01566 01567 01568 TRACE (Func_Entry, "parse_print_stmt", NULL); 01569 01570 /* The following is legal - print a(1)(1:2), "ab" ! a is char array */ 01571 /* The following is also legal - print a(1)(1:2) = ! where reada is arr */ 01572 01573 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) { 01574 curr_stmt_category = Executable_Stmt_Cat; 01575 } 01576 01577 if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) || 01578 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) { 01579 PRINTMSG(TOKEN_LINE(token), 1262, Error, TOKEN_COLUMN(token), 01580 stmt_type_str[stmt_type], 01581 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure" : "elemental", 01582 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx))); 01583 } 01584 01585 INSERT_IO_START; 01586 01587 NTR_IR_TBL(ir_idx); 01588 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 01589 01590 IR_OPR(ir_idx) = Write_Formatted_Opr; 01591 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 01592 column = TOKEN_COLUMN(token); 01593 IR_COL_NUM(ir_idx) = column; 01594 line = TOKEN_LINE(token); 01595 IR_LINE_NUM(ir_idx) = line; 01596 01597 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 01598 IR_LIST_CNT_L(ir_idx) = ciitem_tbl[Write].num_ciitems; 01599 NTR_IR_LIST_TBL(list_idx); 01600 IR_IDX_L(ir_idx) = list_idx; 01601 01602 /* set first one to CN_Tbl_Idx for default unit */ 01603 IL_FLD(list_idx) = CN_Tbl_Idx; 01604 IL_LINE_NUM(list_idx) = line; 01605 IL_COL_NUM(list_idx) = column; 01606 01607 for (i = 2; i <= ciitem_tbl[Write].num_ciitems; i++) { 01608 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 01609 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 01610 list_idx = IL_NEXT_LIST_IDX(list_idx); 01611 } 01612 01613 list_idx = IL_NEXT_LIST_IDX(IR_IDX_L(ir_idx)); 01614 01615 if (LA_CH_VALUE == STAR) { 01616 /* CN_Tbl_Idx and idx = NULL is list directed */ 01617 IL_FLD(list_idx) = CN_Tbl_Idx; 01618 IL_LINE_NUM(list_idx) = line; 01619 IL_COL_NUM(list_idx) = column; 01620 NEXT_LA_CH; 01621 } 01622 else if (LA_CH_CLASS == Ch_Class_Digit && 01623 digit_is_format_label()) { 01624 01625 if (MATCHED_TOKEN_CLASS(Tok_Class_Label) && 01626 ! TOKEN_ERR(token)) { 01627 01628 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx); 01629 01630 if (attr_idx == NULL_IDX) { 01631 attr_idx = ntr_sym_tbl(&token, name_idx); 01632 AT_OBJ_CLASS(attr_idx) = Label; 01633 LN_DEF_LOC(name_idx) = TRUE; 01634 build_fwd_ref_entry(attr_idx, Format_Ref); 01635 } 01636 else if ( ! AT_DCL_ERR(attr_idx) ) { 01637 01638 if (!AT_DEFINED(attr_idx)) { 01639 build_fwd_ref_entry(attr_idx, Format_Ref); 01640 } 01641 else if (ATL_CLASS(attr_idx) != Lbl_Format) { 01642 /* error .. label used previously as something else */ 01643 PRINTMSG(TOKEN_LINE(token), 328, Error, 01644 TOKEN_COLUMN(token), 01645 AT_OBJ_NAME_PTR(attr_idx)); 01646 parsed_ok = FALSE; 01647 } 01648 01649 } 01650 else { 01651 /* no message, at_dcl_err is set */ 01652 parsed_ok = FALSE; 01653 } 01654 01655 if (parsed_ok) { 01656 IL_FLD(list_idx) = AT_Tbl_Idx; 01657 IL_IDX(list_idx) = attr_idx; 01658 IL_LINE_NUM(list_idx) = TOKEN_LINE(token); 01659 IL_COL_NUM(list_idx) = TOKEN_COLUMN(token); 01660 01661 if (cif_flags & XREF_RECS) { 01662 cif_usage_rec(IL_IDX(list_idx), AT_Tbl_Idx, 01663 IL_LINE_NUM(list_idx), IL_COL_NUM(list_idx), 01664 CIF_Label_Referenced_As_Format); 01665 } 01666 } 01667 } 01668 else if (TOKEN_ERR(token)) { 01669 parse_err_flush(Find_Comma, NULL); 01670 parsed_ok = FALSE; 01671 } 01672 else { 01673 parse_err_flush(Find_Comma, "LABEL"); 01674 parsed_ok = FALSE; 01675 } 01676 } 01677 else { 01678 01679 buf_idx = LA_CH_BUF_IDX; 01680 01681 parsed_ok = parse_expr(&opnd); 01682 COPY_OPND(IL_OPND(list_idx), opnd); 01683 01684 if (IL_FLD(list_idx) == CN_Tbl_Idx && 01685 TYP_TYPE(CN_TYPE_IDX(IL_IDX(list_idx))) == Character) { 01686 01687 set_format_start_idx(buf_idx); 01688 01689 format_cn_idx = IL_IDX(list_idx); 01690 # ifndef SOURCE_TO_SOURCE 01691 ignore_trailing_chars = TRUE; 01692 pre_parse_format_idx = pre_parse_format(format_cn_idx, 0); 01693 ignore_trailing_chars = FALSE; 01694 # endif 01695 01696 NTR_IR_LIST_TBL(list2_idx); 01697 IL_FLD(list_idx) = IL_Tbl_Idx; 01698 IL_IDX(list_idx) = list2_idx; 01699 IL_LIST_CNT(list_idx) = 2; 01700 01701 IL_FLD(list2_idx) = AT_Tbl_Idx; 01702 idx = create_format_tmp(format_cn_idx); 01703 IL_IDX(list2_idx) = idx; 01704 IL_LINE_NUM(list2_idx) = line; 01705 IL_COL_NUM(list2_idx) = column; 01706 01707 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list2_idx)); 01708 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list2_idx)) = list2_idx; 01709 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 01710 01711 # ifndef SOURCE_TO_SOURCE 01712 if (pre_parse_format_idx != NULL_IDX) { 01713 IL_FLD(list2_idx) = AT_Tbl_Idx; 01714 idx = create_format_tmp(pre_parse_format_idx); 01715 IL_IDX(list2_idx) = idx; 01716 IL_LINE_NUM(list2_idx) = line; 01717 IL_COL_NUM(list2_idx) = column; 01718 } 01719 # endif 01720 } 01721 } 01722 01723 if (LA_CH_VALUE != EOS) { 01724 01725 if (LA_CH_VALUE != COMMA) { 01726 parse_err_flush(Find_EOS, ","); 01727 parsed_ok = FALSE; 01728 } 01729 else { 01730 01731 NEXT_LA_CH; 01732 01733 parsed_ok = parse_io_list(&opnd) && parsed_ok; 01734 COPY_OPND(IR_OPND_R(ir_idx), opnd); 01735 } 01736 } 01737 01738 if (LA_CH_VALUE != EOS) { 01739 parse_err_flush(Find_EOS, EOS_STR); 01740 parsed_ok = FALSE; 01741 } 01742 01743 matched_specific_token(Tok_EOS, Tok_Class_Punct); 01744 01745 INSERT_IO_END; 01746 01747 TRACE (Func_Exit, "parse_print_stmt", NULL); 01748 01749 return; 01750 01751 } /* parse_print_stmt */ 01752 01753 /******************************************************************************\ 01754 |* *| 01755 |* Description: *| 01756 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 01757 |* *| 01758 |* Input parameters: *| 01759 |* NONE *| 01760 |* *| 01761 |* Output parameters: *| 01762 |* NONE *| 01763 |* *| 01764 |* Returns: *| 01765 |* NONE *| 01766 |* *| 01767 \******************************************************************************/ 01768 01769 void parse_read_stmt (void) 01770 01771 { 01772 int attr_idx; 01773 int buf_idx; 01774 int column; 01775 int i; 01776 int idx; 01777 int ir_idx; 01778 int line; 01779 int list_idx; 01780 int list2_idx; 01781 int name_idx; 01782 opnd_type opnd; 01783 boolean parsed_ok = TRUE; 01784 int pre_parse_format_idx; 01785 01786 01787 TRACE (Func_Entry, "parse_read_stmt", NULL); 01788 01789 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) { 01790 curr_stmt_category = Executable_Stmt_Cat; 01791 } 01792 01793 INSERT_IO_START; 01794 01795 NTR_IR_TBL(ir_idx); 01796 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 01797 01798 IR_OPR(ir_idx) = Read_Formatted_Opr; 01799 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 01800 column = TOKEN_COLUMN(token); 01801 IR_COL_NUM(ir_idx) = column; 01802 line = TOKEN_LINE(token); 01803 IR_LINE_NUM(ir_idx) = line; 01804 01805 if (LA_CH_VALUE == LPAREN) { 01806 parsed_ok = parse_io_control_list(&opnd, Read); 01807 COPY_OPND(IR_OPND_L(ir_idx), opnd); 01808 01809 if (LA_CH_VALUE != EOS) { 01810 01811 parsed_ok = parse_io_list(&opnd) && parsed_ok; 01812 COPY_OPND(IR_OPND_R(ir_idx), opnd); 01813 } 01814 } 01815 else { 01816 01817 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 01818 IR_LIST_CNT_L(ir_idx) = ciitem_tbl[Read].num_ciitems; 01819 NTR_IR_LIST_TBL(list_idx); 01820 IR_IDX_L(ir_idx) = list_idx; 01821 01822 /* set first one to CN_Tbl_Idx for default unit */ 01823 IL_FLD(list_idx) = CN_Tbl_Idx; 01824 IL_LINE_NUM(list_idx) = line; 01825 IL_COL_NUM(list_idx) = column; 01826 01827 for (i = 2; i <= ciitem_tbl[Read].num_ciitems; i++) { 01828 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 01829 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 01830 list_idx = IL_NEXT_LIST_IDX(list_idx); 01831 } 01832 01833 list_idx = IL_NEXT_LIST_IDX(IR_IDX_L(ir_idx)); 01834 01835 if (LA_CH_VALUE == STAR) { 01836 /* CN_Tbl_Idx and idx = NULL is list directed */ 01837 IL_FLD(list_idx) = CN_Tbl_Idx; 01838 IL_LINE_NUM(list_idx) = line; 01839 IL_COL_NUM(list_idx) = column; 01840 NEXT_LA_CH; 01841 } 01842 else if (LA_CH_CLASS == Ch_Class_Digit && 01843 digit_is_format_label()) { 01844 01845 if (MATCHED_TOKEN_CLASS(Tok_Class_Label) && 01846 ! TOKEN_ERR(token)) { 01847 01848 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), 01849 &name_idx); 01850 01851 if (attr_idx == NULL_IDX) { 01852 attr_idx = ntr_sym_tbl(&token, name_idx); 01853 AT_OBJ_CLASS(attr_idx) = Label; 01854 LN_DEF_LOC(name_idx) = TRUE; 01855 build_fwd_ref_entry(attr_idx, Format_Ref); 01856 } 01857 else if ( ! AT_DCL_ERR(attr_idx) ) { 01858 01859 if (!AT_DEFINED(attr_idx)) { 01860 build_fwd_ref_entry(attr_idx, Format_Ref); 01861 } 01862 else if (ATL_CLASS(attr_idx) != Lbl_Format) { 01863 /* error .. label used previously as something else */ 01864 PRINTMSG(TOKEN_LINE(token), 328, Error, 01865 TOKEN_COLUMN(token), 01866 AT_OBJ_NAME_PTR(attr_idx)); 01867 parsed_ok = FALSE; 01868 } 01869 } 01870 else { 01871 /* no message, at_dcl_err is set */ 01872 parsed_ok = FALSE; 01873 } 01874 01875 if (parsed_ok) { 01876 IL_FLD(list_idx) = AT_Tbl_Idx; 01877 IL_IDX(list_idx) = attr_idx; 01878 IL_LINE_NUM(list_idx) = TOKEN_LINE(token); 01879 IL_COL_NUM(list_idx) = TOKEN_COLUMN(token); 01880 01881 if (cif_flags & XREF_RECS) { 01882 cif_usage_rec(IL_IDX(list_idx), AT_Tbl_Idx, 01883 IL_LINE_NUM(list_idx), IL_COL_NUM(list_idx), 01884 CIF_Label_Referenced_As_Format); 01885 } 01886 } 01887 } 01888 else if (TOKEN_ERR(token)) { 01889 parse_err_flush(Find_Comma, NULL); 01890 parsed_ok = FALSE; 01891 } 01892 else { 01893 parse_err_flush(Find_Comma, "LABEL"); 01894 parsed_ok = FALSE; 01895 } 01896 } 01897 else { 01898 01899 buf_idx = LA_CH_BUF_IDX; 01900 01901 parsed_ok = parse_expr(&opnd); 01902 COPY_OPND(IL_OPND(list_idx), opnd); 01903 01904 if (IL_FLD(list_idx) == CN_Tbl_Idx && 01905 TYP_TYPE(CN_TYPE_IDX(IL_IDX(list_idx))) == Character) { 01906 01907 set_format_start_idx(buf_idx); 01908 01909 format_cn_idx = IL_IDX(list_idx); 01910 01911 # ifndef SOURCE_TO_SOURCE 01912 ignore_trailing_chars = TRUE; 01913 pre_parse_format_idx = pre_parse_format(format_cn_idx, 0); 01914 ignore_trailing_chars = FALSE; 01915 # endif 01916 NTR_IR_LIST_TBL(list2_idx); 01917 IL_FLD(list_idx) = IL_Tbl_Idx; 01918 IL_IDX(list_idx) = list2_idx; 01919 IL_LIST_CNT(list_idx) = 2; 01920 01921 IL_FLD(list2_idx) = AT_Tbl_Idx; 01922 idx = create_format_tmp(format_cn_idx); 01923 IL_IDX(list2_idx) = idx; 01924 IL_LINE_NUM(list2_idx) = line; 01925 IL_COL_NUM(list2_idx) = column; 01926 01927 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list2_idx)); 01928 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list2_idx)) = list2_idx; 01929 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 01930 01931 # ifndef SOURCE_TO_SOURCE 01932 if (pre_parse_format_idx != NULL_IDX) { 01933 IL_FLD(list2_idx) = AT_Tbl_Idx; 01934 idx = create_format_tmp(pre_parse_format_idx); 01935 IL_IDX(list2_idx) = idx; 01936 IL_LINE_NUM(list2_idx) = line; 01937 IL_COL_NUM(list2_idx) = column; 01938 } 01939 # endif 01940 01941 } 01942 } 01943 01944 if (LA_CH_VALUE != EOS) { 01945 01946 if (LA_CH_VALUE != COMMA) { 01947 parse_err_flush(Find_EOS, ","); 01948 parsed_ok = FALSE; 01949 } 01950 else { 01951 NEXT_LA_CH; 01952 01953 parsed_ok = parse_io_list(&opnd) && parsed_ok; 01954 COPY_OPND(IR_OPND_R(ir_idx), opnd); 01955 } 01956 } 01957 } 01958 01959 if (LA_CH_VALUE != EOS) { 01960 parse_err_flush(Find_EOS, EOS_STR); 01961 parsed_ok = FALSE; 01962 } 01963 01964 matched_specific_token(Tok_EOS, Tok_Class_Punct); 01965 01966 INSERT_IO_END; 01967 01968 TRACE (Func_Exit, "parse_read_stmt", NULL); 01969 01970 return; 01971 01972 } /* parse_read_stmt */ 01973 01974 /******************************************************************************\ 01975 |* *| 01976 |* Description: *| 01977 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 01978 |* *| 01979 |* Input parameters: *| 01980 |* NONE *| 01981 |* *| 01982 |* Output parameters: *| 01983 |* NONE *| 01984 |* *| 01985 |* Returns: *| 01986 |* NONE *| 01987 |* *| 01988 \******************************************************************************/ 01989 01990 void parse_rewind_stmt (void) 01991 01992 { 01993 int call_idx; 01994 int list_idx; 01995 opnd_type opnd; 01996 boolean parsed_ok = TRUE; 01997 01998 01999 TRACE (Func_Entry, "parse_rewind_stmt", NULL); 02000 02001 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) { 02002 curr_stmt_category = Executable_Stmt_Cat; 02003 } 02004 02005 if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) || 02006 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) { 02007 PRINTMSG(TOKEN_LINE(token), 1262, Error, TOKEN_COLUMN(token), 02008 stmt_type_str[stmt_type], 02009 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure" : "elemental", 02010 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx))); 02011 } 02012 02013 INSERT_IO_START; 02014 02015 NTR_IR_TBL(call_idx); 02016 SH_IR_IDX(curr_stmt_sh_idx) = call_idx; 02017 02018 IR_OPR(call_idx) = Call_Opr; 02019 IR_TYPE_IDX(call_idx) = TYPELESS_DEFAULT_TYPE; 02020 IR_COL_NUM(call_idx) = TOKEN_COLUMN(token); 02021 IR_LINE_NUM(call_idx) = TOKEN_LINE(token); 02022 02023 /* left child is rewind attr */ 02024 02025 if (glb_tbl_idx[Rewind_Attr_Idx] == NULL_IDX) { 02026 glb_tbl_idx[Rewind_Attr_Idx] = create_lib_entry_attr(REWIND_LIB_ENTRY, 02027 REWIND_NAME_LEN, 02028 TOKEN_LINE(token), 02029 TOKEN_COLUMN(token)); 02030 } 02031 02032 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Rewind_Attr_Idx]); 02033 02034 IR_FLD_L(call_idx) = AT_Tbl_Idx; 02035 IR_IDX_L(call_idx) = glb_tbl_idx[Rewind_Attr_Idx]; 02036 02037 IR_LINE_NUM_L(call_idx) = TOKEN_LINE(token); 02038 IR_COL_NUM_L(call_idx) = TOKEN_COLUMN(token); 02039 02040 if (LA_CH_VALUE == LPAREN) { 02041 parsed_ok = parse_io_control_list(&opnd, Rewind); 02042 COPY_OPND(IR_OPND_R(call_idx), opnd); 02043 } 02044 else { 02045 /* call parse_expr to get external file unit */ 02046 parsed_ok = parse_expr(&opnd); 02047 NTR_IR_LIST_TBL(list_idx); 02048 IL_ARG_DESC_VARIANT(list_idx) = TRUE; 02049 IR_FLD_R(call_idx) = IL_Tbl_Idx; 02050 IR_IDX_R(call_idx) = list_idx; 02051 COPY_OPND(IL_OPND(list_idx), opnd); 02052 IR_LIST_CNT_R(call_idx) = 3; 02053 02054 /* add the blank arguments */ 02055 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 02056 list_idx = IL_NEXT_LIST_IDX(list_idx); 02057 IL_ARG_DESC_VARIANT(list_idx) = TRUE; 02058 02059 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 02060 list_idx = IL_NEXT_LIST_IDX(list_idx); 02061 IL_ARG_DESC_VARIANT(list_idx) = TRUE; 02062 } 02063 02064 if (LA_CH_VALUE != EOS) { 02065 parse_err_flush(Find_EOS, EOS_STR); 02066 parsed_ok = FALSE; 02067 } 02068 02069 matched_specific_token(Tok_EOS, Tok_Class_Punct); 02070 02071 SH_ERR_FLG(curr_stmt_sh_idx) = ! parsed_ok; 02072 02073 INSERT_IO_END; 02074 02075 TRACE (Func_Exit, "parse_rewind_stmt", NULL); 02076 02077 return; 02078 02079 } /* parse_rewind_stmt */ 02080 02081 /******************************************************************************\ 02082 |* *| 02083 |* Description: *| 02084 |* BRIEF DESCRIPTION OF THIS FUNCTION'S PURPOSE *| 02085 |* *| 02086 |* Input parameters: *| 02087 |* NONE *| 02088 |* *| 02089 |* Output parameters: *| 02090 |* NONE *| 02091 |* *| 02092 |* Returns: *| 02093 |* NONE *| 02094 |* *| 02095 \******************************************************************************/ 02096 02097 void parse_write_stmt (void) 02098 02099 { 02100 int attr_idx; 02101 int buf_idx; 02102 int column; 02103 int i; 02104 int idx; 02105 int ir_idx; 02106 int line; 02107 int list_idx; 02108 int list2_idx; 02109 int name_idx; 02110 opnd_type opnd; 02111 boolean parsed_ok = TRUE; 02112 int pre_parse_format_idx; 02113 02114 02115 TRACE (Func_Entry, "parse_write_stmt", NULL); 02116 02117 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) { 02118 curr_stmt_category = Executable_Stmt_Cat; 02119 } 02120 02121 INSERT_IO_START; 02122 02123 NTR_IR_TBL(ir_idx); 02124 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx; 02125 02126 IR_OPR(ir_idx) = Write_Formatted_Opr; 02127 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 02128 column = TOKEN_COLUMN(token); 02129 IR_COL_NUM(ir_idx) = column; 02130 line = TOKEN_LINE(token); 02131 IR_LINE_NUM(ir_idx) = line; 02132 02133 if (LA_CH_VALUE == LPAREN) { 02134 parsed_ok = parse_io_control_list(&opnd, Write); 02135 COPY_OPND(IR_OPND_L(ir_idx), opnd); 02136 02137 if (LA_CH_VALUE != EOS) { 02138 02139 parsed_ok = parse_io_list(&opnd) && parsed_ok; 02140 COPY_OPND(IR_OPND_R(ir_idx), opnd); 02141 } 02142 } 02143 else { 02144 02145 /* issue ansi msg for nonstandard write */ 02146 PRINTMSG(LA_CH_LINE, 174, Ansi, LA_CH_COLUMN, NULL); 02147 02148 IR_FLD_L(ir_idx) = IL_Tbl_Idx; 02149 IR_LIST_CNT_L(ir_idx) = ciitem_tbl[Write].num_ciitems; 02150 NTR_IR_LIST_TBL(list_idx); 02151 IR_IDX_L(ir_idx) = list_idx; 02152 02153 /* set first one to CN_Tbl_Idx for default unit */ 02154 IL_FLD(list_idx) = CN_Tbl_Idx; 02155 IL_LINE_NUM(list_idx) = line; 02156 IL_COL_NUM(list_idx) = column; 02157 02158 for (i = 2; i <= ciitem_tbl[Write].num_ciitems; i++) { 02159 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 02160 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 02161 list_idx = IL_NEXT_LIST_IDX(list_idx); 02162 } 02163 02164 list_idx = IL_NEXT_LIST_IDX(IR_IDX_L(ir_idx)); 02165 02166 if (LA_CH_VALUE == STAR) { 02167 /* CN_Tbl_Idx and idx = NULL is list directed */ 02168 IL_FLD(list_idx) = CN_Tbl_Idx; 02169 IL_LINE_NUM(list_idx) = line; 02170 IL_COL_NUM(list_idx) = column; 02171 NEXT_LA_CH; 02172 } 02173 else if (LA_CH_CLASS == Ch_Class_Digit && 02174 digit_is_format_label()) { 02175 02176 if (MATCHED_TOKEN_CLASS(Tok_Class_Label) && 02177 ! TOKEN_ERR(token)) { 02178 02179 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), 02180 &name_idx); 02181 02182 if (attr_idx == NULL_IDX) { 02183 attr_idx = ntr_sym_tbl(&token, name_idx); 02184 AT_OBJ_CLASS(attr_idx) = Label; 02185 LN_DEF_LOC(name_idx) = TRUE; 02186 build_fwd_ref_entry(attr_idx, Format_Ref); 02187 } 02188 else if ( ! AT_DCL_ERR(attr_idx) ) { 02189 02190 if (!AT_DEFINED(attr_idx)) { 02191 build_fwd_ref_entry(attr_idx, Format_Ref); 02192 } 02193 else if (ATL_CLASS(attr_idx) != Lbl_Format) { 02194 /* error .. label used previously as something else */ 02195 PRINTMSG(TOKEN_LINE(token), 328, Error, 02196 TOKEN_COLUMN(token), 02197 AT_OBJ_NAME_PTR(attr_idx)); 02198 parsed_ok = FALSE; 02199 } 02200 } 02201 else { 02202 /* no message, at_dcl_err is set */ 02203 parsed_ok = FALSE; 02204 } 02205 02206 if (parsed_ok) { 02207 IL_FLD(list_idx) = AT_Tbl_Idx; 02208 IL_IDX(list_idx) = attr_idx; 02209 IL_LINE_NUM(list_idx) = TOKEN_LINE(token); 02210 IL_COL_NUM(list_idx) = TOKEN_COLUMN(token); 02211 } 02212 } 02213 else if (TOKEN_ERR(token)) { 02214 parse_err_flush(Find_Comma, NULL); 02215 parsed_ok = FALSE; 02216 } 02217 else { 02218 parse_err_flush(Find_Comma, "LABEL"); 02219 parsed_ok = FALSE; 02220 } 02221 } 02222 else { 02223 02224 buf_idx = LA_CH_BUF_IDX; 02225 02226 parsed_ok = parse_expr(&opnd); 02227 COPY_OPND(IL_OPND(list_idx), opnd); 02228 02229 if (IL_FLD(list_idx) == CN_Tbl_Idx && 02230 TYP_TYPE(CN_TYPE_IDX(IL_IDX(list_idx))) == Character) { 02231 02232 set_format_start_idx(buf_idx); 02233 02234 format_cn_idx = IL_IDX(list_idx); 02235 # ifndef SOURCE_TO_SOURCE 02236 ignore_trailing_chars = TRUE; 02237 pre_parse_format_idx = pre_parse_format(format_cn_idx, 0); 02238 ignore_trailing_chars = FALSE; 02239 # endif 02240 NTR_IR_LIST_TBL(list2_idx); 02241 IL_FLD(list_idx) = IL_Tbl_Idx; 02242 IL_IDX(list_idx) = list2_idx; 02243 IL_LIST_CNT(list_idx) = 2; 02244 02245 # ifndef SOURCE_TO_SOURCE 02246 IL_FLD(list2_idx) = AT_Tbl_Idx; 02247 idx = create_format_tmp(format_cn_idx); 02248 # else 02249 IL_FLD(list2_idx) = CN_Tbl_Idx; 02250 idx =format_cn_idx; 02251 # endif 02252 IL_IDX(list2_idx) = idx; 02253 IL_LINE_NUM(list2_idx) = line; 02254 IL_COL_NUM(list2_idx) = column; 02255 02256 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list2_idx)); 02257 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list2_idx)) = list2_idx; 02258 list2_idx = IL_NEXT_LIST_IDX(list2_idx); 02259 02260 #ifndef SOURCE_TO_SOURCE 02261 if (pre_parse_format_idx != NULL_IDX ) { 02262 IL_FLD(list2_idx) = AT_Tbl_Idx; 02263 idx = create_format_tmp(pre_parse_format_idx); 02264 IL_IDX(list2_idx) = idx; 02265 IL_LINE_NUM(list2_idx) = line; 02266 IL_COL_NUM(list2_idx) = column; 02267 } 02268 # endif 02269 } 02270 } 02271 02272 if (LA_CH_VALUE != EOS) { 02273 02274 if (LA_CH_VALUE != COMMA) { 02275 parse_err_flush(Find_EOS, ","); 02276 parsed_ok = FALSE; 02277 } 02278 else { 02279 NEXT_LA_CH; 02280 02281 parsed_ok = parse_io_list(&opnd) && parsed_ok; 02282 COPY_OPND(IR_OPND_R(ir_idx), opnd); 02283 } 02284 } 02285 } 02286 02287 if (LA_CH_VALUE != EOS) { 02288 parse_err_flush(Find_EOS, EOS_STR); 02289 parsed_ok = FALSE; 02290 } 02291 02292 matched_specific_token(Tok_EOS, Tok_Class_Punct); 02293 02294 INSERT_IO_END; 02295 02296 TRACE (Func_Exit, "parse_write_stmt", NULL); 02297 02298 return; 02299 02300 } /* parse_write_stmt */ 02301 02302 /******************************************************************************\ 02303 |* *| 02304 |* Description: *| 02305 |* parse io list which may include implied do loops. *| 02306 |* *| 02307 |* Input parameters: *| 02308 |* NONE *| 02309 |* *| 02310 |* Output parameters: *| 02311 |* result_opnd - opnd pointing to root of list tree produced. *| 02312 |* *| 02313 |* Returns: *| 02314 |* TRUE if parsed ok. *| 02315 |* *| 02316 \******************************************************************************/ 02317 02318 boolean parse_io_list (opnd_type *result_opnd) 02319 02320 { 02321 int buf_idx; 02322 int list_idx; 02323 int list2_idx; 02324 char next_char; 02325 opnd_type opnd; 02326 int paren_level = 0; 02327 boolean parsed_ok = TRUE; 02328 int stmt_num; 02329 02330 02331 TRACE (Func_Entry, "parse_io_list", NULL); 02332 02333 OPND_FLD((*result_opnd)) = IL_Tbl_Idx; 02334 OPND_IDX((*result_opnd)) = NULL_IDX; 02335 OPND_LIST_CNT((*result_opnd)) = 0; 02336 02337 do { 02338 02339 if (LA_CH_VALUE == LPAREN) { 02340 02341 if (next_tok_is_paren_slash ()) { 02342 parsed_ok = parse_expr(&opnd) && parsed_ok; 02343 } 02344 else if (is_implied_do ()) { 02345 parsed_ok = parse_imp_do(&opnd) && parsed_ok; 02346 } 02347 else { 02348 next_char = scan_thru_close_paren(0,0,1); 02349 02350 if (next_char == COMMA || 02351 next_char == EOS || 02352 next_char == RPAREN) { 02353 02354 buf_idx = LA_CH_BUF_IDX; 02355 stmt_num = LA_CH_STMT_NUM; 02356 02357 NEXT_LA_CH; 02358 02359 if (LA_CH_VALUE == LPAREN || 02360 LA_CH_VALUE == RPAREN || 02361 LA_CH_VALUE == EOS) { 02362 02363 paren_level++; 02364 continue; 02365 } 02366 else if (paren_grp_is_cplx_const()) { 02367 /* this is a complex constant */ 02368 reset_lex(buf_idx,stmt_num); 02369 parsed_ok = parse_expr(&opnd) && parsed_ok; 02370 } 02371 else { 02372 /* go back and swallow beginning ( */ 02373 reset_lex(buf_idx,stmt_num); 02374 NEXT_LA_CH; 02375 paren_level++; 02376 continue; 02377 } 02378 } 02379 else { 02380 parsed_ok = parse_expr(&opnd) && parsed_ok; 02381 02382 if (stmt_type == Read_Stmt || 02383 stmt_type == Decode_Stmt) { 02384 mark_attr_defined(&opnd); 02385 } 02386 } 02387 } 02388 } 02389 else { 02390 02391 parsed_ok = parse_expr(&opnd) && parsed_ok; 02392 02393 if (stmt_type == Read_Stmt || 02394 stmt_type == Decode_Stmt) { 02395 mark_attr_defined(&opnd); 02396 } 02397 } 02398 02399 ++OPND_LIST_CNT((*result_opnd)); 02400 02401 NTR_IR_LIST_TBL(list_idx); 02402 COPY_OPND(IL_OPND(list_idx), opnd); 02403 02404 if (OPND_IDX((*result_opnd)) == NULL_IDX) { 02405 OPND_IDX((*result_opnd)) = list_idx; 02406 } 02407 else { 02408 IL_NEXT_LIST_IDX(list2_idx) = list_idx; 02409 IL_PREV_LIST_IDX(list_idx) = list2_idx; 02410 } 02411 02412 list2_idx = list_idx; 02413 02414 while (LA_CH_VALUE == RPAREN && paren_level) { 02415 NEXT_LA_CH; 02416 paren_level--; 02417 } 02418 02419 if (LA_CH_VALUE == COMMA) { 02420 NEXT_LA_CH; 02421 } 02422 else { 02423 break; 02424 } 02425 } 02426 while (TRUE); 02427 02428 if (paren_level) { 02429 parse_err_flush(Find_EOS, ")"); 02430 } 02431 02432 TRACE (Func_Exit, "parse_io_list", NULL); 02433 return(parsed_ok); 02434 } /* parse_io_list */ 02435 02436 /******************************************************************************\ 02437 |* *| 02438 |* Description: *| 02439 |* search ciitem table for ciitem entry. *| 02440 |* *| 02441 |* Input parameters: *| 02442 |* stmt_type - idx into ciitem table *| 02443 |* *| 02444 |* Output parameters: *| 02445 |* None. *| 02446 |* *| 02447 |* Returns: *| 02448 |* idx into ciitem list for io stmt. *| 02449 |* *| 02450 \******************************************************************************/ 02451 02452 static int find_ciitem_idx (io_stmt_type stmt_type) 02453 02454 { 02455 int finish; 02456 int i; 02457 int idx = -1; 02458 int start; 02459 int test; 02460 02461 02462 TRACE (Func_Entry, "find_ciitem_idx", NULL); 02463 02464 start = 0; 02465 finish = ciitem_tbl[stmt_type].num_diff_ciitems; 02466 while (TRUE) { 02467 test = (finish - start) / 2 + start; 02468 02469 if ((i = strncmp(TOKEN_STR(token),ciitem_tbl[stmt_type].ciitem_list[test]. 02470 name, ciitem_tbl[stmt_type].ciitem_list[test].name_length)) == 0) { 02471 /* found match */ 02472 02473 if (TOKEN_LEN(token) == ciitem_tbl[stmt_type].ciitem_list[test]. 02474 name_length) { 02475 idx = test; 02476 break; 02477 } 02478 else if (start == test) { 02479 break; 02480 } 02481 else { 02482 start = test; 02483 } 02484 } 02485 else if (i < 0) { 02486 if (finish == test) { 02487 break; 02488 } 02489 finish = test; 02490 } 02491 else { 02492 if (start == test) { 02493 break; 02494 } 02495 start = test; 02496 } 02497 02498 if (finish <= start) { 02499 break; 02500 } 02501 } 02502 TRACE (Func_Exit, "find_ciitem_idx", NULL); 02503 02504 return(idx); 02505 } /* find_ciitem_idx */ 02506 02507 /******************************************************************************\ 02508 |* *| 02509 |* Description: *| 02510 |* parse io list which may include implied do loops. *| 02511 |* *| 02512 |* Input parameters: *| 02513 |* can_have_expression - Boolean flag for input or output list. *| 02514 |* *| 02515 |* Output parameters: *| 02516 |* result_opnd - opnd pointing to root of list tree produced. *| 02517 |* *| 02518 |* Returns: *| 02519 |* TRUE if parsed ok. *| 02520 |* *| 02521 \******************************************************************************/ 02522 02523 static boolean parse_io_control_list (opnd_type *result_opnd, 02524 io_stmt_type stmt_type) 02525 02526 { 02527 int arg_array[26]; 02528 int arg_cnt = 0; 02529 int arg_idx; 02530 int attr_idx; 02531 int buf_idx; 02532 char *ch_ptr1; 02533 char *ch_ptr2; 02534 int ciitem_idx; 02535 boolean found; 02536 boolean had_fmt = FALSE; 02537 boolean had_keyword = FALSE; 02538 boolean had_nml = FALSE; 02539 long i; 02540 int idx; 02541 boolean item_has_keyword; 02542 int kwd_col; 02543 int kwd_line; 02544 int list_idx; 02545 int list2_idx; 02546 int name_idx; 02547 int num_args; 02548 opnd_type opnd; 02549 int opnd_column; 02550 int opnd_line; 02551 boolean parsed_ok = TRUE; 02552 int pre_parse_format_idx; 02553 02554 02555 TRACE (Func_Entry, "parse_io_control_list", NULL); 02556 02557 if (LA_CH_VALUE != LPAREN) { 02558 /* shouldn't be here */ 02559 parse_err_flush(Find_EOS, "("); 02560 parsed_ok = FALSE; 02561 } 02562 else { 02563 OPND_FLD((*result_opnd)) = IL_Tbl_Idx; 02564 num_args = ciitem_tbl[stmt_type].num_ciitems; 02565 OPND_LIST_CNT((*result_opnd)) = num_args; 02566 list2_idx = NULL_IDX; 02567 02568 for (i = 1; i <= num_args; i++) { 02569 NTR_IR_LIST_TBL(list_idx) 02570 arg_array[i] = list_idx; 02571 02572 if (stmt_type == Backspace || 02573 stmt_type == Close || 02574 stmt_type == Endfile || 02575 stmt_type == Inquire || 02576 stmt_type == Open || 02577 stmt_type == Rewind) { 02578 02579 IL_ARG_DESC_VARIANT(list_idx) = TRUE; 02580 02581 if (list2_idx) { 02582 IL_NEXT_LIST_IDX(list2_idx) = list_idx; 02583 } 02584 } 02585 else if (list2_idx) { 02586 IL_NEXT_LIST_IDX(list2_idx) = list_idx; 02587 IL_PREV_LIST_IDX(list_idx) = list2_idx; 02588 } 02589 list2_idx = list_idx; 02590 } 02591 OPND_IDX((*result_opnd)) = arg_array[1]; 02592 02593 do { 02594 NEXT_LA_CH; 02595 02596 if (LA_CH_VALUE == RPAREN && arg_cnt == 0) { 02597 break; 02598 } 02599 02600 arg_cnt++; 02601 02602 item_has_keyword = FALSE; 02603 02604 if (next_arg_is_kwd_equal()) { 02605 MATCHED_TOKEN_CLASS(Tok_Class_Id); 02606 02607 kwd_line = TOKEN_LINE(token); 02608 kwd_col = TOKEN_COLUMN(token); 02609 02610 /* have keyword */ 02611 had_keyword = TRUE; 02612 item_has_keyword = TRUE; 02613 ciitem_idx = find_ciitem_idx(stmt_type); 02614 02615 if (ciitem_idx < 0) { 02616 /* ciitem not found */ 02617 PRINTMSG(TOKEN_LINE(token), 73, Error, 02618 TOKEN_COLUMN(token), NULL); 02619 parsed_ok = FALSE; 02620 parse_err_flush(Find_Comma_Rparen, NULL); 02621 continue; 02622 } 02623 02624 NEXT_LA_CH; 02625 } 02626 else { /* had id but not kwd, must reparse as expression */ 02627 02628 if (arg_cnt == 2 && 02629 had_keyword && 02630 ciitem_tbl[stmt_type].num_without_kwd == 2 && 02631 IL_FLD(arg_array[UNIT_IDX]) != NO_Tbl_Idx) { 02632 02633 /* this is an extension "write (unit = 100, *)" */ 02634 02635 PRINTMSG(LA_CH_LINE, 1208, Ansi, LA_CH_COLUMN); 02636 } 02637 else if (arg_cnt > ciitem_tbl[stmt_type].num_without_kwd || 02638 had_keyword) { 02639 /* keyword missing for something other than UNIT or FMT */ 02640 PRINTMSG(LA_CH_LINE, 139, Error, LA_CH_COLUMN); 02641 parsed_ok = FALSE; 02642 parse_err_flush(Find_Comma_Rparen, NULL); 02643 continue; 02644 } 02645 ciitem_idx = arg_idx_tbl[stmt_type][arg_cnt]; 02646 } 02647 02648 arg_idx = ciitem_tbl[stmt_type].ciitem_list[ciitem_idx].arg_position; 02649 02650 if (stmt_type == Write && 02651 (arg_idx == END_IDX || 02652 arg_idx == SIZE_IDX || 02653 arg_idx == EOR_IDX)) { 02654 02655 PRINTMSG(kwd_line, 445, Error, kwd_col, 02656 ciitem_tbl[stmt_type].ciitem_list[ciitem_idx].name); 02657 parsed_ok = FALSE; 02658 } 02659 else if (IL_FLD(arg_array[arg_idx]) != NO_Tbl_Idx) { 02660 /* can't have two args the same */ 02661 02662 if (arg_idx == FMT_IDX && 02663 (stmt_type == Read || stmt_type == Write)) { 02664 02665 if ((had_fmt && 02666 strcmp(ciitem_tbl[stmt_type].ciitem_list[ciitem_idx].name, 02667 "NML") == 0) || 02668 (had_nml && 02669 strcmp(ciitem_tbl[stmt_type].ciitem_list[ciitem_idx].name, 02670 "FMT") == 0)) { 02671 02672 PRINTMSG(TOKEN_LINE(token), 443, Error, TOKEN_COLUMN(token)); 02673 } 02674 else { 02675 PRINTMSG(TOKEN_LINE(token), 70, Error, TOKEN_COLUMN(token)); 02676 } 02677 } 02678 else { 02679 PRINTMSG(TOKEN_LINE(token), 70, Error, TOKEN_COLUMN(token)); 02680 } 02681 parsed_ok = FALSE; 02682 parse_err_flush(Find_Comma_Rparen, NULL); 02683 continue; 02684 } 02685 02686 if (LA_CH_VALUE == STAR) { 02687 02688 if (ciitem_tbl[stmt_type].ciitem_list[ciitem_idx].allowed_form == 02689 Format_Form || 02690 arg_idx == UNIT_IDX) { 02691 IL_FLD(arg_array[arg_idx]) = CN_Tbl_Idx; 02692 IL_IDX(arg_array[arg_idx]) = NULL_IDX; 02693 IL_LINE_NUM(arg_array[arg_idx]) = LA_CH_LINE; 02694 IL_COL_NUM(arg_array[arg_idx]) = LA_CH_COLUMN; 02695 } 02696 else { 02697 PRINTMSG(LA_CH_LINE, 47, Error, LA_CH_COLUMN, NULL); 02698 parsed_ok = FALSE; 02699 } 02700 NEXT_LA_CH; 02701 continue; 02702 } 02703 02704 02705 switch (ciitem_tbl[stmt_type].ciitem_list[ciitem_idx].allowed_form) { 02706 case Exp_Form : 02707 02708 parsed_ok = parse_expr(&opnd) && parsed_ok; 02709 COPY_OPND(IL_OPND(arg_array[arg_idx]), opnd); 02710 break; 02711 02712 case Label_Form : 02713 02714 switch (stmt_type) { 02715 case Backspace : 02716 ATP_HAS_ALT_RETURN(glb_tbl_idx[Backspace_Attr_Idx]) = TRUE; 02717 break; 02718 02719 case Close : 02720 ATP_HAS_ALT_RETURN(glb_tbl_idx[Close_Attr_Idx]) = TRUE; 02721 break; 02722 02723 case Endfile : 02724 ATP_HAS_ALT_RETURN(glb_tbl_idx[Endfile_Attr_Idx]) = TRUE; 02725 break; 02726 02727 case Inquire : 02728 ATP_HAS_ALT_RETURN(glb_tbl_idx[Inquire_Attr_Idx]) = TRUE; 02729 break; 02730 02731 case Open : 02732 ATP_HAS_ALT_RETURN(glb_tbl_idx[Open_Attr_Idx]) = TRUE; 02733 break; 02734 02735 case Rewind : 02736 ATP_HAS_ALT_RETURN(glb_tbl_idx[Rewind_Attr_Idx]) = TRUE; 02737 break; 02738 02739 default : 02740 break; 02741 } 02742 02743 if (LA_CH_CLASS == Ch_Class_Digit) { 02744 /* label */ 02745 02746 if (MATCHED_TOKEN_CLASS(Tok_Class_Label) && 02747 ! TOKEN_ERR(token)) { 02748 02749 attr_idx = check_label_ref(); 02750 02751 AT_REFERENCED(attr_idx) = Referenced; 02752 IL_FLD(arg_array[arg_idx]) = AT_Tbl_Idx; 02753 IL_IDX(arg_array[arg_idx]) = attr_idx; 02754 IL_LINE_NUM(arg_array[arg_idx]) = TOKEN_LINE(token); 02755 IL_COL_NUM(arg_array[arg_idx]) = TOKEN_COLUMN(token); 02756 } 02757 else if (TOKEN_ERR(token)) { 02758 parse_err_flush(Find_Comma_Rparen, NULL); 02759 parsed_ok = FALSE; 02760 } 02761 else { 02762 parse_err_flush(Find_Comma_Rparen, "LABEL"); 02763 parsed_ok = FALSE; 02764 } 02765 } 02766 else { 02767 parsed_ok = parse_expr(&opnd) && parsed_ok; 02768 COPY_OPND(IL_OPND(arg_array[arg_idx]), opnd); 02769 } 02770 break; 02771 02772 case Namelist_Form : 02773 02774 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) { 02775 parsed_ok = parse_deref(&opnd, NULL_IDX) && parsed_ok; 02776 COPY_OPND(IL_OPND(arg_array[arg_idx]), opnd); 02777 } 02778 else { 02779 /* error .. no namelist group name */ 02780 PRINTMSG(LA_CH_LINE, 173, Error, LA_CH_COLUMN, NULL); 02781 parse_err_flush(Find_Comma_Rparen, NULL); 02782 parsed_ok = FALSE; 02783 } 02784 02785 IL_NAMELIST_EXPECTED(arg_array[arg_idx]) = TRUE; 02786 IL_FORMAT_EXPECTED(arg_array[arg_idx]) = FALSE; 02787 02788 had_nml = TRUE; 02789 02790 break; 02791 02792 case Var_Only_Form : 02793 02794 parsed_ok = parse_expr(&opnd) && parsed_ok; 02795 COPY_OPND(IL_OPND(arg_array[arg_idx]), opnd); 02796 02797 mark_attr_defined(&opnd); 02798 02799 break; 02800 02801 case Format_Form : 02802 02803 buf_idx = LA_CH_BUF_IDX; 02804 02805 if (LA_CH_CLASS == Ch_Class_Digit && 02806 digit_is_format_label()) { 02807 02808 /* label */ 02809 02810 if (MATCHED_TOKEN_CLASS(Tok_Class_Label) && 02811 ! TOKEN_ERR(token)) { 02812 02813 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), 02814 &name_idx); 02815 02816 if (attr_idx == NULL_IDX) { 02817 attr_idx = ntr_sym_tbl(&token, name_idx); 02818 AT_OBJ_CLASS(attr_idx) = Label; 02819 LN_DEF_LOC(name_idx) = TRUE; 02820 build_fwd_ref_entry(attr_idx, Format_Ref); 02821 } 02822 else if ( ! AT_DCL_ERR(attr_idx) ) { 02823 02824 if (!AT_DEFINED(attr_idx)) { 02825 build_fwd_ref_entry(attr_idx, Format_Ref); 02826 } 02827 else if (ATL_CLASS(attr_idx) != Lbl_Format) { 02828 /* error .. label used previously as something else */ 02829 PRINTMSG(TOKEN_LINE(token), 328, Error, 02830 TOKEN_COLUMN(token), 02831 AT_OBJ_NAME_PTR(attr_idx)); 02832 parsed_ok = FALSE; 02833 break; 02834 } 02835 } 02836 else { 02837 /* no message, at_dcl_err is set */ 02838 parsed_ok = FALSE; 02839 break; 02840 } 02841 02842 IL_FLD(arg_array[arg_idx]) = AT_Tbl_Idx; 02843 IL_IDX(arg_array[arg_idx]) = attr_idx; 02844 IL_LINE_NUM(arg_array[arg_idx]) = TOKEN_LINE(token); 02845 IL_COL_NUM(arg_array[arg_idx]) = TOKEN_COLUMN(token); 02846 02847 if (cif_flags & XREF_RECS) { 02848 cif_usage_rec(attr_idx, AT_Tbl_Idx, 02849 TOKEN_LINE(token), TOKEN_COLUMN(token), 02850 CIF_Label_Referenced_As_Format); 02851 } 02852 } 02853 else if (TOKEN_ERR(token)) { 02854 parse_err_flush(Find_Comma_Rparen, NULL); 02855 parsed_ok = FALSE; 02856 } 02857 else { 02858 parse_err_flush(Find_Comma_Rparen, "LABEL"); 02859 parsed_ok = FALSE; 02860 } 02861 } 02862 else { 02863 parsed_ok = parse_expr(&opnd) && parsed_ok; 02864 COPY_OPND(IL_OPND(arg_array[arg_idx]), opnd); 02865 } 02866 02867 IL_FORMAT_EXPECTED(arg_array[arg_idx]) = item_has_keyword; 02868 IL_NAMELIST_EXPECTED(arg_array[arg_idx]) = FALSE; 02869 02870 if (!item_has_keyword && 02871 IL_FLD(arg_array[arg_idx]) == AT_Tbl_Idx && 02872 AT_OBJ_CLASS(IL_IDX(arg_array[arg_idx])) == Namelist_Grp) { 02873 had_nml = TRUE; 02874 } 02875 else { 02876 had_fmt = TRUE; 02877 } 02878 02879 if (had_fmt && 02880 IL_FLD(arg_array[arg_idx]) == CN_Tbl_Idx && 02881 TYP_TYPE(CN_TYPE_IDX(IL_IDX(arg_array[arg_idx]))) == 02882 Character) { 02883 02884 /* preparse format constant */ 02885 set_format_start_idx(buf_idx); 02886 02887 format_cn_idx = IL_IDX(arg_array[arg_idx]); 02888 # ifndef SOURCE_TO_SOURCE 02889 ignore_trailing_chars = TRUE; 02890 pre_parse_format_idx = pre_parse_format(format_cn_idx, 0); 02891 ignore_trailing_chars = FALSE; 02892 # endif 02893 02894 NTR_IR_LIST_TBL(list_idx); 02895 IL_FLD(arg_array[arg_idx]) = IL_Tbl_Idx; 02896 IL_IDX(arg_array[arg_idx]) = list_idx; 02897 IL_LIST_CNT(arg_array[arg_idx]) = 2; 02898 # ifndef SOURCE_TO_SOURCE 02899 IL_FLD(list_idx) = AT_Tbl_Idx; 02900 idx = create_format_tmp(format_cn_idx); 02901 # else 02902 IL_FLD(list_idx) = CN_Tbl_Idx; 02903 idx = format_cn_idx; 02904 # endif 02905 IL_IDX(list_idx) = idx; 02906 IL_LINE_NUM(list_idx) = stmt_start_line; 02907 IL_COL_NUM(list_idx) = stmt_start_col; 02908 02909 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx)); 02910 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx; 02911 list_idx = IL_NEXT_LIST_IDX(list_idx); 02912 #ifndef SOURCE_TO_SOURCE 02913 if (pre_parse_format_idx != NULL_IDX) { 02914 IL_FLD(list_idx) = AT_Tbl_Idx; 02915 idx = create_format_tmp(pre_parse_format_idx); 02916 IL_IDX(list_idx) = idx; 02917 IL_LINE_NUM(list_idx) = stmt_start_line; 02918 IL_COL_NUM(list_idx) = stmt_start_col; 02919 } 02920 # endif 02921 } 02922 02923 break; 02924 } /* switch */ 02925 02926 02927 if (ciitem_tbl[stmt_type].ciitem_list[ciitem_idx].has_const_opts && 02928 IL_FLD(arg_array[arg_idx]) == CN_Tbl_Idx && 02929 TYP_TYPE(CN_TYPE_IDX(IL_IDX(arg_array[arg_idx]))) == Character) { 02930 02931 /* make character const upper case */ 02932 for (i = 0; 02933 i < CN_INT_TO_C(TYP_IDX(CN_TYPE_IDX(IL_IDX(arg_array[arg_idx])))); 02934 i++) { 02935 02936 if (islower(((char *) 02937 &CN_CONST(IL_IDX(arg_array[arg_idx])))[i])) { 02938 ((char *)&CN_CONST(IL_IDX(arg_array[arg_idx])))[i] = 02939 TOUPPER(((char *)&CN_CONST(IL_IDX(arg_array[arg_idx])))[i]); 02940 } 02941 } 02942 /* check for correct character constant */ 02943 for (i = 0; i < ciitem_tbl[stmt_type].ciitem_list[ciitem_idx]. 02944 num_const_opts; i++) { 02945 02946 ch_ptr1 = (char *)&CN_CONST(IL_IDX(arg_array[arg_idx])); 02947 ch_ptr2 = ciitem_tbl[stmt_type].ciitem_list[ciitem_idx]. 02948 const_opts[i]; 02949 found = TRUE; 02950 while (TRUE) { 02951 02952 if (*ch_ptr2 == '\0') { 02953 break; 02954 } 02955 else if (*ch_ptr1 != *ch_ptr2) { 02956 found = FALSE; 02957 break; 02958 } 02959 ch_ptr1++; 02960 ch_ptr2++; 02961 } 02962 02963 if (found) { 02964 02965 while (*ch_ptr1 != '\0') { 02966 02967 if (*ch_ptr1 != ' ') { 02968 found = FALSE; 02969 break; 02970 } 02971 ch_ptr1++; 02972 } 02973 } 02974 02975 if (found) { 02976 break; 02977 } 02978 } 02979 02980 if (! found) { 02981 /* error .. string constant not right one. */ 02982 PRINTMSG(IL_LINE_NUM(arg_array[arg_idx]), 24, Error, 02983 IL_COL_NUM(arg_array[arg_idx]), 02984 (char *)&CN_CONST(IL_IDX(arg_array[arg_idx])), 02985 ciitem_tbl[stmt_type].ciitem_list[ciitem_idx].name); 02986 parsed_ok = FALSE; 02987 } 02988 } 02989 02990 if (LA_CH_VALUE != COMMA && 02991 LA_CH_VALUE != RPAREN) { 02992 02993 if (!parse_err_flush(Find_Comma_Rparen, ", or )")) { 02994 parsed_ok = FALSE; 02995 goto EXIT; 02996 } 02997 parsed_ok = FALSE; 02998 } 02999 } 03000 while (LA_CH_VALUE == COMMA); 03001 03002 if (LA_CH_VALUE != RPAREN) { 03003 parse_err_flush(Find_EOS,")"); 03004 parsed_ok = FALSE; 03005 goto EXIT; 03006 } 03007 else { 03008 NEXT_LA_CH; 03009 } 03010 03011 /* do some checks here */ 03012 if (IL_FLD(arg_array[UNIT_IDX]) == NO_Tbl_Idx) { 03013 /* no UNIT */ 03014 if (stmt_type == Inquire) { 03015 if (IL_FLD(arg_array[FILE_IDX]) == NO_Tbl_Idx) { 03016 /* error .. must have UNIT or FILE */ 03017 PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 440, Error, 03018 SH_COL_NUM(curr_stmt_sh_idx)); 03019 parsed_ok = FALSE; 03020 } 03021 } 03022 else { 03023 /* error .. must have unit */ 03024 PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 439, Error, 03025 SH_COL_NUM(curr_stmt_sh_idx), 03026 io_stmt_str[stmt_type]); 03027 parsed_ok = FALSE; 03028 } 03029 } 03030 03031 if (stmt_type == Inquire && 03032 IL_FLD(arg_array[UNIT_IDX]) != NO_Tbl_Idx && 03033 IL_FLD(arg_array[FILE_IDX]) != NO_Tbl_Idx) { 03034 03035 /* error.. INQUIRE can't have both UNIT and FILE */ 03036 03037 find_opnd_line_and_column((opnd_type *)&IL_OPND(arg_array[1]), 03038 &opnd_line, 03039 &opnd_column); 03040 03041 PRINTMSG(opnd_line, 442, Error, opnd_column); 03042 parsed_ok = FALSE; 03043 } 03044 03045 if (stmt_type == Read || stmt_type == Write) { 03046 03047 if (IL_FLD(arg_array[REC_IDX]) != NO_Tbl_Idx) { 03048 03049 if (IL_FLD(arg_array[END_IDX]) != NO_Tbl_Idx) { 03050 03051 /* if rec = , can't have end = */ 03052 03053 find_opnd_line_and_column((opnd_type *) 03054 &IL_OPND(arg_array[END_IDX]), 03055 &opnd_line, 03056 &opnd_column); 03057 03058 PRINTMSG(opnd_line, 463, Error, opnd_column, 03059 io_stmt_str[stmt_type]); 03060 parsed_ok = FALSE; 03061 } 03062 03063 if (IL_FLD(arg_array[FMT_IDX]) == CN_Tbl_Idx && 03064 IL_IDX(arg_array[FMT_IDX]) == NULL_IDX) { 03065 03066 /* if rec = , can't have list directed */ 03067 03068 find_opnd_line_and_column((opnd_type *) 03069 &IL_OPND(arg_array[FMT_IDX]), 03070 &opnd_line, 03071 &opnd_column); 03072 PRINTMSG(opnd_line, 464, Error, opnd_column, 03073 io_stmt_str[stmt_type]); 03074 parsed_ok = FALSE; 03075 } 03076 03077 if (IL_FLD(arg_array[ADVANCE_IDX]) != NO_Tbl_Idx) { 03078 03079 /* if ADVANCE, can't have REC= (direct access) */ 03080 03081 find_opnd_line_and_column((opnd_type *) 03082 &IL_OPND(arg_array[REC_IDX]), 03083 &opnd_line, 03084 &opnd_column); 03085 PRINTMSG(opnd_line, 473, Error, opnd_column); 03086 parsed_ok = FALSE; 03087 } 03088 } 03089 03090 /* if EOR then must have ADVANCE */ 03091 03092 if (IL_FLD(arg_array[EOR_IDX]) != NO_Tbl_Idx && 03093 IL_FLD(arg_array[ADVANCE_IDX]) == NO_Tbl_Idx) { 03094 find_opnd_line_and_column((opnd_type *)&IL_OPND(arg_array[EOR_IDX]), 03095 &opnd_line, 03096 &opnd_column); 03097 PRINTMSG(opnd_line, 465, Error, opnd_column, 03098 io_stmt_str[stmt_type]); 03099 parsed_ok = FALSE; 03100 } 03101 03102 /* if SIZE then must have ADVANCE */ 03103 03104 if (IL_FLD(arg_array[SIZE_IDX]) != NO_Tbl_Idx && 03105 IL_FLD(arg_array[ADVANCE_IDX]) == NO_Tbl_Idx) { 03106 find_opnd_line_and_column((opnd_type *) 03107 &IL_OPND(arg_array[SIZE_IDX]), 03108 &opnd_line, 03109 &opnd_column); 03110 PRINTMSG(opnd_line, 946, Error, opnd_column, 03111 io_stmt_str[stmt_type]); 03112 parsed_ok = FALSE; 03113 } 03114 03115 /* if UNIT == STAR, can't be unformatted */ 03116 03117 if (IL_FLD(arg_array[UNIT_IDX]) == CN_Tbl_Idx && 03118 IL_IDX(arg_array[UNIT_IDX]) == NULL_IDX && 03119 IL_FLD(arg_array[FMT_IDX]) == NO_Tbl_Idx) { 03120 03121 PRINTMSG(IL_LINE_NUM(arg_array[UNIT_IDX]), 03122 1207, Error, 03123 IL_COL_NUM(arg_array[UNIT_IDX])); 03124 03125 parsed_ok = FALSE; 03126 } 03127 } 03128 else { 03129 if (IL_FLD(arg_array[UNIT_IDX]) == CN_Tbl_Idx && 03130 IL_IDX(arg_array[UNIT_IDX]) == NULL_IDX) { 03131 03132 /* can't have * for UNIT on anything but read and write */ 03133 03134 PRINTMSG(IL_LINE_NUM(arg_array[UNIT_IDX]), 03135 1206, Error, 03136 IL_COL_NUM(arg_array[UNIT_IDX]), 03137 io_stmt_str[stmt_type]); 03138 03139 parsed_ok = FALSE; 03140 } 03141 } 03142 } /* else */ 03143 03144 EXIT: 03145 03146 TRACE (Func_Exit, "parse_io_control_list", NULL); 03147 03148 return(parsed_ok); 03149 } /* parse_io_control_list */ 03150 03151 /******************************************************************************\ 03152 |* *| 03153 |* Description: *| 03154 |* <description> *| 03155 |* *| 03156 |* Input parameters: *| 03157 |* NONE *| 03158 |* *| 03159 |* Output parameters: *| 03160 |* NONE *| 03161 |* *| 03162 |* Returns: *| 03163 |* NOTHING *| 03164 |* *| 03165 \******************************************************************************/ 03166 03167 static int pre_parse_format(int const_idx, 03168 int lbl_name_len) 03169 03170 03171 { 03172 int caller_flag; 03173 long format_len; 03174 long *new_fmt; 03175 int pre_parse_idx; 03176 int type_idx; 03177 boolean unused_boolean; 03178 void (*the_func)(); 03179 03180 # if defined(_HOST32) && defined(_TARGET64) 03181 int i; 03182 long *long_const; 03183 # endif 03184 03185 03186 TRACE (Func_Entry, "pre_parse_format", NULL); 03187 03188 /* KAY - should I always ask for ANSI because of the disable message stuff */ 03189 03190 caller_flag = (on_off_flags.issue_ansi_messages) ? COMPILER_CALL_ANSI_95 : 03191 COMPILER_CALL_NO_ANSI; 03192 format_len = (long) CN_INT_TO_C(TYP_IDX(CN_TYPE_IDX(const_idx))) - 03193 lbl_name_len; 03194 the_func = &emit_format_msg; 03195 03196 /* bhj wants this to hang around please */ 03197 # if 0 03198 printf("format -->%s<--\n",(char *)&CN_CONST(const_idx)); 03199 # endif 03200 03201 new_fmt = _fmt_parse(&the_func, 03202 (char *)&CN_CONST(const_idx) + lbl_name_len, 03203 caller_flag, 03204 &format_len, 03205 &unused_boolean); 03206 03207 03208 /* Word 1 of the new_fmt is reserved for use by the compiler. */ 03209 /* Currently, it is unused. Word 2 of the new_fmt is reserved */ 03210 /* for use by the library to keep track of what level it is. */ 03211 03212 /* We put the pre-parsed format into the constant table as a */ 03213 /* Typeless constant. The argument format_len is the word length */ 03214 /* of the pre-parsed format. */ 03215 03216 03217 if (new_fmt != NULL) { 03218 03219 # if 0 03220 pre_parse_idx = translate_pp_format((fmt_type *)new_fmt, format_len); 03221 # endif 03222 03223 # if defined(_HOST32) && defined(_TARGET64) 03224 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 03225 TYP_TYPE(TYP_WORK_IDX) = Typeless; 03226 TYP_BIT_LEN(TYP_WORK_IDX) = format_len * HOST_BITS_PER_WORD; 03227 type_idx = ntr_type_tbl(); 03228 03229 pre_parse_idx = ntr_const_tbl(type_idx, FALSE, NULL); 03230 03231 long_const = (long *)&CN_CONST(pre_parse_idx); 03232 03233 03234 for (i = 0; i < format_len; i++) { 03235 long_const[i] = new_fmt[i]; 03236 } 03237 # else 03238 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 03239 TYP_TYPE(TYP_WORK_IDX) = Typeless; 03240 TYP_BIT_LEN(TYP_WORK_IDX) = format_len * TARGET_BITS_PER_WORD; 03241 type_idx = ntr_type_tbl(); 03242 03243 pre_parse_idx = ntr_const_tbl(type_idx, FALSE, (long_type *)new_fmt); 03244 03245 # endif 03246 03247 MEM_FREE(new_fmt); 03248 } 03249 else { 03250 pre_parse_idx = NULL_IDX; 03251 } 03252 03253 TRACE (Func_Exit, "pre_parse_format", NULL); 03254 03255 return(pre_parse_idx); 03256 03257 } /* pre_parse_format */ 03258 03259 /******************************************************************************\ 03260 |* *| 03261 |* Description: *| 03262 |* Create a tmp with a type of a one-dimensional array to use for the *| 03263 |* format string and pre-parsed format. *| 03264 |* *| 03265 |* Input parameters: *| 03266 |* NONE *| 03267 |* *| 03268 |* Output parameters: *| 03269 |* NONE *| 03270 |* *| 03271 |* Returns: *| 03272 |* NONE *| 03273 |* *| 03274 \******************************************************************************/ 03275 03276 static int create_format_tmp (int const_idx) 03277 03278 { 03279 int attr_idx; 03280 int bd_idx; 03281 int cn_idx; 03282 int ir_idx; 03283 int list1_idx; 03284 int list2_idx; 03285 int list3_idx; 03286 long64 num_bits; 03287 long64 num_els; 03288 size_offset_type stride; 03289 opnd_type opnd; 03290 03291 03292 TRACE (Func_Entry, "create_format_tmp", NULL); 03293 03294 attr_idx = gen_compiler_tmp(stmt_start_line, 03295 stmt_start_col, 03296 Shared, TRUE); 03297 03298 /* GEN_COMPILER_TMP_ASG(ir_idx, 03299 attr_idx, 03300 FALSE, 03301 stmt_start_line, 03302 stmt_start_col, 03303 Character_4, 03304 Shared); 03305 OPND_LINE_NUM(opnd) = stmt_start_line; 03306 OPND_COL_NUM(opnd) = stmt_start_col; 03307 OPND_FLD(opnd) = CN_Tbl_Idx; 03308 OPND_IDX(opnd) = const_idx; 03309 03310 COPY_OPND(IR_OPND_R(ir_idx), (opnd)); 03311 */ 03312 /* 03313 # if defined(GENERATE_WHIRL) 03314 ATD_TYPE_IDX(attr_idx) = Integer_8; 03315 # else 03316 ATD_TYPE_IDX(attr_idx) = CG_INTEGER_DEFAULT_TYPE; 03317 # endif 03318 */ 03319 ATD_TYPE_IDX(attr_idx) = Character_4; 03320 03321 # ifndef SOURCE_TO_SOURCE 03322 ATD_SAVED(attr_idx) = TRUE; 03323 ATD_DATA_INIT(attr_idx) = TRUE; 03324 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx); 03325 # else 03326 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 03327 #endif 03328 03329 AT_SEMANTICS_DONE(attr_idx) = TRUE; 03330 ATD_READ_ONLY_VAR(attr_idx) = TRUE; 03331 03332 # ifndef SOURCE_TO_SOURCE 03333 03334 if (TYP_TYPE(CN_TYPE_IDX(const_idx)) == Character) { 03335 num_els = 1L + 03336 TARGET_BYTES_TO_WORDS(CN_INT_TO_C(TYP_IDX(CN_TYPE_IDX(const_idx)))); 03337 # if defined(GENERATE_WHIRL) 03338 # ifndef _WHIRL_HOST64_TARGET64 03339 num_els = (num_els + 1) / 2; 03340 # endif 03341 num_bits = num_els * 64; 03342 # else 03343 num_bits = num_els * TARGET_BITS_PER_WORD; 03344 # endif 03345 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 03346 TYP_TYPE(TYP_WORK_IDX) = Typeless; 03347 TYP_BIT_LEN(TYP_WORK_IDX) = num_bits; 03348 CN_TYPE_IDX(const_idx) = ntr_type_tbl(); 03349 CN_EXTRA_ZERO_WORD(const_idx) = FALSE; 03350 } 03351 else if (TYP_TYPE(CN_TYPE_IDX(const_idx)) == Typeless) { 03352 03353 num_els = TARGET_BITS_TO_WORDS((long)TYP_BIT_LEN(CN_TYPE_IDX(const_idx))); 03354 03355 # if defined(GENERATE_WHIRL) 03356 # ifndef _WHIRL_HOST64_TARGET64 03357 num_els = (num_els + 1) / 2; 03358 # endif 03359 num_bits = num_els * 64; 03360 # else 03361 num_bits = num_els * TARGET_BITS_PER_WORD; 03362 # endif 03363 } 03364 03365 cn_idx = C_INT_TO_CN(NULL_IDX, num_els); 03366 03367 03368 bd_idx = reserve_array_ntry(1); 03369 03370 set_stride_for_first_dim(ATD_TYPE_IDX(attr_idx), &stride); 03371 03372 BD_RESOLVED(bd_idx) = TRUE; 03373 BD_ARRAY_CLASS(bd_idx) = Explicit_Shape; 03374 BD_ARRAY_SIZE(bd_idx) = Constant_Size; 03375 BD_RANK(bd_idx) = 1; 03376 BD_LEN_FLD(bd_idx) = CN_Tbl_Idx; 03377 BD_LEN_IDX(bd_idx) = cn_idx; 03378 BD_LINE_NUM(bd_idx) = stmt_start_line; 03379 BD_COLUMN_NUM(bd_idx) = stmt_start_col; 03380 BD_LB_FLD(bd_idx,1) = CN_Tbl_Idx; 03381 BD_LB_IDX(bd_idx,1) = CN_INTEGER_ONE_IDX; 03382 BD_UB_FLD(bd_idx,1) = CN_Tbl_Idx; 03383 BD_UB_IDX(bd_idx,1) = cn_idx; 03384 BD_XT_FLD(bd_idx,1) = CN_Tbl_Idx; 03385 BD_XT_IDX(bd_idx,1) = cn_idx; 03386 BD_SM_FLD(bd_idx,1) = stride.fld; 03387 BD_SM_IDX(bd_idx,1) = stride.idx; 03388 ATD_ARRAY_IDX(attr_idx) = bd_idx; 03389 NTR_IR_TBL(ir_idx); 03390 IR_OPR(ir_idx) = Init_Opr; 03391 03392 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 03393 IR_LINE_NUM(ir_idx) = stmt_start_line; 03394 IR_COL_NUM(ir_idx) = stmt_start_col; 03395 03396 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 03397 IR_IDX_L(ir_idx) = attr_idx; 03398 IR_LINE_NUM_L(ir_idx) = stmt_start_line; 03399 IR_COL_NUM_L(ir_idx) = stmt_start_col; 03400 03401 03402 03403 NTR_IR_LIST_TBL(list1_idx); 03404 NTR_IR_LIST_TBL(list2_idx); 03405 NTR_IR_LIST_TBL(list3_idx); 03406 03407 IR_FLD_R(ir_idx) = IL_Tbl_Idx; 03408 IR_IDX_R(ir_idx) = list1_idx; 03409 IR_LIST_CNT_R(ir_idx) = 3; 03410 03411 IL_NEXT_LIST_IDX(list1_idx) = list2_idx; 03412 IL_PREV_LIST_IDX(list2_idx) = list1_idx; 03413 03414 IL_NEXT_LIST_IDX(list2_idx) = list3_idx; 03415 IL_PREV_LIST_IDX(list3_idx) = list2_idx; 03416 03417 IL_FLD(list1_idx) = CN_Tbl_Idx; 03418 IL_IDX(list1_idx) = const_idx; 03419 IL_LINE_NUM(list1_idx) = stmt_start_line; 03420 IL_COL_NUM(list1_idx) = stmt_start_col; 03421 03422 IL_FLD(list2_idx) = CN_Tbl_Idx; 03423 IL_IDX(list2_idx) = CN_INTEGER_ONE_IDX; 03424 IL_LINE_NUM(list2_idx) = stmt_start_line; 03425 IL_COL_NUM(list2_idx) = stmt_start_col; 03426 03427 IL_FLD(list3_idx) = CN_Tbl_Idx; 03428 IL_IDX(list3_idx) = CN_INTEGER_ZERO_IDX; 03429 IL_LINE_NUM(list3_idx) = stmt_start_line; 03430 IL_COL_NUM(list3_idx) = stmt_start_col; 03431 03432 03433 03434 ATD_FLD(attr_idx) = CN_Tbl_Idx; 03435 # else 03436 03437 ATD_FLD(attr_idx) = AT_Tbl_Idx; 03438 # endif 03439 ATD_TMP_IDX(attr_idx) = const_idx; 03440 gen_sh(Before, Assignment_Stmt, stmt_start_line, 03441 stmt_start_col, FALSE, FALSE, TRUE); 03442 03443 # ifndef SOURCE_TO_SOURCE 03444 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx; 03445 # endif 03446 03447 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 03448 03449 03450 TRACE (Func_Exit, "create_format_tmp", NULL); 03451 03452 return(attr_idx); 03453 03454 } /* create_format_tmp */ 03455 # if 0 03456 # if defined(_HOST32) && defined(_TARGET64) 03457 03458 /******************************************************************************\ 03459 |* *| 03460 |* Description: *| 03461 |* <description> *| 03462 |* *| 03463 |* Input parameters: *| 03464 |* NONE *| 03465 |* *| 03466 |* Output parameters: *| 03467 |* NONE *| 03468 |* *| 03469 |* Returns: *| 03470 |* NOTHING *| 03471 |* *| 03472 \******************************************************************************/ 03473 03474 static int translate_pp_format(char *old_const, 03475 int num_host_wds) 03476 03477 { 03478 int cn_idx; 03479 int cn_offset; 03480 int i; 03481 int new_idx; 03482 int new_revert_idx; 03483 int num_bits; 03484 int num_elements; 03485 int revert_idx; 03486 int revert_val; 03487 int str_cnt; 03488 int type_idx; 03489 03490 TRACE (Func_Entry, "translate_pp_format", NULL); 03491 03492 num_elements = num_host_wds/FMT_ENTRY_WORD_SIZE; 03493 03494 /* since the size of the new constant is dependent on the number */ 03495 /* of character strings, I will keep it as the original size and */ 03496 /* shrink it when I'm done. The parsfmt routine will stick char */ 03497 /* strings into consecutive structures which are 20 bytes long */ 03498 /* on the sun. The structure is 16 bytes on crays so I can't */ 03499 /* calculate the new size. */ 03500 03501 num_bits = num_host_wds * HOST_BITS_PER_WORD; 03502 03503 /* get constant */ 03504 03505 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 03506 TYP_TYPE(TYP_WORK_IDX) = Typeless; 03507 TYP_BIT_LEN(TYP_WORK_IDX) = num_bits; 03508 type_idx = ntr_type_tbl(); 03509 03510 cn_idx = ntr_const_tbl(type_idx, FALSE, NULL); 03511 03512 # ifdef _DEBUG 03513 if (old_const[num_elements-1].op_code != REVERT_OP) { 03514 PRINTMSG(stmt_start_line, 1095, Internal, stmt_start_col); 03515 } 03516 # endif 03517 03518 revert_val = old_const[num_elements-1].rep_count; 03519 revert_idx = revert_val + (num_elements - 1); 03520 03521 /* now fill in the constant */ 03522 03523 cn_offset = 0; 03524 03525 for (i = 0; i < num_elements; i++) { 03526 03527 new_idx = cn_offset/2; 03528 03529 if (i == revert_idx) { 03530 new_revert_idx = new_idx; 03531 } 03532 03533 CP_CONSTANT(CN_POOL_IDX(cn_idx) + cn_offset) = /* BRIANJ */ 03534 ((long_type)(old_const[i].op_code)) << 57 | 03535 ((long_type)(old_const[i].reserved1)) << 54 | 03536 ((long_type)(old_const[i].exponent)) << 48 | 03537 ((long_type)(old_const[i].decimal_field)) << 24 | 03538 old_const[i].field_width; 03539 03540 cn_offset++; 03541 03542 CP_CONSTANT(CN_POOL_IDX(cn_idx) + cn_offset) = /* BRIANJ */ 03543 ((long_type)(old_const[i].rgcdedf)) << 63 | 03544 ((long_type)(old_const[i].reserved2)) << 48 | 03545 ((long_type)(old_const[i].offset)) << 32; 03546 03547 if (i == num_elements - 1) { 03548 CP_CONSTANT(CN_POOL_IDX(cn_idx) + cn_offset) |= /* BRIANJ */ 03549 ((new_revert_idx - new_idx) & 037777777777); 03550 } 03551 else { 03552 CP_CONSTANT(CN_POOL_IDX(cn_idx) + cn_offset) |= /* BRIANJ */ 03553 (old_const[i].rep_count & 037777777777); 03554 } 03555 03556 cn_offset++; 03557 03558 if (old_const[i].op_code == STRING_ED) { 03559 03560 /* the string is in the next node */ 03561 str_cnt = old_const[i].field_width; 03562 03563 strncpy((char *)&(CP_CONSTANT(CN_POOL_IDX(cn_idx) + cn_offset)), 03564 (char *)&(old_const[i+1]), 03565 str_cnt); 03566 03567 03568 /* now calculate where we are */ 03569 cn_offset += ((str_cnt + 15) / 16) * 2; 03570 i += (str_cnt + FMT_ENTRY_BYTE_SIZE - 1) / FMT_ENTRY_BYTE_SIZE; 03571 } 03572 } 03573 03574 /* now calculate the new length */ 03575 num_bits = cn_offset * TARGET_BITS_PER_WORD; 03576 03577 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 03578 TYP_TYPE(TYP_WORK_IDX) = Typeless; 03579 TYP_BIT_LEN(TYP_WORK_IDX) = num_bits; 03580 type_idx = ntr_type_tbl(); 03581 03582 CN_TYPE_IDX(cn_idx) = type_idx; 03583 03584 TRACE (Func_Exit, "translate_pp_format", NULL); 03585 03586 return(cn_idx); 03587 03588 } /* translate_pp_format */ 03589 # endif 03590 # endif
1.7.6.1 
