pgsymtab.c

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

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

				/* Skip common blocks */
	    if(storage_class_of(glob_symtab[i].type) != class_SUBPROGRAM)
		continue;

				/* Skip unvisited library modules */
	    if(glob_symtab[i].library_module && !glob_symtab[i].visited)
		continue;


	    if((alist=glob_symtab[i].info.arglist) == NULL){
	      oops_message(OOPS_NONFATAL,NO_LINE_NUM,NO_COL_NUM,
		      "global symbol has no argument lists:");
	      oops_tail(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:\n    ",
				      glob_symtab[i].name);
			      arg_error_locate(defn_list);
			    }
			    fprintf(list_fd,"\n    ");
			    arg_error_locate(list_item);
			}
			++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    %s",
			     (defn_list->external_decl)?"declared":"invoked");
		     arg_error_locate(defn_list);

			/* 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    (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    defined");
			arg_error_locate(defn_list);
		    }
		}

			/* 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( check_args_type &&
		   defn_list->is_defn || !defn_list->external_decl) {
		  while(alist != NULL){
			int typerrs = 0;
			if(alist != defn_list && !alist->external_decl
			   && !irrelevant(alist)) {
			  int t1 = datatype_of(defn_list->type),
			      t2 = datatype_of(alist->type),
			      s1 = defn_list->size,
			      s2 = alist->size,
			      defsize1 = (s1 == size_DEFAULT),
			      defsize2 = (s2 == size_DEFAULT);
		/* 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){ /*size_ADJUSTABLE or UNKNOWN*/
			    s1 = s2 = size_DEFAULT;/* suppress size warnings */
			    defsize1 = defsize2 = TRUE;
			  }
				/* Check class, type, and size */
			  if(defn_list->type != alist->type ||
			     ( (s1 != s2) &&
				/*exclude char size-only mismatch betw calls */
			      (t1 != type_STRING ||
			        defn_list->is_defn || alist->is_defn )) ){

			    	if(typerrs++ == 0){
				  fprintf(list_fd,
				    "\nSubprogram %s invoked inconsistently:",
				     glob_symtab[i].name);
				  fprintf(list_fd,
				    "\n    %s type %s",
				    defn_list->is_defn? "Defined":"Invoked",
				    type_name[t1]);
				  if(!defsize1)
				    fprintf(list_fd,"*%d",s1);
				  arg_error_locate(defn_list);
				}
				fprintf(list_fd,
				    "\n    %s type %s",
				    alist->is_defn? "Defined":"Invoked",
				    type_name[t2]);
				if(!defsize2)
				  fprintf(list_fd,"*%d",s2);
				arg_error_locate(alist);
			  }
			}
			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, save_errors;
	ComListHeader *first_list, *model, *clist;

	if(check_com_off)
		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;
		save_errors = 0;
		while( clist != NULL ){
		    if(clist != model && !irrelevant(clist)) {

			/* If SAVEd in one module, must be SAVEd in all.
			   Main prog is an exception but warn anyway.
			   Only print warning once even if it occurs often. */
		      if(clist->saved != model->saved) {
			if(++save_errors == 1) {
			  fprintf(list_fd,
				"\nCommon block %s not SAVED consistently",
				glob_symtab[i].name);
			  fprintf(list_fd,
				  "\n    is %sSAVED",
				  model->saved?"":"not ");
			  com_error_locate(model);
			  fprintf(list_fd,
				  "\n    is %sSAVED",
				  clist->saved?"":"not ");
			  com_error_locate(clist);
			}
		      }

				/* Now check agreement of common lists */
			if(check_com_byname)
			  com_cmp_strict(glob_symtab[i].name,model,clist);
			else
			  com_cmp_lax(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 */
        size1,size2,		/* unit size of variable */
	word1,word2,		/* number of "words" scanned */
	words1,words2,		/* number of "words" in block */
        defsize1,defsize2,	/* default size used? */
	jump;			/* number of words to skip next in scan */
    int byte_oriented=FALSE,	/* character vs numeric block */
        type_clash;		/* flag for catching clashes */
    int n1=c1->numargs,n2=c2->numargs; /* variable count for each block */
    int numerrs;
    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++) {
      size1 = a1[i1].size;
      if(size1 == size_DEFAULT)
	size1 = type_size[a1[i1].type];
      else
	byte_oriented = TRUE;
      words1 += array_size(a1[i1].dimen_info)*size1;
    }
    for(i2=0; i2<n2; i2++) {
      size2 = a2[i2].size;
      if(size2 == size_DEFAULT)
	size2 = type_size[a2[i2].type];
      else
	byte_oriented = TRUE;
      words2 += array_size(a2[i2].dimen_info)*size2;
    }
	/* If not byte oriented, then sizes are all multiples of
	   BpW and can be reported as words according to F77 std. */
    if(!byte_oriented) {
      words1 /= BpW;
      words2 /= BpW;
    }
    if(check_com_lengths && words1 != words2) {
      fprintf(list_fd,
	      "\nCommon block %s: varying length:", name);
      fprintf(list_fd,
	      "\n    Has %ld %s%s",
		words1,
		byte_oriented? "byte":"word",
		pluralize(words1));
      com_error_locate(c1);
      fprintf(list_fd,
	      "\n    Has %ld %s%s",
		words2,
		byte_oriented? "byte":"word",
		pluralize(words2));
      com_error_locate(c2);
    }

				/* Now check type matches */
    done1=done2=FALSE;
    i1=i2=0;
    len1=len2=0;
    word1=word2=1;
    numerrs=0;
    for(;;) {
	if(len1 == 0) {		/* move to next variable in list 1 */
	    if(i1 == n1) {
		done1 = TRUE;
	    }
	    else {
		type1 = a1[i1].type;
		size1 = a1[i1].size;
		if(defsize1 = (size1 == size_DEFAULT))
		  size1 = type_size[type1];
		if(!byte_oriented)
		  size1 /= BpW;	/* convert bytes to words */
		len1 = array_size(a1[i1].dimen_info)*size1;
		++i1;
	    }
	}
	if(len2 == 0) {		/* move to next variable in list 2 */
	    if(i2 == n2) {
		done2 = TRUE;
	    }
	    else {
		type2 = a2[i2].type;
		size2 = a2[i2].size;
		if( defsize2 =(size2 == size_DEFAULT))
		  size2 = type_size[type2];
		if(!byte_oriented)
		  size2 /= BpW;
		len2 = array_size(a2[i2].dimen_info)*size2;
		++i2;
	    }
	}

	if(done1 || done2){	/* either list exhausted? */
	    break;		/* then stop checking */
	}

		/* Look for type clash.  Allow explicitly sized real to
		   match double of equal size.
		   Allow real to match complex whose parts are of equal size.
		   Within same type category, size diff counts as clash
		   except with char.
		   Also issue warning under -portability or -nowordsize
		   if an explicit size is matched to an implicit size. */
	type_clash = FALSE;
	if( (type_category[type1] == type_category[type2]) ) {
	  if( type1 != type_STRING &&
	      (size1 != size2
	       || ((port_check||local_wordsize==0) && defsize1 != defsize2))) {
	    type_clash = TRUE;
	  }
	}
	else /* different type categories */ {
				/* Equiv_type matches complex to real */
	  if(equiv_type[type1] != equiv_type[type2]) {
	    type_clash = TRUE;
	  }
	  else {
	    if( type_category[type1] == type_COMPLEX ) {
	      type_clash = (size1 != 2*size2);
	    }
	    else {
				/* 2nd block has complex */
	      type_clash = (size2 != 2*size1);
	    }
	  			/* Give warning anyway if default size
				   is matched to explicit. */
	    if( (port_check||local_wordsize==0) && defsize1 != defsize2 )
	      type_clash = TRUE;
	  }
	}

	if(type_clash) {
	     if(++numerrs > 3) {
	       fprintf(list_fd,"\netc...");
	       break;		/* stop checking after third mismatch */
	     }
	     if(numerrs == 1)
	       fprintf(list_fd,
		       "\nCommon block %s: data type mismatch",
		       name);
	     fprintf(list_fd,"\n    %s %ld is type %s",
		     byte_oriented?"Byte":"Word",
		     word1,
		     type_name[type1]);
	     if(!defsize1)
	       fprintf(list_fd,"*%d",
		       size1);
	     com_error_locate(c1);

	     fprintf(list_fd,"\n    %s %ld is type %s",
		     byte_oriented?"Byte":"Word",
		     word2,
		     type_name[type2]);
	     if(!defsize2)
	       fprintf(list_fd,"*%d",
		       size2);
	     com_error_locate(c2);
	}

			/* Advance along list by largest possible
			   step that does not cross a variable boundary.
			   If matching complex to real, only advance
			   the real part.
			 */
	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 level 3 */
	char *name;
	ComListHeader *c1, *c2;
{
	int i,
	    typerr,		/* count of type/size mismatches */
	    dimerr;		/* count of array dim/size mismatches */
	short n,
	      n1 = c1->numargs,
	      n2 = c2->numargs;
	ComListElement *a1 = c1->com_list_array,
		       *a2 = c2->com_list_array;

	n = (n1 > n2) ? n2: n1;
	if(n1 != n2){
	  fprintf(list_fd,
		  "\nCommon block %s: varying length:", name);
	  fprintf(list_fd,
		  "\n    Has %d variable%s",
		  n1,pluralize(n1));
	  com_error_locate(c1);

	  fprintf(list_fd,
		  "\n    Has %d variable%s",
		  n2,pluralize(n2));
	  com_error_locate(c2);
        }
#if DEBUG_PGSYMTAB
if(debug_latest){
fprintf(list_fd,"block %s",name);
fprintf(list_fd,"\n\t1=in module %s line %u file %s",
		    c1->module->name,
		    c1->line_num,
		    c1->filename);
fprintf(list_fd,"\n\t2=in module %s line %u file %s",
		    c2->module->name,
		    c2->line_num,
		    c2->filename);
}
#endif
	typerr = 0;
	for (i=0; i<n; i++) {
	  int 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);
		/* 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( t1 != t2 || s1 != s2 ) {
				/* stop after limit: probably a cascade */
			if(++typerr > CMP_ERR_LIMIT) {
				fprintf(list_fd,"\n etc...");
				break;
			}

		        if(typerr == 1)
			  fprintf(list_fd,
				  "\nCommon block %s: data type mismatch",
				  name);
			fprintf(list_fd, "\n  at position %d:", i+1);

			fprintf(list_fd,
				"\n    Variable has type %s",
				type_name[t1]);
			if(!defsize1)
			  fprintf(list_fd,"*%d",s1);
			com_error_locate(c1);

			fprintf(list_fd,
				"\n    Variable has type %s",
				type_name[t2]);
			if(!defsize2)
			  fprintf(list_fd,"*%d",s2);
			com_error_locate(c2);

		}/*end if(type or size mismatch)*/
	}/*end for(i=0; i<n; i++)*/


	dimerr = 0;
	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;
			}
			if(dimerr == 1)
			  fprintf(list_fd,