symtab.c

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

}/* note_filename */



void
process_lists(curmodhash)  /* Places pointer to linked list of arrays in
			      global symbol table */
	int curmodhash;    /* current_module_hash from fortran.y */
{
	int i, h;
	unsigned long hnum;
	Gsymtab *curr_gsymt;

	Gsymtab *gsymt;
	TokenListHeader *head_ptr;

	if( (curr_gsymt=
	     (curmodhash == -1) ? NULL:hashtab[curmodhash].glob_symtab)
	   == NULL) {
	  oops_message(OOPS_NONFATAL,NO_LINE_NUM,NO_COL_NUM,
		  "module not in global symtab:");
	  oops_tail(hashtab[curmodhash].name);
	}
	else {
	  if(curr_gsymt->internal_entry) {/* protect ourself */
	    warning(NO_LINE_NUM,NO_COL_NUM,
		    "entry point redefined as module");
	    msg_tail(curr_gsymt->name);
	    msg_tail(": previous definition overridden");
	    curr_gsymt->link.child_list = NULL;
	  }
	  curr_gsymt->internal_entry = FALSE;
	}

	for (i=0; i<loc_symtab_top; i++){
				/* Skip things which are not true externals */
	    if(loc_symtab[i].argument || loc_symtab[i].intrinsic ||
		   loc_symtab[i].array_var)
		      continue;

	    head_ptr = loc_symtab[i].info.toklist;

	    hnum=hash(loc_symtab[i].name);
	    while(h=hnum%HASHSZ,hashtab[h].name != NULL
		 && strcmp(hashtab[h].name,loc_symtab[i].name)!=0){
		      hnum = rehash(hnum);      /* Resolve clashes */
	    }

	    switch (storage_class_of(loc_symtab[i].type)){
		    case class_COMMON_BLOCK:
			if(head_ptr != NULL) {
if((gsymt=hashtab[h].com_glob_symtab) == NULL) {
    oops_message(OOPS_NONFATAL,NO_LINE_NUM,NO_COL_NUM,
		 "common block not in global symtab:");
    oops_tail(loc_symtab[i].name);
}
else {
			Token *tok_ptr;
                        ComListHeader *c;

				/* First we link up possibly multiple
				   declarations of the same common block
				   in this module into one big list */
		    	while (tok_ptr = head_ptr->tokenlist,
			       (head_ptr = head_ptr->next) != NULL){
			    while(tok_ptr->next_token != NULL){
			        tok_ptr = tok_ptr->next_token;
			    }
			    tok_ptr->next_token = head_ptr->tokenlist;
			}

				/* Now make it into array for global table */
		        c=make_com_array(loc_symtab[i].info.toklist->tokenlist);
			c->module = curr_gsymt;
			c->line_num = loc_symtab[i].info.toklist->line_num;
			c->filename = loc_symtab[i].info.toklist->filename;
			c->topfile = top_filename;
			c->saved = global_save || loc_symtab[i].saved;

                        c->next = gsymt->info.comlist;
			gsymt->info.comlist = c;
		/* Replace token list by comlist for project file use */
			loc_symtab[i].info.comlist = c;
}
			}/* end if(head_ptr != NULL) */

		        break;	/* end case class_COMMON_BLOCK */


			/* Are we inside a function or subroutine? */
		    case class_VAR:
		       if(loc_symtab[i].entry_point) {
if((gsymt=hashtab[h].glob_symtab) == NULL) {
    oops_message(OOPS_NONFATAL,NO_LINE_NUM,NO_COL_NUM,
    "subprog not in global symtab:");
    oops_tail(loc_symtab[i].name);
}
else {
                          ArgListHeader *a;
			  int implied_type;

				/* Make each token list into an array of
				   args for global table */
			  while (head_ptr != NULL){
			     a=make_dummy_arg_array(head_ptr->tokenlist);
			     implied_type = get_type(&(loc_symtab[i]));
			     a->type = type_byte(
			         class_SUBPROGRAM,implied_type);
			     a->size = get_size(&(loc_symtab[i]),implied_type);
			     a->module = curr_gsymt;
			     a->filename = head_ptr->filename;
			     a->topfile = top_filename;
			     a->line_num = head_ptr->line_num;

			     a->next = gsymt->info.arglist;
			     gsymt->info.arglist = a;
			/* store arglist in local symtab for project file */
			     loc_symtab[i].info.arglist = a;
			     head_ptr = head_ptr->next;
		          }/* end while (head_ptr != NULL) */

			  if(loc_symtab[i].set_flag)
			         gsymt->set_flag = TRUE;
			  if(loc_symtab[i].used_flag)
			         gsymt->used_flag = TRUE;
			  if(loc_symtab[i].declared_external)
				 gsymt->declared_external = TRUE;
			  if(loc_symtab[i].library_module)
				 gsymt->library_module = TRUE;
			  if(gsymt != curr_gsymt) {
			    gsymt->internal_entry = TRUE;
			    gsymt->link.module = curr_gsymt;
			  }
}
			}/* end if(loc_symtab[i].entry_point) */

		    	break; /* end case class_VAR */

                    case class_SUBPROGRAM:
if((gsymt=hashtab[h].glob_symtab) == NULL)
 {
    oops_message(OOPS_NONFATAL,NO_LINE_NUM,NO_COL_NUM,
    "subprog not in global symtab:");
    oops_tail(loc_symtab[i].name);
}
else {
                        ArgListHeader *a;
			int implied_type;
			while (head_ptr != NULL){
			  if(head_ptr->external_decl || head_ptr->actual_arg)
			    a=make_arrayless_alist();
			  else
			    a=make_arg_array(head_ptr->tokenlist);

			  implied_type = get_type(&(loc_symtab[i]));
			  a->type = type_byte(
			         class_SUBPROGRAM,implied_type);
			  a->size = get_size(&(loc_symtab[i]),implied_type);
			  a->module = curr_gsymt;
			  a->filename = head_ptr->filename;
			  a->topfile = top_filename;
			  a->line_num = head_ptr->line_num;
			  a->external_decl = head_ptr->external_decl;
			  a->actual_arg = head_ptr->actual_arg;

			  a->next = gsymt->info.arglist;
			  gsymt->info.arglist = a;
		/* put arglist into local symtab for project file use */
			  loc_symtab[i].info.arglist = a;
			  head_ptr = head_ptr->next;
		        }
			if(loc_symtab[i].used_flag)
			        gsymt->used_flag = TRUE;
if(debug_glob_symtab)
fprintf(list_fd,"\nmodule %s local used=%d global used=%d",
gsymt->name,loc_symtab[i].used_flag,gsymt->used_flag);
}
				/* Add this guy to linked list of children,
				   unless never actually used. */
			if(loc_symtab[i].used_flag) {
			  ChildList *node=
			    (ChildList *)SN_calloc(1,sizeof(ChildList));
			  node->child = gsymt;
			  node->next = curr_gsymt->link.child_list;
			  curr_gsymt->link.child_list = node;
			}

			break;/* end case class_SUBPROGRAM*/

	    }/* end switch */

        }/* end for (i=0; i<loc_symtab_top; i++) */

}/* process_lists */


void
ref_array(id,subscrs)   /* Array reference: install in symtab */
	Token *id, *subscrs;
{
	int h=id->value.integer;
	Lsymtab *symt=hashtab[h].loc_symtab;

	if(symt == NULL){
	   oops_message(OOPS_NONFATAL,line_num,NO_COL_NUM,
		       "undeclared variable has dim info:");
	   oops_tail(hashtab[h].name);
	   symt = install_local(id,h,type_UNDECL,class_VAR);
	}
	else{    /* check that subscrs match dimension info */


	  if(arg_count(subscrs->next_token)!=array_dims(symt->info.array_dim)){
	      syntax_error(subscrs->line_num,subscrs->col_num,
			"array");
	      msg_tail(symt->name);
	      msg_tail("referenced with wrong no. of subscripts");
	  }
	}
}/* ref_array */

void
ref_namelist(id,stmt_class)
     Token *id;
     int stmt_class;
{
	Token *t;
	TokenListHeader *toklist;
	int h=id->value.integer;
	Lsymtab *symt=hashtab[h].loc_symtab;
	if(symt == NULL){
	   oops_message(OOPS_NONFATAL,line_num,NO_COL_NUM,
			"undeclared identifier is a namelist:");
	   oops_tail(hashtab[h].name);
	   symt = install_local(id,h,type_NAMELIST,class_NAMELIST);
	   symt->info.toklist = NULL;
	}

			/* Go thru token list of namelist variables,
			   setting flags appropriately. */
	toklist = symt->info.toklist;
	if (toklist != NULL){
	    t = toklist->tokenlist;
	    while(t != NULL){
	        if(stmt_class == tok_READ)
		  use_lvalue(t);
		else
		  use_variable(t);
		t = t->next_token;
	    }
	}
}

void
ref_variable(id)	/* Variable reference: install in symtab */
	Token *id;
{
	int h=id->value.integer;

	if( hashtab[h].loc_symtab == NULL) {
	   (void) install_local(id,h,type_UNDECL,class_VAR);
	}

}/*ref_variable*/

		/* this guy reverses a tokenlist and returns a pointer
		   to the new head. */
PRIVATE Token *
reverse_tokenlist(t)
	Token *t;
{
	Token *curr,*next,*temp;

	if(t == NULL)
	    return t;

	curr = t;
	next = curr->next_token;
	while(next != NULL) {
		temp = next->next_token;
		next->next_token = curr;
		curr = next;
		next = temp;
	}
	t->next_token = NULL;		/* former head is now tail */
	return curr;			/* curr now points to new head */
}

void
save_com_block(id)	/* Process SAVEing of a common block */
	Token *id;	/* N.B. Legality checking deferred to END */
{
	int h=id->value.integer;
	Lsymtab *symt;

			/* N.B. SAVE does not create a global table entry */
	if( (symt = hashtab[h].com_loc_symtab) == NULL){
	   symt = install_local(id,h,type_COMMON_BLOCK,class_COMMON_BLOCK);
	   symt->info.toklist = NULL;
	}

	if(symt->saved) {
	  syntax_error(id->line_num,id->col_num,
		       "redundant SAVE declaration");
	}
	else
	  symt->saved = TRUE;
}

void
save_variable(id)	/* Process SAVEing of a variable */
	Token *id;	/* N.B. Legality checking deferred to END */
{
	int h=id->value.integer;
	Lsymtab *symt;

	if( (symt=hashtab[h].loc_symtab) == NULL) {
	   symt = install_local(id,h,type_UNDECL,class_VAR);
	}

	if(symt->saved) {
	  syntax_error(id->line_num,id->col_num,
		       "redundant SAVE declaration");
	}
	else {		/* set flags for all equivalenced vars */
	  Lsymtab *equiv=symt;
	  do{
	    equiv->saved = TRUE;
	    equiv = equiv->equiv_link;
	  } while(equiv != symt);
	}
}

	/* Following routine sets the implicit typing of characters in
	   range c1 to c2 to the given type. */
void
set_implicit_type(type,size,c1,c2)
	int type;		/* Data type of IMPLICIT declaration */
        long size;		/* Type size or size_DEFAULT if not given */
	int c1;			/* First character of range */
	int c2;			/* Last character of range */
{
	int c;
#if ALLOW_DOLLARSIGNS
	  if(c1 == '$')  c1 = 'Z'+1;
	  if(c2 == '$')  c2 = 'Z'+1;
#endif
#if ALLOW_UNDERSCORES
	  if(c1 == '_')  c1 = 'Z'+2;
	  if(c2 == '_')  c2 = 'Z'+2;
#endif
	if(c2 < c1) {
		yyerror("IMPLICIT range must be in alphabetical order");
	}
	else {
		/* Fill in the lookup table for the given range of chars */
	  for(c=c1; c<=c2; c++) {
		implicit_type[c-'A'] = type;
		implicit_size[c-'A'] = size;
	  }
	}
}/*set_implicit_type*/

		/* Finish processing statement function.
		   Clears all used-before-set flags of ordinary
		   variables. Reason: statement functions are processed
		   like assignment to an array element, setting ubs flags.
		   At this point, no valid setting of ubs flags should
		   be possible, so clearing them will elim false messages.*/
void
stmt_function_stmt(id)
     Token *id;			/* Not used at present */
{
    int i;
    for(i=0; i<loc_symtab_top; i++) {
	if(storage_class_of(loc_symtab[i].type) == class_VAR &&
	   ! loc_symtab[i].parameter )
	  loc_symtab[i].used_before_set = FALSE;
    }
}/*stmt_function_stmt(id)*/

char *
token_name(t)
	Token t;
{
	return hashtab[t.value.integer].name;
}/*token_name*/




void
use_actual_arg(id)	/* like use_lvalue except does not set assigned_flag */
	Token *id;
{
	int h=id->value.integer;
	Lsymtab *symt;

	if((symt=hashtab[h].loc_symtab) == NULL) {
	    symt = install_local(id,h,type_UNDECL,class_VAR);
	}
	else {
			/* If an external other than an intrinsic, set up
			   tokenlist for "call".  If intrinsic, check
			   legality of this usage.) */
	  if(storage_class_of(symt->type) == class_SUBPROGRAM) {
	    if(symt->intrinsic) {
	      IntrinsInfo *defn = symt->info.intrins_info;
	      if( !(symt->declared_intrinsic) ) {
		warning(id->line_num,id->col_num,
				defn->name);
		msg_tail("not declared INTRINSIC");
	      }
	      if( (defn->intrins_flags&I_NOTARG) ) {
		syntax_error(id->line_num,id->col_num,
				defn->name);
		msg_tail("intrinsic function cannot be a subprogram argument");
	      }
	    }
	    else {		/* External subprogram as actual arg */
	      TokenListHeader *TH_ptr;
	      TH_ptr= make_TL_head(id);

	      TH_ptr->actual_arg = TRUE;
	      TH_ptr->next = symt->info.toklist;
	      symt->info.toklist = TH_ptr;
	    }
	  }
	}

    {		/* set flags for all equivalenced vars */
      Lsymtab *equiv=symt;
      do{
	equiv->set_flag = TRUE;
	equiv = equiv->equiv_link;
      } while(equiv != symt);
    }

	report( id, PAF_REF_PASS );

}/*use_actual_arg*/


void
use_function_arg(id)	/* Like use_variable but invokes use_actual_arg
			   if id is an external (subprogram) passed as
			   arg of a function. This routine is used when
			   pure_functions flag is set. */
	Token *id;
{
	int h=id->value.integer;
	Lsymtab *symt;

	if( (symt=hashtab[h].loc_symtab) == NULL) {
	   symt = install_local(id,h,type_UNDECL,class_VAR);
	}

	if(storage_class_of(symt->type) == class_SUBPROGRAM)
	  use_actual_arg(id);
	else
	  use_variable(id);

}/*use_function_arg*/

void
use_implied_do_index(id)
	Token *id;
{
		/* Like use_lvalue and use_variable but clears ubs flag.
	           This is because we cannot handle used-before-set
		   properly in this case, and the odds are that ubs
		   was set in the preceding I/O list. */
	int h=id->value.integer;
	Lsymtab *symt;

	use_lvalue(id);
	use_variable(id);
	symt=hashtab[h].loc_symtab;

	symt->used_before_set = FALSE;
}/*use_implied_do_index*/


	/* use_io_keyword handles keyword=value fields in i/o control lists */

#include "iokeywds.h"

void
use_io_keyword(keyword,value,stmt_class)
     Token *keyword,*value;
     int stmt_class;
{
    int i, k, stmt_flag=0, type_flag, setit,useit;
    int hkey=