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/debug.c 5.17 10/14/99 12:53:57\n";
00038
00039 # include "defines.h"
00040
00041 # include "host.m"
00042 # include "host.h"
00043 # include "target.m"
00044 # include "target.h"
00045 # include "globals.m"
00046 # include "tokens.m"
00047 # include "sytb.m"
00048 # include "p_globals.m"
00049 # include "debug.m"
00050 # include "s_utils.m"
00051 # include "globals.h"
00052 # include "tokens.h"
00053 # include "sytb.h"
00054 # include "p_globals.h"
00055 # include "debug.h"
00056
00057 static void build_fake_token (char *);
00058 static void chain_thru_sn_ntries(FILE *, int, boolean);
00059 static void dump_al_ntry (FILE *, int);
00060 static void dump_at_ntry (FILE *, int, boolean);
00061 static void dump_blk_ntry (FILE *, int);
00062 static void dump_bd_ntry (FILE *, int);
00063 static void dump_cn_ntry (FILE *, int);
00064 static void dump_dv (FILE *, int_dope_type *, boolean);
00065 static void dump_ga_ntry (FILE *, int);
00066 static void dump_gb_ntry (FILE *, int);
00067 static void dump_gl_ntry (FILE *, int);
00068 static void dump_gn_ntry (FILE *, int);
00069 static void dump_gt_ntry (FILE *, int);
00070 static void dump_hn_ntry (FILE *, int, boolean);
00071 static void dump_il_ntry (FILE *, int);
00072 static void dump_ir_ntry (FILE *, int, int);
00073 static void dump_ln_ntry (FILE *, int, boolean);
00074 static void dump_fp_ntry (FILE *, int, boolean);
00075 static void dump_ml_ntry (FILE *, int);
00076 static void dump_ro_ntry (FILE *, int);
00077 static void dump_sb_ntry (FILE *, int);
00078 static void dump_scp_ntry (FILE *, int, int, boolean, boolean);
00079 static void dump_sn_ntry (FILE *, int);
00080 static void dump_eq_ntry (FILE *, int);
00081 static void dump_stmt_ntry (FILE *, boolean);
00082 static void dump_typ_ntry (FILE *, int);
00083 static void dump_trace_info (FILE *, trace_type, char *, char *);
00084 static void loop_thru_sn_ntries (FILE *, int, boolean);
00085 static void print_all_text (boolean);
00086 static char *print_at_name (int);
00087 static void print_attr_name (FILE *, int, int);
00088 static void print_const_entry (FILE *, int, int);
00089 static void print_list (FILE *, int, int, int, boolean);
00090 static void print_Dv_Whole_Def_Opr (FILE *, int, int, int);
00091 static void print_mp_dir_opr (FILE *, int, int, int);
00092 static void print_open_mp_dir_opr(FILE *, int, int, int);
00093 static void print_expanded_stmt_for_scp(void);
00094 static void print_expanded_ir (int);
00095 static void print_expanded_il (int);
00096 static void print_expanded_opnd (opnd_type);
00097 static void print_expanded_const(int);
00098 static void print_fld_idx (FILE *, char *, fld_type,int);
00099 static char *print_global_type_f(int);
00100 static void print_tbl_header (char *);
00101 static void dump_io_type_code_ntry(FILE *, long_type *, int);
00102
00103 static boolean full_debug_dump;
00104
00105
00106
00107
00108
00109
00110
00111
00112
00113
00114
00115
00116
00117
00118
00119
00120
00121
00122 FILE * init_debug_file (void)
00123
00124 {
00125 if (debug_file == NULL) {
00126 full_debug_dump = TRUE;
00127
00128
00129
00130
00131 if (debug_file_name[0] == NULL_CHAR) {
00132 strcpy(debug_file_name, "cft90_dump");
00133 }
00134
00135 debug_file = fopen(debug_file_name, "w");
00136
00137 if (debug_file == NULL) {
00138 PRINTMSG(1, 17, Error, 0, debug_file_name);
00139 exit_compiler(RC_USER_ERROR);
00140 }
00141 }
00142
00143 return(debug_file);
00144
00145 }
00146
00147 # ifdef _DEBUG
00148
00149
00150
00151
00152
00153
00154
00155
00156
00157
00158
00159
00160
00161
00162
00163
00164
00165
00166
00167
00168
00169
00170
00171
00172
00173
00174
00175
00176
00177 void print_bd_tbl (void)
00178
00179 {
00180 int bd_idx;
00181
00182
00183 print_tbl_header("Bounds Table");
00184
00185 bd_idx = 1;
00186
00187 while (bd_idx < bounds_tbl_idx) {
00188 dump_bd_ntry(debug_file, bd_idx);
00189 bd_idx += BD_NTRY_SIZE(bd_idx);
00190 }
00191
00192 bd_idx = BD_NEXT_FREE_NTRY(BD_FREE_LIST_IDX);
00193
00194 while (bd_idx != NULL_IDX) {
00195 dump_bd_ntry(debug_file, bd_idx);
00196 bd_idx = BD_NEXT_FREE_NTRY(bd_idx);
00197 }
00198
00199 putc ('\n', debug_file);
00200 fflush(debug_file);
00201 return;
00202
00203 }
00204
00205
00206
00207
00208
00209
00210
00211
00212 void print_blk_tbl (void)
00213
00214 {
00215 int blk_idx;
00216
00217
00218 print_tbl_header("BLOCK STACK");
00219
00220 for (blk_idx = 1; blk_idx <= blk_stk_idx; blk_idx++) {
00221 dump_blk_ntry(debug_file, blk_idx);
00222 }
00223
00224 putc ('\n', debug_file);
00225 fflush (debug_file);
00226 return;
00227
00228 }
00229
00230
00231
00232
00233
00234
00235
00236
00237 void print_cn_tbl (void)
00238
00239 {
00240 int cn_idx;
00241
00242
00243 print_tbl_header("Constant Table");
00244
00245 for (cn_idx = 1; cn_idx <= const_tbl_idx; cn_idx++) {
00246 dump_cn_ntry(debug_file, cn_idx);
00247 }
00248
00249 putc ('\n', debug_file);
00250 fflush (debug_file);
00251 return;
00252
00253 }
00254
00255
00256
00257
00258
00259
00260
00261 void print_eq_tbl (void)
00262 {
00263 int next_group;
00264 int next_item;
00265
00266
00267 if (SCP_FIRST_EQUIV_GRP(curr_scp_idx) == NULL_IDX) {
00268 print_tbl_header("Equivalence Table is empty");
00269 }
00270 else {
00271 print_tbl_header("Equivalence Table");
00272
00273 next_group = SCP_FIRST_EQUIV_GRP(curr_scp_idx);
00274
00275 while (next_group != NULL_IDX) {
00276 fprintf(debug_file, "%21s\n", "NEW EQUIVALENCE GROUP");
00277 next_item = next_group;
00278
00279 while (next_item != NULL_IDX) {
00280 dump_eq_ntry(debug_file, next_item);
00281 next_item = EQ_NEXT_EQUIV_OBJ(next_item);
00282 }
00283 next_group = EQ_NEXT_EQUIV_GRP(next_group);
00284 }
00285 }
00286
00287 putc ('\n', debug_file);
00288 fflush (debug_file);
00289 return;
00290
00291 }
00292
00293
00294
00295
00296
00297
00298
00299
00300 void print_fp_tbl (void)
00301
00302 {
00303 int fp_idx;
00304
00305 print_tbl_header("File Path Table");
00306
00307 fprintf(debug_file, "%s\n\n", "Module paths:");
00308
00309 fp_idx = module_path_idx;
00310
00311 while (fp_idx != NULL_IDX) {
00312 dump_fp_ntry(debug_file, fp_idx, TRUE);
00313 fp_idx = FP_NEXT_FILE_IDX(fp_idx);
00314 }
00315
00316 fprintf(debug_file, "%s\n\n", "Implicit Use Module Paths:");
00317
00318 fp_idx = cmd_line_flags.implicit_use_idx;
00319
00320 while (fp_idx != NULL_IDX) {
00321 dump_fp_ntry(debug_file, fp_idx, TRUE);
00322 fp_idx = FP_NEXT_FILE_IDX(fp_idx);
00323 }
00324
00325 fprintf(debug_file, "%s\n\n", "Inline paths:");
00326
00327 fp_idx = inline_path_idx;
00328
00329 while (fp_idx != NULL_IDX) {
00330 dump_fp_ntry(debug_file, fp_idx, TRUE);
00331 fp_idx = FP_NEXT_FILE_IDX(fp_idx);
00332 }
00333
00334 fprintf(debug_file, "%s\n\n", "Include paths:");
00335
00336 print_fp_includes();
00337
00338 putc ('\n', debug_file);
00339 fflush(debug_file);
00340 return;
00341
00342 }
00343
00344
00345
00346
00347
00348
00349
00350 void print_gb_tbl (void)
00351
00352 {
00353 int gb_idx;
00354
00355
00356 print_tbl_header("Global Bounds Table");
00357
00358 gb_idx = 1;
00359
00360 while (gb_idx != NULL_IDX && gb_idx <= global_bounds_tbl_idx) {
00361 dump_gb_ntry(debug_file, gb_idx);
00362
00363 if (GB_ARRAY_SIZE(gb_idx) == Constant_Size &&
00364 GB_ARRAY_CLASS(gb_idx) == Explicit_Shape) {
00365 gb_idx += (GB_RANK(gb_idx) * 2);
00366 }
00367 else {
00368 gb_idx++;
00369 }
00370
00371 }
00372
00373 putc ('\n', debug_file);
00374 fflush (debug_file);
00375 return;
00376
00377 }
00378
00379
00380
00381
00382
00383
00384
00385
00386 void print_gl_tbl (void)
00387
00388 {
00389 int gl_idx;
00390
00391
00392 print_tbl_header("Global Line Table");
00393
00394 for (gl_idx = 1; gl_idx <= global_line_tbl_idx; gl_idx++) {
00395 dump_gl_ntry(debug_file, gl_idx);
00396 }
00397
00398 fprintf(debug_file,"\n %-22s= %-10d %-20s= %-10d\n",
00399 "num_prog_unit_err", num_prog_unit_errors,
00400 "num_ansi", num_ansi);
00401
00402 fprintf(debug_file," %-22s= %-10d %-20s= %-10d\n",
00403 "num_warnings", num_warnings,
00404 "num_cautions", num_cautions);
00405
00406 fprintf(debug_file," %-22s= %-10d %-20s= %-10d\n",
00407 "num_notes", num_notes,
00408 "num_comments", num_comments);
00409
00410 putc ('\n', debug_file);
00411 fflush (debug_file);
00412 return;
00413
00414 }
00415
00416
00417
00418
00419
00420
00421
00422
00423 void print_gn_tbl (void)
00424
00425 {
00426 int gn_idx;
00427 int gt_idx;
00428
00429
00430 print_tbl_header("Global Name Table");
00431
00432 for (gn_idx = 2; gn_idx < global_name_tbl_idx; gn_idx++) {
00433 fprintf(debug_file, "\n****************************************"
00434 "****************************************\n");
00435 dump_gn_ntry(debug_file, gn_idx);
00436 dump_ga_ntry(debug_file, GN_ATTR_IDX(gn_idx));
00437 }
00438 fprintf(debug_file, "\n****************************************"
00439 "****************************************\n");
00440
00441 for (gt_idx = 1; gt_idx <= global_type_tbl_idx; gt_idx++) {
00442
00443 if (GT_TYPE(gt_idx) == Structure) {
00444 dump_ga_ntry(debug_file, GT_STRUCT_IDX(gt_idx));
00445 }
00446 }
00447
00448 putc ('\n', debug_file);
00449 fflush (debug_file);
00450 return;
00451
00452 }
00453
00454
00455
00456
00457
00458
00459
00460
00461 void print_gt_tbl (void)
00462
00463 {
00464 int gt_idx;
00465
00466
00467 print_tbl_header("Global Type Table");
00468
00469 for (gt_idx = 1; gt_idx <= global_type_tbl_idx; gt_idx++) {
00470 dump_gt_ntry(debug_file, gt_idx);
00471 }
00472
00473 putc ('\n', debug_file);
00474 fflush (debug_file);
00475 return;
00476
00477 }
00478
00479
00480
00481
00482
00483
00484
00485 void print_hn_tbl()
00486
00487 {
00488 int hn_idx;
00489
00490
00491 print_tbl_header("Hidden Name Table");
00492
00493 for (hn_idx = SCP_HN_FW_IDX(curr_scp_idx) + 1;
00494 hn_idx < SCP_HN_LW_IDX(curr_scp_idx);
00495 hn_idx++) {
00496 dump_hn_ntry(debug_file, hn_idx, FALSE);
00497 }
00498
00499 putc ('\n', debug_file);
00500 fflush (debug_file);
00501 return;
00502
00503 }
00504
00505
00506
00507
00508
00509
00510
00511
00512 void print_ln_tbl()
00513
00514 {
00515 int ln_idx;
00516
00517 print_tbl_header("Local Name Table");
00518
00519 for (ln_idx = SCP_LN_FW_IDX(curr_scp_idx) + 1;
00520 ln_idx < SCP_LN_LW_IDX(curr_scp_idx);
00521 ln_idx++) {
00522 dump_ln_ntry(debug_file, ln_idx, FALSE);
00523 }
00524
00525 putc ('\n', debug_file);
00526 fflush (debug_file);
00527 return;
00528
00529 }
00530
00531
00532
00533
00534
00535
00536
00537
00538 void print_ml_tbl()
00539
00540 {
00541 int ml_idx;
00542
00543
00544 print_tbl_header("Module Link Table");
00545
00546 fprintf(debug_file,
00547 " NOTE: Only print entries that have at least one nonzero index\n");
00548
00549 for (ml_idx = 0; ml_idx <= mod_link_tbl_idx; ml_idx++) {
00550
00551 if (ML_AT_IDX(ml_idx) != NULL_IDX ||
00552 ML_BD_IDX(ml_idx) != NULL_IDX ||
00553 ML_CN_IDX(ml_idx) != NULL_IDX ||
00554 ML_LN_IDX(ml_idx) != NULL_IDX ||
00555 ML_NP_IDX(ml_idx) != NULL_IDX ||
00556 ML_SB_IDX(ml_idx) != NULL_IDX ||
00557 ML_IL_IDX(ml_idx) != NULL_IDX ||
00558 ML_IR_IDX(ml_idx) != NULL_IDX ||
00559 ML_CP_IDX(ml_idx) != NULL_IDX ||
00560 ML_SH_IDX(ml_idx) != NULL_IDX ||
00561 ML_TYP_IDX(ml_idx) != NULL_IDX ||
00562 ML_SN_IDX(ml_idx) != NULL_IDX) {
00563 dump_ml_ntry(debug_file, ml_idx);
00564 }
00565 }
00566
00567 putc ('\n', debug_file);
00568 fflush (debug_file);
00569 return;
00570
00571 }
00572
00573
00574
00575
00576
00577
00578
00579
00580 void print_ro_tbl (ro_start_idx)
00581
00582 {
00583 int ro_idx;
00584
00585
00586 print_tbl_header("Rename Only Table");
00587
00588 ro_idx = ro_start_idx;
00589
00590 while (ro_idx != NULL_IDX) {
00591 dump_ro_ntry(debug_file, ro_idx);
00592 ro_idx = RO_NEXT_IDX(ro_idx);
00593 }
00594
00595 putc ('\n', debug_file);
00596 fflush(debug_file);
00597 return;
00598
00599 }
00600
00601
00602
00603
00604
00605
00606
00607
00608 void print_sb_tbl (void)
00609
00610 {
00611 int sb_idx;
00612
00613
00614 print_tbl_header("Storage Block Table");
00615
00616 for (sb_idx = 1; sb_idx <= stor_blk_tbl_idx; sb_idx++) {
00617 dump_sb_ntry(debug_file, sb_idx);
00618 }
00619
00620 putc ('\n', debug_file);
00621 fflush(debug_file);
00622 return;
00623
00624 }
00625
00626
00627
00628
00629
00630
00631
00632
00633 void print_scp_tbl(void)
00634
00635 {
00636 print_tbl_header("Scope Table");
00637
00638 dump_scp_ntry(debug_file, 0, 0, FALSE, TRUE);
00639
00640 putc ('\n', debug_file);
00641 fflush (debug_file);
00642 return;
00643
00644 }
00645
00646
00647
00648
00649
00650
00651
00652
00653
00654
00655
00656
00657
00658 void print_sh_tbl (boolean print_all_scps)
00659
00660 {
00661 int save_curr_scp_idx;
00662 int save_curr_stmt_sh_idx;
00663
00664
00665 print_tbl_header("Statement Header Table");
00666
00667 if (print_all_scps) {
00668 save_curr_scp_idx = curr_scp_idx;
00669 curr_scp_idx = 1;
00670 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
00671
00672 print_all_text(TRUE);
00673
00674 curr_scp_idx = save_curr_scp_idx;
00675 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
00676 }
00677 else {
00678 print_all_text(FALSE);
00679 }
00680
00681 return;
00682
00683 }
00684
00685
00686
00687
00688
00689
00690
00691
00692 void print_typ_tbl (void)
00693
00694 {
00695 int type_idx;
00696
00697
00698 print_tbl_header("Type Table");
00699
00700 for (type_idx = 1; type_idx <= type_tbl_idx; type_idx++) {
00701 dump_typ_ntry(debug_file, type_idx);
00702 }
00703
00704 putc ('\n', debug_file);
00705 fflush(debug_file);
00706 return;
00707
00708 }
00709
00710
00711
00712
00713
00714
00715
00716
00717
00718
00719
00720
00721
00722
00723
00724
00725
00726
00727 void print_cmd_tbl (void)
00728
00729 {
00730 extern char *directive_str[];
00731 int dir_idx;
00732 boolean first;
00733 int fp_idx;
00734 int i,j;
00735
00736
00737 print_tbl_header("Commandline Flags");
00738
00739 fprintf(debug_file, " %-17s = %-s\n",
00740 " source file", src_file);
00741 fprintf(debug_file, " %-17s = %-s\n",
00742 "-b binary_output", (cmd_line_flags.binary_output)?bin_file:"NONE");
00743 fprintf(debug_file, " %-17s= %-s\n",
00744 "-S assembly_output", (cmd_line_flags.assembly_output) ?
00745 assembly_file:"NONE");
00746
00747 if (include_path_idx == NULL_IDX) {
00748 fprintf(debug_file, " %-17s = %-s\n", "-I include paths", "NONE");
00749 }
00750 else {
00751 fprintf(debug_file, " %-17s\n", "-I include paths");
00752 print_fp_includes();
00753 }
00754
00755 if (module_path_idx == NULL_IDX) {
00756 fprintf(debug_file, " %-17s = %-s\n", "-p module paths", "NONE");
00757 }
00758 else {
00759 fprintf(debug_file, " %-17s\n", "-p module paths");
00760 fp_idx = module_path_idx;
00761
00762 while (fp_idx != NULL_IDX) {
00763 fprintf(debug_file, "%4s%-s\n", " ", FP_NAME_PTR(fp_idx));
00764 fp_idx = FP_NEXT_FILE_IDX(fp_idx);
00765 }
00766 }
00767 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-7s\n",
00768 "-align8", boolean_str[cmd_line_flags.align8],
00769 "-align16", boolean_str[cmd_line_flags.align16],
00770 "-align32", boolean_str[cmd_line_flags.align32]);
00771
00772 fprintf(debug_file, " %-17s = %-2s\n",
00773 "-align64", boolean_str[cmd_line_flags.align64]);
00774
00775 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-7s\n",
00776 "-a dalign", boolean_str[cmd_line_flags.dalign],
00777 "-a taskcommon", boolean_str[cmd_line_flags.taskcommon],
00778 "-f ", src_form_str[cmd_line_flags.src_form]);
00779
00780 fprintf(debug_file, " %-17s = %-27s %-18s = %-7s\n",
00781 "-i ", integer_size_str[cmd_line_flags.integer_32],
00782 "-k solaris_profile", boolean_str[cmd_line_flags.solaris_profile]);
00783
00784 fprintf(debug_file, " %-17s = %-27s %-18s = %-7s\n",
00785 "-m ", msg_lvl_str[cmd_line_flags.msg_lvl_suppressed],
00786 "-s float64", boolean_str[cmd_line_flags.s_float64]);
00787
00788 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-7s\n",
00789 "-s default64", boolean_str[cmd_line_flags.s_default64],
00790 "-s default32", boolean_str[cmd_line_flags.s_default32],
00791 "-s cf77types", boolean_str[cmd_line_flags.s_cf77types]);
00792
00793 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-7s\n",
00794 "-s integer8", boolean_str[cmd_line_flags.s_integer8],
00795 "-s logical8", boolean_str[cmd_line_flags.s_logical8],
00796 "-s real8", boolean_str[cmd_line_flags.s_real8]);
00797
00798
00799 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-7s\n",
00800 "-s complex8", boolean_str[cmd_line_flags.s_complex8],
00801 "-s pointer8", boolean_str[cmd_line_flags.s_pointer8],
00802 "-s doublecomplex16", boolean_str[cmd_line_flags.s_doublecomplex16]);
00803
00804 fprintf(debug_file, " %-42s = %-2s\n",
00805 "-s doubleprecision16",
00806 boolean_str[cmd_line_flags.s_doubleprecision16]);
00807
00808 fprintf(debug_file, " %-17s = %-2s %-18s = %-s\n",
00809 "-t truncate_bits", boolean_str[cmd_line_flags.truncate_bits],
00810 "-G ", debug_lvl_str[cmd_line_flags.debug_lvl]);
00811
00812 fprintf(debug_file, " %-17s = ", "-N line_size");
00813
00814 if (cmd_line_flags.line_size_80) {
00815 fprintf(debug_file, "%-7d\n", 80);
00816 }
00817 else if (cmd_line_flags.line_size_132) {
00818 fprintf(debug_file, "%-7d\n", 132);
00819 }
00820 else {
00821 fprintf(debug_file, "%-7d\n", 72);
00822 }
00823
00824 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-7s\n",
00825 "-Ps small pic", boolean_str[(cmd_line_flags.small_pic_model)],
00826 "-Pl large pic", boolean_str[(cmd_line_flags.large_pic_model)],
00827 "-R a", boolean_str[cmd_line_flags.runtime_argument]);
00828
00829 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-7s\n",
00830 "-R b", boolean_str[cmd_line_flags.runtime_bounds],
00831 "-R c", boolean_str[cmd_line_flags.runtime_conformance],
00832 "-R C", boolean_str[cmd_line_flags.runtime_arg_call]);
00833
00834 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-7s\n",
00835 "-R E", boolean_str[cmd_line_flags.runtime_arg_entry],
00836 "-R s", boolean_str[cmd_line_flags.runtime_substring],
00837 "-R n", boolean_str[cmd_line_flags.runtime_arg_count_only]);
00838
00839 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-d\n",
00840 "-V verify_option", boolean_str[(cmd_line_flags.verify_option)],
00841 "-X m", boolean_str[(cmd_line_flags.malleable)],
00842 "-X npes", cmd_line_flags.MPP_num_pes);
00843
00844
00845 fprintf(debug_file, "\n%s On/Off Flags (-e/-d)%s\n\n",
00846 " -------------------------- ",
00847 " -------------------------- ");
00848
00849 fprintf(debug_file, " %-26s = %-2s %-26s = %-2s\n",
00850 "a abort_if_any_errors",
00851 boolean_str[on_off_flags.abort_if_any_errors],
00852 "e ieee",
00853 boolean_str[on_off_flags.ieee]);
00854 fprintf(debug_file, " %-26s = %-2s %-26s = %-2s\n",
00855 "f flowtrace_option",
00856 boolean_str[on_off_flags.flowtrace_option],
00857 "g assembly_listing_file",
00858 boolean_str[on_off_flags.assembly_listing_file]);
00859 fprintf(debug_file, " %-26s = %-2s %-26s = %-2s\n",
00860 "i indef_init",
00861 boolean_str[on_off_flags.indef_init],
00862 "j exec_doloops_once",
00863 boolean_str[on_off_flags.exec_doloops_once]);
00864 fprintf(debug_file, " %-26s = %-2s %-26s = %-2s\n",
00865 "n issue_ansi_messages",
00866 boolean_str[on_off_flags.issue_ansi_messages],
00867 "p enable_double_precision",
00868 boolean_str[on_off_flags.enable_double_precision]);
00869 fprintf(debug_file, " %-26s = %-2s %-26s = %-2s\n",
00870 "q abort_on_100_errors",
00871 boolean_str[on_off_flags.abort_on_100_errors],
00872 "r round_mult_operations",
00873 boolean_str[on_off_flags.round_mult_operations]);
00874 fprintf(debug_file, " %-26s = %-2s %-26s = %-2s\n",
00875 "t alloc_autos_on_stack",
00876 boolean_str[on_off_flags.alloc_autos_on_stack],
00877 "u round_integer_divide",
00878 boolean_str[on_off_flags.round_integer_divide]);
00879 fprintf(debug_file, " %-26s = %-2s %-26s = %-2s\n",
00880 "u reciprical_divide",
00881 boolean_str[on_off_flags.reciprical_divide],
00882 "v save_all_vars",
00883 boolean_str[on_off_flags.save_all_vars]);
00884 fprintf(debug_file, " %-26s = %-2s %-26s = %-2s\n",
00885 "x allow_leading_uscore",
00886 boolean_str[on_off_flags.allow_leading_uscore],
00887 "A MPP_apprentice",
00888 boolean_str[on_off_flags.MPP_apprentice]);
00889 fprintf(debug_file, " %-26s = %-2s %-26s = %-2s\n",
00890 "B binary_output",
00891 boolean_str[on_off_flags.binary_output],
00892 "C shared_to_private_coer",
00893 boolean_str[on_off_flags.shared_to_private_coer]);
00894 fprintf(debug_file, " %-26s = %-2s %-26s = %-2s\n",
00895 "I implicit_none",
00896 boolean_str[on_off_flags.implicit_none],
00897 "P preprocess_only",
00898 boolean_str[on_off_flags.preprocess_only]);
00899 fprintf(debug_file, " %-26s = %-2s %-26s = %-2s\n",
00900 "Q allow_leading_uscore",
00901 boolean_str[on_off_flags.allow_leading_uscore],
00902 "R recursive",
00903 boolean_str[on_off_flags.recursive]);
00904 fprintf(debug_file, " %-26s = %-2s %-26s = %-2s\n",
00905 "S assembly_output",
00906 boolean_str[on_off_flags.assembly_output],
00907 "U upper_case_names",
00908 boolean_str[on_off_flags.upper_case_names]);
00909 fprintf(debug_file, " %-26s = %-2s %-26s = %-2s\n",
00910 "X atexpert",
00911 boolean_str[on_off_flags.atexpert],
00912 "Z save_dot_i",
00913 boolean_str[on_off_flags.save_dot_i]);
00914
00915 fprintf(debug_file, "\n%s Optimization Flags (-O)%s\n\n",
00916 " ------------------------- ",
00917 " ------------------------- ");
00918
00919 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s\n",
00920 "aggress", boolean_str[opt_flags.aggress],
00921 "bottom_load", boolean_str[opt_flags.bottom_load]);
00922
00923 fprintf(debug_file, " %-17s = %-2s %-18s = %-2d %-18s = %-2d\n",
00924 "fusion", boolean_str[opt_flags.fusion],
00925 "ieeeconform", (int) boolean_str[opt_flags.ieeeconform],
00926 "inline_lvl", opt_flags.inline_lvl);
00927
00928 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-2s\n",
00929 "jump", boolean_str[opt_flags.jump],
00930 "loopalign", boolean_str[opt_flags.loopalign],
00931 "mark", boolean_str[opt_flags.mark]);
00932
00933 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-2s\n",
00934 "modinline", boolean_str[opt_flags.modinline],
00935 "msgs", boolean_str[opt_flags.msgs],
00936 "neg_msgs", boolean_str[opt_flags.neg_msgs]);
00937
00938 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-2s\n",
00939 "nointerchange", boolean_str[opt_flags.nointerchange],
00940 "overindex", boolean_str[opt_flags.over_index],
00941 "pattern", boolean_str[opt_flags.pattern]);
00942
00943 fprintf(debug_file, " %-17s = %-2d\n",
00944 "pipeline", opt_flags.pipeline_lvl);
00945
00946 fprintf(debug_file, " %-17s = %-2s %-18s = %-2d %-18s = %-2d\n",
00947 "recurrence", boolean_str[opt_flags.recurrence],
00948 "scalar", opt_flags.scalar_lvl,
00949 "split", opt_flags.split_lvl);
00950
00951 fprintf(debug_file, " %-17s = %-2d %-18s = %-2d %-18s = %-2s\n",
00952 "support_lvl", opt_flags.support_lvl,
00953 "task", opt_flags.task_lvl,
00954 "taskinner", boolean_str[opt_flags.taskinner]);
00955
00956 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-2d\n",
00957 "threshold", boolean_str[opt_flags.threshold],
00958 "vsearch", boolean_str[opt_flags.vsearch],
00959 "unroll", opt_flags.unroll_lvl);
00960
00961 fprintf(debug_file, " %-17s = %-2d %-18s = %-2s %-18s = %-2s\n",
00962 "vector", opt_flags.vector_lvl,
00963 "vsearch", boolean_str[opt_flags.vsearch],
00964 "zeroinc", boolean_str[opt_flags.zeroinc]);
00965
00966
00967 fprintf(debug_file, "\n%s Disregard Flags (-x)%s\n\n",
00968 " -------------------------- ",
00969 " -------------------------- ");
00970
00971 fprintf(debug_file, " ");
00972
00973
00974
00975 for (dir_idx = 1; (dir_idx < (Tok_Dir_End - Tok_Dir_Start -1)); dir_idx++) {
00976 fprintf(debug_file, "%-20s = %-2s ", directive_str[dir_idx],
00977 boolean_str[disregard_directive[dir_idx]]);
00978
00979 if ((dir_idx%3) == 0) {
00980 fprintf(debug_file, "\n ");
00981 }
00982 }
00983
00984 fprintf(debug_file, "\n\n%s Dump Flags (-u)%s\n\n",
00985 " ----------------------------- ",
00986 " ----------------------------- ");
00987
00988 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-2s\n",
00989 "abort_ansi", boolean_str[dump_flags.abort_on_ansi],
00990 "no_dim_pad", boolean_str[dump_flags.no_dimension_padding],
00991 "no_mod_output", boolean_str[dump_flags.no_module_output]);
00992
00993 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s\n",
00994 "bd", boolean_str[dump_flags.bd_tbl],
00995 "blk", boolean_str[dump_flags.blk_stk]);
00996
00997 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-2s\n",
00998 "cmd", boolean_str[dump_flags.cmd_line_tbls],
00999 "cn", boolean_str[dump_flags.cn_tbl],
01000 "defines", boolean_str[dump_flags.defines]);
01001
01002 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-2s\n",
01003 "fortran", boolean_str[dump_flags.fort_out],
01004 "fp", boolean_str[dump_flags.fp_tbl],
01005 "ftrace", boolean_str[dump_flags.ftrace_info]);
01006
01007 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-2s\n",
01008 "gl", boolean_str[dump_flags.gl_tbl],
01009 "intrin", boolean_str[dump_flags.intrin_tbl],
01010 "ir1", boolean_str[dump_flags.ir1_tbl]);
01011
01012 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-2s\n",
01013 "ir2", boolean_str[dump_flags.ir2_tbl],
01014 "ir3", boolean_str[dump_flags.ir3_tbl],
01015 "ir4", boolean_str[dump_flags.ir4_tbl]);
01016
01017 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-2s\n",
01018 "mem_report", boolean_str[dump_flags.mem_report],
01019 "mtrace", boolean_str[dump_flags.mtrace_info],
01020 "names", boolean_str[dump_flags.name_tbls]);
01021
01022 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-2s\n",
01023 "pdg", boolean_str[dump_flags.pdgcs],
01024 "pdt", boolean_str[dump_flags.pdt_dump],
01025 "sb", boolean_str[dump_flags.sb_tbl]);
01026
01027 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-2s\n",
01028 "scp", boolean_str[dump_flags.scp_tbl],
01029 "src", boolean_str[dump_flags.src_dmp],
01030 "stderr", boolean_str[dump_flags.std_err]);
01031
01032 fprintf(debug_file, " %-17s = %-2s %-18s = %-2s %-18s = %-2s\n",
01033 "stmt", boolean_str[dump_flags.stmt_dmp],
01034 "sytb", boolean_str[dump_flags.sytb],
01035 "typ", boolean_str[dump_flags.typ_tbl]);
01036
01037 fprintf(debug_file, "\n\n%s Message Options %s \n\n",
01038 " ----------------------------- ",
01039 " ----------------------------- ");
01040
01041 first = TRUE;
01042
01043 for (i = 0; i < MAX_MSG_SIZE; ++i) {
01044
01045 if (message_suppress_tbl[i] != 0) {
01046
01047 for (j = i * HOST_BITS_PER_WORD; j < (i+1) * HOST_BITS_PER_WORD; ++j) {
01048
01049 if (GET_MESSAGE_TBL(message_suppress_tbl, j)) {
01050
01051 if (!first) {
01052 first = FALSE;
01053 fprintf(debug_file, ",");
01054 }
01055 fprintf(debug_file, " %d", j);
01056 }
01057 }
01058 }
01059
01060 if (message_warning_tbl[i] != 0) {
01061
01062 for (j = i * HOST_BITS_PER_WORD; j < (i+1) * HOST_BITS_PER_WORD; ++j) {
01063
01064 if (GET_MESSAGE_TBL(message_warning_tbl, j)) {
01065
01066 if (!first) {
01067 first = FALSE;
01068 fprintf(debug_file, ",");
01069 }
01070 fprintf(debug_file, " W%d", j);
01071 }
01072 }
01073 }
01074
01075 if (message_error_tbl[i] != 0) {
01076
01077 for (j = i * HOST_BITS_PER_WORD; j < (i+1) * HOST_BITS_PER_WORD; ++j) {
01078
01079 if (GET_MESSAGE_TBL(message_error_tbl, j)) {
01080
01081 if (!first) {
01082 first = FALSE;
01083 fprintf(debug_file, ",");
01084 }
01085 fprintf(debug_file, " E%d", j);
01086 }
01087 }
01088 }
01089 }
01090
01091 putc ('\n', debug_file);
01092
01093 putc ('\n', debug_file);
01094 fflush (debug_file);
01095 return;
01096
01097 }
01098
01099
01100
01101
01102
01103
01104
01105
01106
01107
01108
01109
01110
01111
01112
01113
01114
01115
01116
01117 void print_sytb (int scp_idx,
01118 boolean print_all_scps,
01119 boolean dump_all)
01120
01121 {
01122 int al_idx;
01123 char header[60];
01124 int ln_idx;
01125 int save_scp_idx;
01126
01127
01128 PROCESS_SIBLING:
01129
01130 if (scp_idx == INTRINSIC_SCP_IDX) {
01131 print_tbl_header("Intrinsic Symbol Table Dump");
01132 }
01133 else if (SCP_ATTR_IDX(scp_idx) != NULL_IDX) {
01134 header[0] = '\0';
01135 strcat(header, AT_OBJ_NAME_PTR(SCP_ATTR_IDX(scp_idx)));
01136 print_tbl_header(strcat(header, " Symbol Table Dump"));
01137 }
01138 else {
01139 print_tbl_header("Unnamed Symbol Table Dump");
01140 }
01141
01142 for (ln_idx = SCP_LN_FW_IDX(scp_idx)+1; ln_idx < SCP_LN_LW_IDX(scp_idx);
01143 ln_idx++) {
01144 fprintf(debug_file, "****************************************"
01145 "****************************************\n");
01146 dump_ln_ntry(debug_file, ln_idx, dump_all);
01147 }
01148
01149 al_idx = SCP_ATTR_LIST(scp_idx);
01150
01151 while (al_idx != NULL_IDX) {
01152 fprintf(debug_file, "****************************************"
01153 "****************************************\n");
01154 dump_at_ntry(debug_file, AL_ATTR_IDX(al_idx), dump_all);
01155 al_idx = AL_NEXT_IDX(al_idx);
01156 }
01157
01158 fprintf(debug_file, "****************************************"
01159 "****************************************\n");
01160
01161 if (print_all_scps) {
01162
01163 if (SCP_FIRST_CHILD_IDX(scp_idx) != NULL_IDX) {
01164 save_scp_idx = scp_idx;
01165 scp_idx = SCP_FIRST_CHILD_IDX(scp_idx);
01166 print_sytb(scp_idx, TRUE, TRUE);
01167 scp_idx = save_scp_idx;
01168 }
01169
01170 if (SCP_SIBLING_IDX(scp_idx) != NULL_IDX) {
01171 scp_idx = SCP_SIBLING_IDX(scp_idx);
01172 goto PROCESS_SIBLING;
01173 }
01174
01175 #if 0
01176 fprintf(debug_file, "**name pool***************\n");
01177 for(al_idx = 0; al_idx<=300;al_idx++)
01178 fprintf(debug_file,"%s\n",&name_pool[al_idx].name_char);
01179 #endif
01180 }
01181
01182 return;
01183
01184 }
01185
01186
01187
01188
01189
01190
01191
01192
01193
01194
01195
01196
01197
01198
01199
01200
01201
01202 void print_compressed_sytb(int ln_start,
01203 int ln_end)
01204 {
01205 int ln_idx;
01206
01207 print_tbl_header("Compressed Symbol Table");
01208
01209 for (ln_idx = ln_start; ln_idx <= ln_end; ln_idx++) {
01210 dump_ln_ntry(debug_file, ln_idx, TRUE);
01211 }
01212
01213 putc ('\n', debug_file);
01214 fflush (debug_file);
01215
01216 return;
01217
01218 }
01219
01220
01221
01222
01223
01224
01225
01226
01227
01228
01229
01230
01231
01232
01233
01234
01235
01236
01237
01238
01239
01240
01241
01242
01243
01244
01245 void print_al (int al_idx)
01246
01247 {
01248 if (al_idx <= attr_list_tbl_idx) {
01249 dump_al_ntry(stderr, al_idx);
01250 }
01251 else {
01252 fprintf(stderr, "\n*FE90-ERROR* Invalid Attribute List Table index.\n");
01253 }
01254
01255 return;
01256
01257 }
01258
01259
01260
01261
01262
01263
01264
01265 void print_at(int at_idx)
01266
01267 {
01268
01269 if (at_idx <= attr_tbl_idx) {
01270 dump_at_ntry(stderr, at_idx, FALSE);
01271 }
01272 else {
01273 fprintf(stderr, "\n*FE90-ERROR* Invalid Attribute Table index.\n");
01274 }
01275
01276 return;
01277
01278 }
01279
01280
01281
01282
01283
01284
01285
01286 void print_at_all(int at_idx)
01287
01288 {
01289 if (at_idx <= attr_tbl_idx) {
01290 dump_at_ntry(stderr, at_idx, TRUE);
01291 }
01292 else {
01293 fprintf(stderr, "\n*FE90-ERROR* Invalid Attribute Table index.\n");
01294 }
01295
01296 return;
01297
01298 }
01299
01300
01301
01302
01303
01304
01305
01306 void print_bd (int bd_idx)
01307
01308 {
01309 if (bd_idx <= bounds_tbl_idx) {
01310 dump_bd_ntry(stderr, bd_idx);
01311 }
01312 else {
01313 fprintf(stderr, "\n*FE90-ERROR* Invalid bounds table index.\n");
01314 }
01315
01316 return;
01317
01318 }
01319
01320
01321
01322
01323
01324
01325
01326 void print_blk (int blk_idx)
01327
01328 {
01329 if (blk_idx <= blk_stk_idx) {
01330 dump_blk_ntry(stderr, blk_idx);
01331 }
01332 else {
01333 fprintf(stderr, "\n*FE90-ERROR* Invalid block stack index.\n");
01334 }
01335
01336 return;
01337
01338 }
01339
01340
01341
01342
01343
01344
01345
01346 void print_cn (int cn_idx)
01347
01348 {
01349 if (cn_idx <= const_tbl_idx) {
01350 dump_cn_ntry(stderr, cn_idx);
01351 }
01352 else {
01353 fprintf(stderr, "\n*FE90-ERROR* Invalid constant table index.\n");
01354 }
01355
01356 return;
01357
01358 }
01359
01360
01361
01362
01363
01364
01365
01366 void print_eq (int eq_idx)
01367
01368 {
01369
01370 if (eq_idx <= equiv_tbl_idx) {
01371 dump_eq_ntry(stderr, eq_idx);
01372 }
01373 else {
01374 fprintf(stderr, "\n*FE90-ERROR* Invalid equivalence table index.\n");
01375 }
01376
01377 return;
01378
01379 }
01380
01381
01382
01383
01384
01385
01386
01387 void print_fp (int fp_idx)
01388
01389 {
01390 if (fp_idx <= file_path_tbl_idx) {
01391 dump_fp_ntry(stderr, fp_idx, FALSE);
01392 }
01393 else {
01394 fprintf(stderr, "\n*FE90-ERROR* Invalid file path table index.\n");
01395 }
01396
01397 return;
01398
01399 }
01400
01401
01402
01403
01404
01405
01406
01407 void print_il (int il_idx)
01408
01409 {
01410 if (il_idx <= ir_list_tbl_idx) {
01411 dump_il_ntry(stderr, il_idx);
01412 }
01413 else {
01414 fprintf(stderr, "\n*FE90-ERROR* Invalid ir list table index %d.\n",
01415 il_idx);
01416 }
01417
01418 return;
01419 }
01420
01421
01422
01423
01424
01425
01426
01427 void print_ir (int ir_idx)
01428
01429 {
01430 if (ir_idx <= ir_tbl_idx) {
01431 dump_ir_ntry(stderr, ir_idx, 1);
01432 }
01433 else {
01434 fprintf(stderr, "\n*FE90-ERROR* Invalid ir table index.\n");
01435 }
01436
01437 return;
01438
01439 }
01440
01441
01442
01443
01444
01445
01446
01447 void print_ga (int ga_idx)
01448
01449 {
01450 if (ga_idx <= global_attr_tbl_idx) {
01451 dump_ga_ntry(stderr, ga_idx);
01452 }
01453 else {
01454 fprintf(stderr, "\n*FE90-ERROR* Invalid global attr table index.\n");
01455 }
01456
01457 return;
01458
01459 }
01460
01461
01462
01463
01464
01465
01466
01467 void print_gb (int gb_idx)
01468
01469 {
01470 if (gb_idx <= global_bounds_tbl_idx) {
01471 dump_gb_ntry(stderr, gb_idx);
01472 }
01473 else {
01474 fprintf(stderr, "\n*FE90-ERROR* Invalid global bounds table index.\n");
01475 }
01476
01477 return;
01478
01479 }
01480
01481
01482
01483
01484
01485
01486
01487 void print_gl (int gl_idx)
01488
01489 {
01490 if (gl_idx <= global_line_tbl_idx) {
01491 dump_gl_ntry(stderr, gl_idx);
01492 }
01493 else {
01494 fprintf(stderr, "\n*FE90-ERROR* Invalid global name table index.\n");
01495 }
01496
01497 return;
01498
01499 }
01500
01501
01502
01503
01504
01505
01506
01507 void print_gn (int gn_idx)
01508
01509 {
01510 if (gn_idx <= global_name_tbl_idx) {
01511 dump_gn_ntry(stderr, gn_idx);
01512 }
01513 else {
01514 fprintf(stderr, "\n*FE90-ERROR* Invalid global name table index.\n");
01515 }
01516
01517 return;
01518
01519 }
01520
01521
01522
01523
01524
01525
01526
01527 void print_gt (int gt_idx)
01528
01529 {
01530 if (gt_idx <= global_type_tbl_idx) {
01531 dump_gt_ntry(stderr, gt_idx);
01532 }
01533 else {
01534 fprintf(stderr, "\n*FE90-ERROR* Invalid global type table index.\n");
01535 }
01536
01537 return;
01538
01539 }
01540
01541
01542
01543
01544
01545
01546
01547 void print_hn (int hn_idx)
01548 {
01549
01550 if (hn_idx <= hidden_name_tbl_idx) {
01551 dump_hn_ntry(stderr, hn_idx, FALSE);
01552 }
01553 else {
01554 fprintf(stderr, "\n*FE90-ERROR* Invalid hidden name table index.\n");
01555 }
01556
01557 return;
01558
01559 }
01560
01561
01562
01563
01564
01565
01566
01567 void print_ln (int ln_idx)
01568 {
01569 if (ln_idx <= loc_name_tbl_idx) {
01570 dump_ln_ntry(stderr, ln_idx, FALSE);
01571 }
01572 else {
01573 fprintf(stderr, "\n*FE90-ERROR* Invalid local name table index.\n");
01574 }
01575
01576 return;
01577
01578 }
01579
01580
01581
01582
01583
01584
01585
01586 void print_lnr (int ln_idx,
01587 int end_idx)
01588 {
01589 while (ln_idx <= end_idx) {
01590
01591 if (ln_idx <= loc_name_tbl_idx) {
01592 dump_ln_ntry(stderr, ln_idx, FALSE);
01593 }
01594 else {
01595 fprintf(stderr, "\n*FE90-ERROR* Invalid local name table index.\n");
01596 }
01597 ++ln_idx;
01598 }
01599
01600 return;
01601
01602 }
01603
01604
01605
01606
01607
01608
01609
01610 void print_ml (int ml_idx)
01611
01612 {
01613 if (ml_idx <= mod_link_tbl_idx) {
01614 dump_ml_ntry(stderr, ml_idx);
01615 }
01616 else {
01617 fprintf(stderr, "\n*FE90-ERROR* Invalid module link table index.\n");
01618 }
01619
01620 return;
01621
01622 }
01623
01624
01625
01626
01627
01628
01629
01630 void print_ro (int ro_idx)
01631
01632 {
01633 if (ro_idx <= rename_only_tbl_idx) {
01634 dump_ro_ntry(stderr, ro_idx);
01635 }
01636 else {
01637 fprintf(stderr, "\n*FE90-ERROR* Invalid rename only table index.\n");
01638 }
01639
01640 return;
01641
01642 }
01643
01644
01645
01646
01647
01648
01649
01650 void print_sb (int sb_idx)
01651
01652 {
01653 if (sb_idx <= stor_blk_tbl_idx) {
01654 dump_sb_ntry(stderr, sb_idx);
01655 }
01656 else {
01657 fprintf(stderr, "\n*FE90-ERROR* Invalid Storage Block Table index.\n");
01658 }
01659
01660 return;
01661
01662 }
01663
01664
01665
01666
01667
01668
01669
01670 void print_scp(int scp_idx,
01671 boolean print_impl_tbl)
01672
01673 {
01674 if (scp_idx <= scp_tbl_idx) {
01675 dump_scp_ntry(stderr, scp_idx, 0, print_impl_tbl, FALSE);
01676 }
01677 else {
01678 fprintf(stderr, "\n*FE90-ERROR* Invalid scope table index.\n");
01679 }
01680
01681 return;
01682
01683 }
01684
01685
01686
01687
01688
01689
01690
01691 void print_sh (int stmt_idx)
01692
01693 {
01694 int save_curr_stmt_sh_idx;
01695
01696
01697 if (stmt_idx <= sh_tbl_idx) {
01698 save_curr_stmt_sh_idx = curr_stmt_sh_idx;
01699 curr_stmt_sh_idx = stmt_idx;
01700
01701 dump_stmt_ntry(stderr, TRUE);
01702
01703 curr_stmt_sh_idx = save_curr_stmt_sh_idx;
01704 }
01705 else {
01706 fprintf(stderr, "\n*FE90-ERROR* Invalid statement header index.\n");
01707 }
01708
01709 return;
01710
01711 }
01712
01713
01714
01715
01716
01717
01718
01719 void print_sn (int sn_idx)
01720
01721 {
01722 dump_sn_ntry(stderr, sn_idx);
01723
01724 return;
01725
01726 }
01727
01728
01729
01730
01731
01732
01733
01734 void print_typ (int type_idx)
01735
01736 {
01737 dump_typ_ntry(stderr, type_idx);
01738
01739 return;
01740
01741 }
01742
01743
01744
01745
01746
01747
01748
01749
01750
01751
01752
01753
01754
01755
01756
01757
01758
01759
01760
01761
01762
01763 void print_dv (int_dope_type *dv,
01764 boolean dump_it)
01765
01766 {
01767 dump_dv(stderr, dv, dump_it);
01768
01769 return;
01770
01771 }
01772
01773
01774
01775
01776
01777
01778
01779
01780
01781
01782
01783
01784
01785
01786
01787
01788
01789
01790 void print_ln_by_name (void)
01791
01792 {
01793 char name_string[MAX_ID_LEN + 1];
01794 int ln_tbl_idx;
01795
01796
01797 printf("Enter LOCAL name->");
01798 gets(name_string);
01799 build_fake_token(name_string);
01800
01801 if (srch_sym_tbl(TOKEN_STR(fake_token), TOKEN_LEN(fake_token),
01802 &ln_tbl_idx) != NULL_IDX) {
01803 dump_ln_ntry(stderr, ln_tbl_idx, FALSE);
01804 }
01805 else {
01806 fprintf(stderr, "\n*FE90-ERROR* No such name in the current scope.");
01807 }
01808 return;
01809
01810 }
01811
01812
01813
01814
01815
01816
01817
01818
01819
01820
01821
01822
01823
01824
01825
01826
01827
01828
01829
01830
01831
01832
01833
01834
01835
01836 void print_at_by_name(void)
01837
01838 {
01839 int attr_idx;
01840 int ln_tbl_idx;
01841 char name_string[MAX_ID_LEN + 1];
01842 char reply;
01843
01844 printf("Entity name->");
01845 gets(name_string);
01846
01847
01848
01849 build_fake_token(name_string);
01850 attr_idx = srch_sym_tbl(TOKEN_STR(fake_token), TOKEN_LEN(fake_token),
01851 &ln_tbl_idx);
01852
01853 if (attr_idx != NULL_IDX) {
01854 dump_at_ntry(stderr, attr_idx, FALSE);
01855 }
01856 else {
01857 printf(
01858 "\n*POSSIBLE FE90-ERROR* No such entity name in the local scope.\n");
01859 printf("Search host scope? (y) ");
01860 reply = getchar();
01861
01862 if (reply == '\n' || reply == 'y') {
01863
01864 if (reply == 'y') {
01865 reply = getchar();
01866 }
01867 attr_idx = srch_host_sym_tbl(TOKEN_STR(fake_token),
01868 TOKEN_LEN(fake_token),
01869 &ln_tbl_idx,
01870 TRUE);
01871
01872 if (attr_idx != NULL_IDX) {
01873 dump_at_ntry(stderr, attr_idx, FALSE);
01874 }
01875 else {
01876 printf("\n*FE90-ERROR* No such entity name in the host either.\n");
01877 }
01878 }
01879 else {
01880 reply = getchar();
01881 }
01882 }
01883
01884 return;
01885
01886 }
01887
01888
01889
01890
01891
01892
01893
01894
01895
01896
01897
01898
01899
01900
01901
01902
01903
01904
01905
01906 void print_sb_by_name (void)
01907
01908 {
01909 int sb_idx;
01910 char name_string[MAX_ID_LEN + 1];
01911
01912 printf("Enter common block or module name->");
01913 gets(name_string);
01914
01915 if (strlen(name_string) > 0) {
01916 build_fake_token(name_string);
01917 }
01918 else {
01919 build_fake_token("//");
01920 }
01921
01922 sb_idx = srch_stor_blk_tbl(TOKEN_STR(fake_token),
01923 TOKEN_LEN(fake_token),
01924 curr_scp_idx);
01925
01926 if (sb_idx != NULL_IDX) {
01927 dump_sb_ntry(stderr, sb_idx);
01928 }
01929 else {
01930 fprintf(stderr,"\n*FE90-ERROR* No such common block or module name.\n");
01931 }
01932
01933 return;
01934
01935 }
01936
01937
01938
01939
01940
01941
01942
01943
01944
01945
01946
01947
01948
01949
01950
01951
01952
01953 void print_al_list(FILE *out_file,
01954 int al_idx)
01955
01956 {
01957
01958 while (al_idx != NULL_IDX) {
01959 dump_al_ntry(out_file, al_idx);
01960 al_idx = AL_NEXT_IDX(al_idx);
01961 }
01962
01963 return;
01964
01965 }
01966
01967
01968
01969
01970
01971
01972
01973
01974
01975
01976
01977
01978
01979
01980
01981
01982
01983
01984
01985 void print_sn_list (int attr_idx)
01986
01987 {
01988 if (attr_idx > attr_tbl_idx) {
01989 fprintf(stderr,
01990 "\n*FE90-ERROR* Attribute entry index [%d] is too large.\n",
01991 attr_idx);
01992 return;
01993 }
01994
01995
01996
01997
01998
01999
02000 if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit &&
02001 Pgm_Unknown < ATP_PGM_UNIT(attr_idx) < Program) {
02002 loop_thru_sn_ntries(stderr, attr_idx, FALSE);
02003 }
02004 else if (AT_OBJ_CLASS(attr_idx) == Interface ||
02005 AT_OBJ_CLASS(attr_idx) == Namelist_Grp ||
02006 AT_OBJ_CLASS(attr_idx) == Derived_Type) {
02007 chain_thru_sn_ntries(stderr, attr_idx, FALSE);
02008 }
02009 else {
02010 fprintf(stderr,
02011 "\n*FE90-ERROR* %s can not have Secondary Name table entries.\n",
02012 &name_pool[AT_NAME_IDX(attr_idx)].name_char);
02013 }
02014 return;
02015
02016 }
02017
02018
02019
02020
02021
02022
02023
02024
02025
02026
02027
02028
02029
02030
02031
02032
02033
02034 void print_fp_includes (void)
02035
02036 {
02037 int fp_idx;
02038
02039 fp_idx = include_path_idx;
02040
02041 while (fp_idx != NULL_IDX) {
02042 fprintf(debug_file, "%4s%-s\n", " ", FP_NAME_PTR(fp_idx));
02043
02044 fp_idx = FP_NEXT_FILE_IDX(fp_idx);
02045 }
02046
02047 fflush(debug_file);
02048
02049 return;
02050
02051 }
02052
02053
02054
02055
02056
02057
02058
02059
02060
02061
02062
02063
02064
02065
02066
02067
02068
02069
02070
02071 void print_name(int idx)
02072 {
02073
02074 fprintf(stderr, "%d is %s\n", idx, AT_OBJ_NAME_PTR(idx));
02075
02076 return;
02077
02078 }
02079
02080
02081
02082
02083
02084
02085
02086
02087
02088
02089
02090
02091
02092
02093
02094
02095
02096
02097
02098
02099
02100
02101 static void loop_thru_sn_ntries (FILE *out_file,
02102 int attr_idx,
02103 boolean output_attr)
02104
02105 {
02106 int count;
02107 int first_idx;
02108 int i;
02109
02110
02111 if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {
02112 first_idx = ATP_FIRST_IDX(attr_idx);
02113 count = ATP_NUM_DARGS(attr_idx);
02114
02115 if (first_idx == NULL_IDX) {
02116 fprintf(out_file, "\n %s\n",
02117 " ** No Dummy Arguments - ATP_FIRST_IDX = 0.");
02118 return;
02119 }
02120 }
02121 else {
02122 first_idx = ATP_FIRST_IDX(attr_idx);
02123 count = ATP_NUM_DARGS(attr_idx);
02124
02125 if (first_idx == NULL_IDX) {
02126 fprintf(out_file, "\n %s\n",
02127 " ** No Dummy Arguments - ATP_FIRST_IDX = 0.");
02128 return;
02129 }
02130 }
02131
02132 fprintf(out_file, "\n %s %s:\n\n",
02133 "Dummy Arguments for",
02134 &name_pool[AT_NAME_IDX(attr_idx)].name_char);
02135
02136 for (i = first_idx;
02137 i < (first_idx + count);
02138 i++) {
02139
02140 dump_sn_ntry(out_file, i);
02141
02142 if (output_attr) {
02143 putc('\n', out_file);
02144 dump_at_ntry(out_file, SN_ATTR_IDX(i), FALSE);
02145 }
02146 else if (AT_OBJ_CLASS(SN_ATTR_IDX(i)) == Data_Obj &&
02147 ATD_CLASS(SN_ATTR_IDX(i)) == Dummy_Argument) {
02148
02149 fprintf(out_file, " %-16s= %-7d %-16s= %-7s %-16s= %-8d\n",
02150 "ATD_ARRAY_IDX", ATD_ARRAY_IDX(SN_ATTR_IDX(i)),
02151 "ATD_POINTER", boolean_str[ATD_POINTER(SN_ATTR_IDX(i))],
02152 "ATD_TYPE_IDX", ATD_TYPE_IDX(SN_ATTR_IDX(i)));
02153
02154 # ifdef COARRAY_FORTRAN
02155 fprintf(out_file, " %-16s= %-7d \n",
02156 "ATD_PE_ARRAY_IDX", ATD_PE_ARRAY_IDX(SN_ATTR_IDX(i)));
02157 # endif
02158
02159
02160 putc('\n', out_file);
02161 }
02162 else if (AT_OBJ_CLASS(SN_ATTR_IDX(i)) == Pgm_Unit &&
02163 ATP_PROC(SN_ATTR_IDX(i)) == Dummy_Proc) {
02164 fprintf(out_file, " %-25s\n", "Dummy_Proc");
02165 putc('\n', out_file);
02166 }
02167 else {
02168 putc('\n', out_file);
02169 }
02170 }
02171
02172 fflush(out_file);
02173
02174 return;
02175
02176 }
02177
02178
02179
02180
02181
02182
02183
02184
02185
02186
02187
02188
02189
02190
02191
02192
02193
02194
02195
02196
02197
02198
02199 static void chain_thru_sn_ntries (FILE *out_file,
02200 int attr_idx,
02201 boolean output_attr)
02202
02203 {
02204 char conv_str[80];
02205 int first_idx;
02206 int i;
02207 int idx;
02208 char str[80];
02209
02210
02211
02212 if (AT_OBJ_CLASS(attr_idx) == Derived_Type) {
02213 first_idx = ATT_FIRST_CPNT_IDX(attr_idx);
02214
02215 if (first_idx == NULL_IDX) {
02216 fprintf(out_file, "\n %s\n",
02217 "** No Secondary Name table entries - ATT_FIRST_CPNT_IDX = 0");
02218 return;
02219 }
02220 fprintf(out_file, "\n %s %s:\n\n",
02221 "Component entries for",
02222 &name_pool[AT_NAME_IDX(attr_idx)].name_char);
02223 }
02224 else if (AT_OBJ_CLASS(attr_idx) == Interface) {
02225 first_idx = ATI_FIRST_SPECIFIC_IDX(attr_idx);
02226
02227 if (first_idx == NULL_IDX) {
02228 fprintf(out_file, "\n %s\n",
02229 "** No Secondary Name table entries - ATI_FIRST_SPECIFIC_IDX = 0");
02230 return;
02231 }
02232 fprintf(out_file, "\n %s %s:\n\n",
02233 "Interface bodies for",
02234 &name_pool[AT_NAME_IDX(attr_idx)].name_char);
02235 }
02236 else if (AT_OBJ_CLASS(attr_idx) == Namelist_Grp) {
02237 first_idx = ATN_FIRST_NAMELIST_IDX(attr_idx);
02238
02239 if (first_idx == NULL_IDX) {
02240 fprintf(out_file, "\n %s\n",
02241 " ** No Secondary Name table entries - ATN_FIRST_NAMELIST_IDX = 0");
02242 return;
02243 }
02244 fprintf(out_file, "\n %s %s:\n\n",
02245 "Namelist objects for",
02246 &name_pool[AT_NAME_IDX(attr_idx)].name_char);
02247 }
02248 else {
02249 fprintf(out_file, "\n %s %s:\n\n",
02250 "Invalid attribute entry ",
02251 &name_pool[AT_NAME_IDX(attr_idx)].name_char);
02252 return;
02253 }
02254
02255 for (i = first_idx; i != NULL_IDX; i = SN_SIBLING_LINK(i)) {
02256 dump_sn_ntry(out_file, i);
02257
02258 if (output_attr) {
02259 putc('\n', out_file);
02260 dump_at_ntry(out_file, SN_ATTR_IDX(i), FALSE);
02261
02262 }
02263 else if (AT_OBJ_CLASS(attr_idx) == Interface &&
02264 AT_OBJ_CLASS(SN_ATTR_IDX(i)) == Pgm_Unit) {
02265
02266 fprintf(out_file, " %-25s %-16s= %-7d %-16s= %-8d\n",
02267 atp_pgm_unit_str[ATP_PGM_UNIT(SN_ATTR_IDX(i))],
02268 "ATP_FIRST_IDX", ATP_FIRST_IDX(SN_ATTR_IDX(i)),
02269 "ATP_NUM_DARGS", ATP_NUM_DARGS(SN_ATTR_IDX(i)));
02270
02271 if (ATP_PGM_UNIT(SN_ATTR_IDX(i)) == Function) {
02272 idx = ATP_RSLT_IDX(SN_ATTR_IDX(i));
02273 fprintf(out_file, " %-16s= %-7d %-16s= %-7s %-16s= %-8d\n",
02274 "ATD_ARRAY_IDX", ATD_ARRAY_IDX(idx),
02275 "ATD_POINTER", boolean_str[ATD_POINTER(idx)],
02276 "ATD_TYPE_IDX", ATD_TYPE_IDX(idx));
02277 }
02278
02279 if (ATP_FIRST_IDX(SN_ATTR_IDX(i)) != NULL_IDX) {
02280 loop_thru_sn_ntries(out_file, SN_ATTR_IDX(i), FALSE);
02281 }
02282
02283 putc('\n', out_file);
02284 }
02285 else if (AT_OBJ_CLASS(SN_ATTR_IDX(i)) == Data_Obj &&
02286 ATD_CLASS(SN_ATTR_IDX(i)) == Struct_Component) {
02287
02288 if (ATD_OFFSET_FLD(SN_ATTR_IDX(i)) == CN_Tbl_Idx ||
02289 ATD_OFFSET_FLD(SN_ATTR_IDX(i)) == NO_Tbl_Idx) {
02290 sprintf(str, "(%10s)", convert_to_string(
02291 &CN_CONST(ATD_CPNT_OFFSET_IDX(SN_ATTR_IDX(i))),
02292 CN_TYPE_IDX(ATD_CPNT_OFFSET_IDX(SN_ATTR_IDX(i))),
02293 conv_str));
02294 }
02295 else if (ATD_OFFSET_FLD(SN_ATTR_IDX(i)) == AT_Tbl_Idx) {
02296 sprintf(str, "(%10s)",
02297 AT_OBJ_NAME_PTR(ATD_CPNT_OFFSET_IDX(SN_ATTR_IDX(i))));
02298 }
02299 else {
02300 sprintf(str,"%12s", " ");
02301 }
02302
02303
02304 fprintf(out_file, " %-16s= %-7s %-16s= %-7d %-16s= %-7s\n",
02305 "ATD_ALIGNMENT", align_str[ATD_ALIGNMENT(SN_ATTR_IDX(i))],
02306 "ATD_ARRAY_IDX", ATD_ARRAY_IDX(SN_ATTR_IDX(i)),
02307 "AT_DCL_ERR", boolean_str[AT_DCL_ERR(SN_ATTR_IDX(i))]);
02308
02309 print_fld_idx(out_file, "ATD_CPNT_OFFSET_",
02310 ATD_OFFSET_FLD(SN_ATTR_IDX(i)),
02311 ATD_CPNT_OFFSET_IDX(SN_ATTR_IDX(i)));
02312
02313 fprintf(out_file, " %-16s= %-7s %-16s= %-7s \n",
02314 "ATD_IM_A_DOPE", boolean_str[ATD_IM_A_DOPE(SN_ATTR_IDX(i))],
02315 "ATD_POINTER", boolean_str[ATD_POINTER(SN_ATTR_IDX(i))]);
02316
02317 fprintf(out_file, " %-16s= %-7d %-s\n",
02318 "ATD_TYPE_IDX", ATD_TYPE_IDX(SN_ATTR_IDX(i)),
02319 print_type_f(ATD_TYPE_IDX(SN_ATTR_IDX(i))));
02320
02321 if (ATD_CPNT_INIT_IDX(SN_ATTR_IDX(i)) != NULL_IDX) {
02322 print_fld_idx(out_file, "ATD_CPNT_INIT_ID",
02323 (fld_type) ATD_FLD(SN_ATTR_IDX(i)),
02324 ATD_CPNT_INIT_IDX(SN_ATTR_IDX(i)));
02325
02326 if (ATD_FLD(SN_ATTR_IDX(i)) == IR_Tbl_Idx) {
02327 dump_ir_ntry(out_file, ATD_CPNT_INIT_IDX(SN_ATTR_IDX(i)), 5);
02328 }
02329 else if (ATD_FLD(SN_ATTR_IDX(i)) == CN_Tbl_Idx) {
02330 dump_cn_ntry(out_file, ATD_CPNT_INIT_IDX(SN_ATTR_IDX(i)));
02331 }
02332 }
02333
02334
02335 putc('\n', out_file);
02336 }
02337 }
02338
02339 fflush(out_file);
02340
02341 return;
02342
02343 }
02344
02345
02346
02347
02348
02349
02350
02351
02352
02353
02354
02355
02356
02357
02358
02359
02360
02361
02362
02363
02364
02365
02366
02367
02368 static void build_fake_token (char *name_string)
02369
02370 {
02371 int i;
02372 int len;
02373
02374
02375
02376
02377
02378 len = strlen(name_string);
02379 CREATE_ID(TOKEN_ID(fake_token), name_string, len);
02380
02381 TOKEN_LEN(fake_token) = len;
02382
02383 for (i = 0; i < len; i++) {
02384 TOKEN_STR(fake_token)[i] = toupper(TOKEN_STR(fake_token)[i]);
02385 }
02386
02387 return;
02388
02389 }
02390
02391
02392
02393
02394
02395
02396
02397
02398
02399
02400
02401
02402
02403
02404
02405
02406
02407
02408 void dump_func_trace_info (trace_type trace,
02409 char *func_name,
02410 char *info)
02411 {
02412
02413 if (trace_file == NULL) {
02414 trace_file = fopen (trace_file_name, "w");
02415
02416 if (trace_file == NULL) {
02417 PRINTMSG(1, 17, Error, 0, trace_file_name);
02418 exit_compiler(RC_USER_ERROR);
02419 }
02420
02421 fprintf (trace_file, "\nTRACE DUMP OF PROGRAM %s:\n\n", src_file);
02422 }
02423
02424 dump_trace_info(trace_file, trace, func_name, info);
02425
02426 return;
02427
02428 }
02429
02430
02431
02432
02433
02434
02435
02436
02437
02438
02439
02440
02441
02442
02443
02444
02445
02446
02447
02448 static void dump_trace_info (FILE *out_file,
02449 trace_type trace,
02450 char *func_name,
02451 char *info)
02452 {
02453
02454 int idx;
02455 char *indent_str;
02456
02457
02458 switch (trace) {
02459
02460 case Func_Entry:
02461 case Func_Exit:
02462 if (trace == Func_Exit) {
02463 trace_indent -= trace_indent_len;
02464
02465 if (trace_indent < 0) {
02466 trace_indent = 0;
02467 }
02468 }
02469
02470 indent_str = (char *) malloc (trace_indent+1);
02471
02472 for (idx = 0; idx < trace_indent; idx++) {
02473 indent_str[idx] = (idx % trace_indent_len == 0) ? '|' : BLANK;
02474 }
02475
02476 indent_str[idx] = NULL_CHAR;
02477
02478 if (trace == Func_Entry) {
02479 fprintf (out_file, "%sIN %s", indent_str, func_name);
02480 trace_indent += trace_indent_len;
02481 }
02482 else {
02483 fprintf (out_file, "%sOUT %s", indent_str, func_name);
02484 }
02485 if (info == NULL) {
02486 putc (NEWLINE, out_file);
02487 }
02488 else {
02489 fprintf (out_file, " (%s)\n", info);
02490 }
02491
02492 free (indent_str);
02493 indent_str = NULL;
02494 break;
02495
02496 case Syntax_Pass:
02497 fprintf(out_file, "\n> > > > > > > > > > B e g i n S y n t a x "
02498 " P a s s < < < < < < < < < <\n\n");
02499 trace_indent = 0;
02500 break;
02501
02502 case Semantics_Pass:
02503 fprintf(out_file, "\n> > > > > > > > B e g i n S e m a n t i c s"
02504 " P a s s < < < < < < < <\n\n");
02505 trace_indent = 0;
02506 break;
02507
02508 case PU_Start:
02509 if (info == NULL) {
02510 fprintf (out_file, "\n\n# NEW PROGRAM UNIT ########################"
02511 "####################################\n");
02512 }
02513 else {
02514 fprintf (out_file, "\n\n# NEW PROGRAM UNIT # %s ##################"
02515 "#######\n",
02516 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));
02517
02518 if (SCP_IN_ERR(curr_scp_idx)) {
02519 fprintf (out_file,
02520 "# # # SCP entry is marked in error # # #\n");
02521 }
02522 }
02523
02524 break;
02525
02526 case Stmt_Start:
02527 if (info == NULL) {
02528 fprintf (out_file, "\n- NEW STMT ---------------------------"
02529 "-----------------------------------------\n");
02530 }
02531 else {
02532 fprintf (out_file, "\n- %s%s - %d %s-------------------------"
02533 "-------------------------\n",
02534 (SH_COMPILER_GEN(curr_stmt_sh_idx)) ? "CG " : "",
02535 stmt_type_str[SH_STMT_TYPE(curr_stmt_sh_idx)],
02536 SH_GLB_LINE(curr_stmt_sh_idx),
02537 (SH_P2_SKIP_ME(curr_stmt_sh_idx)) ? "SKIP ME " :
02538 "--------");
02539
02540 if (SH_ERR_FLG(curr_stmt_sh_idx)) {
02541 fprintf (out_file,
02542 "\n* * * Stmt Header is marked in error * * *\n");
02543 }
02544 }
02545
02546 break;
02547
02548 }
02549
02550 return;
02551
02552 }
02553
02554
02555
02556
02557
02558
02559
02560
02561
02562
02563
02564
02565
02566
02567
02568
02569
02570
02571 void dump_mem_trace_info (trace_type trace,
02572 char *struct_name,
02573 void *new_struct_ptr,
02574 void *old_struct_ptr,
02575 long struct_bsize_or_num_used,
02576 int num_entries)
02577 {
02578 int idx;
02579 char *indent_str = NULL;
02580
02581
02582 if (trace_file == NULL) {
02583 trace_file = fopen (trace_file_name, "w");
02584
02585 if (trace_file == NULL) {
02586 PRINTMSG(1, 17, Error, 0, trace_file_name);
02587 exit_compiler(RC_USER_ERROR);
02588 }
02589
02590 fprintf (trace_file, "\nTRACE DUMP OF PROGRAM %s:\n\n", src_file);
02591 }
02592
02593 if (trace_indent > 0) {
02594 indent_str = (char *) malloc (trace_indent+1);
02595
02596 for (idx = 0; idx < trace_indent; idx++) {
02597 indent_str[idx] = (idx % trace_indent_len == 0) ? '|' : BLANK;
02598 }
02599
02600 indent_str[idx] = NULL_CHAR;
02601
02602 fprintf (trace_file, "%s", indent_str);
02603 }
02604
02605 switch (trace) {
02606 case Mem_Alloc:
02607 fprintf (trace_file, "ALLOC %s (%#o) BSIZE=%ld(%d ENTRIES)\n",
02608 struct_name, (uint) new_struct_ptr,
02609 struct_bsize_or_num_used, num_entries);
02610 break;
02611
02612 case Mem_Realloc:
02613 if (new_struct_ptr == old_struct_ptr) {
02614 fprintf (trace_file, "REALLOC %s (%#o) BSIZE=%ld(%d ENTRIES)\n",
02615 struct_name, (uint) new_struct_ptr,
02616 struct_bsize_or_num_used, num_entries);
02617 }
02618 else {
02619 fprintf (trace_file, "REALLOC/MOVE %s (%#o->%#o) "
02620 "BSIZE=%ld(%d ENTRIES)\n",
02621 struct_name, (uint) old_struct_ptr, (uint) new_struct_ptr,
02622 struct_bsize_or_num_used, num_entries);
02623 }
02624 break;
02625
02626 case Mem_Free:
02627 fprintf (trace_file, "FREE %s (%#o) (%d ENTRIES) "
02628 "(%ld USED ENTRIES)\n",
02629 struct_name,
02630 (uint) new_struct_ptr,
02631 num_entries,
02632 struct_bsize_or_num_used);
02633 break;
02634
02635 case Mem_Compress:
02636 fprintf (trace_file, "COMPRESS %s (%ld BEFORE ENTRIES) "
02637 "(%d AFTER ENTRIES)\n",
02638 struct_name,
02639 struct_bsize_or_num_used,
02640 num_entries);
02641 break;
02642 }
02643
02644 if (indent_str != NULL) {
02645 free (indent_str);
02646 indent_str = NULL;
02647 }
02648
02649 return;
02650
02651 }
02652
02653
02654
02655
02656
02657
02658
02659
02660
02661
02662
02663
02664
02665
02666
02667
02668 void print_mem_usage_report(char *name,
02669 int final_size,
02670 int largest_idx)
02671
02672 {
02673
02674 static boolean first_call = TRUE;
02675
02676 print_tbl_header("Memory Report");
02677
02678 if (first_call == TRUE) {
02679 first_call = FALSE;
02680
02681
02682
02683 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02684 "attr_list_tbl",
02685 "init size", attr_list_tbl_init_size,
02686 "increment", attr_list_tbl_inc,
02687 "num words", attr_list_tbl_num_wds);
02688 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02689 "attr_tbl",
02690 "init size", attr_tbl_init_size,
02691 "increment", attr_tbl_inc,
02692 "num words", attr_tbl_num_wds);
02693 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02694 "blk_stk",
02695 "init size", blk_stk_init_size,
02696 "increment", blk_stk_inc,
02697 "num words", blk_stk_num_wds);
02698 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02699 "bounds_tbl",
02700 "init size", bounds_tbl_init_size,
02701 "increment", bounds_tbl_inc,
02702 "num words", bounds_tbl_num_wds);
02703 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02704 "const_tbl",
02705 "init size", const_tbl_init_size,
02706 "increment", const_tbl_inc,
02707 "num words", const_tbl_num_wds);
02708 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02709 "const_pool",
02710 "init size", const_pool_init_size,
02711 "increment", const_pool_inc,
02712 "num words", const_pool_num_wds);
02713 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02714 "equiv_tbl",
02715 "init size", equiv_tbl_init_size,
02716 "increment", equiv_tbl_inc,
02717 "num words", equiv_tbl_num_wds);
02718 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02719 "file_path_tbl",
02720 "init size", file_path_tbl_init_size,
02721 "increment", file_path_tbl_inc,
02722 "num words", file_path_tbl_num_wds);
02723 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02724 "global_line_tbl",
02725 "init size", global_line_tbl_init_size,
02726 "increment", global_line_tbl_inc,
02727 "num words", global_line_tbl_num_wds);
02728 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02729 "global_name_tbl",
02730 "init size", global_name_tbl_init_size,
02731 "increment", global_name_tbl_inc,
02732 "num words", global_name_tbl_num_wds);
02733 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02734 "hidden_name_tbl",
02735 "init size", hidden_name_tbl_init_size,
02736 "increment", hidden_name_tbl_inc,
02737 "num words", hidden_name_tbl_num_wds);
02738 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02739 "ir_tbl",
02740 "init size", ir_tbl_init_size,
02741 "increment", ir_tbl_inc,
02742 "num words", ir_tbl_num_wds);
02743 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02744 "ir_list_tbl",
02745 "init size", ir_list_tbl_init_size,
02746 "increment", ir_list_tbl_inc,
02747 "num words", ir_list_tbl_num_wds);
02748 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02749 "loc_name_tbl",
02750 "init size", loc_name_tbl_init_size,
02751 "increment", loc_name_tbl_inc,
02752 "num words", loc_name_tbl_num_wds);
02753 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02754 "mod_link_tbl",
02755 "init size", mod_link_tbl_init_size,
02756 "increment", mod_link_tbl_inc,
02757 "num words", mod_link_tbl_num_wds);
02758 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02759 "name_pool",
02760 "init size", name_pool_init_size,
02761 "increment", name_pool_inc,
02762 "num words", name_pool_num_wds);
02763 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02764 "rename_only_tbl",
02765 "init size", rename_only_tbl_init_size,
02766 "increment", rename_only_tbl_inc,
02767 "num words", rename_only_tbl_num_wds);
02768 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02769 "scp_tbl",
02770 "init size", scp_tbl_init_size,
02771 "increment", scp_tbl_inc,
02772 "num words", scp_tbl_num_wds);
02773 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02774 "sec_name_tbl",
02775 "init size", sec_name_tbl_init_size,
02776 "increment", sec_name_tbl_inc,
02777 "num words", sec_name_tbl_num_wds);
02778 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02779 "sh_tbl",
02780 "init size", sh_tbl_init_size,
02781 "increment", sh_tbl_inc,
02782 "num words", sh_tbl_num_wds);
02783 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02784 "stor_blk_tbl",
02785 "init size", stor_blk_tbl_init_size,
02786 "increment", stor_blk_tbl_inc,
02787 "num words", stor_blk_tbl_num_wds);
02788 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02789 "str_pool",
02790 "init size", str_pool_init_size,
02791 "increment", str_pool_inc,
02792 "num words", str_pool_num_wds);
02793 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d %-9s= %-7d\n",
02794 "type_tbl",
02795 "init size", type_tbl_init_size,
02796 "increment", type_tbl_inc,
02797 "num words", type_tbl_num_wds);
02798 print_src_input_tbls();
02799 }
02800
02801
02802 fprintf (debug_file, "%-20s %-9s= %-8d %-9s= %-6d\n",
02803 name,
02804 "finalsize", final_size,
02805 "large idx", largest_idx);
02806
02807 fflush (debug_file);
02808 return;
02809
02810 }
02811
02812
02813
02814
02815
02816
02817
02818
02819
02820
02821
02822
02823
02824
02825
02826
02827
02828
02829 void print_defines(void)
02830
02831 {
02832
02833 print_tbl_header("Compiler Defines Dump");
02834
02835 # ifdef _PVP_PVP
02836 fprintf(debug_file, "\t\t\t_PVP_PVP\n");
02837 # endif
02838
02839 # ifdef _MPP_MPP
02840 fprintf(debug_file, "\t\t\t_MPP_MPP\n");
02841 # endif
02842
02843 # ifdef _SOLARIS_SOLARIS
02844 fprintf(debug_file, "\t\t\t_SOLARIS_SOLARIS\n");
02845 # endif
02846
02847 # ifdef _SOLARIS_MPP
02848 fprintf(debug_file, "\t\t\t_SOLARIS_MPP\n");
02849 # endif
02850
02851 # ifdef _SOLARIS_PVP
02852 fprintf(debug_file, "\t\t\t_SOLARIS_PVP\n");
02853 # endif
02854
02855 # ifdef _PVP_MPP
02856 fprintf(debug_file, "\t\t\t_PVP_MPP\n");
02857 # endif
02858
02859 fprintf(debug_file, "\n");
02860
02861 # ifdef _PDGCS
02862 fprintf(debug_file, "\t\t\t_PDGCS\n");
02863 # endif
02864
02865 # ifdef _HOST32
02866 fprintf(debug_file, "\t\t\t_HOST32\n");
02867 # endif
02868
02869 # ifdef _HOST64
02870 fprintf(debug_file, "\t\t\t_HOST64\n");
02871 # endif
02872
02873 # ifdef _TARGET32
02874 fprintf(debug_file, "\t\t\t_TARGET32\n");
02875 # endif
02876
02877 # ifdef _TARGET64
02878 fprintf(debug_file, "\t\t\t_TARGET64\n");
02879 # endif
02880
02881 # if defined(_HOST_OS_IRIX)
02882 fprintf(debug_file, "\t\t\t_HOST_OS_IRIX\n");
02883 # endif
02884
02885 # if defined(_HOST_OS_LINUX)
02886 fprintf(debug_file, "\t\t\t_HOST_OS_LINUX\n");
02887 # endif
02888
02889 # ifdef _HOST_OS_MAX
02890 fprintf(debug_file, "\t\t\t_HOST_OS_MAX\n");
02891 # endif
02892
02893 # ifdef _HOST_OS_SOLARIS
02894 fprintf(debug_file, "\t\t\t_HOST_OS_SOLARIS\n");
02895 # endif
02896
02897 # ifdef _HOST_OS_UNICOS
02898 fprintf(debug_file, "\t\t\t_HOST_OS_UNICOS\n");
02899 # endif
02900
02901
02902 # if defined(_TARGET_OS_IRIX)
02903 fprintf(debug_file, "\t\t\t_TARGET_OS_IRIX\n");
02904 # endif
02905
02906 # if defined(_TARGET_OS_LINUX)
02907 fprintf(debug_file, "\t\t\t_TARGET_OS_LINUX\n");
02908 # endif
02909
02910 # ifdef _TARGET_OS_MAX
02911 fprintf(debug_file, "\t\t\t_TARGET_OS_MAX\n");
02912 # endif
02913
02914 # ifdef _TARGET_OS_SOLARIS
02915 fprintf(debug_file, "\t\t\t_TARGET_OS_SOLARIS\n");
02916 # endif
02917
02918 # ifdef _TARGET_OS_UNICOS
02919 fprintf(debug_file, "\t\t\t_TARGET_OS_UNICOS\n");
02920 # endif
02921
02922 # ifdef _TARGET_SV2
02923 fprintf(debug_file, "\t\t\t_TARGET_SV2\n");
02924 # endif
02925
02926 # ifdef _TARGET_IEEE
02927 fprintf(debug_file, "\t\t\t_TARGET_IEEE\n");
02928 # endif
02929
02930 # ifdef _TARGET_BYTE_ADDRESS
02931 fprintf(debug_file, "\t\t\t_TARGET_BYTE_ADDRESS\n");
02932 # endif
02933
02934 # ifdef _TARGET_WORD_ADDRESS
02935 fprintf(debug_file, "\t\t\t_TARGET_WORD_ADDRESS\n");
02936 # endif
02937
02938 # ifdef _HEAP_REQUEST_IN_BYTES
02939 fprintf(debug_file, "\t\t\t_HEAP_REQUEST_IN_BYTES\n");
02940 # endif
02941
02942 # ifdef _HEAP_REQUEST_IN_WORDS
02943 fprintf(debug_file, "\t\t\t_HEAP_REQUEST_IN_WORDS\n");
02944 # endif
02945
02946 # ifdef _MODULE_DOT_TO_o
02947 fprintf(debug_file, "\t\t\t_MODULE_DOT_TO_o\n");
02948 # endif
02949
02950 # ifdef _MODULE_DOT_TO_M
02951 fprintf(debug_file, "\t\t\t_MODULE_DOT_TO_M\n");
02952 # endif
02953
02954 # ifdef _MODULE_DOT_TO_mod
02955 fprintf(debug_file, "\t\t\t_MODULE_DOT_TO_mod\n");
02956 # endif
02957
02958 # ifdef _ARITH_INPUT_CONV
02959 fprintf(debug_file, "\t\t\t_ARITH_INPUT_CONV\n");
02960 # endif
02961
02962 # ifdef _ARITH_H
02963 fprintf(debug_file, "\t\t\t_ARITH_H\n");
02964 # endif
02965
02966 # ifdef _ALLOCATE_IS_CALL
02967 fprintf(debug_file, "\t\t\t_ALLOCATE_IS_CALL\n");
02968 # endif
02969
02970 # ifdef _SEPARATE_FUNCTION_RETURNS
02971 fprintf(debug_file, "\t\t\t_SEPARATE_FUNCTION_RETURNS\n");
02972 # endif
02973
02974 # ifdef _TARGET_DOUBLE_ALIGN
02975 fprintf(debug_file, "\t\t\t_TARGET_DOUBLE_ALIGN\n");
02976 # endif
02977
02978 # ifdef _ERROR_DUPLICATE_GLOBALS
02979 fprintf(debug_file, "\t\t\t_ERROR_DUPLICATE_GLOBALS\n");
02980 # endif
02981
02982
02983 if (char_len_in_bytes) {
02984 fprintf(debug_file, "\t\t\t_CHAR_LEN_IN_BYTES\n");
02985 }
02986 # ifdef _NO_BINARY_OUTPUT
02987 fprintf(debug_file, "\t\t\t_NO_BINARY_OUTPUT\n");
02988 # endif
02989
02990 # ifdef _CHECK_MAX_MEMORY
02991 fprintf(debug_file, "\t\t\t_CHECK_MAX_MEMORY\n");
02992 # endif
02993
02994 # ifdef _TASK_COMMON_EXTENSION
02995 fprintf(debug_file, "\t\t\t_TASK_COMMON_EXTENSION\n");
02996 # endif
02997
02998 # ifdef _TWO_WORD_FCD
02999 fprintf(debug_file, "\t\t\t_TWO_WORD_FCD\n");
03000 # endif
03001
03002 # ifdef _TRANSFORM_CHAR_SEQUENCE
03003 fprintf(debug_file, "\t\t\t_TRANSFORM_CHAR_SEQUENCE\n");
03004 # endif
03005
03006 # ifdef _TMP_GIVES_COMMON_LENGTH
03007 fprintf(debug_file, "\t\t\t_TMP_GIVES_COMMON_LENGTH\n");
03008 # endif
03009
03010 # ifdef _SPLIT_STATIC_STORAGE_2
03011 fprintf(debug_file, "\t\t\t_SPLIT_STATIC_STORAGE_2\n");
03012 # endif
03013
03014 # ifdef _SPLIT_STATIC_STORAGE_3
03015 fprintf(debug_file, "\t\t\t_SPLIT_STATIC_STORAGE_3\n");
03016 # endif
03017
03018 # ifdef _ALLOW_DATA_INIT_OF_COMMON
03019 fprintf(debug_file, "\t\t\t_ALLOW_DATA_INIT_OF_COMMON\n");
03020 # endif
03021
03022 # ifdef _FRONTEND_CONDITIONAL_COMP
03023 fprintf(debug_file, "\t\t\t_FRONTEND_CONDITIONAL_COMP\n");
03024 # endif
03025
03026
03027 fprintf(debug_file, "\n\n\t\t\tINTEGER_DEFAULT_TYPE\t%s\n",
03028 lin_type_str[INTEGER_DEFAULT_TYPE]);
03029
03030 fprintf(debug_file, "\t\t\tREAL_DEFAULT_TYPE\t%s\n",
03031 lin_type_str[REAL_DEFAULT_TYPE]);
03032
03033 fprintf(debug_file, "\t\t\tDOUBLE_DEFAULT_TYPE\t%s\n",
03034 lin_type_str[DOUBLE_DEFAULT_TYPE]);
03035
03036 fprintf(debug_file, "\t\t\tCOMPLEX_DEFAULT_TYPE\t%s\n",
03037 lin_type_str[COMPLEX_DEFAULT_TYPE]);
03038
03039 fprintf(debug_file, "\t\t\tLOGICAL_DEFAULT_TYPE\t%s\n",
03040 lin_type_str[LOGICAL_DEFAULT_TYPE]);
03041
03042 fprintf(debug_file, "\t\t\tTRUE_VALUE = %d\n", TRUE_VALUE);
03043 fprintf(debug_file, "\t\t\tFALSE_VALUE = %d\n", FALSE_VALUE);
03044
03045 if (target_triton) {
03046 fprintf(debug_file, "\n\t\t\ttarget_triton\n");
03047 }
03048
03049 if (target_ieee) {
03050 fprintf(debug_file, "\n\t\t\ttarget_ieee\n");
03051 }
03052
03053 if (char_len_in_bytes) {
03054 fprintf(debug_file, "\n\t\t\tchar_len_in_bytes\n");
03055 }
03056
03057 putc ('\n', debug_file);
03058 fflush(debug_file);
03059
03060 return;
03061
03062 }
03063
03064
03065
03066
03067
03068
03069
03070
03071
03072
03073
03074
03075
03076
03077
03078
03079
03080
03081 static void dump_dv(FILE *out_file,
03082 int_dope_type *dv,
03083 boolean dump_it)
03084
03085 {
03086 long *lptr;
03087 int k;
03088 int i;
03089 int idx;
03090 int dec_len = 0;
03091 int dp_flag = 0;
03092 int dv_type;
03093 int int_len = 0;
03094 int kind_star = 0;
03095 int type_idx;
03096 int num_chars;
03097 char *char_ptr;
03098
03099 # if 0
03100 char str[80];
03101 # endif
03102
03103
03104 if (dv == NULL) {
03105 fprintf(out_file, "\nDOPE VECTOR ADDRESS IS NULL\n\n");
03106 return;
03107 }
03108 #if defined(_HOST32) && defined(_TARGET64)
03109 fprintf(out_file, "base_addr = 0x%x\n", dv->base_addr);
03110 fprintf(out_file, "el_len = %d\n", dv->el_len);
03111 #else
03112 fprintf(out_file, "base_addr = 0x%" LONG_TYPE_X_FMT "\n", dv->base_addr);
03113 fprintf(out_file, "el_len = %" LONG_TYPE_FMT "\n", dv->el_len);
03114 #endif
03115 fprintf(out_file, "assoc = %d\n", dv->assoc);
03116 fprintf(out_file, "ptr_alloc = %d\n", dv->ptr_alloc);
03117 fprintf(out_file, "p_or_a = %s\n", (dv->p_or_a == 2 ? "ALLOCATABLE" :
03118 (dv->p_or_a == 1 ? "POINTER" : "OTHER")));
03119 fprintf(out_file, "a_contig = %s\n",
03120 (dv->a_contig == 1 ? "TRUE" : "FALSE"));
03121 fprintf(out_file, "unused_1 = %d\n", dv->unused_1);
03122 # if defined(_TARGET64)
03123 fprintf(out_file, "unused_2 = %d\n", dv->unused_2);
03124 # endif
03125 fprintf(out_file, "num_dims = %d\n", dv->num_dims);
03126
03127 # if 0
03128 dump_io_type_code_ntry(out_file, (long_type *)&(dv->type_code), 0);
03129 # endif
03130
03131 #if defined(_HOST32) && defined(_TARGET64)
03132 fprintf(out_file, "orig_base = 0x%x\n", dv->orig_base);
03133 fprintf(out_file, "orig_size = %d\n", dv->orig_size);
03134
03135 for(k = 0; k < (int)(dv->num_dims); k++) {
03136 fprintf(out_file, "low_bound[%d] = %d\n",k+1,
03137 dv->dim[k].low_bound);
03138 fprintf(out_file, "extent[%d] = %d\n",
03139 k+1, dv->dim[k].extent);
03140 fprintf(out_file, "stride_mult[%d] = %d\n\n",k+1,
03141 dv->dim[k].stride_mult);
03142 }
03143 #else
03144 fprintf(out_file, "orig_base = 0x%" LONG_TYPE_X_FMT "\n", dv->orig_base);
03145 fprintf(out_file, "orig_size = %" LONG_TYPE_FMT "\n", dv->orig_size);
03146
03147 for(k = 0; k < (int)(dv->num_dims); k++) {
03148 fprintf(out_file, "low_bound[%d] = %" LONG_TYPE_FMT "\n",k+1,
03149 dv->dim[k].low_bound);
03150 fprintf(out_file, "extent[%d] = %" LONG_TYPE_FMT "\n",
03151 k+1, dv->dim[k].extent);
03152 fprintf(out_file, "stride_mult[%d] = %" LONG_TYPE_FMT "\n\n",k+1,
03153 dv->dim[k].stride_mult);
03154 }
03155 #endif
03156
03157
03158 # if 0
03159 lptr = (long *)(dv->base_addr);
03160
03161 if (lptr != NULL &&
03162 dv->num_dims == 1 &&
03163 dump_it) {
03164
03165
03166
03167 if (dv_type == DV_ASCII_CHAR) {
03168
03169 char_ptr = (char *)(dv->base_addr);
03170
03171 idx = 0;
03172
03173 for (k = 0; k < dv->dim[0].extent; k++) {
03174 fprintf(out_file,"\"");
03175 for (i = 0; i < num_chars; i++) {
03176 fprintf(out_file, "%c", char_ptr[idx]);
03177 idx++;
03178 }
03179 fprintf(out_file,"\" ");
03180 }
03181 fprintf(out_file, "\n");
03182 }
03183 else {
03184
03185 for (k = 0; k < dv->dim[0].extent; k++) {
03186 #if 1
03187 fprintf(out_file, " %x ",
03188 lptr[num_host_wds[TYP_LINEAR(type_idx)] * k]);
03189 # else
03190
03191 fprintf(out_file, " %s ",
03192 convert_to_string(&(lptr[num_host_wds[TYP_LINEAR(type_idx)] * k]),
03193 type_idx,
03194 str));
03195 # endif
03196 }
03197 fprintf(out_file, "\n");
03198 }
03199 }
03200 # endif
03201
03202 return;
03203
03204 }
03205
03206
03207
03208
03209
03210
03211
03212
03213
03214
03215
03216
03217
03218
03219
03220
03221
03222 void print_so (size_offset_type so)
03223
03224 {
03225 char str[80];
03226
03227 switch(so.fld) {
03228
03229 case NO_Tbl_Idx:
03230 print_fld_idx(stderr, "Idx", (fld_type) so.fld, 0);
03231 fprintf(stderr, "Type = (%d) %s", so.type_idx,
03232 print_type_f(so.type_idx));
03233
03234 switch (TYP_TYPE(so.type_idx)) {
03235 case Typeless:
03236 convert_to_string_fmt = Hex_Fmt;
03237 fprintf(stderr,"0x%s",
03238 convert_to_string((long_type *)&(so.constant),
03239 so.type_idx, str));
03240
03241 if (TYP_BIT_LEN(so.type_idx) > TARGET_BITS_PER_WORD) {
03242 convert_to_string_fmt = Hex_Fmt;
03243 fprintf(stderr, " %s",
03244 convert_to_string((long_type *)&(so.constant[1]),
03245 so.type_idx, str));
03246 }
03247
03248 break;
03249
03250 case Integer:
03251 fprintf(stderr,"%s",
03252 convert_to_string((long_type *)&(so.constant),
03253 so.type_idx, str));
03254 break;
03255
03256 case Real:
03257 fprintf(stderr, "%s",
03258 convert_to_string((long_type *)&(so.constant),
03259 so.type_idx, str));
03260 break;
03261
03262 case Character:
03263 break;
03264
03265 case Logical:
03266 fprintf(stderr, "%s",
03267 (THIS_IS_TRUE((long_type *)&(so.constant), so.type_idx) ?
03268 ".TRUE." : ".FALSE."));
03269 break;
03270
03271 case Complex:
03272 fprintf(stderr, "%s",
03273 convert_to_string((long_type *)&(so.constant),
03274 so.type_idx, str));
03275 break;
03276 }
03277
03278 fprintf(stderr,"\n");
03279 break;
03280
03281 case CN_Tbl_Idx:
03282 print_fld_idx(stderr, "Idx", (fld_type) so.fld, so.idx);
03283 fprintf(stderr, "Constant = *Unset*\n");
03284
03285 print_const_entry(stderr, so.idx, 0);
03286 break;
03287
03288 case AT_Tbl_Idx:
03289 print_fld_idx(stderr, "Idx", (fld_type) so.fld, so.idx);
03290 fprintf(stderr, "Constant = *Unset*\n");
03291 print_attr_name(stderr, so.idx, 0);
03292 break;
03293
03294 case IR_Tbl_Idx:
03295 print_fld_idx(stderr, "Idx", (fld_type) so.fld, so.idx);
03296 fprintf(stderr, "Constant = *Unset*\n");
03297 dump_ir_ntry(stderr, so.idx, 0);
03298 break;
03299 }
03300
03301 return;
03302
03303 }
03304
03305
03306
03307
03308
03309
03310
03311
03312
03313
03314
03315
03316
03317
03318
03319
03320
03321
03322
03323
03324
03325 static void print_fld_idx(FILE *out_file,
03326 char *name,
03327 fld_type fld,
03328 int idx)
03329
03330 {
03331 static char str[80];
03332 char conv_str[80];
03333
03334 if (idx == NULL_IDX) {
03335 fprintf(out_file, " %-16s= %-7d %-9s\n", name, idx, field_str[fld]);
03336 }
03337 else {
03338 switch (fld) {
03339
03340 case CN_Tbl_Idx:
03341 sprintf(str,"( %-s )",
03342 convert_to_string(&CN_CONST(idx), CN_TYPE_IDX(idx), conv_str));
03343 break;
03344
03345 case AT_Tbl_Idx:
03346 sprintf(str,"( %-s )", AT_OBJ_NAME_PTR(idx));
03347 break;
03348
03349 case IR_Tbl_Idx:
03350 case IL_Tbl_Idx:
03351 case SH_Tbl_Idx:
03352 case SB_Tbl_Idx:
03353 sprintf(str,"%s", " ");
03354 break;
03355
03356 default:
03357 sprintf(str,"%s", " ");
03358 break;
03359 }
03360
03361 fprintf(out_file, " %-16s= %-7d %-9s%15s %-s\n",
03362 name, idx,
03363 field_str[fld], " ",
03364 str);
03365 }
03366
03367 return;
03368
03369 }
03370
03371
03372
03373
03374
03375
03376
03377
03378
03379
03380
03381
03382
03383
03384
03385
03386
03387
03388
03389
03390 static char *print_at_name(int idx)
03391
03392 {
03393 static char str[1] = "0";
03394
03395
03396 if (idx == NULL_IDX) {
03397 return(str);
03398 }
03399 else {
03400 return(AT_OBJ_NAME_PTR(idx));
03401 }
03402
03403 }
03404
03405
03406
03407
03408
03409
03410
03411
03412
03413
03414
03415 static void print_tbl_header (char *table_name)
03416
03417 {
03418 init_debug_file();
03419
03420 fprintf(debug_file, "****************************************"
03421 "****************************************\n");
03422 fprintf(debug_file, "\n\t\t\t%s\n\n", table_name);
03423 fprintf(debug_file, "****************************************"
03424 "****************************************\n");
03425 return;
03426
03427 }
03428
03429
03430
03431
03432
03433
03434
03435
03436
03437
03438
03439
03440
03441
03442
03443
03444
03445 static char *print_global_type_f(int gt_idx)
03446
03447 {
03448 int kind;
03449 static char str[80];
03450 char str1[80];
03451
03452
03453 if (gt_idx == NULL_IDX) {
03454 sprintf(str, "NULL");
03455 }
03456 else if (GT_TYPE(gt_idx) <= Last_Linear_Type) {
03457
03458 if (GT_DESC(gt_idx) == Star_Typed) {
03459 sprintf(str, "%s * %d",
03460 basic_type_str[GT_TYPE(gt_idx)],
03461 GT_DCL_VALUE(gt_idx));
03462 }
03463 else if (GT_DESC(gt_idx) == Kind_Typed) {
03464 sprintf(str, "%s (kind=%d)",
03465 basic_type_str[GT_TYPE(gt_idx)],
03466 GT_DCL_VALUE(gt_idx));
03467 }
03468 else {
03469
03470
03471
03472 switch (GT_LINEAR_TYPE(gt_idx)) {
03473 case Integer_1:
03474 case Logical_1:
03475 kind = 1;
03476 break;
03477 case Integer_2:
03478 case Logical_2:
03479 kind = 2;
03480 break;
03481 case Integer_4:
03482 case Logical_4:
03483 case Real_4:
03484 case Complex_4:
03485 kind = 4;
03486 break;
03487 case Integer_8:
03488 case Logical_8:
03489 case Real_8:
03490 case Complex_8:
03491 kind = 8;
03492 break;
03493 case Real_16:
03494 case Complex_16:
03495 kind = 16;
03496 break;
03497 default:
03498 kind = 0;
03499 break;
03500 }
03501
03502 if (kind == 0) {
03503 sprintf(str, "%s", basic_type_str[GT_TYPE(gt_idx)]);
03504 }
03505 else {
03506 sprintf(str, "%s (%d)", basic_type_str[GT_TYPE(gt_idx)], kind);
03507 }
03508 }
03509 }
03510 else if (GT_TYPE(gt_idx) == Typeless) {
03511 sprintf(str, "Typeless * %s",
03512 CONVERT_CVAL_TO_STR(&TYP_BIT_LEN(gt_idx), Integer_8, str1));
03513 }
03514 else if (GT_TYPE(gt_idx) != Character) {
03515 sprintf(str, "type(%s)", GA_OBJ_NAME_PTR(GT_STRUCT_IDX(gt_idx)));
03516 }
03517 else if (GT_CHAR_CLASS(gt_idx) == Assumed_Size_Char) {
03518 sprintf(str, "CHARACTER*(*)");
03519 }
03520 else if (GT_CHAR_CLASS(gt_idx) == Const_Len_Char) {
03521 sprintf(str, "CHARACTER*(Const_Len_Char)");
03522
03523
03524
03525 }
03526 else {
03527 sprintf(str, "CHARACTER*(tmp)");
03528 }
03529
03530 return(str);
03531
03532 }
03533
03534
03535
03536
03537
03538
03539
03540
03541
03542
03543
03544
03545
03546
03547
03548
03549
03550
03551
03552
03553
03554
03555
03556 static void print_all_text (boolean print_all_scps)
03557
03558 {
03559 int save_curr_scp_idx;
03560
03561
03562 PROCESS_SIBLING:
03563
03564 init_debug_file();
03565
03566 dump_trace_info (debug_file, PU_Start, NULL, "IR_dump");
03567
03568 if (!SCP_IN_ERR(curr_scp_idx) ) {
03569
03570 curr_stmt_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx);
03571
03572 while (curr_stmt_sh_idx != NULL_IDX) {
03573
03574 dump_stmt_ntry(debug_file, TRUE);
03575
03576 if (SH_NEXT_IDX(curr_stmt_sh_idx) == curr_stmt_sh_idx) {
03577
03578
03579
03580 dump_flags.ir1_tbl = FALSE;
03581 dump_flags.ir2_tbl = FALSE;
03582 dump_flags.ir3_tbl = FALSE;
03583 dump_flags.ir4_tbl = FALSE;
03584 dump_flags.sytb = FALSE;
03585
03586 PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 871, Internal,
03587 SH_COL_NUM(curr_stmt_sh_idx), "SH_NEXT_IDX",
03588 curr_stmt_sh_idx);
03589 }
03590 else if (SH_PREV_IDX(curr_stmt_sh_idx) == curr_stmt_sh_idx) {
03591
03592
03593
03594 dump_flags.ir1_tbl = FALSE;
03595 dump_flags.ir2_tbl = FALSE;
03596 dump_flags.ir3_tbl = FALSE;
03597 dump_flags.ir4_tbl = FALSE;
03598 dump_flags.sytb = FALSE;
03599
03600 PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 871, Internal,
03601 SH_COL_NUM(curr_stmt_sh_idx), "SH_PREV_IDX",
03602 curr_stmt_sh_idx);
03603 }
03604
03605 curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
03606 }
03607 }
03608
03609 if (!print_all_scps) {
03610 return;
03611 }
03612
03613 if (SCP_FIRST_CHILD_IDX(curr_scp_idx) != NULL_IDX) {
03614 save_curr_scp_idx = curr_scp_idx;
03615 curr_scp_idx = SCP_FIRST_CHILD_IDX(curr_scp_idx);
03616 print_all_text(TRUE);
03617 curr_scp_idx = save_curr_scp_idx;
03618 }
03619
03620 if (SCP_SIBLING_IDX(curr_scp_idx) != NULL_IDX) {
03621 curr_scp_idx = SCP_SIBLING_IDX(curr_scp_idx);
03622 goto PROCESS_SIBLING;
03623 }
03624
03625 return;
03626
03627 }
03628
03629
03630
03631
03632
03633
03634
03635
03636
03637
03638
03639
03640
03641
03642
03643
03644
03645
03646
03647 static void print_Dv_Whole_Def_Opr(FILE *out_file,
03648 int idx,
03649 int indent,
03650 int cnt)
03651
03652 {
03653 int dim;
03654 char shift[80];
03655 char n_shift[INDENT_SIZE + 1];
03656 char str[16];
03657 int i;
03658
03659 for (i = 0; i < INDENT_SIZE * indent; i++) {
03660 shift[i] = ' ';
03661 if (i == 79)
03662 break;
03663 }
03664 shift[i] = '\0';
03665 for (i = 0; i < INDENT_SIZE; i++) {
03666 n_shift[i] = ' ';
03667 }
03668 n_shift[i] = '\0';
03669
03670 dim = 0;
03671
03672 for (i = 0; i < cnt; i++) {
03673
03674 if (idx == NULL_IDX) {
03675 break;
03676 }
03677
03678 if (i < 10) {
03679 strcpy(str, dv_whole_def_str[i]);
03680 }
03681 else {
03682 if ((i - 10)%3 == 0) {
03683 dim++;
03684 }
03685 sprintf(str, dv_whole_def_str[i], dim);
03686 }
03687
03688 fprintf(out_file,"%s%-15s, idx = %d, %s",shift, str, idx,
03689 field_str[IL_FLD(idx)]);
03690
03691 if (i == DEBUG_STR_TYPE_CODE) {
03692 convert_to_string_fmt = Hex_Fmt;
03693 }
03694
03695 switch (IL_FLD(idx)) {
03696 case CN_Tbl_Idx :
03697 case AT_Tbl_Idx :
03698 fprintf(out_file," line = %d col = %d\n",IL_LINE_NUM(idx),
03699 IL_COL_NUM(idx));
03700 break;
03701 case IL_Tbl_Idx :
03702 fprintf(out_file," list cnt = %d\n", IL_LIST_CNT(idx));
03703 break;
03704 default :
03705 fprintf(out_file,"\n");
03706 break;
03707 }
03708
03709
03710 switch (IL_FLD(idx)) {
03711 case NO_Tbl_Idx :
03712 break;
03713 case CN_Tbl_Idx :
03714 print_const_entry(out_file, IL_IDX(idx), indent + 1);
03715 break;
03716 case AT_Tbl_Idx :
03717 print_attr_name(out_file, IL_IDX(idx), indent + 1);
03718 break;
03719 case IR_Tbl_Idx :
03720 dump_ir_ntry(out_file, IL_IDX(idx), indent + 1);
03721 break;
03722 case IL_Tbl_Idx :
03723 print_list(out_file, IL_IDX(idx),
03724 indent + 1, IL_LIST_CNT(idx), FALSE);
03725 break;
03726 case SH_Tbl_Idx :
03727 fprintf(out_file, "%s%sstmt header idx = %d\n",shift,n_shift,
03728 IL_IDX(idx));
03729 break;
03730 }
03731 idx = IL_NEXT_LIST_IDX(idx);
03732 }
03733
03734 return;
03735
03736 }
03737
03738
03739
03740
03741
03742
03743
03744
03745
03746
03747
03748
03749
03750
03751
03752
03753
03754
03755
03756 static void print_mp_dir_opr(FILE *out_file,
03757 int idx,
03758 int indent,
03759 int cnt)
03760
03761 {
03762 char shift[80];
03763 char n_shift[INDENT_SIZE + 1];
03764 char str[80];
03765 int i;
03766
03767
03768 for (i = 0; i < INDENT_SIZE * indent; i++) {
03769 shift[i] = ' ';
03770 if (i == 79)
03771 break;
03772 }
03773 shift[i] = '\0';
03774 for (i = 0; i < INDENT_SIZE; i++) {
03775 n_shift[i] = ' ';
03776 }
03777 n_shift[i] = '\0';
03778
03779
03780 for (i = 0; i < cnt; i++) {
03781
03782 if (idx == NULL_IDX) {
03783 break;
03784 }
03785
03786 strcpy(str, mp_dir_opr_str[i]);
03787
03788 fprintf(out_file,"%s%-15s, idx = %d, %s",shift, str, idx,
03789 field_str[IL_FLD(idx)]);
03790
03791 switch (IL_FLD(idx)) {
03792 case CN_Tbl_Idx :
03793 case AT_Tbl_Idx :
03794 fprintf(out_file," line = %d col = %d\n",IL_LINE_NUM(idx),
03795 IL_COL_NUM(idx));
03796 break;
03797 case IL_Tbl_Idx :
03798 fprintf(out_file," list cnt = %d\n", IL_LIST_CNT(idx));
03799 break;
03800 default :
03801 fprintf(out_file,"\n");
03802 break;
03803 }
03804
03805
03806 switch (IL_FLD(idx)) {
03807 case NO_Tbl_Idx :
03808 break;
03809 case CN_Tbl_Idx :
03810 print_const_entry(out_file, IL_IDX(idx), indent + 1);
03811 break;
03812 case AT_Tbl_Idx :
03813 print_attr_name(out_file, IL_IDX(idx), indent + 1);
03814 break;
03815 case IR_Tbl_Idx :
03816 dump_ir_ntry(out_file, IL_IDX(idx), indent + 1);
03817 break;
03818 case IL_Tbl_Idx :
03819 print_list(out_file, IL_IDX(idx),
03820 indent + 1, IL_LIST_CNT(idx), FALSE);
03821 break;
03822 case SH_Tbl_Idx :
03823 fprintf(out_file, "%s%sstmt header idx = %d\n",shift,n_shift,
03824 IL_IDX(idx));
03825 break;
03826 }
03827 idx = IL_NEXT_LIST_IDX(idx);
03828 }
03829
03830 return;
03831
03832 }
03833
03834
03835
03836
03837
03838
03839
03840
03841
03842
03843
03844
03845
03846
03847
03848
03849
03850
03851
03852 static void print_open_mp_dir_opr(FILE *out_file,
03853 int idx,
03854 int indent,
03855 int cnt)
03856
03857 {
03858 char shift[80];
03859 char n_shift[INDENT_SIZE + 1];
03860 char str[80];
03861 int i;
03862
03863
03864 for (i = 0; i < INDENT_SIZE * indent; i++) {
03865 shift[i] = ' ';
03866 if (i == 79)
03867 break;
03868 }
03869 shift[i] = '\0';
03870 for (i = 0; i < INDENT_SIZE; i++) {
03871 n_shift[i] = ' ';
03872 }
03873 n_shift[i] = '\0';
03874
03875 for (i = 0; i < cnt; i++) {
03876
03877 if (idx == NULL_IDX) {
03878 break;
03879 }
03880
03881 strcpy(str, open_mp_dir_opr_str[i]);
03882
03883 fprintf(out_file,"%s%-15s, idx = %d, %s",shift, str, idx,
03884 field_str[IL_FLD(idx)]);
03885
03886 switch (IL_FLD(idx)) {
03887 case CN_Tbl_Idx :
03888 case AT_Tbl_Idx :
03889 fprintf(out_file," line = %d col = %d\n",IL_LINE_NUM(idx),
03890 IL_COL_NUM(idx));
03891 break;
03892 case IL_Tbl_Idx :
03893 fprintf(out_file," list cnt = %d\n", IL_LIST_CNT(idx));
03894 break;
03895 default :
03896 fprintf(out_file,"\n");
03897 break;
03898 }
03899
03900
03901 switch (IL_FLD(idx)) {
03902 case NO_Tbl_Idx :
03903 break;
03904 case CN_Tbl_Idx :
03905 print_const_entry(out_file, IL_IDX(idx), indent + 1);
03906 break;
03907 case AT_Tbl_Idx :
03908 print_attr_name(out_file, IL_IDX(idx), indent + 1);
03909 break;
03910 case IR_Tbl_Idx :
03911 dump_ir_ntry(out_file, IL_IDX(idx), indent + 1);
03912 break;
03913 case IL_Tbl_Idx :
03914 print_list(out_file, IL_IDX(idx),
03915 indent + 1, IL_LIST_CNT(idx), FALSE);
03916 break;
03917 case SH_Tbl_Idx :
03918 fprintf(out_file, "%s%sstmt header idx = %d\n",shift,n_shift,
03919 IL_IDX(idx));
03920 break;
03921 }
03922 idx = IL_NEXT_LIST_IDX(idx);
03923 }
03924
03925 return;
03926
03927 }
03928
03929
03930
03931
03932
03933
03934
03935
03936
03937
03938
03939
03940
03941
03942
03943
03944
03945
03946 static void print_attr_name(FILE *out_file,
03947 int idx,
03948 int indent)
03949
03950 {
03951 int i;
03952 char shift[80];
03953 char str[80];
03954 int type_idx;
03955
03956
03957 for (i = 0; i < INDENT_SIZE * indent; i++) {
03958 shift[i] = ' ';
03959 if (i == 79)
03960 break;
03961 }
03962
03963 shift[i] = '\0';
03964
03965