00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027
00028
00029
00030
00031
00032
00033
00034
00035
00036
00037 static char USMID[] = "\n@(#)5.0_pl/sources/p_io.c 5.3 06/17/99 09:28:10\n";
00038
00039 # include "defines.h"
00040
00041 # include "host.m"
00042 # include "host.h"
00043 # include "target.m"
00044 # include "target.h"
00045
00046 # include "globals.m"
00047 # include "tokens.m"
00048 # include "sytb.m"
00049 # include "p_globals.m"
00050 # include "debug.m"
00051 # 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
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
00073
00074
00075
00076
00077
00078
00079
00080
00081
00082
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
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
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
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 }
00176
00177
00178
00179
00180
00181
00182
00183
00184
00185
00186
00187
00188
00189
00190
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 }
00397
00398
00399
00400
00401
00402
00403
00404
00405
00406
00407
00408
00409
00410
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
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 }
00481
00482
00483
00484
00485
00486
00487
00488
00489
00490
00491
00492
00493
00494
00495
00496
00497
00498 void parse_decode_stmt (void)
00499
00500 {
00501
00502
00503
00504
00505
00506
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
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
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
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 }
00724
00725
00726
00727
00728
00729
00730
00731
00732
00733
00734
00735
00736
00737
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
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
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
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 }
00960
00961
00962
00963
00964
00965
00966
00967
00968
00969
00970
00971
00972
00973
00974
00975
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
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
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
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 }
01073
01074
01075
01076
01077
01078
01079
01080
01081
01082
01083
01084
01085
01086
01087
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
01106
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
01156 }
01157 }
01158 else {
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 }
01169
01170
01171
01172
01173
01174
01175
01176
01177
01178
01179
01180
01181
01182
01183
01184
01185
01186
01187
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
01226
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;
01259
01260 }
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
01311
01312
01313
01314
01315
01316
01317
01318
01319
01320
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
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 }
01449
01450
01451
01452
01453
01454
01455
01456
01457
01458
01459
01460
01461
01462
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
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 }
01533
01534
01535
01536
01537
01538
01539
01540
01541
01542
01543
01544
01545
01546
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
01571
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
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
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
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
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 }
01752
01753
01754
01755
01756
01757
01758
01759
01760
01761
01762
01763
01764
01765
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
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
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
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
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 }
01973
01974
01975
01976
01977
01978
01979
01980
01981
01982
01983
01984
01985
01986
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
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
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
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 }
02080
02081
02082
02083
02084
02085
02086
02087
02088
02089
02090
02091
02092
02093
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
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
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
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
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
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 }
02301
02302
02303
02304
02305
02306
02307
02308
02309
02310
02311
02312
02313
02314
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
02368 reset_lex(buf_idx,stmt_num);
02369 parsed_ok = parse_expr(&opnd) && parsed_ok;
02370 }
02371 else {
02372
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 }
02435
02436
02437
02438
02439
02440
02441
02442
02443
02444
02445
02446
02447
02448
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
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 }
02506
02507
02508
02509
02510
02511
02512
02513
02514
02515
02516
02517
02518
02519
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
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
02611 had_keyword = TRUE;
02612 item_has_keyword = TRUE;
02613 ciitem_idx = find_ciitem_idx(stmt_type);
02614
02615 if (ciitem_idx < 0) {
02616
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 {
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
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
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
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
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
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
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
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
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
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 }
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
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
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
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
03012 if (IL_FLD(arg_array[UNIT_IDX]) == NO_Tbl_Idx) {
03013
03014 if (stmt_type == Inquire) {
03015 if (IL_FLD(arg_array[FILE_IDX]) == NO_Tbl_Idx) {
03016
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
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
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
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
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
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
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
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
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
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 }
03143
03144 EXIT:
03145
03146 TRACE (Func_Exit, "parse_io_control_list", NULL);
03147
03148 return(parsed_ok);
03149 }
03150
03151
03152
03153
03154
03155
03156
03157
03158
03159
03160
03161
03162
03163
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
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
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
03209
03210
03211
03212
03213
03214
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 }
03258
03259
03260
03261
03262
03263
03264
03265
03266
03267
03268
03269
03270
03271
03272
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
03299
03300
03301
03302
03303
03304
03305
03306
03307
03308
03309
03310
03311
03312
03313
03314
03315
03316
03317
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 }
03455 # if 0
03456 # if defined(_HOST32) && defined(_TARGET64)
03457
03458
03459
03460
03461
03462
03463
03464
03465
03466
03467
03468
03469
03470
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
03495
03496
03497
03498
03499
03500
03501 num_bits = num_host_wds * HOST_BITS_PER_WORD;
03502
03503
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
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) =
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) =
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) |=
03549 ((new_revert_idx - new_idx) & 037777777777);
03550 }
03551 else {
03552 CP_CONSTANT(CN_POOL_IDX(cn_idx) + cn_offset) |=
03553 (old_const[i].rep_count & 037777777777);
03554 }
03555
03556 cn_offset++;
03557
03558 if (old_const[i].op_code == STRING_ED) {
03559
03560
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
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
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 }
03589 # endif
03590 # endif
