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_dcl_pu.c 5.5 09/01/99 09:11:00\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
00052 # include "globals.h"
00053 # include "tokens.h"
00054 # include "sytb.h"
00055 # include "p_globals.h"
00056
00057
00058
00059
00060
00061
00062 static void gen_end_prologue_debug_label (int);
00063 static void parse_dummy_args (int);
00064 static void parse_prefix_spec (void);
00065 static void set_function_rslt (int, boolean);
00066 static void start_new_scp (void);
00067 static int start_new_subpgm (pgm_unit_type, boolean, boolean);
00068
00069
00070
00071
00072
00073
00074
00075
00076
00077
00078
00079
00080
00081
00082
00083
00084
00085
00086 void parse_block_stmt (void)
00087 {
00088 int defer_msg = 0;
00089 static char num_unnamed = 'A';
00090 boolean parse_error;
00091 boolean unnamed_blk = FALSE;
00092
00093
00094 TRACE (Func_Entry, "parse_block_stmt", NULL);
00095
00096 if (matched_specific_token(Tok_Kwd_Data, Tok_Class_Keyword)) {
00097 parse_error = FALSE;
00098
00099 if (LA_CH_VALUE == EOS) {
00100 unnamed_blk = TRUE;
00101 TOKEN_STR(token)[0] = 'B';
00102 TOKEN_STR(token)[1] = 'L';
00103 TOKEN_STR(token)[2] = 'K';
00104 # if defined(_NO_AT_SIGN_IN_NAMES)
00105 TOKEN_STR(token)[3] = '.';
00106 # else
00107 TOKEN_STR(token)[3] = '@';
00108 # endif
00109 TOKEN_STR(token)[4] = 'D';
00110 TOKEN_STR(token)[5] = 'A';
00111 TOKEN_STR(token)[6] = 'T';
00112 TOKEN_STR(token)[7] = num_unnamed;
00113 TOKEN_LEN(token) = 8;
00114 TOKEN_VALUE(token) = Tok_Id;
00115 TOKEN_LINE(token) = stmt_start_line;
00116 TOKEN_COLUMN(token) = stmt_start_col;
00117
00118 if (num_unnamed > 'Z') {
00119
00120
00121
00122
00123 TOKEN_STR(token)[7] = 'a';
00124 }
00125 }
00126 else if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
00127 parse_err_flush(Find_EOS, "block-data-name");
00128 parse_error = TRUE;
00129 token = main_token;
00130 TOKEN_LINE(token) = stmt_start_line;
00131 TOKEN_COLUMN(token) = stmt_start_col;
00132 }
00133 }
00134 else {
00135 parse_err_flush(Find_EOS, "DATA");
00136 parse_error = TRUE;
00137 token = main_token;
00138 TOKEN_LINE(token) = stmt_start_line;
00139 TOKEN_COLUMN(token) = stmt_start_col;
00140 }
00141
00142 start_new_prog_unit(Blockdata,
00143 Blockdata_Blk,
00144 FALSE,
00145 parse_error,
00146 &defer_msg);
00147 CURR_BLK_NO_EXEC = TRUE;
00148
00149 if (unnamed_blk) {
00150 CURR_BLK_NAME = NULL_IDX;
00151
00152 if (num_unnamed > 'Z') {
00153 PRINTMSG(stmt_start_line, 29, Error, stmt_start_col);
00154 }
00155 else if (num_unnamed > 'A') {
00156 PRINTMSG(stmt_start_line, 30, Ansi, stmt_start_col);
00157 }
00158 num_unnamed++;
00159 }
00160
00161 if (LA_CH_VALUE != EOS) {
00162 parse_err_flush(Find_EOS, EOS_STR);
00163 }
00164
00165 NEXT_LA_CH;
00166
00167 TRACE (Func_Exit, "parse_block_stmt", NULL);
00168
00169 return;
00170
00171 }
00172
00173
00174
00175
00176
00177
00178
00179
00180
00181
00182
00183
00184
00185
00186
00187
00188
00189 void parse_entry_stmt (void)
00190
00191 {
00192 int attr_idx = NULL_IDX;
00193 boolean blk_err = FALSE;
00194 int branch_around_lbl_idx;
00195 int host_attr_idx;
00196 int host_name_idx;
00197 int ir_idx;
00198 boolean issue_msg;
00199 int length;
00200 int list_idx;
00201 int name_idx;
00202 pgm_unit_type pgm_unit;
00203 atp_proc_type proc_type;
00204 int save_scp_idx;
00205 obj_type sem_type;
00206
00207
00208 TRACE (Func_Entry, "parse_entry_stmt", NULL);
00209
00210 if (STMT_CANT_BE_IN_BLK(Entry_Stmt, CURR_BLK) && iss_blk_stk_err()) {
00211
00212
00213
00214 blk_err = TRUE;
00215
00216 }
00217 else if (curr_stmt_category < Implicit_None_Stmt_Cat) {
00218
00219
00220
00221
00222 curr_stmt_category = Implicit_None_Stmt_Cat;
00223 }
00224
00225 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
00226 attr_idx = srch_sym_tbl(TOKEN_STR(token),
00227 TOKEN_LEN(token),
00228 &name_idx);
00229
00230 pgm_unit = (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Function) ?
00231 Function : Subroutine;
00232
00233 proc_type = (atp_proc_type) ATP_PROC(SCP_ATTR_IDX(curr_scp_idx));
00234
00235
00236
00237 if (ATP_PROC(SCP_ATTR_IDX(curr_scp_idx)) == Module_Proc) {
00238 host_attr_idx = srch_host_sym_tbl(TOKEN_STR(token),
00239 TOKEN_LEN(token),
00240 &host_name_idx,
00241 FALSE);
00242
00243 if (host_attr_idx == NULL_IDX) {
00244
00245 if (attr_idx == NULL_IDX) {
00246 save_scp_idx = curr_scp_idx;
00247 curr_scp_idx = SCP_PARENT_IDX(curr_scp_idx);
00248 host_attr_idx = ntr_sym_tbl(&token, host_name_idx);
00249 curr_scp_idx = save_scp_idx;
00250 attr_idx = srch_sym_tbl(TOKEN_STR(token),
00251 TOKEN_LEN(token),
00252 &name_idx);
00253
00254
00255
00256 attr_idx = ntr_host_in_sym_tbl(&token,
00257 name_idx,
00258 host_attr_idx,
00259 host_name_idx,
00260 FALSE);
00261
00262 LN_DEF_LOC(name_idx) = TRUE;
00263 LN_DEF_LOC(host_name_idx) = TRUE;
00264 AT_OBJ_CLASS(attr_idx) = Pgm_Unit;
00265 ATP_PGM_UNIT(attr_idx) = pgm_unit;
00266 ATP_PROC(attr_idx) = proc_type;
00267 }
00268 else {
00269
00270 sem_type = (pgm_unit == Function) ? Obj_Entry_Func :
00271 Obj_Entry_Subr;
00272
00273 if (fnd_semantic_err(sem_type,
00274 TOKEN_LINE(token),
00275 TOKEN_COLUMN(token),
00276 attr_idx,
00277 TRUE)) {
00278 CREATE_ERR_ATTR(attr_idx,
00279 TOKEN_LINE(token),
00280 TOKEN_COLUMN(token),
00281 Pgm_Unit);
00282
00283 ATP_PGM_UNIT(attr_idx) = pgm_unit;
00284 ATP_PROC(attr_idx) = proc_type;
00285 }
00286 else {
00287 LN_DEF_LOC(name_idx) = TRUE;
00288 }
00289
00290 save_scp_idx = curr_scp_idx;
00291 curr_scp_idx = SCP_PARENT_IDX(curr_scp_idx);
00292 host_attr_idx = ntr_sym_tbl(&token,
00293 host_name_idx);
00294 curr_scp_idx = save_scp_idx;
00295 attr_tbl_idx--;
00296 attr_aux_tbl_idx--;
00297 LN_ATTR_IDX(host_name_idx) = attr_idx;
00298 LN_NAME_IDX(host_name_idx) = AT_NAME_IDX(attr_idx);
00299 LN_DEF_LOC(host_name_idx) = TRUE;
00300
00301 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
00302 chg_data_obj_to_pgm_unit(attr_idx,
00303 pgm_unit,
00304 proc_type);
00305 }
00306 else if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {
00307 ATP_PGM_UNIT(attr_idx) = pgm_unit;
00308 ATP_PROC(attr_idx) = proc_type;
00309 }
00310 }
00311 }
00312 else {
00313 issue_msg = TRUE;
00314
00315 if (attr_idx != NULL_IDX) {
00316 sem_type = (pgm_unit == Function) ? Obj_Entry_Func :
00317 Obj_Entry_Subr;
00318
00319 if (fnd_semantic_err(sem_type,
00320 TOKEN_LINE(token),
00321 TOKEN_COLUMN(token),
00322 attr_idx,
00323 TRUE)) {
00324
00325 CREATE_ERR_ATTR(attr_idx,
00326 TOKEN_LINE(token),
00327 TOKEN_COLUMN(token),
00328 Pgm_Unit);
00329
00330 ATP_PGM_UNIT(attr_idx) = pgm_unit;
00331 ATP_PROC(attr_idx) = proc_type;
00332 issue_msg = FALSE;
00333 }
00334 else {
00335 LN_DEF_LOC(name_idx) = TRUE;
00336 }
00337 }
00338
00339 sem_type = (pgm_unit == Function) ? Obj_Module_Func :
00340 Obj_Module_Subr;
00341
00342 if (AT_OBJ_CLASS(host_attr_idx) == Interface &&
00343 ATI_PROC_IDX(host_attr_idx) != NULL_IDX) {
00344 host_attr_idx = ATI_PROC_IDX(host_attr_idx);
00345 }
00346
00347 if (fnd_semantic_err(sem_type,
00348 TOKEN_LINE(token),
00349 TOKEN_COLUMN(token),
00350 host_attr_idx,
00351 issue_msg)) {
00352 CREATE_ERR_ATTR(host_attr_idx,
00353 TOKEN_LINE(token),
00354 TOKEN_COLUMN(token),
00355 Pgm_Unit);
00356 ATP_PGM_UNIT(host_attr_idx) = pgm_unit;
00357 ATP_PROC(host_attr_idx) = proc_type;
00358
00359 }
00360 else if (AT_OBJ_CLASS(host_attr_idx) == Data_Obj) {
00361 chg_data_obj_to_pgm_unit(host_attr_idx,
00362 pgm_unit,
00363 proc_type);
00364 }
00365 else if (ATP_PROC(host_attr_idx) == Module_Proc &&
00366 ATP_EXPL_ITRFC(host_attr_idx)) {
00367
00368
00369
00370 PRINTMSG(TOKEN_LINE(token), 1529, Error,
00371 TOKEN_COLUMN(token),
00372 AT_OBJ_NAME_PTR(host_attr_idx));
00373 }
00374 else {
00375 ATP_PGM_UNIT(host_attr_idx) = pgm_unit;
00376 ATP_PROC(host_attr_idx) = proc_type;
00377 }
00378
00379 if (attr_idx == NULL_IDX) {
00380 attr_idx = ntr_host_in_sym_tbl(&token,
00381 name_idx,
00382 host_attr_idx,
00383 host_name_idx,
00384 FALSE);
00385 LN_DEF_LOC(name_idx) = TRUE;
00386 }
00387 else {
00388
00389
00390
00391
00392
00393
00394
00395
00396
00397
00398
00399 if (issue_msg && pgm_unit == Function) {
00400 ATP_RSLT_IDX(host_attr_idx) = attr_idx;
00401 ATD_CLASS(attr_idx) = Function_Result;
00402 ATD_FUNC_IDX(attr_idx) = host_attr_idx;
00403 }
00404 }
00405 LN_ATTR_IDX(name_idx) = host_attr_idx;
00406 LN_NAME_IDX(name_idx) = AT_NAME_IDX(host_attr_idx);
00407 LN_DEF_LOC(host_name_idx) = TRUE;
00408 attr_idx = host_attr_idx;
00409 }
00410
00411 ATP_EXT_NAME_IDX(attr_idx) = AT_NAME_IDX(attr_idx);
00412
00413 ATP_EXT_NAME_LEN(attr_idx) = AT_NAME_LEN(attr_idx);
00414 }
00415 else if (attr_idx == NULL_IDX) {
00416 attr_idx = ntr_sym_tbl(&token, name_idx);
00417 LN_DEF_LOC(name_idx) = TRUE;
00418 AT_OBJ_CLASS(attr_idx) = Pgm_Unit;
00419 ATP_PGM_UNIT(attr_idx) = pgm_unit;
00420 ATP_PROC(attr_idx) = ATP_PROC(SCP_ATTR_IDX(curr_scp_idx));
00421 MAKE_EXTERNAL_NAME(attr_idx,
00422 AT_NAME_IDX(attr_idx),
00423 AT_NAME_LEN(attr_idx));
00424 }
00425 else {
00426 sem_type = (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Function) ?
00427 Obj_Entry_Func : Obj_Entry_Subr;
00428
00429 if (fnd_semantic_err(sem_type,
00430 TOKEN_LINE(token),
00431 TOKEN_COLUMN(token),
00432 attr_idx,
00433 TRUE)) {
00434 CREATE_ERR_ATTR(attr_idx,
00435 TOKEN_LINE(token),
00436 TOKEN_COLUMN(token),
00437 Pgm_Unit);
00438
00439 ATP_PGM_UNIT(attr_idx) = pgm_unit;
00440 ATP_PROC(attr_idx) = ATP_PROC(SCP_ATTR_IDX(curr_scp_idx));
00441 MAKE_EXTERNAL_NAME(attr_idx,
00442 AT_NAME_IDX(attr_idx),
00443 AT_NAME_LEN(attr_idx));
00444 }
00445 else {
00446 LN_DEF_LOC(name_idx)= TRUE;
00447
00448 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
00449 chg_data_obj_to_pgm_unit(attr_idx,
00450 pgm_unit,
00451 (atp_proc_type)
00452 ATP_PROC(SCP_ATTR_IDX(curr_scp_idx)));
00453 }
00454 else if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {
00455 ATP_PGM_UNIT(attr_idx) = pgm_unit;
00456 ATP_PROC(attr_idx) = proc_type;
00457 }
00458 }
00459 }
00460
00461 ATP_SCP_IDX(attr_idx) = curr_scp_idx;
00462 ATP_ALT_ENTRY(attr_idx) = TRUE;
00463 ATP_RECURSIVE(attr_idx) = ATP_RECURSIVE(SCP_ATTR_IDX(curr_scp_idx));
00464 ATP_ELEMENTAL(attr_idx) = ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx));
00465 ATP_PURE(attr_idx) = ATP_PURE(SCP_ATTR_IDX(curr_scp_idx));
00466 ATP_SCP_ALIVE(attr_idx) = TRUE;
00467 ATP_EXPL_ITRFC(attr_idx) = TRUE;
00468 ATP_MAY_INLINE(attr_idx) = ATP_MAY_INLINE(SCP_ATTR_IDX(curr_scp_idx));
00469
00470 if ((cif_flags & XREF_RECS) != 0) {
00471 cif_usage_rec(attr_idx,
00472 AT_Tbl_Idx,
00473 TOKEN_LINE(token),
00474 TOKEN_COLUMN(token),
00475 CIF_Symbol_Declaration);
00476 }
00477
00478 NTR_ATTR_LIST_TBL(list_idx);
00479 AL_ATTR_IDX(list_idx) = attr_idx;
00480 AL_NEXT_IDX(list_idx) = SCP_ENTRY_IDX(curr_scp_idx);
00481 SCP_ENTRY_IDX(curr_scp_idx) = list_idx;
00482
00483 if (SCP_ALT_ENTRY_CNT(curr_scp_idx) >= MAX_ALTERNATE_ENTRIES) {
00484 PRINTMSG(TOKEN_LINE(token), 1115, Limit,
00485 TOKEN_COLUMN(token),
00486 MAX_ALTERNATE_ENTRIES);
00487 }
00488
00489 SCP_ALT_ENTRY_CNT(curr_scp_idx) = SCP_ALT_ENTRY_CNT(curr_scp_idx) + 1;
00490 AT_DCL_ERR(attr_idx) |= blk_err;
00491
00492 if (LA_CH_VALUE != EOS && LA_CH_VALUE != LPAREN) {
00493 parse_err_flush(Find_Lparen, "( or " EOS_STR );
00494 }
00495
00496 if (CURR_BLK != Interface_Body_Blk &&
00497 (cmd_line_flags.runtime_argument ||
00498 cmd_line_flags.runtime_arg_entry)) {
00499
00500 ATP_ARGCHCK_ENTRY(attr_idx) = TRUE;
00501 }
00502
00503 if (LA_CH_VALUE == LPAREN) {
00504 parse_dummy_args(attr_idx);
00505 }
00506
00507 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Function) {
00508 set_function_rslt(attr_idx, FALSE);
00509
00510 if (LA_CH_VALUE != EOS) {
00511 parse_err_flush(Find_EOS, EOS_STR);
00512 }
00513 }
00514 else if (LA_CH_VALUE != EOS) {
00515
00516 if (matched_specific_token (Tok_Kwd_Result, Tok_Class_Keyword)){
00517
00518
00519
00520 PRINTMSG(TOKEN_LINE(token), 122, Error, TOKEN_COLUMN(token));
00521 parse_err_flush(Find_EOS, NULL);
00522 }
00523 else {
00524 parse_err_flush(Find_EOS, EOS_STR);
00525 }
00526 }
00527
00528 branch_around_lbl_idx = gen_internal_lbl(TOKEN_LINE(token));
00529
00530 NTR_IR_TBL(ir_idx);
00531 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
00532 SH_COMPILER_GEN(curr_stmt_sh_idx) = TRUE;
00533 SH_STMT_TYPE(curr_stmt_sh_idx) = Goto_Stmt;
00534 IR_OPR(ir_idx) = Br_Uncond_Opr;
00535 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
00536 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token);
00537 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token);
00538 IR_FLD_R(ir_idx) = AT_Tbl_Idx;
00539 IR_IDX_R(ir_idx) = branch_around_lbl_idx;
00540 IR_COL_NUM_R(ir_idx) = TOKEN_COLUMN(token);
00541 IR_LINE_NUM_R(ir_idx) = TOKEN_LINE(token);
00542
00543 gen_sh(After, stmt_type, TOKEN_LINE(token), TOKEN_COLUMN(token),
00544 FALSE, FALSE, FALSE);
00545
00546 NTR_IR_TBL(ir_idx);
00547 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
00548 IR_OPR(ir_idx) = Entry_Opr;
00549 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
00550 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token);
00551 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token);
00552 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
00553 IR_IDX_L(ir_idx) = attr_idx;
00554 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token);
00555 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
00556
00557 if (attr_idx != NULL_IDX) {
00558 ATP_FIRST_SH_IDX(attr_idx) = curr_stmt_sh_idx;
00559 }
00560
00561 gen_sh(After, Continue_Stmt, TOKEN_LINE(token), TOKEN_COLUMN(token),
00562 FALSE, TRUE, TRUE);
00563
00564 NTR_IR_TBL(ir_idx);
00565 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
00566 IR_OPR(ir_idx) = Label_Opr;
00567 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
00568 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token);
00569 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token);
00570 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
00571 IR_IDX_L(ir_idx) = branch_around_lbl_idx;
00572 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token);
00573 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
00574
00575 if (attr_idx != NULL_IDX) {
00576 ATP_ENTRY_LABEL_SH_IDX(attr_idx) = curr_stmt_sh_idx;
00577 }
00578
00579 if (cmd_line_flags.debug_lvl <= Debug_Lvl_1) {
00580 gen_end_prologue_debug_label(attr_idx);
00581 }
00582 }
00583 else {
00584 parse_err_flush(Find_EOS, "entry-name");
00585 }
00586
00587 NEXT_LA_CH;
00588
00589 TRACE (Func_Exit, "parse_entry_stmt", NULL);
00590
00591 return;
00592
00593 }
00594
00595
00596
00597
00598
00599
00600
00601
00602
00603
00604
00605
00606
00607
00608
00609
00610
00611
00612
00613
00614 void parse_function_stmt (void)
00615
00616 {
00617 int attr_idx;
00618 int defer_msg;
00619 boolean err_fnd = FALSE;
00620 token_type save_token;
00621 boolean is_coarray_concurrent = FALSE;
00622
00623
00624 TRACE (Func_Entry, "parse_function_stmt", NULL);
00625
00626 if (curr_stmt_category > Sub_Func_Stmt_Cat) {
00627 err_fnd = TRUE;
00628 iss_blk_stk_err();
00629 }
00630
00631
00632 if (strncmp(token.token_str.string,"COFUNCTI",8)==0)
00633 is_coarray_concurrent = TRUE;
00634
00635 if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
00636 parse_err_flush(Find_Lparen, "function-name");
00637 token = main_token;
00638 TOKEN_LINE(token) = stmt_start_line;
00639 TOKEN_COLUMN(token) = stmt_start_col;
00640 err_fnd = TRUE;
00641 }
00642 else if (LA_CH_VALUE != LPAREN) {
00643 save_token = token;
00644 parse_err_flush(Find_Lparen, "(");
00645 err_fnd = TRUE;
00646 token = save_token;
00647 }
00648
00649 if (curr_stmt_category == Init_Stmt_Cat) {
00650 defer_msg = 0;
00651 attr_idx = start_new_prog_unit(Function,
00652 Function_Blk,
00653 FALSE,
00654 err_fnd,
00655 &defer_msg);
00656 ATP_PROC(attr_idx) = Extern_Proc;
00657 }
00658 else {
00659
00660
00661
00662
00663
00664
00665 start_new_scp();
00666 curr_scp_idx = SCP_PARENT_IDX(curr_scp_idx);
00667 attr_idx = start_new_subpgm(Function, err_fnd, TRUE);
00668 }
00669
00670
00671
00672 SCP_IN_ERR(curr_scp_idx) = SCP_IN_ERR(curr_scp_idx) ||
00673 AT_DCL_ERR(attr_idx);
00674
00675 if (CURR_BLK != Interface_Body_Blk &&
00676 (cmd_line_flags.runtime_argument ||
00677 cmd_line_flags.runtime_arg_entry)) {
00678
00679 ATP_ARGCHCK_ENTRY(attr_idx) = TRUE;
00680 }
00681
00682 if (LA_CH_VALUE == LPAREN) {
00683 parse_dummy_args(attr_idx);
00684 }
00685
00686 set_function_rslt(attr_idx, FALSE);
00687
00688 if (is_coarray_concurrent)
00689 ATP_COARRAY_CONCURRENT(attr_idx)=TRUE;
00690
00691 if (LA_CH_VALUE != EOS) {
00692 parse_err_flush(Find_EOS, EOS_STR);
00693 }
00694
00695 NEXT_LA_CH;
00696
00697 TRACE (Func_Exit, "parse_function_stmt", NULL);
00698
00699 return;
00700
00701 }
00702
00703
00704
00705
00706
00707
00708
00709
00710
00711
00712
00713
00714
00715
00716
00717
00718
00719 void parse_module_stmt (void)
00720
00721 {
00722 int attr_idx;
00723 int defer_msg;
00724 boolean found_comma;
00725 int host_name_idx;
00726 int interface_idx = NULL_IDX;
00727
00728 # if defined(_SPLIT_STATIC_STORAGE_M)
00729 id_str_type name;
00730 int new_idx;
00731 # endif
00732
00733 int name_idx;
00734 int new_attr_idx;
00735 boolean parse_error;
00736 int sn_idx;
00737 int stmt_number;
00738 int tmp_attr_idx;
00739
00740
00741 TRACE (Func_Entry, "parse_module_stmt", NULL);
00742
00743 stmt_number = statement_number;
00744
00745 if (curr_stmt_category != Init_Stmt_Cat &&
00746 matched_specific_token (Tok_Kwd_Procedure, Tok_Class_Keyword)) {
00747
00748
00749
00750
00751 stmt_type = Module_Proc_Stmt;
00752 SH_STMT_TYPE(curr_stmt_sh_idx) = Module_Proc_Stmt;
00753
00754 if (CURR_BLK == Interface_Blk) {
00755
00756 if (CURR_BLK_NAME == NULL_IDX) {
00757 PRINTMSG(stmt_start_line, 4, Error, stmt_start_col);
00758 }
00759 else {
00760 curr_stmt_category = Sub_Func_Stmt_Cat;
00761
00762 if (cif_flags & MISC_RECS) {
00763 cif_stmt_type_rec(TRUE, CIF_Module_Procedure_Stmt, stmt_number);
00764 }
00765 }
00766
00767 interface_idx = CURR_BLK_NAME;
00768 }
00769 else if (!iss_blk_stk_err()) {
00770 curr_stmt_category = Sub_Func_Stmt_Cat;
00771 }
00772
00773 do {
00774 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
00775
00776
00777
00778
00779 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token),
00780 &name_idx);
00781
00782 if (attr_idx == NULL_IDX) {
00783 attr_idx = srch_host_sym_tbl(TOKEN_STR(token),
00784 TOKEN_LEN(token),
00785 &host_name_idx,
00786 FALSE);
00787
00788 if (attr_idx == NULL_IDX) {
00789 attr_idx = ntr_sym_tbl(&token, name_idx);
00790 LN_DEF_LOC(name_idx) = TRUE;
00791 AT_OBJ_CLASS(attr_idx) = Pgm_Unit;
00792 ATP_PROC(attr_idx) = Module_Proc;
00793 ATP_SCP_IDX(attr_idx) = curr_scp_idx;
00794 MAKE_EXTERNAL_NAME(attr_idx,
00795 AT_NAME_IDX(attr_idx),
00796 AT_NAME_LEN(attr_idx));
00797 }
00798 else {
00799
00800 if (AT_OBJ_CLASS(attr_idx) == Interface &&
00801 ATI_PROC_IDX(attr_idx) != NULL_IDX) {
00802 attr_idx = ATI_PROC_IDX(attr_idx);
00803 }
00804
00805 if (AT_NOT_VISIBLE(attr_idx)) {
00806 PRINTMSG(TOKEN_LINE(token), 486, Error,
00807 TOKEN_COLUMN(token),
00808 AT_OBJ_NAME_PTR(attr_idx),
00809 AT_OBJ_NAME_PTR(AT_MODULE_IDX((attr_idx))));
00810 CREATE_ERR_ATTR(attr_idx,
00811 TOKEN_LINE(token),
00812 TOKEN_COLUMN(token),
00813 Pgm_Unit);
00814 ATP_PROC(attr_idx) = Module_Proc;
00815 ATP_SCP_IDX(attr_idx) = curr_scp_idx;
00816 MAKE_EXTERNAL_NAME(attr_idx,
00817 AT_NAME_IDX(attr_idx),
00818 AT_NAME_LEN(attr_idx));
00819 }
00820 else if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit &&
00821 ATP_PROC(attr_idx) == Module_Proc) {
00822
00823
00824
00825 attr_idx = ntr_host_in_sym_tbl(&token,
00826 name_idx,
00827 attr_idx,
00828 host_name_idx,
00829 FALSE);
00830 LN_DEF_LOC(name_idx) = TRUE;
00831 }
00832 else if (AT_OBJ_CLASS(attr_idx) == Interface) {
00833 NTR_ATTR_TBL(tmp_attr_idx);
00834 COPY_COMMON_ATTR_INFO(attr_idx, tmp_attr_idx, Pgm_Unit);
00835 ATI_PROC_IDX(attr_idx) = tmp_attr_idx;
00836 attr_idx = tmp_attr_idx;
00837 AT_USE_ASSOCIATED(attr_idx)= FALSE;
00838 AT_IS_INTRIN(attr_idx) = FALSE;
00839 AT_ELEMENTAL_INTRIN(attr_idx) = FALSE;
00840 MAKE_EXTERNAL_NAME(attr_idx,
00841 AT_NAME_IDX(attr_idx),
00842 AT_NAME_LEN(attr_idx));
00843 ATP_PROC(attr_idx) = Module_Proc;
00844 AT_DEF_LINE(attr_idx) = TOKEN_LINE(token);
00845 AT_DEF_COLUMN(attr_idx) = TOKEN_COLUMN(token);
00846 }
00847 else if (fnd_semantic_err(Obj_Module_Proc,
00848 TOKEN_LINE(token),
00849 TOKEN_COLUMN(token),
00850 attr_idx,
00851 FALSE)) {
00852
00853
00854
00855
00856 PRINTMSG(TOKEN_LINE(token), 707, Error,
00857 TOKEN_COLUMN(token),
00858 AT_OBJ_NAME_PTR(attr_idx));
00859
00860 CREATE_ERR_ATTR(attr_idx,
00861 TOKEN_LINE(token),
00862 TOKEN_COLUMN(token),
00863 Pgm_Unit);
00864
00865 ATP_PROC(attr_idx) = Module_Proc;
00866 ATP_SCP_IDX(attr_idx) = curr_scp_idx;
00867 MAKE_EXTERNAL_NAME(attr_idx,
00868 AT_NAME_IDX(attr_idx),
00869 AT_NAME_LEN(attr_idx));
00870 }
00871 else {
00872
00873
00874 attr_idx = ntr_host_in_sym_tbl(&token, name_idx,
00875 attr_idx, host_name_idx,
00876 FALSE);
00877
00878 if (AT_OBJ_CLASS(attr_idx) != Pgm_Unit) {
00879 CLEAR_VARIANT_ATTR_INFO(attr_idx, Pgm_Unit);
00880 MAKE_EXTERNAL_NAME(attr_idx,
00881 AT_NAME_IDX(attr_idx),
00882 AT_NAME_LEN(attr_idx));
00883 }
00884
00885 ATP_PROC(attr_idx) = Module_Proc;
00886 LN_DEF_LOC(name_idx) = TRUE;
00887 }
00888 }
00889 }
00890 else {
00891
00892 if (AT_OBJ_CLASS(attr_idx) == Interface &&
00893 ATI_PROC_IDX(attr_idx) == NULL_IDX ||
00894 AT_IS_INTRIN(attr_idx)) {
00895
00896
00897
00898
00899
00900
00901
00902
00903 NTR_ATTR_TBL(tmp_attr_idx);
00904 COPY_COMMON_ATTR_INFO(attr_idx, tmp_attr_idx, Pgm_Unit);
00905 AT_IS_INTRIN(attr_idx) = FALSE;
00906 AT_ELEMENTAL_INTRIN(attr_idx) = FALSE;
00907 ATI_PROC_IDX(attr_idx) = tmp_attr_idx;
00908 attr_idx = tmp_attr_idx;
00909 AT_USE_ASSOCIATED(attr_idx) = FALSE;
00910 MAKE_EXTERNAL_NAME(attr_idx,
00911 AT_NAME_IDX(attr_idx),
00912 AT_NAME_LEN(attr_idx));
00913 ATP_PROC(attr_idx) = Module_Proc;
00914 AT_DEF_LINE(attr_idx) = TOKEN_LINE(token);
00915 AT_DEF_COLUMN(attr_idx) = TOKEN_COLUMN(token);
00916 }
00917 else {
00918
00919 if (AT_OBJ_CLASS(attr_idx) == Interface) {
00920 attr_idx = ATI_PROC_IDX(attr_idx);
00921 }
00922
00923 if (AT_NOT_VISIBLE(attr_idx) ||
00924 AT_OBJ_CLASS(attr_idx) != Pgm_Unit ||
00925 ATP_PROC(attr_idx) != Module_Proc) {
00926
00927 if (fnd_semantic_err(Obj_Module_Proc,
00928 TOKEN_LINE(token),
00929 TOKEN_COLUMN(token),
00930 attr_idx,
00931 TRUE)) {
00932 CREATE_ERR_ATTR(attr_idx,
00933 TOKEN_LINE(token),
00934 TOKEN_COLUMN(token),
00935 Pgm_Unit);
00936 ATP_SCP_IDX(attr_idx) = curr_scp_idx;
00937 }
00938 else if (AT_OBJ_CLASS(attr_idx) != Pgm_Unit) {
00939 CLEAR_VARIANT_ATTR_INFO(attr_idx, Pgm_Unit);
00940 }
00941
00942 MAKE_EXTERNAL_NAME(attr_idx,
00943 AT_NAME_IDX(attr_idx),
00944 AT_NAME_LEN(attr_idx));
00945 }
00946
00947 ATP_PROC(attr_idx) = Module_Proc;
00948 }
00949 }
00950
00951 if (ATP_SCP_ALIVE(attr_idx) && !ATP_RECURSIVE(attr_idx) &&
00952 !on_off_flags.recursive) {
00953 PRINTMSG(TOKEN_LINE(token), 708, Warning,
00954 TOKEN_COLUMN(token),
00955 AT_OBJ_NAME_PTR(attr_idx));
00956 }
00957
00958 # if 0
00959 if ((cif_flags & XREF_RECS) != 0) {
00960 cif_usage_rec(attr_idx,
00961 AT_Tbl_Idx,
00962 TOKEN_LINE(token),
00963 TOKEN_COLUMN(token),
00964 CIF_Symbol_Declaration);
00965 }
00966 # endif
00967
00968
00969
00970
00971 if (interface_idx != NULL_IDX) {
00972
00973
00974
00975 sn_idx = ATI_FIRST_SPECIFIC_IDX(interface_idx);
00976 new_attr_idx = srch_linked_sn(TOKEN_STR(token),
00977 TOKEN_LEN(token),
00978 &sn_idx);
00979
00980 if (new_attr_idx == NULL_IDX) {
00981 NTR_INTERFACE_IN_SN_TBL(sn_idx,
00982 attr_idx,
00983 interface_idx,
00984 TOKEN_LINE(token),
00985 TOKEN_COLUMN(token));
00986
00987 if (ATI_INTERFACE_CLASS(interface_idx) ==
00988 Generic_Unknown_Interface &&
00989 ATP_PGM_UNIT(attr_idx) != Pgm_Unknown) {
00990
00991 ATI_INTERFACE_CLASS(interface_idx) =
00992 (ATP_PGM_UNIT(attr_idx) == Function) ?
00993 Generic_Function_Interface:
00994 Generic_Subroutine_Interface;
00995 }
00996 }
00997 else if (ATP_SCP_IDX(attr_idx) == curr_scp_idx) {
00998
00999 if (AT_USE_ASSOCIATED(new_attr_idx) &&
01000 AT_PRIVATE(new_attr_idx)) {
01001
01002
01003
01004
01005
01006 }
01007 else if (AT_IS_INTRIN(new_attr_idx)) {
01008
01009
01010 }
01011 else if (!AT_DCL_ERR(attr_idx)) {
01012 PRINTMSG(TOKEN_LINE(token), 671, Error,
01013 TOKEN_COLUMN(token),
01014 AT_OBJ_NAME_PTR(attr_idx),
01015 AT_OBJ_NAME_PTR(interface_idx));
01016 AT_DCL_ERR(attr_idx) = TRUE;
01017
01018
01019 }
01020
01021
01022 NTR_INTERFACE_IN_SN_TBL(sn_idx,
01023 attr_idx,
01024 interface_idx,
01025 TOKEN_LINE(token),
01026 TOKEN_COLUMN(token));
01027 }
01028 else {
01029 NTR_INTERFACE_IN_SN_TBL(sn_idx,
01030 attr_idx,
01031 interface_idx,
01032 TOKEN_LINE(token),
01033 TOKEN_COLUMN(token));
01034 }
01035 }
01036
01037 if (LA_CH_VALUE != COMMA && LA_CH_VALUE != EOS) {
01038 parse_err_flush(Find_Comma, ", or " EOS_STR);
01039 }
01040 }
01041 else {
01042 parse_err_flush(Find_Comma, "procedure-name");
01043 }
01044
01045 found_comma = (LA_CH_VALUE == COMMA);
01046 NEXT_LA_CH;
01047 }
01048 while (found_comma);
01049 }
01050 else {
01051
01052 if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
01053 parse_err_flush(Find_EOS, "module-name");
01054 token = main_token;
01055 TOKEN_LINE(token) = stmt_start_line;
01056 TOKEN_COLUMN(token) = stmt_start_col;
01057 parse_error = TRUE;
01058 }
01059 else {
01060 parse_error = FALSE;
01061 }
01062
01063 if (cif_flags & MISC_RECS) {
01064 cif_stmt_type_rec(TRUE, CIF_Module_Stmt, stmt_number);
01065 }
01066
01067 SB_MODULE(SCP_SB_STATIC_IDX(curr_scp_idx)) = TRUE;
01068 SB_BLK_TYPE(SCP_SB_STATIC_IDX(curr_scp_idx)) = Static;
01069 SB_RUNTIME_INIT(SCP_SB_STATIC_IDX(curr_scp_idx)) = FALSE;
01070
01071 # if defined(_SPLIT_STATIC_STORAGE_M)
01072
01073
01074
01075
01076 CREATE_ID(name, sb_name[Data_Init_Blk], sb_len[Data_Init_Blk]);
01077 new_idx = ntr_stor_blk_tbl(name.string,
01078 sb_len[Data_Init_Blk],
01079 stmt_start_line,
01080 stmt_start_col,
01081 Static);
01082
01083 SCP_SB_STATIC_INIT_IDX(curr_scp_idx) = new_idx;
01084 SB_PAD_BLK(new_idx) = cmd_line_flags.pad;
01085 SB_MODULE(new_idx) = TRUE;
01086
01087 if (cmd_line_flags.pad_amount != 0) {
01088 SB_PAD_AMOUNT(new_idx) = cmd_line_flags.pad_amount;
01089 SB_PAD_AMOUNT_SET(new_idx) = TRUE;
01090 }
01091
01092 # elif defined(_SPLIT_STATIC_STORAGE_2)
01093
01094
01095
01096 SB_MODULE(SCP_SB_STATIC_INIT_IDX(curr_scp_idx)) = TRUE;
01097
01098 # elif defined(_SPLIT_STATIC_STORAGE_3)
01099
01100
01101
01102
01103
01104
01105
01106 SCP_SB_STATIC_INIT_IDX(curr_scp_idx) = SCP_SB_STATIC_IDX(curr_scp_idx);
01107 SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx) = SCP_SB_STATIC_IDX(curr_scp_idx);
01108 # else
01109
01110
01111
01112
01113
01114
01115
01116 SCP_SB_STATIC_INIT_IDX(curr_scp_idx) = SCP_SB_STATIC_IDX(curr_scp_idx);
01117 # endif
01118
01119 defer_msg = 0;
01120 attr_idx = start_new_prog_unit(Module,
01121 Module_Blk,
01122 FALSE,
01123 parse_error,
01124 &defer_msg);
01125
01126 name_idx = check_global_pgm_unit(attr_idx);
01127 ATP_MODULE_STR_IDX(attr_idx) = GN_NAME_IDX(name_idx);
01128
01129 CURR_BLK_NO_EXEC = TRUE;
01130
01131 # if defined(_MODULE_TO_DOT_o)
01132
01133 if (!cmd_line_flags.binary_output) {
01134 PRINTMSG(TOKEN_LINE(token), 301, Warning, TOKEN_COLUMN(token),
01135 AT_OBJ_NAME_PTR(attr_idx));
01136 }
01137 # endif
01138
01139 if (LA_CH_VALUE != EOS) {
01140 parse_err_flush(Find_EOS, EOS_STR);
01141 }
01142
01143 NEXT_LA_CH;
01144 }
01145
01146 TRACE (Func_Exit, "parse_module_stmt", NULL);
01147
01148 return;
01149
01150 }
01151
01152
01153
01154
01155
01156
01157
01158
01159
01160
01161
01162
01163
01164
01165
01166
01167
01168 void parse_program_stmt (void)
01169
01170 {
01171 int defer_msg = 0;
01172 boolean err_fnd;
01173
01174
01175 TRACE (Func_Entry, "parse_program_stmt", NULL);
01176
01177 if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
01178 parse_err_flush(Find_EOS, "program-name");
01179 token = main_token;
01180 TOKEN_LINE(token) = stmt_start_line;
01181 TOKEN_COLUMN(token) = stmt_start_col;
01182 err_fnd = TRUE;
01183 }
01184 else {
01185 err_fnd = FALSE;
01186 }
01187
01188 start_new_prog_unit(Program,
01189 Program_Blk,
01190 FALSE,
01191 err_fnd,
01192 &defer_msg);
01193
01194 if (LA_CH_VALUE == LPAREN) {
01195
01196 if (MATCHED_TOKEN_CLASS(Tok_Class_Program_Str)) {
01197
01198
01199
01200
01201
01202 PRINTMSG(TOKEN_LINE(token), 31, Ansi, TOKEN_COLUMN(token));
01203 }
01204 else {
01205 parse_err_flush(Find_EOS, NULL);
01206 }
01207 }
01208
01209 if (LA_CH_VALUE != EOS) {
01210 parse_err_flush(Find_EOS, EOS_STR);
01211 }
01212
01213 NEXT_LA_CH;
01214
01215 TRACE (Func_Exit, "parse_program_stmt", NULL);
01216
01217 return;
01218
01219 }
01220
01221
01222
01223
01224
01225
01226
01227
01228
01229
01230
01231
01232
01233
01234
01235
01236
01237 void parse_elemental_stmt (void)
01238 {
01239 TRACE (Func_Entry, "parse_elemental_stmt", NULL);
01240
01241 CLEAR_ATTR_NTRY(AT_WORK_IDX);
01242 AT_OBJ_CLASS(AT_WORK_IDX) = Pgm_Unit;
01243 ATP_ELEMENTAL(AT_WORK_IDX) = TRUE;
01244 parse_prefix_spec();
01245
01246 TRACE (Func_Exit, "parse_elemental_stmt", NULL);
01247
01248 return;
01249
01250 }
01251
01252
01253
01254
01255
01256
01257
01258
01259
01260
01261
01262
01263
01264
01265
01266
01267
01268 void parse_pure_stmt (void)
01269
01270 {
01271 TRACE (Func_Entry, "parse_pure_stmt", NULL);
01272
01273 CLEAR_ATTR_NTRY(AT_WORK_IDX);
01274 AT_OBJ_CLASS(AT_WORK_IDX) = Pgm_Unit;
01275 ATP_PURE(AT_WORK_IDX) = TRUE;
01276 parse_prefix_spec();
01277
01278 TRACE (Func_Exit, "parse_pure_stmt", NULL);
01279
01280 return;
01281
01282 }
01283
01284
01285
01286
01287
01288
01289
01290
01291
01292
01293
01294
01295
01296
01297
01298
01299
01300 void parse_recursive_stmt (void)
01301 {
01302 TRACE (Func_Entry, "parse_recursive_stmt", NULL);
01303
01304 CLEAR_ATTR_NTRY(AT_WORK_IDX);
01305 AT_OBJ_CLASS(AT_WORK_IDX) = Pgm_Unit;
01306 ATP_RECURSIVE(AT_WORK_IDX) = TRUE;
01307 parse_prefix_spec();
01308
01309 TRACE (Func_Exit, "parse_recursive_stmt", NULL);
01310
01311 return;
01312
01313 }
01314
01315
01316
01317
01318
01319
01320
01321
01322
01323
01324
01325
01326
01327
01328
01329
01330
01331 static void parse_prefix_spec (void)
01332
01333 {
01334 int attr_idx;
01335 blk_cntxt_type blk_type;
01336 int defer_msg;
01337 boolean elemental_set;
01338 boolean matched;
01339 pgm_unit_type pgm_type;
01340 boolean pure_set;
01341 boolean recursive_set;
01342
01343
01344 TRACE (Func_Entry, "parse_prefix_spec", NULL);
01345
01346 while (matched = MATCHED_TOKEN_CLASS(Tok_Class_Keyword)) {
01347
01348 switch (TOKEN_VALUE(token)) {
01349 case Tok_Kwd_Recursive:
01350
01351 if (ATP_ELEMENTAL(AT_WORK_IDX)) {
01352
01353
01354
01355 PRINTMSG(TOKEN_LINE(token), 1261, Error, TOKEN_COLUMN(token));
01356 AT_DCL_ERR(AT_WORK_IDX) = TRUE;
01357 }
01358 else if (ATP_RECURSIVE(AT_WORK_IDX)) {
01359 PRINTMSG(TOKEN_LINE(token), 1260, Error, TOKEN_COLUMN(token),
01360 "RECURSIVE");
01361 AT_DCL_ERR(AT_WORK_IDX) = TRUE;
01362 }
01363 else {
01364 ATP_RECURSIVE(AT_WORK_IDX) = TRUE;
01365 }
01366 continue;
01367
01368 case Tok_Kwd_Elemental:
01369
01370 if (ATP_RECURSIVE(AT_WORK_IDX)) {
01371
01372
01373
01374 PRINTMSG(TOKEN_LINE(token), 1261, Error, TOKEN_COLUMN(token));
01375 AT_DCL_ERR(AT_WORK_IDX) = TRUE;
01376 }
01377 else if (ATP_ELEMENTAL(AT_WORK_IDX)) {
01378 PRINTMSG(TOKEN_LINE(token), 1260, Error, TOKEN_COLUMN(token),
01379 "ELEMENTAL");
01380 AT_DCL_ERR(AT_WORK_IDX) = TRUE;
01381 }
01382 else {
01383 ATP_ELEMENTAL(AT_WORK_IDX) = TRUE;
01384 }
01385 continue;
01386
01387 case Tok_Kwd_Pure:
01388
01389 if (ATP_PURE(AT_WORK_IDX)) {
01390 PRINTMSG(TOKEN_LINE(token), 1260, Error, TOKEN_COLUMN(token),
01391 "PURE");
01392 AT_DCL_ERR(AT_WORK_IDX) = TRUE;
01393 }
01394 ATP_PURE(AT_WORK_IDX) = TRUE;
01395 continue;
01396
01397 case Tok_Kwd_Logical:
01398 case Tok_Kwd_Integer:
01399 case Tok_Kwd_Double:
01400 case Tok_Kwd_Real:
01401 case Tok_Kwd_Complex:
01402 case Tok_Kwd_Character:
01403 case Tok_Kwd_Type:
01404 parse_typed_function_stmt();
01405 goto EXIT;
01406
01407 default:
01408 break;
01409 }
01410 break;
01411 }
01412
01413 recursive_set = ATP_RECURSIVE(AT_WORK_IDX);
01414 elemental_set = ATP_ELEMENTAL(AT_WORK_IDX);
01415 pure_set = ATP_PURE(AT_WORK_IDX);
01416
01417 if (TOKEN_VALUE(token) == Tok_Kwd_Subroutine ||
01418 TOKEN_VALUE(token) == Tok_Kwd_CoSubroutine) {
01419 stmt_type = Subroutine_Stmt;
01420 SH_STMT_TYPE(curr_stmt_sh_idx) = Subroutine_Stmt;
01421 parse_subroutine_stmt();
01422 ATP_RECURSIVE(SCP_ATTR_IDX(curr_scp_idx)) = recursive_set;
01423 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx)) = elemental_set;
01424 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) = pure_set;
01425 }
01426 else if (TOKEN_VALUE(token) == Tok_Kwd_Function ||
01427 TOKEN_VALUE(token) == Tok_Kwd_CoFunction) {
01428 stmt_type = Function_Stmt;
01429 SH_STMT_TYPE(curr_stmt_sh_idx) = Function_Stmt;
01430 parse_function_stmt();
01431 ATP_RECURSIVE(SCP_ATTR_IDX(curr_scp_idx)) = recursive_set;
01432 ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx)) = elemental_set;
01433 ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) = pure_set;
01434 }
01435 else if (curr_stmt_category > Sub_Func_Stmt_Cat) {
01436 iss_blk_stk_err();
01437 parse_err_flush(Find_EOS, NULL);
01438 NEXT_LA_CH;
01439 }
01440 else {
01441
01442
01443
01444
01445 if (matched) {
01446 reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
01447 }
01448
01449 parse_err_flush(Find_Lparen, "FUNCTION, SUBROUTINE, INTEGER, "
01450 "LOGICAL, DOUBLE PRECISION, REAL, COMPLEX, CHARACTER or TYPE");
01451
01452 token = main_token;
01453 TOKEN_LINE(token) = stmt_start_line;
01454 TOKEN_COLUMN(token) = stmt_start_col;
01455 pgm_type = Subroutine;
01456 blk_type = Subroutine_Blk;
01457
01458 if (curr_stmt_category == Init_Stmt_Cat) {
01459 defer_msg = 0;
01460 attr_idx = start_new_prog_unit(pgm_type,
01461 blk_type,
01462 FALSE,
01463 TRUE,
01464 &defer_msg);
01465 ATP_PROC(attr_idx) = Extern_Proc;
01466 }
01467 else {
01468
01469
01470
01471 start_new_scp();
01472 curr_scp_idx = SCP_PARENT_IDX(curr_scp_idx);
01473 attr_idx = start_new_subpgm(pgm_type, TRUE, FALSE);
01474 }
01475
01476 CURR_BLK_ERR = TRUE;
01477 SCP_IN_ERR(curr_scp_idx) = TRUE;
01478 ATP_RECURSIVE(attr_idx) = recursive_set;
01479 ATP_ELEMENTAL(attr_idx) = elemental_set;
01480 ATP_PURE(attr_idx) = pure_set;
01481
01482 if (CURR_BLK != Interface_Body_Blk &&
01483 (cmd_line_flags.runtime_argument ||
01484 cmd_line_flags.runtime_arg_entry)) {
01485
01486 ATP_ARGCHCK_ENTRY(attr_idx) = TRUE;
01487 }
01488
01489 if (LA_CH_VALUE == LPAREN) {
01490 parse_dummy_args(attr_idx);
01491 }
01492
01493 if (LA_CH_VALUE == 'R') {
01494
01495
01496
01497
01498 ATP_PGM_UNIT(attr_idx) = Function;
01499
01500 if (CURR_BLK == Subroutine_Blk) {
01501 CURR_BLK = Function_Blk;
01502 }
01503 set_function_rslt(attr_idx, FALSE);
01504 }
01505
01506 if (LA_CH_VALUE != EOS) {
01507 parse_err_flush(Find_EOS, EOS_STR);
01508 }
01509
01510 NEXT_LA_CH;
01511 }
01512
01513 EXIT:
01514
01515 TRACE (Func_Exit, "parse_prefix_spec", NULL);
01516
01517 return;
01518
01519 }
01520
01521
01522
01523
01524
01525
01526
01527
01528
01529
01530
01531
01532
01533
01534
01535
01536
01537
01538
01539 void parse_subroutine_stmt (void)
01540
01541 {
01542 int attr_idx;
01543 int defer_msg;
01544 boolean err_fnd = FALSE;
01545 boolean is_coarray_concurrent = FALSE;
01546
01547
01548
01549 TRACE (Func_Entry, "parse_subroutine_stmt", NULL);
01550
01551 if (curr_stmt_category > Sub_Func_Stmt_Cat) {
01552 iss_blk_stk_err();
01553 err_fnd = TRUE;
01554 }
01555
01556
01557 if (strncmp(token.token_str.string,"COSUBROUTI",10)==0)
01558 is_coarray_concurrent = TRUE;
01559
01560
01561 if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
01562 parse_err_flush(Find_Lparen, "subroutine-name");
01563 token = main_token;
01564 TOKEN_LINE(token) = stmt_start_line;
01565 TOKEN_COLUMN(token) = stmt_start_col;
01566 err_fnd = TRUE;
01567 }
01568
01569 if (curr_stmt_category == Init_Stmt_Cat) {
01570 defer_msg = 0;
01571 attr_idx = start_new_prog_unit(Subroutine,
01572 Subroutine_Blk,
01573 FALSE,
01574 err_fnd,
01575 &defer_msg);
01576 ATP_PROC(attr_idx) = Extern_Proc;
01577 }
01578 else {
01579
01580
01581
01582
01583
01584
01585
01586
01587
01588 start_new_scp();
01589 curr_scp_idx = SCP_PARENT_IDX(curr_scp_idx);
01590 attr_idx = start_new_subpgm(Subroutine, err_fnd, TRUE);
01591 }
01592
01593 SCP_IN_ERR(curr_scp_idx) = AT_DCL_ERR(attr_idx);
01594
01595 if (CURR_BLK != Interface_Body_Blk &&
01596 (cmd_line_flags.runtime_argument ||
01597 cmd_line_flags.runtime_arg_entry)) {
01598
01599 ATP_ARGCHCK_ENTRY(attr_idx) = TRUE;
01600 }
01601
01602 if (LA_CH_VALUE == LPAREN) {
01603 parse_dummy_args(attr_idx);
01604 }
01605
01606 if (LA_CH_VALUE != EOS) {
01607 parse_err_flush(Find_EOS, EOS_STR);
01608 }
01609
01610 if (is_coarray_concurrent)
01611 ATP_COARRAY_CONCURRENT(attr_idx)=TRUE;
01612
01613 NEXT_LA_CH;
01614
01615 TRACE (Func_Exit, "parse_subroutine_stmt", NULL);
01616
01617 return;
01618
01619 }
01620
01621
01622
01623
01624
01625
01626
01627
01628
01629
01630
01631
01632
01633
01634
01635
01636
01637 static void set_function_rslt(int attr_idx,
01638 boolean type_err)
01639
01640 {
01641 boolean err_found = FALSE;
01642 int func_rslt_idx;
01643 int name_idx;
01644 int rslt_idx = NULL_IDX;
01645 token_type save_token;
01646
01647
01648 TRACE (Func_Entry, "set_function_rslt", NULL);
01649
01650 if (LA_CH_VALUE != EOS) {
01651
01652 if (!matched_specific_token(Tok_Kwd_Result, Tok_Class_Keyword)) {
01653 parse_err_flush(Find_EOS, "RESULT or " EOS_STR);
01654 err_found = TRUE;
01655 }
01656 else if (LA_CH_VALUE != LPAREN) {
01657 parse_err_flush(Find_EOS, "(");
01658 err_found = TRUE;
01659 }
01660 else {
01661 NEXT_LA_CH;
01662
01663 if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
01664 parse_err_flush(Find_EOS, "result-name");
01665 err_found = TRUE;
01666 }
01667 else {
01668
01669 if (LA_CH_VALUE == RPAREN) {
01670 NEXT_LA_CH;
01671 }
01672 else {
01673 save_token = token;
01674 parse_err_flush(Find_EOS, ")");
01675 err_found = TRUE;
01676 token = save_token;
01677 }
01678
01679 rslt_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token),
01680 &name_idx);
01681
01682 if (rslt_idx == NULL_IDX) {
01683 rslt_idx = ntr_sym_tbl(&token, name_idx);
01684 LN_DEF_LOC(name_idx) = TRUE;
01685 AT_OBJ_CLASS(rslt_idx) = Data_Obj;
01686 }
01687 else if (!ATP_ALT_ENTRY(attr_idx)) {
01688
01689
01690
01691 PRINTMSG(TOKEN_LINE(token), 1471, Error, TOKEN_COLUMN(token),
01692 AT_OBJ_NAME_PTR(rslt_idx));
01693 CREATE_ERR_ATTR(rslt_idx,
01694 TOKEN_LINE(token),
01695 TOKEN_COLUMN(token),
01696 Data_Obj);
01697 }
01698 else if (fnd_semantic_err(Obj_Ntry_Func_Result,
01699 TOKEN_LINE(token),
01700 TOKEN_COLUMN(token),
01701 rslt_idx,
01702 TRUE)) {
01703 CREATE_ERR_ATTR(rslt_idx,
01704 TOKEN_LINE(token),
01705 TOKEN_COLUMN(token),
01706 Data_Obj);
01707 }
01708 else if (AT_REFERENCED(rslt_idx) == Char_Rslt_Bound_Ref) {
01709 AT_ATTR_LINK(rslt_idx) = NULL_IDX;
01710 LN_DEF_LOC(name_idx) = TRUE;
01711 }
01712
01713 if ((cif_flags & XREF_RECS) != 0) {
01714 cif_usage_rec(rslt_idx,
01715 AT_Tbl_Idx,
01716 TOKEN_LINE(token),
01717 TOKEN_COLUMN(token),
01718 CIF_Symbol_Declaration);
01719 }
01720
01721 ATD_CLASS(rslt_idx) = Function_Result;
01722 ATP_RSLT_NAME(attr_idx) = TRUE;
01723 }
01724 }
01725 }
01726
01727 func_rslt_idx = ATP_RSLT_IDX(attr_idx);
01728
01729 if (rslt_idx == NULL_IDX) {
01730
01731 if (func_rslt_idx == NULL_IDX) {
01732 NTR_ATTR_TBL(rslt_idx);
01733 COPY_COMMON_ATTR_INFO(attr_idx, rslt_idx, Data_Obj);
01734 ATD_CLASS(rslt_idx) = Function_Result;
01735 }
01736 else {
01737 rslt_idx = func_rslt_idx;
01738 }
01739 }
01740 else if (func_rslt_idx != NULL_IDX) {
01741
01742
01743
01744
01745
01746
01747
01748
01749
01750
01751 if (ATD_ARRAY_IDX(func_rslt_idx) != NULL_IDX) {
01752 err_found = TRUE;
01753 PRINTMSG(TOKEN_LINE(token), 27, Error, TOKEN_COLUMN(token),
01754 AT_OBJ_NAME_PTR(attr_idx), AT_OBJ_NAME_PTR(rslt_idx));
01755
01756 if (ATD_ARRAY_IDX(rslt_idx) == NULL_IDX) {
01757 ATD_ARRAY_IDX(rslt_idx) = ATD_ARRAY_IDX(func_rslt_idx);
01758 }
01759 }
01760
01761 if (ATD_POINTER(func_rslt_idx)) {
01762 err_found = TRUE;
01763 PRINTMSG(TOKEN_LINE(token), 36, Error, TOKEN_COLUMN(token),
01764 AT_OBJ_NAME_PTR(attr_idx), AT_OBJ_NAME_PTR(rslt_idx));
01765
01766 if (!ATD_POINTER(rslt_idx)) {
01767 ATD_POINTER(rslt_idx) = TRUE;
01768 }
01769 }
01770
01771 if (ATD_TARGET(func_rslt_idx)) {
01772 err_found = TRUE;
01773 PRINTMSG(TOKEN_LINE(token), 132, Error, TOKEN_COLUMN(token),
01774 AT_OBJ_NAME_PTR(attr_idx), AT_OBJ_NAME_PTR(rslt_idx));
01775
01776 if (!ATD_TARGET(rslt_idx)) {
01777 ATD_TARGET(rslt_idx) = TRUE;
01778 }
01779 }
01780
01781 if (AT_TYPED(func_rslt_idx)) {
01782 err_found = TRUE;
01783 PRINTMSG(TOKEN_LINE(token), 185, Error, TOKEN_COLUMN(token),
01784 AT_OBJ_NAME_PTR(attr_idx), AT_OBJ_NAME_PTR(rslt_idx));
01785
01786 if (!AT_TYPED(rslt_idx)) {
01787 ATD_TYPE_IDX(rslt_idx) = ATD_TYPE_IDX(func_rslt_idx);
01788 AT_TYPED(rslt_idx) = AT_TYPED(func_rslt_idx);
01789 }
01790 }
01791 AT_ACCESS_SET(rslt_idx) = AT_ACCESS_SET(func_rslt_idx);
01792 AT_PRIVATE(rslt_idx) = AT_PRIVATE(func_rslt_idx);
01793
01794
01795
01796
01797 CLEAR_ATTR_NTRY(func_rslt_idx);
01798 AT_DCL_ERR(func_rslt_idx) = TRUE;
01799 }
01800
01801 if (!AT_TYPED(rslt_idx) || type_err) {
01802
01803 if (!AT_DCL_ERR(rslt_idx)) {
01804 SET_IMPL_TYPE(rslt_idx);
01805 }
01806 else if (ATD_TYPE_IDX(rslt_idx) == NULL_IDX) {
01807 ATD_TYPE_IDX(rslt_idx) = TYPELESS_DEFAULT_TYPE;
01808 }
01809 }
01810
01811 ATP_RSLT_IDX(attr_idx) = rslt_idx;
01812 ATD_FUNC_IDX(rslt_idx) = attr_idx;
01813 AT_DCL_ERR(rslt_idx) = err_found || AT_DCL_ERR(rslt_idx);
01814 AT_DCL_ERR(attr_idx) = AT_DCL_ERR(attr_idx) || AT_DCL_ERR(rslt_idx);
01815
01816 TRACE (Func_Exit, "set_function_rslt", NULL);
01817
01818 return;
01819
01820 }
01821
01822
01823
01824
01825
01826
01827
01828
01829
01830
01831
01832
01833
01834
01835
01836
01837 static void parse_dummy_args(int pgm_attr_idx)
01838 {
01839 int attr_idx;
01840 boolean found_end = FALSE;
01841 int list_idx;
01842 int name_idx;
01843 int sn_idx;
01844 int sn_attr_idx;
01845
01846
01847 TRACE (Func_Entry, "parse_dummy_args", NULL);
01848
01849 # ifdef _DEBUG
01850 if (LA_CH_VALUE != LPAREN) {
01851 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token),
01852 "parse_dummy_args", "LPAREN");
01853 }
01854 # endif
01855
01856 NEXT_LA_CH;
01857
01858 if (LA_CH_VALUE == RPAREN) {
01859 NEXT_LA_CH;
01860 return;
01861 }
01862
01863
01864
01865
01866
01867 NTR_SN_TBL(sn_attr_idx);
01868
01869 do {
01870 if (MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
01871 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx);
01872
01873 if (attr_idx == NULL_IDX) {
01874 attr_idx = ntr_sym_tbl(&token, name_idx);
01875 LN_DEF_LOC(name_idx) = TRUE;
01876 AT_OBJ_CLASS(attr_idx) = Data_Obj;
01877 ATD_CLASS(attr_idx) = Dummy_Argument;
01878 SET_IMPL_TYPE(attr_idx);
01879 AT_IS_DARG(attr_idx) = TRUE;
01880 AT_DCL_ERR(attr_idx) = AT_DCL_ERR(pgm_attr_idx);
01881
01882
01883
01884 NTR_ATTR_LIST_TBL(list_idx);
01885 AL_NEXT_IDX(list_idx) = SCP_DARG_LIST(curr_scp_idx);
01886 AL_ATTR_IDX(list_idx) = attr_idx;
01887 SCP_DARG_LIST(curr_scp_idx) = list_idx;
01888 }
01889 else if (!fnd_semantic_err(Obj_Dummy_Arg,
01890 TOKEN_LINE(token),
01891 TOKEN_COLUMN(token),
01892 attr_idx,
01893 TRUE)) {
01894
01895 AT_DCL_ERR(attr_idx) = AT_DCL_ERR(pgm_attr_idx);
01896
01897 if (AT_REFERENCED(attr_idx) == Char_Rslt_Bound_Ref) {
01898 AT_ATTR_LINK(attr_idx) = NULL_IDX;
01899 LN_DEF_LOC(name_idx) = TRUE;
01900 CLEAR_VARIANT_ATTR_INFO(attr_idx, Data_Obj);
01901 ATD_CLASS(attr_idx) = Dummy_Argument;
01902 SET_IMPL_TYPE(attr_idx);
01903 }
01904 else if ((AT_REFERENCED(attr_idx) == Referenced ||
01905 AT_DEFINED(attr_idx)) && !AT_IS_DARG(attr_idx)) {
01906
01907
01908
01909
01910
01911 PRINTMSG(TOKEN_LINE(token), 529, Error, TOKEN_COLUMN(token),
01912 AT_OBJ_NAME_PTR(attr_idx));
01913 }
01914
01915 if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {
01916
01917 if (ATP_PROC(attr_idx) != Dummy_Proc) {
01918 ATP_PROC(attr_idx) = Dummy_Proc;
01919 }
01920 }
01921 else if (ATD_CLASS(attr_idx) != Dummy_Argument) {
01922 ATD_CLASS(attr_idx) = Dummy_Argument;
01923 }
01924
01925
01926
01927 if (!AT_IS_DARG(attr_idx)) {
01928 NTR_ATTR_LIST_TBL(list_idx);
01929 AL_NEXT_IDX(list_idx) = SCP_DARG_LIST(curr_scp_idx);
01930 AL_ATTR_IDX(list_idx) = attr_idx;
01931 SCP_DARG_LIST(curr_scp_idx) = list_idx;
01932 }
01933 AT_IS_DARG(attr_idx) = TRUE;
01934 }
01935
01936 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
01937 ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) = TRUE;
01938 }
01939
01940
01941 if ((cif_flags & XREF_RECS) != 0) {
01942 cif_usage_rec(attr_idx,
01943 AT_Tbl_Idx,
01944 TOKEN_LINE(token),
01945 TOKEN_COLUMN(token),
01946 CIF_Symbol_Is_Dummy_Arg);
01947 }
01948
01949
01950
01951 sn_attr_idx = srch_kwd_name(TOKEN_STR(token), TOKEN_LEN(token),
01952 pgm_attr_idx, &sn_idx);
01953
01954 if (sn_attr_idx != NULL_IDX) {
01955 PRINTMSG(TOKEN_LINE(token), 10, Error, TOKEN_COLUMN(token),
01956 TOKEN_STR(token));
01957 }
01958 else {
01959 NTR_SN_TBL(sn_idx);
01960 SN_ATTR_IDX(sn_idx) = attr_idx;
01961 SN_NAME_LEN(sn_idx) = AT_NAME_LEN(attr_idx);
01962 SN_NAME_IDX(sn_idx) = AT_NAME_IDX(attr_idx);
01963 SN_LINE_NUM(sn_idx) = TOKEN_LINE(token);
01964 SN_COLUMN_NUM(sn_idx) = TOKEN_COLUMN(token);
01965
01966 if (ATP_FIRST_IDX(pgm_attr_idx) == NULL_IDX) {
01967 ATP_FIRST_IDX(pgm_attr_idx) = sn_idx;
01968 }
01969 ATP_NUM_DARGS(pgm_attr_idx) += 1;
01970 }
01971 }
01972 else if (LA_CH_VALUE == STAR &&
01973 ATP_PGM_UNIT(pgm_attr_idx) == Subroutine) {
01974
01975
01976
01977
01978 attr_idx = gen_compiler_tmp(LA_CH_LINE, LA_CH_COLUMN, Shared, TRUE);
01979
01980 NEXT_LA_CH;
01981
01982
01983 AT_REFERENCED(attr_idx) = Referenced;
01984 AT_DEFINED(attr_idx) = TRUE;
01985 AT_SEMANTICS_DONE(attr_idx) = TRUE;
01986 ATD_TYPE_IDX(attr_idx) = INTEGER_DEFAULT_TYPE;
01987 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_DARG_IDX(curr_scp_idx);
01988 ATD_CLASS(attr_idx) = Dummy_Argument;
01989 AT_IS_DARG(attr_idx) = TRUE;
01990 ATP_HAS_ALT_RETURN(pgm_attr_idx) = TRUE;
01991 ATP_HAS_ALT_RETURN(SCP_ATTR_IDX(curr_scp_idx)) = TRUE;
01992
01993 NTR_SN_TBL(sn_attr_idx);
01994 SN_ATTR_IDX(sn_attr_idx) = attr_idx;
01995 SN_NAME_IDX(sn_attr_idx) = AT_NAME_IDX(attr_idx);
01996 SN_LINE_NUM(sn_attr_idx) = LA_CH_LINE;
01997 SN_COLUMN_NUM(sn_attr_idx) = LA_CH_COLUMN;
01998
01999 if (ATP_FIRST_IDX(pgm_attr_idx) == NULL_IDX) {
02000 ATP_FIRST_IDX(pgm_attr_idx) = sn_attr_idx;
02001 }
02002 ATP_NUM_DARGS(pgm_attr_idx) +=1;
02003 }
02004 else {
02005 parse_err_flush(Find_Comma_Rparen, "dummy-arg-name");
02006 found_end = (LA_CH_VALUE == EOS);
02007 }
02008
02009 if (LA_CH_VALUE != RPAREN && LA_CH_VALUE != COMMA && !found_end) {
02010 parse_err_flush(Find_Comma_Rparen, ", or )");
02011 }
02012
02013 if (LA_CH_VALUE == COMMA) {
02014 NEXT_LA_CH;
02015 }
02016 else {
02017 found_end = TRUE;
02018 }
02019 }
02020 while (!found_end);
02021
02022
02023
02024
02025
02026 if (ATP_NUM_DARGS(pgm_attr_idx) > max_call_list_size) {
02027 max_call_list_size = (long) ATP_NUM_DARGS(pgm_attr_idx);
02028 }
02029
02030 if (LA_CH_VALUE == RPAREN) {
02031 NEXT_LA_CH;
02032 }
02033
02034 TRACE (Func_Exit, "parse_dummy_args", NULL);
02035
02036 return;
02037
02038 }
02039
02040
02041
02042
02043
02044
02045
02046
02047
02048
02049
02050
02051
02052
02053
02054
02055
02056
02057
02058
02059
02060
02061
02062 static int start_new_subpgm(pgm_unit_type pgm_type,
02063 boolean has_error,
02064 boolean save_idxs)
02065
02066 {
02067 int attr_idx;
02068 int host_name_idx;
02069 int interface_idx = NULL_IDX;
02070 int ir_idx;
02071 int length;
02072 int loc_name_idx;
02073 int name_idx;
02074 atp_proc_type proc_type;
02075 int sb_idx;
02076 int sn_idx;
02077 int tmp_attr_idx;
02078 obj_type type_of_obj;
02079
02080
02081 TRACE (Func_Entry, "start_new_subpgm", NULL);
02082
02083 if (CURR_BLK == Interface_Blk) {
02084 interface_idx = CURR_BLK_NAME;
02085
02086 if (interface_idx) {
02087
02088 if (ATI_INTERFACE_CLASS(interface_idx) == Generic_Unknown_Interface) {
02089 ATI_INTERFACE_CLASS(interface_idx) = (pgm_type == Function) ?
02090 Generic_Function_Interface :
02091 Generic_Subroutine_Interface;
02092 }
02093 }
02094 else {
02095 interface_idx = BLK_UNNAMED_INTERFACE(blk_stk_idx);
02096 }
02097
02098 ATI_HAS_NON_MOD_PROC(interface_idx) = TRUE;
02099
02100
02101
02102
02103 if (save_idxs && BLK_AT_IDX(blk_stk_idx) == NULL_IDX) {
02104 BLK_AT_IDX(blk_stk_idx) = attr_tbl_idx;
02105 BLK_BD_IDX(blk_stk_idx) = bounds_tbl_idx;
02106 BLK_CN_IDX(blk_stk_idx) = const_tbl_idx;
02107 BLK_CP_IDX(blk_stk_idx) = const_pool_idx;
02108 BLK_NP_IDX(blk_stk_idx) = name_pool_idx;
02109 BLK_SB_IDX(blk_stk_idx) = stor_blk_tbl_idx;
02110 BLK_SN_IDX(blk_stk_idx) = sec_name_tbl_idx;
02111 BLK_TYP_IDX(blk_stk_idx) = type_tbl_idx;
02112 }
02113
02114 PUSH_BLK_STK(Interface_Body_Blk);
02115 CURR_BLK_NO_EXEC = TRUE;
02116 proc_type = Extern_Proc;
02117 type_of_obj = (pgm_type == Function) ? Obj_Interface_Func :
02118 Obj_Interface_Subr;
02119 }
02120 else if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) {
02121
02122
02123
02124
02125 PUSH_BLK_STK(Module_Proc_Blk);
02126 type_of_obj = (pgm_type == Function) ? Obj_Module_Func :
02127 Obj_Module_Subr;
02128 # ifdef SOURCE_TO_SOURCE
02129 proc_type = Intern_Proc;
02130 # else
02131 proc_type = Module_Proc;
02132 #endif
02133
02134
02135 }
02136 else {
02137 PUSH_BLK_STK(Internal_Blk);
02138 proc_type = Intern_Proc;
02139 type_of_obj = (pgm_type == Function) ? Obj_Intern_Func :
02140 Obj_Intern_Subr;
02141 }
02142
02143
02144
02145 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx);
02146
02147 if (CURR_BLK == Interface_Body_Blk) {
02148
02149
02150
02151
02152
02153
02154
02155
02156 if (SCP_LEVEL(curr_scp_idx) == 1 &&
02157 (attr_idx == NULL_IDX || AT_OBJ_CLASS(attr_idx) == Interface)) {
02158
02159 attr_idx = srch_host_sym_tbl(TOKEN_STR(token),
02160 TOKEN_LEN(token),
02161 &host_name_idx,
02162 TRUE);
02163
02164 if (attr_idx != NULL_IDX &&
02165 !SH_ERR_FLG(curr_stmt_sh_idx) &&
02166 (SCP_ATTR_IDX(SCP_PARENT_IDX(curr_scp_idx)) == attr_idx ||
02167 AT_OBJ_CLASS(attr_idx) == Pgm_Unit &&
02168 ATP_ALT_ENTRY(attr_idx)) ) {
02169
02170
02171
02172
02173
02174 curr_scp_idx = SCP_LAST_CHILD_IDX(curr_scp_idx);
02175 SCP_ATTR_IDX(curr_scp_idx) = attr_idx;
02176 PRINTMSG(TOKEN_LINE(token), 44, Error, TOKEN_COLUMN(token),
02177 AT_OBJ_NAME_PTR(attr_idx));
02178 AT_DCL_ERR(attr_idx) = TRUE;
02179 curr_scp_idx = SCP_PARENT_IDX(curr_scp_idx);
02180 }
02181 attr_idx = NULL_IDX;
02182 }
02183 }
02184
02185 if (attr_idx == NULL_IDX) {
02186 attr_idx = ntr_sym_tbl(&token, name_idx);
02187 AT_OBJ_CLASS(attr_idx) = Pgm_Unit;
02188 LN_DEF_LOC(name_idx) = TRUE;
02189 ATP_PROC(attr_idx) = proc_type;
02190 ATP_PGM_UNIT(attr_idx) = pgm_type;
02191 }
02192 else if (AT_NOT_VISIBLE(attr_idx)) {
02193 curr_scp_idx = SCP_LAST_CHILD_IDX(curr_scp_idx);
02194 SCP_ATTR_IDX(curr_scp_idx) = attr_idx;
02195
02196 PRINTMSG(TOKEN_LINE(token), 486, Error,
02197 TOKEN_COLUMN(token),
02198 AT_OBJ_NAME_PTR(attr_idx),
02199 AT_OBJ_NAME_PTR(AT_MODULE_IDX((attr_idx))));
02200
02201 CREATE_ERR_ATTR(attr_idx,
02202 TOKEN_LINE(token),
02203 TOKEN_COLUMN(token),
02204 Pgm_Unit);
02205
02206 ATP_PROC(attr_idx) = proc_type;
02207 ATP_PGM_UNIT(attr_idx) = pgm_type;
02208 AT_TYPED(attr_idx) = FALSE;
02209 curr_scp_idx = SCP_PARENT_IDX(curr_scp_idx);
02210 }
02211 else if (CURR_BLK == Interface_Body_Blk && interface_idx == attr_idx) {
02212
02213
02214
02215 NTR_ATTR_TBL(tmp_attr_idx);
02216 COPY_COMMON_ATTR_INFO(attr_idx, tmp_attr_idx, Pgm_Unit);
02217 ATI_PROC_IDX(attr_idx) = tmp_attr_idx;
02218 attr_idx = tmp_attr_idx;
02219 ATP_PROC(attr_idx) = proc_type;
02220 ATP_PGM_UNIT(attr_idx) = pgm_type;
02221 AT_DEF_LINE(attr_idx) = TOKEN_LINE(token);
02222 AT_DEF_COLUMN(attr_idx) = TOKEN_COLUMN(token);
02223 AT_IS_INTRIN(attr_idx) = FALSE;
02224 AT_ELEMENTAL_INTRIN(attr_idx) = FALSE;
02225 }
02226 else if (CURR_BLK == Interface_Body_Blk &&
02227 SCP_ATTR_IDX(curr_scp_idx) == attr_idx) {
02228
02229
02230
02231
02232 NTR_ATTR_TBL(tmp_attr_idx);
02233 COPY_COMMON_ATTR_INFO(attr_idx, tmp_attr_idx, Pgm_Unit);
02234 ATP_DUPLICATE_INTERFACE_IDX(attr_idx) = tmp_attr_idx;
02235 attr_idx = tmp_attr_idx;
02236 ATP_PROC(attr_idx) = proc_type;
02237 ATP_PGM_UNIT(attr_idx) = pgm_type;
02238 AT_DEF_LINE(attr_idx) = TOKEN_LINE(token);
02239 AT_DEF_COLUMN(attr_idx) = TOKEN_COLUMN(token);
02240 AT_IS_INTRIN(attr_idx) = FALSE;
02241 AT_ELEMENTAL_INTRIN(attr_idx) = FALSE;
02242 }
02243 else {
02244
02245 if (AT_OBJ_CLASS(attr_idx) == Interface &&
02246 ATI_PROC_IDX(attr_idx) != NULL_IDX) {
02247 attr_idx = ATI_PROC_IDX(attr_idx);
02248 }
02249
02250 if (proc_type == Intern_Proc &&
02251 AT_ATTR_LINK(attr_idx) != NULL_IDX &&
02252 AT_LOCKED_IN(attr_idx)) {
02253
02254 do {
02255 tmp_attr_idx = AT_ATTR_LINK(attr_idx);
02256 }
02257 while (AT_ATTR_LINK(tmp_attr_idx) != NULL_IDX);
02258
02259 if (AT_OBJ_CLASS(tmp_attr_idx) == Data_Obj &&
02260 ATD_CLASS(tmp_attr_idx) == Constant) {
02261
02262
02263
02264
02265 curr_scp_idx = SCP_LAST_CHILD_IDX(curr_scp_idx);
02266 SCP_ATTR_IDX(curr_scp_idx) = attr_idx;
02267
02268 PRINTMSG(TOKEN_LINE(token), 919, Error,
02269 TOKEN_COLUMN(token),
02270 AT_OBJ_NAME_PTR(attr_idx),
02271 (pgm_type == Function) ? "FUNCTION" : "SUBROUTINE");
02272 curr_scp_idx = SCP_PARENT_IDX(curr_scp_idx);
02273 }
02274 }
02275
02276 if (SH_ERR_FLG(curr_stmt_sh_idx) ||
02277 attr_idx == glb_tbl_idx[Main_Attr_Idx] ||
02278 AT_DCL_ERR(attr_idx) ||
02279 fnd_semantic_err(type_of_obj,
02280 TOKEN_LINE(token),
02281 TOKEN_COLUMN(token),
02282 attr_idx,
02283 TRUE)) {
02284
02285
02286
02287
02288
02289
02290 CREATE_ERR_ATTR(attr_idx,
02291 TOKEN_LINE(token),
02292 TOKEN_COLUMN(token),
02293 Pgm_Unit);
02294 AT_TYPED(attr_idx) = FALSE;
02295 ATP_PROC(attr_idx) = proc_type;
02296 ATP_PGM_UNIT(attr_idx) = pgm_type;
02297 }
02298 else if (CURR_BLK != Interface_Body_Blk &&
02299 proc_type == Module_Proc &&
02300 (AT_OBJ_CLASS(attr_idx) == Pgm_Unit &&
02301 ATP_PROC(attr_idx) == Module_Proc &&
02302 ATP_EXPL_ITRFC(attr_idx))) {
02303
02304
02305
02306 curr_scp_idx = SCP_LAST_CHILD_IDX(curr_scp_idx);
02307 SCP_ATTR_IDX(curr_scp_idx) = attr_idx;
02308
02309 PRINTMSG(TOKEN_LINE(token), 1529, Error,
02310 TOKEN_COLUMN(token),
02311 AT_OBJ_NAME_PTR(attr_idx));
02312 curr_scp_idx = SCP_PARENT_IDX(curr_scp_idx);
02313 }
02314 else if (AT_OBJ_CLASS(attr_idx) == Interface) {
02315
02316 if (AT_IS_INTRIN(attr_idx) && !LN_DEF_LOC(name_idx)) {
02317
02318
02319
02320
02321 CLEAR_VARIANT_ATTR_INFO(attr_idx, Pgm_Unit);
02322 AT_ATTR_LINK(attr_idx) = NULL_IDX;
02323 AT_IS_INTRIN(attr_idx) = FALSE;
02324 AT_ELEMENTAL_INTRIN(attr_idx)= FALSE;
02325 ATP_PROC(attr_idx) = proc_type;
02326 ATP_PGM_UNIT(attr_idx) = pgm_type;
02327 AT_USE_ASSOCIATED(attr_idx) = FALSE;
02328 AT_DEF_LINE(attr_idx) = TOKEN_LINE(token);
02329 AT_DEF_COLUMN(attr_idx) = TOKEN_COLUMN(token);
02330 LN_DEF_LOC(name_idx) = TRUE;
02331 }
02332 else {
02333 NTR_ATTR_TBL(tmp_attr_idx);
02334 COPY_COMMON_ATTR_INFO(attr_idx, tmp_attr_idx, Pgm_Unit);
02335 ATI_PROC_IDX(attr_idx) = tmp_attr_idx;
02336 attr_idx = tmp_attr_idx;
02337 AT_USE_ASSOCIATED(attr_idx) = FALSE;
02338 MAKE_EXTERNAL_NAME(attr_idx,
02339 AT_NAME_IDX(attr_idx),
02340 AT_NAME_LEN(attr_idx));
02341 ATP_PROC(attr_idx) = proc_type;
02342 ATP_PGM_UNIT(attr_idx) = pgm_type;
02343 AT_DEF_LINE(attr_idx) = TOKEN_LINE(token);
02344 AT_DEF_COLUMN(attr_idx) = TOKEN_COLUMN(token);
02345 AT_IS_INTRIN(attr_idx) = FALSE;
02346 AT_ELEMENTAL_INTRIN(attr_idx) = FALSE;
02347 }
02348 }
02349 else {
02350
02351
02352
02353
02354
02355
02356 AT_ATTR_LINK(attr_idx) = NULL_IDX;
02357 LN_DEF_LOC(name_idx) = TRUE;
02358
02359 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
02360 chg_data_obj_to_pgm_unit(attr_idx, pgm_type, proc_type);
02361 }
02362 else {
02363 ATP_PROC(attr_idx) = proc_type;
02364 ATP_PGM_UNIT(attr_idx) = pgm_type;
02365
02366 if (pgm_type == Function && ATP_RSLT_IDX(attr_idx) != NULL_IDX) {
02367 AT_ATTR_LINK(ATP_RSLT_IDX(attr_idx)) = NULL_IDX;
02368 }
02369 }
02370 AT_DEF_LINE(attr_idx) = TOKEN_LINE(token);
02371 AT_DEF_COLUMN(attr_idx) = TOKEN_COLUMN(token);
02372 }
02373
02374 }
02375
02376
02377
02378
02379
02380
02381 curr_scp_idx = SCP_LAST_CHILD_IDX(curr_scp_idx);
02382 SCP_ATTR_IDX(curr_scp_idx) = attr_idx;
02383 ATP_SCP_IDX(attr_idx) = curr_scp_idx;
02384 AT_DCL_ERR(attr_idx) = AT_DCL_ERR(attr_idx) || has_error;
02385
02386
02387
02388 tmp_attr_idx = srch_sym_tbl(TOKEN_STR(token),
02389 TOKEN_LEN(token),
02390 &loc_name_idx);
02391
02392
02393
02394
02395
02396
02397 ATP_PARENT_IDX(attr_idx) = SCP_ATTR_IDX(SCP_PARENT_IDX(curr_scp_idx));
02398
02399 if (tmp_attr_idx != NULL_IDX) {
02400 fnd_semantic_err(type_of_obj,
02401 TOKEN_LINE(token),
02402 TOKEN_COLUMN(token),
02403 tmp_attr_idx,
02404 TRUE);
02405
02406
02407
02408
02409
02410
02411
02412
02413
02414
02415
02416
02417 LN_ATTR_IDX(loc_name_idx) = attr_idx;
02418 LN_NAME_IDX(loc_name_idx) = AT_NAME_IDX(attr_idx);
02419 }
02420 else {
02421
02422
02423
02424
02425 attr_idx = ntr_host_in_sym_tbl(&token, loc_name_idx, attr_idx, name_idx,
02426 FALSE);
02427 }
02428
02429 LN_DEF_LOC(loc_name_idx) = TRUE;
02430 curr_stmt_category = Dir_Integer_Stmt_Cat;
02431 CURR_BLK_NAME = attr_idx;
02432 ATP_EXPL_ITRFC(attr_idx) = TRUE;
02433
02434 if ((cif_flags & XREF_RECS) != 0) {
02435 cif_usage_rec(attr_idx,
02436 AT_Tbl_Idx,
02437 TOKEN_LINE(token),
02438 TOKEN_COLUMN(token),
02439 CIF_Symbol_Declaration);
02440 }
02441
02442
02443
02444
02445 CURR_BLK_FIRST_SH_IDX =
02446 (SH_STMT_TYPE(SCP_FIRST_SH_IDX(curr_scp_idx)) != Label_Def) ?
02447 SCP_FIRST_SH_IDX(curr_scp_idx) :
02448 IR_IDX_L(SH_IR_IDX(SCP_FIRST_SH_IDX(curr_scp_idx)));
02449
02450 NTR_IR_TBL(ir_idx);
02451 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02452 IR_OPR(ir_idx) = Entry_Opr;
02453 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
02454 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token);
02455 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token);
02456 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
02457 IR_IDX_L(ir_idx) = attr_idx;
02458 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token);
02459 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
02460
02461 ATP_SCP_ALIVE(attr_idx) = TRUE;
02462
02463 if (CURR_BLK == Interface_Body_Blk) {
02464 MAKE_EXTERNAL_NAME(attr_idx,
02465 AT_NAME_IDX(attr_idx),
02466 AT_NAME_LEN(attr_idx));
02467 ATP_IN_INTERFACE_BLK(attr_idx) = TRUE;
02468 ATP_IN_UNNAMED_INTERFACE(attr_idx)= ATI_UNNAMED_INTERFACE(interface_idx);
02469
02470 if (interface_idx != NULL_IDX) {
02471 sn_idx = ATI_FIRST_SPECIFIC_IDX(interface_idx);
02472 tmp_attr_idx = srch_linked_sn(TOKEN_STR(token),
02473 TOKEN_LEN(token),
02474 &sn_idx);
02475
02476 if (tmp_attr_idx == NULL_IDX) {
02477
02478
02479 }
02480 else if (AT_IS_INTRIN(tmp_attr_idx)) {
02481
02482
02483 }
02484 else if (ATP_SCP_IDX(attr_idx) == curr_scp_idx &&
02485 !AT_USE_ASSOCIATED(attr_idx) &&
02486 !ATI_UNNAMED_INTERFACE(interface_idx)) {
02487
02488 if (!AT_DCL_ERR(attr_idx)) {
02489 PRINTMSG(TOKEN_LINE(token), 671, Error,
02490 TOKEN_COLUMN(token),
02491 AT_OBJ_NAME_PTR(attr_idx),
02492 AT_OBJ_NAME_PTR(interface_idx));
02493 AT_DCL_ERR(attr_idx) = TRUE;
02494 }
02495
02496
02497
02498 }
02499 else {
02500
02501
02502 }
02503
02504 NTR_INTERFACE_IN_SN_TBL(sn_idx,
02505 attr_idx,
02506 interface_idx,
02507 TOKEN_LINE(token),
02508 TOKEN_COLUMN(token));
02509 }
02510
02511
02512
02513
02514 sb_idx = SCP_SB_STATIC_IDX(curr_scp_idx);
02515 SB_HOSTED_STATIC(sb_idx) = TRUE;
02516 SB_BLK_TYPE(sb_idx) = Static;
02517 SB_RUNTIME_INIT(sb_idx) = FALSE;
02518
02519 SCP_SB_HOSTED_STATIC_IDX(curr_scp_idx) = sb_idx;
02520
02521
02522
02523 SB_NAME_IDX(sb_idx) = make_in_parent_string(SB_NAME_IDX(sb_idx),
02524 SB_NAME_LEN(sb_idx),
02525 curr_scp_idx,
02526 &length);
02527 SB_NAME_LEN(sb_idx) = length;
02528
02529 if (sb_idx != SCP_SB_STATIC_INIT_IDX(curr_scp_idx)) {
02530 sb_idx = SCP_SB_STATIC_INIT_IDX(curr_scp_idx);
02531 SB_HOSTED_STATIC(sb_idx) = TRUE;
02532 SB_BLK_TYPE(sb_idx) = Static_Named;
02533 SB_RUNTIME_INIT(sb_idx) = FALSE;
02534 SCP_SB_HOSTED_DATA_IDX(curr_scp_idx) = sb_idx;
02535
02536 SB_NAME_IDX(sb_idx) = make_in_parent_string(SB_NAME_IDX(sb_idx),
02537 SB_NAME_LEN(sb_idx),
02538 curr_scp_idx,
02539 &length);
02540 SB_NAME_LEN(sb_idx) = length;
02541 }
02542
02543 if (sb_idx != SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx)) {
02544 sb_idx = SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx);
02545 SB_HOSTED_STATIC(sb_idx) = TRUE;
02546 SB_BLK_TYPE(sb_idx) = Static_Named;
02547 SB_RUNTIME_INIT(sb_idx) = FALSE;
02548 SB_NAME_IDX(sb_idx) = make_in_parent_string(SB_NAME_IDX(sb_idx),
02549 SB_NAME_LEN(sb_idx),
02550 curr_scp_idx,
02551 &length);
02552 SB_NAME_LEN(sb_idx) = length;
02553 }
02554 }
02555 else {
02556
02557 # if 0
02558
02559 ATP_EXT_NAME_IDX(attr_idx) = make_in_parent_string(AT_NAME_IDX(attr_idx),
02560 AT_NAME_LEN(attr_idx),
02561 SCP_PARENT_IDX(curr_scp_idx),
02562 &length);
02563 ATP_EXT_NAME_LEN(attr_idx) = length;
02564 # endif
02565
02566 ATP_EXT_NAME_IDX(attr_idx) = AT_NAME_IDX(attr_idx);
02567 ATP_EXT_NAME_LEN(attr_idx) = AT_NAME_LEN(attr_idx);
02568
02569 if (cmd_line_flags.debug_lvl <= Debug_Lvl_1) {
02570 gen_end_prologue_debug_label(attr_idx);
02571 }
02572
02573
02574
02575 sb_idx = SCP_SB_STATIC_IDX(curr_scp_idx);
02576 SB_NAME_IDX(sb_idx) = make_in_parent_string(SB_NAME_IDX(sb_idx),
02577 SB_NAME_LEN(sb_idx),
02578 curr_scp_idx,
02579 &length);
02580 SB_NAME_LEN(sb_idx) = length;
02581
02582 if (sb_idx != SCP_SB_STATIC_INIT_IDX(curr_scp_idx)) {
02583 sb_idx = SCP_SB_STATIC_INIT_IDX(curr_scp_idx);
02584 SB_NAME_IDX(sb_idx) = make_in_parent_string(SB_NAME_IDX(sb_idx),
02585 SB_NAME_LEN(sb_idx),
02586 curr_scp_idx,
02587 &length);
02588 SB_NAME_LEN(sb_idx) = length;
02589 }
02590
02591 if (sb_idx != SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx)) {
02592 sb_idx = SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx);
02593 SB_NAME_IDX(sb_idx) = make_in_parent_string(SB_NAME_IDX(sb_idx),
02594 SB_NAME_LEN(sb_idx),
02595 curr_scp_idx,
02596 &length);
02597 SB_NAME_LEN(sb_idx) = length;
02598 }
02599
02600 ATP_MAY_INLINE(attr_idx) =
02601 ATP_MAY_INLINE(SCP_ATTR_IDX(SCP_PARENT_IDX(curr_scp_idx)));
02602 }
02603
02604
02605
02606
02607 if (cif_flags & BASIC_RECS) {
02608 cif_begin_scope_rec();
02609 }
02610
02611 if (CURR_BLK == Interface_Body_Blk) {
02612
02613
02614 cdir_switches.implicit_use_idx = cmd_line_flags.implicit_use_idx;
02615 }
02616
02617 implicit_use_semantics();
02618
02619 TRACE (Func_Exit, "start_new_subpgm", NULL);
02620
02621 return(attr_idx);
02622
02623 }
02624
02625
02626
02627
02628
02629
02630
02631
02632
02633
02634
02635
02636
02637
02638
02639
02640 static void gen_end_prologue_debug_label(int attr_idx)
02641
02642 {
02643 int ir_idx;
02644 int lbl_attr_idx;
02645
02646
02647 TRACE (Func_Entry, "gen_end_prologue_debug_label", NULL);
02648
02649
02650
02651
02652 NTR_ATTR_TBL(lbl_attr_idx);
02653 COPY_COMMON_ATTR_INFO(attr_idx, lbl_attr_idx, Label);
02654 AT_DEFINED(lbl_attr_idx) = TRUE;
02655 ATL_CLASS(lbl_attr_idx) = Lbl_Debug;
02656 ATL_DEBUG_CLASS(lbl_attr_idx) = Ldbg_End_Prologue;
02657
02658 if (ATP_EXT_NAME_IDX(attr_idx) != NULL_IDX) {
02659 AT_NAME_LEN(lbl_attr_idx) = ATP_EXT_NAME_LEN(attr_idx);
02660 AT_NAME_IDX(lbl_attr_idx) = ATP_EXT_NAME_IDX(attr_idx);
02661 }
02662
02663 ADD_ATTR_TO_LOCAL_LIST(lbl_attr_idx);
02664
02665 gen_sh(After,
02666 Continue_Stmt,
02667 SH_GLB_LINE(curr_stmt_sh_idx),
02668 SH_COL_NUM(curr_stmt_sh_idx),
02669 FALSE,
02670 TRUE,
02671 TRUE);
02672
02673 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02674
02675 NTR_IR_TBL(ir_idx);
02676 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02677 IR_OPR(ir_idx) = Label_Opr;
02678 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
02679 IR_LINE_NUM(ir_idx) = SH_GLB_LINE(curr_stmt_sh_idx);
02680 IR_COL_NUM(ir_idx) = SH_COL_NUM(curr_stmt_sh_idx);
02681 IR_LINE_NUM_L(ir_idx) = SH_GLB_LINE(curr_stmt_sh_idx);
02682 IR_COL_NUM_L(ir_idx) = SH_COL_NUM(curr_stmt_sh_idx);
02683 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
02684 IR_IDX_L(ir_idx) = lbl_attr_idx;
02685 ATL_DEF_STMT_IDX(lbl_attr_idx) = curr_stmt_sh_idx;
02686
02687 TRACE (Func_Exit, "gen_end_prologue_debug_label", NULL);
02688
02689 return;
02690
02691 }
02692
02693
02694
02695
02696
02697
02698
02699
02700
02701
02702
02703
02704
02705
02706
02707
02708
02709
02710
02711
02712
02713
02714
02715
02716 int start_new_prog_unit(pgm_unit_type pgm_type,
02717 blk_cntxt_type blk_type,
02718 boolean no_name_entry,
02719 boolean parse_error,
02720 int *defer_msg)
02721
02722 {
02723 int attr_idx;
02724 static int num_main_program = 0;
02725 static int num_no_name_entry = 0;
02726 boolean has_task_dirs = FALSE;
02727 int ir_idx;
02728 int length;
02729 int message;
02730 int name_idx;
02731 int save_sh_idx;
02732 int sb_idx;
02733
02734
02735 TRACE (Func_Entry, "start_new_prog_unit", NULL);
02736
02737 if (!no_name_entry) {
02738
02739 if (curr_stmt_category != Init_Stmt_Cat) {
02740 iss_blk_stk_err();
02741 SCP_IN_ERR(curr_scp_idx) = TRUE;
02742
02743
02744
02745 }
02746
02747 curr_stmt_category = Dir_Integer_Stmt_Cat;
02748 }
02749
02750 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), &name_idx);
02751
02752 if (attr_idx == NULL_IDX) {
02753 attr_idx = ntr_sym_tbl(&token, name_idx);
02754 AT_DCL_ERR(attr_idx) = parse_error;
02755 SCP_ATTR_IDX(curr_scp_idx) = attr_idx;
02756 message = 0;
02757
02758 if (no_name_entry) {
02759
02760
02761
02762
02763
02764
02765
02766 has_task_dirs = ATP_HAS_TASK_DIRS(glb_tbl_idx[Main_Attr_Idx]);
02767 attr_idx = glb_tbl_idx[Main_Attr_Idx];
02768 AT_DEF_LINE(attr_idx) = TOKEN_LINE(token);
02769 AT_DEF_COLUMN(attr_idx) = TOKEN_COLUMN(token);
02770 AT_NAME_LEN(attr_idx) = TOKEN_LEN(token);
02771 AT_NAME_IDX(attr_idx) = LN_NAME_IDX(name_idx);
02772 AT_DEFINED(attr_idx) = TRUE;
02773 LN_ATTR_IDX(name_idx) = attr_idx;
02774 SCP_ATTR_IDX(curr_scp_idx) = attr_idx;
02775 attr_tbl_idx--;
02776 attr_aux_tbl_idx--;
02777
02778 if (++num_no_name_entry == 2) {
02779 message = 1003;
02780 }
02781 else if (++num_main_program == 2) {
02782 message = 1009;
02783 }
02784 }
02785 else if (pgm_type == Program && ++num_main_program == 2) {
02786 message = 1009;
02787 }
02788
02789 if (message != 0 && !parse_error) {
02790
02791 if (*defer_msg > 0) {
02792 *defer_msg = message;
02793 }
02794 else if (!parse_error) {
02795
02796 PRINTMSG(TOKEN_LINE(token), message,
02797 # if defined(_ERROR_DUPLICATE_GLOBALS)
02798 Error,
02799 # else
02800 Warning,
02801 # endif
02802 TOKEN_COLUMN(token));
02803 }
02804 }
02805 }
02806 else if (pgm_type == Function) {
02807 SCP_ATTR_IDX(curr_scp_idx) = attr_idx;
02808
02809
02810
02811 PRINTMSG(TOKEN_LINE(token), 666, Error, TOKEN_COLUMN(token),
02812 AT_OBJ_NAME_PTR(attr_idx));
02813 CREATE_ERR_ATTR(attr_idx, TOKEN_LINE(token),
02814 TOKEN_COLUMN(token), Pgm_Unit);
02815 SCP_IN_ERR(curr_scp_idx) = TRUE;
02816 SCP_ATTR_IDX(curr_scp_idx) = attr_idx;
02817 }
02818 else {
02819 SCP_ATTR_IDX(curr_scp_idx) = attr_idx;
02820
02821 if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
02822 ATD_CLASS(attr_idx) == Variable &&
02823 ATD_SYMBOLIC_CONSTANT(attr_idx)) {
02824 }
02825 else {
02826 PRINTMSG(TOKEN_LINE(token), 180, Internal, TOKEN_COLUMN(token),
02827 TOKEN_STR(token), "attr_tbl");
02828 }
02829 }
02830
02831 LN_DEF_LOC(name_idx) = TRUE;
02832 AT_OBJ_CLASS(attr_idx) = Pgm_Unit;
02833 ATP_PGM_UNIT(attr_idx) = pgm_type;
02834 ATP_HAS_TASK_DIRS(attr_idx) = has_task_dirs;
02835
02836 MAKE_EXTERNAL_NAME(attr_idx, AT_NAME_IDX(attr_idx), AT_NAME_LEN(attr_idx));
02837
02838 ATP_SCP_ALIVE(attr_idx) = TRUE;
02839 ATP_EXPL_ITRFC(attr_idx) = TRUE;
02840 ATP_SCP_IDX(attr_idx) = curr_scp_idx;
02841
02842 if (cif_flags && pgm_type == Program) {
02843 AT_CIF_SYMBOL_ID(attr_idx) = 2;
02844 }
02845
02846 ATP_MAY_INLINE(attr_idx) = opt_flags.modinline ||
02847 (pgm_type != Module && dump_flags.preinline);
02848 if (pgm_type <= Program) {
02849 NTR_IR_TBL(ir_idx);
02850 IR_OPR(ir_idx) = Entry_Opr;
02851 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
02852 IR_LINE_NUM(ir_idx) = TOKEN_LINE(token);
02853 IR_COL_NUM(ir_idx) = TOKEN_COLUMN(token);
02854 IR_FLD_L(ir_idx) = AT_Tbl_Idx;
02855 IR_IDX_L(ir_idx) = attr_idx;
02856 IR_COL_NUM_L(ir_idx) = TOKEN_COLUMN(token);
02857 IR_LINE_NUM_L(ir_idx) = TOKEN_LINE(token);
02858
02859 if (no_name_entry ) {
02860
02861
02862
02863
02864
02865
02866
02867
02868
02869 save_sh_idx = curr_stmt_sh_idx;
02870 curr_stmt_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx);
02871
02872 gen_sh(Before,
02873 Program_Stmt,
02874 stmt_start_line,
02875 stmt_start_col,
02876 FALSE,
02877 FALSE,
02878 TRUE);
02879
02880 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
02881 curr_stmt_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx);
02882
02883 if (cmd_line_flags.debug_lvl <= Debug_Lvl_1) {
02884 gen_end_prologue_debug_label(attr_idx);
02885 }
02886
02887 curr_stmt_sh_idx = save_sh_idx;
02888 }
02889 else {
02890 SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02891
02892 if (cmd_line_flags.debug_lvl <= Debug_Lvl_1) {
02893 gen_end_prologue_debug_label(attr_idx);
02894 }
02895 }
02896 }
02897
02898
02899
02900 sb_idx = SCP_SB_STATIC_IDX(curr_scp_idx);
02901 SB_NAME_IDX(sb_idx) = make_in_parent_string(SB_NAME_IDX(sb_idx),
02902 SB_NAME_LEN(sb_idx),
02903 curr_scp_idx,
02904 &length);
02905 SB_NAME_LEN(sb_idx) = length;
02906
02907 if (sb_idx != SCP_SB_STATIC_INIT_IDX(curr_scp_idx)) {
02908 sb_idx = SCP_SB_STATIC_INIT_IDX(curr_scp_idx);
02909 SB_NAME_IDX(sb_idx) = make_in_parent_string(SB_NAME_IDX(sb_idx),
02910 SB_NAME_LEN(sb_idx),
02911 curr_scp_idx,
02912 &length);
02913 SB_NAME_LEN(sb_idx) = length;
02914 }
02915
02916 if (sb_idx != SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx)) {
02917 sb_idx = SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx);
02918 SB_NAME_IDX(sb_idx) = make_in_parent_string(SB_NAME_IDX(sb_idx),
02919 SB_NAME_LEN(sb_idx),
02920 curr_scp_idx,
02921 &length);
02922 SB_NAME_LEN(sb_idx) = length;
02923 }
02924
02925 CURR_BLK = blk_type;
02926 CURR_BLK_NAME = attr_idx;
02927 CURR_BLK_DEF_LINE = stmt_start_line;
02928 CURR_BLK_DEF_COLUMN = stmt_start_col;
02929
02930 if (cif_flags & XREF_RECS) {
02931 cif_usage_rec(attr_idx,
02932 AT_Tbl_Idx,
02933 TOKEN_LINE(token),
02934 TOKEN_COLUMN(token),
02935 CIF_Symbol_Declaration);
02936 }
02937
02938 if (!no_name_entry) {
02939
02940
02941
02942
02943 implicit_use_semantics();
02944 }
02945
02946 TRACE (Func_Exit, "start_new_prog_unit", NULL);
02947
02948 return(attr_idx);
02949
02950 }
02951
02952
02953
02954
02955
02956
02957
02958
02959
02960
02961
02962
02963
02964
02965
02966
02967
02968
02969
02970
02971
02972
02973
02974
02975
02976
02977
02978
02979
02980 void parse_typed_function_stmt()
02981
02982 {
02983 boolean assumed_size_ch = FALSE;
02984 int attr_idx;
02985 int defer_msg;
02986 boolean elemental_set;
02987 boolean err_fnd = FALSE;
02988 char err_str[45];
02989 int idx;
02990 int local_scp_idx = curr_scp_idx;
02991 boolean matched;
02992 int interface_idx;
02993 boolean pure_set;
02994 boolean recursive_set;
02995 int rslt_idx;
02996 int stmt_number;
02997 boolean type_err;
02998
02999
03000 TRACE (Func_Entry, "parse_typed_function_stmt", NULL);
03001
03002 stmt_type = Function_Stmt;
03003 SH_STMT_TYPE(curr_stmt_sh_idx) = Function_Stmt;
03004 stmt_number = statement_number;
03005
03006 if (curr_stmt_category == Sub_Func_Stmt_Cat) {
03007
03008
03009
03010
03011
03012 if (CURR_BLK == Interface_Blk) {
03013 interface_idx = CURR_BLK_NAME;
03014
03015 if (interface_idx == NULL_IDX) {
03016 interface_idx = BLK_UNNAMED_INTERFACE(blk_stk_idx);
03017 }
03018
03019 ATI_HAS_NON_MOD_PROC(interface_idx) = TRUE;
03020
03021
03022
03023
03024 if (BLK_AT_IDX(blk_stk_idx) == NULL_IDX) {
03025 BLK_AT_IDX(blk_stk_idx) = attr_tbl_idx;
03026 BLK_BD_IDX(blk_stk_idx) = bounds_tbl_idx;
03027 BLK_CN_IDX(blk_stk_idx) = const_tbl_idx;
03028 BLK_CP_IDX(blk_stk_idx) = const_pool_idx;
03029 BLK_NP_IDX(blk_stk_idx) = name_pool_idx;
03030 BLK_SB_IDX(blk_stk_idx) = stor_blk_tbl_idx;
03031 BLK_SN_IDX(blk_stk_idx) = sec_name_tbl_idx;
03032 BLK_TYP_IDX(blk_stk_idx) = type_tbl_idx;
03033 }
03034 }
03035
03036
03037
03038
03039
03040 start_new_scp();
03041 curr_scp_idx = SCP_PARENT_IDX(curr_scp_idx);
03042 }
03043
03044 if (AT_OBJ_CLASS(AT_WORK_IDX) == Pgm_Unit) {
03045
03046
03047
03048
03049
03050 err_fnd = AT_DCL_ERR(AT_WORK_IDX);
03051 recursive_set = ATP_RECURSIVE(AT_WORK_IDX);
03052 elemental_set = ATP_ELEMENTAL(AT_WORK_IDX);
03053 pure_set = ATP_PURE(AT_WORK_IDX);
03054 }
03055 else {
03056 recursive_set = FALSE;
03057 elemental_set = FALSE;
03058 pure_set = FALSE;
03059 }
03060
03061 if (AT_TYPED(AT_WORK_IDX)) {
03062 type_err = AT_DCL_ERR(AT_WORK_IDX);
03063 }
03064 else {
03065
03066
03067
03068
03069
03070
03071 if (curr_stmt_category == Sub_Func_Stmt_Cat) {
03072
03073
03074
03075
03076
03077
03078
03079 curr_scp_idx =SCP_LAST_CHILD_IDX(curr_scp_idx);
03080 SCP_ATTR_IDX(curr_scp_idx) =SCP_ATTR_IDX(SCP_PARENT_IDX(curr_scp_idx));
03081 }
03082
03083 type_err = !parse_type_spec(TRUE);
03084 err_fnd = type_err;
03085
03086 if (curr_stmt_category == Sub_Func_Stmt_Cat) {
03087
03088
03089
03090 local_scp_idx = curr_scp_idx;
03091 curr_scp_idx = SCP_PARENT_IDX(curr_scp_idx);
03092 }
03093 }
03094
03095 while (matched = MATCHED_TOKEN_CLASS(Tok_Class_Keyword)) {
03096
03097 switch (TOKEN_VALUE(token)) {
03098 case Tok_Kwd_Recursive:
03099
03100 if (elemental_set) {
03101
03102
03103
03104 PRINTMSG(TOKEN_LINE(token), 1261, Error, TOKEN_COLUMN(token));
03105 err_fnd = TRUE;
03106 }
03107 else if (recursive_set) {
03108 PRINTMSG(TOKEN_LINE(token), 1260, Error, TOKEN_COLUMN(token),
03109 "RECURSIVE");
03110 err_fnd = TRUE;
03111 }
03112 else {
03113 recursive_set = TRUE;
03114 }
03115 continue;
03116
03117 case Tok_Kwd_Elemental:
03118
03119 if (recursive_set) {
03120
03121
03122
03123 PRINTMSG(TOKEN_LINE(token), 1261, Error, TOKEN_COLUMN(token));
03124 err_fnd = TRUE;
03125 }
03126 else if (elemental_set) {
03127 PRINTMSG(TOKEN_LINE(token), 1260, Error, TOKEN_COLUMN(token),
03128 "ELEMENTAL");
03129 err_fnd = TRUE;
03130 }
03131 else {
03132 elemental_set = TRUE;
03133 }
03134 continue;
03135
03136 case Tok_Kwd_Pure:
03137
03138 if (pure_set) {
03139 PRINTMSG(TOKEN_LINE(token), 1260, Error, TOKEN_COLUMN(token),
03140 "PURE");
03141 err_fnd = TRUE;
03142 }
03143 pure_set = TRUE;
03144 continue;
03145
03146 case Tok_Kwd_Function:
03147
03148 if (!MATCHED_TOKEN_CLASS(Tok_Class_Id)) {
03149 parse_err_flush(Find_Lparen, "function-name");
03150 token = main_token;
03151 TOKEN_LINE(token) = stmt_start_line;
03152 TOKEN_COLUMN(token) = stmt_start_col;
03153 err_fnd = TRUE;
03154 }
03155 break;
03156
03157 default:
03158 matched = FALSE;
03159 reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token));
03160 break;
03161 }
03162 break;
03163 }
03164
03165 if (!matched) {
03166 err_str[0] = '\0';
03167
03168 if (!recursive_set) {
03169 strcat(err_str, "[RECURSIVE] ");
03170 }
03171 if (!elemental_set) {
03172 strcat(err_str, "[ELEMENTAL] ");
03173 }
03174 if (!pure_set) {
03175 strcat(err_str, "[PURE] ");
03176 }
03177
03178 strcat(err_str, "FUNCTION");
03179
03180 parse_err_flush(Find_EOS, err_str);
03181 token = main_token;
03182 TOKEN_LINE(token) = stmt_start_line;
03183 TOKEN_COLUMN(token) = stmt_start_col;
03184 err_fnd = TRUE;
03185 }
03186
03187 if (TYP_TYPE(ATD_TYPE_IDX(AT_WORK_IDX)) == Character) {
03188
03189 if (TYP_CHAR_CLASS(ATD_TYPE_IDX(AT_WORK_IDX)) == Assumed_Size_Char) {
03190 assumed_size_ch = TRUE;
03191 }
03192 else if (TYP_CHAR_CLASS(ATD_TYPE_IDX(AT_WORK_IDX)) == Var_Len_Char ||
03193 TYP_CHAR_CLASS(ATD_TYPE_IDX(AT_WORK_IDX)) == Unknown_Char) {
03194
03195
03196
03197
03198 for (idx = SCP_LN_FW_IDX(local_scp_idx);
03199 idx < SCP_LN_LW_IDX(local_scp_idx); idx++) {
03200 AT_REFERENCED(LN_ATTR_IDX(idx)) = Char_Rslt_Bound_Ref;
03201 }
03202 }
03203 }
03204
03205 if (curr_stmt_category != Sub_Func_Stmt_Cat) {
03206 defer_msg = 0;
03207 attr_idx = start_new_prog_unit(Function,
03208 Function_Blk,
03209 FALSE,
03210 err_fnd,
03211 &defer_msg);
03212 ATP_PROC(attr_idx) = Extern_Proc;
03213 }
03214 else {
03215 attr_idx = start_new_subpgm(Function, err_fnd, FALSE);
03216 }
03217
03218 if (assumed_size_ch) {
03219 PRINTMSG(AT_DEF_LINE(attr_idx), 1565, Comment,
03220 AT_DEF_COLUMN(attr_idx));
03221
03222 if (ATP_PROC(attr_idx) == Intern_Proc ||
03223 ATP_PROC(attr_idx) == Module_Proc) {
03224
03225
03226
03227
03228 PRINTMSG(AT_DEF_LINE(attr_idx), 367, Error,
03229 AT_DEF_COLUMN(attr_idx),
03230 AT_OBJ_NAME_PTR(attr_idx));
03231 AT_DCL_ERR(attr_idx) = TRUE;
03232 ATD_TYPE_IDX(AT_WORK_IDX) = CHARACTER_DEFAULT_TYPE;
03233 }
03234 else if (CURR_BLK == Interface_Body_Blk) {
03235
03236
03237
03238
03239 PRINTMSG(AT_DEF_LINE(attr_idx), 1566, Warning,
03240 AT_DEF_COLUMN(attr_idx),
03241 AT_OBJ_NAME_PTR(attr_idx));
03242 }
03243 else if (recursive_set) {
03244
03245 PRINTMSG(AT_DEF_LINE(attr_idx), 506, Error,
03246 AT_DEF_COLUMN(attr_idx),
03247 AT_OBJ_NAME_PTR(attr_idx));
03248 AT_DCL_ERR(attr_idx) = TRUE;
03249 ATD_TYPE_IDX(AT_WORK_IDX) = CHARACTER_DEFAULT_TYPE;
03250 }
03251 }
03252
03253 if ((cif_flags & MISC_RECS) && ! err_fnd) {
03254 cif_stmt_type_rec(TRUE, CIF_Function_Stmt, stmt_number);
03255 }
03256
03257 SCP_IN_ERR(curr_scp_idx) = AT_DCL_ERR(attr_idx);
03258 SCP_IN_ERR(SCP_PARENT_IDX(curr_scp_idx)) = AT_DCL_ERR(attr_idx);
03259 CURR_BLK_ERR = AT_DCL_ERR(attr_idx);
03260 ATP_RECURSIVE(attr_idx) = recursive_set;
03261 ATP_ELEMENTAL(attr_idx) = elemental_set;
03262 ATP_PURE(attr_idx) = pure_set;
03263
03264 if (CURR_BLK != Interface_Body_Blk &&
03265 (cmd_line_flags.runtime_argument ||
03266 cmd_line_flags.runtime_arg_entry)) {
03267
03268 ATP_ARGCHCK_ENTRY(attr_idx) = TRUE;
03269 }
03270
03271
03272
03273 if (LA_CH_VALUE == LPAREN || (!err_fnd &&
03274 parse_err_flush(Find_Lparen, "(") )) {
03275 parse_dummy_args(attr_idx);
03276 }
03277
03278 set_function_rslt(attr_idx, type_err);
03279
03280 rslt_idx = ATP_RSLT_IDX(attr_idx);
03281 AT_TYPED(rslt_idx) = TRUE;
03282 ATD_TYPE_IDX(rslt_idx) = ATD_TYPE_IDX(AT_WORK_IDX);
03283
03284 if (LA_CH_VALUE != EOS) {
03285 parse_err_flush(Find_EOS, EOS_STR);
03286 }
03287
03288 NEXT_LA_CH;
03289
03290 TRACE (Func_Exit, "parse_typed_function_stmt", NULL);
03291
03292 return;
03293
03294 }
03295
03296
03297
03298
03299
03300
03301
03302
03303
03304
03305
03306
03307
03308
03309
03310
03311
03312
03313
03314
03315
03316
03317
03318
03319
03320
03321 static void start_new_scp(void)
03322
03323 {
03324 int first_sh_idx;
03325 int idx;
03326 int name_idx;
03327 int npes_attr;
03328 token_type npes_token;
03329 int parent_idx;
03330 int parent_name_idx;
03331 int save_scp;
03332
03333
03334 TRACE (Func_Entry, "start_new_scp", NULL);
03335
03336 parent_idx = curr_scp_idx;
03337 NTR_SCP_TBL(curr_scp_idx);
03338
03339
03340
03341 if (SCP_FIRST_CHILD_IDX(parent_idx) == NULL_IDX) {
03342 SCP_FIRST_CHILD_IDX(parent_idx) = curr_scp_idx;
03343 }
03344 else {
03345 SCP_SIBLING_IDX(SCP_LAST_CHILD_IDX(parent_idx)) = curr_scp_idx;
03346 }
03347
03348 SCP_LAST_CHILD_IDX(parent_idx) = curr_scp_idx;
03349 SCP_NUM_CHILDREN(parent_idx) = SCP_NUM_CHILDREN(parent_idx) + 1;
03350 SCP_PARENT_IDX(curr_scp_idx) = parent_idx;
03351 SCP_LEVEL(curr_scp_idx) = SCP_LEVEL(parent_idx) + 1;
03352 SCP_IMPL_NONE(curr_scp_idx) = FALSE;
03353
03354
03355
03356
03357
03358
03359 first_sh_idx = SH_LABELED(curr_stmt_sh_idx) ? SH_PREV_IDX(curr_stmt_sh_idx) :
03360 curr_stmt_sh_idx;
03361
03362 SCP_FIRST_SH_IDX(curr_scp_idx) = first_sh_idx;
03363
03364
03365
03366
03367 SCP_LAST_SH_IDX(parent_idx) = SH_PREV_IDX(first_sh_idx);
03368 SH_PREV_IDX(first_sh_idx) = NULL_IDX;
03369 SH_NEXT_IDX(SH_PREV_IDX(first_sh_idx)) = NULL_IDX;
03370
03371
03372
03373 init_name_and_stor_tbls(curr_scp_idx, TRUE);
03374
03375 if (CURR_BLK == Interface_Blk) {
03376 SCP_PARENT_NONE(curr_scp_idx) = FALSE;
03377 SCP_IS_INTERFACE(curr_scp_idx) = TRUE;
03378
03379
03380
03381 for (idx = 0; idx < MAX_IMPL_CHS; idx++) {
03382 IM_TYPE_IDX(curr_scp_idx, idx) = REAL_DEFAULT_TYPE;
03383 IM_SET(curr_scp_idx, idx) = FALSE;
03384 }
03385
03386 for (idx = IMPL_IDX('I'); idx <= IMPL_IDX('N'); idx++) {
03387 IM_TYPE_IDX(curr_scp_idx, idx) = INTEGER_DEFAULT_TYPE;
03388 }
03389
03390
03391
03392
03393
03394
03395
03396
03397 SCP_SB_STACK_IDX(curr_scp_idx) = SCP_SB_STACK_IDX(parent_idx);
03398
03399 # if defined(GENERATE_WHIRL)
03400
03401
03402
03403 SB_SCP_IDX(SCP_SB_DARG_IDX(curr_scp_idx)) =
03404 SB_SCP_IDX(SCP_SB_DARG_IDX(parent_idx));
03405 # endif
03406
03407 }
03408 else {
03409 SCP_PARENT_NONE(curr_scp_idx) = SCP_IMPL_NONE(parent_idx) ||
03410 SCP_PARENT_NONE(parent_idx);
03411
03412 for (idx = 0; idx < MAX_IMPL_CHS; idx++) {
03413
03414 IM_TYPE_IDX(curr_scp_idx, idx) = IM_TYPE_IDX(parent_idx, idx);
03415 }
03416 }
03417
03418
03419
03420 CREATE_ID(TOKEN_ID(npes_token), "N$PES", 5);
03421
03422 TOKEN_COLUMN(npes_token) = 1;
03423 TOKEN_LEN(npes_token) = 5;
03424 TOKEN_LINE(npes_token) = stmt_start_line;
03425 npes_attr = srch_sym_tbl(TOKEN_STR(npes_token),
03426 TOKEN_LEN(npes_token),
03427 &name_idx);
03428 npes_attr = ntr_sym_tbl(&npes_token,name_idx);
03429 LN_DEF_LOC(name_idx) = TRUE;
03430 save_scp = curr_scp_idx;
03431 curr_scp_idx = parent_idx;
03432 npes_attr = srch_sym_tbl(TOKEN_STR(npes_token),
03433 TOKEN_LEN(npes_token),
03434 &parent_name_idx);
03435
03436
03437
03438 LN_ATTR_IDX(name_idx) = npes_attr;
03439 LN_NAME_IDX(name_idx) = AT_NAME_IDX(npes_attr);
03440 curr_scp_idx = save_scp;
03441
03442 TRACE (Func_Exit, "start_new_scp", NULL);
03443
03444 return;
03445
03446 }
