Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
00001 /* 00002 00003 Copyright (C) 2000, 2001 Silicon Graphics, Inc. All Rights Reserved. 00004 00005 This program is free software; you can redistribute it and/or modify it 00006 under the terms of version 2 of the GNU General Public License as 00007 published by the Free Software Foundation. 00008 00009 This program is distributed in the hope that it would be useful, but 00010 WITHOUT ANY WARRANTY; without even the implied warranty of 00011 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00012 00013 Further, this software is distributed without any warranty that it is 00014 free of the rightful claim of any third person regarding infringement 00015 or the like. Any license provided herein, whether implied or 00016 otherwise, applies only to this software file. Patent licenses, if 00017 any, provided herein do not apply to combinations of this program with 00018 other software, or any other product whatsoever. 00019 00020 You should have received a copy of the GNU General Public License along 00021 with this program; if not, write the Free Software Foundation, Inc., 59 00022 Temple Place - Suite 330, Boston MA 02111-1307, USA. 00023 00024 Contact information: Silicon Graphics, Inc., 1600 Amphitheatre Pky, 00025 Mountain View, CA 94043, or: 00026 00027 http://www.sgi.com 00028 00029 For further information regarding this notice, see: 00030 00031 http://oss.sgi.com/projects/GenInfo/NoticeExplan 00032 00033 */ 00034 00035 00036 00037 static char USMID[] = "\n@(#)5.0_pl/sources/fecif.c 5.9 10/14/99 12:53:57\n"; 00038 00039 #include "defines.h" /* Machine dependent ifdefs */ 00040 00041 00042 #define __NLS_INTERNALS 1 /* Obtain internal <nl_types.h> definitions. */ 00043 /* (Required to get at prototype for */ 00044 /* __cat_path_name.) */ 00045 #include <nl_types.h> /* Contains typedef for nl_catd and prototype for */ 00046 /* __cat_path_name. */ 00047 00048 #if defined(_HOST_OS_LINUX) 00049 # include <nlcatmsg.h> 00050 #endif 00051 00052 00053 00054 #include <time.h> 00055 00056 00057 #define CIF_VERSION 3 00058 00059 #include "cif.h" 00060 00061 #include "cifprocs.h" 00062 00063 00064 #include "host.m" /* Host machine dependent macros.*/ 00065 #include "host.h" /* Host machine dependent header.*/ 00066 #include "target.m" /* Target machine dependent macros.*/ 00067 #include "target.h" /* Target machine dependent header.*/ 00068 00069 #include "globals.m" 00070 #include "tokens.m" 00071 #include "sytb.m" 00072 #include "p_globals.m" 00073 #include "s_globals.m" 00074 #include "debug.m" 00075 #include "cif.m" 00076 #include "fecif.m" 00077 00078 #include "globals.h" 00079 #include "tokens.h" 00080 #include "sytb.h" 00081 #include "p_globals.h" 00082 #include "s_globals.h" 00083 #include "fecif.h" 00084 00085 #if (defined(_HOST_OS_SOLARIS) || defined(_HOST_OS_IRIX)) 00086 # include <sys/systeminfo.h> 00087 #else 00088 # include <unistd.h> /* for gethostname() */ 00089 #endif 00090 00091 /*****************************************************************\ 00092 |* Function prototypes of static functions declared in this file *| 00093 \*****************************************************************/ 00094 00095 static int cif_data_type(int); 00096 static void cif_flush_include_recs (void); 00097 static int get_line_and_file_id (int, int *); 00098 static void output_minimal_object_rec (int); 00099 static void process_attr_list (int, boolean); 00100 static boolean output_struct_ids(opnd_type *); 00101 00102 static char output_buf[2][64]; 00103 00104 # define outbuf1 output_buf[0] 00105 # define outbuf2 output_buf[1] 00106 00107 00108 /*****************************************************************************\ 00109 |* *| 00110 |* Description: *| 00111 |* Open the Compiler Information File and output the header record. *| 00112 |* *| 00113 |* Input parameters: *| 00114 |* NONE *| 00115 |* *| 00116 |* Output parameters: *| 00117 |* NONE *| 00118 |* *| 00119 |* Returns: *| 00120 |* NOTHING *| 00121 |* *| 00122 \*****************************************************************************/ 00123 00124 void init_cif(char *comp_date_time, char *release_level) 00125 { 00126 char cif_date[9]; 00127 char cif_time[9]; 00128 char cpu_name[MAXHOSTNAMELEN + 1]; 00129 char month[4]; 00130 int save_cif_file_id; 00131 char *msg_cat_name; 00132 00133 # if defined(_GETPMC_AVAILABLE) 00134 extern int GETPMC(long *, char *); /* UNICOS library routine*/ 00135 00136 union {long int_form; 00137 char char_form[9]; 00138 } host_cpu_type; 00139 00140 union host_machine_entry {struct {long mcpmt; 00141 Ulong unused[127]; 00142 } fld; 00143 long host_tbl[128]; 00144 }; 00145 00146 typedef union host_machine_entry host_machine_type; 00147 00148 host_machine_type host_machine_info; 00149 00150 # elif (defined(_HOST_OS_SOLARIS) || defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX)) 00151 char host_cpu_type[9]; /* Max of 8 chars (plus NULL).*/ 00152 # endif 00153 00154 00155 TRACE (Func_Entry, "init_cif", NULL); 00156 00157 cif_end_unit_column = 0; 00158 cif_file_id = 2; /* Reserve 1 for msg cat name.*/ 00159 cif_first_pgm_unit = TRUE; 00160 cif_need_unit_rec = TRUE; 00161 cif_pgm_unit_error_recovery = FALSE; 00162 cif_pgm_unit_start_line = 1; 00163 00164 00165 /* If the CIF name was provided by the command line processor, open it. */ 00166 /* If the user specified -C, set_prog_file_names has already created the */ 00167 /* .T name in cif_name. */ 00168 /* Otherwise, get a temporary file. */ 00169 00170 if ((cif_C_opts & CMD_PROVIDED_CIF) || cif_flags != 0) { 00171 00172 if ((cif_actual_file = fopen(cif_name, "w")) == NULL) { 00173 PRINTMSG(0, 556, Log_Error, 0); 00174 perror("Reason"); 00175 00176 # ifdef _DEBUG 00177 00178 fprintf(stderr, " Trying to open file %s\n", cif_name); 00179 system("df /tmp"); 00180 00181 # endif 00182 00183 exit_compiler(RC_USER_ERROR); 00184 } 00185 } 00186 else { 00187 00188 if (! get_temp_file("w+", &cif_actual_file, cif_name)) { 00189 PRINTMSG(1, 556, Log_Error, 0); 00190 perror(" Reason"); 00191 00192 # ifdef _DEBUG 00193 00194 fprintf(stderr, " Trying to open file %s\n", cif_name); 00195 system("df /tmp"); 00196 00197 # endif 00198 00199 exit_compiler(RC_USER_ERROR); 00200 } 00201 } 00202 00203 c_i_f = cif_actual_file; 00204 00205 /* Create a temporary file to save records that are output while the */ 00206 /* first stmt of a program unit is being parsed. (All records for a */ 00207 /* program unit must be between the Unit and End Unit records for the */ 00208 /* program unit.) */ 00209 00210 if (! get_temp_file("w+", &cif_tmp_file, cif_tmp_file_name)) { 00211 PRINTMSG(0, 556, Log_Error, 0); 00212 perror("Reason"); 00213 00214 # ifdef _DEBUG 00215 00216 fprintf(stderr, " Trying to open file %s\n", cif_name); 00217 system("df /tmp"); 00218 00219 # endif 00220 00221 if (c_i_f == cif_actual_file) { 00222 /* prevent closing the same file twice. Linux does not handle it */ 00223 cif_actual_file = NULL; 00224 } 00225 00226 fclose(c_i_f); 00227 00228 if (! (cif_C_opts & CMD_PROVIDED_CIF)) { 00229 remove(cif_name); 00230 } 00231 00232 exit_compiler(RC_USER_ERROR); 00233 } 00234 00235 00236 /* -----------------------------------------------------------------------*/ 00237 /* Output the CIF header record. */ 00238 /* */ 00239 /* First, brute-force the date from the format in comp_date_time to the */ 00240 /* format CIF expects: Ddd Mmm dd, yyyy -> mm/dd/yy */ 00241 /* -----------------------------------------------------------------------*/ 00242 00243 memcpy(month, comp_date_time+4, 3); 00244 00245 switch (month[0]) { 00246 00247 case 'A': 00248 strcpy(cif_date, (month[1] == 'p') ? "04/" : "08/"); 00249 break; 00250 00251 case 'D': 00252 strcpy(cif_date, "12/"); 00253 break; 00254 00255 case 'F': 00256 strcpy(cif_date, "02/"); 00257 break; 00258 00259 case 'J': 00260 if (month[1] == 'a') { 00261 strcpy(cif_date, "01/"); 00262 } 00263 else { 00264 strcpy(cif_date, (month[2] == 'n') ? "06/" : "07/"); 00265 } 00266 break; 00267 00268 case 'M': 00269 strcpy(cif_date, (month[2] == 'r') ? "03/" : "05/"); 00270 break; 00271 00272 case 'N': 00273 strcpy(cif_date, "11/"); 00274 break; 00275 00276 case 'O': 00277 strcpy(cif_date, "10/"); 00278 break; 00279 00280 case 'S': 00281 strcpy(cif_date, "09/"); 00282 } 00283 00284 cif_date[3] = (comp_date_time[8] == ' ') ? '0' : comp_date_time[8]; 00285 cif_date[4] = comp_date_time[9]; 00286 cif_date[5] = '/'; 00287 cif_date[6] = comp_date_time[14]; 00288 cif_date[7] = comp_date_time[15]; 00289 cif_date[8] = EOS; 00290 00291 memcpy(cif_time, comp_date_time+18, 8); 00292 cif_time[8] = NULL_CHAR; 00293 00294 # if defined(_HOST_OS_LINUX) 00295 msg_cat_name = "shouldnotgethere"; 00296 # else 00297 00298 /* 00299 * Solaris workaround 00300 * there is no __cat_path_name() declaration in Solaris nl_types.h 00301 * for now we just explicitly set up the message catalog file path. 00302 * it also works for IRIX. 00303 * 00304 */ 00305 msg_cat_name = CF90CATPATHNAME; 00306 00307 # endif 00308 00309 00310 # if (defined(_HOST_OS_SOLARIS) || defined(_HOST_OS_IRIX)) 00311 00312 if (sysinfo(SI_HOSTNAME, cpu_name, ((long int) MAXHOSTNAMELEN)) < 0L) { 00313 Cif_Error(); 00314 } 00315 00316 # else 00317 00318 /* eraxxon: this used to be used on _HOST_OS_LINUX */ 00319 /* strcpy(cpu_name, "LINUX"); */ 00320 00321 if (gethostname(cpu_name, (MAXHOSTNAMELEN + 1)) < 0) { 00322 Cif_Error(); 00323 } 00324 00325 # endif 00326 00327 00328 # if defined(_GETPMC_AVAILABLE) 00329 GETPMC (host_machine_info.host_tbl, "HOST"); 00330 host_cpu_type.int_form = host_machine_info.fld.mcpmt; 00331 host_cpu_type.char_form[8] = NULL_CHAR; 00332 # elif defined(_HOST_OS_SOLARIS) 00333 strcpy(host_cpu_type, "SPARC"); 00334 # elif defined(_HOST_OS_IRIX) 00335 strcpy(host_cpu_type, "SGI"); 00336 # elif defined(_HOST_OS_LINUX) 00337 strcpy(host_cpu_type, "INTEL"); 00338 # endif 00339 00340 00341 Cif_Cifhdr_Rec(c_i_f, 00342 CIF_LG_F90, 00343 release_level, 00344 cif_date, 00345 cif_time, 00346 group_code, 00347 1, /* Message catalog file id. */ 00348 cpu_name, 00349 00350 # if defined(_GETPMC_AVAILABLE) 00351 host_cpu_type.char_form); 00352 # elif (defined(_HOST_OS_SOLARIS) || defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX)) 00353 host_cpu_type); 00354 # endif 00355 00356 Cif_Src_Pos_Rec(c_i_f, 00357 CIF_SRC_KIND_MAIN, 00358 2, 00359 0, 00360 0, 00361 0, 00362 2, 00363 0, 00364 0, 00365 0); 00366 00367 00368 save_cif_file_id = cif_file_id; 00369 cif_file_id = 1; 00370 00371 cif_file_name_rec(msg_cat_name, (char *) NULL); 00372 00373 cif_file_id = save_cif_file_id; 00374 00375 if (cif_flags & COMPILER_RECS) { 00376 cif_enable_disable_rec(); 00377 cif_misc_compiler_opts_rec(); 00378 cif_optimization_opts_rec(); 00379 cif_machine_characteristics_rec(); 00380 } 00381 00382 00383 /* orig_cmd_line should only be NULL if the compiler is called directly */ 00384 /* (like in debug mode). Even if it is NULL for another reason, there is */ 00385 /* no great harm; the Original Command Line record will just not be */ 00386 /* produced in the CIF. */ 00387 00388 if (orig_cmd_line != NULL) { 00389 Cif_Orig_Cmd(c_i_f, orig_cmd_line); 00390 MEM_FREE(orig_cmd_line); 00391 } 00392 00393 00394 /* Set the CIF to the temp file so that all records preceding the Unit */ 00395 /* record will go to the temp file. cif_unit_rec will copy the temp */ 00396 /* file to the actual file so that these records will properly follow */ 00397 /* the Unit record. */ 00398 00399 c_i_f = cif_tmp_file; 00400 00401 TRACE (Func_Exit, "init_cif", NULL); 00402 00403 return; 00404 00405 } /* init_cif */ 00406 00407 00408 /******************************************************************************\ 00409 |* *| 00410 |* Description: *| 00411 |* Perform initializations that need to be done for each program unit. *| 00412 |* *| 00413 |* Input parameters: *| 00414 |* NONE *| 00415 |* *| 00416 |* Output parameters: *| 00417 |* NONE *| 00418 |* *| 00419 |* Returns: *| 00420 |* NOTHING *| 00421 |* *| 00422 \******************************************************************************/ 00423 00424 void cif_prog_unit_init(void) 00425 { 00426 00427 TRACE (Func_Entry, "cif_prog_unit_init", NULL); 00428 00429 cif_derived_type_id = 101; 00430 cif_symbol_or_scope_id = 3; /* Reserve 1 for main program */ 00431 /* scope ID. */ 00432 /* Reserve 2 for main pgm name.*/ 00433 SCP_CIF_ID(curr_scp_idx) = 00434 (BLK_TYPE(blk_stk_idx) == Program_Blk) ? 1 : NEXT_SCOPE_ID; 00435 00436 cif_end_unit_column = 0; 00437 cif_need_unit_rec = TRUE; 00438 cif_pgm_unit_error_recovery = FALSE; 00439 00440 c_i_f = cif_tmp_file; 00441 00442 TRACE (Func_Exit, "cif_prog_unit_init", NULL); 00443 00444 return; 00445 00446 } /* cif_prog_unit_init */ 00447 00448 00449 /******************************************************************************\ 00450 |* *| 00451 |* Description: *| 00452 |* Send the symbol table to CIF: *| 00453 |* - Go through the Storage Block table to find all storage blocks *| 00454 |* that belong to the current scoping unit. Produce a Common Block *| 00455 |* record for each common block declared in the scoping unit. *| 00456 |* - If "-ci" (or an option that includes "i") was specified, go *| 00457 |* through the Local Name table to find ALL entities associated with *| 00458 |* the current scoping unit. If "-Cf" was specified, go through the *| 00459 |* Local Name table to find all Pgm_Unit and Stmt_Func Attrs (to *| 00460 |* produce Entry Point records) and to find all the interface blocks *| 00461 |* (to produce Interface Block records). *| 00462 |* Note: Common Block records are also produced when only "-Cf" is *| 00463 |* specified. *| 00464 |* *| 00465 |* Input parameters: *| 00466 |* NONE *| 00467 |* *| 00468 |* Output parameters: *| 00469 |* NONE *| 00470 |* *| 00471 |* Returns: *| 00472 |* NOTHING *| 00473 |* *| 00474 \******************************************************************************/ 00475 00476 void cif_send_sytb() 00477 { 00478 int al_idx; 00479 int attr_idx; 00480 long_type blk_len; 00481 int module_symbol_id; 00482 int name_idx; 00483 long_type result[MAX_WORDS_FOR_INTEGER]; 00484 int sb_idx; 00485 int stor_class; 00486 int type_idx; 00487 00488 00489 TRACE (Func_Entry, "cif_send_sytb", NULL); 00490 00491 for (sb_idx = 1; sb_idx <= stor_blk_tbl_idx; sb_idx++) { 00492 00493 if (SB_SCP_IDX(sb_idx) != curr_scp_idx) { 00494 continue; 00495 } 00496 00497 if (SB_CIF_SYMBOL_ID(sb_idx) == 0) { 00498 SB_CIF_SYMBOL_ID(sb_idx) = NEXT_SYMBOL_ID; 00499 } 00500 00501 if (SB_BLK_TYPE(sb_idx) == Common) { 00502 stor_class = CIF_CB_REG; 00503 } 00504 else if (SB_BLK_TYPE(sb_idx) == Task_Common) { 00505 stor_class = CIF_CB_TASK; 00506 } 00507 else { 00508 continue; 00509 } 00510 00511 if (SB_USE_ASSOCIATED(sb_idx)) { 00512 00513 if (AT_CIF_SYMBOL_ID(SB_MODULE_IDX(sb_idx)) == 0) { 00514 AT_CIF_SYMBOL_ID(SB_MODULE_IDX(sb_idx)) = NEXT_SYMBOL_ID; 00515 } 00516 00517 module_symbol_id = AT_CIF_SYMBOL_ID(SB_MODULE_IDX(sb_idx)); 00518 } 00519 else { 00520 00521 /* If the common block is defined in a module, get the symbol id of */ 00522 /* the module name. Each common block, whether it is host */ 00523 /* associated or not, will carry it's original SCP_ID. Use this to */ 00524 /* determine if it came from a module. */ 00525 /* Need to check for NULL_IDX because common blocks from interface */ 00526 /* bodies will have NULL_IDX for SB_ORIG_SCP_IDX. */ 00527 00528 module_symbol_id = 0; 00529 00530 if (SB_ORIG_SCP_IDX(sb_idx) != NULL_IDX) { 00531 attr_idx = SCP_ATTR_IDX(SB_ORIG_SCP_IDX(sb_idx)); 00532 00533 if (ATP_PGM_UNIT(attr_idx) == Module) { 00534 module_symbol_id = AT_CIF_SYMBOL_ID(attr_idx); 00535 } 00536 } 00537 } 00538 00539 /* The SB_LEN_IDX may not always be a constant. */ 00540 /* 0 is issued, if the length is variable. */ 00541 00542 blk_len = 0; 00543 00544 if (SB_LEN_FLD(sb_idx) == CN_Tbl_Idx) { 00545 type_idx = CN_TYPE_IDX(SB_LEN_IDX(sb_idx)); 00546 00547 if (folder_driver((char *) &CN_CONST(SB_LEN_IDX(sb_idx)), 00548 CN_TYPE_IDX(SB_LEN_IDX(sb_idx)), 00549 (char *) &CN_CONST(CN_INTEGER_THREE_IDX), 00550 CN_TYPE_IDX(CN_INTEGER_THREE_IDX), 00551 result, 00552 &type_idx, 00553 SB_DEF_LINE(sb_idx), 00554 SB_DEF_COLUMN(sb_idx), 00555 2, 00556 Shiftr_Opr)) { 00557 blk_len = (long) F_INT_TO_C(result, TYP_LINEAR(type_idx)); 00558 } 00559 } 00560 00561 /* On the receiving end, blk_len is an int, so we can loose precision. */ 00562 /* KAY */ 00563 00564 Cif_F90_Comblk_Rec(c_i_f, 00565 SB_NAME_PTR(sb_idx), 00566 SB_CIF_SYMBOL_ID(sb_idx), 00567 SCP_CIF_ID(curr_scp_idx), 00568 stor_class, 00569 module_symbol_id, 00570 blk_len, 00571 0); 00572 } 00573 00574 if (cif_flags & INFO_RECS) { 00575 00576 for (name_idx = SCP_LN_FW_IDX(curr_scp_idx) + 1; 00577 name_idx < SCP_LN_LW_IDX(curr_scp_idx); name_idx++) { 00578 00579 attr_idx = LN_ATTR_IDX(name_idx); 00580 00581 /* Attrs that have AT_DCL_ERR set to TRUE will be dealt with in */ 00582 /* cif_send_attr. */ 00583 /* A variable used as a loop control variable (LCV) in a DATA or */ 00584 /* array constructor implied-DO is local to thta implied-DO nest. */ 00585 /* If no variable with the same name exists outside the implied-DOs, */ 00586 /* implied-DO processing creates an Attr entry for the variable in */ 00587 /* order to "borrow" the data type for the implied-DO LCV. Implied- */ 00588 /* DO processing then creates a temp with the same name as the */ 00589 /* variable (to make the implied-DO LCV local to the implied-DO) and */ 00590 /* uses the temp as the LCV. This special case temp must be sent */ 00591 /* through cif_send_attr to have an Object record produced for it. */ 00592 /* If no variable of the same name ever appears anywhere else in */ 00593 /* the program unit outside the implied-DOs, the "master" Attr */ 00594 /* becomes redundant and must not be sent through cif_send_attr. */ 00595 /* (If this extra Attr is sent through cif_send_attr, it will appear */ 00596 /* in a xref listing as an implicitly declared variable with no */ 00597 /* references - an impossibility). So, to weed out such extra Attrs,*/ 00598 /* we look for: */ 00599 /* * a variable [ AT_OBJ_CLASS == Data_Obj and */ 00600 /* ATD_CLASS == Variable */ 00601 /* * that only appeared as an implied-DO LCV */ 00602 /* [ ATD_SEEN_OUTSIDE_IMP_DO == FALSE ] */ 00603 /* * and, in particular, appeared only as a DATA or array */ 00604 /* constructor implied-DO LCV [ ATD_SEEN_AS_IO_LCV == FALSE ] */ 00605 00606 if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 00607 ATD_CLASS(attr_idx) == Variable && 00608 ! ATD_SEEN_OUTSIDE_IMP_DO(attr_idx) && 00609 ! ATD_SEEN_AS_IO_LCV(attr_idx)) { 00610 continue; 00611 } 00612 00613 cif_send_attr(attr_idx, NULL_IDX); 00614 } 00615 00616 process_attr_list(SCP_ATTR_LIST(curr_scp_idx), FALSE); 00617 process_attr_list(SCP_CIF_ERR_LIST(curr_scp_idx), TRUE); 00618 } 00619 else { 00620 00621 /* "-Cf" was specified. */ 00622 00623 for (name_idx = SCP_LN_FW_IDX(curr_scp_idx) + 1; 00624 name_idx < SCP_LN_LW_IDX(curr_scp_idx); name_idx++) { 00625 00626 attr_idx = LN_ATTR_IDX(name_idx); 00627 00628 /* Only want to generate entry records. */ 00629 00630 if (AT_OBJ_CLASS(attr_idx) != Pgm_Unit && 00631 AT_OBJ_CLASS(attr_idx) != Stmt_Func && 00632 AT_OBJ_CLASS(attr_idx) != Interface) { 00633 continue; 00634 } 00635 00636 cif_send_attr(attr_idx, NULL_IDX); 00637 } 00638 00639 /* Go through the Attr list to pick up Attrs for nongeneric (unnamed) */ 00640 /* interface blocks (and interface bodies inherited from a host scope */ 00641 /* when interface blocks with the same name are merged?). */ 00642 /* See also the comments preceding the analogous loop above. */ 00643 00644 al_idx = SCP_ATTR_LIST(curr_scp_idx); 00645 00646 while (al_idx != NULL_IDX) { 00647 00648 if ((AT_OBJ_CLASS(attr_idx) == Pgm_Unit && 00649 AT_CIF_SYMBOL_ID(AL_ATTR_IDX(al_idx)) == 0) || 00650 AT_OBJ_CLASS(attr_idx) == Interface) { 00651 cif_send_attr(AL_ATTR_IDX(al_idx), NULL_IDX); 00652 } 00653 00654 al_idx = AL_NEXT_IDX(al_idx); 00655 } 00656 } 00657 00658 TRACE (Func_Exit, "cif_send_sytb", NULL); 00659 00660 return; 00661 00662 } /* cif_send_sytb */ 00663 00664 00665 /******************************************************************************\ 00666 |* *| 00667 |* Description: *| 00668 |* Produce records representing the entities associated with the current *| 00669 |* scoping unit. *| 00670 |* *| 00671 |* Input parameters: *| 00672 |* NONE *| 00673 |* *| 00674 |* Output parameters: *| 00675 |* NONE *| 00676 |* *| 00677 |* Returns: *| 00678 |* NOTHING *| 00679 |* *| 00680 \******************************************************************************/ 00681 00682 void cif_send_attr(int attr_idx, 00683 int dt_attr_idx) 00684 00685 { 00686 long attributes; 00687 int bd_idx; 00688 char buffer[160]; 00689 char char_len[20]; 00690 int darg_idx; 00691 linear_type_type data_type; 00692 int derived_type; 00693 int dt_idx; 00694 int i; 00695 int interface_idx; 00696 int interface_type; 00697 int namelist_idx; 00698 int num_dargs; 00699 int num_namelist; 00700 char *obj_name_ptr; 00701 long64 offset; 00702 char offset_buf[20]; 00703 int pgm_unit_type; 00704 int pointer_id; 00705 int rslt_id; 00706 int rslt_idx; 00707 boolean save_cif_done; 00708 # if 0 00709 int save_symbol_id; 00710 # endif 00711 int scope_id; 00712 int sn_idx; 00713 int storage_class; 00714 int storage_id; 00715 char string[20]; 00716 int symbol_class; 00717 int type_idx; 00718 00719 00720 TRACE (Func_Entry, "cif_send_attr", NULL); 00721 00722 /* Skip this Attribute entry if: */ 00723 /* - It has already been processed. */ 00724 /* - It's for a compiler generated variable. */ 00725 /* - It is host associated and is not a program unit Attr. Even if a */ 00726 /* program unit Attr is host associated, it must be processed because */ 00727 /* CIF needs a record for both the reference to the program unit and */ 00728 /* the definition of the program unit. Example: */ 00729 /* */ 00730 /* module mod */ 00731 /* */ 00732 /* contains */ 00733 /* */ 00734 /* subroutine sub1(i) */ 00735 /* integer i */ 00736 /* ... */ 00737 /* end subroutine */ 00738 /* */ 00739 /* subroutine sub2(j) */ 00740 /* integer j */ 00741 /* call sub1(2) */ 00742 /* end subroutine */ 00743 /* */ 00744 /* end module */ 00745 /* */ 00746 /* An Attr for SUB1 will exist at the module level so SUB2 can call it.*/ 00747 /* An Attr for SUB1 will also exist in SUB2 and be attr-linked to the */ 00748 /* the Attr for SUB1 at the module level. The module does not actually*/ 00749 /* reference SUB1 so no Entry record will be generated for SUB1 there. */ 00750 /* But there will be a definition Entry record generated within SUB1 */ 00751 /* and there must be a reference Entry record generated within SUB2 for*/ 00752 /* SUB1. Thus, even though the Attr for SUB1 in SUB2 is attr-linked to*/ 00753 /* the Attr for SUB1 at the module level, the Attr in SUB2 must be */ 00754 /* sent through cif_send_attr so that the reference Entry record will */ 00755 /* show up in the proper scoping unit. */ 00756 00757 if (AT_CIF_DONE(attr_idx)) { 00758 goto EXIT; 00759 } 00760 00761 if (!AT_CIF_IN_USAGE_REC(attr_idx) && 00762 ((AT_COMPILER_GEND(attr_idx) && 00763 (AT_OBJ_CLASS(attr_idx) != Data_Obj || 00764 ATD_CLASS(attr_idx) != Compiler_Tmp || 00765 ! ATD_TMP_NEEDS_CIF(attr_idx))) || 00766 (AT_ATTR_LINK(attr_idx) != NULL_IDX && 00767 AT_OBJ_CLASS(attr_idx) != Pgm_Unit))) { 00768 goto EXIT; 00769 } 00770 00771 00772 AT_CIF_DONE(attr_idx) = TRUE; 00773 00774 00775 switch (AT_OBJ_CLASS(attr_idx)) { 00776 00777 /* ----------------------------------------------------------------------- */ 00778 /* Data_Obj */ 00779 /* ----------------------------------------------------------------------- */ 00780 00781 case Data_Obj: 00782 00783 /* If the Attr entry is marked in error, produce an Object record */ 00784 /* anyway (with "symbol class" and most other fields set to 0 to */ 00785 /* indicate the record is incomplete) because we can't stop all Usage */ 00786 /* records from being produced (and Usage records must have a "defining"*/ 00787 /* record). All Usage records can not be stopped primarily because */ 00788 /* they are produced in the Syntax Pass while the Object record is */ 00789 /* produced in the Semantics Pass, and because they are generally */ 00790 /* produced as the objects are seen. Example: */ 00791 /* REAL i */ 00792 /* INTEGER i */ 00793 /* A Usage record is produced for I when the REAL stmt is parsed. When */ 00794 /* the INTEGER stmt is parsed, I has already been typed so an error is */ 00795 /* issued and AT_DCL_ERR for I is set to TRUE. Since the Usage record */ 00796 /* already exists, an Object record must also exist. libcif will */ 00797 /* ignore all records that relate to an Object record that is marked */ 00798 /* in error. */ 00799 00800 if (AT_DCL_ERR(attr_idx)) { 00801 output_minimal_object_rec(attr_idx); 00802 goto EXIT; 00803 } 00804 00805 if (AT_CIF_SYMBOL_ID(attr_idx) == 0) { 00806 AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID; 00807 } 00808 00809 char_len[0] = NULL_CHAR; 00810 type_idx = ATD_TYPE_IDX(attr_idx); 00811 00812 if (TYP_TYPE(type_idx) == Structure) { 00813 00814 if (! AT_DCL_ERR(TYP_IDX(type_idx))) { 00815 dt_idx = (AT_ATTR_LINK(TYP_IDX(type_idx)) == NULL_IDX) ? 00816 TYP_IDX(type_idx) : AT_ATTR_LINK(TYP_IDX(type_idx)); 00817 } 00818 else { 00819 output_minimal_object_rec(attr_idx); 00820 goto EXIT; 00821 } 00822 00823 00824 /* If the CIF derived type id is 0, it means that the derived type */ 00825 /* was use associated (or made available by other means?) and not */ 00826 /* included in the LN table, and thus we have to send it through now */ 00827 /* to get all of its members processed. Normally, the declaration */ 00828 /* rules of Fortran 90 would require the derived type to have been */ 00829 /* defined prior to its being used in a declaration (which would */ 00830 /* normally mean that it would already have been seen and processed).*/ 00831 00832 if (ATT_CIF_DT_ID(dt_idx) == 0) { 00833 cif_send_attr(dt_idx, NULL_IDX); 00834 } 00835 00836 00837 data_type = (linear_type_type) ATT_CIF_DT_ID(dt_idx); 00838 } 00839 else { 00840 data_type = TYP_LINEAR(type_idx); 00841 00842 if (TYP_TYPE(type_idx) == Character) { 00843 00844 if (TYP_FLD(type_idx) == CN_Tbl_Idx) { 00845 convert_to_string(&CN_CONST(TYP_IDX(type_idx)), 00846 CN_TYPE_IDX(TYP_IDX(type_idx)), 00847 char_len); 00848 } 00849 else { 00850 char_len[0] = (TYP_CHAR_CLASS(type_idx) == Assumed_Size_Char) ? 00851 ASSUMED_SIZE_CHAR : 00852 VAR_LEN_CHAR; 00853 char_len[1] = NULL_CHAR; 00854 } 00855 } 00856 } 00857 00858 00859 obj_name_ptr = AT_OBJ_NAME_PTR(attr_idx); 00860 00861 switch (ATD_CLASS(attr_idx)) { 00862 00863 case Struct_Component: 00864 storage_class = CIF_F90_ST_NO_STORAGE; 00865 storage_id = 0; 00866 offset = (ATD_OFFSET_FLD(attr_idx) == CN_Tbl_Idx) ? 00867 CN_INT_TO_C(ATD_CPNT_OFFSET_IDX(attr_idx)) : -1; 00868 symbol_class = CIF_F90_SC_STRUCT; 00869 attributes = 0; 00870 derived_type = ATT_CIF_DT_ID(dt_attr_idx); 00871 break; 00872 00873 case Constant: 00874 storage_class = CIF_F90_ST_NO_STORAGE; 00875 00876 if (AT_USE_ASSOCIATED(attr_idx)) { 00877 00878 if (AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)) == 0) { 00879 00880 /* If the module's symbol ID is 0, it probably means the */ 00881 /* module is being used indirectly. If so, the module Attr */ 00882 /* won't exist in the current scope (or any parent scope) so */ 00883 /* send it through to get an Entry Point record generated to */ 00884 /* resolve the storage id field of the Object record currently */ 00885 /* being constructed. */ 00886 00887 cif_send_attr(AT_MODULE_IDX(attr_idx), NULL_IDX); 00888 } 00889 00890 storage_id = AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)); 00891 } 00892 else if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) { 00893 storage_id = AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(curr_scp_idx)); 00894 } 00895 else { 00896 storage_id = 0; 00897 } 00898 00899 offset = -1; 00900 symbol_class = CIF_F90_SC_NAMED_CONST; 00901 attributes = 0; 00902 derived_type = 0; 00903 00904 /* If the named constant is use associated, spit out a dummy Named */ 00905 /* Constant record (line and column numbers will be zero and value */ 00906 /* is meaningful only if it is a simple constant). */ 00907 00908 if (AT_USE_ASSOCIATED(attr_idx)) { 00909 cif_named_constant_rec(attr_idx, 0, 0); 00910 } 00911 00912 break; 00913 00914 case Function_Result: 00915 00916 /* If get_other_func_rslt_info is TRUE, it means we're processing */ 00917 /* a function reference from one internal function to another or */ 00918 /* from one module function to another. If the function result of */ 00919 /* the CALLED function is of derived type, we need to produce all */ 00920 /* the records necessary to represent the derived type (and any */ 00921 /* nested derived types) in the scoping unit of the CALLING function */ 00922 /* because the referencing Entry Point record points to the Object */ 00923 /* record for the called function result which in turn contains the */ 00924 /* CIF derived type id. We must satisfy the derived type id which */ 00925 /* means we need to provide all the records to do so. To do this, */ 00926 /* we need to send all the Attrs representing the derived type in */ 00927 /* the CALLED function's scoping unit through cif_send_attr again. */ 00928 00929 if (get_other_func_rslt_info) { 00930 00931 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure) { 00932 AT_CIF_DONE(dt_idx) = FALSE; 00933 AT_CIF_SYMBOL_ID(dt_idx) = 0; 00934 ATT_CIF_DT_ID(dt_idx) = 0; 00935 cif_send_attr(dt_idx, NULL_IDX); 00936 data_type = (linear_type_type) ATT_CIF_DT_ID(dt_idx); 00937 } 00938 } 00939 00940 00941 if (ATD_STOR_BLK_IDX(attr_idx) == NULL_IDX) { /* Stmt func result */ 00942 storage_class = CIF_F90_ST_NO_STORAGE; 00943 storage_id = 0; 00944 } 00945 else { 00946 00947 /* May be the hidden first dummy arg, rather than the result. */ 00948 00949 storage_class = 00950 (SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx)) == Formal) ? 00951 CIF_F90_ST_DUMMY : CIF_F90_ST_STACK; 00952 00953 /* A function result can be use associated if the function */ 00954 /* belongs to an interface block that was use associated. */ 00955 00956 storage_id = (AT_USE_ASSOCIATED(attr_idx)) ? 00957 AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)) : 0; 00958 } 00959 00960 offset = -1; 00961 symbol_class = CIF_F90_SC_FUNC_RESULT; 00962 attributes = 0; 00963 derived_type = 0; 00964 00965 if (ATP_PROC(ATD_FUNC_IDX(attr_idx)) == Intrin_Proc && 00966 AT_OBJ_NAME(attr_idx) == '_') { 00967 ++obj_name_ptr; 00968 } 00969 00970 break; 00971 00972 case Dummy_Argument: 00973 derived_type = 0; 00974 symbol_class = CIF_F90_SC_VARIABLE; 00975 attributes = (AT_CIF_USE_IN_BND(attr_idx)) ? CIF_DARG_IN_BND : 0; 00976 storage_id = 0; 00977 00978 if (ATD_SF_DARG(attr_idx)) { 00979 offset = -1; 00980 storage_class = CIF_F90_ST_NO_STORAGE; 00981 } 00982 else { 00983 00984 /* If the dummy arg name is in the main entry point's dummy arg */ 00985 /* list, make its offset its position within the list. (If the */ 00986 /* same dummy arg is named in an alternate entry, the offset is */ 00987 /* meaningless.) If the dummy arg appeared in an alternate entry */ 00988 /* dummy arg list but not in the main dummy arg list, set its */ 00989 /* offset to 0. */ 00990 00991 storage_class = CIF_F90_ST_DUMMY; 00992 offset = 0; 00993 sn_idx = ATP_FIRST_IDX(SCP_ATTR_IDX(curr_scp_idx)); 00994 00995 for (i = 1; i <= ATP_NUM_DARGS(SCP_ATTR_IDX(curr_scp_idx)); ++i) { 00996 00997 if (attr_idx == SN_ATTR_IDX(sn_idx)) { 00998 offset = (ATP_EXTRA_DARG(SCP_ATTR_IDX(curr_scp_idx))) ? 00999 (i - 1) : i; 01000 break; 01001 } 01002 else { 01003 ++sn_idx; 01004 } 01005 } 01006 } 01007 01008 break; 01009 01010 default: 01011 derived_type = 0; 01012 symbol_class = CIF_F90_SC_VARIABLE; 01013 attributes = 0; 01014 offset = (ATD_OFFSET_ASSIGNED(attr_idx) && 01015 ATD_OFFSET_FLD(attr_idx) == CN_Tbl_Idx) ? 01016 CN_INT_TO_C(ATD_OFFSET_IDX(attr_idx)) : -1; 01017 01018 storage_id = SB_CIF_SYMBOL_ID(ATD_STOR_BLK_IDX(attr_idx)); 01019 01020 switch (SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx))) { 01021 01022 case Static: 01023 case Static_Local: 01024 case Static_Named: 01025 01026 if (ATD_ALLOCATABLE(attr_idx) || ATD_POINTER(attr_idx)) { 01027 storage_class = CIF_F90_ST_BASED; 01028 } 01029 else { 01030 storage_class = CIF_F90_ST_STATIC; 01031 } 01032 01033 if (SB_MODULE(ATD_STOR_BLK_IDX(attr_idx))) { 01034 symbol_class = CIF_F90_SC_MODULE; 01035 01036 storage_id = (AT_USE_ASSOCIATED(attr_idx)) ? 01037 AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)) : 01038 AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(curr_scp_idx)); 01039 } 01040 01041 break; 01042 01043 case Stack: 01044 case Equivalenced: 01045 if (ATD_ALLOCATABLE(attr_idx) || ATD_POINTER(attr_idx)) { 01046 storage_class = CIF_F90_ST_BASED; 01047 } 01048 else { 01049 storage_class = (ATD_AUXILIARY(attr_idx) == 0) ? 01050 CIF_F90_ST_STACK : CIF_F90_ST_AUXILIARY; 01051 } 01052 01053 break; 01054 01055 case Common: 01056 case Task_Common: 01057 symbol_class = (ATD_EQUIV(attr_idx) && !ATD_IN_COMMON(attr_idx)) ? 01058 CIF_F90_SC_EQUIV : 01059 CIF_F90_SC_COMMON; 01060 storage_class = (ATD_AUXILIARY(attr_idx) == 0) ? 01061 CIF_F90_ST_COMMON : CIF_F90_ST_AUXILIARY; 01062 break; 01063 01064 case Formal: 01065 storage_class = CIF_F90_ST_DUMMY; 01066 break; 01067 01068 case Based: 01069 storage_class = (ATD_CLASS(attr_idx) == CRI__Pointee) ? 01070 CIF_F90_ST_POINTEE : CIF_F90_ST_BASED; 01071 break; 01072 01073 default: 01074 storage_class = CIF_F90_ST_ERROR; 01075 break; 01076 } 01077 break; 01078 } 01079 01080 /* Set attributes */ 01081 01082 switch (TYP_DESC(type_idx)) { 01083 case Default_Typed: 01084 attributes = attributes | CIF_DEFAULT_TYPED; 01085 break; 01086 01087 case Star_Typed: 01088 attributes = attributes | CIF_STAR_TYPED; 01089 break; 01090 01091 case Kind_Typed: 01092 attributes = attributes | CIF_KIND_TYPED; 01093 break; 01094 } 01095 01096 if (!AT_TYPED(attr_idx)) { 01097 attributes = attributes | CIF_IMPLICITLY_TYPED; 01098 } 01099 01100 if (ATD_SAVED(attr_idx)) { 01101 attributes = attributes | CIF_SAVED; 01102 } 01103 01104 if (ATD_DATA_INIT(attr_idx)) { 01105 attributes = attributes | CIF_DATA_INIT; 01106 attributes = attributes | CIF_SAVED; /* Implied by initialization. */ 01107 } 01108 01109 if (ATD_DCL_EQUIV(attr_idx)) { 01110 attributes = attributes | CIF_EQUIVALENCED; 01111 } 01112 01113 if (ATD_ALLOCATABLE(attr_idx)) { 01114 attributes = attributes | CIF_ALLOCATABLE; 01115 } 01116 01117 if (ATD_CLASS(attr_idx) == Dummy_Argument) { 01118 01119 switch (ATD_INTENT(attr_idx)) { 01120 case Intent_Unseen: 01121 break; 01122 01123 case Intent_In: 01124 attributes = attributes | CIF_INTENT_IN; 01125 break; 01126 01127 case Intent_Out: 01128 attributes = attributes | CIF_INTENT_OUT; 01129 break; 01130 01131 case Intent_Inout: 01132 attributes = attributes | CIF_INTENT_INOUT; 01133 break; 01134 } 01135 01136 if (AT_OPTIONAL(attr_idx)) { 01137 attributes = attributes | CIF_OPTIONAL; 01138 } 01139 } 01140 01141 pointer_id = 0; 01142 01143 if (ATD_POINTER(attr_idx)) { 01144 attributes = attributes | CIF_POINTER; 01145 } 01146 else if (ATD_CLASS(attr_idx) == CRI__Pointee) { 01147 attributes = attributes | CIF_CRI_POINTEE; 01148 01149 if (AT_CIF_SYMBOL_ID(ATD_PTR_IDX(attr_idx)) == 0) { 01150 AT_CIF_SYMBOL_ID(ATD_PTR_IDX(attr_idx)) = NEXT_SYMBOL_ID; 01151 } 01152 01153 pointer_id = AT_CIF_SYMBOL_ID(ATD_PTR_IDX(attr_idx)); 01154 } 01155 01156 if (AT_PRIVATE(attr_idx)) { 01157 attributes = attributes | CIF_PRIVATE; 01158 } 01159 01160 if (ATD_TARGET(attr_idx)) { 01161 attributes = attributes | CIF_TARGET; 01162 } 01163 01164 if (AT_USE_ASSOCIATED(attr_idx) && 01165 AT_ORIG_NAME_IDX(attr_idx) != AT_NAME_IDX(attr_idx)) { 01166 attributes = attributes | CIF_RENAMED; 01167 } 01168 01169 scope_id = SCP_CIF_ID(curr_scp_idx); 01170 01171 if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) { 01172 CONVERT_CVAL_TO_STR(&offset, Integer_8, offset_buf); 01173 01174 if (fprintf(c_i_f, 01175 "%d%c%s%c%d%c%d%c%d%c%d%c%d%c%d%c%s%c%lx%c%d%c%s%c%d%c%d%c%d%c%d%c%d%c", 01176 CIF_F90_OBJECT, EOI, 01177 obj_name_ptr, EOI, 01178 AT_CIF_SYMBOL_ID(attr_idx), EOI, 01179 scope_id, EOI, 01180 cif_data_type(data_type), EOI, 01181 symbol_class, EOI, 01182 storage_class, EOI, 01183 storage_id, EOI, 01184 offset_buf, EOI, 01185 attributes, EOI, 01186 derived_type, EOI, 01187 char_len, EOI, 01188 0, EOI, /* num dims */ 01189 0, EOI, /* array type */ 01190 0, EOI, /* distribution */ 01191 0, EOI, /* geometry id */ 01192 pointer_id, EOR) < 0) { 01193 Cif_Error(); 01194 } 01195 } 01196 else { 01197 bd_idx = ATD_ARRAY_IDX(attr_idx); 01198 buffer[0] = NULL_CHAR; 01199 01200 /* if (BD_ARRAY_CLASS(bd_idx) == Assumed_Shape) { 01201 01202 for (i = 1; i <= BD_RANK(bd_idx); i++) { 01203 01204 if (BD_LB_FLD(bd_idx,i) == CN_Tbl_Idx) { 01205 sprintf(string, "%c%s", 01206 EOI, 01207 convert_to_string(&CN_CONST(BD_LB_IDX(bd_idx,i)), 01208 CN_TYPE_IDX(BD_LB_IDX(bd_idx,i)), 01209 outbuf1)); 01210 } 01211 else { 01212 string[0] = EOI; 01213 string[1] = VAR_LEN_CHAR; 01214 string[2] = NULL_CHAR; 01215 } 01216 strcat(buffer, string); 01217 } 01218 } 01219 */ 01220 /* else if (BD_ARRAY_CLASS(bd_idx) != Deferred_Shape) */ 01221 { 01222 01223 for (i = 1; i <= BD_RANK(bd_idx); i++) { 01224 01225 if (BD_LB_FLD(bd_idx,i) == CN_Tbl_Idx) { 01226 sprintf(string, "%c%s", 01227 EOI, 01228 convert_to_string(&CN_CONST(BD_LB_IDX(bd_idx,i)), 01229 CN_TYPE_IDX(BD_LB_IDX(bd_idx,i)), 01230 outbuf1)); 01231 } 01232 else if (BD_LB_FLD(bd_idx,i) != NO_Tbl_Idx) { 01233 string[0] = EOI; 01234 string[1] = VAR_LEN_CHAR; 01235 string[2] = NULL_CHAR; 01236 } 01237 01238 strcat(buffer, string); 01239 01240 if (BD_ARRAY_CLASS(bd_idx) == Assumed_Size && 01241 BD_RANK(bd_idx) == i) { 01242 string[0] = EOI; 01243 string[1] = ASSUMED_SIZE_CHAR; 01244 string[2] = NULL_CHAR; 01245 } 01246 else if (BD_UB_FLD(bd_idx,i) == CN_Tbl_Idx) { 01247 sprintf(string, "%c%s", 01248 EOI, 01249 convert_to_string(&CN_CONST(BD_UB_IDX(bd_idx,i)), 01250 CN_TYPE_IDX(BD_UB_IDX(bd_idx,i)), 01251 outbuf1)); 01252 } 01253 else { 01254 string[0] = EOI; 01255 string[1] = (BD_UB_FLD(bd_idx,i) != NO_Tbl_Idx) ? 01256 VAR_LEN_CHAR : 01257 ASSUMED_SIZE_CHAR; 01258 string[2] = NULL_CHAR; 01259 } 01260 strcat(buffer, string); 01261 } 01262 } 01263 01264 CONVERT_CVAL_TO_STR(&offset, Integer_8, offset_buf); 01265 01266 if (fprintf(c_i_f, 01267 "%d%c%s%c%d%c%d%c%d%c%d%c%d%c%d%c%s%c%lx%c%d%c%s%c%d%c%d%s%c%d%c%d%c%d%c", 01268 CIF_F90_OBJECT, EOI, 01269 AT_OBJ_NAME_PTR(attr_idx), EOI, 01270 AT_CIF_SYMBOL_ID(attr_idx), EOI, 01271 SCP_CIF_ID(curr_scp_idx), EOI, 01272 cif_data_type(data_type), EOI, 01273 symbol_class, EOI, 01274 storage_class, EOI, 01275 storage_id, EOI, 01276 offset_buf, EOI, 01277 attributes, EOI, 01278 derived_type, EOI, 01279 char_len, EOI, 01280 BD_RANK(bd_idx), EOI, 01281 BD_ARRAY_CLASS(bd_idx), 01282 buffer, EOI, 01283 0, EOI, /* distribution */ 01284 0, EOI, /* geometry id */ 01285 pointer_id, EOR) < 0) { 01286 Cif_Error(); 01287 } 01288 } 01289 01290 break; 01291 01292 01293 /* ----------------------------------------------------------------------- */ 01294 /* Pgm_Unit */ 01295 /* ----------------------------------------------------------------------- */ 01296 01297 case Pgm_Unit: 01298 01299 if (ATP_PROC(attr_idx) != Intrin_Proc && 01300 ((name_pool[AT_NAME_IDX(attr_idx)].name_char == '$' && 01301 attr_idx != glb_tbl_idx[Main_Attr_Idx]) || 01302 name_pool[AT_NAME_IDX(attr_idx)].name_char == '_')) { /* Lib call */ 01303 break; 01304 } 01305 01306 /* If the Attr entry is marked in error, produce an Entry Point record */ 01307 /* anyway so that its symbol id will be defined. See the comments at */ 01308 /* the head of the Data_Obj case for details. */ 01309 01310 if (AT_DCL_ERR(attr_idx)) { 01311 01312 if (AT_CIF_SYMBOL_ID(attr_idx) == 0) { 01313 AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID; 01314 } 01315 01316 Cif_F90_Entry_Rec(c_i_f, 01317 AT_OBJ_NAME_PTR(attr_idx), 01318 AT_CIF_SYMBOL_ID(attr_idx), 01319 SCP_CIF_ID(curr_scp_idx), 01320 0, 01321 0, 01322 0, 01323 0, 01324 0, 01325 0, 01326 NULL); 01327 goto EXIT; 01328 } 01329 01330 if (ATP_IN_INTERFACE_BLK(attr_idx)) { 01331 01332 if (ATP_SCP_ALIVE(attr_idx)) { 01333 attributes = CIF_PGM_IN_INTERFACE; 01334 } 01335 else if (AT_REFERENCED(attr_idx) != Not_Referenced) { 01336 attributes = CIF_PGM_REFERENCE; 01337 } 01338 else { 01339 01340 /* This stops interface body records from being produced in the */ 01341 /* host procedure if the interface body is not referenced. */ 01342 01343 AT_CIF_DONE(attr_idx) = FALSE; 01344 goto EXIT; 01345 } 01346 } 01347 else if (ATP_SCP_ALIVE(attr_idx)) { 01348 attributes = CIF_PGM_DEFINITION; 01349 } 01350 else if (AT_REFERENCED(attr_idx) != Not_Referenced && 01351 ! AT_REF_IN_CHILD(attr_idx)) { 01352 01353 /* The program unit is being referenced in some fashion but its */ 01354 /* scope is not alive. If Attr for the entry point exists because */ 01355 /* it was referenced in a child scope (for example, one internal */ 01356 /* procedure references another so an Attr for the referenced */ 01357 /* internal procedure also exists at the parent level), then DON'T */ 01358 /* send it through again or it will mess up the Usage records that */ 01359 /* have already been generated (their symbol ids won't match the */ 01360 /* symbol id in the Attr we're currently processing). */ 01361 /* In contrast, if one sibling is referencing another and we're in */ 01362 /* of the sibling scopes, reset AT_CIF_DONE back to FALSE so the */ 01363 /* definitional Entry Point record will be produced when the Attr is */ 01364 /* sent through cif_send_attr a little later. */ 01365 01366 AT_CIF_DONE(attr_idx) = FALSE; 01367 01368 01369 /* If the program unit name is a dummy argument AND it's referenced */ 01370 /* somewhere in the current procedure, we don't want to produce */ 01371 /* multiple Entry Point records for it but for the above reasons we */ 01372 /* can't use AT_CIF_DONE so use ATP_CIF_DARG_PROC. If this flag is */ 01373 /* TRUE, we're processing the dummy arg so clear it and continue. */ 01374 /* If it's FALSE, we're here the second time for the reference so */ 01375 /* quit. */ 01376 01377 if (AT_IS_DARG(attr_idx)) { 01378 01379 if (ATP_CIF_DARG_PROC(attr_idx)) { 01380 ATP_CIF_DARG_PROC(attr_idx) = FALSE; 01381 } 01382 else { 01383 goto EXIT; 01384 } 01385 } 01386 01387 01388 /* If this is a module procedure and it was referenced by another */ 01389 /* module procedure but we are now processing the Attrs in the */ 01390 /* specification part of the module, do not produce an Entry Point */ 01391 /* record for the module procedure now. Produce it when the module */ 01392 /* procedure is being processed. */ 01393 /* The second case covers a module that's been used indirectly. */ 01394 01395 if (ATP_PROC(attr_idx) == Module_Proc && 01396 ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) { 01397 goto EXIT; 01398 } 01399 else if (ATP_PGM_UNIT(attr_idx) == Module && 01400 AT_USE_ASSOCIATED(attr_idx)) { 01401 attributes = CIF_PGM_USE_ASSOCIATED; 01402 } 01403 else { 01404 attributes = CIF_PGM_REFERENCE; 01405 } 01406 } 01407 else if (AT_IS_DARG(attr_idx)) { 01408 01409 /* If the program unit name is a dummy argument and its name is not */ 01410 /* "referenced" in the Fortran 90 sense, an Entry Point record still */ 01411 /* must be generated to satisfy the symbol ID in the Usage record */ 01412 /* generated for the appearance of the name. */ 01413 01414 attributes = CIF_PGM_REFERENCE; 01415 } 01416 else if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit && 01417 (ATP_VFUNCTION(attr_idx) || 01418 ATP_NOSIDE_EFFECTS(attr_idx) || 01419 ATP_NAME_IN_STONE(attr_idx) || 01420 ATP_DCL_EXTERNAL(attr_idx))) { 01421 01422 /* Same idea as above for a dummy arg procedure. If the name only */ 01423 /* appears in an EXTERNAL stmt, we must still generate an Entry */ 01424 /* Point record to satisfy the Usage record. */ 01425 /* Also VFUNCTION, NOSIDE EFFECTS and NAME dirs. */ 01426 01427 attributes = CIF_PGM_REFERENCE; 01428 } 01429 else if (AT_USE_ASSOCIATED(attr_idx)) { 01430 01431 /* This case catches a module procedure that was brought in by use */ 01432 /* association but never referenced. Without this case, if it was */ 01433 /* brought in and never invoked but WAS named in a PUBLIC stmt, for */ 01434 /* instance, a Usage record for the PUBLIC stmt appearance would be */ 01435 /* generated but no Entry Point record would be generated to satisfy */ 01436 /* the symbol id in the Usage record. */ 01437 /* CIF_PGM_USE_ASSOCIATED is added to "attributes" later. */ 01438 01439 } 01440 else { 01441 01442 /* This stops internal and module procedure records from being */ 01443 /* produced in the host procedure if the internal or module */ 01444 /* procedure was not referenced. */ 01445 01446 AT_CIF_DONE(attr_idx) = FALSE; 01447 goto EXIT; 01448 } 01449 01450 01451 /* If AT_ATTR_LINK is not NULL_IDX, it means we're processing: */ 01452 /* - a reference from one module procedure to another module */ 01453 /* procedure in the same module, */ 01454 /* - a reference from one module procedure to another module */ 01455 /* procedure but the other module procedure name was use associated */ 01456 /* into the module specification part, */ 01457 /* - a reference from one internal procedure to another internal */ 01458 /* procedure within the same program unit, */ 01459 /* - a reference from an internal procedure to another procedure */ 01460 /* where the other procedure name is host associated into the */ 01461 /* internal procedure, or */ 01462 /* - a procedure that belongs to an interface block. */ 01463 /* If the reference is to another procedure whose name is known in an */ 01464 /* outer scope, get some of the info from the outer Attr. */ 01465 01466 if (AT_ATTR_LINK(attr_idx) == NULL_IDX) { 01467 get_other_func_rslt_info = FALSE; 01468 } 01469 else if (AT_OBJ_CLASS(AT_ATTR_LINK(attr_idx)) != Interface) { 01470 get_other_func_rslt_info = TRUE; 01471 attr_idx = AT_ATTR_LINK(attr_idx); 01472 } 01473 else { 01474 goto EXIT; 01475 } 01476 01477 if (AT_CIF_SYMBOL_ID(attr_idx) == 0) { 01478 AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID; 01479 } 01480 01481 switch (ATP_PGM_UNIT(attr_idx)) { 01482 01483 case Pgm_Unknown: 01484 pgm_unit_type = CIF_F90_ET_UNKNOWN; 01485 num_dargs = ATP_NUM_DARGS(attr_idx); 01486 break; 01487 01488 case Function: 01489 pgm_unit_type = 01490 (ATP_ALT_ENTRY(attr_idx)) ? CIF_F90_ET_ALT_ENTRY : 01491 CIF_F90_ET_FUNCTION; 01492 01493 /* This may be a reference only. Then there is no darg list */ 01494 /* but ATP_EXTRA_DARG will be set. */ 01495 01496 if (ATP_EXPL_ITRFC(attr_idx) && ATP_EXTRA_DARG(attr_idx)) { 01497 num_dargs = ATP_NUM_DARGS(attr_idx) - 1; 01498 } 01499 else { 01500 num_dargs = ATP_NUM_DARGS(attr_idx); 01501 } 01502 01503 if (AT_USE_ASSOCIATED(attr_idx)) { 01504 attributes = attributes | CIF_PGM_USE_ASSOCIATED; 01505 } 01506 01507 break; 01508 01509 case Subroutine: 01510 pgm_unit_type = 01511 (ATP_ALT_ENTRY(attr_idx)) ? CIF_F90_ET_ALT_ENTRY : 01512 CIF_F90_ET_SUBROUTINE; 01513 01514 num_dargs = ATP_NUM_DARGS(attr_idx); 01515 01516 if (AT_USE_ASSOCIATED(attr_idx)) { 01517 attributes = attributes | CIF_PGM_USE_ASSOCIATED; 01518 } 01519 01520 break; 01521 01522 case Program: 01523 num_dargs = 0; 01524 pgm_unit_type= CIF_F90_ET_PROGRAM; 01525 break; 01526 01527 case Blockdata: 01528 num_dargs = 0; 01529 pgm_unit_type = CIF_F90_ET_BLOCKDATA; 01530 break; 01531 01532 case Module: 01533 num_dargs = 0; 01534 pgm_unit_type= CIF_F90_ET_MODULE; 01535 } 01536 01537 if ((attributes & CIF_PGM_REFERENCE) || 01538 AT_USE_ASSOCIATED(attr_idx) || 01539 get_other_func_rslt_info) { 01540 num_dargs = 0; 01541 } 01542 01543 01544 if (AT_OPTIONAL(attr_idx)) { 01545 attributes = attributes | CIF_PGM_OPTIONAL; 01546 } 01547 01548 01549 /* The Attr entry associated with the SCP for a module is marked */ 01550 /* private if the module contains a bare PRIVATE statement. But the */ 01551 /* name of the module does not have an accessibility attribute */ 01552 /* associated with it - only the names within the module. So don't set */ 01553 /* the CIF PRIVATE attribute in this case. */ 01554 01555 if (AT_PRIVATE(attr_idx) && ATP_PGM_UNIT(attr_idx) != Module) { 01556 attributes = attributes | CIF_PGM_PRIVATE; 01557 } 01558 01559 if (ATP_RECURSIVE(attr_idx)) { 01560 attributes = attributes | CIF_PGM_RECURSIVE; 01561 } 01562 01563 if (ATP_PGM_UNIT(attr_idx) == Function) { 01564 rslt_idx = ATP_RSLT_IDX(attr_idx); 01565 01566 if (ATP_SCP_ALIVE(attr_idx)) { 01567 01568 if (! AT_CIF_DONE(rslt_idx)) { 01569 cif_send_attr(rslt_idx, NULL_IDX); 01570 } 01571 01572 rslt_id = AT_CIF_SYMBOL_ID(rslt_idx); 01573 } 01574 else { 01575 01576 /* We might be getting information from an outer Attr for */ 01577 /* multiple references to a function whose name is known in an */ 01578 /* outer scope. We need to produce an Object record for the */ 01579 /* result to satisfy the symbol id in the Entry Point record. */ 01580 /* If the function has been called before, the result would have */ 01581 /* already been processed which means we need to clear */ 01582 /* AT_CIF_DONE so an Object record can be produced in the current */ 01583 /* scope. Since the function's scope is not alive, it may well */ 01584 /* be processed AFTER this (that is, the Pgm_Unit attr we're */ 01585 /* processing now could be due to a forward reference). This */ 01586 /* means we need to save the symbol id and restore it so that if */ 01587 /* we later process the result when its scope is alive, the */ 01588 /* symbol id will match the symbol ids in the Usage records that */ 01589 /* were generated for the result. */ 01590 01591 AT_CIF_DONE(rslt_idx) = FALSE; 01592 01593 # if 0 01594 save_symbol_id = AT_CIF_SYMBOL_ID(rslt_idx); 01595 AT_CIF_SYMBOL_ID(rslt_idx) = 0; 01596 # endif 01597 cif_send_attr(rslt_idx, NULL_IDX); 01598 rslt_id = AT_CIF_SYMBOL_ID(rslt_idx); 01599 # if 0 01600 AT_CIF_SYMBOL_ID(rslt_idx) = save_symbol_id; 01601 # endif 01602 AT_CIF_DONE(rslt_idx) = FALSE; 01603 } 01604 } 01605 else { 01606 rslt_id = 0; 01607 } 01608 01609 if (ATP_PROC(attr_idx) == Module_Proc) { 01610 01611 if (AT_MODULE_IDX(attr_idx) == 0) { 01612 storage_id = (SCP_LEVEL(curr_scp_idx) == 0) ? 01613 AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(curr_scp_idx)) : 01614 AT_CIF_SYMBOL_ID( 01615 SCP_ATTR_IDX(SCP_PARENT_IDX(curr_scp_idx))); 01616 } 01617 else { 01618 01619 if (AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)) == 0) { 01620 01621 /* If the module's symbol id is 0, it probably means the */ 01622 /* module is being used indirectly. If so, the module Attr */ 01623 /* won't exist in the current scope (or any parent scope) so */ 01624 /* send it through to get an Entry record generated to resolve */ 01625 /* the storage id field of the Object record currently being */ 01626 /* constructed. */ 01627 01628 cif_send_attr(AT_MODULE_IDX(attr_idx), NULL_IDX); 01629 } 01630 01631 storage_id = AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)); 01632 } 01633 } 01634 else if (AT_USE_ASSOCIATED(attr_idx)) { 01635 01636 if (AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)) == 0) { 01637 01638 /* See reasoning above for sending the module's Attr through */ 01639 /* cif_send_attr. */ 01640 01641 cif_send_attr(AT_MODULE_IDX(attr_idx), NULL_IDX); 01642 } 01643 01644 storage_id = AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)); 01645 } 01646 else { 01647 storage_id = 0; 01648 } 01649 01650 if (num_dargs != 0) { 01651 sn_idx = ATP_FIRST_IDX(attr_idx); 01652 01653 if (ATP_EXTRA_DARG(attr_idx)) { 01654 ++sn_idx; 01655 } 01656 01657 for (i = 0; i < num_dargs; i++) { 01658 darg_idx = SN_ATTR_IDX(sn_idx++); 01659 01660 if (! AT_COMPILER_GEND(darg_idx)) { 01661 01662 /* Not an alternate return dummy arg. */ 01663 01664 /* If the program unit name is a dummy arg AND it's referenced */ 01665 /* somewhere in the current procedure, we don't want to */ 01666 /* produce multiple Entry Point records for it but for reasons */ 01667 /* documented earlier in the Pgm_Unit case we can't use */ 01668 /* AT_CIF_DONE. So set ATP_CIF_DARG_PROC to indicate we should*/ 01669 /* process the Attr as a dummy arg. The flag is cleared */ 01670 /* farther up in this case code. */ 01671 01672 if (AT_OBJ_CLASS(darg_idx) == Pgm_Unit) { 01673 ATP_CIF_DARG_PROC(darg_idx) = TRUE; 01674 } 01675 01676 cif_send_attr(darg_idx, NULL_IDX); 01677 } 01678 } 01679 } 01680 01681 if (fprintf(c_i_f, 01682 "%d%c%s%c%d%c%d%c%d%c%d%c%lx%c%d%c%d%c%d", 01683 CIF_F90_ENTRY, EOI, 01684 AT_OBJ_NAME_PTR(attr_idx), EOI, 01685 AT_CIF_SYMBOL_ID(attr_idx), EOI, 01686 SCP_CIF_ID(curr_scp_idx), EOI, 01687 pgm_unit_type, EOI, 01688 ATP_PROC(attr_idx), EOI, 01689 attributes, EOI, 01690 rslt_id, EOI, 01691 storage_id, EOI, 01692 num_dargs) < 0) { 01693 Cif_Error(); 01694 } 01695 01696 if (num_dargs != 0) { 01697 sn_idx = ATP_FIRST_IDX(attr_idx); 01698 01699 if (ATP_EXTRA_DARG(attr_idx)) { 01700 ++sn_idx; 01701 } 01702 01703 for (i = 0; i < num_dargs; i++) { 01704 darg_idx = SN_ATTR_IDX(sn_idx++); 01705 01706 if (AT_COMPILER_GEND(darg_idx)) { /* An alternate return darg. */ 01707 darg_idx = 0; 01708 } 01709 else { 01710 darg_idx = AT_CIF_SYMBOL_ID(darg_idx); 01711 } 01712 01713 if (fprintf(c_i_f, "%c%d", EOI, darg_idx) < 0) { 01714 Cif_Error(); 01715 } 01716 } 01717 } 01718 01719 if (fprintf(c_i_f, "\n") < 0) { 01720 Cif_Error(); 01721 } 01722 01723 get_other_func_rslt_info = FALSE; 01724 01725 break; 01726 01727 01728 /* ----------------------------------------------------------------------- */ 01729 /* Label */ 01730 /* ----------------------------------------------------------------------- */ 01731 01732 case Label: 01733 cif_label_rec(attr_idx); 01734 break; 01735 01736 01737 /* ----------------------------------------------------------------------- */ 01738 /* Derived_Type */ 01739 /* ----------------------------------------------------------------------- */ 01740 01741 case Derived_Type: 01742 01743 # if 0 01744 /* If the Attr entry is marked in error, produce a Derived Type Def */ 01745 /* record anyway so that its symbol id will be defined. See the */ 01746 /* comments at the head of the Data_Obj case for details. */ 01747 01748 if (AT_DCL_ERR(attr_idx)) { 01749 01750 if (AT_CIF_SYMBOL_ID(attr_idx) == 0) { 01751 AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID; 01752 } 01753 01754 Cif_F90_Derived_Type_Rec(c_i_f, 01755 AT_OBJ_NAME_PTR(attr_idx), 01756 AT_CIF_SYMBOL_ID(attr_idx), 01757 SCP_CIF_ID(curr_scp_idx), 01758 ATT_CIF_DT_ID(attr_idx), 01759 0, 01760 0, 01761 NULL, 01762 0); 01763 goto EXIT; 01764 } 01765 # endif 01766 01767 if (AT_CIF_SYMBOL_ID(attr_idx) == 0) { 01768 AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID; 01769 } 01770 01771 if (ATT_CIF_DT_ID(attr_idx) == 0) { 01772 ATT_CIF_DT_ID(attr_idx) = NEXT_DERIVED_TYPE_ID; 01773 } 01774 01775 attributes = (ATT_SEQUENCE_SET(attr_idx)) ? (CIF_DRT_SEQUENCE) : 0; 01776 01777 if (AT_PRIVATE(attr_idx)) { 01778 attributes = attributes | CIF_DRT_PRIVATE; 01779 } 01780 01781 if (ATT_PRIVATE_CPNT(attr_idx)) { 01782 attributes = attributes | CIF_DRT_COMP_PRIVATE; 01783 } 01784 01785 sn_idx = ATT_FIRST_CPNT_IDX(attr_idx); 01786 01787 while (sn_idx != NULL_IDX) { 01788 01789 if (get_other_func_rslt_info) { 01790 AT_CIF_DONE(SN_ATTR_IDX(sn_idx)) = FALSE; 01791 AT_CIF_SYMBOL_ID(SN_ATTR_IDX(sn_idx)) = 0; 01792 } 01793 01794 cif_send_attr(SN_ATTR_IDX(sn_idx), attr_idx); 01795 sn_idx = SN_SIBLING_LINK(sn_idx); 01796 } 01797 01798 if (fprintf(c_i_f, "%d%c%s%c%d%c%d%c%d%c%lx%c%d", 01799 CIF_F90_DERIVED_TYPE, EOI, 01800 AT_OBJ_NAME_PTR(attr_idx), EOI, 01801 AT_CIF_SYMBOL_ID(attr_idx), EOI, 01802 SCP_CIF_ID(curr_scp_idx), EOI, 01803 ATT_CIF_DT_ID(attr_idx), EOI, 01804 attributes, EOI, 01805 ATT_NUM_CPNTS(attr_idx)) < 0) { 01806 Cif_Error(); 01807 } 01808 01809 sn_idx = ATT_FIRST_CPNT_IDX(attr_idx); 01810 01811 while (sn_idx != NULL_IDX) { 01812 01813 if (fprintf(c_i_f, "%c%d", 01814 EOI, AT_CIF_SYMBOL_ID(SN_ATTR_IDX(sn_idx))) < 0) { 01815 Cif_Error(); 01816 } 01817 01818 sn_idx = SN_SIBLING_LINK(sn_idx); 01819 } 01820 01821 if (fprintf(c_i_f, "\n") < 0) { 01822 Cif_Error(); 01823 } 01824 01825 break; 01826 01827 01828 /* ----------------------------------------------------------------------- */ 01829 /* Interface */ 01830 /* ----------------------------------------------------------------------- */ 01831 01832 case Interface: 01833 01834 /* If the interface identifier is marked in error but its symbol id has */ 01835 /* been referenced somewhere (like in a Usage record), output a dummy */ 01836 /* Interface Block record to define the symbol id). */ 01837 01838 if (AT_DCL_ERR(attr_idx) && AT_CIF_SYMBOL_ID(attr_idx) != 0) { 01839 scope_id = (AT_USE_ASSOCIATED(attr_idx)) ? 01840 SCP_CIF_ID(curr_scp_idx) : 01841 ATI_CIF_SCOPE_ID(attr_idx); 01842 01843 switch (ATI_INTERFACE_CLASS(attr_idx)) { 01844 01845 case Defined_Assign_Interface: 01846 interface_type = CIF_IB_ASSIGNMENT; 01847 break; 01848 01849 case Generic_Unknown_Interface: 01850 case Generic_Function_Interface: 01851 case Generic_Subroutine_Interface: 01852 interface_type = CIF_IB_GENERIC; 01853 break; 01854 01855 default: 01856 interface_type = CIF_IB_OPERATOR; 01857 break; 01858 } 01859 01860 Cif_F90_Int_Block_Rec(c_i_f, 01861 AT_OBJ_NAME_PTR(attr_idx), 01862 AT_CIF_SYMBOL_ID(attr_idx), 01863 scope_id, 01864 interface_type, 01865 0, 01866 0, 01867 NULL, 01868 0); 01869 01870 goto EXIT; 01871 } 01872 01873 01874 if (AT_CIF_SYMBOL_ID(attr_idx) == 0) { 01875 AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID; 01876 } 01877 01878 01879 /* If the interface block was brought in from a module and the module's */ 01880 /* Attr entry has not yet been produced, normally the module's Attr */ 01881 /* entry would be sent through cif_send_attr to get an Entry Point */ 01882 /* record produced. But if the interface is for an intrinsic procedure,*/ 01883 /* don't do this because it will cause redundant Entry Point records to */ 01884 /* be generated. See the "if" stmt immediately following the one this */ 01885 /* comment is documenting. */ 01886 01887 if (AT_USE_ASSOCIATED(attr_idx) && 01888 AT_MODULE_IDX(attr_idx) != NULL_IDX && 01889 ! AT_CIF_DONE(AT_MODULE_IDX(attr_idx))) { 01890 01891 if (AT_IS_INTRIN(attr_idx) && 01892 ! ATI_USER_SPECIFIED(attr_idx) && 01893 ATI_CIF_SEEN_IN_CALL(attr_idx)) { 01894 01895 /* Do nothing. Easier to visualize the code this way. */ 01896 01897 } 01898 else { 01899 cif_send_attr(AT_MODULE_IDX(attr_idx), NULL_IDX); 01900 } 01901 } 01902 01903 01904 if (AT_IS_INTRIN(attr_idx) && ! ATI_USER_SPECIFIED(attr_idx)) { 01905 01906 /* If this intrinsic procedure has been referenced and a Call Site */ 01907 /* record was output to record the call, then the Entry record (and */ 01908 /* Object record if it is a function) have already been output. */ 01909 01910 if (ATI_CIF_SEEN_IN_CALL(attr_idx)) { 01911 goto EXIT; 01912 } 01913 01914 01915 rslt_id = 0; 01916 01917 if (ATI_INTERFACE_CLASS(attr_idx) == Generic_Function_Interface) { 01918 pgm_unit_type = CIF_F90_ET_FUNCTION; 01919 01920 01921 /* Count on the fact that the last specific Attr in the intrinsic */ 01922 /* interface block is the "default" type Attr. That is, if the */ 01923 /* specific form of the intrinsic is passed as an actual argument,*/ 01924 /* this is the one that records what the specific's argument type */ 01925 /* must be (and thus the result type of the specific). Generics */ 01926 /* can't be passed as arguments but some, like SQRT, have the */ 01927 /* same generic and specific name and cflint needs to have a */ 01928 /* result type to compare the characteristics of actual procedure */ 01929 /* arguments to how the dummy procedure argument is invoked. */ 01930 01931 sn_idx = ATI_FIRST_SPECIFIC_IDX(attr_idx); 01932 01933 for (i = 2; i <= ATI_NUM_SPECIFICS(attr_idx); ++i) { 01934 sn_idx = SN_SIBLING_LINK(sn_idx); 01935 } 01936 01937 rslt_idx = ATP_RSLT_IDX(SN_ATTR_IDX(sn_idx)); 01938 01939 01940 /* Always send the function result Attr through even though its */ 01941 /* symbol id might already be nonzero and AT_CIF_DONE might */ 01942 /* already be TRUE because the Entry Point record generated for */ 01943 /* each intrinsic function in each CIF scope must have an */ 01944 /* associated Object record to pass on to CIF the function */ 01945 /* result type. For example, if a module contains several module */ 01946 /* procedures, each of which reference BIT_SIZE, each module */ 01947 /* procedure has its own Attr for BIT_SIZE but they all refer to */ 01948 /* the same function result Attr so we can't go by CIF_SYMBOL_ID */ 01949 /* being 0 in that function result Attr. */ 01950 01951 save_cif_done = AT_CIF_DONE(rslt_idx); 01952 AT_CIF_DONE(rslt_idx) = FALSE; 01953 cif_send_attr(rslt_idx, NULL_IDX); 01954 AT_CIF_DONE(rslt_idx) = save_cif_done; 01955 01956 rslt_id = AT_CIF_SYMBOL_ID(rslt_idx); 01957 } 01958 else if (ATI_INTERFACE_CLASS(attr_idx) ==Generic_Subroutine_Interface){ 01959 pgm_unit_type = CIF_F90_ET_SUBROUTINE; 01960 } 01961 else { 01962 pgm_unit_type = CIF_F90_ET_UNKNOWN; 01963 } 01964 01965 attributes = CIF_PGM_REFERENCE; 01966 01967 if (AT_PRIVATE(attr_idx)) { 01968 attributes = attributes | CIF_PGM_PRIVATE; 01969 } 01970 01971 Cif_F90_Entry_Rec(c_i_f, 01972 AT_OBJ_NAME_PTR(attr_idx), 01973 AT_CIF_SYMBOL_ID(attr_idx), 01974 SCP_CIF_ID(curr_scp_idx), 01975 pgm_unit_type, 01976 CIF_F90_PT_INTRINSIC, 01977 attributes, 01978 rslt_id, 01979 0, 01980 0, 01981 NULL); 01982 01983 break; 01984 } 01985 01986 if (ATI_UNNAMED_INTERFACE(attr_idx)) { 01987 01988 if (fprintf(c_i_f, 01989 "%d%c%c%d%c%d%c%d%c%x%c%d", 01990 CIF_F90_INT_BLOCK, EOI, 01991 EOI, /* Do not put out name */ 01992 AT_CIF_SYMBOL_ID(attr_idx), EOI, 01993 ATI_CIF_SCOPE_ID(attr_idx), EOI, 01994 CIF_IB_SPECIFIC, EOI, 01995 0, EOI, 01996 ATI_NUM_SPECIFICS(attr_idx)) < 0) { 01997 Cif_Error(); 01998 } 01999 } 02000 else { 02001 02002 if (ATI_PROC_IDX(attr_idx) != NULL_IDX) { 02003 cif_send_attr(ATI_PROC_IDX(attr_idx), NULL_IDX); 02004 } 02005 02006 attributes = (AT_PRIVATE(attr_idx)) ? 1 : 0; 02007 02008 switch (ATI_INTERFACE_CLASS(attr_idx)) { 02009 case Defined_Assign_Interface: 02010 interface_type = CIF_IB_ASSIGNMENT; 02011 break; 02012 02013 case Generic_Unknown_Interface: 02014 case Generic_Function_Interface: 02015 case Generic_Subroutine_Interface: 02016 interface_type = CIF_IB_GENERIC; 02017 break; 02018 02019 default: 02020 interface_type = CIF_IB_OPERATOR; 02021 break; 02022 } 02023 02024 /* If the interface block is pulled in from a module, there are no */ 02025 /* Begin Scope or End Scope records associated with it (they only */ 02026 /* occur where the interface block was defined). So give it the */ 02027 /* scope id of the current scope (the USEing scope) so that libcif */ 02028 /* some kind of valid scope id to sort by. */ 02029 /* LRR: Could this same thing happen if the interface block is */ 02030 /* pulled in from a host scoping unit? */ 02031 /* LRR: We may need to add a flag to the Interface Block record in */ 02032 /* the future to flag the fact that scope id is the containing */ 02033 /* scope rather than the scope that the interface blk defines. */ 02034 02035 scope_id = (AT_USE_ASSOCIATED(attr_idx)) ? 02036 SCP_CIF_ID(curr_scp_idx) : 02037 ATI_CIF_SCOPE_ID(attr_idx); 02038 02039 if (fprintf(c_i_f, 02040 "%d%c%s%c%d%c%d%c%d%c%lx%c%d", 02041 CIF_F90_INT_BLOCK, EOI, 02042 AT_OBJ_NAME_PTR(attr_idx), EOI, 02043 AT_CIF_SYMBOL_ID(attr_idx), EOI, 02044 scope_id, EOI, 02045 interface_type, EOI, 02046 attributes, EOI, 02047 ATI_NUM_SPECIFICS(attr_idx)) < 0) { 02048 Cif_Error(); 02049 } 02050 } 02051 02052 02053 /* Go through the SN list to get the symbol IDs for the procedure names */ 02054 /* in the interface block (finishes off the Interface Block record). */ 02055 02056 sn_idx = ATI_FIRST_SPECIFIC_IDX(attr_idx); 02057 02058 while (sn_idx != NULL_IDX) { 02059 interface_idx = SN_ATTR_IDX(sn_idx); 02060 sn_idx = SN_SIBLING_LINK(sn_idx); 02061 02062 if (AT_CIF_SYMBOL_ID(interface_idx) == 0) { 02063 AT_CIF_SYMBOL_ID(interface_idx) = NEXT_SYMBOL_ID; 02064 } 02065 02066 if (fprintf(c_i_f, "%c%d", 02067 EOI, 02068 AT_CIF_SYMBOL_ID(interface_idx)) < 0) { 02069 Cif_Error(); 02070 } 02071 } 02072 02073 if (fprintf(c_i_f, "%c", EOR) < 0) { 02074 Cif_Error(); 02075 } 02076 02077 02078 /* Go through the SN list again to produce an Entry record for each */ 02079 /* module procedure and/or intrinsic procedure named in the (possibly */ 02080 /* user extended intrinsic) interface block. All interface bodies */ 02081 /* were taken care of when the interface scope was still alive. */ 02082 /* Note, however, that if an interface body was brought in by use */ 02083 /* association (because it belongs to an interface block that was use */ 02084 /* associated), the interface body has NOT been taken care of so we */ 02085 /* to produce an Entry Point record for it here. */ 02086 02087 sn_idx = ATI_FIRST_SPECIFIC_IDX(attr_idx); 02088 02089 while (sn_idx != NULL_IDX) { 02090 interface_idx = SN_ATTR_IDX(sn_idx); 02091 sn_idx = SN_SIBLING_LINK(sn_idx); 02092 02093 if (ATP_PROC(interface_idx) == Module_Proc || 02094 ATP_PROC(interface_idx) == Intrin_Proc || 02095 (ATP_PROC(interface_idx) == Extern_Proc && 02096 AT_USE_ASSOCIATED(interface_idx))) { 02097 02098 if (ATP_PGM_UNIT(interface_idx) == Function) { 02099 pgm_unit_type = CIF_F90_ET_FUNCTION; 02100 rslt_id = ATP_RSLT_IDX(interface_idx); 02101 cif_send_attr(rslt_id, NULL_IDX); 02102 rslt_id = AT_CIF_SYMBOL_ID(rslt_id); 02103 } 02104 else { 02105 pgm_unit_type = CIF_F90_ET_SUBROUTINE; 02106 rslt_id = 0; 02107 } 02108 02109 if (AT_MODULE_IDX(interface_idx) == NULL_IDX) { 02110 02111 if (SCP_LEVEL(curr_scp_idx) == 0) { 02112 storage_id = AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(curr_scp_idx)); 02113 } 02114 else { 02115 i = SCP_PARENT_IDX(curr_scp_idx); 02116 02117 while (SCP_LEVEL(i) != 0) { 02118 i = SCP_PARENT_IDX(i); 02119 } 02120 02121 storage_id = AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(i)); 02122 } 02123 } 02124 else { 02125 02126 if (AT_CIF_SYMBOL_ID(AT_MODULE_IDX(interface_idx)) == 0) { 02127 cif_send_attr(AT_MODULE_IDX(interface_idx), NULL_IDX); 02128 } 02129 02130 storage_id = AT_CIF_SYMBOL_ID(AT_MODULE_IDX(interface_idx)); 02131 } 02132 02133 02134 attributes = CIF_PGM_REFERENCE; 02135 02136 if (AT_OPTIONAL(interface_idx)) { 02137 attributes = attributes | CIF_PGM_OPTIONAL; 02138 } 02139 02140 if (AT_PRIVATE(interface_idx)) { 02141 attributes = attributes | CIF_PGM_PRIVATE; 02142 } 02143 02144 if (AT_USE_ASSOCIATED(interface_idx)) { 02145 attributes = attributes | CIF_PGM_USE_ASSOCIATED; 02146 } 02147 02148 if (ATP_RECURSIVE(interface_idx)) { 02149 attributes = attributes | CIF_PGM_RECURSIVE; 02150 } 02151 02152 02153 Cif_F90_Entry_Rec(c_i_f, 02154 AT_OBJ_NAME_PTR(interface_idx), 02155 AT_CIF_SYMBOL_ID(interface_idx), 02156 scope_id, 02157 pgm_unit_type, 02158 ATP_PROC(interface_idx), 02159 attributes, 02160 rslt_id, 02161 storage_id, 02162 0, 02163 NULL); 02164 } 02165 } 02166 02167 break; 02168 02169 02170 /* ----------------------------------------------------------------------- */ 02171 /* Namelist_Grp */ 02172 /* ----------------------------------------------------------------------- */ 02173 02174 case Namelist_Grp: 02175 02176 if (AT_CIF_SYMBOL_ID(attr_idx) == 0) { 02177 AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID; 02178 } 02179 02180 if (AT_USE_ASSOCIATED(attr_idx)) { 02181 02182 if (AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)) == 0) { 02183 cif_send_attr(AT_MODULE_IDX(attr_idx), NULL_IDX); 02184 } 02185 02186 storage_id = AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)); 02187 } 02188 else if (AT_HOST_ASSOCIATED(attr_idx)) { 02189 02190 /* If the namelist group name is host associated, don't produce */ 02191 /* another Namelist record. (AT_ATTR_LINK was broken earlier in */ 02192 /* the Semantics Pass driver so there's an independent local Attr */ 02193 /* for the namelist group name. That's how we got here.) */ 02194 02195 goto EXIT; 02196 } 02197 else { 02198 02199 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) { 02200 storage_id = AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(curr_scp_idx)); 02201 } 02202 else { 02203 storage_id = 0; 02204 } 02205 } 02206 02207 num_namelist = AT_DCL_ERR(attr_idx) ? 0: ATN_NUM_NAMELIST(attr_idx); 02208 02209 if (fprintf(c_i_f, 02210 "%d%c%s%c%d%c%d%c%d%c%d", 02211 CIF_F90_NAMELIST, EOI, 02212 AT_OBJ_NAME_PTR(attr_idx), EOI, 02213 AT_CIF_SYMBOL_ID(attr_idx), EOI, 02214 SCP_CIF_ID(curr_scp_idx), EOI, 02215 storage_id, EOI, 02216 num_namelist) < 0) { 02217 Cif_Error(); 02218 } 02219 02220 if (num_namelist > 0) { 02221 sn_idx = ATN_FIRST_NAMELIST_IDX(attr_idx); 02222 02223 while (sn_idx != NULL_IDX) { 02224 namelist_idx = SN_ATTR_IDX(sn_idx); 02225 sn_idx = SN_SIBLING_LINK(sn_idx); 02226 02227 if (AT_CIF_SYMBOL_ID(namelist_idx) == 0) { 02228 AT_CIF_SYMBOL_ID(namelist_idx) = NEXT_SYMBOL_ID; 02229 } 02230 02231 if (fprintf(c_i_f,"%c%d",EOI,AT_CIF_SYMBOL_ID(namelist_idx)) < 0) { 02232 Cif_Error(); 02233 } 02234 } 02235 } 02236 02237 if (fprintf(c_i_f, "%c", EOR) < 0) { 02238 Cif_Error(); 02239 } 02240 02241 break; 02242 02243 02244 /* ----------------------------------------------------------------------- */ 02245 /* Stmt_Func */ 02246 /* ----------------------------------------------------------------------- */ 02247 02248 case Stmt_Func: 02249 attributes = 0; /* eraxxon: add to avoid unitialized read below */ 02250 02251 # if 0 02252 if (AT_DCL_ERR(attr_idx)) { 02253 goto EXIT; 02254 } 02255 # endif 02256 02257 if (AT_CIF_SYMBOL_ID(attr_idx) == 0) { 02258 AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID; 02259 } 02260 02261 if (fprintf(c_i_f, 02262 "%d%c%s%c%d%c%d%c%d%c%d%c%lx%c%d%c%d%c%d", 02263 CIF_F90_ENTRY, EOI, 02264 AT_OBJ_NAME_PTR(attr_idx), EOI, 02265 AT_CIF_SYMBOL_ID(attr_idx), EOI, 02266 SCP_CIF_ID(curr_scp_idx), EOI, 02267 CIF_F90_ET_STMT, EOI, 02268 Unknown_Proc, EOI, 02269 attributes, EOI, 02270 0, EOI, 02271 0, EOI, 02272 ATP_NUM_DARGS(attr_idx)) < 0) { 02273 Cif_Error(); 02274 } 02275 02276 if (ATP_NUM_DARGS(attr_idx) != NULL_IDX) { 02277 sn_idx = ATP_FIRST_IDX(attr_idx); 02278 02279 for (i = 0; i < ATP_NUM_DARGS(attr_idx); i++) { 02280 02281 if (AT_CIF_SYMBOL_ID(SN_ATTR_IDX(sn_idx)) == 0) { 02282 AT_CIF_SYMBOL_ID(SN_ATTR_IDX(sn_idx)) = NEXT_SYMBOL_ID; 02283 } 02284 02285 darg_idx = AT_CIF_SYMBOL_ID(SN_ATTR_IDX(sn_idx++)); 02286 02287 if (fprintf(c_i_f, "%c%d", EOI, darg_idx) < 0) { 02288 Cif_Error(); 02289 } 02290 } 02291 02292 if (fprintf(c_i_f, "%c", EOR) < 0) { 02293 Cif_Error(); 02294 } 02295 02296 sn_idx = ATP_FIRST_IDX(attr_idx); 02297 02298 for (i = 0; i < ATP_NUM_DARGS(attr_idx); i++) { 02299 cif_send_attr(SN_ATTR_IDX(sn_idx++), NULL_IDX); 02300 } 02301 } 02302 else if (fprintf(c_i_f, "%c", EOR) < 0) { 02303 Cif_Error(); 02304 } 02305 02306 break; 02307 02308 } 02309 02310 02311 EXIT: 02312 02313 TRACE (Func_Exit, "cif_send_attr", NULL); 02314 02315 return; 02316 02317 } /* cif_send_attr */ 02318 02319 02320 /******************************************************************************\ 02321 |* *| 02322 |* Description: *| 02323 |* Output a CDIR$ record [5]. *| 02324 |* *| 02325 |* Input parameters: *| 02326 |* dir: The CDIR$ type. *| 02327 |* line: Global line number of the line containing the CDIR$. *| 02328 |* col: Column in which the CDIR$ begins. *| 02329 |* *| 02330 |* Output parameters: *| 02331 |* NONE *| 02332 |* *| 02333 |* Returns: *| 02334 |* NOTHING *| 02335 |* *| 02336 \******************************************************************************/ 02337 02338 void cif_directive_rec(cif_directive_code_type dir, 02339 int line, 02340 int col) 02341 02342 { 02343 int file_line_num; 02344 int local_file_id; 02345 02346 TRACE (Func_Entry, "cif_directive_rec", NULL); 02347 02348 file_line_num = get_line_and_file_id(line, &local_file_id); 02349 02350 Cif_Cdir_Rec(c_i_f, dir, local_file_id, file_line_num, col, 0, NULL); 02351 02352 TRACE (Func_Exit, "cif_directive_rec", NULL); 02353 02354 return; 02355 02356 } /* cif_directive_rec */ 02357 02358 02359 /******************************************************************************\ 02360 |* *| 02361 |* Description: *| 02362 |* Output a File Name record [7]. The file name is assigned the next *| 02363 |* file id value. *| 02364 |* *| 02365 |* Input parameters: *| 02366 |* expanded_file_name: The fully expanded path name for the file. *| 02367 |* user_specified_file_name: The file name as the user wrote it on the *| 02368 |* command line or in an INCLUDE. *| 02369 |* *| 02370 |* Output parameters: *| 02371 |* NONE *| 02372 |* *| 02373 |* Returns: *| 02374 |* The CIF file id. *| 02375 |* *| 02376 \******************************************************************************/ 02377 02378 int cif_file_name_rec(char *file_name, 02379 char *user_specified_file_name) 02380 { 02381 int return_val; 02382 02383 02384 TRACE (Func_Entry, "cif_file_name_rec", NULL); 02385 02386 return_val = NEXT_FILE_ID; 02387 02388 Cif_File_Rec(c_i_f, 02389 file_name, 02390 return_val, 02391 user_specified_file_name); 02392 02393 TRACE (Func_Exit, "cif_file_name_rec", NULL); 02394 02395 return(return_val); 02396 02397 } /* cif_file_name_rec */ 02398 02399 02400 /******************************************************************************\ 02401 |* *| 02402 |* Description: *| 02403 |* Output an Include record [9]. *| 02404 |* *| 02405 |* Input parameters: *| 02406 |* line_num: *| 02407 |* col_num: *| 02408 |* include_file_id: *| 02409 |* *| 02410 |* Output parameters: *| 02411 |* NONE *| 02412 |* *| 02413 |* Returns: *| 02414 |* NONE *| 02415 |* *| 02416 \******************************************************************************/ 02417 02418 void cif_include_rec(int line_num, 02419 int col_num, 02420 int include_file_id) 02421 { 02422 int file_line_num; 02423 int parent_file_id; 02424 02425 02426 TRACE (Func_Entry, "cif_include_rec", NULL); 02427 02428 file_line_num = get_line_and_file_id(line_num, &parent_file_id); 02429 02430 Cif_Include_Rec(c_i_f, 02431 parent_file_id, 02432 file_line_num, 02433 col_num, 02434 include_file_id); 02435 02436 Cif_Src_Pos_Rec(c_i_f, 02437 CIF_SRC_KIND_INCLUDE, 02438 include_file_id, 02439 parent_file_id, 02440 file_line_num, 02441 col_num, 02442 include_file_id, 02443 0, 02444 0, 02445 0); 02446 02447 TRACE (Func_Exit, "cif_include_rec", NULL); 02448 02449 return; 02450 02451 } /* cif_include_rec */ 02452 02453 02454 /******************************************************************************\ 02455 |* *| 02456 |* Description: *| 02457 |* Output a Message record [11]. *| 02458 |* *| 02459 |* Input parameters: *| 02460 |* msg_num The message number. *| 02461 |* glb_line_num The global source line number. *| 02462 |* col_num The column number of the offending text (may be 0). *| 02463 |* msg_severity The severity level of the message. *| 02464 |* msg_text A pointer to the character string containing the *| 02465 |* message text (from the message catalog). *| 02466 |* arg1, arg2, The 4 optional arguments that may be used to insert *| 02467 |* arg3, arg4 text into a message. *| 02468 |* *| 02469 |* scoping_unit_name Only used for the buffered message file. *| 02470 |* file_name Only used for the buffered message file. *| 02471 |* *| 02472 |* Output parameters: *| 02473 |* NONE *| 02474 |* *| 02475 |* Returns: *| 02476 |* NONE *| 02477 |* *| 02478 |* Algorithm notes: *| 02479 |* The size of "insert" was chosen because it seemed "big enough". See the *| 02480 |* definitions of ORIG_MSG_SIZE and EXPANDED_MSG_SIZE in messages.m. *| 02481 |* *| 02482 \******************************************************************************/ 02483 02484 void cif_message_rec(int msg_num, 02485 int glb_line_num, 02486 int col_num, 02487 msg_severities_type msg_severity, 02488 char *msg_text, 02489 long arg0, 02490 long arg1, 02491 long arg2, 02492 long arg3, 02493 char *scoping_unit_name, 02494 int relative_order) 02495 02496 { 02497 char *char_ptr; 02498 int file_line_num; 02499 char *format[4] = { "%c", "%d", "%f", "%s" }; 02500 int format_idx; 02501 char insert[4][128]; 02502 char *insert_ptr[4]; 02503 int local_file_id; 02504 int num_inserts = 0; 02505 02506 02507 TRACE (Func_Entry, "cif_message_rec", NULL); 02508 02509 if (msg_severity == Log_Error || msg_severity == Log_Warning || 02510 glb_line_num == 0) { 02511 goto EXIT; 02512 } 02513 02514 file_line_num = get_line_and_file_id(glb_line_num, &local_file_id); 02515 02516 char_ptr = msg_text; 02517 02518 while ((char_ptr = strchr(char_ptr, '%')) != NULL) { 02519 ++char_ptr; 02520 02521 switch (*char_ptr++) { 02522 02523 case 'c': 02524 format_idx = 0; 02525 break; 02526 02527 case 'd': 02528 format_idx = 1; 02529 break; 02530 02531 case 'f': 02532 format_idx = 2; 02533 break; 02534 02535 case 's': 02536 format_idx = 3; 02537 break; 02538 02539 case '%': 02540 continue; 02541 02542 case EOS: 02543 goto LOOP_EXIT; 02544 02545 default: 02546 PRINTMSG(glb_line_num, 179, Internal, 0, "cif_message_rec"); 02547 } 02548 02549 switch (num_inserts) { 02550 02551 case 0: 02552 sprintf(insert[0], format[format_idx], arg0); 02553 break; 02554 02555 case 1: 02556 sprintf(insert[1], format[format_idx], arg1); 02557 break; 02558 02559 case 2: 02560 sprintf(insert[2], format[format_idx], arg2); 02561 break; 02562 02563 case 3: 02564 sprintf(insert[3], format[format_idx], arg3); 02565 } 02566 02567 insert_ptr[num_inserts] = insert[num_inserts]; 02568 02569 ++num_inserts; 02570 } 02571 02572 LOOP_EXIT: 02573 02574 Cif_Message_Rec(c_i_f, 02575 msg_severity, 02576 msg_num, 02577 local_file_id, 02578 glb_line_num, 02579 col_num, 02580 file_line_num, 02581 num_inserts, 02582 insert_ptr, 02583 scoping_unit_name, 02584 relative_order, 02585 0, 02586 local_file_id); 02587 02588 last_msg_file_rec = CIF_MESSAGE; 02589 02590 EXIT: 02591 02592 TRACE (Func_Exit, "cif_message_rec", NULL); 02593 02594 return; 02595 02596 } /* cif_message_rec */ 02597 02598 02599 /******************************************************************************\ 02600 |* *| 02601 |* Description: *| 02602 |* Output a Source File record [14]. *| 02603 |* *| 02604 |* Input parameters: *| 02605 |* source_file_id The file id of the file containing the program. *| 02606 |* source_form The source form in which the program is written (at *| 02607 |* least initially). *| 02608 |* *| 02609 |* Output parameters: *| 02610 |* NONE *| 02611 |* *| 02612 |* Returns: *| 02613 |* NONE *| 02614 |* *| 02615 \******************************************************************************/ 02616 02617 void cif_source_file_rec(int source_file_id, 02618 src_form_type source_form) 02619 { 02620 02621 TRACE (Func_Entry, "cif_source_file_rec", NULL); 02622 02623 Cif_Srcfile_Rec(c_i_f, 02624 source_file_id, 02625 (source_form == Fixed_Form) ? CIF_F90_FORM_FIXED : 02626 CIF_F90_FORM_FREE); 02627 02628 TRACE (Func_Exit, "cif_source_file_rec", NULL); 02629 02630 return; 02631 02632 } /* cif_source_file_rec */ 02633 02634 02635 /******************************************************************************\ 02636 |* *| 02637 |* Description: *| 02638 |* Output a Summary record [15]. *| 02639 |* *| 02640 |* Input parameters: *| 02641 |* release_level : compiler release level *| 02642 |* gen_date : date the compiler was created *| 02643 |* gen_time : time of day the compiler was created *| 02644 |* elapsed_time : Cray : compilation time in microseconds *| 02645 |* non-Cray: compilation time in microseconds for a *| 02646 |* "short" compilation, otherwise in *| 02647 |* seconds; see Algorithm notes below *| 02648 |* aux_elapsed_time : Cray : not used (always 0) *| 02649 |* non-Cray: if compilation time is "short", this is *| 02650 |* the compilation time in microseconds *| 02651 |* max_field_len : maximum amount of memory used *| 02652 |* *| 02653 |* Output parameters: *| 02654 |* NONE *| 02655 |* *| 02656 |* Returns: *| 02657 |* NONE *| 02658 |* *| 02659 |* Algorithm notes: *| 02660 |* LRR notes: URGENT SPR 701346 demonstrated that the compile time info *| 02661 |* we were printing in the summary lines was grossly wrong for some *| 02662 |* compilations on the T3E. TAM told me that SECOND had not been ported *| 02663 |* to T3E's and advised me to use SECONDR. However, when I tried it, it *| 02664 |* also failed. I then checked with KRZ to find out what the C front-end *| 02665 |* uses. They use clock() on all platforms. In order to perturb the *| 02666 |* front-end as little as possible with this change, I've only changed *| 02667 |* the MPP timing to use clock(). If someone has the time sometime in *| 02668 |* the future, someone should probably investigate using clock() where *| 02669 |* we now use SECOND. *| 02670 |* The first sentence of the following paragraph has existed for a very *| 02671 |* long time. Knowing what we now know about clock(), the description and *| 02672 |* concluseion no longer seem to make sense. If anyone ever gets around *| 02673 |* to changing from SECOND to clock() for general use, the following *| 02674 |* paragraph should be corrected as well. 4 March 1997 *| 02675 |* The clock() function on both Crays and Suns counts in microseconds. *| 02676 |* For this reason, SECOND is used on Crays. It returns a floating point *| 02677 |* value of the number of seconds (down to at least a microsecond) of CPU *| 02678 |* time. *| 02679 |* Since the Sun word is 32 bits, the counter rolls over in just over 2147 *| 02680 |* seconds (about 36 minutes). main.c captures the compilation start and *| 02681 |* end times from both clock() and time(). time()'s granularity is in *| 02682 |* seconds. For a Sun, (end_time - start_time) is passed to elapsed_time. *| 02683 |* If elapsed_time <= 2147 seconds, the compilation time is taken from *| 02684 |* aux_elapsed_time (the value of the second call to clock() in main.c) *| 02685 |* and is reported in milliseconds. If the counter rolled over, the time *| 02686 |* is reported in seconds. Since the compilation time would have to be *| 02687 |* at least 36 minutes, it was thought that 1 part in 36*3600 is *| 02688 |* sufficiently accurate. *| 02689 |* *| 02690 |* CLOCKS_PER_SEC is defined in time.h. *| 02691 |* *| 02692 \******************************************************************************/ 02693 02694 void cif_summary_rec(char *release_level, 02695 char *gen_date, 02696 char *gen_time, 02697 float elapsed_time, 02698 long aux_elapsed_time, 02699 long max_field_len) 02700 { 02701 char comp_time[13]; 02702 int hms; 02703 int hours; 02704 int milliseconds; 02705 int minutes; 02706 int seconds; 02707 02708 02709 TRACE (Func_Entry, "cif_summary_rec", NULL); 02710 02711 if (max_field_len == -1) { /* Signalling abort on 100 errors. */ 02712 comp_time[0] = '0'; 02713 comp_time[1] = NULL_CHAR; 02714 } 02715 else { 02716 02717 hms = elapsed_time; 02718 02719 02720 # if (defined(_HOST_OS_UNICOS) || defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX)) 02721 02722 elapsed_time = elapsed_time - hms; 02723 milliseconds = (elapsed_time + .0005) * 1000; 02724 02725 # elif defined(_HOST_OS_MAX) 02726 02727 milliseconds = ((aux_elapsed_time % CLOCKS_PER_SEC) + 500L) / 1000L; 02728 hms = aux_elapsed_time / CLOCKS_PER_SEC; 02729 02730 # else /* defined(_HOST_OS_SOLARIS) */ 02731 02732 if (hms <= 2147) { 02733 milliseconds = ((aux_elapsed_time % CLOCKS_PER_SEC) + 500L) / 1000L; 02734 hms = aux_elapsed_time / CLOCKS_PER_SEC; 02735 } 02736 else { 02737 milliseconds = -1; 02738 } 02739 02740 # endif 02741 02742 02743 hours = hms / 3600; 02744 hms = hms % 3600; 02745 minutes = hms / 60; 02746 seconds = hms % 60; 02747 02748 02749 # ifndef _HOST_OS_SOLARIS 02750 02751 sprintf(comp_time, "%2.2d:%2.2d:%2.2d.%3.3d", 02752 hours, minutes, seconds, milliseconds); 02753 02754 # else 02755 02756 if (milliseconds >= 0) { 02757 sprintf(comp_time, "%2.2d:%2.2d:%2.2d.%3.3d", 02758 hours, minutes, seconds, milliseconds); 02759 } 02760 else { 02761 sprintf(comp_time, "%2.2d:%2.2d:%2.2d", hours, minutes, seconds); 02762 } 02763 02764 # endif 02765 02766 } 02767 02768 Cif_Summary_Rec(c_i_f, 02769 release_level, 02770 gen_date, 02771 gen_time, 02772 comp_time, 02773 max_field_len, 02774 --curr_glb_line, 02775 code_size, 02776 data_size); 02777 02778 /* Don't leave contents of curr_glb_line destroyed. */ 02779 02780 ++curr_glb_line; 02781 02782 02783 TRACE (Func_Exit, "cif_summary_rec", NULL); 02784 02785 return; 02786 02787 } /* cif_summary_rec */ 02788 02789 02790 /******************************************************************************\ 02791 |* *| 02792 |* Description: *| 02793 |* Output a Unit record [17]. *| 02794 |* *| 02795 |* Input parameters: *| 02796 |* NONE *| 02797 |* *| 02798 |* Output parameters: *| 02799 |* NONE *| 02800 |* *| 02801 |* Returns: *| 02802 |* NONE *| 02803 |* *| 02804 \******************************************************************************/ 02805 02806 void cif_unit_rec(void) 02807 { 02808 int cif_col_num; 02809 int file_line_num; 02810 int glb_line_num; 02811 int local_file_id; 02812 02813 02814 TRACE (Func_Entry, "cif_unit_rec", NULL); 02815 02816 if (cif_pgm_unit_start_line == stmt_start_line) { 02817 02818 /* For a program that is tremendously screwed up, it is possible for */ 02819 /* cif_unit_rec to be called from cif_fake_a_unit even before the Block */ 02820 /* Stack has been set up. If this is so, just fake the line and column.*/ 02821 02822 if (blk_stk_idx > 0) { 02823 glb_line_num = CURR_BLK_DEF_LINE; 02824 cif_col_num = CURR_BLK_DEF_COLUMN; 02825 } 02826 else { 02827 glb_line_num = 1; 02828 cif_col_num = 1; 02829 } 02830 } 02831 else { 02832 02833 /* For the pathological case where the only significant line in the */ 02834 /* program contains an END statement, cif_pgm_unit_start_line is */ 02835 /* incremented before we get here. */ 02836 02837 glb_line_num = (cif_pgm_unit_start_line < stmt_start_line) ? 02838 cif_pgm_unit_start_line : stmt_start_line; 02839 cif_col_num = 1; 02840 } 02841 02842 file_line_num = get_line_and_file_id(glb_line_num, &local_file_id); 02843 02844 02845 /* Write the Unit record in the actual CIF. */ 02846 02847 c_i_f = cif_actual_file; 02848 02849 02850 Cif_Unit_Rec(c_i_f, 02851 (scp_tbl != NULL) ? 02852 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)) : 02853 UNNAMED_PROGRAM_NAME, 02854 local_file_id, 02855 file_line_num, 02856 cif_col_num); 02857 02858 cif_need_unit_rec = FALSE; 02859 cif_first_pgm_unit = FALSE; 02860 02861 last_msg_file_rec = CIF_UNIT; 02862 02863 if (! cif_pgm_unit_error_recovery) { 02864 cif_copy_temp_to_actual_CIF(); 02865 } 02866 02867 TRACE (Func_Exit, "cif_unit_rec", NULL); 02868 02869 return; 02870 02871 } /* cif_unit_rec */ 02872 02873 02874 /******************************************************************************\ 02875 |* *| 02876 |* Description: *| 02877 |* Copy records from the temporary CIF to the actual CIF. *| 02878 |* *| 02879 |* Input parameters: *| 02880 |* NONE *| 02881 |* *| 02882 |* Output parameters: *| 02883 |* NONE *| 02884 |* *| 02885 |* Returns: *| 02886 |* NONE *| 02887 |* *| 02888 \******************************************************************************/ 02889 02890 void cif_copy_temp_to_actual_CIF(void) 02891 { 02892 char cif_rec[256]; /* Arbitrary size. */ 02893 02894 02895 TRACE (Func_Entry, "cif_copy_temp_to_actual_CIF", NULL); 02896 02897 /* Copy any records in the temporary file to the actual CIF. Rewind the */ 02898 /* temporary CIF file so it's ready for the next program unit (if one */ 02899 /* exists). */ 02900 02901 fprintf(cif_tmp_file, "%d\n", EOF); 02902 fflush(cif_tmp_file); 02903 rewind(cif_tmp_file); 02904 02905 while (fgets(cif_rec, 256, cif_tmp_file) != NULL && atoi(cif_rec) != EOF) { 02906 fputs(cif_rec, c_i_f); 02907 } 02908 02909 rewind(cif_tmp_file); 02910 02911 TRACE (Func_Exit, "cif_copy_temp_to_actual_CIF", NULL); 02912 02913 return; 02914 02915 } /* cif_copy_temp_to_actual_CIF */ 02916 02917 02918 /******************************************************************************\ 02919 |* *| 02920 |* Description: *| 02921 |* Output an End Unit record [18]. *| 02922 |* *| 02923 |* Input parameters: *| 02924 |* NONE *| 02925 |* *| 02926 |* Output parameters: *| 02927 |* NONE *| 02928 |* *| 02929 |* Returns: *| 02930 |* NONE *| 02931 |* *| 02932 \******************************************************************************/ 02933 02934 void cif_end_unit_rec(char *name_ptr) 02935 { 02936 int file_line_num; 02937 int local_file_id; 02938 02939 02940 TRACE (Func_Entry, "cif_end_unit_rec", NULL); 02941 02942 file_line_num = get_line_and_file_id(cif_end_unit_line, &local_file_id); 02943 02944 cif_flush_include_recs(); 02945 02946 Cif_Endunit_Rec(c_i_f, 02947 name_ptr, 02948 local_file_id, 02949 file_line_num, 02950 (cif_end_unit_column > 0) ? 02951 cif_end_unit_column : stmt_start_col); 02952 02953 last_msg_file_rec = CIF_ENDUNIT; 02954 02955 TRACE (Func_Exit, "cif_end_unit_rec", NULL); 02956 02957 return; 02958 02959 } /* cif_end_unit_rec */ 02960 02961 02962 /******************************************************************************\ 02963 |* *| 02964 |* Description: *| 02965 |* Output a Usage record [19]. *| 02966 |* *| 02967 |* Input parameters: *| 02968 |* obj_idx : An Attr index, IR index or symbol id depending on the *| 02969 |* value of obj_fld *| 02970 |* obj_fld : AT_Tbl_Idx, IR_Tbl_Idx or NO_Tbl_Idx *| 02971 |* line_num : the line number containing the symbol for which this *| 02972 |* Usage record is being produced *| 02973 |* col_num : the column number for the symbol *| 02974 |* usage_code : the CIF-defined usage code *| 02975 |* *| 02976 |* Output parameters: *| 02977 |* NONE *| 02978 |* *| 02979 |* Returns: *| 02980 |* NONE *| 02981 |* *| 02982 \******************************************************************************/ 02983 02984 void cif_usage_rec(int obj_idx, 02985 fld_type obj_fld, 02986 int line_num, 02987 int col_num, 02988 int usage_code) 02989 { 02990 int attr_idx; 02991 int cif_symbol_id; 02992 int file_line_num; 02993 int local_file_id; 02994 opnd_type opnd; 02995 02996 02997 TRACE (Func_Entry, "cif_usage_rec", NULL); 02998 /* 02999 if (SH_CIF_SKIP_ME(curr_stmt_sh_idx) || usage_code == CIF_No_Usage_Rec) { 03000 goto EXIT; 03001 } 03002 */ 03003 03004 if (usage_code == CIF_No_Usage_Rec) { 03005 goto EXIT; 03006 } 03007 03008 03009 switch (obj_fld) { 03010 03011 case AT_Tbl_Idx: 03012 attr_idx = obj_idx; 03013 AT_CIF_IN_USAGE_REC(attr_idx) = TRUE; 03014 03015 if (AT_DCL_ERR(attr_idx) || 03016 (AT_COMPILER_GEND(attr_idx) && 03017 (AT_OBJ_CLASS(attr_idx) != Data_Obj || 03018 ! (ATD_CLASS(attr_idx) == Compiler_Tmp && 03019 ATD_TMP_NEEDS_CIF(attr_idx))))) { 03020 goto EXIT; 03021 } 03022 03023 /* If this is the specific name of an intrinsic procedure, we are */ 03024 /* looking at the compiler-generated name (like _NABS_ for IABS). Get */ 03025 /* back to the interface Attr entry that describes the specific */ 03026 /* intrinsic (and that contains the name the user wrote in the program) */ 03027 /* and use it instead. */ 03028 03029 if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit && 03030 ATP_PROC(attr_idx) == Intrin_Proc && 03031 ! ATP_IN_INTERFACE_BLK(attr_idx)) { 03032 attr_idx = ATP_INTERFACE_IDX(attr_idx); 03033 } 03034 03035 03036 if (AT_CIF_SYMBOL_ID(attr_idx) == 0) { 03037 AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID; 03038 } 03039 03040 file_line_num = get_line_and_file_id(line_num, &local_file_id); 03041 03042 Cif_Usage_Rec(c_i_f, 03043 AT_CIF_SYMBOL_ID(attr_idx), 03044 local_file_id, 03045 file_line_num, 03046 col_num, 03047 usage_code, 03048 0, 03049 NULL); 03050 03051 break; 03052 03053 case NO_Tbl_Idx: 03054 file_line_num = get_line_and_file_id(line_num, &local_file_id); 03055 03056 Cif_Usage_Rec(c_i_f, 03057 obj_idx, 03058 local_file_id, 03059 file_line_num, 03060 col_num, 03061 usage_code, 03062 0, 03063 NULL); 03064 03065 break; 03066 03067 default: 03068 skip_struct_base = TRUE; 03069 OPND_FLD(opnd) = obj_fld; 03070 OPND_IDX(opnd) = obj_idx; 03071 03072 /* Get line and column of last component. */ 03073 03074 attr_idx = find_base_attr(&opnd, &line_num, &col_num); 03075 03076 03077 /* Get base attr. */ 03078 03079 attr_idx = find_left_attr(&opnd); 03080 03081 if (AT_DCL_ERR(attr_idx)) { 03082 goto EXIT; 03083 } 03084 03085 if (AT_CIF_SYMBOL_ID(attr_idx) == 0) { 03086 AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID; 03087 } 03088 03089 cif_symbol_id = AT_CIF_SYMBOL_ID(attr_idx); 03090 AT_CIF_IN_USAGE_REC(attr_idx) = TRUE; 03091 03092 file_line_num = get_line_and_file_id(line_num, &local_file_id); 03093 03094 if (fprintf(c_i_f, "%d%c%d%c%d%c%d%c%d%c%d", 03095 CIF_USAGE, EOI, 03096 cif_symbol_id, EOI, 03097 local_file_id, EOI, 03098 file_line_num, EOI, 03099 col_num, EOI, 03100 usage_code) < 0) { 03101 Cif_Error(); 03102 } 03103 03104 cif_number_of_struct_ids = 0; 03105 03106 output_struct_ids(&opnd); 03107 03108 if (fprintf(c_i_f, "%c%d", EOI, cif_number_of_struct_ids) < 0) { 03109 Cif_Error(); 03110 } 03111 03112 cif_number_of_struct_ids = -1; 03113 03114 if (! output_struct_ids(&opnd)) { 03115 Cif_Error(); 03116 } 03117 03118 if (fprintf(c_i_f, "%c", EOR) < 0) { 03119 Cif_Error(); 03120 } 03121 03122 break; 03123 } 03124 03125 EXIT: 03126 03127 TRACE (Func_Exit, "cif_usage_rec", NULL); 03128 03129 return; 03130 03131 } /* cif_usage_rec */ 03132 03133 03134 /******************************************************************************\ 03135 |* *| 03136 |* Description: *| 03137 |* Output a Usage record [19] for a common block name. *| 03138 |* *| 03139 |* Input parameters: *| 03140 |* sb_idx : stor blk index *| 03141 |* line_num : the line number containing the symbol for which this *| 03142 |* Usage record is being produced *| 03143 |* col_num : the column number for the block *| 03144 |* usage_code : the CIF-defined usage code *| 03145 |* *| 03146 |* Output parameters: *| 03147 |* NONE *| 03148 |* *| 03149 |* Returns: *| 03150 |* NONE *| 03151 |* *| 03152 \******************************************************************************/ 03153 03154 void cif_sb_usage_rec(int sb_idx, 03155 int line_num, 03156 int col_num, 03157 cif_usage_code_type usage_code) 03158 { 03159 int file_line_num; 03160 int local_file_id; 03161 03162 03163 TRACE (Func_Entry, "cif_sb_usage_rec", NULL); 03164 03165 file_line_num = get_line_and_file_id(line_num, &local_file_id); 03166 03167 if (SB_CIF_SYMBOL_ID(sb_idx) == 0) { 03168 SB_CIF_SYMBOL_ID(sb_idx) = NEXT_SYMBOL_ID; 03169 } 03170 03171 Cif_Usage_Rec(c_i_f, 03172 SB_CIF_SYMBOL_ID(sb_idx), 03173 local_file_id, 03174 file_line_num, 03175 col_num, 03176 usage_code, 03177 0, 03178 NULL); 03179 03180 TRACE (Func_Exit, "cif_sb_usage_rec", NULL); 03181 03182 return; 03183 03184 } /* cif_sb_usage_rec */ 03185 03186 03187 /******************************************************************************\ 03188 |* *| 03189 |* Description: *| 03190 |* Output an Enable/Disable Compiler Options record [21]. *| 03191 |* *| 03192 |* Input parameters: *| 03193 |* NONE *| 03194 |* *| 03195 |* Output parameters: *| 03196 |* NONE *| 03197 |* *| 03198 |* Returns: *| 03199 |* NONE *| 03200 |* *| 03201 \******************************************************************************/ 03202 03203 void cif_enable_disable_rec(void) 03204 { 03205 long enable_disable_opts; 03206 03207 03208 TRACE (Func_Entry, "cif_enable_disable_rec", NULL); 03209 03210 enable_disable_opts = 0; 03211 03212 if (on_off_flags.abort_if_any_errors) { 03213 enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTa; 03214 } 03215 03216 03217 # ifdef _ACCEPT_FLOW 03218 03219 if (on_off_flags.flowtrace_option) { 03220 enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTf; 03221 } 03222 03223 # endif 03224 03225 03226 # ifdef _ACCEPT_CMD_ed_i 03227 03228 if (on_off_flags.indef_init) { 03229 enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTi; 03230 } 03231 03232 # endif 03233 03234 03235 # ifdef _ACCEPT_CMD_ed_j 03236 03237 if (on_off_flags.exec_doloops_once) { 03238 enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTj; 03239 } 03240 03241 # endif 03242 03243 03244 if (on_off_flags.issue_ansi_messages) { 03245 enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTn; 03246 } 03247 03248 if (on_off_flags.enable_double_precision) { 03249 enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTp; 03250 } 03251 03252 if (on_off_flags.abort_on_100_errors) { 03253 enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTq; 03254 } 03255 03256 03257 # ifdef _ACCEPT_CMD_ed_r 03258 03259 if (on_off_flags.round_mult_operations) { 03260 enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTr; 03261 } 03262 03263 # endif 03264 03265 03266 if (on_off_flags.alloc_autos_on_stack) { 03267 enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTt; 03268 } 03269 03270 if (on_off_flags.eu) { 03271 enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTu; 03272 } 03273 03274 if (on_off_flags.save_all_vars) { 03275 enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTv; 03276 } 03277 03278 03279 # ifdef _ACCEPT_CMD_ed_A 03280 03281 if (on_off_flags.MPP_apprentice) { 03282 enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTA; 03283 } 03284 03285 # endif 03286 03287 03288 if (cmd_line_flags.binary_output) { 03289 enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTB; 03290 } 03291 03292 if (cmd_line_flags.assembly_output) { 03293 enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTS; 03294 } 03295 03296 03297 # ifdef _ACCEPT_CMD_ed_X 03298 03299 if (on_off_flags.atexpert) { 03300 enable_disable_opts = enable_disable_opts | CIF_F90_EDF_OPTX; 03301 } 03302 03303 # endif 03304 03305 03306 Cif_EDopts_Rec(c_i_f, enable_disable_opts); 03307 03308 TRACE (Func_Exit, "cif_enable_disable_rec", NULL); 03309 03310 return; 03311 03312 } /* cif_enable_disable_rec */ 03313 03314 03315 /******************************************************************************\ 03316 |* *| 03317 |* Description: *| 03318 |* Output a Machine Characteristics record [22]. *| 03319 |* *| 03320 |* Input parameters: *| 03321 |* NONE *| 03322 |* *| 03323 |* Output parameters: *| 03324 |* NONE *| 03325 |* *| 03326 |* Returns: *| 03327 |* NONE *| 03328 |* *| 03329 \******************************************************************************/ 03330 03331 void cif_machine_characteristics_rec(void) 03332 { 03333 03334 03335 # if defined(_HOST_OS_UNICOS) || defined(_HOST_OS_MAX) 03336 03337 int characteristics; 03338 03339 union {long int_form; 03340 char char_form[9]; 03341 } cpu_type; 03342 03343 # endif 03344 03345 03346 TRACE (Func_Entry, "cif_machine_characteristics_rec", NULL); 03347 03348 03349 # ifdef _TARGET_OS_UNICOS 03350 03351 # ifdef _GETPMC_AVAILABLE 03352 03353 /* Get the "primary" name of the machine. */ 03354 03355 cpu_type.int_form = target_machine.fld.mcpmt; 03356 cpu_type.char_form[8] = NULL_CHAR; 03357 03358 03359 /* Get the "characteristics" bitmask values. */ 03360 03361 characteristics = 0; 03362 03363 if (target_machine.fld.mcvpop) { 03364 characteristics = characteristics | CIF_MC_VPOP; 03365 } 03366 03367 if (target_machine.fld.mcema) { 03368 characteristics = characteristics | CIF_MC_EMA; 03369 } 03370 03371 if (target_machine.fld.mccigs) { 03372 characteristics = characteristics | CIF_MC_CIGS; 03373 } 03374 03375 if (target_machine.fld.mcpc) { 03376 characteristics = characteristics | CIF_MC_PCF; 03377 } 03378 03379 if (target_machine.fld.mcrdvl) { 03380 characteristics = characteristics | CIF_MC_READVL; 03381 } 03382 03383 if (target_machine.fld.mcvrcr) { 03384 characteristics = characteristics | CIF_MC_VRECUR; 03385 } 03386 03387 if (target_machine.fld.mcavl) { 03388 characteristics = characteristics | CIF_MC_AVL; 03389 } 03390 03391 if (target_machine.fld.mchpm) { 03392 characteristics = characteristics | CIF_MC_HPF; 03393 } 03394 03395 if (target_machine.fld.mcbdm) { 03396 characteristics = characteristics | CIF_MC_BDM; 03397 } 03398 03399 if (target_machine.fld.mcstr) { 03400 characteristics = characteristics | CIF_MC_SREG; 03401 } 03402 03403 if (target_machine.fld.mcstr) { 03404 characteristics = characteristics | CIF_MC_CLUSTER; 03405 } 03406 03407 if (target_machine.fld.mccori) { 03408 characteristics = characteristics | CIF_MC_COR; 03409 } 03410 03411 if (target_machine.fld.mcaddr32) { 03412 characteristics = characteristics | CIF_MC_ADDR32; 03413 } 03414 03415 if (target_machine.fld.mcbmm) { 03416 characteristics = characteristics | CIF_MC_BMM; 03417 } 03418 03419 if (target_machine.fld.mcxea) { 03420 characteristics = characteristics | CIF_MC_XEA; 03421 } 03422 03423 if (target_machine.fld.mcavpop) { 03424 characteristics = characteristics | CIF_MC_AVPOP; 03425 } 03426 03427 if (target_machine.fld.mcfullsect) { 03428 characteristics = characteristics | CIF_MC_FULLSECT; 03429 } 03430 03431 if (target_machine.fld.mcieee) { 03432 characteristics = characteristics | CIF_MC_IEEE; 03433 } 03434 03435 if (target_machine.fld.mccmrreq) { 03436 characteristics = characteristics | CIF_MC_CMRREQ; 03437 } 03438 03439 if (target_machine.fld.mccache) { 03440 characteristics = characteristics | CIF_MC_CACHE; 03441 } 03442 03443 Cif_Mach_Char_Rec(c_i_f, 03444 cpu_type.char_form, 03445 target_machine.fld.mcmspd, 03446 target_machine.fld.mcmsz, 03447 characteristics, 03448 target_machine.fld.mcbank, 03449 target_machine.fld.mcncpu, 03450 target_machine.fld.mcibsz, 03451 target_machine.fld.mcclk, 03452 target_machine.fld.mcncl, 03453 target_machine.fld.mcbbsy, 03454 TARGET_BITS_PER_WORD); 03455 03456 03457 # else 03458 03459 03460 /* Assume since target is UNICOS and host is not that this is a DPE */ 03461 /* compiler. */ 03462 /* Dummy up a record until the machine characteristics library routine has */ 03463 /* been ported. mcpmt already has the target machine name in it in char */ 03464 /* form. */ 03465 03466 Cif_Mach_Char_Rec(c_i_f, 03467 target_machine.fld.mcpmt, 03468 -1L, 03469 -1L, 03470 0, 03471 -1L, 03472 -1L, 03473 -1L, 03474 -1L, 03475 -1L, 03476 -1L, 03477 TARGET_BITS_PER_WORD); 03478 03479 # endif 03480 03481 03482 # endif 03483 03484 03485 # ifdef _TARGET_OS_MAX 03486 03487 03488 # if defined(_GETPMC_AVAILABLE) 03489 03490 /* Get the "primary" name of the machine. */ 03491 03492 cpu_type.int_form = target_machine.fld.mcpmt; 03493 cpu_type.char_form[8] = NULL_CHAR; 03494 03495 03496 Cif_Mach_Char_Rec(c_i_f, 03497 cpu_type.char_form, 03498 -1L, 03499 target_machine.fld.mcmsz, 03500 0, 03501 -1L, 03502 -1L, 03503 -1L, 03504 -1L, 03505 -1L, 03506 -1L, 03507 TARGET_BITS_PER_WORD); 03508 03509 # else 03510 03511 03512 /* Assume since target is MAX and host is not UNICOS that this is a cross */ 03513 /* compiler. */ 03514 /* Dummy up a record until the machine characteristics library routine has */ 03515 /* been ported. mcpmt already has the target machine name in it in char */ 03516 /* form. */ 03517 03518 Cif_Mach_Char_Rec(c_i_f, 03519 target_machine.fld.mcpmt, 03520 -1L, 03521 -1L, 03522 0, 03523 -1L, 03524 -1L, 03525 -1L, 03526 -1L, 03527 -1L, 03528 -1L, 03529 TARGET_BITS_PER_WORD); 03530 03531 03532 # endif 03533 03534 03535 # endif 03536 03537 03538 # if defined(GENERATE_WHIRL) 03539 03540 03541 /* Produce a dummy Machine Characteristics record for a IRIX. */ 03542 03543 Cif_Mach_Char_Rec(c_i_f, 03544 "IRIX", 03545 -1L, 03546 -1L, 03547 0, 03548 -1L, 03549 -1L, 03550 -1L, 03551 -1L, 03552 -1L, 03553 -1L, 03554 TARGET_BITS_PER_WORD); 03555 03556 # elif defined(_TARGET_OS_SOLARIS) 03557 03558 /* Produce a dummy Machine Characteristics record for a SPARC. */ 03559 03560 Cif_Mach_Char_Rec(c_i_f, 03561 "SPARC", 03562 -1L, 03563 -1L, 03564 0, 03565 -1L, 03566 -1L, 03567 -1L, 03568 -1L, 03569 -1L, 03570 -1L, 03571 TARGET_BITS_PER_WORD); 03572 # endif 03573 03574 03575 TRACE (Func_Exit, "cif_machine_characteristics_rec", NULL); 03576 03577 return; 03578 03579 } /* cif_machine_characteristics_rec */ 03580 03581 03582 /******************************************************************************\ 03583 |* *| 03584 |* Description: *| 03585 |* Output a Statement Type record [25]. *| 03586 |* *| 03587 |* Input parameters: *| 03588 |* exact_stmt_type_known : *| 03589 |* exact_stmt_type : *| 03590 |* stmt_number : *| 03591 |* *| 03592 |* Output parameters: *| 03593 |* NONE *| 03594 |* *| 03595 |* Returns: *| 03596 |* NONE *| 03597 |* *| 03598 \******************************************************************************/ 03599 03600 void cif_stmt_type_rec(boolean exact_stmt_type_known, 03601 cif_stmt_type exact_stmt_type, 03602 int stmt_number) 03603 { 03604 int file_line_num; 03605 int local_file_id; 03606 cif_stmt_type local_stmt_type; 03607 03608 03609 TRACE (Func_Entry, "cif_stmt_type_rec", NULL); 03610 03611 local_stmt_type = (exact_stmt_type_known) ? 03612 exact_stmt_type : mapped_stmt_type[stmt_type]; 03613 03614 switch (local_stmt_type) { 03615 03616 case CIF_Not_Exact: 03617 if (comp_phase < Decl_Semantics && stmt_type == Assignment_Stmt) { 03618 03619 /* Place a Statement_Num_Stmt before this to hold the value of */ 03620 /* stmt_number in its SH_PARENT_BLK_IDX field. */ 03621 03622 gen_sh(Before, Statement_Num_Stmt, stmt_start_line, stmt_start_col, 03623 FALSE, FALSE, TRUE); 03624 SH_PARENT_BLK_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = stmt_number; 03625 } 03626 03627 break; 03628 03629 case CIF_Stmt_Type_Error: 03630 PRINTMSG(stmt_start_line, 776, Internal, stmt_start_col); 03631 03632 default: 03633 file_line_num = get_line_and_file_id(stmt_start_line, &local_file_id); 03634 03635 Cif_Stmt_Type_Rec(c_i_f, 03636 local_stmt_type, 03637 local_file_id, 03638 file_line_num, 03639 stmt_start_col, 03640 stmt_number); 03641 } 03642 03643 TRACE (Func_Exit, "cif_stmt_type_rec", NULL); 03644 03645 return; 03646 03647 } /* cif_stmt_type_rec */ 03648 03649 03650 /******************************************************************************\ 03651 |* *| 03652 |* Description: *| 03653 |* Output a Continuation Line record [27]. *| 03654 |* *| 03655 |* Input parameters: *| 03656 |* continuation_type : 0 = source line, 1 = CDIR$ line *| 03657 |* line_number : line number of the continuation line *| 03658 |* *| 03659 |* Output parameters: *| 03660 |* NONE *| 03661 |* *| 03662 |* Returns: *| 03663 |* NONE *| 03664 |* *| 03665 \******************************************************************************/ 03666 03667 void cif_cont_line_rec(int continuation_type, 03668 int line_number) 03669 { 03670 int file_line_num; /* placeholder */ 03671 int local_file_id; 03672 03673 03674 file_line_num = get_line_and_file_id(line_number, &local_file_id); 03675 03676 Cif_Continuation_Rec(c_i_f, 03677 continuation_type, 03678 local_file_id, 03679 line_number, 03680 1); 03681 03682 return; 03683 03684 } /* cif_cont_line_rec */ 03685 03686 03687 /******************************************************************************\ 03688 |* *| 03689 |* Description: *| 03690 |* Output a Call Site [28] record. *| 03691 |* *| 03692 |* Input parameters: *| 03693 |* ir_idx - ir idx for call operator. *| 03694 |* gen_idx - attr_idx of original call attr. *| 03695 |* *| 03696 |* Output parameters: *| 03697 |* NONE *| 03698 |* *| 03699 |* Returns: *| 03700 |* NOTHING *| 03701 |* *| 03702 \******************************************************************************/ 03703 03704 void cif_call_site_rec(int ir_idx, 03705 int gen_idx) 03706 03707 { 03708 int array_type; 03709 long attributes; 03710 int attr_idx; 03711 int bd_idx; 03712 char buffer[160]; /* Copied from cif_send_attr. */ 03713 char char_len[20]; 03714 int column; 03715 int derived_type_id; 03716 int file_line_num; 03717 int i; 03718 int info_idx; 03719 int k; 03720 int list_idx; 03721 int local_file_id; 03722 int misc_attrs; 03723 int num_args; 03724 int num_dims; 03725 opnd_type opnd; 03726 int pgm_unit_type; 03727 int rslt_id; 03728 int save_reference; 03729 int spec_idx; 03730 int specific_symbol_id; 03731 char string[20]; /* Copied from cif_send_attr. */ 03732 int symbol_id; 03733 int type; 03734 char var_len_bound[3]; 03735 03736 03737 TRACE (Func_Entry, "cif_call_site_rec", NULL); 03738 03739 /* 03740 if (SH_CIF_SKIP_ME(curr_stmt_sh_idx)) { 03741 TRACE (Func_Exit, "cif_call_site_rec", NULL); 03742 return; 03743 } 03744 */ 03745 03746 skip_struct_base = FALSE; 03747 file_line_num = get_line_and_file_id(IR_LINE_NUM_L(ir_idx), 03748 &local_file_id); 03749 spec_idx = IR_IDX_L(ir_idx); 03750 03751 /* If this is a generic procedure reference and there is something wrong */ 03752 /* with the generic procedure Attr, then don't output the Call Site record */ 03753 /* because other records might not be generated to resolve symbol ids in */ 03754 /* the Call Site record. */ 03755 03756 if (spec_idx != gen_idx && AT_DCL_ERR(gen_idx)) { 03757 goto EXIT; 03758 } 03759 03760 num_args = IR_LIST_CNT_R(ir_idx); 03761 list_idx = IR_IDX_R(ir_idx); 03762 03763 for (i = 1; i <= num_args; i++) { 03764 03765 info_idx = IL_ARG_DESC_IDX(list_idx); 03766 03767 if (info_idx == 0) { 03768 /* cif id is 0 */ 03769 } 03770 else if (arg_info_list[info_idx].ed.component) { 03771 arg_info_list[info_idx].ed.cif_id = list_idx; 03772 } 03773 else if (arg_info_list[info_idx].ed.cif_id != 0) { 03774 /* intentionally blank */ 03775 } 03776 else if (arg_info_list[info_idx].ed.reference || 03777 (IL_FLD(list_idx) == AT_Tbl_Idx && 03778 ! AT_COMPILER_GEND(IL_IDX(list_idx)))) { 03779 03780 /* If no CIF symbol id yet, get one. */ 03781 03782 COPY_OPND(opnd, IL_OPND(list_idx)); 03783 attr_idx = find_left_attr(&opnd); 03784 03785 if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit && 03786 ATP_PROC(attr_idx) == Intrin_Proc) { 03787 attr_idx = ATP_INTERFACE_IDX(attr_idx); 03788 } 03789 03790 if (AT_CIF_SYMBOL_ID(attr_idx) == 0) { 03791 AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID; 03792 } 03793 03794 arg_info_list[info_idx].ed.cif_id = AT_CIF_SYMBOL_ID(attr_idx); 03795 } 03796 else { 03797 symbol_id = NEXT_SYMBOL_ID; 03798 char_len[0] = NULL_CHAR; 03799 03800 COPY_OPND(opnd, IL_OPND(list_idx)); 03801 attr_idx = find_left_attr(&opnd); 03802 03803 type = (arg_info_list[info_idx].ed.type == Structure) ? 03804 ATT_CIF_DT_ID(TYP_IDX(arg_info_list[info_idx].ed.type_idx)) : 03805 arg_info_list[info_idx].ed.linear_type; 03806 03807 if (arg_info_list[info_idx].ed.type == Character) { 03808 03809 if (arg_info_list[info_idx].ed.char_len.fld == CN_Tbl_Idx) { 03810 convert_to_string( 03811 &CN_CONST(arg_info_list[info_idx].ed.char_len.idx), 03812 CN_TYPE_IDX(arg_info_list[info_idx].ed.char_len.idx), 03813 char_len); 03814 } 03815 else { 03816 char_len[0] = VAR_LEN_CHAR; 03817 char_len[1] = NULL_CHAR; 03818 } 03819 } 03820 03821 misc_attrs = 0; 03822 derived_type_id = 0; 03823 03824 if (arg_info_list[info_idx].ed.constant) { 03825 03826 if (IL_FLD(list_idx) == CN_Tbl_Idx) { 03827 attr_idx = IL_IDX(list_idx); 03828 } 03829 } 03830 03831 num_dims = arg_info_list[info_idx].ed.rank; 03832 03833 array_type = (num_dims > 0) ? 1 /* explicit shape */ : 0; 03834 03835 if (fprintf(c_i_f, 03836 "%d%c%s%c%d%c%d%c%d%c%d%c%d%c%d%c%d%c%d%c%d%c%s%c%d%c%d", 03837 CIF_F90_OBJECT, EOI, 03838 "", EOI, 03839 symbol_id, EOI, 03840 SCP_CIF_ID(curr_scp_idx), EOI, 03841 cif_data_type(type), EOI, 03842 2, EOI, 03843 7,EOI, 03844 0,EOI, 03845 -1, EOI, 03846 misc_attrs, EOI, 03847 derived_type_id, EOI, 03848 char_len, EOI, 03849 num_dims, EOI, 03850 array_type) < 0) { 03851 Cif_Error(); 03852 goto EXIT; 03853 } 03854 03855 buffer[0] = NULL_CHAR; 03856 03857 var_len_bound[0] = EOI; 03858 var_len_bound[1] = VAR_LEN_CHAR; 03859 var_len_bound[2] = NULL_CHAR; 03860 03861 for (k = 0; k < num_dims; k++) { 03862 03863 if (arg_info_list[info_idx].ed.constant && 03864 attr_idx != NULL_IDX) { 03865 03866 bd_idx = ATD_ARRAY_IDX(attr_idx); 03867 03868 if (BD_LB_FLD(bd_idx, k+1) == CN_Tbl_Idx) { 03869 sprintf(string, "%c%s", 03870 EOI, 03871 convert_to_string(&CN_CONST(BD_LB_IDX(bd_idx,k+1)), 03872 CN_TYPE_IDX(BD_LB_IDX(bd_idx,k+1)), 03873 outbuf1)); 03874 strcat(buffer, string); 03875 } 03876 else { 03877 strcat(buffer, var_len_bound); 03878 } 03879 03880 if (BD_UB_FLD(bd_idx, k+1) == CN_Tbl_Idx) { 03881 sprintf(string, "%c%s", 03882 EOI, 03883 convert_to_string(&CN_CONST(BD_UB_IDX(bd_idx,k+1)), 03884 CN_TYPE_IDX(BD_UB_IDX(bd_idx,k+1)), 03885 outbuf1)); 03886 strcat(buffer, string); 03887 } 03888 else { 03889 strcat(buffer, var_len_bound); 03890 } 03891 } 03892 else { 03893 buffer[0] = EOI; 03894 buffer[1] = '1'; 03895 buffer[2] = NULL_CHAR; 03896 03897 if (OPND_FLD(arg_info_list[info_idx].ed.shape[k]) == 03898 CN_Tbl_Idx) { 03899 sprintf(string, "%c%s", 03900 EOI, 03901 convert_to_string( 03902 &CN_CONST(OPND_IDX( 03903 arg_info_list[info_idx].ed.shape[k])), 03904 CN_TYPE_IDX(OPND_IDX( 03905 arg_info_list[info_idx].ed.shape[k])), 03906 outbuf1)); 03907 strcat(buffer, string); 03908 } 03909 else { 03910 strcat(buffer, var_len_bound); 03911 } 03912 } 03913 03914 if (fprintf(c_i_f, "%s", buffer) < 0) { 03915 Cif_Error(); 03916 goto EXIT; 03917 } 03918 } 03919 03920 if (fprintf(c_i_f, "%c%d%c%d%c%d%c", 03921 EOI, 03922 0, EOI, /* Distribution */ 03923 0, EOI, /* Geometry id */ 03924 0, EOR) < 0) { /* CRI ptr id */ 03925 Cif_Error(); 03926 goto EXIT; 03927 } 03928 03929 arg_info_list[info_idx].ed.cif_id = symbol_id; 03930 } 03931 03932 list_idx = IL_NEXT_LIST_IDX(list_idx); 03933 } 03934 03935 if (ATP_PROC(spec_idx) == Intrin_Proc && !ATI_USER_SPECIFIED(gen_idx)) { 03936 03937 /* Intrinsic call where the intrinsic name was NOT specified as the */ 03938 /* generic name on a user interface block. */ 03939 03940 if (AT_CIF_SYMBOL_ID(gen_idx) == 0) { 03941 AT_CIF_SYMBOL_ID(gen_idx) = NEXT_SYMBOL_ID; 03942 } 03943 03944 symbol_id = AT_CIF_SYMBOL_ID(gen_idx); 03945 03946 if (AT_CIF_SYMBOL_ID(spec_idx) == 0) { 03947 AT_CIF_SYMBOL_ID(spec_idx) = NEXT_SYMBOL_ID; 03948 } 03949 03950 specific_symbol_id = 0; 03951 specific_symbol_id = AT_CIF_SYMBOL_ID(spec_idx); 03952 03953 column = (ATP_PGM_UNIT(spec_idx) == Function) ? IR_COL_NUM_L(ir_idx) : 03954 IR_COL_NUM(ir_idx); 03955 if (! ATI_CIF_SEEN_IN_CALL(gen_idx)) { 03956 03957 /* Issue an entry record for the interface. These do not go out */ 03958 /* in cif_send_attr but need to be specially sent through here. */ 03959 03960 rslt_id = 0; 03961 03962 if (ATI_INTERFACE_CLASS(gen_idx) == Generic_Function_Interface) { 03963 pgm_unit_type = CIF_F90_ET_FUNCTION; 03964 03965 /* Just set the result's symbol id for now. The Object record */ 03966 /* will be produced via calls directly from call site processing */ 03967 /* code after all information about the function being called has */ 03968 /* been resolved. The specific entry will be sent at that time. */ 03969 03970 if (AT_CIF_SYMBOL_ID(ATP_RSLT_IDX(spec_idx)) == 0) { 03971 AT_CIF_SYMBOL_ID(ATP_RSLT_IDX(spec_idx)) = NEXT_SYMBOL_ID; 03972 } 03973 03974 rslt_id = AT_CIF_SYMBOL_ID(ATP_RSLT_IDX(spec_idx)); 03975 } 03976 else if (ATI_INTERFACE_CLASS(gen_idx) == Generic_Subroutine_Interface){ 03977 pgm_unit_type = CIF_F90_ET_SUBROUTINE; 03978 03979 /* Send the specific entry as it will not get sent when the */ 03980 /* symbol table gets sent as intrinsics are special cased. */ 03981 03982 save_reference = AT_REFERENCED(spec_idx); 03983 AT_REFERENCED(spec_idx) = Referenced; 03984 cif_send_attr(spec_idx, NULL_IDX); 03985 AT_REFERENCED(spec_idx) = save_reference; 03986 03987 } 03988 else { 03989 pgm_unit_type = CIF_F90_ET_UNKNOWN; 03990 cif_send_attr(spec_idx, NULL_IDX); 03991 } 03992 03993 attributes = CIF_PGM_REFERENCE; 03994 03995 if (AT_PRIVATE(gen_idx)) { 03996 attributes = attributes | CIF_PGM_PRIVATE; 03997 } 03998 03999 Cif_F90_Entry_Rec(c_i_f, 04000 AT_OBJ_NAME_PTR(gen_idx), 04001 AT_CIF_SYMBOL_ID(gen_idx), 04002 SCP_CIF_ID(curr_scp_idx), 04003 pgm_unit_type, 04004 CIF_F90_PT_INTRINSIC, 04005 attributes, 04006 rslt_id, 04007 0, 04008 0, 04009 NULL); 04010 } 04011 } 04012 else if (spec_idx == gen_idx) { /* Specific call. */ 04013 04014 if (AT_CIF_SYMBOL_ID(spec_idx) == 0) { 04015 AT_CIF_SYMBOL_ID(spec_idx) = NEXT_SYMBOL_ID; 04016 } 04017 04018 symbol_id = AT_CIF_SYMBOL_ID(spec_idx); 04019 specific_symbol_id = 0; 04020 04021 if (ATP_PGM_UNIT(spec_idx) == Function) { 04022 column = IR_COL_NUM_L(ir_idx); 04023 } 04024 else { 04025 column = IR_COL_NUM(ir_idx); 04026 } 04027 } 04028 else if (ATI_INTERFACE_CLASS(gen_idx) == Defined_Assign_Interface) { 04029 04030 if (AT_CIF_SYMBOL_ID(spec_idx) == 0) { 04031 AT_CIF_SYMBOL_ID(spec_idx) = NEXT_SYMBOL_ID; 04032 } 04033 04034 specific_symbol_id = AT_CIF_SYMBOL_ID(spec_idx); 04035 04036 if (AT_CIF_SYMBOL_ID(gen_idx) == 0) { 04037 AT_CIF_SYMBOL_ID(gen_idx) = NEXT_SYMBOL_ID; 04038 } 04039 04040 symbol_id = AT_CIF_SYMBOL_ID(gen_idx); 04041 column = IR_COL_NUM(ir_idx); 04042 } 04043 else { 04044 04045 if (AT_CIF_SYMBOL_ID(spec_idx) == 0) { 04046 AT_CIF_SYMBOL_ID(spec_idx) = NEXT_SYMBOL_ID; 04047 } 04048 04049 specific_symbol_id = AT_CIF_SYMBOL_ID(spec_idx); 04050 04051 if (AT_CIF_SYMBOL_ID(gen_idx) == 0) { 04052 AT_CIF_SYMBOL_ID(gen_idx) = NEXT_SYMBOL_ID; 04053 } 04054 04055 symbol_id = AT_CIF_SYMBOL_ID(gen_idx); 04056 04057 if (ATI_INTERFACE_CLASS(gen_idx) == Generic_Function_Interface) { 04058 column = IR_COL_NUM_L(ir_idx); 04059 } 04060 else { 04061 column = IR_COL_NUM(ir_idx); 04062 } 04063 } 04064 04065 if (fprintf(c_i_f, "%d%c%d%c%d%c%d%c%d%c%d%c%d%c%d", 04066 CIF_F90_CALLSITE, EOI, 04067 symbol_id, EOI, 04068 SCP_CIF_ID(curr_scp_idx), EOI, 04069 local_file_id, EOI, 04070 file_line_num, EOI, 04071 column, EOI, 04072 specific_symbol_id, EOI, 04073 num_args) < 0) { 04074 04075 Cif_Error(); 04076 goto EXIT; 04077 } 04078 04079 04080 /* Output the symbol IDs for the actual arguments. */ 04081 04082 list_idx = IR_IDX_R(ir_idx); 04083 04084 for (i = 1; i <= num_args; i++) { 04085 04086 info_idx = IL_ARG_DESC_IDX(list_idx); 04087 04088 if (info_idx == 0) { 04089 04090 if (fprintf(c_i_f, "%c%d", EOI, 0) < 0) { 04091 Cif_Error(); 04092 goto EXIT; 04093 } 04094 } 04095 else if (arg_info_list[info_idx].ed.component) { 04096 04097 if (fprintf(c_i_f, "%c%c", EOI, '%') < 0) { 04098 Cif_Error(); 04099 goto EXIT; 04100 } 04101 04102 COPY_OPND(opnd, 04103 IL_OPND(arg_info_list[info_idx].ed.cif_id)); 04104 04105 cif_number_of_struct_ids = 0; 04106 04107 output_struct_ids(&opnd); 04108 04109 if (fprintf(c_i_f, "%c%d", EOI, cif_number_of_struct_ids) < 0) { 04110 Cif_Error(); 04111 goto EXIT; 04112 } 04113 04114 cif_number_of_struct_ids = -1; 04115 04116 if (! output_struct_ids(&opnd)) { 04117 Cif_Error(); 04118 goto EXIT; 04119 } 04120 04121 if (fprintf(c_i_f, "%c%c", EOI, '%') < 0) { 04122 Cif_Error(); 04123 goto EXIT; 04124 } 04125 } 04126 else { 04127 if (fprintf(c_i_f, "%c%d", 04128 EOI, 04129 arg_info_list[info_idx].ed.cif_id) < 0) { 04130 Cif_Error(); 04131 goto EXIT; 04132 } 04133 } 04134 04135 list_idx = IL_NEXT_LIST_IDX(list_idx); 04136 } 04137 04138 04139 /* Output the rank for the each actual argument. */ 04140 04141 list_idx = IR_IDX_R(ir_idx); 04142 04143 for (i = 1; i <= num_args; i++) { 04144 04145 info_idx = IL_ARG_DESC_IDX(list_idx); 04146 04147 if (info_idx == 0) { 04148 04149 if (fprintf(c_i_f, "%c%d", EOI, 0) < 0) { 04150 Cif_Error(); 04151 goto EXIT; 04152 } 04153 } 04154 else { 04155 04156 if (fprintf(c_i_f, "%c%d", 04157 EOI, 04158 arg_info_list[info_idx].ed.rank) < 0) { 04159 Cif_Error(); 04160 goto EXIT; 04161 } 04162 } 04163 04164 list_idx = IL_NEXT_LIST_IDX(list_idx); 04165 } 04166 04167 if (fprintf(c_i_f,"%c", EOR) < 0) { 04168 Cif_Error(); 04169 goto EXIT; 04170 } 04171 04172 EXIT: 04173 04174 TRACE (Func_Exit, "cif_call_site_rec", NULL); 04175 04176 return; 04177 04178 } /* cif_call_site_rec */ 04179 04180 04181 /******************************************************************************\ 04182 |* *| 04183 |* Description: *| 04184 |* Output a Named Constant record [30]. *| 04185 |* *| 04186 |* Input parameters: *| 04187 |* attr_idx : AT table index of the named constant *| 04188 |* start_line : line where the value starts *| 04189 |* start_column : column where the value starts *| 04190 |* *| 04191 |* Output parameters: *| 04192 |* NONE *| 04193 |* *| 04194 |* Returns: *| 04195 |* NONE *| 04196 |* *| 04197 \******************************************************************************/ 04198 04199 void cif_named_constant_rec(int attr_idx, 04200 int start_line, 04201 int start_column) 04202 { 04203 int cn_idx; 04204 int const_idx; 04205 int end_col; 04206 int end_line; 04207 int file_id; 04208 long64 length; 04209 boolean ok; 04210 long_type result[MAX_WORDS_FOR_NUMERIC]; 04211 char str[80]; 04212 int type_idx; 04213 04214 04215 TRACE (Func_Entry, "cif_named_constant_rec", NULL); 04216 04217 if (AT_CIF_SYMBOL_ID(attr_idx) == 0) { 04218 AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID; 04219 } 04220 04221 if (TYP_LINEAR(ATD_TYPE_IDX(attr_idx)) != Structure_Type && 04222 ATD_ARRAY_IDX(attr_idx) == NULL_IDX) { 04223 const_idx = ATD_CONST_IDX(attr_idx); 04224 } 04225 else { 04226 const_idx = NULL_IDX; 04227 } 04228 04229 get_line_and_file_id(start_line, &file_id); 04230 04231 if (fprintf(c_i_f, "%d%c%d%c%d%c%d%c", 04232 CIF_F90_CONST, EOI, 04233 AT_CIF_SYMBOL_ID(attr_idx), EOI, 04234 (c_i_f == cif_actual_file) ? 04235 SCP_CIF_ID(curr_scp_idx) : 1, EOI, 04236 (const_idx) ? 0 : 1, EOI) < 0) { 04237 Cif_Error(); 04238 } 04239 04240 if (const_idx) { 04241 04242 switch (TYP_TYPE(ATD_TYPE_IDX(attr_idx))) { 04243 04244 case Logical: 04245 if (fprintf(c_i_f, "%s", 04246 (THIS_IS_TRUE(&(CN_CONST(const_idx)), 04247 CN_TYPE_IDX(const_idx)) ? 04248 04249 ".TRUE." : ".FALSE.")) < 0) { 04250 Cif_Error(); 04251 } 04252 04253 break; 04254 04255 case Integer: 04256 case Real: 04257 case Complex: 04258 04259 if (fprintf(c_i_f, "%s", convert_to_string(&CN_CONST(const_idx), 04260 CN_TYPE_IDX(const_idx), 04261 str)) < 0) { 04262 Cif_Error(); 04263 } 04264 04265 break; 04266 04267 case Typeless: 04268 if (TYP_LINEAR(CN_TYPE_IDX(const_idx)) == Typeless_4 || 04269 TYP_LINEAR(CN_TYPE_IDX(const_idx)) == Typeless_8) { 04270 04271 if (fprintf(c_i_f, "%s", 04272 convert_to_string(&CN_CONST(const_idx), 04273 CN_TYPE_IDX(const_idx), 04274 str)) < 0) { 04275 Cif_Error(); 04276 } 04277 } 04278 else if (fprintf(c_i_f, "%s", (char *) &CN_CONST(const_idx)) < 0) { 04279 Cif_Error(); 04280 } 04281 04282 break; 04283 04284 case Character: 04285 04286 C_TO_F_INT(result, TARGET_CHARS_PER_WORD, CG_INTEGER_DEFAULT_TYPE); 04287 04288 cn_idx = TYP_IDX(CN_TYPE_IDX(const_idx)); 04289 type_idx = CG_INTEGER_DEFAULT_TYPE; 04290 04291 ok = folder_driver((char *) &CN_CONST(cn_idx), 04292 CN_TYPE_IDX(cn_idx), 04293 (char *) result, 04294 type_idx, 04295 result, 04296 &type_idx, 04297 stmt_start_line, 04298 stmt_start_col, 04299 2, 04300 Mod_Opr); 04301 04302 ok |= folder_driver((char *) result, 04303 type_idx, 04304 (char *) &CN_CONST(CN_INTEGER_ZERO_IDX), 04305 CN_TYPE_IDX(CN_INTEGER_ZERO_IDX), 04306 result, 04307 &type_idx, 04308 stmt_start_line, 04309 stmt_start_col, 04310 2, 04311 Eq_Opr); 04312 04313 04314 if (ok && THIS_IS_TRUE(result, type_idx)) { 04315 04316 if (fprintf(c_i_f, "%s", (char *) &CN_CONST(const_idx)) < 0) { 04317 Cif_Error(); 04318 } 04319 } 04320 else { 04321 length = CN_INT_TO_C(TYP_IDX(CN_TYPE_IDX(const_idx))); 04322 ((char *) &CN_CONST(const_idx)) [length] = NULL_CHAR; 04323 04324 if (fprintf(c_i_f, "%s", (char *) &CN_CONST(const_idx)) < 0) { 04325 Cif_Error(); 04326 } 04327 04328 ((char *) &CN_CONST(const_idx)) [length] = ' '; 04329 } 04330 04331 break; 04332 04333 } /* End switch */ 04334 } 04335 04336 /* If start_line is 0, it means cif_named_constant_rec is being called from*/ 04337 /* the ATD_CLASS == Constant case of cif_send_attr to spit out a dummy */ 04338 /* Named Constant record for a use associated named constant. */ 04339 04340 if (start_line != 0) { 04341 prev_char_line_and_col(&end_line, &end_col); 04342 } 04343 else { 04344 file_id = 0; 04345 end_line = 0; 04346 end_col = 0; 04347 } 04348 04349 if (fprintf(c_i_f, "%c%d%c%d%c%d%c%d%c%d%c", 04350 EOI, 04351 file_id, EOI, 04352 start_line, EOI, 04353 start_column, EOI, 04354 end_line, EOI, 04355 end_col, EOR) < 0) { 04356 Cif_Error(); 04357 } 04358 04359 TRACE (Func_Exit, "cif_named_constant_rec", NULL); 04360 04361 return; 04362 04363 } /* cif_named_constant_rec */ 04364 04365 04366 /******************************************************************************\ 04367 |* *| 04368 |* Description: *| 04369 |* Output a Loop Definitions record [32]. *| 04370 |* *| 04371 |* Input parameters: *| 04372 |* NONE *| 04373 |* *| 04374 |* Output parameters: *| 04375 |* NONE *| 04376 |* *| 04377 |* Returns: *| 04378 |* NONE *| 04379 |* *| 04380 \******************************************************************************/ 04381 04382 void cif_loop_def_rec(void) 04383 { 04384 int construct_name_id; 04385 int do_sh_idx; 04386 int do_var_idx; 04387 int end_file_id; 04388 int end_line; 04389 int il_idx; 04390 int loop_info_il_idx; 04391 int loop_ir_idx; 04392 int loop_label_id; 04393 int loop_type; 04394 int lcv_symbol_id; 04395 int start_file_id; 04396 int start_line; 04397 04398 04399 TRACE (Func_Entry, "cif_loop_def_rec", NULL); 04400 04401 do_sh_idx = SH_PARENT_BLK_IDX(curr_stmt_sh_idx); 04402 04403 if (do_sh_idx == NULL_IDX || SH_COMPILER_GEN(do_sh_idx)) { 04404 TRACE (Func_Exit, "cif_loop_def_rec", NULL); 04405 return; 04406 } 04407 04408 loop_ir_idx = SH_IR_IDX(do_sh_idx); 04409 loop_info_il_idx = IR_IDX_R(loop_ir_idx); 04410 04411 if (SH_STMT_TYPE(do_sh_idx) == Do_Iterative_Stmt) { 04412 loop_type = CIF_LP_DO; 04413 04414 /* There are two version of this. The first is what we need */ 04415 /* The second should only be compiler generated so we should */ 04416 /* not get here, but I have code here just in case. */ 04417 04418 if (IL_FLD(loop_info_il_idx) == IL_Tbl_Idx) { 04419 il_idx = IL_IDX(loop_info_il_idx); 04420 } 04421 else { 04422 il_idx = loop_info_il_idx; 04423 } 04424 04425 if (IL_FLD(il_idx) == AT_Tbl_Idx) { 04426 do_var_idx = IL_IDX(il_idx); 04427 } 04428 else { 04429 04430 /* Had better be a Dv_Deref IR. */ 04431 04432 do_var_idx = IR_IDX_L(IL_IDX(il_idx)); 04433 } 04434 04435 if (AT_CIF_SYMBOL_ID(do_var_idx) == 0) { 04436 AT_CIF_SYMBOL_ID(do_var_idx) = NEXT_SYMBOL_ID; 04437 } 04438 04439 lcv_symbol_id = AT_CIF_SYMBOL_ID(do_var_idx); 04440 } 04441 else { 04442 loop_type = (SH_STMT_TYPE(do_sh_idx) == Do_While_Stmt) ? 04443 CIF_LP_DOWHILE : CIF_LP_DO_INFINITE; 04444 lcv_symbol_id = 0; 04445 } 04446 04447 04448 /* Get the line number and file id of the DO statement and the file id of */ 04449 /* line that ends the DO loop. For the ending line case, the line number */ 04450 /* is already known (obtained from the Statement_Number SH already */ 04451 /* processed by prog_unit_semantics). */ 04452 04453 start_line = get_line_and_file_id(SH_GLB_LINE(do_sh_idx), 04454 &start_file_id); 04455 04456 end_line = get_line_and_file_id(stmt_end_line, &end_file_id); 04457 04458 04459 loop_info_il_idx = IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(loop_info_il_idx)); 04460 il_idx = IL_IDX(loop_info_il_idx); 04461 04462 if (IL_FLD(il_idx) == NO_Tbl_Idx) { 04463 loop_label_id = 0; 04464 } 04465 else { 04466 04467 if (AT_CIF_SYMBOL_ID(IL_IDX(il_idx)) == 0) { 04468 AT_CIF_SYMBOL_ID(IL_IDX(il_idx)) = NEXT_SYMBOL_ID; 04469 } 04470 04471 loop_label_id = AT_CIF_SYMBOL_ID(IL_IDX(il_idx)); 04472 } 04473 04474 il_idx = IL_NEXT_LIST_IDX(il_idx); 04475 04476 if (IL_FLD(il_idx) == NO_Tbl_Idx) { 04477 construct_name_id = 0; 04478 } 04479 else { 04480 04481 if (AT_CIF_SYMBOL_ID(IL_IDX(il_idx)) == 0) { 04482 AT_CIF_SYMBOL_ID(IL_IDX(il_idx)) = NEXT_SYMBOL_ID; 04483 } 04484 04485 construct_name_id = AT_CIF_SYMBOL_ID(IL_IDX(il_idx)); 04486 } 04487 04488 Cif_F90_Loop_Rec(c_i_f, 04489 SCP_CIF_ID(curr_scp_idx), 04490 loop_type, 04491 start_file_id, 04492 start_line, 04493 SH_COL_NUM(do_sh_idx), 04494 end_file_id, 04495 end_line, 04496 stmt_end_col, 04497 lcv_symbol_id, 04498 loop_label_id, 04499 construct_name_id, 04500 statement_number); 04501 04502 TRACE (Func_Exit, "cif_loop_def_rec", NULL); 04503 04504 return; 04505 04506 } /* cif_loop_def_rec */ 04507 04508 04509 /******************************************************************************\ 04510 |* *| 04511 |* Description: *| 04512 |* Output a Label record [34]. *| 04513 |* *| 04514 |* Input parameters: *| 04515 |* attr_idx : the label's Attr table index *| 04516 |* *| 04517 |* Output parameters: *| 04518 |* NONE *| 04519 |* *| 04520 |* Returns: *| 04521 |* NONE *| 04522 |* *| 04523 \******************************************************************************/ 04524 04525 void cif_label_rec(int attr_idx) 04526 04527 { 04528 int label_class; 04529 04530 04531 TRACE(Func_Entry, "cif_label_rec", NULL); 04532 04533 switch (ATL_CLASS(attr_idx)) { 04534 04535 case Lbl_Unknown: 04536 label_class = CIF_LB_UNKNOWN; 04537 break; 04538 04539 case Lbl_User: 04540 label_class = CIF_LB_STMT; 04541 break; 04542 04543 case Lbl_Format: 04544 label_class = CIF_LB_FORMAT; 04545 break; 04546 04547 case Lbl_Debug: 04548 case Lbl_Internal: 04549 goto EXIT; 04550 04551 default: 04552 label_class = CIF_LB_CONSTRUCT; 04553 } 04554 04555 if (AT_CIF_SYMBOL_ID(attr_idx) == 0) { 04556 AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID; 04557 } 04558 04559 Cif_F90_Label_Rec(c_i_f, 04560 AT_OBJ_NAME_PTR(attr_idx), 04561 AT_CIF_SYMBOL_ID(attr_idx), 04562 SCP_CIF_ID(curr_scp_idx), 04563 label_class); 04564 04565 EXIT: 04566 04567 TRACE(Func_Exit, "cif_label_rec", NULL); 04568 04569 return; 04570 04571 } /* cif_label_rec */ 04572 04573 04574 /******************************************************************************\ 04575 |* *| 04576 |* Description: *| 04577 |* Output a Miscellaneous Compiler Options record [37]. *| 04578 |* *| 04579 |* Input parameters: *| 04580 |* NONE *| 04581 |* *| 04582 |* Output parameters: *| 04583 |* NONE *| 04584 |* *| 04585 |* Returns: *| 04586 |* NONE *| 04587 |* *| 04588 \******************************************************************************/ 04589 04590 void cif_misc_compiler_opts_rec(void) 04591 { 04592 char char_msg_num[5]; 04593 int i; 04594 int int_len = 0; 04595 int j; 04596 int msg_level; 04597 char work_buf[512]; 04598 char null_string[1] = ""; 04599 int num_items; 04600 int num_paths; 04601 int path_idx; 04602 04603 04604 TRACE (Func_Entry, "cif_misc_compiler_opts_rec", NULL); 04605 04606 04607 if (cmd_line_flags.integer_32) { 04608 int_len = 2; 04609 } 04610 04611 switch (cmd_line_flags.msg_lvl_suppressed) { 04612 04613 case Comment_Lvl: 04614 msg_level = 0; 04615 break; 04616 04617 case Note_Lvl: 04618 msg_level = 1; 04619 break; 04620 04621 case Caution_Lvl: 04622 msg_level = 2; 04623 break; 04624 04625 case Warning_Lvl: 04626 msg_level = 3; 04627 break; 04628 04629 case Error_Lvl: 04630 msg_level = 4; 04631 } 04632 04633 04634 /* Gather information about the -M (message suppress) option. */ 04635 04636 num_items = 0; 04637 work_buf[0] = NULL_CHAR; 04638 04639 for (i = 0; i < MAX_MSG_SIZE; ++i) { 04640 04641 if (message_suppress_tbl[i] != 0) { 04642 04643 for (j = i * HOST_BITS_PER_WORD; 04644 j < (i + 1) * HOST_BITS_PER_WORD; 04645 ++j) { 04646 04647 if (GET_MESSAGE_TBL(message_suppress_tbl, j)) { 04648 ++num_items; 04649 sprintf(char_msg_num, "%d%c", j, EOI); 04650 strcat(work_buf, char_msg_num); 04651 } 04652 } 04653 } 04654 } 04655 04656 if (fprintf(c_i_f, "%d%c%d%c%d%c%d%c%d%c%d%c%d%c", 04657 CIF_F90_MISC_OPTS, EOI, 04658 int_len, EOI, 04659 msg_level, EOI, 04660 (cmd_line_flags.verify_option) ? 1 : 0, EOI, 04661 04662 (on_off_flags.round_mult_operations) ? 0 : 1, EOI, 04663 04664 (!on_off_flags.round_mult_operations) ? 04665 cmd_line_flags.truncate_bits : 0, EOI, 04666 num_items, EOI) < 0) { 04667 Cif_Error(); 04668 } 04669 04670 if (num_items > 0) { 04671 04672 if (fprintf(c_i_f, "%s", work_buf) < 0) { 04673 Cif_Error(); 04674 } 04675 } 04676 04677 04678 /* Gather information about the directive suppress (-x) option. */ 04679 04680 num_items = 0; 04681 work_buf[0] = NULL_CHAR; 04682 04683 if (cmd_line_flags.disregard_all_directives) { 04684 ++num_items; 04685 strcat(work_buf, "all"); 04686 strcat(work_buf, "\036"); 04687 } 04688 04689 if (cmd_line_flags.disregard_all_dirs) { 04690 ++num_items; 04691 strcat(work_buf, "dir"); 04692 strcat(work_buf, "\036"); 04693 } 04694 04695 if (cmd_line_flags.disregard_all_mics) { 04696 ++num_items; 04697 strcat(work_buf, "mic"); 04698 strcat(work_buf, "\036"); 04699 } 04700 04701 if (cmd_line_flags.disregard_conditional_omp) { 04702 ++num_items; 04703 strcat(work_buf, "conditional_omp"); 04704 strcat(work_buf, "\036"); 04705 } 04706 04707 if (cmd_line_flags.disregard_all_mpp_cdirs) { 04708 ++num_items; 04709 strcat(work_buf, "mpp"); 04710 strcat(work_buf, "\036"); 04711 } 04712 04713 if (cmd_line_flags.disregard_all_mips) { 04714 ++num_items; 04715 strcat(work_buf, "mipspro"); 04716 strcat(work_buf, "\036"); 04717 } 04718 04719 if (cmd_line_flags.disregard_all_omps) { 04720 ++num_items; 04721 strcat(work_buf, "omp"); 04722 strcat(work_buf, "\036"); 04723 } 04724 04725 if (cmd_line_flags.disregard_all_openads) { 04726 /* eraxxon: OpenAD directive */ 04727 ++num_items; 04728 strcat(work_buf, "openad"); 04729 strcat(work_buf, "\036"); 04730 } 04731 04732 for (i = 0; i < (Tok_Dir_End - Tok_Dir_Start); i++) { 04733 04734 if (disregard_directive[i]) { 04735 ++num_items; 04736 strcat(work_buf, directive_str[i]); 04737 strcat(work_buf, "\036"); 04738 } 04739 } 04740 04741 for (i = 0; i < (Tok_Mic_End - Tok_Mic_Start); i++) { 04742 04743 if (disregard_mics[i]) { 04744 ++num_items; 04745 strcat(work_buf, dir_mic_str[i]); 04746 strcat(work_buf, "\036"); 04747 } 04748 } 04749 04750 if (fprintf(c_i_f, "%d%c", num_items, EOI) < 0) { 04751 Cif_Error(); 04752 } 04753 04754 if (num_items > 0) { 04755 04756 if (fprintf(c_i_f, "%s", work_buf) < 0) { 04757 Cif_Error(); 04758 } 04759 } 04760 04761 04762 if (fprintf(c_i_f, "%s%c%s%c%s%c%s%c%x%c%d%c", 04763 (cmd_line_flags.binary_output) ? bin_file : null_string, 04764 EOI, 04765 (cmd_line_flags.assembly_output) ? assembly_file : 04766 null_string, EOI, 04767 null_string, EOI, /* inline name */ 04768 cif_name, EOI, 04769 cif_C_opts, EOI, 04770 (cmd_line_flags.line_size_80) ? 80 : 72, EOI) < 0) { 04771 Cif_Error(); 04772 } 04773 04774 04775 /* If no INCLUDE file paths were specified, just output a 0 count and skip */ 04776 /* the path field. Otherwise, count them up, output the count, then */ 04777 /* output the paths. */ 04778 04779 if (include_path_idx == NULL_IDX) { 04780 04781 if (fprintf(c_i_f, "%d%c", 0, EOI) < 0) { 04782 Cif_Error(); 04783 } 04784 } 04785 else { 04786 04787 path_idx = include_path_idx; 04788 num_paths = 0; 04789 04790 while (path_idx != NULL_IDX) { 04791 ++num_paths; 04792 path_idx = FP_NEXT_FILE_IDX(path_idx); 04793 } 04794 04795 if (fprintf(c_i_f, "%d%c", num_paths, EOI) < 0) { 04796 Cif_Error(); 04797 } 04798 04799 path_idx = include_path_idx; 04800 04801 while (path_idx != NULL_IDX) { 04802 04803 if (fprintf(c_i_f, "%s%c", 04804 FP_NAME_PTR(path_idx), EOI) < 0) { 04805 Cif_Error(); 04806 } 04807 04808 path_idx = FP_NEXT_FILE_IDX(path_idx); 04809 } 04810 } 04811 04812 /* If no module file paths were specified, just output a 0 count and skip */ 04813 /* the path field. Otherwise, count them up, output the count, then */ 04814 /* output the paths. */ 04815 04816 if (module_path_idx == 0) { 04817 04818 if (fprintf(c_i_f, "%d%c", 0, EOI) < 0) { 04819 Cif_Error(); 04820 } 04821 } 04822 else { 04823 path_idx = module_path_idx; 04824 num_paths = 0; 04825 04826 while (path_idx != NULL_IDX) { 04827 ++num_paths; 04828 path_idx = FP_NEXT_FILE_IDX(path_idx); 04829 } 04830 04831 /* Subtract 1 from num_paths because the first thing in the list is the */ 04832 /* object file being created, not a module in a -p option. */ 04833 04834 --num_paths; 04835 04836 if (fprintf(c_i_f, "%d%c", num_paths, EOI) < 0) { 04837 Cif_Error(); 04838 } 04839 04840 path_idx = FP_NEXT_FILE_IDX(module_path_idx); 04841 04842 for (i = 1; i <= num_paths; ++i) { 04843 04844 if (fprintf(c_i_f, "%s%c", FP_NAME_PTR(path_idx), EOI) < 0) { 04845 Cif_Error(); 04846 } 04847 04848 path_idx = FP_NEXT_FILE_IDX(path_idx); 04849 } 04850 } 04851 04852 if (fprintf(c_i_f, "%d%c", 04853 (cmd_line_flags.src_form == Fixed_Form) ? 0 : 1, 04854 EOR) < 0) { 04855 Cif_Error(); 04856 } 04857 04858 TRACE (Func_Exit, "cif_misc_compiler_opts_rec", NULL); 04859 04860 return; 04861 04862 } /* cif_misc_compiler_opts_rec */ 04863 04864 04865 /******************************************************************************\ 04866 |* *| 04867 |* Description: *| 04868 |* Output a Optimization Options record [38]. *| 04869 |* *| 04870 |* Input parameters: *| 04871 |* NONE *| 04872 |* *| 04873 |* Output parameters: *| 04874 |* NONE *| 04875 |* *| 04876 |* Returns: *| 04877 |* NONE *| 04878 |* *| 04879 \******************************************************************************/ 04880 04881 void cif_optimization_opts_rec(void) 04882 { 04883 char buffer[32]; 04884 int num_opts = 0; 04885 char opt_with_lvl[8]; 04886 int optz_opts; 04887 04888 04889 TRACE (Func_Entry, "cif_optimization_opts_rec", NULL); 04890 04891 optz_opts = 0; 04892 04893 if (opt_flags.aggress) { 04894 optz_opts = optz_opts | CIF_OOF_AGGRESS; 04895 } 04896 04897 # ifdef _ACCEPT_BL 04898 04899 if (opt_flags.bottom_load) { 04900 optz_opts = optz_opts | CIF_OOF_BLOAD; 04901 } 04902 04903 # endif 04904 04905 04906 # ifdef _ACCEPT_CMD_O_LOOPALIGN 04907 04908 if (opt_flags.loopalign) { 04909 optz_opts = optz_opts | CIF_OOF_LOOPALIGN; 04910 } 04911 04912 # endif 04913 04914 04915 if (opt_flags.over_index) { 04916 optz_opts = optz_opts | CIF_OOF_OVERINDEX; 04917 } 04918 04919 04920 # ifdef _ACCEPT_PATTERN 04921 04922 if (opt_flags.pattern) { 04923 optz_opts = optz_opts | CIF_OOF_PATTERN; 04924 } 04925 04926 # endif 04927 04928 04929 if (opt_flags.recurrence) { 04930 optz_opts = optz_opts | CIF_OOF_RECURRENCE; 04931 } 04932 04933 04934 # ifdef _ACCEPT_VSEARCH 04935 04936 if (opt_flags.vsearch) { 04937 optz_opts = optz_opts | CIF_OOF_VSEARCH; 04938 } 04939 04940 # endif 04941 04942 04943 # ifdef _ACCEPT_CMD_O_ZEROINC 04944 04945 if (opt_flags.zeroinc) { 04946 optz_opts = optz_opts | CIF_OOF_ZEROINC; 04947 } 04948 04949 # endif 04950 04951 04952 if (fprintf(c_i_f, "%d%c%x%c", 04953 CIF_F90_OPT_OPTS, EOI, 04954 optz_opts, EOI) < 0) { 04955 Cif_Error(); 04956 } 04957 04958 buffer[0] = NULL_CHAR; 04959 04960 04961 # ifdef _ACCEPT_INLINE 04962 04963 if (opt_flags.inline_lvl > Inline_Lvl_0) { 04964 ++num_opts; 04965 sprintf(opt_with_lvl, "%c%x%c%d", 04966 EOI, 04967 CIF_OOF_INLINE, EOI, 04968 opt_flags.inline_lvl); 04969 strcat(buffer, opt_with_lvl); 04970 } 04971 04972 # endif 04973 04974 04975 ++num_opts; 04976 04977 sprintf(opt_with_lvl, "%c%x%c%d", 04978 EOI, 04979 CIF_OOF_SCALAR, EOI, 04980 opt_flags.scalar_lvl); 04981 strcat(buffer, opt_with_lvl); 04982 04983 04984 # ifdef _ACCEPT_VECTOR 04985 04986 ++num_opts; 04987 sprintf(opt_with_lvl, "%c%x%c%d", 04988 EOI, 04989 CIF_OOF_VECTOR, EOI, 04990 opt_flags.vector_lvl); 04991 strcat(buffer, opt_with_lvl); 04992 04993 # endif 04994 04995 04996 # ifdef _ACCEPT_TASK 04997 04998 ++num_opts; 04999 sprintf(opt_with_lvl, "%c%x%c%d", 05000 EOI, 05001 CIF_OOF_TASK, EOI, 05002 opt_flags.task_lvl); 05003 strcat(buffer, opt_with_lvl); 05004 05005 # endif 05006 05007 05008 if (num_opts == 0) { 05009 05010 if (fprintf(c_i_f, "0%c", EOR) < 0) { 05011 Cif_Error(); 05012 } 05013 } 05014 else { 05015 05016 if (fprintf(c_i_f, "%d%s%c", num_opts, buffer, EOR) < 0) { 05017 Cif_Error(); 05018 } 05019 } 05020 05021 TRACE (Func_Exit, "cif_optimization_opts_rec", NULL); 05022 05023 return; 05024 05025 } /* cif_optimization_opts_rec */ 05026 05027 05028 /******************************************************************************\ 05029 |* *| 05030 |* Description: *| 05031 |* Output a Begin Scope record [39]. *| 05032 |* *| 05033 |* Input parameters: *| 05034 |* NONE *| 05035 |* *| 05036 |* Output parameters: *| 05037 |* NONE *| 05038 |* *| 05039 |* Returns: *| 05040 |* NONE *| 05041 |* *| 05042 \******************************************************************************/ 05043 05044 void cif_begin_scope_rec(void) 05045 { 05046 int blk_idx; 05047 int cif_col_num; 05048 int file_line_num; 05049 int glb_line_num; 05050 int level; 05051 int local_blk_stk_idx; 05052 int local_file_id; 05053 int parent_scope_id; 05054 int scope_type; 05055 int symbol_id; 05056 05057 05058 TRACE (Func_Entry, "cif_begin_scope_rec", NULL); 05059 05060 /* Trick case: If the program unit consists of nothing but END, the Block */ 05061 /* Stack will already have been popped by the time we get here. */ 05062 05063 if (blk_stk_idx == 0 && BLK_TYPE(1) == Program_Blk) { 05064 local_blk_stk_idx = 1; 05065 } 05066 else { 05067 local_blk_stk_idx = blk_stk_idx; 05068 } 05069 05070 if (BLK_TYPE(local_blk_stk_idx) <= Interface_Body_Blk) { 05071 05072 if (SCP_CIF_ID(curr_scp_idx) == 0) { 05073 SCP_CIF_ID(curr_scp_idx) = 05074 (BLK_TYPE(local_blk_stk_idx) == Program_Blk) ? 1 : NEXT_SCOPE_ID; 05075 } 05076 05077 BLK_CIF_SCOPE_ID(local_blk_stk_idx) = SCP_CIF_ID(curr_scp_idx); 05078 level = SCP_LEVEL(curr_scp_idx); 05079 } 05080 05081 if (BLK_TYPE(local_blk_stk_idx) < Internal_Blk) { 05082 05083 if (cif_pgm_unit_start_line == stmt_start_line) { 05084 glb_line_num = CURR_BLK_DEF_LINE; 05085 cif_col_num = CURR_BLK_DEF_COLUMN; 05086 } 05087 else { 05088 05089 /* For the pathological case where the only significant line in the */ 05090 /* program contains an END statement, cif_pgm_unit_start_line is */ 05091 /* incremented before we get here. */ 05092 05093 glb_line_num = (cif_pgm_unit_start_line < stmt_start_line) ? 05094 cif_pgm_unit_start_line : stmt_start_line; 05095 05096 cif_col_num = 1; 05097 } 05098 } 05099 05100 switch (BLK_TYPE(local_blk_stk_idx)) { 05101 05102 case Blockdata_Blk: 05103 scope_type = CIF_SCP_BLOCK; 05104 parent_scope_id = 0; 05105 break; 05106 05107 case Module_Blk: 05108 scope_type = CIF_SCP_MOD_SUB; 05109 parent_scope_id = 0; 05110 level = 0; 05111 05112 if (AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(curr_scp_idx)) == 0) { 05113 symbol_id = NEXT_SYMBOL_ID; 05114 AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(curr_scp_idx)) = symbol_id; 05115 } 05116 else { 05117 symbol_id = AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(curr_scp_idx)); 05118 } 05119 05120 break; 05121 05122 case Program_Blk: 05123 scope_type = CIF_SCP_MAIN; 05124 parent_scope_id = 0; 05125 break; 05126 05127 case Function_Blk: 05128 case Subroutine_Blk: 05129 scope_type = CIF_SCP_EXTERNAL; 05130 parent_scope_id = 0; 05131 break; 05132 05133 case Internal_Blk: 05134 scope_type = CIF_SCP_INTERNAL; 05135 parent_scope_id = BLK_CIF_SCOPE_ID(blk_stk_idx - 1); 05136 05137 if (cif_internal_proc_start_line == stmt_start_line) { 05138 glb_line_num = CURR_BLK_DEF_LINE; 05139 cif_col_num = CURR_BLK_DEF_COLUMN; 05140 } 05141 else { 05142 glb_line_num = cif_internal_proc_start_line + 1; 05143 cif_col_num = 1; 05144 } 05145 05146 break; 05147 05148 case Module_Proc_Blk: 05149 scope_type = CIF_SCP_MODULE; 05150 parent_scope_id = SCP_CIF_ID(SCP_PARENT_IDX(curr_scp_idx)); 05151 05152 if (cif_module_proc_start_line == stmt_start_line) { 05153 glb_line_num = CURR_BLK_DEF_LINE; 05154 cif_col_num = CURR_BLK_DEF_COLUMN; 05155 } 05156 else { 05157 glb_line_num = cif_module_proc_start_line + 1; 05158 cif_col_num = 1; 05159 } 05160 05161 break; 05162 05163 case Interface_Body_Blk: 05164 scope_type = CIF_SCP_INTERFACE; 05165 parent_scope_id = BLK_CIF_SCOPE_ID(blk_stk_idx - 1); 05166 glb_line_num = BLK_DEF_LINE(local_blk_stk_idx); 05167 cif_col_num = BLK_DEF_COLUMN(local_blk_stk_idx); 05168 file_line_num = get_line_and_file_id(glb_line_num, &local_file_id); 05169 05170 /* LRR: Can we assume there are no invalid blocks between the */ 05171 /* interface body block and the containing procedure block? */ 05172 05173 level = 1; 05174 blk_idx = blk_stk_idx - 1; 05175 05176 while (BLK_TYPE(blk_idx) > Module_Proc_Blk) { 05177 ++level; 05178 blk_idx--; 05179 } 05180 05181 break; 05182 05183 case Do_Blk: 05184 case If_Blk: 05185 case If_Then_Blk: 05186 case Select_Blk: 05187 case Where_Then_Blk: 05188 case Contains_Blk: 05189 case Derived_Type_Blk: 05190 05191 /* If the current block type > Interface_Body_Blk it better be */ 05192 /* because the block is the first thing in the main program. */ 05193 05194 if ((CURR_BLK == If_Then_Blk && 05195 BLK_TYPE(blk_stk_idx - 2) == Program_Blk) || 05196 (CURR_BLK != If_Then_Blk && 05197 BLK_TYPE(blk_stk_idx - 1) == Program_Blk)) { 05198 scope_type = CIF_SCP_MAIN; 05199 SCP_CIF_ID(curr_scp_idx) = 1; 05200 05201 local_blk_stk_idx = (CURR_BLK == If_Then_Blk) ? 05202 blk_stk_idx - 2 : blk_stk_idx - 1; 05203 05204 BLK_CIF_SCOPE_ID(local_blk_stk_idx) = 1; 05205 parent_scope_id = 0; 05206 level = 0; 05207 05208 if (cif_pgm_unit_start_line == stmt_start_line) { 05209 glb_line_num = BLK_DEF_LINE(local_blk_stk_idx); 05210 cif_col_num = BLK_DEF_COLUMN(local_blk_stk_idx); 05211 } 05212 else { 05213 glb_line_num = cif_pgm_unit_start_line; 05214 cif_col_num = 1; 05215 } 05216 } 05217 # ifdef _DEBUG 05218 else { 05219 PRINTMSG(stmt_start_line, 260, Internal, 0); 05220 } 05221 # endif 05222 break; 05223 05224 # ifdef _DEBUG 05225 case If_Else_If_Blk: 05226 case Case_Blk: 05227 case Where_Else_Blk: 05228 case Where_Else_Mask_Blk: 05229 PRINTMSG(stmt_start_line, 260, Internal, 0); 05230 # endif 05231 05232 case Interface_Blk: 05233 if (BLK_TYPE(blk_stk_idx - 1) == Program_Blk && 05234 BLK_CIF_SCOPE_ID(blk_stk_idx - 1) == 0) { 05235 scope_type = CIF_SCP_MAIN; 05236 SCP_CIF_ID(curr_scp_idx) = 1; 05237 BLK_CIF_SCOPE_ID(blk_stk_idx - 1) = 1; 05238 parent_scope_id = 0; 05239 level = 0; 05240 05241 if (cif_pgm_unit_start_line == stmt_start_line) { 05242 glb_line_num = BLK_DEF_LINE(blk_stk_idx - 1); 05243 cif_col_num = BLK_DEF_COLUMN(blk_stk_idx - 1); 05244 } 05245 else { 05246 glb_line_num = cif_pgm_unit_start_line; 05247 cif_col_num = 1; 05248 } 05249 05250 file_line_num = get_line_and_file_id(glb_line_num, &local_file_id); 05251 05252 /* Symbol ID 2 is reserved for the name of the main program. */ 05253 05254 symbol_id = 2; 05255 05256 if (BLK_NAME(blk_stk_idx - 1) == NULL_IDX) { 05257 05258 if (AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(curr_scp_idx)) == 0) { 05259 AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(curr_scp_idx)) = symbol_id; 05260 } 05261 } 05262 else if (AT_CIF_SYMBOL_ID(BLK_NAME(blk_stk_idx - 1)) == 0) { 05263 AT_CIF_SYMBOL_ID(BLK_NAME(blk_stk_idx - 1)) = symbol_id; 05264 } 05265 05266 if (fprintf(c_i_f, "%d%c%d%c%d%c%d%c%d%c%d%c%d%c%d%c%d%c", 05267 CIF_F90_BEGIN_SCOPE, EOI, 05268 BLK_CIF_SCOPE_ID(blk_stk_idx - 1), EOI, 05269 symbol_id, EOI, 05270 local_file_id, EOI, 05271 file_line_num, EOI, 05272 cif_col_num, EOI, 05273 scope_type, EOI, 05274 level, EOI, 05275 parent_scope_id, EOR) < 0) { 05276 Cif_Error(); 05277 } 05278 05279 } 05280 05281 scope_type = CIF_SCP_INT_BLOCK; 05282 local_blk_stk_idx = blk_stk_idx; 05283 BLK_CIF_SCOPE_ID(blk_stk_idx) = NEXT_SCOPE_ID; 05284 parent_scope_id = BLK_CIF_SCOPE_ID(blk_stk_idx - 1); 05285 level = SCP_LEVEL(curr_scp_idx) + 1; 05286 glb_line_num = BLK_DEF_LINE(local_blk_stk_idx); 05287 cif_col_num = BLK_DEF_COLUMN(local_blk_stk_idx); 05288 break; 05289 05290 default: 05291 PRINTMSG(stmt_start_line, 179, Internal, 0, "cif_begin_scope_rec"); 05292 } 05293 05294 if (BLK_NAME(local_blk_stk_idx) == NULL_IDX) { 05295 05296 if (BLK_TYPE(local_blk_stk_idx) == Program_Blk || 05297 BLK_TYPE(local_blk_stk_idx) == Blockdata_Blk) { 05298 05299 if (AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(curr_scp_idx)) == 0) { 05300 symbol_id = NEXT_SYMBOL_ID; 05301 AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(curr_scp_idx)) = symbol_id; 05302 } 05303 else { 05304 symbol_id = AT_CIF_SYMBOL_ID(SCP_ATTR_IDX(curr_scp_idx)); 05305 } 05306 } 05307 else { 05308 symbol_id = 0; 05309 } 05310 } 05311 else { 05312 if (AT_CIF_SYMBOL_ID(BLK_NAME(local_blk_stk_idx)) == 0) { 05313 symbol_id = NEXT_SYMBOL_ID; 05314 AT_CIF_SYMBOL_ID(BLK_NAME(local_blk_stk_idx)) = symbol_id; 05315 } 05316 else { 05317 symbol_id = AT_CIF_SYMBOL_ID(BLK_NAME(local_blk_stk_idx)); 05318 } 05319 05320 } 05321 05322 file_line_num = get_line_and_file_id(glb_line_num, &local_file_id); 05323 05324 Cif_F90_Begin_Scope_Rec(c_i_f, 05325 BLK_CIF_SCOPE_ID(local_blk_stk_idx), 05326 symbol_id, 05327 local_file_id, 05328 file_line_num, 05329 cif_col_num, 05330 scope_type, 05331 level, 05332 parent_scope_id); 05333 05334 TRACE (Func_Exit, "cif_begin_scope_rec", NULL); 05335 05336 return; 05337 05338 } /* cif_begin_scope_rec */ 05339 05340 05341 /******************************************************************************\ 05342 |* *| 05343 |* Description: *| 05344 |* Output a End Scope record [40]. *| 05345 |* *| 05346 |* Input parameters: *| 05347 |* NONE *| 05348 |* *| 05349 |* Output parameters: *| 05350 |* NONE *| 05351 |* *| 05352 |* Returns: *| 05353 |* NONE *| 05354 |* *| 05355 \******************************************************************************/ 05356 05357 void cif_end_scope_rec(void) 05358 { 05359 int file_line_num; 05360 int local_file_id; 05361 05362 05363 TRACE (Func_Entry, "cif_end_scope_rec", NULL); 05364 05365 /* cif_end_scope_rec assumes that it is called AFTER the scope ending stmt */ 05366 /* has been parsed but BEFORE the EOS has been eaten. Thus, the LA_CH */ 05367 /* should be for the EOS. */ 05368 05369 file_line_num = get_line_and_file_id(LA_CH_LINE, &local_file_id); 05370 05371 if (cif_pgm_unit_error_recovery) { 05372 BLK_CIF_SCOPE_ID(blk_stk_idx) = 1; 05373 } 05374 else { 05375 05376 /* Pathological case: the program unit is nothing but an END stmt. */ 05377 05378 if (CURR_BLK <= Interface_Body_Blk) { 05379 05380 if (SCP_CIF_ID(curr_scp_idx) == 0) { 05381 SCP_CIF_ID(curr_scp_idx) = 05382 (CURR_BLK == Program_Blk) ? 1 : NEXT_SCOPE_ID; 05383 } 05384 05385 BLK_CIF_SCOPE_ID(blk_stk_idx) = SCP_CIF_ID(curr_scp_idx); 05386 } 05387 } 05388 05389 Cif_F90_End_Scope_Rec(c_i_f, 05390 BLK_CIF_SCOPE_ID(blk_stk_idx), 05391 local_file_id, 05392 file_line_num, 05393 LA_CH_COLUMN - 1, 05394 CURR_BLK_ERR); 05395 05396 if (CURR_BLK == Internal_Blk) { 05397 cif_internal_proc_start_line = LA_CH_LINE; 05398 } 05399 else if (CURR_BLK == Module_Proc_Blk) { 05400 cif_module_proc_start_line = LA_CH_LINE; 05401 } 05402 05403 TRACE (Func_Exit, "cif_end_scope_rec", NULL); 05404 05405 return; 05406 05407 } /* cif_end_scope_rec */ 05408 05409 05410 /******************************************************************************\ 05411 |* *| 05412 |* Description: *| 05413 |* Output a Scope Info record [41]. *| 05414 |* *| 05415 |* Input parameters: *| 05416 |* NONE *| 05417 |* *| 05418 |* Output parameters: *| 05419 |* NONE *| 05420 |* *| 05421 |* Returns: *| 05422 |* NONE *| 05423 |* *| 05424 \******************************************************************************/ 05425 05426 void cif_scope_info_rec(void) 05427 { 05428 int al_idx; 05429 int attributes; 05430 char buffer[160]; 05431 int str_len; 05432 char string[10]; 05433 05434 05435 TRACE (Func_Entry, "cif_scope_info_rec", NULL); 05436 05437 attributes = (SCP_IMPL_NONE(curr_scp_idx)) ? CIF_SCP_IMPL_NONE : 0; 05438 05439 if (SCP_DOES_IO(curr_scp_idx)) { 05440 attributes = attributes | CIF_SCP_DOES_IO; 05441 } 05442 05443 if (SCP_HAS_CALLS(curr_scp_idx)) { 05444 attributes = attributes | CIF_SCP_HAS_CALLS; 05445 } 05446 05447 if (SCP_ALT_ENTRY_CNT(curr_scp_idx) == 0) { 05448 buffer[0] = EOR; 05449 buffer[1] = NULL_CHAR; 05450 } 05451 else { 05452 buffer[0] = NULL_CHAR; 05453 al_idx = SCP_ENTRY_IDX(curr_scp_idx); 05454 05455 do { 05456 sprintf(string, "%c%d", 05457 EOI, AT_CIF_SYMBOL_ID(AL_ATTR_IDX(al_idx))); 05458 strcat(buffer, string); 05459 al_idx = AL_NEXT_IDX(al_idx); 05460 } 05461 while (al_idx != NULL_IDX); 05462 05463 str_len = strlen(buffer); 05464 buffer[str_len] = EOR; 05465 buffer[str_len + 1] = NULL_CHAR; 05466 } 05467 05468 if (fprintf(c_i_f, "%d%c%d%c%x%c%d%s", 05469 CIF_F90_SCOPE_INFO, EOI, 05470 SCP_CIF_ID(curr_scp_idx), EOI, 05471 attributes, EOI, 05472 SCP_ALT_ENTRY_CNT(curr_scp_idx), 05473 buffer) < 0) { 05474 Cif_Error(); 05475 } 05476 05477 TRACE (Func_Exit, "cif_scope_info_rec", NULL); 05478 05479 return; 05480 05481 } /* cif_scope_info_rec */ 05482 05483 05484 /******************************************************************************\ 05485 |* *| 05486 |* Description: *| 05487 |* Output a Use Module record [42]. *| 05488 |* *| 05489 |* Input parameters: *| 05490 |* NONE *| 05491 |* *| 05492 |* Output parameters: *| 05493 |* NONE *| 05494 |* *| 05495 |* Returns: *| 05496 |* NONE *| 05497 |* *| 05498 \******************************************************************************/ 05499 05500 void cif_use_module_rec(int attr_idx, 05501 int mf_tbl_idx, 05502 boolean send_attr) 05503 { 05504 int cif_file_id; 05505 int flag; 05506 05507 05508 TRACE (Func_Entry, "cif_use_module_rec", NULL); 05509 05510 if (mf_tbl_idx == NULL_IDX) { 05511 05512 /* This is an indirect reference to a module. If there is more than */ 05513 /* one reference to the same module, we call cif_send_attr for all the */ 05514 /* duplicate entries. We do this because we only keep one attr around */ 05515 /* for each module name and CIF wants to know where the module came from*/ 05516 05517 if (send_attr) { 05518 cif_send_attr(attr_idx, NULL_IDX); 05519 } 05520 else if (AT_CIF_SYMBOL_ID(attr_idx) == 0) { 05521 AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID; 05522 } 05523 05524 cif_file_id = cif_file_name_rec(ATP_MOD_PATH_NAME_PTR(attr_idx), 05525 (char *) NULL); 05526 flag = CIF_USE_MODULE_INDIRECT; 05527 } 05528 else { 05529 05530 if (AT_CIF_SYMBOL_ID(attr_idx) == 0) { 05531 AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID; 05532 } 05533 05534 if (FP_CIF_ID(mf_tbl_idx) == 0) { 05535 FP_CIF_ID(mf_tbl_idx) = cif_file_name_rec(FP_NAME_PTR(mf_tbl_idx), 05536 (char *) NULL); 05537 } 05538 05539 cif_file_id = FP_CIF_ID(mf_tbl_idx); 05540 flag = CIF_USE_MODULE_DIRECT; 05541 } 05542 05543 Cif_F90_Use_Module_Rec(c_i_f, 05544 AT_CIF_SYMBOL_ID(attr_idx), 05545 cif_file_id, 05546 flag); 05547 05548 TRACE (Func_Exit, "cif_use_module_rec", NULL); 05549 05550 return; 05551 05552 } /* cif_use_module_rec */ 05553 05554 05555 /******************************************************************************\ 05556 |* *| 05557 |* Description: *| 05558 |* Output a Rename record [43]. *| 05559 |* Note: We've gone back and forth a couple of times on whether this *| 05560 |* record should also record names in ONLY clauses. The current *| 05561 |* is that it does NOT. But we're leaving the external name *| 05562 |* as "cif_rename_only_rec" in case we change our minds again. *| 05563 |* *| 05564 |* Input parameters: *| 05565 |* NONE *| 05566 |* *| 05567 |* Output parameters: *| 05568 |* NONE *| 05569 |* *| 05570 |* Returns: *| 05571 |* NONE *| 05572 |* *| 05573 \******************************************************************************/ 05574 05575 int cif_rename_rec(int ro_idx, 05576 int cif_symbol_id, 05577 int attr_idx, 05578 int module_attr_idx) 05579 { 05580 05581 TRACE (Func_Entry, "cif_rename_rec", NULL); 05582 05583 /* This routine issues a Rename record and generates a symbol id for the */ 05584 /* name in the module if one is needed. If cif_symbol_id is zero, a new */ 05585 /* symbol id is generated and returned. */ 05586 05587 if (cif_symbol_id == 0) { 05588 cif_symbol_id = NEXT_SYMBOL_ID; 05589 } 05590 05591 if (AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)) == 0) { 05592 AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)) = NEXT_SYMBOL_ID; 05593 } 05594 05595 if (AT_CIF_SYMBOL_ID(attr_idx) == 0) { 05596 AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID; 05597 } 05598 05599 /* AT_ORIG_NAME_PTR and AT_MODULE_IDX will always be set. If the object */ 05600 /* originated in the module being read in, AT_MODULE_IDX is set to the */ 05601 /* module being read in. */ 05602 05603 Cif_F90_Rename_Rec(c_i_f, 05604 SCP_CIF_ID(curr_scp_idx), 05605 RO_NAME_PTR(ro_idx), 05606 cif_symbol_id, 05607 AT_CIF_SYMBOL_ID(module_attr_idx), 05608 AT_ORIG_NAME_PTR(attr_idx), 05609 AT_CIF_SYMBOL_ID(AT_MODULE_IDX(attr_idx)), 05610 (long) AT_CIF_SYMBOL_ID(attr_idx)); 05611 05612 TRACE (Func_Exit, "cif_rename_rec", NULL); 05613 05614 return(cif_symbol_id); 05615 05616 } /* cif_rename_rec */ 05617 05618 05619 /******************************************************************************\ 05620 |* *| 05621 |* Description: *| 05622 |* This procedure is called from main.c when it discovers that no Unit *| 05623 |* record has been generated and we're at the end of the source file. *| 05624 |* This can happen in cases like a free source form program being *| 05625 |* compiled in fixed source form mode. Fake up enough records in the *| 05626 |* CIF (if one is being produced) and the buffered message file so that *| 05627 |* the files are usable. *| 05628 |* *| 05629 |* Input parameters: *| 05630 |* NONE *| 05631 |* *| 05632 |* Output parameters: *| 05633 |* NONE *| 05634 |* *| 05635 |* Returns: *| 05636 |* NOTHING *| 05637 |* *| 05638 \******************************************************************************/ 05639 05640 void cif_fake_a_unit() 05641 { 05642 int file_line_num; 05643 int glb_line_num; 05644 int local_file_id; 05645 int scope_id; 05646 int symbol_id; 05647 05648 05649 TRACE (Func_Entry, "cif_fake_a_unit", NULL); 05650 05651 stmt_start_line = 1; 05652 05653 cif_unit_rec(); 05654 05655 cif_symbol_or_scope_id = 3; /* First 2 values are reserved. */ 05656 /* See cif_prog_unit_init. */ 05657 symbol_id = NEXT_SYMBOL_ID; 05658 scope_id = NEXT_SCOPE_ID; 05659 05660 /* The following pieces of code were lifted from cif_begin_scope_rec. */ 05661 /* That procedure can't be used directly because it relies on the Block */ 05662 /* Stack (which at this point contains junk). */ 05663 05664 glb_line_num = cif_pgm_unit_start_line; 05665 file_line_num = get_line_and_file_id(glb_line_num, &local_file_id); 05666 05667 if (cif_flags & BASIC_RECS) { 05668 05669 Cif_F90_Begin_Scope_Rec(c_i_f, 05670 scope_id, 05671 symbol_id, 05672 local_file_id, 05673 file_line_num, 05674 1, 05675 CIF_SCP_MAIN, 05676 0, 05677 0); 05678 05679 /* Now dummy up an Entry Point record for $MAIN. */ 05680 05681 Cif_F90_Entry_Rec(c_i_f, 05682 UNNAMED_PROGRAM_NAME, 05683 symbol_id, 05684 scope_id, 05685 0, 05686 0, 05687 0, 05688 0, 05689 0, 05690 0, 05691 NULL); 05692 05693 /* The following pieces of code were lifted from cif_end_scope_rec. */ 05694 /* That procedure can't be used directly because it relies on the Block */ 05695 /* Stack (which at this point contains junk). */ 05696 05697 file_line_num = get_line_and_file_id(curr_glb_line - 1, &local_file_id); 05698 05699 Cif_F90_End_Scope_Rec(c_i_f, 05700 scope_id, 05701 local_file_id, 05702 file_line_num, 05703 stmt_start_col, 05704 1); 05705 } 05706 05707 /* Now dummy up an End Unit record. */ 05708 05709 stmt_start_line = (curr_glb_line > 1) ? curr_glb_line - 1 : 1; 05710 stmt_start_col = 1; 05711 cif_end_unit_rec(UNNAMED_PROGRAM_NAME); 05712 05713 TRACE (Func_Exit, "cif_fake_a_unit", NULL); 05714 05715 return; 05716 05717 } /* cif_fake_a_unit */ 05718 05719 05720 /******************************************************************************\ 05721 |* *| 05722 |* Description: *| 05723 |* Print a message and give up if an error is detected when writing to *| 05724 |* the CIF. *| 05725 |* *| 05726 |* Input parameters: *| 05727 |* NONE *| 05728 |* *| 05729 |* Output parameters: *| 05730 |* NONE *| 05731 |* *| 05732 |* Returns: *| 05733 |* NOTHING *| 05734 |* *| 05735 \******************************************************************************/ 05736 05737 void Cif_Error() 05738 { 05739 05740 TRACE (Func_Entry, "Cif_Error", NULL); 05741 05742 PRINTMSG((curr_stmt_sh_idx > 0) ? SH_GLB_LINE(curr_stmt_sh_idx) : 1, 05743 383, Error, 0); 05744 05745 exit_compiler(RC_USER_ERROR); 05746 05747 TRACE (Func_Exit, "Cif_Error", NULL); 05748 05749 } /* Cif_Error */ 05750 05751 05752 /******************************************************************************\ 05753 |* *| 05754 |* Description: *| 05755 |* This routine converts a global line number to a line number within a *| 05756 |* file and also gets the file's CIF file id. *| 05757 |* *| 05758 |* Input parameters: *| 05759 |* search_line Global line number to be translated. *| 05760 |* *| 05761 |* Global Input *| 05762 |* glb_line tbl An entry is made to this table whenever the compiler *| 05763 |* compiler starts inputting source from a file or *| 05764 |* returns to inputting source from a file (after an *| 05765 |* INCLUDE, for example). *| 05766 |* *| 05767 |* Output parameters: *| 05768 |* file_id The CIF file id for the translated line. *| 05769 |* *| 05770 |* Returns: *| 05771 |* act_line Line number within the file. *| 05772 |* *| 05773 \******************************************************************************/ 05774 05775 static int get_line_and_file_id (int search_line, 05776 int *file_id) 05777 { 05778 int idx; /* Index to global line table for line. */ 05779 int actual_line; /* The line number within the file. */ 05780 05781 05782 TRACE (Func_Entry, "get_line_and_file_id", NULL); 05783 05784 GLOBAL_LINE_TO_FILE_LINE(search_line, idx, actual_line); 05785 05786 *file_id = GL_CIF_FILE_ID(idx); 05787 05788 TRACE (Func_Exit, "get_line_and_file_id", NULL); 05789 05790 return(actual_line); 05791 05792 } /* get_line_and_file_id */ 05793 05794 05795 /******************************************************************************\ 05796 |* *| 05797 |* Description: *| 05798 |* This routine recursively prints out structure component symbol ids *| 05799 |* in the proper left to right order. If the global variable *| 05800 |* cif_number_of_struct_ids is set to zero or greater, it will only *| 05801 |* make a count of these components. It is therefore meant to be called *| 05802 |* twice for the same tree. Once for the count, (which is output first) *| 05803 |* and then for the output of the symbol ids. *| 05804 |* *| 05805 |* Input parameters: *| 05806 |* opnd - root of reference tree. *| 05807 |* *| 05808 |* Output parameters: *| 05809 |* NONE *| 05810 |* *| 05811 |* Returns: *| 05812 |* FALSE if cif error *| 05813 |* *| 05814 \******************************************************************************/ 05815 05816 static boolean output_struct_ids(opnd_type *opnd) 05817 05818 { 05819 opnd_type loc_opnd; 05820 boolean ok = TRUE; 05821 05822 TRACE (Func_Entry, "output_struct_ids", NULL); 05823 05824 if (OPND_FLD((*opnd)) == IR_Tbl_Idx) { 05825 05826 if (IR_OPR(OPND_IDX((*opnd))) == Struct_Opr) { 05827 COPY_OPND(loc_opnd, IR_OPND_L(OPND_IDX((*opnd)))); 05828 ok = output_struct_ids(&loc_opnd); 05829 05830 if (ok) { 05831 COPY_OPND(loc_opnd, IR_OPND_R(OPND_IDX((*opnd)))); 05832 ok = output_struct_ids(&loc_opnd); 05833 } 05834 } 05835 else { 05836 COPY_OPND(loc_opnd, IR_OPND_L(OPND_IDX((*opnd)))); 05837 ok = output_struct_ids(&loc_opnd); 05838 } 05839 } 05840 else if (OPND_FLD((*opnd)) == AT_Tbl_Idx) { 05841 05842 if (skip_struct_base && 05843 ATD_CLASS(OPND_IDX((*opnd))) != Struct_Component) { 05844 05845 /* intentionally blank */ 05846 } 05847 else if (cif_number_of_struct_ids >= 0) { 05848 cif_number_of_struct_ids++; 05849 } 05850 else { 05851 if (AT_CIF_SYMBOL_ID(OPND_IDX((*opnd))) == 0) { 05852 AT_CIF_SYMBOL_ID(OPND_IDX((*opnd))) = NEXT_SYMBOL_ID; 05853 } 05854 05855 ok = fprintf(c_i_f, "%c%d", EOI, 05856 AT_CIF_SYMBOL_ID(OPND_IDX((*opnd)))) >= 0; 05857 } 05858 } 05859 05860 TRACE (Func_Exit, "output_struct_ids", NULL); 05861 05862 return(ok); 05863 05864 } /* output_struct_ids */ 05865 05866 05867 /******************************************************************************\ 05868 |* *| 05869 |* Description: *| 05870 |* This routine outputs an Object record with just enough information *| 05871 |* in it so that the visual tools can use it. Such a record should *| 05872 |* only be output if the object it is trying to describe is in error or *| 05873 |* something the object depends upon (such as a derived type definition) *| 05874 |* is in error. *| 05875 |* *| 05876 |* Input parameters: *| 05877 |* attr_idx - Attr index of the object that the record is to record. *| 05878 |* *| 05879 |* Output parameters: *| 05880 |* NONE *| 05881 |* *| 05882 |* Returns: *| 05883 |* NONE *| 05884 |* *| 05885 \******************************************************************************/ 05886 05887 static void output_minimal_object_rec(int attr_idx) 05888 05889 { 05890 char char_len[1]; 05891 05892 05893 TRACE (Func_Entry, "output_minimal_object_rec", NULL); 05894 05895 char_len[0] = NULL_CHAR; 05896 05897 if (AT_CIF_SYMBOL_ID(attr_idx) == 0) { 05898 AT_CIF_SYMBOL_ID(attr_idx) = NEXT_SYMBOL_ID; 05899 } 05900 05901 if (fprintf(c_i_f, 05902 "%d%c%s%c%d%c%d%c%d%c%d%c%d%c%d%c%d%c%x%c%d%c%s%c%d%c%d%c%d%c%d%c%d%c", 05903 CIF_F90_OBJECT, EOI, 05904 AT_OBJ_NAME_PTR(attr_idx), EOI, 05905 AT_CIF_SYMBOL_ID(attr_idx), EOI, 05906 SCP_CIF_ID(curr_scp_idx), EOI, 05907 0, EOI, 05908 0, EOI, 05909 0, EOI, 05910 0, EOI, 05911 -1, EOI, 05912 0, EOI, 05913 0, EOI, 05914 char_len, EOI, 05915 0, EOI, /* Num dims */ 05916 0, EOI, /* Array type */ 05917 0, EOI, /* Distribution */ 05918 0, EOI, /* Geometry id */ 05919 0, EOR) < 0) { /* CRI pointer id */ 05920 Cif_Error(); 05921 } 05922 05923 TRACE (Func_Exit, "output_minimal_object_rec", NULL); 05924 05925 return; 05926 05927 } /* output_minimal_object_rec */ 05928 05929 05930 /******************************************************************************\ 05931 |* *| 05932 |* Description: *| 05933 |* This routine flushes records associated with INCLUDE lines at the end *| 05934 |* of a program unit. It is ugly, it is nasty, but unfortunately it (or *| 05935 |* something like it) is required because INCLUDE lines are always *| 05936 |* processed in "lookahead" mode and all the records are immediately *| 05937 |* produced when the INCLUDE line is processed. Consider: *| 05938 |* *| 05939 |* ... *| 05940 |* END ! a program unit *| 05941 |* SUBROUTINE sub *| 05942 |* INCLUDE '...' *| 05943 |* *| 05944 |* The source input routines buffer up the current line and its following*| 05945 |* line. When the current line is completed, its following line is made *| 05946 |* the current line and a new "following" line is obtained. In the above*| 05947 |* example, when the END line is the current line, the SUBROUTINE line is*| 05948 |* the "following" line. When the EOS at the end of the END line is *| 05949 |* eaten, the source input routines move the SUBROUTINE line to the *| 05950 |* "current line" buffer and read the INCLUDE line into the "following *| 05951 |* line" buffer. BUT the source input routines realize it's an INCLUDE *| 05952 |* line, so they get the first line of the INCLUDE file and make IT the *| 05953 |* "following line". As a part of this all the CIF records associated *| 05954 |* with the INCLUDE line are produced. But in the above example, they *| 05955 |* would fall into the first subprogram's record group because the End *| 05956 |* Unit record for that subprogram has not yet been produced. Therefore,*| 05957 |* the records associated with the INCLUDE line must be "buffered" in the*| 05958 |* temporary CIF until the next unit begins (this is the same thing that *| 05959 |* happens at the beginning of the first program unit in a file). *| 05960 |* *| 05961 |* However, if we have a case like *| 05962 |* *| 05963 |* ... *| 05964 |* INCLUDE '...' *| 05965 |* ... *| 05966 |* END *| 05967 |* *| 05968 |* the CIF records associated with the INCLUDE DO belong to the current *| 05969 |* unit. Since these are records MUST be buffered (because they are *| 05970 |* produced before they actually should be), we need to know when to *| 05971 |* UNbuffer them. In this second case, they need to be unbuffered while *| 05972 |* the current unit is still active. At the END statement is good *| 05973 |* enough. *| 05974 |* *| 05975 |* Now, suppose we have *| 05976 |* *| 05977 |* ... *| 05978 |* INCLUDE '...' *| 05979 |* ... *| 05980 |* END *| 05981 |* SUBROUTINE sub *| 05982 |* INCLUDE '...' *| 05983 |* *| 05984 |* At the END statement, we want to unbuffer any INCLUDE records that *| 05985 |* are associated with the current unit but NOT those associated with a *| 05986 |* following unit. And that's the raison d'etre of this ugly little *| 05987 |* procedure. When called from END stmt processing, it unbuffers the *| 05988 |* right sets of records as follows: *| 05989 |* *| 05990 |* - Write an EOF to the temp CIF and rewind it. *| 05991 |* - Read records from the temp CIF file and write them to the actual *| 05992 |* CIF until the line number is greater than the line number of the *| 05993 |* END statement. *| 05994 |* - Write the remainder of the records (they belong to the next unit) *| 05995 |* to another (secondary) temp file. When done, write an EOF to *| 05996 |* this file and rewind it. *| 05997 |* - Rewind the temp CIF. *| 05998 |* - Copy each record in the secondary temp file to the temp CIF. *| 05999 |* - Get rid of the secondary temp file. *| 06000 |* *| 06001 |* Input parameters: *| 06002 |* NONE *| 06003 |* *| 06004 |* Output parameters: *| 06005 |* NONE *| 06006 |* *| 06007 |* Returns: *| 06008 |* NONE *| 06009 |* *| 06010 \******************************************************************************/ 06011 06012 static void cif_flush_include_recs(void) 06013 06014 { 06015 06016 # define FILE_ID_LIST_SIZE 1000 06017 06018 FILE *aux_file; 06019 char aux_file_name[MAX_FILE_NAME_SIZE]; 06020 char buf[9]; 06021 int end_stmt_line; 06022 int file_id; 06023 int file_id_list[FILE_ID_LIST_SIZE]; 06024 int file_id_list_idx = 0; 06025 boolean first_record = TRUE; 06026 char generic_rec[512]; /* Arbitrary size. */ 06027 int gr_idx; 06028 boolean have_file_name_rec = FALSE; 06029 boolean have_rec = FALSE; 06030 char holding_pen[512]; 06031 int i; 06032 int line_num; 06033 int rec_type; 06034 char rec_type_str[3]; 06035 06036 06037 TRACE (Func_Entry, "cif_flush_include_recs", NULL); 06038 06039 fprintf(cif_tmp_file, "%d\n", EOF); 06040 rewind(cif_tmp_file); 06041 06042 end_stmt_line = global_to_local_line_number(stmt_start_line); 06043 file_id_list[0] = GL_CIF_FILE_ID(1); 06044 06045 while (fgets(generic_rec, 512, cif_tmp_file) != NULL && 06046 atoi(generic_rec) != EOF) { 06047 06048 # ifdef _DEBUG 06049 if (file_id_list_idx >= FILE_ID_LIST_SIZE - 1) { 06050 PRINTMSG(stmt_start_line, 1406, Internal, 1); 06051 } 06052 # endif 06053 06054 rec_type_str[0] = generic_rec[0]; 06055 06056 if (generic_rec[1] == EOI) { 06057 rec_type_str[1] = NULL_CHAR; 06058 } 06059 else { 06060 rec_type_str[1] = generic_rec[1]; 06061 rec_type_str[2] = NULL_CHAR; 06062 } 06063 06064 rec_type = atoi(rec_type_str); 06065 06066 switch (rec_type) { 06067 06068 case CIF_FILE: 06069 strcpy(holding_pen, generic_rec); 06070 have_file_name_rec = TRUE; 06071 break; 06072 06073 06074 case CIF_INCLUDE: 06075 06076 /* Start at the third character of the Include record and get the */ 06077 /* file id. Make sure the record belongs to either the current */ 06078 /* source file or any INCLUDE file that was opened while the */ 06079 /* current source file was being processed (this happens due to */ 06080 /* the lookahead in src_input.c). */ 06081 06082 buf[0] = generic_rec[2]; 06083 gr_idx = 3; 06084 i = 1; 06085 06086 while (generic_rec[gr_idx] != EOI) { 06087 buf[i++] = generic_rec[gr_idx++]; 06088 } 06089 06090 buf[i] = NULL_CHAR; 06091 file_id = atoi(buf); 06092 06093 for (i = file_id_list_idx; i >= 0; i--) { 06094 06095 if (file_id == file_id_list[i]) { 06096 break; 06097 } 06098 } 06099 06100 if (i < 0) { 06101 06102 /* Sanity check. The first non-File Name record had better be */ 06103 /* a Stmt Type record (if -Ca was specified) or an Include */ 06104 /* record (if -Ca was not specified). The file id might not */ 06105 /* be the same as for the program unit being compiled due to */ 06106 /* nesting of INCLUDE files and the way the source lines */ 06107 /* happen to lay out (all kinds of weirdness happens with */ 06108 /* source line lookahead). If it's file id is *not* the same */ 06109 /* as the program unit's file id, add it to the list so that */ 06110 /* it will act as another "parent" file id. */ 06111 06112 if (first_record) { 06113 file_id_list[++file_id_list_idx] = file_id; 06114 first_record = FALSE; 06115 } 06116 else { 06117 have_rec = TRUE; 06118 goto RECORDS_FOR_NEXT_UNIT; 06119 } 06120 } 06121 else if (i == 0) { 06122 06123 /* We now know that the Include record refers to a line that is*/ 06124 /* contained in the source file being compiled. Now need to */ 06125 /* see if it belongs to the current program unit. Get the line*/ 06126 /* number and compare to the line number of the last line of */ 06127 /* the current program unit. */ 06128 /* Note: When i > 0, it means the Include record belongs to */ 06129 /* an INCLUDE file. Checking the line number against the */ 06130 /* current program unit is meaningless. Just fall into the */ 06131 /* code that moves the record to the actual CIF. */ 06132 06133 ++gr_idx; 06134 buf[0] = generic_rec[gr_idx++]; 06135 i = 1; 06136 06137 while (generic_rec[gr_idx] != EOI) { 06138 buf[i++] = generic_rec[gr_idx++]; 06139 } 06140 06141 buf[i] = NULL_CHAR; 06142 line_num = atoi(buf); 06143 06144 if (line_num > end_stmt_line) { 06145 have_rec = TRUE; 06146 goto RECORDS_FOR_NEXT_UNIT; 06147 } 06148 } 06149 06150 if (have_file_name_rec) { 06151 fputs(holding_pen, cif_actual_file); 06152 have_file_name_rec = FALSE; 06153 } 06154 06155 fputs(generic_rec, cif_actual_file); 06156 06157 06158 /* The Include record had better be followed by a Source */ 06159 /* Position record. The Source Position record is also written */ 06160 /* to the actual CIF now. */ 06161 06162 if (fgets(generic_rec, 512, cif_tmp_file) != NULL && 06163 atoi(generic_rec) != EOF) { 06164 rec_type_str[0] = generic_rec[0]; 06165 06166 if (generic_rec[1] != EOI) { 06167 rec_type_str[1] = generic_rec[1]; 06168 rec_type_str[2] = NULL_CHAR; 06169 } 06170 else { 06171 PRINTMSG(end_stmt_line, 1148, Internal, 0); 06172 } 06173 06174 rec_type = atoi(rec_type_str); 06175 06176 if (rec_type == CIF_SRC_POS) { 06177 fputs(generic_rec, cif_actual_file); 06178 } 06179 else { 06180 PRINTMSG(end_stmt_line, 1148, Internal, 0); 06181 } 06182 06183 06184 /* Now get the file id for the INCLUDE file being opened. If */ 06185 /* it's already in the list, pop down to it. Otherwise, add */ 06186 /* it to the list. */ 06187 06188 gr_idx = 3; 06189 06190 while (generic_rec[gr_idx++] != EOI) { 06191 } 06192 06193 buf[0] = generic_rec[gr_idx++]; 06194 i = 1; 06195 06196 while (generic_rec[gr_idx] != EOI) { 06197 buf[i++] = generic_rec[gr_idx++]; 06198 } 06199 06200 buf[i] = NULL_CHAR; 06201 file_id = atoi(buf); 06202 06203 for (i = file_id_list_idx; i > 0; --i) { 06204 06205 if (file_id == file_id_list[i]) { 06206 break; 06207 } 06208 } 06209 06210 if (i > 0) { 06211 file_id_list_idx = i; 06212 } 06213 else { 06214 file_id_list[++file_id_list_idx] = file_id; 06215 } 06216 } 06217 else { 06218 PRINTMSG(end_stmt_line, 1148, Internal, 0); 06219 } 06220 06221 break; 06222 06223 06224 case CIF_MESSAGE: 06225 06226 /* Start at the fourth (gr_idx = 3) character of the Message */ 06227 /* record (which is the first character of the message type). */ 06228 /* Skip it. Skip the next field (the message number) as well. */ 06229 /* Get the file id and make sure the record belongs to either */ 06230 /* the current source file or any INCLUDE file that was opened */ 06231 /* while the current source file was being processed (this */ 06232 /* happens due to the lookahead in src_input.c). */ 06233 06234 gr_idx = 3; 06235 06236 while (generic_rec[gr_idx++] != EOI) { 06237 } 06238 06239 ++gr_idx; 06240 06241 while (generic_rec[gr_idx++] != EOI) { 06242 } 06243 06244 buf[0] = generic_rec[gr_idx++]; 06245 i = 1; 06246 06247 while (generic_rec[gr_idx] != EOI) { 06248 buf[i++] = generic_rec[gr_idx++]; 06249 } 06250 06251 buf[i] = NULL_CHAR; 06252 file_id = atoi(buf); 06253 06254 for (i = file_id_list_idx; i >= 0; i--) { 06255 06256 if (file_id == file_id_list[i]) { 06257 break; 06258 } 06259 } 06260 06261 if (i < 0) { 06262 have_rec = TRUE; 06263 goto RECORDS_FOR_NEXT_UNIT; 06264 } 06265 else if (i > 0) { 06266 06267 /* The Message record belongs to an INCLUDE file. Checking */ 06268 /* the line number against the current program unit is */ 06269 /* meaningless. Just move the record to the actual CIF. */ 06270 06271 fputs(generic_rec, cif_actual_file); 06272 break; 06273 } 06274 06275 06276 /* We now know that the Message record refers to a line that is */ 06277 /* contained in the source file being compiled. Now need to see */ 06278 /* if it belongs to the current program unit. Get the line number*/ 06279 /* and compare to the line number of the last line of the current */ 06280 /* program unit. */ 06281 06282 ++gr_idx; 06283 buf[0] = generic_rec[gr_idx++]; 06284 i = 1; 06285 06286 while (generic_rec[gr_idx] != EOI) { 06287 buf[i++] = generic_rec[gr_idx++]; 06288 } 06289 06290 buf[i] = NULL_CHAR; 06291 line_num = atoi(buf); 06292 06293 if (line_num <= end_stmt_line) { 06294 fputs(generic_rec, cif_actual_file); 06295 } 06296 else { 06297 have_rec = TRUE; 06298 goto RECORDS_FOR_NEXT_UNIT; 06299 } 06300 06301 break; 06302 06303 06304 case CIF_STMT_TYPE: 06305 06306 /* Start at the fourth (gr_idx = 3) character of the Stmt Type */ 06307 /* record (which is the first character of the stmt type). Skip */ 06308 /* it. Get the file id and make sure the record belongs to */ 06309 /* either the current source file or any INCLUDE file that was */ 06310 /* opened while the current source file was being processed */ 06311 /* (this happens due to the lookahead in src_input.c). */ 06312 06313 gr_idx = 3; 06314 06315 while (generic_rec[gr_idx++] != EOI) { 06316 } 06317 06318 buf[0] = generic_rec[gr_idx++]; 06319 i = 1; 06320 06321 while (generic_rec[gr_idx] != EOI) { 06322 buf[i++] = generic_rec[gr_idx++]; 06323 } 06324 06325 buf[i] = NULL_CHAR; 06326 file_id = atoi(buf); 06327 06328 for (i = file_id_list_idx; i >= 0; i--) { 06329 06330 if (file_id == file_id_list[i]) { 06331 break; 06332 } 06333 } 06334 06335 if (i < 0) { 06336 06337 /* Sanity check. The first non-File Name record had better be */ 06338 /* a Stmt Type record (if -Ca was specified) or an Include */ 06339 /* record (if -Ca was not specified). The file id might not */ 06340 /* be the same as for the program unit being compiled due to */ 06341 /* nesting of INCLUDE files and the way the source lines */ 06342 /* happen to lay out (all kinds of weirdness happens with */ 06343 /* source line lookahead). If it's file id is *not* the same */ 06344 /* as the program unit's file id, add it to the list so that */ 06345 /* it will act as another "parent" file id. */ 06346 06347 if (first_record) { 06348 file_id_list[++file_id_list_idx] = file_id; 06349 first_record = FALSE; 06350 } 06351 else { 06352 have_rec = TRUE; 06353 goto RECORDS_FOR_NEXT_UNIT; 06354 } 06355 } 06356 else if (i > 0) { 06357 06358 /* The Stmt Type record belongs to an INCLUDE file. Checking */ 06359 /* the line number against the current program unit is */ 06360 /* meaningless. Just move the record to the actual CIF. */ 06361 06362 fputs(generic_rec, cif_actual_file); 06363 break; 06364 } 06365 06366 06367 /* We now know that the Stmt Type record refers to a line that is */ 06368 /* contained in the source file being compiled. Now need to see */ 06369 /* if it belongs to the current program unit. Get the line number*/ 06370 /* and compare to the line number of the last line of the current */ 06371 /* program unit. */ 06372 06373 ++gr_idx; 06374 buf[0] = generic_rec[gr_idx++]; 06375 i = 1; 06376 06377 while (generic_rec[gr_idx] != EOI) { 06378 buf[i++] = generic_rec[gr_idx++]; 06379 } 06380 06381 buf[i] = NULL_CHAR; 06382 line_num = atoi(buf); 06383 06384 if (line_num < end_stmt_line) { 06385 fputs(generic_rec, cif_actual_file); 06386 } 06387 else { 06388 have_rec = TRUE; 06389 goto RECORDS_FOR_NEXT_UNIT; 06390 } 06391 06392 break; 06393 06394 06395 default: 06396 PRINTMSG(end_stmt_line, 179, Internal, 0, "cif_flush_include_recs"); 06397 } 06398 } 06399 06400 RECORDS_FOR_NEXT_UNIT: 06401 06402 if (have_rec || have_file_name_rec) { 06403 06404 if (! get_temp_file("w+", &aux_file, aux_file_name)) { 06405 PRINTMSG(stmt_start_line, 382, Log_Error, 0, "<aux CIF>"); 06406 perror("Reason"); 06407 goto EXIT; 06408 } 06409 06410 if (have_file_name_rec) { 06411 fputs(holding_pen, aux_file); 06412 } 06413 06414 if (have_rec) { 06415 fputs(generic_rec, aux_file); 06416 } 06417 06418 while (fgets(generic_rec, 512, cif_tmp_file) != NULL && 06419 atoi(generic_rec) != EOF) { 06420 fputs(generic_rec, aux_file); 06421 } 06422 06423 fprintf(aux_file, "%d\n", EOF); 06424 rewind(aux_file); 06425 rewind(cif_tmp_file); 06426 06427 while (fgets(generic_rec, 512, aux_file) != NULL && 06428 atoi(generic_rec) != EOF) { 06429 fputs(generic_rec, cif_tmp_file); 06430 } 06431 06432 fclose(aux_file); 06433 remove(aux_file_name); 06434 } 06435 else { 06436 06437 /* If there were no records in the CIF temp file or no records for the */ 06438 /* next program unit, rewind it so it's ready for the next program unit.*/ 06439 06440 rewind(cif_tmp_file); 06441 } 06442 06443 EXIT: 06444 06445 TRACE (Func_Entry, "cif_flush_include_recs", NULL); 06446 06447 return; 06448 06449 } /* cif_flush_include_recs */ 06450 06451 06452 /******************************************************************************\ 06453 |* *| 06454 |* Description: *| 06455 |* Called by main.c to close the CIF file. This procedure is used *| 06456 |* rather than just putting the code in main.c in order to isolate *| 06457 |* knowledge of the CIF file (no code other than code in this file need *| 06458 |* know about it). *| 06459 |* *| 06460 |* Input parameters: *| 06461 |* NONE *| 06462 |* *| 06463 |* Output parameters: *| 06464 |* NONE *| 06465 |* *| 06466 |* Returns: *| 06467 |* NOTHING *| 06468 |* *| 06469 \******************************************************************************/ 06470 06471 void close_cif() 06472 { 06473 06474 TRACE (Func_Entry, "close_cif", NULL); 06475 06476 fflush(c_i_f); 06477 if (c_i_f == cif_actual_file) { 06478 /* prevent closing the same file twice. Linux does not handle it */ 06479 cif_actual_file = NULL; 06480 } 06481 fclose(c_i_f); 06482 fclose(cif_tmp_file); 06483 remove(cif_tmp_file_name); 06484 06485 TRACE (Func_Exit, "close_cif", NULL); 06486 06487 } /* close_cif */ 06488 06489 06490 /******************************************************************************\ 06491 |* *| 06492 |* Description: *| 06493 |* This procedure is used to translate from our enum that represents a *| 06494 |* specific data type to the define constant value that libcif uses. *| 06495 |* *| 06496 |* Input parameters: *| 06497 |* data_type: The linear data type of the object or the CIF derived *| 06498 |* type id. Note: It's probably not very elegant to not *| 06499 |* linear_type_type for data_type but it really can't *| 06500 |* conveniently be used because sometimes it's the CIF *| 06501 |* derived type id that's being passed in. See, in *| 06502 |* particular, cif_call_site_rec and you will see why the *| 06503 |* linear type or Attr index can't always be passed to this *| 06504 |* routine (try the example CALL sub(SQRT(x)) ). *| 06505 |* *| 06506 |* Output parameters: *| 06507 |* NONE *| 06508 |* *| 06509 |* Returns: *| 06510 |* The integer value that libcif uses to represent the data type. *| 06511 |* *| 06512 \******************************************************************************/ 06513 06514 static int cif_data_type(int data_type) 06515 { 06516 int cif_value; 06517 06518 06519 TRACE (Func_Entry, "cif_data_type", NULL); 06520 06521 if (data_type > 100) { 06522 TRACE (Func_Exit, "cif_data_type", NULL); 06523 return(data_type); 06524 } 06525 06526 06527 switch (data_type) { 06528 06529 case Err_Res: 06530 cif_value = CIF_F90_DT_UNKNOWN; 06531 break; 06532 06533 case Short_Char_Const: 06534 cif_value = CIF_F90_DT_CHARACTER_1; 06535 break; 06536 06537 case Short_Typeless_Const: 06538 case Typeless_4: 06539 case Typeless_8: 06540 case Long_Typeless: 06541 06542 /* Need a new libcif define constant for this case. */ 06543 06544 cif_value = CIF_F90_DT_TYPELESS; 06545 break; 06546 06547 case Integer_1: 06548 cif_value = CIF_F90_DT_INTEGER_1; 06549 break; 06550 06551 case Integer_2: 06552 cif_value = CIF_F90_DT_INTEGER_2; 06553 break; 06554 06555 case Integer_4: 06556 cif_value = CIF_F90_DT_INTEGER_4; 06557 break; 06558 06559 case Integer_8: 06560 cif_value = CIF_F90_DT_INTEGER_8; 06561 break; 06562 06563 case Real_4: 06564 cif_value = CIF_F90_DT_REAL_4; 06565 break; 06566 06567 case Real_8: 06568 cif_value = CIF_F90_DT_REAL_8; 06569 break; 06570 06571 case Real_16: 06572 cif_value = CIF_F90_DT_REAL_16; 06573 break; 06574 06575 case Complex_4: 06576 cif_value = CIF_F90_DT_COMPLEX_4; 06577 break; 06578 06579 case Complex_8: 06580 cif_value = CIF_F90_DT_COMPLEX_8; 06581 break; 06582 06583 case Complex_16: 06584 cif_value = CIF_F90_DT_COMPLEX_16; 06585 break; 06586 06587 case CRI_Ptr_8: 06588 cif_value = CIF_F90_DT_FPTR; 06589 break; 06590 06591 case Logical_1: 06592 cif_value = CIF_F90_DT_LOGICAL_1; 06593 break; 06594 06595 case Logical_2: 06596 cif_value = CIF_F90_DT_LOGICAL_2; 06597 break; 06598 06599 case Logical_4: 06600 cif_value = CIF_F90_DT_LOGICAL_4; 06601 break; 06602 06603 case Logical_8: 06604 cif_value = CIF_F90_DT_LOGICAL_8; 06605 break; 06606 06607 case Character_1: 06608 cif_value = CIF_F90_DT_CHARACTER_1; 06609 break; 06610 06611 case Character_2: 06612 cif_value = CIF_F90_DT_CHARACTER_2; 06613 break; 06614 06615 case Character_4: 06616 cif_value = CIF_F90_DT_CHARACTER_4; 06617 break; 06618 06619 case CRI_Ch_Ptr_8: 06620 cif_value = CIF_F90_DT_FCPTR; 06621 break; 06622 06623 case Structure_Type: 06624 06625 /* Taken care of at the top of this routine. */ 06626 06627 PRINTMSG(stmt_start_line, 179, Internal, 0, 06628 "cif_data_type (Structure_Type)"); 06629 break; 06630 06631 case CRI_Parcel_Ptr_8: 06632 06633 /* Should never get here because there should be no user item that */ 06634 /* could have this type. Used for passing a procedure as an arg. */ 06635 06636 PRINTMSG(stmt_start_line, 179, Internal, 0, 06637 "cif_data_type (parcel ptr)"); 06638 } 06639 06640 TRACE (Func_Exit, "cif_data_type", NULL); 06641 06642 return(cif_value); 06643 06644 } /* cif_data_type */ 06645 06646 06647 /******************************************************************************\ 06648 |* *| 06649 |* Description: *| 06650 |* This procedure is used by call site semantics processing to output an *| 06651 |* Object record for a function result after all the characteristics *| 06652 |* about the function result have been resolved. *| 06653 |* *| 06654 |* Input parameters: *| 06655 |* rslt_idx : Attr index for the result of the specific function being *| 06656 |* called *| 06657 |* *| 06658 |* Output parameters: *| 06659 |* NONE *| 06660 |* *| 06661 |* Returns: *| 06662 |* NOTHING *| 06663 |* *| 06664 \******************************************************************************/ 06665 06666 void cif_object_rec_for_func_result(int attr_idx) 06667 06668 { 06669 int rslt_idx; 06670 boolean save_cif_done; 06671 boolean save_cif_done1; 06672 int save_reference; 06673 06674 06675 TRACE (Func_Entry, "cif_object_rec_for_func_result", NULL); 06676 06677 /* How this works: This is only for calls to specific intrinsics. */ 06678 /* First cif_call_site_rec is called. A cif rec is */ 06679 /* issued for the interface. symbol id's are */ 06680 /* assigned to the specific and the result. Then */ 06681 /* later on in processing from call_site_semantics */ 06682 /* this routine is called where the specific and */ 06683 /* the result records are issued. */ 06684 06685 /* We need to send the function attr through as well, because it will not */ 06686 /* be sent via the cif_send_attr mechanism because only the interface is */ 06687 /* in the symbol table and it is specially sent during cif_call_site */ 06688 /* Always send the function result Attr through even though its symbol id */ 06689 /* might already be nonzero and AT_CIF_DONE might already be TRUE because */ 06690 /* the Entry Point record generated for each intrinsic function in each */ 06691 /* CIF scope must have an associated Object record to pass on to CIF the */ 06692 /* function result type. For example, if a module contains several module */ 06693 /* procedures, each of which reference BIT_SIZE, each module procedure has */ 06694 /* its own Attr for BIT_SIZE but they all refer to the same function */ 06695 /* result Attr so we can't go by CIF_SYMBOL_ID being 0 in that function */ 06696 /* result Attr. */ 06697 06698 rslt_idx = ATP_RSLT_IDX(attr_idx); 06699 save_cif_done = AT_CIF_DONE(rslt_idx); 06700 save_cif_done1 = AT_CIF_DONE(attr_idx); 06701 save_reference = AT_REFERENCED(attr_idx); 06702 AT_REFERENCED(attr_idx) = Referenced; 06703 AT_CIF_DONE(rslt_idx) = FALSE; 06704 AT_CIF_DONE(attr_idx) = FALSE; 06705 cif_send_attr(attr_idx, NULL_IDX); 06706 cif_send_attr(rslt_idx, NULL_IDX); 06707 AT_CIF_DONE(rslt_idx) = save_cif_done; 06708 AT_CIF_DONE(attr_idx) = save_cif_done1; 06709 AT_REFERENCED(attr_idx) = save_reference; 06710 06711 TRACE (Func_Exit, "cif_object_rec_for_func_result", NULL); 06712 06713 return; 06714 06715 } /* cif_object_rec_for_func_result */ 06716 06717 /******************************************************************************\ 06718 |* *| 06719 |* Description: *| 06720 |* Process lists of attrs from the al table. *| 06721 |* *| 06722 |* Input parameters: *| 06723 |* al_idx : Attr list index to list to process. *| 06724 |* *| 06725 |* Output parameters: *| 06726 |* NONE *| 06727 |* *| 06728 |* Returns: *| 06729 |* NOTHING *| 06730 |* *| 06731 \******************************************************************************/ 06732 static void process_attr_list(int al_idx, 06733 boolean error_list) 06734 { 06735 int attr_idx; 06736 06737 06738 TRACE (Func_Entry, "process_attr_list", NULL); 06739 06740 /* Pgm_Unit Attr entries (among others) end up in the AL list. For */ 06741 /* reasons documented elsewhere in this file, Pgm_Unit Attr entries may */ 06742 /* need to be processed more than once so we can't go by the flag */ 06743 /* AT_CIF_DONE. However, by the time the AL is being scanned, */ 06744 /* processing for Pgm_Unit Attr entries should be essentially complete. */ 06745 /* Therefore, we can now go by AT_CIF_SYMBOL_ID to determine whether or */ 06746 /* not the Attr has been processed. If it has a symbol ID then we */ 06747 /* don't want to produce another Entry Point record for it. */ 06748 06749 /* The AL list also contains compiler temp Attr entries. Although */ 06750 /* cif_send_attr has a check to ignore these Attr entries (for */ 06751 /* recursive calls to cif_send_attr), we check for them here to avoid */ 06752 /* procedure call overhead. */ 06753 06754 06755 while (al_idx != NULL_IDX) { 06756 attr_idx = AL_ATTR_IDX(al_idx); 06757 06758 if (!error_list && 06759 AT_OBJ_CLASS(attr_idx) == Pgm_Unit && 06760 AT_CIF_SYMBOL_ID(attr_idx) != 0) { 06761 06762 /* Just want this to fall through to next AL list item. */ 06763 06764 } 06765 else if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 06766 ATD_CLASS(attr_idx) == Compiler_Tmp && 06767 ATD_TMP_NEEDS_CIF(attr_idx)) { 06768 06769 /* It's a compiler temp that got generated for a DATA or array */ 06770 /* constructor implied-DO variable, so produce an Object record */ 06771 /* for it. */ 06772 06773 cif_send_attr(attr_idx, NULL_IDX); 06774 } 06775 else if (! AT_COMPILER_GEND(attr_idx)) { 06776 cif_send_attr(attr_idx, NULL_IDX); 06777 } 06778 06779 al_idx = AL_NEXT_IDX(al_idx); 06780 } 06781 06782 TRACE (Func_Exit, "process_attr_list", NULL); 06783 06784 return; 06785 06786 } /* process_attr_list */