/*! @decl program load_module(string module_name)
*!
*! Load a binary module.
*!
*! This function loads a module written in C or some other language
*! into Pike. The module is initialized and any programs or constants
*! defined will immediately be available.
*!
*! When a module is loaded the C function @tt{pike_module_init()@} will
*! be called to initialize it. When Pike exits @tt{pike_module_exit()@}
*! will be called. These two functions @b{must@} be available in the module.
*!
*! @note
*! The current working directory is normally not searched for
*! dynamic modules. Please use @expr{"./name.so"@} instead of just
*! @expr{"name.so"@} to load modules from the current directory.
*/
void f_load_module(INT32 args)
{
extern int global_callable_flags;
void *module;
modfun init, exit;
struct module_list *new_module;
struct pike_string *module_name;
ONERROR err;
module_name = Pike_sp[-args].u.string;
if((Pike_sp[-args].type != T_STRING) ||
(module_name->size_shift) ||
string_has_null(module_name)) {
Pike_error("Bad argument 1 to load_module()\n");
}
{
struct module_list *mp;
for (mp = dynamic_module_list; mp; mp = mp->next)
if (mp->name == module_name && mp->module_prog) {
pop_n_elems(args);
ref_push_program(mp->module_prog);
return;
}
}
/* Removing RTLD_GLOBAL breaks some PiGTK themes - Hubbe */
/* Using RTLD_LAZY is faster, but makes it impossible to
* detect linking problems at runtime..
*/
module=dlopen(module_name->str,
RTLD_NOW /*|RTLD_GLOBAL*/ );
if(!module)
{
struct object *err_obj = low_clone (module_load_error_program);
#define LOADERR_STRUCT(OBJ) \
((struct module_load_error_struct *) (err_obj->storage + module_load_error_offset))
const char *err = dlerror();
if (err) {
if (err[strlen (err) - 1] == '\n')
push_string (make_shared_binary_string (err, strlen (err) - 1));
else
push_text (err);
}
else
push_constant_text ("Unknown reason");
add_ref (LOADERR_STRUCT (err_obj)->path = Pike_sp[-args - 1].u.string);
add_ref (LOADERR_STRUCT (err_obj)->reason = Pike_sp[-1].u.string);
if (Pike_sp[-args].u.string->len < 1024) {
throw_error_object (err_obj, "load_module", Pike_sp - args - 1, args,
"load_module(\"%s\") failed: %s\n",
module_name->str, Pike_sp[-1].u.string->str);
} else {
throw_error_object (err_obj, "load_module", Pike_sp - args - 1, args,
"load_module() failed: %s\n",
Pike_sp[-1].u.string->str);
}
}
#ifdef PIKE_DEBUG
{
struct module_list *mp;
for (mp = dynamic_module_list; mp; mp = mp->next)
if (mp->module == module && mp->module_prog) {
fprintf(stderr, "load_module(): Module loaded twice:\n"
"Old name: %s\n"
"New name: %s\n",
mp->name->str, module_name->str);
pop_n_elems(args);
ref_push_program(mp->module_prog);
return;
}
}
#endif /* PIKE_DEBUG */
init = CAST_TO_FUN(dlsym(module, "pike_module_init"));
if (!init) {
init = CAST_TO_FUN(dlsym(module, "_pike_module_init"));
if (!init) {
dlclose(module);
Pike_error("pike_module_init missing in dynamic module \"%S\".\n",
module_name);
}
}
exit = CAST_TO_FUN(dlsym(module, "pike_module_exit"));
if (!exit) {
exit = CAST_TO_FUN(dlsym(module, "_pike_module_exit"));
if (!exit) {
dlclose(module);
Pike_error("pike_module_exit missing in dynamic module \"%S\".\n",
module_name);
}
}
#if defined(__NT__) && defined(_M_IA64)
{
fprintf(stderr, "pike_module_init: 0x%p\n"
" func: 0x%p\n"
" gp: 0x%p\n",
init, ((void **)init)[0], ((void **)init)[1]);
fprintf(stderr, "pike_module_exit: 0x%p\n"
" func: 0x%p\n"
" gp: 0x%p\n",
exit, ((void **)exit)[0], ((void **)exit)[1]);
}
#endif /* __NT__ && _M_IA64 */
new_module=ALLOC_STRUCT(module_list);
new_module->next=dynamic_module_list;
dynamic_module_list=new_module;
new_module->module=module;
copy_shared_string(new_module->name, Pike_sp[-args].u.string);
new_module->module_prog = NULL;
new_module->init=init;
new_module->exit=exit;
enter_compiler(new_module->name, 1);
start_new_program();
global_callable_flags|=CALLABLE_DYNAMIC;
#ifdef PIKE_DEBUG
{ struct svalue *save_sp=Pike_sp;
#endif
SET_ONERROR(err, cleanup_compilation, NULL);
#if defined(__NT__) && defined(_M_IA64)
fprintf(stderr, "Calling pike_module_init()...\n");
#endif /* __NT__ && _M_IA64 */
(*(modfun)init)();
#if defined(__NT__) && defined(_M_IA64)
fprintf(stderr, "pike_module_init() done.\n");
#endif /* __NT__ && _M_IA64 */
UNSET_ONERROR(err);
#ifdef PIKE_DEBUG
if(Pike_sp != save_sp)
Pike_fatal("load_module(%s) left %ld droppings on stack!\n",
module_name->str,
PTRDIFF_T_TO_LONG(Pike_sp - save_sp));
}
#endif
pop_n_elems(args);
{
struct program *p = end_program();
exit_compiler();
if (p) {
if (
#if 0
p->num_identifier_references
#else /* !0 */
1
#endif /* 0 */
) {
push_program(p);
add_ref(new_module->module_prog = Pike_sp[-1].u.program);
} else {
/* No identifier references -- Disabled module. */
free_program(p);
push_undefined();
}
} else {
/* Initialization failed. */
new_module->exit();
dlclose(module);
dynamic_module_list = new_module->next;
free_string(new_module->name);
free(new_module);
Pike_error("Failed to initialize dynamic module \"%S\".\n",
module_name);
}
}
}
static void check_license (void)
{
# define CRAY_LM_NQE 1
# define CRAY_LM_DPE 2
# define CRAY_LM_F90E 3
# define LM_NOWAIT 0
# define LM_WAIT 1
extern int cray_lm_checkout(int, char *, int, int, char *, double);
int ignore = 0;
double version = 1.0;
TRACE (Func_Entry, "check_license", NULL);
# if defined(_TARGET_OS_UNICOS) || defined(_TARGET_OS_MAX)
if (cray_lm_checkout(CRAY_LM_DPE, "", LM_NOWAIT, ignore, "", version)) {
# else
if (cray_lm_checkout(CRAY_LM_F90E, "", LM_NOWAIT, ignore, "", version)) {
# endif
/* This compiler is not licensed on this hardware. */
PRINTMSG(0, 631, Log_Error, 0);
exit_compiler(RC_USER_ERROR);
}
TRACE (Func_Exit, "check_license", NULL);
return;
} /* check_license */
# endif
/******************************************************************************\
|* *|
|* Description: *|
|* Check defines compatibility. *|
|* *|
|* Input parameters: *|
|* NONE *|
|* *|
|* Output parameters: *|
|* NONE *|
|* *|
|* Returns: *|
|* NOTHING *|
|* *|
\******************************************************************************/
static void check_defines_compatibility(void)
{
TRACE (Func_Entry, "check_defines_compatibility", NULL);
/* Make sure that both pairs of a defines are not set. */
# if defined(_MODULE_TO_DOT_o) && defined(_MODULE_TO_DOT_M)
PRINTMSG(1, 1114, Internal, 0,
"_MODULE_TO_DOT_o",
"_MODULE_TO_DOT_M");
# endif
# if defined(_HEAP_REQUEST_IN_BYTES) && defined(_HEAP_REQUEST_IN_WORDS)
PRINTMSG(1, 1114, Internal, 0,
"_HEAP_REQUEST_IN_BYTES",
"_HEAP_REQUEST_IN_WORDS");
# endif
# if defined(_HOST32) && defined(_HOST64)
PRINTMSG(1, 1114, Internal, 0,
"_HOST32",
"_HOST64");
# endif
# if defined(_TARGET32) && defined(_TARGET64)
PRINTMSG(1, 1114, Internal, 0,
"_TARGET32",
"_TARGET64");
# endif
# if defined(_TARGET_WORD_ADDRESS) && defined(_TARGET_BYTE_ADDRESS)
PRINTMSG(1, 1114, Internal, 0,
"_TARGET_WORD_ADDRESS",
"_TARGET_BYTE_ADDRESS");
# endif
# if 0
/* Make sure at least one defines of a pair is set. */
# if !defined(_MODULE_TO_DOT_o) && !defined(_MODULE_TO_DOT_M)
if (!on_off_flags.module_to_mod) { /* Need -em or one of these defined */
PRINTMSG(1, 1116, Internal, 0,
"_MODULE_TO_DOT_o",
"_MODULE_TO_DOT_M");
}
# endif
# endif
# if !defined(_HEAP_REQUEST_IN_BYTES) && !defined(_HEAP_REQUEST_IN_WORDS)
PRINTMSG(1, 1116, Internal, 0,
"_HEAP_REQUEST_IN_BYTES",
"_HEAP_REQUEST_IN_WORDS");
# endif
# if !defined(_HOST32) && !defined(_HOST64)
PRINTMSG(1, 1116, Internal, 0,
"_HOST32",
"_HOST64");
# endif
# if !defined(_TARGET32) && !defined(_TARGET64)
PRINTMSG(1, 1116, Internal, 0,
"_TARGET32",
"_TARGET64");
# endif
# if !defined(_TARGET_WORD_ADDRESS) && !defined(_TARGET_BYTE_ADDRESS)
PRINTMSG(1, 1116, Internal, 0,
"_TARGET_WORD_ADDRESS",
"_TARGET_BYTE_ADDRESS");
# endif
TRACE (Func_Exit, "check_defines_compatibility", NULL);
return;
} /* check_defines_compatibility */
static void get_machine_chars (void)
{
# if defined(_TARGET_OS_UNICOS) || defined(_TARGET_OS_MAX)
# if defined(_GETPMC_AVAILABLE)
extern int GETPMC(long *, char *); /* UNICOS library routine */
# else
int idx;
char *name;
# endif
TRACE (Func_Entry, "get_machine_chars", NULL);
# if defined(_GETPMC_AVAILABLE)
/* Use target_machine to get information about the host machine. */
/* This information is used by ntr_const_tbl to choose the algorithm */
/* it uses to convert and store floating point constants. */
if (GETPMC (target_machine.mc_tbl, "host") == 0) {
PRINTMSG (0, 584, Log_Error, 0, "GETPMC");
}
host_ieee = target_machine.fld.mcieee;
/* Set machine characteristics table based on the target environment. */
/* The target environment is either the machine the compiler is running */
/* on or the machine specified by the TARGET environment variable. */
if (GETPMC (target_machine.mc_tbl, "target") == 0) {
PRINTMSG (0, 584, Log_Error, 0, "GETPMC");
}
# else
name = getenv("TARGET");
if (name == NULL) {
PRINTMSG(0, 1052, Log_Error, 0);
TRACE (Func_Exit, "get_machine_chars", NULL);
exit_compiler(RC_USER_ERROR);
}
else {
strcpy(target_machine.fld.mcpmt, name);
/* GETPMC translates the target machine name to upper case. */
for (idx = 0; idx <= strlen(target_machine.fld.mcpmt); ++idx) {
target_machine.fld.mcpmt[idx] = toupper(target_machine.fld.mcpmt[idx]);
}
}
# endif
TRACE (Func_Exit, "get_machine_chars", NULL);
# endif
return;
} /* get_machine_chars */
static void init_compiler (int argc,
char *argv[])
{
extern void init_lex (void);
extern void init_msg_processing (char *[]);
extern void init_src_input (void);
extern void init_type (void);
extern void process_cmd_line (int, char *[]);
extern void init_cond_comp(void);
extern void enter_predefined_macros(void);
extern void init_parse_prog_unit(void);
extern void init_PDGCS (void);
extern void set_up_token_tables(void);
extern void sgi_cmd_line(int *argc, char **argv[]);
extern char *operator_str[];
extern void verify_semantic_tbls(void);
int idx;
TRACE (Func_Entry, "init_compiler", NULL);
init_date_time_info (); /* set compilation data and time */
init_msg_processing (argv); /* initialize for messages. Must */
/* preceed process_cmd_line. */
# ifdef _DEBUG
check_defines_compatibility(); /* Is the compiler built correctly? */
check_enums_for_change(); /* Some enums must not be changed. */
# endif
# if 0
check_license();
# endif
/* allocate memory for data structures required across compilation units. */
/* These must preceed process_cmd_line. */
TBL_ALLOC (global_line_tbl);
TBL_ALLOC (global_name_tbl);
TBL_ALLOC (global_attr_tbl);
TBL_ALLOC (global_type_tbl);
TBL_ALLOC (global_bounds_tbl);
TBL_ALLOC (global_ir_tbl);
TBL_ALLOC (global_ir_list_tbl);
TBL_ALLOC (global_sh_tbl);
TBL_ALLOC (file_path_tbl);
TBL_ALLOC (str_pool);
init_release_level (); /* Set up release_level from system */
str_pool[0].name_long = 0;
str_pool[1].name_long = 0;
str_pool[2].name_long = LARGE_WORD_FOR_TBL_SRCH;
str_pool_idx = 2;
TBL_REALLOC_CK(global_name_tbl, 2);
CLEAR_TBL_NTRY(global_name_tbl, 1);
CLEAR_TBL_NTRY(global_name_tbl, 2);
GN_NAME_IDX(1) = 1;
GN_NAME_LEN(1) = HOST_BYTES_PER_WORD;
GN_NAME_IDX(2) = 2;
GN_NAME_LEN(2) = HOST_BYTES_PER_WORD;
/* Initialize the bounds table for deferred shape arrays */
TBL_REALLOC_CK(global_bounds_tbl, 7);
for (idx = BD_DEFERRED_1_IDX; idx <= BD_DEFERRED_7_IDX; idx++) {
CLEAR_TBL_NTRY(global_bounds_tbl, idx);
GB_ARRAY_CLASS(idx) = Deferred_Shape;
GB_RANK(idx) = idx;
}
/* Initialize the conditional compilation tables. It must be done before */
/* the command line processing because of the -D and -U options. */
init_cond_comp ();
get_machine_chars();
set_up_token_tables();
/* The following routines sets things such as target_ieee, target_triton */
/* two_word_fcd, word_byte_size ect... */
set_compile_info_for_target();
comp_phase = Cmdline_Parsing;
cif_name[0] = NULL_CHAR;
assembly_listing_file[0] = NULL_CHAR;
debug_file_name[0] = NULL_CHAR;
# if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX))
/* sgi_cmd_line does some option manipulation, process SGI specific */
/* command line options, and strips out things that the front-end doesn't */
/* need to see. */
sgi_cmd_line (&argc,&argv);
# endif
process_cmd_line (argc, argv); /* pass input args */
# if defined(_INTEGER_1_AND_2)
if (on_off_flags.integer_1_and_2) {
bit_size_tbl[Integer_1] = 8;
bit_size_tbl[Integer_2] = 16;
bit_size_tbl[Logical_1] = 8;
bit_size_tbl[Logical_2] = 16;
storage_bit_size_tbl[Integer_1] = 8;
storage_bit_size_tbl[Integer_2] = 16;
storage_bit_size_tbl[Logical_1] = 8;
storage_bit_size_tbl[Logical_2] = 16;
storage_bit_prec_tbl[Integer_1] = 8;
storage_bit_prec_tbl[Integer_2] = 16;
storage_bit_prec_tbl[Logical_1] = 8;
storage_bit_prec_tbl[Logical_2] = 16;
stride_mult_unit_in_bits[Integer_1] = 8;
stride_mult_unit_in_bits[Integer_2] = 16;
stride_mult_unit_in_bits[Logical_1] = 8;
stride_mult_unit_in_bits[Logical_2] = 16;
linear_to_arith[Integer_1] = AR_Int_8_S;
linear_to_arith[Integer_2] = AR_Int_16_S;
input_arith_type[Integer_1] = AR_Int_8_U;
input_arith_type[Integer_2] = AR_Int_16_U;
strcpy(arith_type_string[Integer_1], "AR_Int_8_U");
strcpy(arith_type_string[Integer_2], "AR_Int_16_U");
}
# endif
comp_phase = Pass1_Parsing;
/* only -V info requested */
if (argc == 2 && cmd_line_flags.verify_option) {
print_id_line();
exit_compiler(RC_OKAY);
}
if (num_errors != 0) { /* command line errors */
PRINTMSG(0, 912, Log_Summary, 0, num_errors);
exit_compiler(RC_USER_ERROR);
}
/* Call init_cif even if the user did NOT request Compiler Information */
/* File (CIF) output because the CIF is used for messaging. */
init_cif(comp_date_time, release_level);
some_scp_in_err = FALSE;
clearing_blk_stk = FALSE;
init_type();
make_table_changes ();
init_sytb (); /* Must be before src_input for err msgs */
/* Enter conditional compilation predefined macros. This must happen */
/* after process_cmd_line because it calls GETPMC (and the information */
/* from GETPMC is needed to set the predefined macros that depend on the */
/* target machine). This call must also happen after target_triton and */
/* target_ieee have been set so that we can get _CRAYIEEE set correctly. */
/* And finally, this call must come before init_src_input because that */
/* procedure gets the first source line - which could be a conditional */
/* compilation directive. */
enter_predefined_macros();
/* Must do the first call here so that tables needed by conditional */
/* compilation are set up. */
init_parse_prog_unit();
init_src_input();
if (on_off_flags.preprocess_only) {
preprocess_only_driver();
issue_deferred_msgs();
TRACE (Func_Exit, "init_compiler", NULL);
return;
}
init_lex ();
max_field_len = (long) sbrk(0); /* Keep track of memory usage */
# if defined(_HOST_OS_MAX)
max_field_len &= (1 << 32) - 1;
# endif
/* Pathological case: The file is empty. At least an END statement must */
/* be present to constitute a valid Fortran program. */
if (LA_CH_CLASS == Ch_Class_EOF) {
PRINTMSG(0, 1391, Log_Warning, 0, src_file);
issue_deferred_msgs();
}
# ifdef _NAME_SUBSTITUTION_INLINING
if (!dump_flags.preinline)
# endif
init_PDGCS();
# ifdef _DEBUG
verify_semantic_tbls(); /* Make sure flags and messages agree. */
if (strcmp(operator_str[The_Last_Opr], "The_Last_Opr") != 0) {
PRINTMSG(1, 689, Internal, 0);
}
# endif
TRACE (Func_Exit, "init_compiler", NULL);
return;
} /* init_compiler */
int main (int argc,
char *argv[])
# endif
{
int column_num;
long field_len;
int line_num;
char *msg_name;
int save_statement_number = 0;
# if (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
double end_time;
double start_time;
/* char time[20]; */
double total_cpu_time;
struct rusage ru;
# else
# if !defined(_HOST_OS_UNICOS)
long end_clock;
# endif
float end_time;
float start_time;
float total_cpu_time;
# endif
# if defined(_HOST_OS_UNICOS) && defined(_DEBUG)
lowmem_check();
# endif
# if defined(_TARGET32) && defined(_DEBUG)
setbuf(stdout, NULL);
setbuf(stderr, NULL);
# endif
# if defined(_HOST_OS_UNICOS)
/* Lots of start up - ignore first call. See the comment block that */
/* precedes procedure cif_summary_rec in fecif.c for a discussion of the */
/* timing methods used by the different platforms. */
SECOND(&start_time);
/* M_LOWFIT will eventually be in malloc.h. */
/* When it is remove this definition. */
# define M_LOWFIT 0107 /* Use lowest-fit algorithm for allocation. */
mallopt(M_LOWFIT, 1);
# elif defined(_HOST_OS_MAX)
/* Use clock() on MPP's (in particular T3E's) because at the time this */
/* change was made, neither SECOND() nor SECONDR() worked on T3E's. */
/* LRR 4 Mar 1997 */
clock();
start_time = 0;
/* M_LOWFIT will eventually be in malloc.h. */
/* When it is remove this definition. */
# define M_LOWFIT 0107 /* Use lowest-fit algorithm for allocation. */
mallopt(M_LOWFIT, 1);
# elif defined(_HOST_OS_SOLARIS)
/* clock() is only semi-useful on a Sun because it rolls over in just over */
/* 2147 seconds (about 36 minutes). So on a Sun, we use clock() and */
/* time() both. If elapsed time <= 2147 seconds, the accounting info will */
/* show milliseconds (from clock()), else it will show seconds (because */
/* that is the accuracy of time()). This resolution should be good enough */
/* for a compilation exceeding 36 minutes. */
start_time = (float) time(NULL);
clock();
# elif (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
getrusage (RUSAGE_SELF, &ru);
start_time = (double) ru.ru_utime.tv_sec +
(double) ru.ru_utime.tv_usec * 1e-6 +
(double) ru.ru_stime.tv_sec +
(double) ru.ru_stime.tv_usec * 1e-6;
# else
start_time = 0;
# endif
comp_phase = Pass1_Parsing;
stmt_start_line = 1; /* Set in case mem problems */
init_compiler(argc, argv); /* init and process cmd line */
if (on_off_flags.preprocess_only) {
goto PREPROCESS_ONLY_SKIP;
}
stmt_start_line = 0;
while (LA_CH_CLASS != Ch_Class_EOF) {
comp_phase = Pass1_Parsing;
num_prog_unit_errors = 0; /* Accum errs for pgm unit */
OUTPUT_PASS_HEADER(Syntax_Pass);
if (save_statement_number != 0) {
statement_number = save_statement_number;
}
parse_prog_unit();
save_statement_number = statement_number;
if (LA_CH_CLASS == Ch_Class_EOF) {
issue_deferred_msgs();
}
/* get current field length and save largest value */
field_len = (long) sbrk(0);
# if defined(_HOST_OS_MAX)
field_len &= (1 << 32) - 1;
# endif
if (field_len > max_field_len) { /* Max set in init_compiler */
max_field_len = field_len; /* Track max usage */
}
PRINT_IR_TBL; /* If -u ir and DEBUG compiler, print ir. */
OUTPUT_PASS_HEADER(Semantics_Pass);
semantics_pass_driver(); /* PASS 2 */
if (SCP_IN_ERR(curr_scp_idx)) {
some_scp_in_err = TRUE;
}
PRINT_ALL_SYM_TBLS; /* If debug print -u options */
PRINT_FORTRAN_OUT; /* Print ir in a fortran format */
line_num = SH_GLB_LINE(SCP_LAST_SH_IDX(curr_scp_idx));
column_num = SH_COL_NUM(SCP_LAST_SH_IDX(curr_scp_idx));
if (num_prog_unit_errors == 0) {
if (opt_flags.inline_lvl > Inline_Lvl_0) {
comp_phase = Inlining;
inline_processing(SCP_FIRST_SH_IDX(curr_scp_idx));
PRINT_IR_TBL3;
}
}
insert_global_directives = TRUE;
comp_phase = Pdg_Conversion;
if (dump_flags.preinline) { /* Do not do a full compile */
if (ATP_PGM_UNIT(SCP_ATTR_IDX(MAIN_SCP_IDX)) == Module ||
ATP_PGM_UNIT(SCP_ATTR_IDX(MAIN_SCP_IDX)) == Function ||
ATP_PGM_UNIT(SCP_ATTR_IDX(MAIN_SCP_IDX)) == Subroutine) {
curr_scp_idx = MAIN_SCP_IDX;
#ifdef KEY /* Bug 3477 */
if (create_mod_info_file()) { /* Creates a name for the file. */
create_mod_info_tbl(); /* Creates the table. */
output_mod_info_file(); /* Writes the table. */
}
#else
create_mod_info_file(); /* Creates a name for the file. */
create_mod_info_tbl(); /* Creates the table. */
output_mod_info_file(); /* Writes the table. */
#endif /* KEY Bug 3477 */
free_tables(); /* Frees the tables. */
}
}
else {
#ifdef KEY /* Bug 3477 */
int do_output_file = FALSE;
#endif /* KEY Bug 3477 */
if (ATP_PGM_UNIT(SCP_ATTR_IDX(MAIN_SCP_IDX)) == Module) {
#ifdef KEY /* Bug 3477 */
do_output_file = create_mod_info_file(); /* Creates a name for the file. */
#else
create_mod_info_file(); /* Creates a name for the file. */
#endif /* KEY Bug 3477 */
}
if (num_prog_unit_errors == 0 && (binary_output || assembly_output)) {
cvrt_to_pdg(compiler_gen_date);
}
else if (ATP_PGM_UNIT(SCP_ATTR_IDX(MAIN_SCP_IDX)) == Module) {
if (!SCP_IN_ERR(MAIN_SCP_IDX)) {
curr_scp_idx = MAIN_SCP_IDX;
#ifdef KEY /* Bug 3477 */
if (do_output_file) {
create_mod_info_tbl(); /* Creates the table. */
output_mod_info_file(); /* Writes the table. */
}
#else
create_mod_info_tbl(); /* Creates the table. */
output_mod_info_file(); /* Writes the table. */
#endif /* KEY Bug 3477 */
}
free_tables(); /* Frees the tables. */
}
else {
free_tables(); /* Frees the tables. */
}
}
/* ALERT - At this point, the symbol tables are invalid. */
/* Spit out the End Unit for the current program unit. The End Unit */
/* is needed if the Compiler Information File (CIF) is being produced */
/* and for the buffered message file. */
stmt_start_line = line_num;
stmt_start_col = column_num;
if (scp_tbl == NULL_IDX) { /* Table has been freed. */
cif_end_unit_rec(program_unit_name);
}
else {
cif_end_unit_rec(AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));
}
} /* while */
clean_up_module_files();
# ifdef _NAME_SUBSTITUTION_INLINING
if (!dump_flags.preinline)
# endif
terminate_PDGCS();
PRINT_GL_TBL; /* Prints to debug_file ifdef _DEBUG and -u gl */
PRINT_GN_TBL; /* Prints to debug_file ifdef _DEBUG and -u gn */
PREPROCESS_ONLY_SKIP:
# if defined(_HOST_OS_UNICOS)
SECOND(&end_time);
# elif defined(_HOST_OS_MAX)
end_clock = clock();
end_time = 0;
# elif defined(_HOST_OS_SOLARIS)
end_time = (float) time(NULL);
end_clock = clock();
# elif (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
getrusage(RUSAGE_SELF, &ru);
end_time = (double) ru.ru_utime.tv_sec +
(double) ru.ru_utime.tv_usec * 1e-6 +
(double) ru.ru_stime.tv_sec +
(double) ru.ru_stime.tv_usec * 1e-6;
# else
end_time = 0;
# endif
total_cpu_time = end_time - start_time;
if (cif_need_unit_rec && cif_first_pgm_unit) {
/* Catastrophic errors, like a free source form program was compiled */
/* in fixed source form mode, so no Unit record was output. Output */
/* enough records to keep libcif tools happy. This routine needs to be */
/* called whether or not a CIF is being written because the buffered */
/* message file also must have the correct format. */
cif_fake_a_unit();
}
/* CAUTION: The following code assumes that non-Cray platforms measure */
/* memory usage in terms of bytes and that there are 4 bytes per word. */
cif_summary_rec(release_level,
compiler_gen_date,
compiler_gen_time,
total_cpu_time,
# if defined(_HOST_OS_UNICOS)
(long) 0,
(some_scp_in_err) ? -3 : max_field_len);
# elif defined(_HOST_OS_MAX)
end_clock,
(some_scp_in_err) ? -3 : max_field_len);
# elif (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
(long) 0,
(some_scp_in_err) ? -3 : max_field_len/4);
# else /* defined(_HOST_OS_SOLARIS) */
end_clock,
(some_scp_in_err) ? -3 : max_field_len/4);
# endif
/* Output compilation summary info if the -V option was specified on the */
/* command line. Also, issue the summary information if any messages were */
/* actually issued. */
if (cmd_line_flags.verify_option ||
num_errors > 0 ||
num_warnings > 0 ||
num_cautions > 0 ||
num_notes > 0 ||
num_comments > 0 ||
num_ansi > 0 ||
(num_optz_msgs > 0 && opt_flags.msgs)) {
print_buffered_messages();
print_id_line();
/* Output the summary lines. The compilation time is in seconds. */
/* CAUTION: The following non-Cray code assumes a 32-bit word. */
# if defined(_HOST_OS_UNICOS)
PRINTMSG (0, 104, Log_Summary, 0, (double) total_cpu_time);
msg_name = "cf90";
# elif defined(_HOST_OS_MAX)
PRINTMSG (0, 104, Log_Summary, 0, (double) end_clock/1000000.0);
msg_name = "cf90";
# elif defined(_HOST_OS_LINUX)
msg_name = PSC_NAME_PREFIX "f95";
# elif (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
/* IRIX cannot handle the int to float change necessary to get the */
/* time printed correctly, so we'll convert it to a character string */
/* and use a different message. */
/* */
/* LRR 4/28/97 In an email message from Rich Shapiro to me, he stated */
/* he did not want this line in the summary lines. */
/* sprintf(time, "%-1.2f", (double) total_cpu_time);
PRINTMSG (0, 1310, Log_Summary, 0, time); */
msg_name = "cf90";
# elif defined(_HOST_OS_SOLARIS)
PRINTMSG (0, 104, Log_Summary, 0,
(total_cpu_time <= 2147.0) ? (float) end_clock/1000000.0 :
(float) total_cpu_time);
msg_name = "cf90";
# endif
/* Maximum field length (maximum amount of memory used) in words */
/* (decimal). */
/* CAUTION: Non-Cray platforms are assumed to measure memory usage in */
/* bytes and we assume 4 bytes per word. */
# if defined(_HOST_OS_UNICOS)
PRINTMSG (0, 105, Log_Summary, 0, max_field_len);
# elif ! (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
/* LRR 4/28/97 In an email message from Rich Shapiro to me, he stated */
/* he did not want this line in the summary lines. */
PRINTMSG (0, 105, Log_Summary, 0, max_field_len/4);
# endif
/* Number of source lines compiled. */
# if (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX)) && !defined(_TARGET_SV2)
PRINTMSG (0, 1401, Log_Summary, 0, --curr_glb_line);
# else
PRINTMSG (0, 106, Log_Summary, 0, --curr_glb_line);
# endif
/* Number of messages issued. */
# if (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX)) && !defined(_TARGET_SV2)
PRINTMSG (0, 1403, Log_Summary, 0,
num_errors,
num_warnings,
(opt_flags.msgs == 0) ?
(num_cautions + num_notes + num_comments) :
(num_cautions + num_notes + num_comments + num_optz_msgs),
num_ansi);
# else
PRINTMSG (0, 107, Log_Summary, 0,
num_errors,
num_warnings,
(opt_flags.msgs == 0) ?
(num_cautions + num_notes + num_comments) :
(num_cautions + num_notes + num_comments + num_optz_msgs),
num_ansi);
/* Code: in words; data: in words. */
/* LRR 4/28/97 In an email message from Rich Shapiro to me, he stated */
/* he did not want this line in the summary lines. */
# if !defined(_TARGET_SV2) /* Prints blank for sv2 right now. */
PRINTMSG (0, 108, Log_Summary, 0, code_size, data_size);
# endif
# endif
if (num_errors > 0 ||
num_warnings > 0 ||
num_cautions > 0 ||
num_notes > 0 ||
num_comments > 0 ||
num_ansi > 0 ||
(num_optz_msgs > 0 && opt_flags.msgs)) {
PRINTMSG (0, 1636, Log_Summary, 0, msg_name, msg_name);
}
} /* End of summary printing. */
# ifdef _DEBUG
/* Get memory usage reports for these global tables. */
final_src_input();
MEM_REPORT(file_path_tbl);
MEM_REPORT(global_attr_tbl);
MEM_REPORT(global_bounds_tbl);
MEM_REPORT(global_line_tbl);
MEM_REPORT(global_name_tbl);
MEM_REPORT(global_type_tbl);
MEM_REPORT(str_pool);
# endif
exit_compiler ((num_errors == 0) ? RC_OKAY : RC_USER_ERROR);
} /* main */
