home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
FTNCHEK2.ZIP
/
SOURCE
/
PRSYMTAB.C
< prev
next >
Wrap
C/C++ Source or Header
|
1992-09-19
|
49KB
|
1,839 lines
/* prsymtab.c:
Routines associated with printing of symbol table info
Copyright (C) 1992 by Robert K. Moniot.
This program is free software. Permission is granted to
modify it and/or redistribute it, retaining this notice.
No guarantees accompany this software.
Shared functions defined:
arg_array_cmp() Compares subprogram calls with defns.
check_arglists() Scans global symbol table for subprograms
and finds subprogram defn if it exists.
check_comlists() Scans global symbol table for common blocks.
com_cmp_strict() Compares lists of common variables.
debug_symtabs() Prints debugging info about symbol tables.
print_loc_symbols(curmodhash) Prints local symtab info.
Private functions defined:
check_mixed_common() checks common for nonportable mixed type
sort_symbols() Sorts the list of names of a given category.
swap_symptrs() Swaps a pair of pointers.
check_flags() Outputs messages about used-before-set etc.
print_symbols(sym_list,n,do_types) Prints symbol lists.
print_variables(sym_list,n) Prints variable symbol table
*/
#include <stdio.h>
#include <ctype.h>
#include <string.h>
#include "ftnchek.h"
#include "symtab.h"
PRIVATE int
has_nonalnum();
PRIVATE unsigned
find_sixclashes(), print_variables(), print_symbols();
PRIVATE void
swap_symptrs(), sort_symbols(), check_flags(), check_mixed_common(),
com_cmp_lax(),com_cmp_strict(), arg_array_cmp(),
print_tokenlist(), visit_child(), sort_child_list();
/* Shorthand for check control settings */
#define check_array_dims (array_arg_check&01) /* levels 1 and 3 */
#define check_array_size (array_arg_check&02) /* levels 2 and 3 */
#define check_set_used (usage_check&01) /* levels 1 and 3 */
#define check_unused (usage_check&02) /* levels 2 and 3 */
#define pluralize(n) ((n)==1? "":"s") /* singular/plural suffix for n */
#define CMP_ERR_LIMIT 3 /* stop printing errors after this many */
PRIVATE void
arg_array_cmp(name,args1,args2)
/* Compares subprogram calls with definition */
char *name;
ArgListHeader *args1, *args2;
{
int i,
typerr = 0,
usage_err = 0;
int n,
n1 = args1->numargs,
n2 = args2->numargs;
ArgListElement *a1 = args1->arg_array,
*a2 = args2->arg_array;
n = (n1 > n2) ? n2: n1; /* n = min(n1,n2) */
if (n1 != n2){
fprintf(list_fd,"\nSubprogram %s: varying number of arguments:",name);
fprintf(list_fd,"\n\t%s with %d argument%s in module %s line %u file %s",
args1->is_defn? "Defined":"Invoked",
n1,pluralize(n1),
args1->module->name,
args1->line_num,
args1->filename);
fprintf(list_fd,"\n\t%s with %d argument%s in module %s line %u file %s",
args2->is_defn? "Defined":"Invoked",
n2,pluralize(n2),
args2->module->name,
args2->line_num,
args2->filename);
}
{ /* Look for type mismatches */
typerr = 0;
for (i=0; i<n; i++) {
if(a1[i].type != a2[i].type){
int t1 = datatype_of(a1[i].type),
t2 = datatype_of(a2[i].type);
/* Allow hollerith to match integer or logical */
if( (t1 == type_HOLLERITH
&& (t2 == type_INTEGER || t2 == type_LOGICAL))
|| (t2 == type_HOLLERITH
&& (t1 == type_INTEGER || t1 == type_LOGICAL))
&& (storage_class_of(a1[i].type)==storage_class_of(a1[i].type)) )
continue;
/* stop after limit: probably a cascade */
if(++typerr > CMP_ERR_LIMIT) {
fprintf(list_fd,"\n etc...");
break;
}
if(typerr == 1)
fprintf(list_fd,"\nSubprogram %s: argument data type mismatch",
name);
fprintf(list_fd, "\n at position %d:", i+1);
fprintf(list_fd,"\n\t%s %s %s in module %s line %u file %s",
args1->is_defn? "Dummy type": "Actual type",
type_name[t1],
class_name[storage_class_of(a1[i].type)],
args1->module->name,
args1->line_num,
args1->filename);
fprintf(list_fd,"\n\t%s %s %s in module %s line %u file %s",
args2->is_defn? "Dummy type": "Actual type",
type_name[t2],
class_name[storage_class_of(a2[i].type)],
args2->module->name,
args2->line_num,
args2->filename);
if(args1->is_defn
&& storage_class_of(a1[i].type) == class_SUBPROGRAM
&& storage_class_of(a2[i].type) != class_SUBPROGRAM
&& datatype_of(a1[i].type) != type_SUBROUTINE
&& ! a1[i].declared_external )
fprintf(list_fd,"\n\t(possibly it is an array which was not declared)");
}
}
}/* end look for type mismatches */
/* Check arrayness of args only if defn exists */
if( args1->is_defn ) {
int arrayness_errs = 0;
unsigned long diminfo1,diminfo2,dims1,dims2,size1,size2;
for (i=0; i<n; i++) {
if(storage_class_of(a1[i].type) == class_VAR
&& storage_class_of(a2[i].type) == class_VAR) {
/* Allow holleriths to match arrays. Type
match was checked above, so they will
be matching arrays of integer or logical. */
if( datatype_of(a1[i].type) == type_HOLLERITH
|| datatype_of(a2[i].type) == type_HOLLERITH )
continue;
diminfo1 = a1[i].info.array_dim;
diminfo2 = a2[i].info.array_dim;
dims1 = array_dims(diminfo1);
dims2 = array_dims(diminfo2);
size1 = array_size(diminfo1);
size2 = array_size(diminfo2);
#if DEBUG_PRSYMTAB
if(debug_latest){
fprintf(list_fd,"\n%s arg %d: array_var=%d%d array_element=%d%d",
name,i+1,
a1[i].array_var,a2[i].array_var,
a1[i].array_element,a2[i].array_element);
fprintf(list_fd,"\nDummy dims=%ld size=%ld",dims1,size1);
fprintf(list_fd,"\nActual dims=%ld size=%ld",dims2,size2);
}
#endif
if( a1[i].array_var ) { /* I. Dummy arg is array */
if( a2[i].array_var ) {
if( a2[i].array_element ) {
/* A. Actual arg is array elt */
/* Warn on check_array_dims. */
if(check_array_dims) {
/* stop after limit: probably a cascade */
if(++arrayness_errs > CMP_ERR_LIMIT) {
fprintf(list_fd,"\n etc...");
break;
}
if(arrayness_errs == 1)
fprintf(list_fd,"\nSubprogram %s: argument arrayness mismatch",
name);
fprintf(list_fd, "\n at position %d:", i+1);
fprintf(list_fd,
"\n\tDummy arg is whole array in module %s line %u file %s",
args1->module->name,
args1->line_num,
args1->filename);
fprintf(list_fd,
"\n\tActual arg is array element in module %s line %u file %s",
args2->module->name,
args2->line_num,
args2->filename);
}
}
else {
/* B. Actual arg is whole array */
/* Warn if dims or sizes differ */
/* size = 0 or 1 means adjustable: OK to differ */
if( (check_array_size &&
(size1 > 1 && size2 > 1 && size1 != size2))
|| (check_array_dims &&
(dims1 != dims2)) ) {
/* stop after limit: probably a cascade */
if(++arrayness_errs > CMP_ERR_LIMIT) {
fprintf(list_fd,"\n etc...");
break;
}
if(arrayness_errs == 1)
fprintf(list_fd,"\nSubprogram %s: argument arrayness mismatch",
name);
fprintf(list_fd, "\n at position %d:", i+1);
fprintf(list_fd,
"\n\tDummy arg %ld dim%s size %ld in module %s line %u file %s",
dims1,pluralize(dims1),
size1,
args1->module->name,
args1->line_num,
args1->filename);
fprintf(list_fd,
"\n\tActual arg %ld dim%s size %ld in module %s line %u file %s",
dims2,pluralize(dims2),
size2,
args2->module->name,
args2->line_num,
args2->filename);
}
}
}
else {
/* C. Actual arg is scalar */
/* Warn in all cases */
/* stop after limit: probably a cascade */
if(++arrayness_errs > CMP_ERR_LIMIT) {
fprintf(list_fd,"\n etc...");
break;
}
if(arrayness_errs == 1)
fprintf(list_fd,"\nSubprogram %s: argument arrayness mismatch",
name);
fprintf(list_fd, "\n at position %d:", i+1);
fprintf(list_fd,
"\n\tDummy arg is array in module %s line %u file %s",
args1->module->name,
args1->line_num,
args1->filename);
fprintf(list_fd,
"\n\tActual arg is scalar in module %s line %u file %s",
args2->module->name,
args2->line_num,
args2->filename);
}
} /* end dummy is array case */
else { /* II. Dummy arg is scalar */
if( a2[i].array_var ) {
if( a2[i].array_element ) {
/* A. Actual arg is array elt */
/* OK */
}
else {
/* B. Actual arg is whole array */
/* Warn in all cases */
/* stop after limit: probably a cascade */
if(++arrayness_errs > CMP_ERR_LIMIT) {
fprintf(list_fd,"\n etc...");
break;
}
if(arrayness_errs == 1)
fprintf(list_fd,"\nSubprogram %s: argument arrayness mismatch",
name);
fprintf(list_fd, "\n at position %d:", i+1);
fprintf(list_fd,
"\n\tDummy arg is scalar in module %s line %u file %s",
args1->module->name,
args1->line_num,
args1->filename);
fprintf(list_fd,
"\n\tActual arg is whole array in module %s line %u file %s",
args2->module->name,
args2->line_num,
args2->filename);
}
}
else {
/* C. Actual arg is scalar */
/* OK */
}
} /* end dummy is scalar case */
} /* end if class_VAR */
}/* end for (i=0; i<n; i++) */
}/* if( args1->is_defn ) */
/* Check usage of args only if defn exists */
if(check_set_used && args1->is_defn) {
usage_err = 0;
for (i=0; i<n; i++) {
int nonlvalue_out = (a1[i].assigned_flag && !a2[i].is_lvalue),
nonset_in = (a1[i].used_before_set && !a2[i].set_flag);
#if DEBUG_PRSYMTAB
if(debug_latest) {
fprintf(list_fd,
"\nUsage check: %s[%d] dummy asgnd %d ubs %d actual lvalue %d set %d",
args1->module->name,
i+1,
a1[i].assigned_flag,
a1[i].used_before_set,
a2[i].is_lvalue,
a2[i].set_flag);
}
#endif
if(nonlvalue_out || nonset_in) {
/* stop after limit: probably a cascade */
if(++usage_err > CMP_ERR_LIMIT) {
fprintf(list_fd,"\n etc...");
break;
}
if(usage_err == 1)
fprintf(list_fd,"\nSubprogram %s: argument usage mismatch",
name);
fprintf(list_fd, "\n at position %d:", i+1);
if(nonlvalue_out) {
fprintf(list_fd,
"\n\tDummy arg is modified in module %s line %u file %s",
args1->module->name,
args1->line_num,
args1->filename);
fprintf(list_fd,
"\n\tActual arg is const or expr in module %s line %u file %s",
args2->module->name,
args2->line_num,
args2->filename);
}
else
if(nonset_in) {
fprintf(list_fd,
"\n\tDummy arg used before set in module %s line %u file %s",
args1->module->name,
args1->line_num,
args1->filename);
fprintf(list_fd,
"\n\tActual arg not set in module %s line %u file %s",
args2->module->name,
args2->line_num,
args2->filename);
}
}
}
}/*end if(check_set_used && args->is_defn) */
}/* arg_array_cmp */
/* Macro for testing whether an arglist or comlist header is
irrelevant for purposes of error checking: i.e. it comes
from an unvisited library module. */
#define irrelevant(list) ((list)->module->library_module &&\
!(list)->module->visited_somewhere)
void
check_arglists() /* Scans global symbol table for subprograms */
{ /* and finds subprogram defn if it exists */
unsigned i;
ArgListHeader *defn_list, *alist;
for (i=0; i<glob_symtab_top; i++){
if(debug_latest){
printf("\n%s: type 0x%x lib %d int %d vis %d vis-smw %d",
glob_symtab[i].name,
glob_symtab[i].type,
glob_symtab[i].library_module,
glob_symtab[i].internal_entry,
glob_symtab[i].visited,
glob_symtab[i].visited_somewhere
);
}
/* Skip common blocks */
if(storage_class_of(glob_symtab[i].type) != class_SUBPROGRAM)
continue;
if(debug_latest)printf(": class OK");
/* Skip unvisited library modules */
if(glob_symtab[i].library_module && !glob_symtab[i].visited)
continue;
if(debug_latest)printf(": status OK");
if((alist=glob_symtab[i].info.arglist) == NULL){
fprintf(list_fd,
"\nOops--global symbol %s has no argument lists",
glob_symtab[i].name);
}
else{ /* alist != NULL */
int num_defns= 0;
ArgListHeader *list_item;
/* use 1st invocation instead of defn if no defn */
defn_list = alist;
/* Find a definition in the linked list of
usages. Count how many defns found. */
list_item = alist;
while(list_item != NULL){
if(list_item->is_defn){
if(ext_def_check && num_defns > 0) {/* multiple defn */
if(num_defns == 1) {
fprintf(list_fd,"\nSubprogram %s multiply defined:",
glob_symtab[i].name);
fprintf(list_fd,"\n\tin module %s line %u file %s",
defn_list->module->name,
defn_list->line_num,
defn_list->filename);
}
fprintf(list_fd,"\n\tin module %s line %u file %s",
list_item->module->name,
list_item->line_num,
list_item->filename);
}
++num_defns;
defn_list = list_item; /* Use last defn found */
}
else { /* ! list_item->is_defn */
/* Here treat use as actual arg like call */
if(list_item->is_call || list_item->actual_arg){
/* Use last call by a visited or nonlibrary
module as defn if no defn found */
if(!defn_list->is_defn
&& !irrelevant(list_item) )
defn_list = list_item;
}
}
list_item = list_item->next;
}
if(num_defns == 0){
/* If no defn found, and all calls are
from unvisited library modules, skip. */
if(irrelevant(defn_list))
continue;
/* If no definitions found, report error
unless -noext is given */
if(ext_def_check) {
fprintf(list_fd, "\nSubprogram %s never defined",
glob_symtab[i].name);
if(!glob_symtab[i].used_flag)
fprintf(list_fd," nor invoked");
fprintf(list_fd, "\n\t%s in module %s line %u file %s",
(defn_list->external_decl)?"declared":"invoked",
defn_list->module->name,
defn_list->line_num,
defn_list->filename);
/* Warn if it seems it may just be an array they
forgot to declare */
if(defn_list->numargs != 0
&& datatype_of(defn_list->type) != type_SUBROUTINE
&& ! glob_symtab[i].declared_external) {
if(novice_help)
fprintf(list_fd,"\n\t(possibly it is an array which was not declared)");
}
}
}
/* If definition is found but module is
not in call tree, report it unless -lib */
else{ /* num_defns != 0 */
if(!glob_symtab[i].visited
&& datatype_of(glob_symtab[i].type) != type_BLOCK_DATA
&& !glob_symtab[i].library_module) {
fprintf(list_fd,"\nSubprogram %s never invoked",
glob_symtab[i].name);
fprintf(list_fd, "\n\tdefined in module %s line %u file %s",
defn_list->module->name,
defn_list->line_num,
defn_list->filename);
}
}
/* Now check defns/invocations for consistency. If
no defn, 1st invocation will serve. Here treat
use as actual arg like call. Ignore calls & defns
in unvisited library modules. */
if(defn_list->is_defn || !defn_list->external_decl) {
while(alist != NULL){
int typerrs = 0;
if(alist != defn_list && !alist->external_decl
&& !irrelevant(alist)) {
if(alist->type != defn_list->type){
int t1 = datatype_of(defn_list->type),
t2 = datatype_of(alist->type);
if(typerrs++ == 0){
fprintf(list_fd,"\nSubprogram %s invoked inconsistently:",
glob_symtab[i].name);
fprintf(list_fd,"\n\t%s type %s in module %s line %u file %s",
defn_list->is_defn? "Defined":"Invoked",
type_name[t1],
defn_list->module->name,
defn_list->line_num,
defn_list->filename);
}
fprintf(list_fd,"\n\t%s type %s in module %s line %u file %s",
alist->is_defn? "Defined":"Invoked",
type_name[t2],
alist->module->name,
alist->line_num,
alist->filename);
}
}
alist = alist->next;
}/* end while(alist != NULL) */
}/* end if(defn) */
alist = glob_symtab[i].info.arglist;
while(alist != NULL){
/* Here we require true call, not use as actual arg.
Also, do not compare multiple defns against each
other. */
if(alist != defn_list &&
(defn_list->is_defn || defn_list->is_call) &&
(alist->is_call && !irrelevant(alist)) ){
arg_array_cmp(glob_symtab[i].name,defn_list,alist);
}
alist = alist->next;
}/* end while(alist != NULL) */
}/* end else <alist != NULL> */
}/* end for (i=0; i<glob_symtab_top; i++) */
}
void
check_comlists() /* Scans global symbol table for common blocks */
{
unsigned i, model_n;
ComListHeader *first_list, *model, *clist;
if(comcheck_strictness == 0)
return;
for (i=0; i<glob_symtab_top; i++){
if (storage_class_of(glob_symtab[i].type) != class_COMMON_BLOCK)
continue;
if((first_list=glob_symtab[i].info.comlist) == NULL){
fprintf(list_fd,"\nCommon block %s never defined",
glob_symtab[i].name);
}
else {
/* Find instance with most variables to use as model */
model=first_list;
model_n = first_list->numargs;
clist = model;
while( (clist=clist->next) != NULL ){
if(clist->numargs >= model_n /* if tie, use earlier */
/* also if model is from an unvisited library
module, take another */
|| irrelevant(model) ) {
model = clist;
model_n = clist->numargs;
}
}
if( irrelevant(model) )
continue; /* skip if irrelevant */
clist = first_list;
while( clist != NULL ){
if(clist != model && !irrelevant(clist)) {
if(comcheck_strictness <= 2)
com_cmp_lax(glob_symtab[i].name,model,clist);
else
com_cmp_strict(glob_symtab[i].name,model,clist);
}
clist = clist->next;
}
}
}
} /* check_comlists */
PRIVATE void
com_cmp_lax(name,c1,c2) /* Common-list check at levels 1 & 2 */
char *name;
ComListHeader *c1,*c2;
{
int i1,i2, /* count of common variables in each block */
done1,done2, /* true when end of block reached */
type1,type2; /* type of variable presently in scan */
unsigned long
len1,len2, /* length of variable remaining */
word1,word2, /* number of "words" scanned */
words1,words2, /* number of "words" in block */
jump; /* number of words to skip next in scan */
int n1=c1->numargs,n2=c2->numargs; /* variable count for each block */
ComListElement *a1=c1->com_list_array, *a2=c2->com_list_array;
/* Count words in each list */
words1=words2=0;
for(i1=0; i1<n1; i1++)
words1 += array_size(a1[i1].dimen_info);
for(i2=0; i2<n2; i2++)
words2 += array_size(a2[i2].dimen_info);
if(comcheck_strictness >= 2 && words1 != words2) {
fprintf(list_fd,"\nCommon block %s: varying length:", name);
fprintf(list_fd,
"\n\tDeclared with %ld word%s in module %s line %u file %s",
words1, pluralize(words1),
c1->module->name,
c1->line_num,
c1->filename);
fprintf(list_fd,
"\n\tDeclared with %ld word%s in module %s line %u file %s",
words2, pluralize(words2),
c2->module->name,
c2->line_num,
c2->filename);
}
/* Now check type matches */
done1=done2=FALSE;
i1=i2=0;
len1=len2=0;
word1=word2=1;
for(;;) {
if(len1 == 0) { /* move to next variable in list 1 */
if(i1 == n1) {
done1 = TRUE;
}
else {
type1 = a1[i1].type;
len1 = array_size(a1[i1].dimen_info);
++i1;
}
}
if(len2 == 0) { /* move to next variable in list 2 */
if(i2 == n2) {
done2 = TRUE;
}
else {
type2 = a2[i2].type;
len2 = array_size(a2[i2].dimen_info);
++i2;
}
}
if(done1 || done2){ /* either list exhausted? */
break; /* then stop checking */
}
if(type1 != type2) { /* type clash? */
fprintf(list_fd,"\nCommon block %s: data type mismatch",
name);
fprintf(list_fd,
"\n\tWord %ld is type %s in module %s line %u file %s",
word1,
type_name[type1],
c1->module->name,
c1->line_num,
c1->filename);
fprintf(list_fd,
"\n\tWord %ld is type %s in module %s line %u file %s",
word2,
type_name[type2],
c2->module->name,
c2->line_num,
c2->filename);
break; /* stop checking at first mismatch */
}
/* Advance along list by largest possible
step that does not cross a variable boundary
*/
jump = len1 < len2? len1: len2; /* min(len1,len2) */
len1 -= jump;
len2 -= jump;
word1 += jump;
word2 += jump;
}/* end for(;;) */
}
PRIVATE void
com_cmp_strict(name,c1,c2) /* Common-list check at levels 1 & 2 */
char *name;
ComListHeader *c1, *c2;
{
int i,
typerr = 0,
dimerr = 0;
short n,
n1 = c1->numargs,
n2 = c2->numargs;
ComListElement *a1 = c1->com_list_array,
*a2 = c2->com_list_array;
n = (n1 > n2) ? n2: n1;
for (i=0; i<n; i++){
if(a1[i].type != a2[i].type){
typerr = 1;
break;
}
}
for (i=0; i<n; i++){
if(a1[i].dimen_info != a2[i].dimen_info){
dimerr = 1;
break;
}
}
if(n1 != n2){
fprintf(list_fd,"\nCommon block %s: varying length:", name);
fprintf(list_fd,
"\n\tDeclared with %d variable%s in module %s line %u file %s",
n1,pluralize(n1),
c1->module->name,
c1->line_num,
c1->filename);
fprintf(list_fd,
"\n\tDeclared with %d variable%s in module %s line %u file %s",
n2,pluralize(n2),
c2->module->name,
c2->line_num,
c2->filename);
}
if(typerr){
typerr = 0; /* start count over again */
fprintf(list_fd,"\nCommon block %s: data type mismatch",
name);
for (i=0; i<n; i++) {
if(a1[i].type != a2[i].type){
int t1 = datatype_of(a1[i].type),
t2 = datatype_of(a2[i].type);
/* stop after limit: probably a cascade */
if(++typerr > CMP_ERR_LIMIT) {
fprintf(list_fd,"\n etc...");
break;
}
fprintf(list_fd, "\n at position %d:", i+1);
fprintf(list_fd,"\n\tVariable declared type %s in module %s line %u file %s",
type_name[t1],
c1->module->name,
c1->line_num,
c1->filename);
fprintf(list_fd,"\n\tVariable declared type %s in module %s line %u file %s",
type_name[t2],
c2->module->name,
c2->line_num,
c2->filename);
}
}
}
if(dimerr){
dimerr = 0; /* start count over again */
fprintf(list_fd,"\nCommon block %s: array dimen/size mismatch",
name);
for (i=0; i<n; i++){
unsigned long d1, d2, s1, s2;
if((d1=array_dims(a1[i].dimen_info)) !=
(d2=array_dims(a2[i].dimen_info))){
/* stop after limit: probably a cascade */
if(++dimerr > CMP_ERR_LIMIT) {
fprintf(list_fd,"\n etc...");
break;
}
fprintf(list_fd, "\nat position %d:", i+1);
fprintf(list_fd,
"\n\tDeclared with %ld dimension%s in module %s line %u file %s",
d1,pluralize(d1),
c1->module->name,
c1->line_num,
c1->filename);
fprintf(list_fd,
"\n\tDeclared with %ld dimension%s in module %s line %u file %s",
d2,pluralize(d2),
c2->module->name,
c2->line_num,
c2->filename);
}
if((s1=array_size(a1[i].dimen_info)) !=
(s2=array_size(a2[i].dimen_info))){
/* stop after limit: probably a cascade */
if(++dimerr > CMP_ERR_LIMIT) {
fprintf(list_fd,"\n etc...");
break;
}
fprintf(list_fd, "\nat position %d:", i+1);
fprintf(list_fd,
"\n\tDeclared with size %ld in module %s line %u file %s",
s1,
c1->module->name,
c1->line_num,
c1->filename);
fprintf(list_fd,
"\n\tDeclared with size %ld in module %s line %u file %s",
s2,
c2->module->name,
c2->line_num,
c2->filename);
}
}
}
}/*com_cmp_strict*/
PRIVATE void
sort_symbols(sp,n) /* sorts a given list */
Lsymtab *sp[];
unsigned n;
{
int i,j,swaps;
for(i=0;i<n;i++) {
swaps = 0;
for(j=n-1;j>=i+1;j--) {
if((strcmp(sp[j-1]->name, sp[j]->name)) > 0) {
swap_symptrs(&sp[j-1], &sp[j]);
swaps ++;
}
}
if(swaps == 0) break;
}
}
PRIVATE void /* swaps two pointers */
swap_symptrs(x_ptr,y_ptr)
Lsymtab **x_ptr,**y_ptr;
{
Lsymtab *temp = *x_ptr;
*x_ptr = *y_ptr;
*y_ptr = temp;
}
void
print_loc_symbols(curmodhash)
int curmodhash; /* hash entry of current module */
{
Lsymtab *sym_list[LOCSYMTABSZ]; /* temp. list of symtab entries to print */
int mod_type, /* datatype of this module */
this_is_a_function; /* flag for treating funcs specially */
Lsymtab *module; /* entry of current module in symtab */
char *mod_name; /* module name */
unsigned
com_vars_modified=0, /* count of common variables which are set */
args_modified=0, /* count of arguments which are set */
imps=0, /* count of implicitly declared identifiers */
numentries; /* count of entry points of module */
/* Keep track of symbol table and string usage */
if(loc_symtab_top > max_loc_symtab) {
max_loc_symtab = loc_symtab_top;
}
if(loc_str_top > max_loc_strings) {
max_loc_strings = loc_str_top;
}
if(token_space_top > max_token_space) {
max_token_space = token_space_top;
}
/* Global symbols only increase in number */
max_glob_symtab = glob_symtab_top;
max_glob_strings = STRSPACESZ - glob_str_bot;
/* Set up name & type, and see what kind of module it is */
module = hashtab[curmodhash].loc_symtab;
mod_name = module->name;
mod_type = get_type(module);
if( mod_type != type_PROGRAM
&& mod_type != type_SUBROUTINE
&& mod_type != type_COMMON_BLOCK
&& mod_type != type_BLOCK_DATA )
this_is_a_function = TRUE;
else
this_is_a_function = FALSE;
/* Print name & type of the module */
if(do_symtab) {
unsigned i;
for(i=0,numentries=0;i<loc_symtab_top;i++) {
if(loc_symtab[i].entry_point)
sym_list[numentries++] = &loc_symtab[i];
}
if(numentries > 1) {
sort_symbols(sym_list,numentries);
}
fprintf(list_fd,"\n\nModule %s:",mod_name);
if( this_is_a_function ) fprintf(list_fd," func:");
fprintf(list_fd," %4s",type_name[mod_type]);
/* Print a * next to non-declared function name */
if(datatype_of(module->type) == type_UNDECL ) {
fprintf(list_fd,"*");
imps++;
}
fprintf(list_fd,"\n");
/* Print Entry Points (skip if only one,
since it is same as module name) */
if(do_symtab && numentries > 1) {
fprintf(list_fd,"\nEntry Points\n");
(void) print_symbols(list_fd,sym_list,numentries,FALSE);
}
/* End of printing module name and entry points */
}/*if(do_symtab)*/
/* Print the externals */
if(do_symtab) {
unsigned i,n;
for(i=0,n=0;i<loc_symtab_top;i++) {
if(storage_class_of(loc_symtab[i].type) == class_SUBPROGRAM) {
sym_list[n++] = &loc_symtab[i];
}
}
if(n != 0) {
sort_symbols(sym_list,n);
fprintf(list_fd,"\nExternal subprograms referenced:\n");
imps += print_symbols(list_fd,sym_list,n,TRUE);
}
}/*if(do_symtab)*/
/* Print list of statement functions */
if(do_symtab) {
unsigned i,n;
for(i=0,n=0;i<loc_symtab_top;i++) {
if(storage_class_of(loc_symtab[i].type) == class_STMT_FUNCTION){
sym_list[n++] = &loc_symtab[i];
}
}
if(n != 0) {
sort_symbols(sym_list,n);
fprintf(list_fd,"\nStatement functions defined:\n");
imps += print_symbols(list_fd,sym_list,n,TRUE);
}
}/*if(do_symtab)*/
/* Print the common blocks */
if(do_symtab || port_check) {
unsigned i,numblocks;
for(i=0,numblocks=0;i<loc_symtab_top;i++) {
if(storage_class_of(loc_symtab[i].type) == class_COMMON_BLOCK) {
sym_list[numblocks++] = &loc_symtab[i];
}
}
if(numblocks != 0) {
sort_symbols(sym_list,numblocks);
if(do_symtab) {
fprintf(list_fd,"\nCommon blocks referenced:\n");
(void) print_symbols(list_fd,sym_list,numblocks,FALSE);
}
if(port_check) {
check_mixed_common(list_fd,sym_list,numblocks);
}
}
}/*if(do_symtab||port_check)*/
/* Print the namelists */
if(do_symtab) {
unsigned i,numlists;
for(i=0,numlists=0;i<loc_symtab_top;i++) {
if(storage_class_of(loc_symtab[i].type) == class_NAMELIST) {
sym_list[numlists++] = &loc_symtab[i];
}
}
if(numlists != 0) {
sort_symbols(sym_list,numlists);
if(do_symtab) {
fprintf(list_fd,"\nNamelists defined:\n");
(void) print_symbols(list_fd,sym_list,numlists,FALSE);
}
}
}/* End printing the namelists */
/* Process the variables */
if(do_symtab || usage_check) {
unsigned i,n;
for(i=0,n=0;i<loc_symtab_top;i++) {
if(storage_class_of(loc_symtab[i].type) == class_VAR
&& (!loc_symtab[i].entry_point || this_is_a_function)) {
sym_list[n++] = &loc_symtab[i];
if(loc_symtab[i].argument && loc_symtab[i].set_flag) {
if(++args_modified <= 3)
if(this_is_a_function && pure_functions)
fprintf(list_fd,
"\nFunction %s %s argument %s",
mod_name,
loc_symtab[i].assigned_flag?
"modifies":"may modify",
loc_symtab[i].name);
}
if(loc_symtab[i].common_var && loc_symtab[i].set_flag) {
if(++com_vars_modified <= 3)
if(this_is_a_function && pure_functions)
fprintf(list_fd,
"\nFunction %s %s common variable %s",
mod_name,
loc_symtab[i].assigned_flag?
"modifies":"may modify",
loc_symtab[i].name);
}
}
}
if(args_modified > 3 || com_vars_modified > 3)
if(this_is_a_function && pure_functions)
fprintf(list_fd,"\netc...");
if(n != 0) {
sort_symbols(sym_list,n);
/* Print the variables */
if(do_symtab) {
fprintf(list_fd,"\nVariables:\n ");
imps += print_variables(sym_list,n);
}
}
/* Explain the asterisk on implicitly defined
identifiers. Note that this message will
be given also if functions implicitly defined */
if(do_symtab && imps != 0) {
fprintf(list_fd,"\n* Variable not declared.");
fprintf(list_fd," Type has been implicitly defined.\n");
}
if(usage_check) {
if(do_symtab || do_list)
fprintf(list_fd,"\n");
if(check_unused) {
check_flags(sym_list,n,0,0,0,
"declared but never referenced",mod_name);
check_flags(sym_list,n,0,1,0,
"set but never used",mod_name);
}
if(check_set_used) {
check_flags(sym_list,n,1,0,1,
"used before set",mod_name);
check_flags(sym_list,n,1,1,1,
"may be used before set",mod_name);
}
}/*end if(usage_check)*/
if(do_symtab || do_list)
fprintf(list_fd,"\n");
}/* end if(do_symtab || usage_check) */
/* List all undeclared vars & functions */
if(decls_required || implicit_none) {
unsigned i,n;
for(i=0,n=0;i<loc_symtab_top;i++) {
if(datatype_of(loc_symtab[i].type) == type_UNDECL
&& ! loc_symtab[i].intrinsic /* omit intrinsics */
/* omit subroutines called */
&& (!loc_symtab[i].external || loc_symtab[i].invoked_as_func)
) {
sym_list[n++] = &loc_symtab[i];
}
}
if(n != 0) {
sort_symbols(sym_list,n);
fprintf(list_fd,"\nIdentifiers of undeclared type in module %s:",
mod_name);
(void) print_symbols(list_fd,sym_list,n,FALSE);
}
}/*if(decls_required || implicit_none)*/
/* issue portability warning for identifiers
longer than 6 characters
*/
if(f77_standard) {
unsigned i,n;
for(i=0,n=0;i<loc_symtab_top;i++) {
if(strlen(loc_symtab[i].name) > 6)
sym_list[n++] = &loc_symtab[i];
}
if(n != 0) {
sort_symbols(sym_list,n);
++warning_count;
fprintf(list_fd,
"\nNames longer than 6 chars in module %s (nonstandard):",
mod_name);
(void) print_symbols(list_fd,sym_list,n,FALSE);
}
}
/* If -f77 flag given, list names with underscore or dollarsign */
#if ALLOW_UNDERSCORES || ALLOW_DOLLARSIGNS
if(f77_standard) {
unsigned i,n;
for(i=0,n=0;i<loc_symtab_top;i++) {
/* Find all names with nonstd chars, but
exclude internal names like %MAIN */
if(has_nonalnum(loc_symtab[i].name) &&
loc_symtab[i].name[0] != '%')
sym_list[n++] = &loc_symtab[i];
}
if(n != 0) {
sort_symbols(sym_list,n);
++warning_count;
fprintf(list_fd,
"\nNames containing nonstandard characters in module %s:",
mod_name);
(void) print_symbols(list_fd,sym_list,n,FALSE);
}
}/*if(f77_standard)*/
#endif
/* Print out clashes in first six chars of name */
if(sixclash) {
unsigned n;
n = find_sixclashes(sym_list);
if(n != 0) {
sort_symbols(sym_list,n);
fprintf(list_fd,
"\nIdentifiers which are not unique in first six chars in module %s:"
,mod_name);
(void) print_symbols(list_fd,sym_list,n,FALSE);
}/* end if(n != 0) */
}/* end if(sixclash) */
/* If portability flag was given, check equivalence
groups for mixed type. */
if(port_check) {
unsigned i,j,n;
int caption_given=FALSE;
unsigned imps=0;
Lsymtab *equiv;
/* scan thru table for equivalenced variables */
for(i=0;i<loc_symtab_top;i++) {
if(storage_class_of(loc_symtab[i].type) == class_VAR
&& loc_symtab[i].equiv_link != (equiv= &loc_symtab[i]) ){
n=0;
do {
if(equiv < &loc_symtab[i]) { /* skip groups done before */
n=0;
break;
}
sym_list[n++] = equiv;
equiv = equiv->equiv_link;
} while(equiv != &loc_symtab[i]); /* complete the circle */
/* Check for mixed types */
if(n != 0) {
int mixed_type = FALSE;
for(j=1; j<n; j++) {
if(get_type(sym_list[j]) != get_type(sym_list[j-1])) {
mixed_type = TRUE;
break;
}
}
if(mixed_type) {
sort_symbols(sym_list,n);
if(caption_given)/* give short or long caption */
fprintf(list_fd," and");
else {
fprintf(list_fd,
"\nMixed types equivalenced in module %s",
mod_name);
fprintf(list_fd,
" (not portable):");
caption_given = TRUE;
}
imps += print_symbols(list_fd,sym_list,n,TRUE);
}
}
}
}
if(imps != 0) {
fprintf(list_fd,"\n* Variable not declared.");
fprintf(list_fd," Type has been implicitly defined.\n");
}
}/*if(port_check)*/
}/* print_loc_symbols */
PRIVATE int
has_nonalnum(s) /* Returns TRUE if s contains a non-alphanumeric character */
char *s;
{
while( *s != '\0' )
if( ! isalnum( (int)(*s++) ) )
return TRUE;
return FALSE;
}
/* This routine prints symbol names neatly. If do_types is true
also prints types, with * next to implicitly
typed identifiers, and returns count thereof. */
PRIVATE unsigned
print_symbols(fd,sym_list,n,do_types)
FILE *fd;
Lsymtab *sym_list[];
unsigned n;
int do_types;
{
unsigned i,col=0,len,implicits=0;
fprintf(fd,"\n");
for(i=0;i<n;i++) {
len = strlen(sym_list[i]->name);
col += len = (len <= 10? 10: len) + 9;
if(col > 78) {
fprintf(fd,"\n");
col = len;
}
fprintf(fd,"%10s",sym_list[i]->name);
if( do_types ) {
if(sym_list[i]->intrinsic)
fprintf(fd,": intrns ");
else
fprintf(fd,": %4s%1s ",
type_name[get_type(sym_list[i])],
(datatype_of(sym_list[i]->type) == type_UNDECL)?
(implicits++,"*" ) : ""
);
}
else
fprintf(fd,"%9s","");
}
fprintf(fd,"\n");
return implicits;
}/*print_symbols*/
/* This routine prints the variables nicely, and returns
count of number implicitly defined.
*/
PRIVATE unsigned
print_variables(sym_list,n)
Lsymtab *sym_list[];
unsigned n;
{
unsigned i,implicits=0;
fprintf(list_fd,"\n ");
for(i=0; i<4; i++) {
fprintf(list_fd,"%5sName Type Dims","");
/* 12345678901234567890 template for above*/
}
for(i=0; i<n; i++) {
if(i % 4 == 0)
fprintf(list_fd,"\n");
else
fprintf(list_fd," ");
fprintf(list_fd,"%10s",sym_list[i]->name);
/* Print a * next to non-declared variables */
fprintf(list_fd," %4s%1s",
type_name[get_type(sym_list[i])],
(datatype_of(sym_list[i]->type) == type_UNDECL )?
(implicits++,"*") : ""
);
/* print no. of dimensions next to var name */
if(sym_list[i]->array_var) {
fprintf(list_fd," %ld",
array_dims(sym_list[i]->info.array_dim));
}
else {
fprintf(list_fd,"%2s","");
}
}
fprintf(list_fd,"\n");
return implicits;
}/*print_variables*/
/* Search thru local symbol table for clashes where identifiers
are not unique in 1st six characters. Return value =
number of clashes found, with pointers to symbol table
entries of clashers in array list. */
PRIVATE unsigned
find_sixclashes(list)
Lsymtab *list[];
{
unsigned i,h, clashes=0;
int class;
unsigned long hnum;
for(i=0; i<loc_symtab_top; i++) { /* Scan thru symbol table */
class = storage_class_of(loc_symtab[i].type);
hnum = hash( loc_symtab[i].name );
/* First look for a clash of any kind.
(N.B. this loop will never quit if hash
table is full, but let's not worry) */
while( (h=hnum % HASHSZ), hashtab[h].name != (char *)NULL) {
/* Now see if the clashing name is used locally and still
clashes at 6 chars. Treat common blocks separately. */
if((class == class_COMMON_BLOCK &&
(
hashtab[h].com_loc_symtab != NULL
&& strcmp( hashtab[h].name,loc_symtab[i].name) != 0
&& strncmp(hashtab[h].name,loc_symtab[i].name,6) == 0
)
) ||
(class != class_COMMON_BLOCK &&
(
hashtab[h].loc_symtab != NULL
&& strcmp( hashtab[h].name,loc_symtab[i].name) != 0
&& strncmp(hashtab[h].name,loc_symtab[i].name,6) == 0
)
)
) {
/* If so, then i'th symbol is a clash */
list[clashes++] = &loc_symtab[i];
break;
}
else {
hnum = rehash(hnum);
}
}
}
return clashes;
}
PRIVATE void
print_arg_array(arglist) /* prints type and flag info for arguments */
ArgListHeader *arglist;
{
int i, count;
ArgListElement *a;
count = arglist->numargs;
if(arglist->external_decl || arglist->actual_arg)
count = 0;
a = arglist->arg_array;
fprintf(list_fd,"\nArg list in module %s file %s line %u:",
arglist->module->name, arglist->filename, arglist->line_num);
fprintf(list_fd,"\n\tdef%d call%d ext%d arg%d",
arglist->is_defn,
arglist->is_call,
arglist->external_decl,
arglist->actual_arg);
if(count == 0)
fprintf(list_fd,"\n(Empty list)");
else {
for (i=0; i<count; i++) {
fprintf(list_fd,
"\n\t%d %s: lv%d st%d as%d ub%d ar%d ae%d ex%d",
i+1,
type_name[datatype_of(a[i].type)],
a[i].is_lvalue,
a[i].set_flag,
a[i].assigned_flag,
a[i].used_before_set,
a[i].array_var,
a[i].array_element,
a[i].declared_external);
if(a[i].array_var)
fprintf(list_fd,"(%ld,%ld)",
array_dims(a[i].info.array_dim),
array_size(a[i].info.array_dim) );
fprintf(list_fd,", ");
}
}
}/* print_arg_array */
/* prints type and dimen info for common vars */
PRIVATE void
print_com_array(cmlist)
ComListHeader *cmlist;
{
int i, count;
ComListElement *c;
count = cmlist->numargs;
c = cmlist->com_list_array;
fprintf(list_fd,"\nCom list in module %s file %s line %u:",
cmlist->module->name, cmlist->filename, cmlist->line_num);
fprintf(list_fd,"\n\t");
if(count == 0)
fprintf(list_fd,"(Empty list)");
else {
for (i=0; i<count; i++){
fprintf(list_fd,"%s",type_name[datatype_of(c[i].type)]);
if(c[i].dimen_info)
fprintf(list_fd,":%ldD(%ld)",array_dims(c[i].dimen_info),
array_size(c[i].dimen_info));
fprintf(list_fd,", ");
}
}
}/* print_com_array */
PRIVATE void
print_tokenlist(toklist) /* prints list of token names or types */
TokenListHeader *toklist;
{
int numargs=0;
Token *t;
fprintf(list_fd,"\n");
if (toklist == NULL){
fprintf(list_fd,"\t(No list)");
}
else {
t = toklist->tokenlist;
while(t != NULL){
++numargs;
fprintf(list_fd," ");
if ( is_true(ID_EXPR,t->subclass) )
fprintf(list_fd,"%s ",token_name(*t));
else
fprintf(list_fd,"%s ",type_name[datatype_of(t->class)]);
t = t->next_token;
}
if(numargs == 0)
fprintf(list_fd,"\t(Empty list)");
}
}/* print_tokenlist */
void
debug_symtabs() /* Debugging output: hashtable and symbol tables */
{
if(debug_loc_symtab) {
fprintf(list_fd,"\n Debugging of local symbol table disabled");
return;
}
if(debug_hashtab) {
int i;
fprintf(list_fd,"\n\nContents of hashtable\n");
for(i=0; i<HASHSZ; i++) {
if(hashtab[i].name != NULL) {
fprintf(list_fd,"\n%4d %s",i,hashtab[i].name);
if(hashtab[i].loc_symtab != NULL)
fprintf(list_fd," loc %d",hashtab[i].loc_symtab-loc_symtab);
if(hashtab[i].glob_symtab != NULL)
fprintf(list_fd,
" glob %d",hashtab[i].glob_symtab-glob_symtab);
if(hashtab[i].com_loc_symtab != NULL)
fprintf(list_fd,
" Cloc %d",hashtab[i].com_loc_symtab-loc_symtab);
if(hashtab[i].com_glob_symtab != NULL)
fprintf(list_fd,
" Cglob %d",hashtab[i].com_glob_symtab-glob_symtab);
}
}
}
if(debug_glob_symtab) {
int i;
fprintf(list_fd,"\n\nContents of global symbol table");
for(i=0; i<glob_symtab_top; i++) {
fprintf(list_fd,
"\n%4d %s type 0x%x=%s,%s: ",
i,
glob_symtab[i].name,
glob_symtab[i].type,
class_name[storage_class_of(glob_symtab[i].type)],
type_name[datatype_of(glob_symtab[i].type)]
);
fprintf(list_fd,
"usd%d set%d asg%d ubs%d lib%d int%d invf%d vis%d smw%d incl%d ext%d ",
glob_symtab[i].used_flag,
glob_symtab[i].set_flag,
glob_symtab[i].assigned_flag,
glob_symtab[i].used_before_set,
glob_symtab[i].library_module,
glob_symtab[i].internal_entry,
glob_symtab[i].invoked_as_func,
glob_symtab[i].visited,
glob_symtab[i].visited_somewhere,
glob_symtab[i].defined_in_include,
glob_symtab[i].declared_external
);
switch(storage_class_of(glob_symtab[i].type)){
case class_COMMON_BLOCK:{
ComListHeader *clist;
clist=glob_symtab[i].info.comlist;
while(clist != NULL){
print_com_array(clist);
clist = clist->next;
}
break;
}
case class_SUBPROGRAM:{
ArgListHeader *alist;
alist=glob_symtab[i].info.arglist;
while(alist != NULL){
print_arg_array(alist);
alist = alist->next;
}
break;
}
}
}
}
}/* debug_symtabs*/
PRIVATE void
check_mixed_common(fd,sym_list,n)
FILE *fd;
Lsymtab *sym_list[];
unsigned n;
{
int i;
for(i=0; i<n; i++) {
ComListHeader *chead = sym_list[i]->info.comlist;
ComListElement *clist;
int j,nvars;
int has_char=FALSE,has_nonchar=FALSE;
int size, next_size;
if(chead == NULL)
continue;
clist=chead->com_list_array;
nvars = chead->numargs;
if(nvars > 0)
size = type_size[datatype_of(clist[0].type)];
for(j=0; j<nvars; j++) {
/* Check conformity to ANSI rule: no mixing char with other types */
if(datatype_of(clist[j].type) == type_STRING)
has_char = TRUE;
else
has_nonchar = TRUE;
if(has_char && has_nonchar) {
fprintf(fd,
"\nCommon block %s line %u module %s has mixed",
sym_list[i]->name,
chead->line_num,
chead->module->name);
fprintf(fd,"\n character and non-character variables");
fprintf(fd," (may not be portable)");
break;
}
/* Check that variables are in descending order of type size */
if( (next_size = type_size[datatype_of(clist[j].type)]) > size ) {
fprintf(fd,
"\nCommon block %s line %u module %s has long data type",
sym_list[i]->name,
chead->line_num,
chead->module->name);
fprintf(fd,
"\n following short data type (may not be portable)");
break;
}
size = next_size;
}
}
}
PRIVATE
void
check_flags(list,n,used,set,ubs,msg,mod_name)
Lsymtab *list[];
unsigned n;
unsigned used,set,ubs;
char *msg,*mod_name;
{
int matches=0,col=0,unused_args=0,i,len;
unsigned pattern = flag_combo(used,set,ubs);
for(i=0;i<n;i++) {
if( list[i]->common_var ) /* common vars are immune */
continue;
/* for args, do only 'never used' */
if( list[i]->argument && pattern != flag_combo(0,0,0) )
continue;
#ifdef ALLOW_INCLUDE
/* Skip variables 'declared but not used'
and parameters 'set but never used'
if defined in include file. */
if( list[i]->defined_in_include &&
( pattern == flag_combo(0,0,0)
|| (list[i]->parameter && pattern == flag_combo(0,1,0)) ) )
continue;
#endif
/* function return val: ignore 'set but never used' */
if( list[i]->entry_point && pattern == flag_combo(0,1,0) )
continue;
if(flag_combo(list[i]->used_flag,list[i]->set_flag,
list[i]->used_before_set) == pattern) {
if(matches++ == 0)
fprintf(list_fd,"\nVariables %s in module %s:\n",
msg,mod_name);
len = strlen(list[i]->name);
col += len = (len <= 10? 10: len) + 9;
if(col > 78) {
fprintf(list_fd,"\n");
col = len;
}
fprintf(list_fd,"%10s",list[i]->name);
/* arg never used: tag with asterisk */
fprintf(list_fd,"%-9s",
list[i]->argument? (++unused_args,"*") : "" );
}
}
if(unused_args > 0)
fprintf(list_fd,"\n * Dummy argument");
if(matches > 0)
fprintf(list_fd,"\n");
}
void
visit_children()
{
int i,num_mains;
if(print_call_tree)
fprintf(list_fd,"\nTree of subprogram calls:");
for(i=0; i<glob_symtab_top; i++) {
if(storage_class_of(glob_symtab[i].type) == class_SUBPROGRAM
&& ! glob_symtab[i].internal_entry) {
sort_child_list(glob_symtab[i].link.child_list);
}
}
/* Visit children of all main progs */
for(i=0,num_mains=0; i<glob_symtab_top; i++) {
if(storage_class_of(glob_symtab[i].type) == class_SUBPROGRAM
&& datatype_of(glob_symtab[i].type) == type_PROGRAM) {
visit_child(&glob_symtab[i],0);
++num_mains;
}
}
/* If no main program found, give
warning unless -noextern was set */
if(num_mains == 0) {
if(print_call_tree)
fprintf(list_fd,"\n (no main program found)");
else if(ext_def_check)
fprintf(list_fd,"\nNo main program found");
/* If no main, visit trees rooted at unvisited
nonlibrary routines, as the
next best thing.
*/
for(i=0; i<glob_symtab_top; i++) {
if(storage_class_of(glob_symtab[i].type) == class_SUBPROGRAM
&& !glob_symtab[i].library_module && !glob_symtab[i].used_flag) {
visit_child(&glob_symtab[i],0);
}
}
}
if(print_call_tree)
fprintf(list_fd,"\n");
}
/* Depth-first search of call tree */
PRIVATE void
visit_child(gsymt,level)
Gsymtab *gsymt;
int level;
{
static char fmt[]="%000s"; /* Variable format for indenting names */
ChildList *child_list;
int i,n;
if(print_call_tree) {
fprintf(list_fd,"\n");
if(level > 0) {
sprintf(fmt,"%%%ds",level*4); /* indent 4 spaces per nesting level */
fprintf(list_fd,fmt,"");
}
fprintf(list_fd,"%s",gsymt->name);
}
/* Visit its unvisited children. Note
that children of internal entry are
taken as those of its superior module.
*/
child_list = (gsymt->internal_entry?gsymt->link.module:gsymt)
->link.child_list;
/* If already visited, do not visit its
children, but give note to reader if it
has some. */
if(gsymt->visited) {
if(print_call_tree && child_list != NULL)
fprintf(list_fd," (see above)");
}
else {
/* Mark node as visited */
gsymt->visited = TRUE;
/* Record that containing module
is visited via this entry point*/
if(gsymt->internal_entry)
gsymt->link.module->visited_somewhere = TRUE;
else
gsymt->visited_somewhere = TRUE;
++level; /* move to next level */
while(child_list != NULL) {
visit_child(child_list->child,level);
child_list = child_list->next;
}
}
}
/* Insertion sort of child list.
Also removes duplicates which
can be introduced via multiple
defns or via project files. */
PRIVATE void
sort_child_list(child_list)
ChildList *child_list;
{
ChildList *front,*prev,*next;
Gsymtab *temp;
prev = NULL;
while(child_list != NULL) {
/* Scan thru list for lexicographically lowest name */
front=child_list;
for(next=child_list->next; next != NULL; next = next->next) {
if(strcmp(front->child->name,next->child->name) > 0) {
front = next;
}
}
/* Swap child pointers so front is first */
if(front != child_list) {
temp = front->child;
front->child = child_list->child;
child_list->child = temp;
}
/* If duplicate, remove from list */
if(prev != NULL && prev->child == child_list->child)
prev->next = child_list->next;
else
prev = child_list;
child_list = child_list->next;
}
}