pgsymtab.c

这是一个Linux下的集成开发环境

/*

Copyright (c) 2000, Red Hat, Inc.

This file is part of Source-Navigator.

Source-Navigator is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License as published
by the Free Software Foundation; either version 2, or (at your option)
any later version.

Source-Navigator is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License along
with Source-Navigator; see the file COPYING.  If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
MA 02111-1307, USA.



*/

/* pgsymtab.c:

		Routines associated with printing of global symbol table info

    Copyright (C) 1993 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.
		check_com_usage() Checks usage status of common blocks & vars


	Private functions defined:
		arg_array_cmp()	  Compares arg lists of subprog calls/defns
		com_cmp_lax()	  Compares common blocks at strictness 1,2
		com_cmp_strict()  Compares common blocks at strictness 3
		com_element_usage() Checks set/used status of common variables
		com_block_usage() Checks for dead common blocks & variables
		print_modules()	  Prints names from a list of gsymt pointers.
		sort_gsymbols()	  Sorts the list of gsymt names.
		swap_gsymptrs()	  Swaps a pair of pointers.
		visit_child()	  Recursively visits callees of module,
				  printing call tree as it goes.
		visit_child_reflist() Recursively visits callees of module,
				  printing reference list as it goes.
		print_crossrefs() Prints list of callers of module.
		toposort()	  Topological sort of call tree.
		sort_child_list() Sorts linked list of callees.
*/

#include <stdio.h>
#include <ctype.h>
#include <string.h>

#include <tcl.h>

#include "ftnchek.h"
#define PGSYMTAB
#include "symtab.h"


PRIVATE void
com_cmp_lax(),com_cmp_strict(), arg_array_cmp(),
visit_child(),visit_child_reflist(),sort_child_list();

PRIVATE void
print_crossrefs(),sort_gsymbols(),swap_gsymptrs();

PRIVATE int
toposort();

PRIVATE void
com_element_usage(), com_block_usage(), print_modules();


		/* 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)

#define pluralize(n) ((n)==1? "":"s")	/* singular/plural suffix for n */

#define CMP_ERR_LIMIT 3	/* stop printing errors after this many */

static void * SN_calloc (int size1, int size2)
{
	void * p;
	p = (void*)ckalloc (size1*size2);
	memset (p, 0, size1*size2);
	return p;
}

PRIVATE int cmp_error_count;
PRIVATE int
cmp_error_head(name,message)
     char *name,*message;
	/* Increment error count, and if it is 1, print header for arg
	   mismatch error messages.  If it is past limit, print "etc"
	   and return TRUE, otherwise return FALSE.
	   */
{
		/* stop after limit: probably a cascade */
	if(++cmp_error_count > CMP_ERR_LIMIT) {
	  fprintf(list_fd,"\n etc...");
	  return TRUE;
	}
	if(cmp_error_count == 1)
	  fprintf(list_fd,"\nSubprogram %s: %s",name,message);
	return FALSE;
}
PRIVATE void
arg_error_locate(alh)	/* Gives module, line, filename for error messages */
     ArgListHeader *alh;
{
  if(novice_help)		/* oldstyle messages */
    fprintf(list_fd," in module %s line %u file %s",
		    alh->module->name,
		    alh->line_num,
		    alh->filename);
  else				/* lint-style messages */
    fprintf(list_fd," in module %s of \"%s\", line %u",
		    alh->module->name,
		    alh->filename,
		    alh->line_num);
}

PRIVATE void
com_error_locate(clh)	/* Gives module, line, filename for error messages */
     ComListHeader *clh;
{
  if(novice_help)		/* oldstyle messages */
    fprintf(list_fd," in module %s line %u file %s",
		    clh->module->name,
		    clh->line_num,
		    clh->filename);
  else				/* lint-style messages */
    fprintf(list_fd," in module %s of \"%s\", line %u",
		    clh->module->name,
		    clh->filename,
		    clh->line_num);
}

PRIVATE void
arg_array_cmp(name,args1,args2)
     		/* Compares subprogram calls with definition */
	char *name;
	ArgListHeader *args1, *args2;
{
	int i;
	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 (check_args_number && n1 != n2){
	  cmp_error_count = 0;
	  (void) cmp_error_head(name,"varying number of arguments:");

	  fprintf(list_fd,"\n    %s with %d argument%s",
		    args1->is_defn? "Defined":"Invoked",
	    	    n1,pluralize(n1));
	  arg_error_locate(args1);

	  fprintf(list_fd,"\n    %s with %d argument%s",
		    args2->is_defn? "Defined":"Invoked",
		    n2,pluralize(n2));
	  arg_error_locate(args2);
	}

	if(check_args_type)
	{	/* Look for type mismatches */
	    cmp_error_count = 0;
	    for (i=0; i<n; i++) {
	      int c1 = storage_class_of(a1[i].type),
	          c2 = storage_class_of(a2[i].type),
		  t1 = datatype_of(a1[i].type),
	          t2 = datatype_of(a2[i].type),
		  s1 = a1[i].size,
		  s2 = a2[i].size,
		  defsize1 = (s1==size_DEFAULT),
		  defsize2 = (s2==size_DEFAULT);
				/* cmptype is type to use for mismatch test.
				   Basically cmptype=type but DP matches
				   REAL, DCPX matches CPLX, and hollerith
				   matches any numeric or logical type
				   but not  character.  The single/double
				   match will be deferred to size check. */
	      int cmptype1= (t1==type_HOLLERITH && t2!=type_STRING)?
				t2:type_category[t1];
	      int cmptype2= (t2==type_HOLLERITH && t1!=type_STRING)?
				t1:type_category[t2];

		/* If -portability, do not translate default sizes so
		   they will never match explicit sizes. */
	      if(!(port_check || local_wordsize==0)) {
		if(defsize1)
		  s1 = type_size[t1];
		if(defsize2)
		  s2 = type_size[t2];
	      }

	      if(s1 < 0 || s2 < 0) { /* char size_ADJUSTABLE or UNKNOWN */
		s1 = s2 = size_DEFAULT;	/* suppress warnings on size */
		defsize1 = defsize2 = TRUE;
	      }

			 /* Require exact match between storage classes and
			    compatible data type.  If that is OK, then for
			    non-char args require exact size match.  For char
			    and hollerith defer size check to other section.
			  */
	    if( (c1 != c2) || (cmptype1 != cmptype2) || ( (s1 != s2) &&
			is_num_log_type(t1) && is_num_log_type(t2) ) ) {

		if(cmp_error_head(name," argument data type mismatch"))
		  break;

		fprintf(list_fd, "\n  at position %d:", i+1);
		fprintf(list_fd,"\n    %s type %s",
			    args1->is_defn? "Dummy": "Actual",
			    type_name[t1]);
		if(!defsize1)
		  fprintf(list_fd,"*%d",s1);
		fprintf(list_fd," %s",
			class_name[storage_class_of(a1[i].type)]);
		arg_error_locate(args1);

		fprintf(list_fd,"\n    %s type %s",
			    args2->is_defn? "Dummy": "Actual",
			    type_name[t2]);
		if(!defsize2)
		  fprintf(list_fd,"*%d",s2);
		fprintf(list_fd," %s",
			class_name[storage_class_of(a2[i].type)]);
		arg_error_locate(args2);

		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    (possibly it is an array which was not declared)");
	      }
				/* If no class/type/elementsize clash,
				   and if comparing dummy vs. actual,
				   check character and hollerith sizes */
	      else if(args1->is_defn) {
				/* Character: check size but skip *(*)
				   and dummy array vs. actual array element.
				 */
		if(t1 == type_STRING && s1 > 0 && s2 > 0 &&
		  !(a1[i].array_var && a2[i].array_element)) {
		    unsigned long
		      dims1,dims2,size1,size2;

		    if(a1[i].array_var) {
		      dims1 = array_dims(a1[i].info.array_dim);
		      size1 = array_size(a1[i].info.array_dim);
		    }
		    else {
		      dims1 = 0;
		      size1 = 1;
		    }
		    if(a2[i].array_var && !a2[i].array_element) {
		      dims2 = array_dims(a2[i].info.array_dim);
		      size2 = array_size(a2[i].info.array_dim);
		    }
		    else {
		      dims2 = 0;
		      size2 = 1;
		    }

				/* standard requires dummy <= actual size.
			         */
		  if( (s1*size1 > s2*size2 &&
		      (dims1==0 || size1>1) && (dims2==0 || size2>1)) ) {

		    if(cmp_error_head(name," argument mismatch"))
				break;

		    fprintf(list_fd, "\n  at position %d:", i+1);
		    fprintf(list_fd,"\n    Dummy type %s*%d",
			    type_name[t1],s1);
		    if(dims1 > 0)
		      fprintf(list_fd,"(%d)",size1);
		    arg_error_locate(args1);

		    fprintf(list_fd,"\n    Actual type %s*%d",
			    type_name[t2],s2);
		    if(dims2 > 0)
		      fprintf(list_fd,"(%d)",size2);
		    arg_error_locate(args2);
		  }/*end if char size mismatch*/
		}/*end if type==char*/

		else if(t2 == type_HOLLERITH) {
			/* Allow hollerith to match any noncharacter type of
			   at least equal aggregate size.  */
		    unsigned long dims1,size1;
		    if(a1[i].array_var) {
		      dims1 = array_dims(a1[i].info.array_dim);
		      size1 = array_size(a1[i].info.array_dim);
		    }
		    else {
		      dims1 = 0;
		      size1 = 1;
		    }
		    if(s2 > s1*size1 && (dims1==0 || size1>1)) {

		      if(cmp_error_head(name," argument mismatch"))
				break;

		      fprintf(list_fd, "\n  at position %d:", i+1);
		      fprintf(list_fd,"\n    Dummy type %s",
			    type_name[t1]);
		      if(!defsize1)
			fprintf(list_fd,"*%d",s1);
		      if(dims1 > 0)
			fprintf(list_fd,"(%d)",size1);
		      arg_error_locate(args1);

		      fprintf(list_fd,"\n    Actual type %s*%d",
			    type_name[t2],s2);
		      arg_error_locate(args2);
		    }/*end if holl size mismatch*/
		}/*end if type==holl*/
	      }
	    }/*end for i*/
	}/* end look for type && size mismatches */


		 /* Check arrayness of args only if defn exists */
	if(check_args_type && args1->is_defn ) {
	    cmp_error_count = 0;
	    for (i=0; i<n; i++) {
			/* Skip if class or datatype mismatch.  This
			   also skips holleriths which were checked above.
			   Do not process externals.
			 */
	      if(datatype_of(a2[i].type) != type_HOLLERITH &&
		 storage_class_of(a1[i].type) == class_VAR &&
		 storage_class_of(a2[i].type) == class_VAR) {

		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) {

			      if(cmp_error_head(
				      name," argument arrayness mismatch"))
				break;

			      fprintf(list_fd,"\n  at position %d:", i+1);

			      fprintf(list_fd,"\n    Dummy arg is whole array");
			      arg_error_locate(args1);

			      fprintf(list_fd,"\n    Actual arg is array element");
			      arg_error_locate(args2);
			    }
			}/* end case I.A. */

			else {
					/*   B. Actual arg is whole array */
					/*	Warn if dims or sizes differ */
			  unsigned long
			    diminfo1,diminfo2,dims1,dims2,size1,size2,
			    cmpsize1,cmpsize2;
			  diminfo1 = a1[i].info.array_dim;
			  diminfo2 = a2[i].info.array_dim;
			  dims1 = array_dims(diminfo1);
			  dims2 = array_dims(diminfo2);
			  cmpsize1 = size1 = array_size(diminfo1);
			  cmpsize2 = size2 = array_size(diminfo2);
				/* For char arrays relevant size is no. of
				   elements times element size. But use
				   no. of elements if *(*) involved. */
			  if(datatype_of(a1[i].type) == type_STRING
			     && a1[i].size > 0 && a2[i].size > 0) {
			    cmpsize1 *= a1[i].size;
			    cmpsize2 *= a2[i].size;
			  }

			/* size = 0 or 1 means variable-dim: OK to differ */
			  if( (check_array_size &&
				  (size1>1 && size2>1 && cmpsize1 != cmpsize2))
			     || (check_array_dims &&
				  (dims1 != dims2)) ) {


				if(cmp_error_head(
					name," argument arrayness mismatch"))
				      break;

				fprintf(list_fd,"\n  at position %d:", i+1);

				fprintf(list_fd,
					"\n    Dummy arg %ld dim%s size %ld",
					dims1,pluralize(dims1),
					size1);
				if(datatype_of(a1[i].type) == type_STRING &&
				   a1[i].size > 0)
				  fprintf(list_fd,"*%d",a1[i].size);
				arg_error_locate(args1);

				fprintf(list_fd,
					"\n    Actual arg %ld dim%s size %ld",
					dims2,pluralize(dims2),
					size2);
				if(datatype_of(a2[i].type) == type_STRING
				   && a2[i].size > 0)
				  fprintf(list_fd,"*%d",a2[i].size);
				arg_error_locate(args2);
			  }/* end if size mismatch */
			}/* end case I.B. */
		    }
		    else {
					/*   C. Actual arg is scalar */
					/*	Warn in all cases */

		      	if(cmp_error_head(
				name," argument arrayness mismatch"))
			  break;

			fprintf(list_fd,"\n  at position %d:", i+1);

			fprintf(list_fd,"\n    Dummy arg is array");
			arg_error_locate(args1);

			fprintf(list_fd,"\n    Actual arg is scalar");
			arg_error_locate(args2);
		    }/* end case I.C. */
		} /* end dummy is array, case I. */

		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 */

			  if(cmp_error_head(
				   name," argument arrayness mismatch"))
			    break;

			  fprintf(list_fd,"\n  at position %d:", i+1);

			  fprintf(list_fd,"\n    Dummy arg is scalar");
			  arg_error_locate(args1);

			  fprintf(list_fd,"\n    Actual arg is whole array");
			  arg_error_locate(args2);

			}/* end case II.B. */
		    }
		    else {
					/*   C. Actual arg is scalar */
					/*	OK */
		    }

		} /* end dummy is scalar, case II */

	      } /* 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) {

	    cmp_error_count = 0;
	    for (i=0; i<n; i++) {
	      if(storage_class_of(a1[i].type) == class_VAR &&
		 storage_class_of(a2[i].type) == class_VAR ) {
		int nonlvalue_out = (a1[i].assigned_flag && !a2[i].is_lvalue),
		    nonset_in = (a1[i].used_before_set && !a2[i].set_flag);

#if DEBUG_PGSYMTAB
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) {

		  if(cmp_error_head(name," argument usage mismatch"))
		     break;

		  fprintf(list_fd,"\n  at position %d:", i+1);

		  if(nonlvalue_out) {
		    fprintf(list_fd,"\n    Dummy arg is modified");
		    arg_error_locate(args1);

		    fprintf(list_fd,"\n    Actual arg is const or expr");
		    arg_error_locate(args2);
		  }
		  else if(nonset_in) {

		    fprintf(list_fd,"\n    Dummy arg used before set");
		    arg_error_locate(args1);

		    fprintf(list_fd,"\n    Actual arg not set");
		    arg_error_locate(args2);
		  }
		}
	      }
	    }
	}/*end if(check_set_used && args->is_defn) */

}/* arg_array_cmp */