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
00038
00039
00040
00041 static char USMID[] = "\n@(#)5.0_pl/sources/p_io.c 5.3 06/17/99 09:28:10\n";
00042
00043 # include "defines.h"
00044
00045 # include "host.m"
00046 # include "host.h"
00047 # include "target.m"
00048 # include "target.h"
00049
00050 # include "globals.m"
00051 # include "tokens.m"
00052 # include "sytb.m"
00053 # include "p_globals.m"
00054 # include "debug.m"
00055 # include "p_io.m"
00056
00057 # include "globals.h"
00058 # include "tokens.h"
00059 # include "sytb.h"
00060 # include "p_globals.h"
00061 # include "p_io.h"
00062
00063
00064
00065
00066 extern long *_fmt_parse(void (**msg_rtn)(), char *, int, long *, boolean *);
00067 void emit_format_msg(int, int, int);
00068 static int find_ciitem_idx (io_stmt_type);
00069 static boolean parse_io_control_list (opnd_type *, io_stmt_type);
00070 static int pre_parse_format(int, int);
00071 static int create_format_tmp (int);
00072
00073
00074
00075
00076
00077
00078
00079
00080
00081
00082
00083
00084
00085
00086
00087
00088
00089 void parse_backspace_stmt (void)
00090
00091 {
00092 int call_idx;
00093 int list_idx;
00094 opnd_type opnd;
00095 boolean parsed_ok = TRUE;
00096
00097
00098 TRACE (Func_Entry, "parse_backspace_stmt", NULL);
00099
00100 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) {
00101 curr_stmt_category = Executable_Stmt_Cat;
00102 }
00103
00104 if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
00105 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) {
00106 PRINTMSG(TOKEN_LINE(token), 1262, Error, TOKEN_COLUMN(token),
00107 stmt_type_str[stmt_type],
00108 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure" : "elemental",
00109 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));
00110 }
00111
00112 INSERT_IO_START;
00113
00114 NTR_IR_TBL(call_idx);
00115 SH_IR_IDX(curr_stmt_sh_idx) = call_idx;
00116
00117 IR_OPR(call_idx) = Call_Opr;
00118 IR_TYPE_IDX(call_idx) = TYPELESS_DEFAULT_TYPE;
00119 IR_COL_NUM(call_idx) = TOKEN_COLUMN(token);
00120 IR_LINE_NUM(call_idx) = TOKEN_LINE(token);
00121
00122
00123
00124 if (glb_tbl_idx[Backspace_Attr_Idx] == NULL_IDX) {
00125 glb_tbl_idx[Backspace_Attr_Idx] = create_lib_entry_attr(
00126 BACKSPACE_LIB_ENTRY,
00127 BACKSPACE_NAME_LEN,
00128 TOKEN_LINE(token),
00129 TOKEN_COLUMN(token));
00130 }
00131
00132 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Backspace_Attr_Idx]);
00133
00134 IR_FLD_L(call_idx) = AT_Tbl_Idx;
00135 IR_IDX_L(call_idx) = glb_tbl_idx[Backspace_Attr_Idx];
00136 IR_LINE_NUM_L(call_idx) = TOKEN_LINE(token);
00137 IR_COL_NUM_L(call_idx) = TOKEN_COLUMN(token);
00138
00139 if (LA_CH_VALUE == LPAREN) {
00140 parsed_ok = parse_io_control_list(&opnd, Backspace);
00141 COPY_OPND(IR_OPND_R(call_idx), opnd);
00142 }
00143 else {
00144
00145 parsed_ok = parse_expr(&opnd);
00146 NTR_IR_LIST_TBL(list_idx);
00147 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
00148 IR_FLD_R(call_idx) = IL_Tbl_Idx;
00149 IR_IDX_R(call_idx) = list_idx;
00150 COPY_OPND(IL_OPND(list_idx), opnd);
00151 IR_LIST_CNT_R(call_idx) = 3;
00152
00153
00154 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
00155 list_idx = IL_NEXT_LIST_IDX(list_idx);
00156 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
00157
00158
00159 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
00160 list_idx = IL_NEXT_LIST_IDX(list_idx);
00161 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
00162 }
00163
00164 if (LA_CH_VALUE != EOS) {
00165 parse_err_flush(Find_EOS, EOS_STR);
00166 parsed_ok = FALSE;
00167 }
00168
00169 matched_specific_token(Tok_EOS, Tok_Class_Punct);
00170
00171 SH_ERR_FLG(curr_stmt_sh_idx) = ! parsed_ok;
00172
00173 INSERT_IO_END;
00174
00175 TRACE (Func_Exit, "parse_backspace_stmt", NULL);
00176
00177 return;
00178
00179 }
00180
00181
00182
00183
00184
00185
00186
00187
00188
00189
00190
00191
00192
00193
00194
00195
00196
00197
00198 void parse_buffer_stmt (void)
00199
00200 {
00201 boolean buffer_in;
00202 int ir_idx;
00203 int list1_idx;
00204 int list2_idx;
00205 int list3_idx;
00206 int list4_idx;
00207 opnd_type opnd;
00208 boolean parsed_ok = TRUE;
00209
00210
00211 TRACE (Func_Entry, "parse_buffer_stmt", NULL);
00212
00213 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) {
00214 curr_stmt_category = Executable_Stmt_Cat;
00215 }
00216
00217 INSERT_IO_START;
00218
00219 NTR_IR_TBL(ir_idx);
00220 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
00221 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token);
00222 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token);
00223
00224 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
00225
00226 IR_OPR(ir_idx) = Call_Opr;
00227 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
00228
00229 if (strcmp(TOKEN_STR(token), "IN") == 0) {
00230
00231 buffer_in = TRUE;
00232
00233 if (glb_tbl_idx[Buffer_In_Attr_Idx] == NULL_IDX) {
00234 glb_tbl_idx[Buffer_In_Attr_Idx] =
00235 create_lib_entry_attr(BUFFER_IN_LIB_ENTRY,
00236 BUFFER_IN_NAME_LEN,
00237 TOKEN_LINE(token),
00238 TOKEN_COLUMN(token));
00239 }
00240
00241 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Buffer_In_Attr_Idx]);
00242
00243 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
00244 IR_IDX_L(ir_idx) = glb_tbl_idx[Buffer_In_Attr_Idx];
00245 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token);
00246 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
00247 }
00248 else if (strcmp(TOKEN_STR(token), "OUT") == 0) {
00249
00250 buffer_in = FALSE;
00251
00252 if (glb_tbl_idx[Buffer_Out_Attr_Idx] == NULL_IDX) {
00253 glb_tbl_idx[Buffer_Out_Attr_Idx] =
00254 create_lib_entry_attr(BUFFER_OUT_LIB_ENTRY,
00255 BUFFER_OUT_NAME_LEN,
00256 TOKEN_LINE(token),
00257 TOKEN_COLUMN(token));
00258 }
00259
00260 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Buffer_Out_Attr_Idx]);
00261
00262 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
00263 IR_IDX_L(ir_idx) = glb_tbl_idx[Buffer_Out_Attr_Idx];
00264 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token);
00265 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
00266 }
00267 else {
00268 parsed_ok = FALSE;
00269 PRINTMSG(TOKEN_LINE(token), 197, Error, TOKEN_COLUMN(token),
00270 "IN or OUT",TOKEN_STR(token));
00271 parse_err_flush(Find_EOS, NULL);
00272 goto EXIT;
00273 }
00274
00275 if (LA_CH_VALUE != LPAREN) {
00276 parse_err_flush(Find_EOS, "(");
00277 parsed_ok = FALSE;
00278 goto EXIT;
00279 }
00280
00281 if (cif_flags & MISC_RECS) {
00282 cif_stmt_type_rec(TRUE,
00283 (buffer_in) ?
00284 CIF_Buffer_In_Stmt : CIF_Buffer_Out_Stmt,
00285 statement_number);
00286 }
00287
00288 NEXT_LA_CH;
00289
00290 NTR_IR_LIST_TBL(list1_idx);
00291 NTR_IR_LIST_TBL(list2_idx);
00292 NTR_IR_LIST_TBL(list3_idx);
00293 NTR_IR_LIST_TBL(list4_idx);
00294 IR_FLD_R(ir_idx) = IL_Tbl_Idx;
00295 IR_LIST_CNT_R(ir_idx) = 4;
00296 IR_IDX_R(ir_idx) = list1_idx;
00297 IL_NEXT_LIST_IDX(list1_idx) = list2_idx;
00298 IL_NEXT_LIST_IDX(list2_idx) = list3_idx;
00299 IL_NEXT_LIST_IDX(list3_idx) = list4_idx;
00300
00301 IL_ARG_DESC_VARIANT(list1_idx) = TRUE;
00302 IL_ARG_DESC_VARIANT(list2_idx) = TRUE;
00303 IL_ARG_DESC_VARIANT(list3_idx) = TRUE;
00304 IL_ARG_DESC_VARIANT(list4_idx) = TRUE;
00305
00306 parsed_ok = parse_expr(&opnd) && parsed_ok;
00307 COPY_OPND(IL_OPND(list1_idx), opnd);
00308
00309 if (LA_CH_VALUE != COMMA) {
00310 parse_err_flush(Find_EOS, ",");
00311 parsed_ok = FALSE;
00312 goto EXIT;
00313 }
00314
00315 NEXT_LA_CH;
00316
00317 parsed_ok = parse_expr(&opnd) && parsed_ok;
00318 COPY_OPND(IL_OPND(list2_idx), opnd);
00319
00320 if (LA_CH_VALUE != RPAREN) {
00321 parse_err_flush(Find_EOS, ")");
00322 parsed_ok = FALSE;
00323 goto EXIT;
00324 }
00325
00326 NEXT_LA_CH;
00327
00328 if (LA_CH_VALUE != LPAREN) {
00329 parse_err_flush(Find_EOS, "(");
00330 parsed_ok = FALSE;
00331 goto EXIT;
00332 }
00333
00334 NEXT_LA_CH;
00335
00336 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
00337 parsed_ok = parse_deref(&opnd, NULL_IDX) && parsed_ok;
00338 COPY_OPND(IL_OPND(list3_idx), opnd);
00339
00340 if (buffer_in) {
00341 mark_attr_defined(&opnd);
00342 }
00343 }
00344 else {
00345 parse_err_flush(Find_EOS, "IDENTIFIER");
00346 parsed_ok = FALSE;
00347 goto EXIT;
00348 }
00349
00350 if (LA_CH_VALUE != COMMA) {
00351 parse_err_flush(Find_EOS, ",");
00352 parsed_ok = FALSE;
00353 goto EXIT;
00354 }
00355
00356 NEXT_LA_CH;
00357
00358 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
00359 parsed_ok = parse_deref(&opnd, NULL_IDX) && parsed_ok;
00360 COPY_OPND(IL_OPND(list4_idx), opnd);
00361
00362 if (buffer_in) {
00363 mark_attr_defined(&opnd);
00364 }
00365 }
00366 else {
00367 parse_err_flush(Find_EOS, "IDENTIFIER");
00368 parsed_ok = FALSE;
00369 goto EXIT;
00370 }
00371
00372 if (LA_CH_VALUE != RPAREN) {
00373 parse_err_flush(Find_EOS, ")");
00374 parsed_ok = FALSE;
00375 }
00376 else {
00377 NEXT_LA_CH;
00378 }
00379 }
00380 else {
00381 parse_err_flush(Find_EOS, "IN or OUT");
00382 parsed_ok = FALSE;
00383 }
00384
00385 EXIT:
00386
00387 if (LA_CH_VALUE != EOS) {
00388 parse_err_flush(Find_EOS, EOS_STR);
00389 parsed_ok = FALSE;
00390 }
00391
00392 NEXT_LA_CH;
00393
00394 INSERT_IO_END;
00395
00396 TRACE (Func_Exit, "parse_buffer_stmt", NULL);
00397
00398 return;
00399
00400 }
00401
00402
00403
00404
00405
00406
00407
00408
00409
00410
00411
00412
00413
00414
00415
00416
00417
00418 void parse_close_stmt (void)
00419
00420 {
00421 int call_idx;
00422 opnd_type opnd;
00423 boolean parsed_ok = TRUE;
00424
00425
00426 TRACE (Func_Entry, "parse_close_stmt", NULL);
00427
00428 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) {
00429 curr_stmt_category = Executable_Stmt_Cat;
00430 }
00431
00432 if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
00433 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) {
00434 PRINTMSG(TOKEN_LINE(token), 1262, Error, TOKEN_COLUMN(token),
00435 stmt_type_str[stmt_type],
00436 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure" : "elemental",
00437 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));
00438 }
00439
00440 INSERT_IO_START;
00441
00442 NTR_IR_TBL(call_idx);
00443 SH_IR_IDX(curr_stmt_sh_idx) = call_idx;
00444
00445 IR_OPR(call_idx) = Call_Opr;
00446 IR_TYPE_IDX(call_idx) = TYPELESS_DEFAULT_TYPE;
00447 IR_COL_NUM(call_idx) = TOKEN_COLUMN(token);
00448 IR_LINE_NUM(call_idx) = TOKEN_LINE(token);
00449
00450
00451
00452 if (glb_tbl_idx[Close_Attr_Idx] == NULL_IDX) {
00453 glb_tbl_idx[Close_Attr_Idx] = create_lib_entry_attr(CLOSE_LIB_ENTRY,
00454 CLOSE_NAME_LEN,
00455 TOKEN_LINE(token),
00456 TOKEN_COLUMN(token));
00457 }
00458
00459 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Close_Attr_Idx]);
00460
00461 IR_FLD_L(call_idx) = AT_Tbl_Idx;
00462 IR_IDX_L(call_idx) = glb_tbl_idx[Close_Attr_Idx];
00463 IR_LINE_NUM_L(call_idx) = TOKEN_LINE(token);
00464 IR_COL_NUM_L(call_idx) = TOKEN_COLUMN(token);
00465
00466 parsed_ok = parse_io_control_list(&opnd, Close);
00467 COPY_OPND(IR_OPND_R(call_idx), opnd);
00468
00469 if (LA_CH_VALUE != EOS) {
00470 parse_err_flush(Find_EOS, EOS_STR);
00471 parsed_ok = FALSE;
00472 }
00473
00474 matched_specific_token(Tok_EOS, Tok_Class_Punct);
00475
00476 SH_ERR_FLG(curr_stmt_sh_idx) = ! parsed_ok;
00477
00478 INSERT_IO_END;
00479
00480 TRACE (Func_Exit, "parse_close_stmt", NULL);
00481
00482 return;
00483
00484 }
00485
00486
00487
00488
00489
00490
00491
00492
00493
00494
00495
00496
00497
00498
00499
00500
00501
00502 void parse_decode_stmt (void)
00503
00504 {
00505
00506
00507
00508
00509
00510
00511
00512 int attr_idx;
00513 int buf_idx;
00514 int column;
00515 int idx;
00516 int ir_idx;
00517 int line;
00518 int list_idx;
00519 int list1_idx;
00520 int list2_idx;
00521 int list3_idx;
00522 int name_idx;
00523 opnd_type opnd;
00524 boolean parsed_ok = TRUE;
00525 int pre_parse_format_idx;
00526
00527
00528 TRACE (Func_Entry, "parse_decode_stmt", NULL);
00529
00530 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) {
00531 curr_stmt_category = Executable_Stmt_Cat;
00532 }
00533
00534 INSERT_IO_START;
00535
00536 NTR_IR_TBL(ir_idx);
00537 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
00538
00539 IR_OPR(ir_idx) = Read_Formatted_Opr;
00540 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
00541 column = TOKEN_COLUMN(token);
00542 IR_COL_NUM(ir_idx) = column;
00543 line = TOKEN_LINE(token);
00544 IR_LINE_NUM(ir_idx) = line;
00545
00546 if (LA_CH_VALUE == LPAREN) {
00547 IR_FLD_L(ir_idx) = IL_Tbl_Idx;
00548 IR_LIST_CNT_L(ir_idx) = 3;
00549 NTR_IR_LIST_TBL(list1_idx);
00550 NTR_IR_LIST_TBL(list2_idx);
00551 NTR_IR_LIST_TBL(list3_idx);
00552 IR_IDX_L(ir_idx) = list1_idx;
00553 IL_NEXT_LIST_IDX(list1_idx) = list2_idx;
00554 IL_NEXT_LIST_IDX(list2_idx) = list3_idx;
00555 IL_PREV_LIST_IDX(list2_idx) = list1_idx;
00556 IL_PREV_LIST_IDX(list3_idx) = list2_idx;
00557
00558 NEXT_LA_CH;
00559
00560 parsed_ok = parse_expr(&opnd);
00561 COPY_OPND(IL_OPND(list1_idx), opnd);
00562
00563 if (LA_CH_VALUE != COMMA) {
00564 parse_err_flush(Find_Rparen, ",");
00565 parsed_ok = FALSE;
00566 }
00567 else {
00568
00569 NEXT_LA_CH;
00570
00571 buf_idx = LA_CH_BUF_IDX;
00572
00573 if (LA_CH_CLASS == Ch_Class_Digit &&
00574 digit_is_format_label()) {
00575
00576 if (MATCHED_TOKEN_CLASS(Tok_Class_Label) &&
00577 ! TOKEN_ERR(token)) {
00578
00579 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token),
00580 &name_idx);
00581
00582 if (attr_idx == NULL_IDX) {
00583 attr_idx = ntr_sym_tbl(&token, name_idx);
00584 AT_OBJ_CLASS(attr_idx) = Label;
00585 LN_DEF_LOC(name_idx) = TRUE;
00586 build_fwd_ref_entry(attr_idx, Format_Ref);
00587 }
00588 else if ( ! AT_DCL_ERR(attr_idx) ) {
00589
00590 if (!AT_DEFINED(attr_idx)) {
00591 build_fwd_ref_entry(attr_idx, Format_Ref);
00592 }
00593 else if (ATL_CLASS(attr_idx) != Lbl_Format) {
00594
00595 PRINTMSG(TOKEN_LINE(token), 328, Error,
00596 TOKEN_COLUMN(token),
00597 AT_OBJ_NAME_PTR(attr_idx));
00598 parsed_ok = FALSE;
00599 }
00600
00601 }
00602 else {
00603
00604 parsed_ok = FALSE;
00605 }
00606
00607 IL_FLD(list2_idx) = AT_Tbl_Idx;
00608 IL_IDX(list2_idx) = attr_idx;
00609 IL_LINE_NUM(list2_idx) = TOKEN_LINE(token);
00610 IL_COL_NUM(list2_idx) = TOKEN_COLUMN(token);
00611
00612 if (cif_flags & XREF_RECS) {
00613 cif_usage_rec(attr_idx, AT_Tbl_Idx,
00614 TOKEN_LINE(token), TOKEN_COLUMN(token),
00615 CIF_Label_Referenced_As_Format);
00616 }
00617
00618 }
00619 else if (TOKEN_ERR(token)) {
00620 parse_err_flush(Find_Comma, NULL);
00621 parsed_ok = FALSE;
00622 }
00623 else {
00624 parse_err_flush(Find_Comma, "LABEL");
00625 parsed_ok = FALSE;
00626 }
00627 }
00628 else {
00629 parsed_ok = parse_expr(&opnd) && parsed_ok;
00630 COPY_OPND(IL_OPND(list2_idx), opnd);
00631 }
00632
00633 if (parsed_ok &&
00634 IL_FLD(list2_idx) == CN_Tbl_Idx &&
00635 TYP_TYPE(CN_TYPE_IDX(IL_IDX(list2_idx))) == Character) {
00636
00637
00638 set_format_start_idx(buf_idx);
00639
00640 format_cn_idx = IL_IDX(list2_idx);
00641 ignore_trailing_chars = TRUE;
00642 pre_parse_format_idx = pre_parse_format(format_cn_idx, 0);
00643 ignore_trailing_chars = FALSE;
00644
00645 NTR_IR_LIST_TBL(list_idx);
00646 IL_FLD(list2_idx) = IL_Tbl_Idx;
00647 IL_IDX(list2_idx) = list_idx;
00648 IL_LIST_CNT(list2_idx) = 2;
00649
00650 IL_FLD(list_idx) = AT_Tbl_Idx;
00651 idx = create_format_tmp(format_cn_idx);
00652 IL_IDX(list_idx) = idx;
00653 IL_LINE_NUM(list_idx) = line;
00654 IL_COL_NUM(list_idx) = column;
00655
00656 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
00657 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
00658 list_idx = IL_NEXT_LIST_IDX(list_idx);
00659
00660 if (pre_parse_format_idx != NULL_IDX) {
00661 IL_FLD(list_idx) = AT_Tbl_Idx;
00662 idx = create_format_tmp(pre_parse_format_idx);
00663 IL_IDX(list_idx) = idx;
00664 IL_LINE_NUM(list_idx) = line;
00665 IL_COL_NUM(list_idx) = column;
00666 }
00667 }
00668
00669 if (LA_CH_VALUE != COMMA) {
00670 parse_err_flush(Find_Rparen, ",");
00671 parsed_ok = FALSE;
00672 }
00673 else {
00674 NEXT_LA_CH;
00675
00676 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
00677 parsed_ok = parse_deref(&opnd, NULL_IDX) && parsed_ok;
00678 COPY_OPND(IL_OPND(list3_idx), opnd);
00679 }
00680 else {
00681 parse_err_flush(Find_Rparen, "IDENTIFIER");
00682 parsed_ok = FALSE;
00683 }
00684 }
00685
00686 if (LA_CH_VALUE != RPAREN) {
00687
00688 if (parse_err_flush(Find_Rparen, ")")) {
00689 NEXT_LA_CH;
00690 }
00691 parsed_ok = FALSE;
00692 }
00693 else {
00694 NEXT_LA_CH;
00695 }
00696 }
00697
00698 if (LA_CH_VALUE != EOS) {
00699
00700 parsed_ok = parse_io_list(&opnd) && parsed_ok;
00701 COPY_OPND(IR_OPND_R(ir_idx), opnd);
00702 }
00703 }
00704 else {
00705 parse_err_flush(Find_EOS, "(");
00706 parsed_ok = FALSE;
00707 }
00708
00709 if (LA_CH_VALUE != EOS) {
00710 parse_err_flush(Find_EOS, EOS_STR);
00711 parsed_ok = FALSE;
00712 }
00713
00714 matched_specific_token(Tok_EOS, Tok_Class_Punct);
00715
00716 INSERT_IO_END;
00717
00718 TRACE (Func_Exit, "parse_decode_stmt", NULL);
00719
00720 return;
00721
00722 }
00723
00724
00725
00726
00727
00728
00729
00730
00731
00732
00733
00734
00735
00736
00737
00738
00739
00740 void parse_encode_stmt (void)
00741
00742 {
00743 int attr_idx;
00744 int buf_idx;
00745 int column;
00746 int idx;
00747 int ir_idx;
00748 int line;
00749 int list_idx;
00750 int list1_idx;
00751 int list2_idx;
00752 int list3_idx;
00753 int name_idx;
00754 opnd_type opnd;
00755 boolean parsed_ok = TRUE;
00756 int pre_parse_format_idx;
00757
00758
00759 TRACE (Func_Entry, "parse_encode_stmt", NULL);
00760
00761 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) {
00762 curr_stmt_category = Executable_Stmt_Cat;
00763 }
00764
00765 INSERT_IO_START;
00766
00767 NTR_IR_TBL(ir_idx);
00768 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
00769
00770 IR_OPR(ir_idx) = Write_Formatted_Opr;
00771 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
00772 column = TOKEN_COLUMN(token);
00773 IR_COL_NUM(ir_idx) = column;
00774 line = TOKEN_LINE(token);
00775 IR_LINE_NUM(ir_idx) = line;
00776
00777 if (LA_CH_VALUE == LPAREN) {
00778 IR_FLD_L(ir_idx) = IL_Tbl_Idx;
00779 IR_LIST_CNT_L(ir_idx) = 3;
00780 NTR_IR_LIST_TBL(list1_idx);
00781 NTR_IR_LIST_TBL(list2_idx);
00782 NTR_IR_LIST_TBL(list3_idx);
00783 IR_IDX_L(ir_idx) = list1_idx;
00784 IL_NEXT_LIST_IDX(list1_idx) = list2_idx;
00785 IL_NEXT_LIST_IDX(list2_idx) = list3_idx;
00786 IL_PREV_LIST_IDX(list2_idx) = list1_idx;
00787 IL_PREV_LIST_IDX(list3_idx) = list2_idx;
00788
00789 NEXT_LA_CH;
00790
00791 parsed_ok = parse_expr(&opnd);
00792 COPY_OPND(IL_OPND(list1_idx), opnd);
00793
00794 if (LA_CH_VALUE != COMMA) {
00795 parse_err_flush(Find_Rparen, ",");
00796 parsed_ok = FALSE;
00797 }
00798 else {
00799
00800 NEXT_LA_CH;
00801
00802 buf_idx = LA_CH_BUF_IDX;
00803
00804 if (LA_CH_CLASS == Ch_Class_Digit &&
00805 digit_is_format_label()) {
00806
00807 if (MATCHED_TOKEN_CLASS(Tok_Class_Label) &&
00808 ! TOKEN_ERR(token)) {
00809
00810 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token),
00811 &name_idx);
00812
00813 if (attr_idx == NULL_IDX) {
00814 attr_idx = ntr_sym_tbl(&token, name_idx);
00815 AT_OBJ_CLASS(attr_idx) = Label;
00816 LN_DEF_LOC(name_idx) = TRUE;
00817 build_fwd_ref_entry(attr_idx, Format_Ref);
00818 }
00819 else if ( ! AT_DCL_ERR(attr_idx) ) {
00820
00821 if (!AT_DEFINED(attr_idx)) {
00822 build_fwd_ref_entry(attr_idx, Format_Ref);
00823 }
00824 else if (ATL_CLASS(attr_idx) != Lbl_Format) {
00825
00826 PRINTMSG(TOKEN_LINE(token), 328, Error,
00827 TOKEN_COLUMN(token),
00828 AT_OBJ_NAME_PTR(attr_idx));
00829 parsed_ok = FALSE;
00830 }
00831
00832 }
00833 else {
00834
00835 parsed_ok = FALSE;
00836 }
00837
00838 IL_FLD(list2_idx) = AT_Tbl_Idx;
00839 IL_IDX(list2_idx) = attr_idx;
00840 IL_LINE_NUM(list2_idx) = TOKEN_LINE(token);
00841 IL_COL_NUM(list2_idx) = TOKEN_COLUMN(token);
00842
00843 if (cif_flags & XREF_RECS) {
00844 cif_usage_rec(attr_idx, AT_Tbl_Idx,
00845 TOKEN_LINE(token), TOKEN_COLUMN(token),
00846 CIF_Label_Referenced_As_Format);
00847 }
00848 }
00849 else if (TOKEN_ERR(token)) {
00850 parse_err_flush(Find_Comma, NULL);
00851 parsed_ok = FALSE;
00852 }
00853 else {
00854 parse_err_flush(Find_Comma, "LABEL");
00855 parsed_ok = FALSE;
00856 }
00857 }
00858 else {
00859 parsed_ok = parse_expr(&opnd) && parsed_ok;
00860 COPY_OPND(IL_OPND(list2_idx), opnd);
00861 }
00862
00863 if (parsed_ok &&
00864 IL_FLD(list2_idx) == CN_Tbl_Idx &&
00865 TYP_TYPE(CN_TYPE_IDX(IL_IDX(list2_idx))) == Character) {
00866
00867
00868 set_format_start_idx(buf_idx);
00869
00870 format_cn_idx = IL_IDX(list2_idx);
00871 ignore_trailing_chars = TRUE;
00872 pre_parse_format_idx = pre_parse_format(format_cn_idx, 0);
00873 ignore_trailing_chars = FALSE;
00874
00875 NTR_IR_LIST_TBL(list_idx);
00876 IL_FLD(list2_idx) = IL_Tbl_Idx;
00877 IL_IDX(list2_idx) = list_idx;
00878 IL_LIST_CNT(list2_idx) = 2;
00879
00880 IL_FLD(list_idx) = AT_Tbl_Idx;
00881 idx = create_format_tmp(format_cn_idx);
00882 IL_IDX(list_idx) = idx;
00883 IL_LINE_NUM(list_idx) = line;
00884 IL_COL_NUM(list_idx) = column;
00885
00886 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
00887 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
00888 list_idx = IL_NEXT_LIST_IDX(list_idx);
00889
00890 if (pre_parse_format_idx != NULL_IDX) {
00891 IL_FLD(list_idx) = AT_Tbl_Idx;
00892 idx = create_format_tmp(pre_parse_format_idx);
00893 IL_IDX(list_idx) = idx;
00894 IL_LINE_NUM(list_idx) = line;
00895 IL_COL_NUM(list_idx) = column;
00896 }
00897 }
00898
00899 if (LA_CH_VALUE != COMMA) {
00900 parse_err_flush(Find_Rparen, ",");
00901 parsed_ok = FALSE;
00902 }
00903 else {
00904 NEXT_LA_CH;
00905
00906 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
00907 parsed_ok = parse_deref(&opnd, NULL_IDX) && parsed_ok;
00908 COPY_OPND(IL_OPND(list3_idx), opnd);
00909
00910 mark_attr_defined(&opnd);
00911 }
00912 else {
00913 parse_err_flush(Find_Rparen, "IDENTIFIER");
00914 parsed_ok = FALSE;
00915 }
00916 }
00917
00918 if (LA_CH_VALUE != RPAREN) {
00919
00920 if (parse_err_flush(Find_Rparen, ")")) {
00921 NEXT_LA_CH;
00922 }
00923 parsed_ok = FALSE;
00924 }
00925 else {
00926 NEXT_LA_CH;
00927 }
00928 }
00929
00930 if (LA_CH_VALUE != EOS) {
00931
00932 parsed_ok = parse_io_list(&opnd) && parsed_ok;
00933 COPY_OPND(IR_OPND_R(ir_idx), opnd);
00934 }
00935 }
00936 else {
00937 parse_err_flush(Find_EOS, "(");
00938 parsed_ok = FALSE;
00939 }
00940
00941 if (LA_CH_VALUE != EOS) {
00942 parse_err_flush(Find_EOS, EOS_STR);
00943 parsed_ok = FALSE;
00944 }
00945
00946 matched_specific_token(Tok_EOS, Tok_Class_Punct);
00947
00948 INSERT_IO_END;
00949
00950 TRACE (Func_Exit, "parse_encode_stmt", NULL);
00951
00952 return;
00953
00954 }
00955
00956
00957
00958
00959
00960
00961
00962
00963
00964
00965
00966
00967
00968
00969
00970
00971
00972
00973
00974 void parse_endfile_stmt (void)
00975
00976 {
00977 int call_idx;
00978 int list_idx;
00979 opnd_type opnd;
00980 boolean parsed_ok = TRUE;
00981
00982
00983 TRACE (Func_Entry, "parse_endfile_stmt", NULL);
00984
00985 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) {
00986 curr_stmt_category = Executable_Stmt_Cat;
00987 }
00988
00989 if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
00990 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) {
00991 PRINTMSG(TOKEN_LINE(token), 1262, Error, TOKEN_COLUMN(token),
00992 stmt_type_str[stmt_type],
00993 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure" : "elemental",
00994 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));
00995 }
00996
00997 if (cif_flags & MISC_RECS) {
00998 cif_stmt_type_rec(TRUE, CIF_Endfile_Stmt, statement_number);
00999 }
01000
01001 INSERT_IO_START;
01002
01003 NTR_IR_TBL(call_idx);
01004 SH_IR_IDX(curr_stmt_sh_idx) = call_idx;
01005
01006 IR_OPR(call_idx) = Call_Opr;
01007 IR_TYPE_IDX(call_idx) = TYPELESS_DEFAULT_TYPE;
01008 IR_COL_NUM(call_idx) = TOKEN_COLUMN(token);
01009 IR_LINE_NUM(call_idx) = TOKEN_LINE(token);
01010
01011
01012
01013 if (glb_tbl_idx[Endfile_Attr_Idx] == NULL_IDX) {
01014 glb_tbl_idx[Endfile_Attr_Idx] = create_lib_entry_attr(ENDFILE_LIB_ENTRY,
01015 ENDFILE_NAME_LEN,
01016 TOKEN_LINE(token),
01017 TOKEN_COLUMN(token));
01018 }
01019
01020 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Endfile_Attr_Idx]);
01021
01022 IR_FLD_L(call_idx) = AT_Tbl_Idx;
01023 IR_IDX_L(call_idx) = glb_tbl_idx[Endfile_Attr_Idx];
01024
01025 IR_LINE_NUM_L(call_idx) = TOKEN_LINE(token);
01026 IR_COL_NUM_L(call_idx) = TOKEN_COLUMN(token);
01027
01028 if (LA_CH_VALUE == LPAREN) {
01029 parsed_ok = parse_io_control_list(&opnd, Endfile);
01030 COPY_OPND(IR_OPND_R(call_idx), opnd);
01031 }
01032 else {
01033
01034 parsed_ok = parse_expr(&opnd);
01035 NTR_IR_LIST_TBL(list_idx);
01036 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
01037 IR_FLD_R(call_idx) = IL_Tbl_Idx;
01038 IR_IDX_R(call_idx) = list_idx;
01039 COPY_OPND(IL_OPND(list_idx), opnd);
01040 IR_LIST_CNT_R(call_idx) = 3;
01041
01042
01043 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01044 list_idx = IL_NEXT_LIST_IDX(list_idx);
01045 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
01046
01047 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01048 list_idx = IL_NEXT_LIST_IDX(list_idx);
01049 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
01050 }
01051
01052 if (LA_CH_VALUE != EOS) {
01053 parse_err_flush(Find_EOS, EOS_STR);
01054 parsed_ok = FALSE;
01055 }
01056
01057 matched_specific_token(Tok_EOS, Tok_Class_Punct);
01058
01059 SH_ERR_FLG(curr_stmt_sh_idx) = ! parsed_ok;
01060
01061 INSERT_IO_END;
01062
01063 TRACE (Func_Exit, "parse_endfile_stmt", NULL);
01064
01065 return;
01066
01067 }
01068
01069
01070
01071
01072
01073
01074
01075
01076
01077
01078
01079
01080
01081
01082
01083
01084
01085
01086 void parse_format_stmt (void)
01087
01088 {
01089 int pre_parse_format_idx;
01090 int tmp_idx;
01091
01092
01093 TRACE (Func_Entry, "parse_format_stmt", NULL);
01094
01095 if (LA_CH_VALUE == LPAREN) {
01096
01097 if (CURR_BLK_NO_EXEC && iss_blk_stk_err()) {
01098
01099
01100
01101
01102 parse_err_flush(Find_EOS, NULL);
01103 goto EXIT;
01104 }
01105
01106 if (curr_stmt_category < Implicit_None_Stmt_Cat) {
01107 curr_stmt_category = Implicit_None_Stmt_Cat;
01108 }
01109
01110 if (stmt_label_idx == NULL_IDX) {
01111 PRINTMSG(TOKEN_LINE(token), 135, Error, TOKEN_COLUMN(token));
01112 parse_err_flush(Find_EOS, NULL);
01113 goto EXIT;
01114 }
01115
01116 ATL_CLASS(stmt_label_idx) = Lbl_Format;
01117
01118 if (MATCHED_TOKEN_CLASS(Tok_Class_Format_Str)) {
01119 set_format_start_idx(TOKEN_BUF_IDX(token) - 1);
01120 format_cn_idx = TOKEN_CONST_TBL_IDX(token);
01121
01122 pre_parse_format_idx = pre_parse_format(format_cn_idx,
01123 AT_NAME_LEN(stmt_label_idx));
01124
01125 tmp_idx = create_format_tmp(format_cn_idx);
01126
01127 ATL_FORMAT_TMP(stmt_label_idx) = tmp_idx;
01128
01129 if (pre_parse_format_idx != NULL_IDX) {
01130 tmp_idx = create_format_tmp(pre_parse_format_idx);
01131 ATL_PP_FORMAT_TMP(stmt_label_idx) = tmp_idx;
01132 }
01133 else {
01134 ATL_PP_FORMAT_TMP(stmt_label_idx) = NULL_IDX;
01135 }
01136
01137 if (LA_CH_VALUE != EOS) {
01138 PRINTMSG(LA_CH_LINE, 166, Error, LA_CH_COLUMN);
01139 parse_err_flush(Find_EOS, NULL);
01140 }
01141 }
01142 else {
01143
01144 }
01145 }
01146 else {
01147 parse_err_flush(Find_EOS, "(");
01148 }
01149 EXIT:
01150
01151 matched_specific_token(Tok_EOS, Tok_Class_Punct);
01152 TRACE (Func_Exit, "parse_format_stmt", NULL);
01153
01154 return;
01155
01156 }
01157
01158
01159
01160
01161
01162
01163
01164
01165
01166
01167
01168
01169
01170
01171
01172
01173
01174
01175
01176
01177
01178 void emit_format_msg(int msg_num,
01179 int column,
01180 int ed_column)
01181
01182 {
01183 int line;
01184 char ch;
01185 int col;
01186 int ed_idx;
01187
01188
01189 switch (msg_num) {
01190 case TRAILING_CHARS:
01191
01192 if (ignore_trailing_chars) {
01193 goto EXIT;
01194 }
01195
01196 format_line_n_col(&line, &col, ed_column);
01197 ed_idx = column;
01198 break;
01199
01200 case ANSI_EMPTY_PAREN_MSG:
01201 case MINUS_X_NON_ANSI:
01202 case H_IS_OBSOLETE_IN_F90:
01203 case EXPECTING_RIGHT_PAREN:
01204 case NON_ANSI_NULL_DESCRIPTOR:
01205 case E_WITH_D_NON_ANSI:
01206
01207 format_line_n_col(&line, &col, ed_column);
01208 ed_idx = column;
01209 break;
01210
01211 case REP_SLASH_NON_ANSI:
01212
01213
01214
01215
01216 goto EXIT;
01217
01218 case MISSING_WIDTH_NON_ANSI:
01219 case ZERO_WIDTH_NON_ANSI:
01220 format_line_n_col(&line, &col, ed_column);
01221 ed_idx = ed_column;
01222 break;
01223
01224 case NON_ANSI_EDIT_DESCRIPTOR:
01225 format_line_n_col(&line, &col, ed_column);
01226 ed_idx = ed_column;
01227
01228 if (stmt_type == Format_Stmt) {
01229 ch = ((char *)&CN_CONST(format_cn_idx) +
01230 AT_NAME_LEN(stmt_label_idx))[ed_idx - 1];
01231 }
01232 else {
01233 ch = ((char *)&CN_CONST(format_cn_idx))[ed_idx - 1];
01234 }
01235
01236 switch (ch) {
01237 case '*':
01238 case '$':
01239 case 'R':
01240 case 'r':
01241 case 'X':
01242 case 'x':
01243 #ifdef KEY
01244 case 'H':
01245 case 'h':
01246 #endif
01247 break;
01248
01249 default:
01250 goto EXIT;
01251
01252 }
01253
01254 break;
01255
01256 case INVALID_REP_COUNT:
01257 format_line_n_col(&line, &col, column);
01258 ed_idx = ed_column;
01259 break;
01260
01261 default :
01262 format_line_n_col(&line, &col, column);
01263 ed_idx = column;
01264 break;
01265 }
01266
01267 switch (msg_num_tbl[msg_num].num_args) {
01268 case 0:
01269 PRINTMSG(line,
01270 msg_num_tbl[msg_num].msg_num,
01271 msg_num_tbl[msg_num].msg_severity,
01272 col);
01273 break;
01274
01275 case 1:
01276 if (stmt_type == Format_Stmt) {
01277 PRINTMSG(line,
01278 msg_num_tbl[msg_num].msg_num,
01279 msg_num_tbl[msg_num].msg_severity,
01280 col,
01281 ((char *)&CN_CONST(format_cn_idx))
01282 [AT_NAME_LEN(stmt_label_idx) + ed_idx - 1]);
01283 }
01284 else {
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))[ed_idx - 1]);
01290 }
01291 break;
01292 }
01293
01294 EXIT:
01295
01296 return;
01297 }
01298
01299
01300
01301
01302
01303
01304
01305
01306
01307
01308
01309
01310
01311
01312
01313
01314
01315
01316 void parse_inquire_stmt (void)
01317
01318 {
01319 int buf_idx;
01320 int call_idx;
01321 int list_idx;
01322 opnd_type opnd;
01323 boolean parsed_ok = TRUE;
01324 int stmt_num;
01325
01326
01327 TRACE (Func_Entry, "parse_inquire_stmt", NULL);
01328
01329 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) {
01330 curr_stmt_category = Executable_Stmt_Cat;
01331 }
01332
01333 if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
01334 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) {
01335 PRINTMSG(TOKEN_LINE(token), 1262, Error, TOKEN_COLUMN(token),
01336 stmt_type_str[stmt_type],
01337 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure" : "elemental",
01338 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));
01339 }
01340
01341 INSERT_IO_START;
01342
01343 NTR_IR_TBL(call_idx);
01344 SH_IR_IDX(curr_stmt_sh_idx) = call_idx;
01345
01346 IR_COL_NUM(call_idx) = TOKEN_COLUMN(token);
01347 IR_LINE_NUM(call_idx) = TOKEN_LINE(token);
01348 IR_TYPE_IDX(call_idx) = TYPELESS_DEFAULT_TYPE;
01349
01350 IR_LINE_NUM_L(call_idx) = TOKEN_LINE(token);
01351 IR_COL_NUM_L(call_idx) = TOKEN_COLUMN(token);
01352
01353 if (LA_CH_VALUE == LPAREN) {
01354 buf_idx = LA_CH_BUF_IDX;
01355 stmt_num = LA_CH_STMT_NUM;
01356 NEXT_LA_CH;
01357
01358 if (LA_CH_VALUE == 'I' &&
01359 MATCHED_TOKEN_CLASS(Tok_Class_Id) &&
01360 strcmp(TOKEN_STR(token),"IOLENGTH") == 0 &&
01361 LA_CH_VALUE == EQUAL) {
01362
01363 IR_OPR(call_idx) = Inquire_Iolength_Opr;
01364
01365 NEXT_LA_CH;
01366 NTR_IR_LIST_TBL(list_idx);
01367 IR_FLD_L(call_idx) = IL_Tbl_Idx;
01368 IR_IDX_L(call_idx) = list_idx;
01369 IR_LIST_CNT_L(call_idx) = 1;
01370
01371 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
01372 parsed_ok = parse_deref(&opnd, NULL_IDX);
01373 COPY_OPND(IL_OPND(list_idx), opnd);
01374
01375 mark_attr_defined(&opnd);
01376 }
01377 else {
01378 parse_err_flush(Find_Rparen, "IDENTIFIER");
01379 parsed_ok = FALSE;
01380 }
01381
01382 if (LA_CH_VALUE == RPAREN) {
01383 NEXT_LA_CH;
01384 if (LA_CH_VALUE != EOS) {
01385 parsed_ok = parse_io_list(&opnd) && parsed_ok;
01386 COPY_OPND(IR_OPND_R(call_idx), opnd);
01387 }
01388 }
01389 else {
01390 parse_err_flush(Find_EOS, ")");
01391 parsed_ok = FALSE;
01392 }
01393 }
01394 else {
01395 reset_lex(buf_idx, stmt_num);
01396
01397 IR_OPR(call_idx) = Call_Opr;
01398
01399
01400
01401 if (glb_tbl_idx[Inquire_Attr_Idx] == NULL_IDX) {
01402 glb_tbl_idx[Inquire_Attr_Idx] = create_lib_entry_attr(
01403 INQUIRE_LIB_ENTRY,
01404 INQUIRE_NAME_LEN,
01405 TOKEN_LINE(token),
01406 TOKEN_COLUMN(token));
01407 }
01408
01409 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Inquire_Attr_Idx]);
01410
01411 IR_FLD_L(call_idx) = AT_Tbl_Idx;
01412 IR_IDX_L(call_idx) = glb_tbl_idx[Inquire_Attr_Idx];
01413 IR_LINE_NUM_L(call_idx) = IR_LINE_NUM(call_idx);
01414 IR_COL_NUM_L(call_idx) = IR_COL_NUM(call_idx);
01415
01416 parsed_ok = parse_io_control_list(&opnd, Inquire);
01417 COPY_OPND(IR_OPND_R(call_idx), opnd);
01418 }
01419 }
01420 else {
01421 parse_err_flush(Find_EOS, "(");
01422 parsed_ok = FALSE;
01423 }
01424
01425 if (LA_CH_VALUE != EOS) {
01426 parse_err_flush(Find_EOS, EOS_STR);
01427 parsed_ok = FALSE;
01428 }
01429
01430 matched_specific_token(Tok_EOS, Tok_Class_Punct);
01431
01432 SH_ERR_FLG(curr_stmt_sh_idx) = ! parsed_ok;
01433
01434 INSERT_IO_END;
01435
01436 TRACE (Func_Exit, "parse_inquire_stmt", NULL);
01437
01438 return;
01439
01440 }
01441
01442
01443
01444
01445
01446
01447
01448
01449
01450
01451
01452
01453
01454
01455
01456
01457
01458 void parse_open_stmt (void)
01459
01460 {
01461 int call_idx;
01462 opnd_type opnd;
01463 boolean parsed_ok = TRUE;
01464
01465
01466 TRACE (Func_Entry, "parse_open_stmt", NULL);
01467
01468 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) {
01469 curr_stmt_category = Executable_Stmt_Cat;
01470 }
01471
01472 if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
01473 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) {
01474 PRINTMSG(TOKEN_LINE(token), 1262, Error, TOKEN_COLUMN(token),
01475 stmt_type_str[stmt_type],
01476 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure" : "elemental",
01477 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));
01478 }
01479
01480 INSERT_IO_START;
01481
01482 NTR_IR_TBL(call_idx);
01483 SH_IR_IDX(curr_stmt_sh_idx) = call_idx;
01484
01485 IR_OPR(call_idx) = Call_Opr;
01486 IR_TYPE_IDX(call_idx) = TYPELESS_DEFAULT_TYPE;
01487 IR_COL_NUM(call_idx) = TOKEN_COLUMN(token);
01488 IR_LINE_NUM(call_idx) = TOKEN_LINE(token);
01489
01490
01491
01492 if (glb_tbl_idx[Open_Attr_Idx] == NULL_IDX) {
01493 glb_tbl_idx[Open_Attr_Idx] = create_lib_entry_attr(OPEN_LIB_ENTRY,
01494 OPEN_NAME_LEN,
01495 TOKEN_LINE(token),
01496 TOKEN_COLUMN(token));
01497 }
01498
01499 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Open_Attr_Idx]);
01500
01501 IR_FLD_L(call_idx) = AT_Tbl_Idx;
01502 IR_IDX_L(call_idx) = glb_tbl_idx[Open_Attr_Idx];
01503 IR_COL_NUM_L(call_idx) = TOKEN_COLUMN(token);
01504 IR_LINE_NUM_L(call_idx) = TOKEN_LINE(token);
01505
01506 parsed_ok = parse_io_control_list(&opnd, Open);
01507 COPY_OPND(IR_OPND_R(call_idx), opnd);
01508
01509 if (LA_CH_VALUE != EOS) {
01510 parse_err_flush(Find_EOS, EOS_STR);
01511 parsed_ok = FALSE;
01512 }
01513
01514 matched_specific_token(Tok_EOS, Tok_Class_Punct);
01515
01516 SH_ERR_FLG(curr_stmt_sh_idx) = ! parsed_ok;
01517
01518 INSERT_IO_END;
01519
01520 TRACE (Func_Exit, "parse_open_stmt", NULL);
01521
01522 return;
01523
01524 }
01525
01526
01527
01528
01529
01530
01531
01532
01533
01534
01535
01536
01537
01538
01539
01540
01541
01542 void parse_print_stmt (void)
01543
01544 {
01545 int attr_idx;
01546 int buf_idx;
01547 int column;
01548 int i;
01549 int idx;
01550 int ir_idx;
01551 int line;
01552 int list_idx;
01553 int list2_idx;
01554 int name_idx;
01555 opnd_type opnd;
01556 boolean parsed_ok = TRUE;
01557 int pre_parse_format_idx;
01558
01559
01560 TRACE (Func_Entry, "parse_print_stmt", NULL);
01561
01562
01563
01564
01565 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) {
01566 curr_stmt_category = Executable_Stmt_Cat;
01567 }
01568
01569 if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
01570 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) {
01571 PRINTMSG(TOKEN_LINE(token), 1262, Error, TOKEN_COLUMN(token),
01572 stmt_type_str[stmt_type],
01573 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure" : "elemental",
01574 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));
01575 }
01576
01577 INSERT_IO_START;
01578
01579 NTR_IR_TBL(ir_idx);
01580 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
01581
01582 IR_OPR(ir_idx) = Write_Formatted_Opr;
01583 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
01584 column = TOKEN_COLUMN(token);
01585 IR_COL_NUM(ir_idx) = column;
01586 line = TOKEN_LINE(token);
01587 IR_LINE_NUM(ir_idx) = line;
01588
01589 IR_FLD_L(ir_idx) = IL_Tbl_Idx;
01590 IR_LIST_CNT_L(ir_idx) = ciitem_tbl[Write].num_ciitems;
01591 NTR_IR_LIST_TBL(list_idx);
01592 IR_IDX_L(ir_idx) = list_idx;
01593
01594
01595 IL_FLD(list_idx) = CN_Tbl_Idx;
01596 IL_LINE_NUM(list_idx) = line;
01597 IL_COL_NUM(list_idx) = column;
01598
01599 for (i = 2; i <= ciitem_tbl[Write].num_ciitems; i++) {
01600 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01601 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01602 list_idx = IL_NEXT_LIST_IDX(list_idx);
01603 }
01604
01605 list_idx = IL_NEXT_LIST_IDX(IR_IDX_L(ir_idx));
01606
01607 if (LA_CH_VALUE == STAR) {
01608
01609 IL_FLD(list_idx) = CN_Tbl_Idx;
01610 IL_LINE_NUM(list_idx) = line;
01611 IL_COL_NUM(list_idx) = column;
01612 NEXT_LA_CH;
01613 }
01614 else if (LA_CH_CLASS == Ch_Class_Digit &&
01615 digit_is_format_label()) {
01616
01617 if (MATCHED_TOKEN_CLASS(Tok_Class_Label) &&
01618 ! TOKEN_ERR(token)) {
01619
01620 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx);
01621
01622 if (attr_idx == NULL_IDX) {
01623 attr_idx = ntr_sym_tbl(&token, name_idx);
01624 AT_OBJ_CLASS(attr_idx) = Label;
01625 LN_DEF_LOC(name_idx) = TRUE;
01626 build_fwd_ref_entry(attr_idx, Format_Ref);
01627 }
01628 else if ( ! AT_DCL_ERR(attr_idx) ) {
01629
01630 if (!AT_DEFINED(attr_idx)) {
01631 build_fwd_ref_entry(attr_idx, Format_Ref);
01632 }
01633 else if (ATL_CLASS(attr_idx) != Lbl_Format) {
01634
01635 PRINTMSG(TOKEN_LINE(token), 328, Error,
01636 TOKEN_COLUMN(token),
01637 AT_OBJ_NAME_PTR(attr_idx));
01638 parsed_ok = FALSE;
01639 }
01640
01641 }
01642 else {
01643
01644 parsed_ok = FALSE;
01645 }
01646
01647 if (parsed_ok) {
01648 IL_FLD(list_idx) = AT_Tbl_Idx;
01649 IL_IDX(list_idx) = attr_idx;
01650 IL_LINE_NUM(list_idx) = TOKEN_LINE(token);
01651 IL_COL_NUM(list_idx) = TOKEN_COLUMN(token);
01652
01653 if (cif_flags & XREF_RECS) {
01654 cif_usage_rec(IL_IDX(list_idx), AT_Tbl_Idx,
01655 IL_LINE_NUM(list_idx), IL_COL_NUM(list_idx),
01656 CIF_Label_Referenced_As_Format);
01657 }
01658 }
01659 }
01660 else if (TOKEN_ERR(token)) {
01661 parse_err_flush(Find_Comma, NULL);
01662 parsed_ok = FALSE;
01663 }
01664 else {
01665 parse_err_flush(Find_Comma, "LABEL");
01666 parsed_ok = FALSE;
01667 }
01668 }
01669 else {
01670
01671 buf_idx = LA_CH_BUF_IDX;
01672
01673 parsed_ok = parse_expr(&opnd);
01674 COPY_OPND(IL_OPND(list_idx), opnd);
01675
01676 if (IL_FLD(list_idx) == CN_Tbl_Idx &&
01677 TYP_TYPE(CN_TYPE_IDX(IL_IDX(list_idx))) == Character) {
01678
01679 set_format_start_idx(buf_idx);
01680
01681 format_cn_idx = IL_IDX(list_idx);
01682
01683 ignore_trailing_chars = TRUE;
01684 pre_parse_format_idx = pre_parse_format(format_cn_idx, 0);
01685 ignore_trailing_chars = FALSE;
01686
01687 NTR_IR_LIST_TBL(list2_idx);
01688 IL_FLD(list_idx) = IL_Tbl_Idx;
01689 IL_IDX(list_idx) = list2_idx;
01690 IL_LIST_CNT(list_idx) = 2;
01691
01692 IL_FLD(list2_idx) = AT_Tbl_Idx;
01693 idx = create_format_tmp(format_cn_idx);
01694 IL_IDX(list2_idx) = idx;
01695 IL_LINE_NUM(list2_idx) = line;
01696 IL_COL_NUM(list2_idx) = column;
01697
01698 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list2_idx));
01699 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list2_idx)) = list2_idx;
01700 list2_idx = IL_NEXT_LIST_IDX(list2_idx);
01701
01702
01703 if (pre_parse_format_idx != NULL_IDX) {
01704 IL_FLD(list2_idx) = AT_Tbl_Idx;
01705 idx = create_format_tmp(pre_parse_format_idx);
01706 IL_IDX(list2_idx) = idx;
01707 IL_LINE_NUM(list2_idx) = line;
01708 IL_COL_NUM(list2_idx) = column;
01709 }
01710 }
01711 }
01712
01713 if (LA_CH_VALUE != EOS) {
01714
01715 if (LA_CH_VALUE != COMMA) {
01716 parse_err_flush(Find_EOS, ",");
01717 parsed_ok = FALSE;
01718 }
01719 else {
01720
01721 NEXT_LA_CH;
01722
01723 parsed_ok = parse_io_list(&opnd) && parsed_ok;
01724 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01725 }
01726 }
01727
01728 if (LA_CH_VALUE != EOS) {
01729 parse_err_flush(Find_EOS, EOS_STR);
01730 parsed_ok = FALSE;
01731 }
01732
01733 matched_specific_token(Tok_EOS, Tok_Class_Punct);
01734
01735 INSERT_IO_END;
01736
01737 TRACE (Func_Exit, "parse_print_stmt", NULL);
01738
01739 return;
01740
01741 }
01742
01743
01744
01745
01746
01747
01748
01749
01750
01751
01752
01753
01754
01755
01756
01757
01758
01759 void parse_read_stmt (void)
01760
01761 {
01762 int attr_idx;
01763 int buf_idx;
01764 int column;
01765 int i;
01766 int idx;
01767 int ir_idx;
01768 int line;
01769 int list_idx;
01770 int list2_idx;
01771 int name_idx;
01772 opnd_type opnd;
01773 boolean parsed_ok = TRUE;
01774 int pre_parse_format_idx;
01775
01776
01777 TRACE (Func_Entry, "parse_read_stmt", NULL);
01778
01779 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) {
01780 curr_stmt_category = Executable_Stmt_Cat;
01781 }
01782
01783 INSERT_IO_START;
01784
01785 NTR_IR_TBL(ir_idx);
01786 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
01787
01788 IR_OPR(ir_idx) = Read_Formatted_Opr;
01789 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
01790 column = TOKEN_COLUMN(token);
01791 IR_COL_NUM(ir_idx) = column;
01792 line = TOKEN_LINE(token);
01793 IR_LINE_NUM(ir_idx) = line;
01794
01795 if (LA_CH_VALUE == LPAREN) {
01796 parsed_ok = parse_io_control_list(&opnd, Read);
01797 COPY_OPND(IR_OPND_L(ir_idx), opnd);
01798
01799 #ifdef KEY
01800
01801 if (LA_CH_VALUE == COMMA && ! on_off_flags.issue_ansi_messages) {
01802 NEXT_LA_CH;
01803 }
01804 #endif
01805
01806 if (LA_CH_VALUE != EOS) {
01807
01808 parsed_ok = parse_io_list(&opnd) && parsed_ok;
01809 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01810 }
01811 }
01812 else {
01813
01814 IR_FLD_L(ir_idx) = IL_Tbl_Idx;
01815 IR_LIST_CNT_L(ir_idx) = ciitem_tbl[Read].num_ciitems;
01816 NTR_IR_LIST_TBL(list_idx);
01817 IR_IDX_L(ir_idx) = list_idx;
01818
01819
01820 IL_FLD(list_idx) = CN_Tbl_Idx;
01821 IL_LINE_NUM(list_idx) = line;
01822 IL_COL_NUM(list_idx) = column;
01823
01824 for (i = 2; i <= ciitem_tbl[Read].num_ciitems; i++) {
01825 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01826 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01827 list_idx = IL_NEXT_LIST_IDX(list_idx);
01828 }
01829
01830 list_idx = IL_NEXT_LIST_IDX(IR_IDX_L(ir_idx));
01831
01832 if (LA_CH_VALUE == STAR) {
01833
01834 IL_FLD(list_idx) = CN_Tbl_Idx;
01835 IL_LINE_NUM(list_idx) = line;
01836 IL_COL_NUM(list_idx) = column;
01837 NEXT_LA_CH;
01838 }
01839 else if (LA_CH_CLASS == Ch_Class_Digit &&
01840 digit_is_format_label()) {
01841
01842 if (MATCHED_TOKEN_CLASS(Tok_Class_Label) &&
01843 ! TOKEN_ERR(token)) {
01844
01845 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token),
01846 &name_idx);
01847
01848 if (attr_idx == NULL_IDX) {
01849 attr_idx = ntr_sym_tbl(&token, name_idx);
01850 AT_OBJ_CLASS(attr_idx) = Label;
01851 LN_DEF_LOC(name_idx) = TRUE;
01852 build_fwd_ref_entry(attr_idx, Format_Ref);
01853 }
01854 else if ( ! AT_DCL_ERR(attr_idx) ) {
01855
01856 if (!AT_DEFINED(attr_idx)) {
01857 build_fwd_ref_entry(attr_idx, Format_Ref);
01858 }
01859 else if (ATL_CLASS(attr_idx) != Lbl_Format) {
01860
01861 PRINTMSG(TOKEN_LINE(token), 328, Error,
01862 TOKEN_COLUMN(token),
01863 AT_OBJ_NAME_PTR(attr_idx));
01864 parsed_ok = FALSE;
01865 }
01866 }
01867 else {
01868
01869 parsed_ok = FALSE;
01870 }
01871
01872 if (parsed_ok) {
01873 IL_FLD(list_idx) = AT_Tbl_Idx;
01874 IL_IDX(list_idx) = attr_idx;
01875 IL_LINE_NUM(list_idx) = TOKEN_LINE(token);
01876 IL_COL_NUM(list_idx) = TOKEN_COLUMN(token);
01877
01878 if (cif_flags & XREF_RECS) {
01879 cif_usage_rec(IL_IDX(list_idx), AT_Tbl_Idx,
01880 IL_LINE_NUM(list_idx), IL_COL_NUM(list_idx),
01881 CIF_Label_Referenced_As_Format);
01882 }
01883 }
01884 }
01885 else if (TOKEN_ERR(token)) {
01886 parse_err_flush(Find_Comma, NULL);
01887 parsed_ok = FALSE;
01888 }
01889 else {
01890 parse_err_flush(Find_Comma, "LABEL");
01891 parsed_ok = FALSE;
01892 }
01893 }
01894 else {
01895
01896 buf_idx = LA_CH_BUF_IDX;
01897
01898 parsed_ok = parse_expr(&opnd);
01899 COPY_OPND(IL_OPND(list_idx), opnd);
01900
01901 if (IL_FLD(list_idx) == CN_Tbl_Idx &&
01902 TYP_TYPE(CN_TYPE_IDX(IL_IDX(list_idx))) == Character) {
01903
01904 set_format_start_idx(buf_idx);
01905
01906 format_cn_idx = IL_IDX(list_idx);
01907
01908 ignore_trailing_chars = TRUE;
01909 pre_parse_format_idx = pre_parse_format(format_cn_idx, 0);
01910 ignore_trailing_chars = FALSE;
01911
01912 NTR_IR_LIST_TBL(list2_idx);
01913 IL_FLD(list_idx) = IL_Tbl_Idx;
01914 IL_IDX(list_idx) = list2_idx;
01915 IL_LIST_CNT(list_idx) = 2;
01916
01917 IL_FLD(list2_idx) = AT_Tbl_Idx;
01918 idx = create_format_tmp(format_cn_idx);
01919 IL_IDX(list2_idx) = idx;
01920 IL_LINE_NUM(list2_idx) = line;
01921 IL_COL_NUM(list2_idx) = column;
01922
01923 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list2_idx));
01924 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list2_idx)) = list2_idx;
01925 list2_idx = IL_NEXT_LIST_IDX(list2_idx);
01926
01927 if (pre_parse_format_idx != NULL_IDX) {
01928 IL_FLD(list2_idx) = AT_Tbl_Idx;
01929 idx = create_format_tmp(pre_parse_format_idx);
01930 IL_IDX(list2_idx) = idx;
01931 IL_LINE_NUM(list2_idx) = line;
01932 IL_COL_NUM(list2_idx) = column;
01933 }
01934 }
01935 }
01936
01937 if (LA_CH_VALUE != EOS) {
01938
01939 if (LA_CH_VALUE != COMMA) {
01940 parse_err_flush(Find_EOS, ",");
01941 parsed_ok = FALSE;
01942 }
01943 else {
01944 NEXT_LA_CH;
01945
01946 parsed_ok = parse_io_list(&opnd) && parsed_ok;
01947 COPY_OPND(IR_OPND_R(ir_idx), opnd);
01948 }
01949 }
01950 }
01951
01952 if (LA_CH_VALUE != EOS) {
01953 parse_err_flush(Find_EOS, EOS_STR);
01954 parsed_ok = FALSE;
01955 }
01956
01957 matched_specific_token(Tok_EOS, Tok_Class_Punct);
01958
01959 INSERT_IO_END;
01960
01961 TRACE (Func_Exit, "parse_read_stmt", NULL);
01962
01963 return;
01964
01965 }
01966
01967
01968
01969
01970
01971
01972
01973
01974
01975
01976
01977
01978
01979
01980
01981
01982
01983 void parse_rewind_stmt (void)
01984
01985 {
01986 int call_idx;
01987 int list_idx;
01988 opnd_type opnd;
01989 boolean parsed_ok = TRUE;
01990
01991
01992 TRACE (Func_Entry, "parse_rewind_stmt", NULL);
01993
01994 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) {
01995 curr_stmt_category = Executable_Stmt_Cat;
01996 }
01997
01998 if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
01999 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) {
02000 PRINTMSG(TOKEN_LINE(token), 1262, Error, TOKEN_COLUMN(token),
02001 stmt_type_str[stmt_type],
02002 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ? "pure" : "elemental",
02003 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));
02004 }
02005
02006 INSERT_IO_START;
02007
02008 NTR_IR_TBL(call_idx);
02009 SH_IR_IDX(curr_stmt_sh_idx) = call_idx;
02010
02011 IR_OPR(call_idx) = Call_Opr;
02012 IR_TYPE_IDX(call_idx) = TYPELESS_DEFAULT_TYPE;
02013 IR_COL_NUM(call_idx) = TOKEN_COLUMN(token);
02014 IR_LINE_NUM(call_idx) = TOKEN_LINE(token);
02015
02016
02017
02018 if (glb_tbl_idx[Rewind_Attr_Idx] == NULL_IDX) {
02019 glb_tbl_idx[Rewind_Attr_Idx] = create_lib_entry_attr(REWIND_LIB_ENTRY,
02020 REWIND_NAME_LEN,
02021 TOKEN_LINE(token),
02022 TOKEN_COLUMN(token));
02023 }
02024
02025 ADD_ATTR_TO_LOCAL_LIST(glb_tbl_idx[Rewind_Attr_Idx]);
02026
02027 IR_FLD_L(call_idx) = AT_Tbl_Idx;
02028 IR_IDX_L(call_idx) = glb_tbl_idx[Rewind_Attr_Idx];
02029
02030 IR_LINE_NUM_L(call_idx) = TOKEN_LINE(token);
02031 IR_COL_NUM_L(call_idx) = TOKEN_COLUMN(token);
02032
02033 if (LA_CH_VALUE == LPAREN) {
02034 parsed_ok = parse_io_control_list(&opnd, Rewind);
02035 COPY_OPND(IR_OPND_R(call_idx), opnd);
02036 }
02037 else {
02038
02039 parsed_ok = parse_expr(&opnd);
02040 NTR_IR_LIST_TBL(list_idx);
02041 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
02042 IR_FLD_R(call_idx) = IL_Tbl_Idx;
02043 IR_IDX_R(call_idx) = list_idx;
02044 COPY_OPND(IL_OPND(list_idx), opnd);
02045 IR_LIST_CNT_R(call_idx) = 3;
02046
02047
02048 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02049 list_idx = IL_NEXT_LIST_IDX(list_idx);
02050 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
02051
02052 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02053 list_idx = IL_NEXT_LIST_IDX(list_idx);
02054 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
02055 }
02056
02057 if (LA_CH_VALUE != EOS) {
02058 parse_err_flush(Find_EOS, EOS_STR);
02059 parsed_ok = FALSE;
02060 }
02061
02062 matched_specific_token(Tok_EOS, Tok_Class_Punct);
02063
02064 SH_ERR_FLG(curr_stmt_sh_idx) = ! parsed_ok;
02065
02066 INSERT_IO_END;
02067
02068 TRACE (Func_Exit, "parse_rewind_stmt", NULL);
02069
02070 return;
02071
02072 }
02073
02074
02075
02076
02077
02078
02079
02080
02081
02082
02083
02084
02085
02086
02087
02088
02089
02090 void parse_write_stmt (void)
02091
02092 {
02093 int attr_idx;
02094 int buf_idx;
02095 int column;
02096 int i;
02097 int idx;
02098 int ir_idx;
02099 int line;
02100 int list_idx;
02101 int list2_idx;
02102 int name_idx;
02103 opnd_type opnd;
02104 boolean parsed_ok = TRUE;
02105 int pre_parse_format_idx;
02106
02107
02108 TRACE (Func_Entry, "parse_write_stmt", NULL);
02109
02110 if (!CURR_BLK_NO_EXEC || !iss_blk_stk_err()) {
02111 curr_stmt_category = Executable_Stmt_Cat;
02112 }
02113
02114 INSERT_IO_START;
02115
02116 NTR_IR_TBL(ir_idx);
02117 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02118
02119 IR_OPR(ir_idx) = Write_Formatted_Opr;
02120 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
02121 column = TOKEN_COLUMN(token);
02122 IR_COL_NUM(ir_idx) = column;
02123 line = TOKEN_LINE(token);
02124 IR_LINE_NUM(ir_idx) = line;
02125
02126 if (LA_CH_VALUE == LPAREN) {
02127 parsed_ok = parse_io_control_list(&opnd, Write);
02128 COPY_OPND(IR_OPND_L(ir_idx), opnd);
02129
02130 #ifdef KEY
02131
02132 if (LA_CH_VALUE == COMMA && ! on_off_flags.issue_ansi_messages) {
02133 NEXT_LA_CH;
02134 }
02135 #endif
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
02236 ignore_trailing_chars = TRUE;
02237 pre_parse_format_idx = pre_parse_format(format_cn_idx, 0);
02238 ignore_trailing_chars = FALSE;
02239
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 IL_FLD(list2_idx) = AT_Tbl_Idx;
02246 idx = create_format_tmp(format_cn_idx);
02247 IL_IDX(list2_idx) = idx;
02248 IL_LINE_NUM(list2_idx) = line;
02249 IL_COL_NUM(list2_idx) = column;
02250
02251 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list2_idx));
02252 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list2_idx)) = list2_idx;
02253 list2_idx = IL_NEXT_LIST_IDX(list2_idx);
02254
02255 if (pre_parse_format_idx != NULL_IDX) {
02256 IL_FLD(list2_idx) = AT_Tbl_Idx;
02257 idx = create_format_tmp(pre_parse_format_idx);
02258 IL_IDX(list2_idx) = idx;
02259 IL_LINE_NUM(list2_idx) = line;
02260 IL_COL_NUM(list2_idx) = column;
02261 }
02262 }
02263 }
02264
02265 if (LA_CH_VALUE != EOS) {
02266
02267 if (LA_CH_VALUE != COMMA) {
02268 parse_err_flush(Find_EOS, ",");
02269 parsed_ok = FALSE;
02270 }
02271 else {
02272 NEXT_LA_CH;
02273
02274 parsed_ok = parse_io_list(&opnd) && parsed_ok;
02275 COPY_OPND(IR_OPND_R(ir_idx), opnd);
02276 }
02277 }
02278 }
02279
02280 if (LA_CH_VALUE != EOS) {
02281 parse_err_flush(Find_EOS, EOS_STR);
02282 parsed_ok = FALSE;
02283 }
02284
02285 matched_specific_token(Tok_EOS, Tok_Class_Punct);
02286
02287 INSERT_IO_END;
02288
02289 TRACE (Func_Exit, "parse_write_stmt", NULL);
02290
02291 return;
02292
02293 }
02294
02295
02296
02297
02298
02299
02300
02301
02302
02303
02304
02305
02306
02307
02308
02309
02310
02311 boolean parse_io_list (opnd_type *result_opnd)
02312
02313 {
02314 int buf_idx;
02315 int list_idx;
02316 #ifdef KEY
02317 int list2_idx = 0;
02318 #else
02319 int list2_idx;
02320 #endif
02321 char next_char;
02322 opnd_type opnd;
02323 int paren_level = 0;
02324 boolean parsed_ok = TRUE;
02325 int stmt_num;
02326
02327
02328 TRACE (Func_Entry, "parse_io_list", NULL);
02329
02330 OPND_FLD((*result_opnd)) = IL_Tbl_Idx;
02331 OPND_IDX((*result_opnd)) = NULL_IDX;
02332 OPND_LIST_CNT((*result_opnd)) = 0;
02333
02334 do {
02335
02336 if (LA_CH_VALUE == LPAREN) {
02337
02338 if (next_tok_is_paren_slash ()) {
02339 parsed_ok = parse_expr(&opnd) && parsed_ok;
02340 }
02341 else if (is_implied_do ()) {
02342 parsed_ok = parse_imp_do(&opnd) && parsed_ok;
02343 }
02344 else {
02345 next_char = scan_thru_close_paren(0,0,1);
02346
02347 if (next_char == COMMA ||
02348 next_char == EOS ||
02349 next_char == RPAREN) {
02350
02351 buf_idx = LA_CH_BUF_IDX;
02352 stmt_num = LA_CH_STMT_NUM;
02353
02354 NEXT_LA_CH;
02355
02356 if (LA_CH_VALUE == LPAREN ||
02357 LA_CH_VALUE == RPAREN ||
02358 LA_CH_VALUE == EOS) {
02359
02360 paren_level++;
02361 continue;
02362 }
02363 else if (paren_grp_is_cplx_const()) {
02364
02365 reset_lex(buf_idx,stmt_num);
02366 parsed_ok = parse_expr(&opnd) && parsed_ok;
02367 }
02368 else {
02369
02370 reset_lex(buf_idx,stmt_num);
02371 NEXT_LA_CH;
02372 paren_level++;
02373 continue;
02374 }
02375 }
02376 else {
02377 parsed_ok = parse_expr(&opnd) && parsed_ok;
02378
02379 if (stmt_type == Read_Stmt ||
02380 stmt_type == Decode_Stmt) {
02381 mark_attr_defined(&opnd);
02382 }
02383 }
02384 }
02385 }
02386 else {
02387
02388 parsed_ok = parse_expr(&opnd) && parsed_ok;
02389
02390 if (stmt_type == Read_Stmt ||
02391 stmt_type == Decode_Stmt) {
02392 mark_attr_defined(&opnd);
02393 }
02394 }
02395
02396 ++OPND_LIST_CNT((*result_opnd));
02397
02398 NTR_IR_LIST_TBL(list_idx);
02399 COPY_OPND(IL_OPND(list_idx), opnd);
02400
02401 if (OPND_IDX((*result_opnd)) == NULL_IDX) {
02402 OPND_IDX((*result_opnd)) = list_idx;
02403 }
02404 else {
02405 IL_NEXT_LIST_IDX(list2_idx) = list_idx;
02406 IL_PREV_LIST_IDX(list_idx) = list2_idx;
02407 }
02408
02409 list2_idx = list_idx;
02410
02411 while (LA_CH_VALUE == RPAREN && paren_level) {
02412 NEXT_LA_CH;
02413 paren_level--;
02414 }
02415
02416 if (LA_CH_VALUE == COMMA) {
02417 NEXT_LA_CH;
02418 }
02419 else {
02420 break;
02421 }
02422 }
02423 while (TRUE);
02424
02425 if (paren_level) {
02426 parse_err_flush(Find_EOS, ")");
02427 }
02428
02429 TRACE (Func_Exit, "parse_io_list", NULL);
02430 return(parsed_ok);
02431 }
02432
02433
02434
02435
02436
02437
02438
02439
02440
02441
02442
02443
02444
02445
02446
02447
02448
02449 static int find_ciitem_idx (io_stmt_type stmt_type)
02450
02451 {
02452 int finish;
02453 int i;
02454 int idx = -1;
02455 int start;
02456 int test;
02457
02458
02459 TRACE (Func_Entry, "find_ciitem_idx", NULL);
02460
02461 start = 0;
02462 finish = ciitem_tbl[stmt_type].num_diff_ciitems;
02463 while (TRUE) {
02464 test = (finish - start) / 2 + start;
02465
02466 if ((i = strncmp(TOKEN_STR(token),ciitem_tbl[stmt_type].ciitem_list[test].
02467 name, ciitem_tbl[stmt_type].ciitem_list[test].name_length)) == 0) {
02468
02469
02470 if (TOKEN_LEN(token) == ciitem_tbl[stmt_type].ciitem_list[test].
02471 name_length) {
02472 idx = test;
02473 break;
02474 }
02475 else if (start == test) {
02476 break;
02477 }
02478 else {
02479 start = test;
02480 }
02481 }
02482 else if (i < 0) {
02483 if (finish == test) {
02484 break;
02485 }
02486 finish = test;
02487 }
02488 else {
02489 if (start == test) {
02490 break;
02491 }
02492 start = test;
02493 }
02494
02495 if (finish <= start) {
02496 break;
02497 }
02498 }
02499 TRACE (Func_Exit, "find_ciitem_idx", NULL);
02500
02501 return(idx);
02502 }
02503
02504
02505
02506
02507
02508
02509
02510
02511
02512
02513
02514
02515
02516
02517
02518
02519
02520 static boolean parse_io_control_list (opnd_type *result_opnd,
02521 io_stmt_type stmt_type)
02522
02523 {
02524 int arg_array[26];
02525 int arg_cnt = 0;
02526 int arg_idx;
02527 int attr_idx;
02528 int buf_idx;
02529 char *ch_ptr1;
02530 char *ch_ptr2;
02531 int ciitem_idx;
02532 #ifdef KEY
02533 boolean found = FALSE;
02534 #else
02535 boolean found;
02536 #endif
02537 boolean had_fmt = FALSE;
02538 boolean had_keyword = FALSE;
02539 boolean had_nml = FALSE;
02540 long i;
02541 int idx;
02542 boolean item_has_keyword;
02543 #ifdef KEY
02544 int kwd_col = 0;
02545 int kwd_line = 0;
02546 #else
02547 int kwd_col;
02548 int kwd_line;
02549 #endif
02550 int list_idx;
02551 int list2_idx;
02552 int name_idx;
02553 int num_args;
02554 opnd_type opnd;
02555 int opnd_column;
02556 int opnd_line;
02557 boolean parsed_ok = TRUE;
02558 int pre_parse_format_idx;
02559
02560
02561 TRACE (Func_Entry, "parse_io_control_list", NULL);
02562
02563 if (LA_CH_VALUE != LPAREN) {
02564
02565 parse_err_flush(Find_EOS, "(");
02566 parsed_ok = FALSE;
02567 }
02568 else {
02569 OPND_FLD((*result_opnd)) = IL_Tbl_Idx;
02570 num_args = ciitem_tbl[stmt_type].num_ciitems;
02571 OPND_LIST_CNT((*result_opnd)) = num_args;
02572 list2_idx = NULL_IDX;
02573
02574 for (i = 1; i <= num_args; i++) {
02575 NTR_IR_LIST_TBL(list_idx)
02576 arg_array[i] = list_idx;
02577
02578 if (stmt_type == Backspace ||
02579 stmt_type == Close ||
02580 stmt_type == Endfile ||
02581 stmt_type == Inquire ||
02582 stmt_type == Open ||
02583 stmt_type == Rewind) {
02584
02585 IL_ARG_DESC_VARIANT(list_idx) = TRUE;
02586
02587 if (list2_idx) {
02588 IL_NEXT_LIST_IDX(list2_idx) = list_idx;
02589 }
02590 }
02591 else if (list2_idx) {
02592 IL_NEXT_LIST_IDX(list2_idx) = list_idx;
02593 IL_PREV_LIST_IDX(list_idx) = list2_idx;
02594 }
02595 list2_idx = list_idx;
02596 }
02597 OPND_IDX((*result_opnd)) = arg_array[1];
02598
02599 do {
02600 NEXT_LA_CH;
02601
02602 if (LA_CH_VALUE == RPAREN && arg_cnt == 0) {
02603 break;
02604 }
02605
02606 arg_cnt++;
02607
02608 item_has_keyword = FALSE;
02609
02610 if (next_arg_is_kwd_equal()) {
02611 MATCHED_TOKEN_CLASS(Tok_Class_Id);
02612
02613 kwd_line = TOKEN_LINE(token);
02614 kwd_col = TOKEN_COLUMN(token);
02615
02616
02617 had_keyword = TRUE;
02618 item_has_keyword = TRUE;
02619 ciitem_idx = find_ciitem_idx(stmt_type);
02620
02621 if (ciitem_idx < 0) {
02622
02623 PRINTMSG(TOKEN_LINE(token), 73, Error,
02624 TOKEN_COLUMN(token), NULL);
02625 parsed_ok = FALSE;
02626 parse_err_flush(Find_Comma_Rparen, NULL);
02627 continue;
02628 }
02629
02630 NEXT_LA_CH;
02631 }
02632 else {
02633
02634 if (arg_cnt == 2 &&
02635 had_keyword &&
02636 ciitem_tbl[stmt_type].num_without_kwd == 2 &&
02637 IL_FLD(arg_array[UNIT_IDX]) != NO_Tbl_Idx) {
02638
02639
02640
02641 PRINTMSG(LA_CH_LINE, 1208, Ansi, LA_CH_COLUMN);
02642 }
02643 else if (arg_cnt > ciitem_tbl[stmt_type].num_without_kwd ||
02644 had_keyword) {
02645
02646 PRINTMSG(LA_CH_LINE, 139, Error, LA_CH_COLUMN);
02647 parsed_ok = FALSE;
02648 parse_err_flush(Find_Comma_Rparen, NULL);
02649 continue;
02650 }
02651 ciitem_idx = arg_idx_tbl[stmt_type][arg_cnt];
02652 }
02653
02654 arg_idx = ciitem_tbl[stmt_type].ciitem_list[ciitem_idx].arg_position;
02655
02656 if (stmt_type == Write &&
02657 (arg_idx == END_IDX ||
02658 arg_idx == SIZE_IDX ||
02659 arg_idx == EOR_IDX)) {
02660
02661 PRINTMSG(kwd_line, 445, Error, kwd_col,
02662 ciitem_tbl[stmt_type].ciitem_list[ciitem_idx].name);
02663 parsed_ok = FALSE;
02664 }
02665 else if (IL_FLD(arg_array[arg_idx]) != NO_Tbl_Idx) {
02666
02667
02668 if (arg_idx == FMT_IDX &&
02669 (stmt_type == Read || stmt_type == Write)) {
02670
02671 if ((had_fmt &&
02672 strcmp(ciitem_tbl[stmt_type].ciitem_list[ciitem_idx].name,
02673 "NML") == 0) ||
02674 (had_nml &&
02675 strcmp(ciitem_tbl[stmt_type].ciitem_list[ciitem_idx].name,
02676 "FMT") == 0)) {
02677
02678 PRINTMSG(TOKEN_LINE(token), 443, Error, TOKEN_COLUMN(token));
02679 }
02680 else {
02681 PRINTMSG(TOKEN_LINE(token), 70, Error, TOKEN_COLUMN(token));
02682 }
02683 }
02684 else {
02685 PRINTMSG(TOKEN_LINE(token), 70, Error, TOKEN_COLUMN(token));
02686 }
02687 parsed_ok = FALSE;
02688 parse_err_flush(Find_Comma_Rparen, NULL);
02689 continue;
02690 }
02691
02692 if (LA_CH_VALUE == STAR) {
02693
02694 if (ciitem_tbl[stmt_type].ciitem_list[ciitem_idx].allowed_form ==
02695 Format_Form ||
02696 arg_idx == UNIT_IDX) {
02697 IL_FLD(arg_array[arg_idx]) = CN_Tbl_Idx;
02698 IL_IDX(arg_array[arg_idx]) = NULL_IDX;
02699 IL_LINE_NUM(arg_array[arg_idx]) = LA_CH_LINE;
02700 IL_COL_NUM(arg_array[arg_idx]) = LA_CH_COLUMN;
02701 }
02702 else {
02703 PRINTMSG(LA_CH_LINE, 47, Error, LA_CH_COLUMN, NULL);
02704 parsed_ok = FALSE;
02705 }
02706 NEXT_LA_CH;
02707 continue;
02708 }
02709
02710
02711 switch (ciitem_tbl[stmt_type].ciitem_list[ciitem_idx].allowed_form) {
02712 case Exp_Form :
02713
02714 parsed_ok = parse_expr(&opnd) && parsed_ok;
02715 COPY_OPND(IL_OPND(arg_array[arg_idx]), opnd);
02716 break;
02717
02718 case Label_Form :
02719
02720 switch (stmt_type) {
02721 case Backspace :
02722 ATP_HAS_ALT_RETURN(glb_tbl_idx[Backspace_Attr_Idx]) = TRUE;
02723 break;
02724
02725 case Close :
02726 ATP_HAS_ALT_RETURN(glb_tbl_idx[Close_Attr_Idx]) = TRUE;
02727 break;
02728
02729 case Endfile :
02730 ATP_HAS_ALT_RETURN(glb_tbl_idx[Endfile_Attr_Idx]) = TRUE;
02731 break;
02732
02733 case Inquire :
02734 ATP_HAS_ALT_RETURN(glb_tbl_idx[Inquire_Attr_Idx]) = TRUE;
02735 break;
02736
02737 case Open :
02738 ATP_HAS_ALT_RETURN(glb_tbl_idx[Open_Attr_Idx]) = TRUE;
02739 break;
02740
02741 case Rewind :
02742 ATP_HAS_ALT_RETURN(glb_tbl_idx[Rewind_Attr_Idx]) = TRUE;
02743 break;
02744
02745 default :
02746 break;
02747 }
02748
02749 if (LA_CH_CLASS == Ch_Class_Digit) {
02750
02751
02752 if (MATCHED_TOKEN_CLASS(Tok_Class_Label) &&
02753 ! TOKEN_ERR(token)) {
02754
02755 attr_idx = check_label_ref();
02756
02757 AT_REFERENCED(attr_idx) = Referenced;
02758 IL_FLD(arg_array[arg_idx]) = AT_Tbl_Idx;
02759 IL_IDX(arg_array[arg_idx]) = attr_idx;
02760 IL_LINE_NUM(arg_array[arg_idx]) = TOKEN_LINE(token);
02761 IL_COL_NUM(arg_array[arg_idx]) = TOKEN_COLUMN(token);
02762 }
02763 else if (TOKEN_ERR(token)) {
02764 parse_err_flush(Find_Comma_Rparen, NULL);
02765 parsed_ok = FALSE;
02766 }
02767 else {
02768 parse_err_flush(Find_Comma_Rparen, "LABEL");
02769 parsed_ok = FALSE;
02770 }
02771 }
02772 else {
02773 parsed_ok = parse_expr(&opnd) && parsed_ok;
02774 COPY_OPND(IL_OPND(arg_array[arg_idx]), opnd);
02775 }
02776 break;
02777
02778 case Namelist_Form :
02779
02780 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
02781 parsed_ok = parse_deref(&opnd, NULL_IDX) && parsed_ok;
02782 COPY_OPND(IL_OPND(arg_array[arg_idx]), opnd);
02783 }
02784 else {
02785
02786 PRINTMSG(LA_CH_LINE, 173, Error, LA_CH_COLUMN, NULL);
02787 parse_err_flush(Find_Comma_Rparen, NULL);
02788 parsed_ok = FALSE;
02789 }
02790
02791 IL_NAMELIST_EXPECTED(arg_array[arg_idx]) = TRUE;
02792 IL_FORMAT_EXPECTED(arg_array[arg_idx]) = FALSE;
02793
02794 had_nml = TRUE;
02795
02796 break;
02797
02798 case Var_Only_Form :
02799
02800 parsed_ok = parse_expr(&opnd) && parsed_ok;
02801 COPY_OPND(IL_OPND(arg_array[arg_idx]), opnd);
02802
02803 mark_attr_defined(&opnd);
02804
02805 break;
02806
02807 case Format_Form :
02808
02809 buf_idx = LA_CH_BUF_IDX;
02810
02811 if (LA_CH_CLASS == Ch_Class_Digit &&
02812 digit_is_format_label()) {
02813
02814
02815
02816 if (MATCHED_TOKEN_CLASS(Tok_Class_Label) &&
02817 ! TOKEN_ERR(token)) {
02818
02819 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token),
02820 &name_idx);
02821
02822 if (attr_idx == NULL_IDX) {
02823 attr_idx = ntr_sym_tbl(&token, name_idx);
02824 AT_OBJ_CLASS(attr_idx) = Label;
02825 LN_DEF_LOC(name_idx) = TRUE;
02826 build_fwd_ref_entry(attr_idx, Format_Ref);
02827 }
02828 else if ( ! AT_DCL_ERR(attr_idx) ) {
02829
02830 if (!AT_DEFINED(attr_idx)) {
02831 build_fwd_ref_entry(attr_idx, Format_Ref);
02832 }
02833 else if (ATL_CLASS(attr_idx) != Lbl_Format) {
02834
02835 PRINTMSG(TOKEN_LINE(token), 328, Error,
02836 TOKEN_COLUMN(token),
02837 AT_OBJ_NAME_PTR(attr_idx));
02838 parsed_ok = FALSE;
02839 break;
02840 }
02841 }
02842 else {
02843
02844 parsed_ok = FALSE;
02845 break;
02846 }
02847
02848 IL_FLD(arg_array[arg_idx]) = AT_Tbl_Idx;
02849 IL_IDX(arg_array[arg_idx]) = attr_idx;
02850 IL_LINE_NUM(arg_array[arg_idx]) = TOKEN_LINE(token);
02851 IL_COL_NUM(arg_array[arg_idx]) = TOKEN_COLUMN(token);
02852
02853 if (cif_flags & XREF_RECS) {
02854 cif_usage_rec(attr_idx, AT_Tbl_Idx,
02855 TOKEN_LINE(token), TOKEN_COLUMN(token),
02856 CIF_Label_Referenced_As_Format);
02857 }
02858 }
02859 else if (TOKEN_ERR(token)) {
02860 parse_err_flush(Find_Comma_Rparen, NULL);
02861 parsed_ok = FALSE;
02862 }
02863 else {
02864 parse_err_flush(Find_Comma_Rparen, "LABEL");
02865 parsed_ok = FALSE;
02866 }
02867 }
02868 else {
02869 parsed_ok = parse_expr(&opnd) && parsed_ok;
02870 COPY_OPND(IL_OPND(arg_array[arg_idx]), opnd);
02871 }
02872
02873 IL_FORMAT_EXPECTED(arg_array[arg_idx]) = item_has_keyword;
02874 IL_NAMELIST_EXPECTED(arg_array[arg_idx]) = FALSE;
02875
02876 if (!item_has_keyword &&
02877 IL_FLD(arg_array[arg_idx]) == AT_Tbl_Idx &&
02878 AT_OBJ_CLASS(IL_IDX(arg_array[arg_idx])) == Namelist_Grp) {
02879 had_nml = TRUE;
02880 }
02881 else {
02882 had_fmt = TRUE;
02883 }
02884
02885 if (had_fmt &&
02886 IL_FLD(arg_array[arg_idx]) == CN_Tbl_Idx &&
02887 TYP_TYPE(CN_TYPE_IDX(IL_IDX(arg_array[arg_idx]))) ==
02888 Character) {
02889
02890
02891 set_format_start_idx(buf_idx);
02892
02893 format_cn_idx = IL_IDX(arg_array[arg_idx]);
02894
02895 ignore_trailing_chars = TRUE;
02896 pre_parse_format_idx = pre_parse_format(format_cn_idx, 0);
02897 ignore_trailing_chars = FALSE;
02898
02899 NTR_IR_LIST_TBL(list_idx);
02900 IL_FLD(arg_array[arg_idx]) = IL_Tbl_Idx;
02901 IL_IDX(arg_array[arg_idx]) = list_idx;
02902 IL_LIST_CNT(arg_array[arg_idx]) = 2;
02903
02904 IL_FLD(list_idx) = AT_Tbl_Idx;
02905 idx = create_format_tmp(format_cn_idx);
02906 IL_IDX(list_idx) = idx;
02907 IL_LINE_NUM(list_idx) = stmt_start_line;
02908 IL_COL_NUM(list_idx) = stmt_start_col;
02909
02910 NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02911 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02912 list_idx = IL_NEXT_LIST_IDX(list_idx);
02913
02914 if (pre_parse_format_idx != NULL_IDX) {
02915 IL_FLD(list_idx) = AT_Tbl_Idx;
02916 idx = create_format_tmp(pre_parse_format_idx);
02917 IL_IDX(list_idx) = idx;
02918 IL_LINE_NUM(list_idx) = stmt_start_line;
02919 IL_COL_NUM(list_idx) = stmt_start_col;
02920 }
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 if (new_fmt != NULL) {
03216
03217 # if 0
03218 pre_parse_idx = translate_pp_format((fmt_type *)new_fmt, format_len);
03219 # endif
03220
03221 # if defined(_HOST32) && defined(_TARGET64)
03222 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
03223 TYP_TYPE(TYP_WORK_IDX) = Typeless;
03224 TYP_BIT_LEN(TYP_WORK_IDX) = format_len * HOST_BITS_PER_WORD;
03225 type_idx = ntr_type_tbl();
03226
03227 pre_parse_idx = ntr_const_tbl(type_idx, FALSE, NULL);
03228
03229 long_const = (long *)&CN_CONST(pre_parse_idx);
03230
03231 for (i = 0; i < format_len; i++) {
03232 long_const[i] = new_fmt[i];
03233 }
03234 # else
03235 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
03236 TYP_TYPE(TYP_WORK_IDX) = Typeless;
03237 TYP_BIT_LEN(TYP_WORK_IDX) = format_len * TARGET_BITS_PER_WORD;
03238 type_idx = ntr_type_tbl();
03239
03240 pre_parse_idx = ntr_const_tbl(type_idx, FALSE, (long_type *)new_fmt);
03241 # endif
03242
03243 MEM_FREE(new_fmt);
03244 }
03245 else {
03246 pre_parse_idx = NULL_IDX;
03247 }
03248
03249 TRACE (Func_Exit, "pre_parse_format", NULL);
03250
03251 return(pre_parse_idx);
03252
03253 }
03254
03255
03256
03257
03258
03259
03260
03261
03262
03263
03264
03265
03266
03267
03268
03269
03270
03271
03272 static int create_format_tmp (int const_idx)
03273
03274 {
03275 int attr_idx;
03276 int bd_idx;
03277 int cn_idx;
03278 int ir_idx;
03279 int list1_idx;
03280 int list2_idx;
03281 int list3_idx;
03282 long64 num_bits;
03283 #ifdef KEY
03284 long64 num_els = 0;
03285 #else
03286 long64 num_els;
03287 #endif
03288 size_offset_type stride;
03289
03290
03291 TRACE (Func_Entry, "create_format_tmp", NULL);
03292
03293 attr_idx = gen_compiler_tmp(stmt_start_line,
03294 stmt_start_col,
03295 Shared, TRUE);
03296 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
03297 ATD_TYPE_IDX(attr_idx) = Integer_8;
03298 # else
03299 ATD_TYPE_IDX(attr_idx) = CG_INTEGER_DEFAULT_TYPE;
03300 # endif
03301 ATD_SAVED(attr_idx) = TRUE;
03302 ATD_DATA_INIT(attr_idx) = TRUE;
03303 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx);
03304 AT_SEMANTICS_DONE(attr_idx) = TRUE;
03305 ATD_READ_ONLY_VAR(attr_idx) = TRUE;
03306
03307 if (TYP_TYPE(CN_TYPE_IDX(const_idx)) == Character) {
03308 num_els = 1L +
03309 TARGET_BYTES_TO_WORDS(CN_INT_TO_C(TYP_IDX(CN_TYPE_IDX(const_idx))));
03310 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
03311 # ifndef _WHIRL_HOST64_TARGET64
03312 num_els = (num_els + 1) / 2;
03313 # endif
03314 num_bits = num_els * 64;
03315 # else
03316 num_bits = num_els * TARGET_BITS_PER_WORD;
03317 # endif
03318 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
03319 TYP_TYPE(TYP_WORK_IDX) = Typeless;
03320 TYP_BIT_LEN(TYP_WORK_IDX) = num_bits;
03321 CN_TYPE_IDX(const_idx) = ntr_type_tbl();
03322 CN_EXTRA_ZERO_WORD(const_idx) = FALSE;
03323 }
03324 else if (TYP_TYPE(CN_TYPE_IDX(const_idx)) == Typeless) {
03325
03326 num_els = TARGET_BITS_TO_WORDS((long)TYP_BIT_LEN(CN_TYPE_IDX(const_idx)));
03327
03328 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
03329 # ifndef _WHIRL_HOST64_TARGET64
03330 num_els = (num_els + 1) / 2;
03331 # endif
03332 num_bits = num_els * 64;
03333 # else
03334 num_bits = num_els * TARGET_BITS_PER_WORD;
03335 # endif
03336 }
03337
03338 cn_idx = C_INT_TO_CN(NULL_IDX, num_els);
03339
03340 bd_idx = reserve_array_ntry(1);
03341
03342 set_stride_for_first_dim(ATD_TYPE_IDX(attr_idx), &stride);
03343
03344 BD_RESOLVED(bd_idx) = TRUE;
03345 BD_ARRAY_CLASS(bd_idx) = Explicit_Shape;
03346 BD_ARRAY_SIZE(bd_idx) = Constant_Size;
03347 BD_RANK(bd_idx) = 1;
03348 BD_LEN_FLD(bd_idx) = CN_Tbl_Idx;
03349 BD_LEN_IDX(bd_idx) = cn_idx;
03350 BD_LINE_NUM(bd_idx) = stmt_start_line;
03351 BD_COLUMN_NUM(bd_idx) = stmt_start_col;
03352 BD_LB_FLD(bd_idx,1) = CN_Tbl_Idx;
03353 BD_LB_IDX(bd_idx,1) = CN_INTEGER_ONE_IDX;
03354 BD_UB_FLD(bd_idx,1) = CN_Tbl_Idx;
03355 BD_UB_IDX(bd_idx,1) = cn_idx;
03356 BD_XT_FLD(bd_idx,1) = CN_Tbl_Idx;
03357 BD_XT_IDX(bd_idx,1) = cn_idx;
03358 BD_SM_FLD(bd_idx,1) = stride.fld;
03359 BD_SM_IDX(bd_idx,1) = stride.idx;
03360 ATD_ARRAY_IDX(attr_idx) = bd_idx;
03361
03362 NTR_IR_TBL(ir_idx);
03363 IR_OPR(ir_idx) = Init_Opr;
03364 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
03365 IR_LINE_NUM(ir_idx) = stmt_start_line;
03366 IR_COL_NUM(ir_idx) = stmt_start_col;
03367
03368 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
03369 IR_IDX_L(ir_idx) = attr_idx;
03370 IR_LINE_NUM_L(ir_idx) = stmt_start_line;
03371 IR_COL_NUM_L(ir_idx) = stmt_start_col;
03372
03373 NTR_IR_LIST_TBL(list1_idx);
03374 NTR_IR_LIST_TBL(list2_idx);
03375 NTR_IR_LIST_TBL(list3_idx);
03376
03377 IR_FLD_R(ir_idx) = IL_Tbl_Idx;
03378 IR_IDX_R(ir_idx) = list1_idx;
03379 IR_LIST_CNT_R(ir_idx) = 3;
03380
03381 IL_NEXT_LIST_IDX(list1_idx) = list2_idx;
03382 IL_PREV_LIST_IDX(list2_idx) = list1_idx;
03383
03384 IL_NEXT_LIST_IDX(list2_idx) = list3_idx;
03385 IL_PREV_LIST_IDX(list3_idx) = list2_idx;
03386
03387 IL_FLD(list1_idx) = CN_Tbl_Idx;
03388 IL_IDX(list1_idx) = const_idx;
03389 IL_LINE_NUM(list1_idx) = stmt_start_line;
03390 IL_COL_NUM(list1_idx) = stmt_start_col;
03391
03392 IL_FLD(list2_idx) = CN_Tbl_Idx;
03393 IL_IDX(list2_idx) = CN_INTEGER_ONE_IDX;
03394 IL_LINE_NUM(list2_idx) = stmt_start_line;
03395 IL_COL_NUM(list2_idx) = stmt_start_col;
03396
03397 IL_FLD(list3_idx) = CN_Tbl_Idx;
03398 IL_IDX(list3_idx) = CN_INTEGER_ZERO_IDX;
03399 IL_LINE_NUM(list3_idx) = stmt_start_line;
03400 IL_COL_NUM(list3_idx) = stmt_start_col;
03401
03402 ATD_FLD(attr_idx) = CN_Tbl_Idx;
03403 ATD_TMP_IDX(attr_idx) = const_idx;
03404
03405 gen_sh(Before, Assignment_Stmt, stmt_start_line,
03406 stmt_start_col, FALSE, FALSE, TRUE);
03407
03408 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
03409 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
03410
03411 TRACE (Func_Exit, "create_format_tmp", NULL);
03412
03413 return(attr_idx);
03414
03415 }
03416 # if 0
03417 # if defined(_HOST32) && defined(_TARGET64)
03418
03419
03420
03421
03422
03423
03424
03425
03426
03427
03428
03429
03430
03431
03432
03433
03434
03435 static int translate_pp_format(fmt_type *old_const,
03436 int num_host_wds)
03437
03438 {
03439 int cn_idx;
03440 int cn_offset;
03441 int i;
03442 int new_idx;
03443 int new_revert_idx;
03444 int num_bits;
03445 int num_elements;
03446 int revert_idx;
03447 int revert_val;
03448 int str_cnt;
03449 int type_idx;
03450
03451 TRACE (Func_Entry, "translate_pp_format", NULL);
03452
03453 num_elements = num_host_wds/FMT_ENTRY_WORD_SIZE;
03454
03455
03456
03457
03458
03459
03460
03461
03462 num_bits = num_host_wds * HOST_BITS_PER_WORD;
03463
03464
03465
03466 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
03467 TYP_TYPE(TYP_WORK_IDX) = Typeless;
03468 TYP_BIT_LEN(TYP_WORK_IDX) = num_bits;
03469 type_idx = ntr_type_tbl();
03470
03471 cn_idx = ntr_const_tbl(type_idx, FALSE, NULL);
03472
03473 # ifdef _DEBUG
03474 if (old_const[num_elements-1].op_code != REVERT_OP) {
03475 PRINTMSG(stmt_start_line, 1095, Internal, stmt_start_col);
03476 }
03477 # endif
03478
03479 revert_val = old_const[num_elements-1].rep_count;
03480 revert_idx = revert_val + (num_elements - 1);
03481
03482
03483
03484 cn_offset = 0;
03485
03486 for (i = 0; i < num_elements; i++) {
03487
03488 new_idx = cn_offset/2;
03489
03490 if (i == revert_idx) {
03491 new_revert_idx = new_idx;
03492 }
03493
03494 CP_CONSTANT(CN_POOL_IDX(cn_idx) + cn_offset) =
03495 ((long_type)(old_const[i].op_code)) << 57 |
03496 ((long_type)(old_const[i].reserved1)) << 54 |
03497 ((long_type)(old_const[i].exponent)) << 48 |
03498 ((long_type)(old_const[i].decimal_field)) << 24 |
03499 old_const[i].field_width;
03500
03501 cn_offset++;
03502
03503 CP_CONSTANT(CN_POOL_IDX(cn_idx) + cn_offset) =
03504 ((long_type)(old_const[i].rgcdedf)) << 63 |
03505 ((long_type)(old_const[i].reserved2)) << 48 |
03506 ((long_type)(old_const[i].offset)) << 32;
03507
03508 if (i == num_elements - 1) {
03509 CP_CONSTANT(CN_POOL_IDX(cn_idx) + cn_offset) |=
03510 ((new_revert_idx - new_idx) & 037777777777);
03511 }
03512 else {
03513 CP_CONSTANT(CN_POOL_IDX(cn_idx) + cn_offset) |=
03514 (old_const[i].rep_count & 037777777777);
03515 }
03516
03517 cn_offset++;
03518
03519 if (old_const[i].op_code == STRING_ED) {
03520
03521
03522 str_cnt = old_const[i].field_width;
03523
03524 strncpy((char *)&(CP_CONSTANT(CN_POOL_IDX(cn_idx) + cn_offset)),
03525 (char *)&(old_const[i+1]),
03526 str_cnt);
03527
03528
03529
03530 cn_offset += ((str_cnt + 15) / 16) * 2;
03531 i += (str_cnt + FMT_ENTRY_BYTE_SIZE - 1) / FMT_ENTRY_BYTE_SIZE;
03532 }
03533 }
03534
03535
03536 num_bits = cn_offset * TARGET_BITS_PER_WORD;
03537
03538 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
03539 TYP_TYPE(TYP_WORK_IDX) = Typeless;
03540 TYP_BIT_LEN(TYP_WORK_IDX) = num_bits;
03541 type_idx = ntr_type_tbl();
03542
03543 CN_TYPE_IDX(cn_idx) = type_idx;
03544
03545 TRACE (Func_Exit, "translate_pp_format", NULL);
03546
03547 return(cn_idx);
03548
03549 }
03550 # endif
03551 # endif
