symtab.c

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

			/* Found in info table: set intrins flag and store
			   pointer to definition info. */
	     symt->intrinsic = TRUE;
	     symt->info.intrins_info = defn;
	   }
	}
	symt->declared_external = TRUE;
}/*def_intrins_name*/

void
def_namelist(id,list)		/* Process NAMELIST declaration */
     Token *id,*list;
{
	int h=id->value.integer;
	Lsymtab *symt;

	if( (symt=hashtab[h].loc_symtab) != NULL) {
	  syntax_error(id->line_num,id->col_num,
			"name is already in use");
	}
	else {
	  symt = install_local(id,h,type_NAMELIST,class_NAMELIST);
	  symt->info.toklist = NULL;
	  call_external(symt,id,list); /* attach list to symt->info.toklist */
	}

}/*def_namelist*/


void
def_namelist_item(id)		/* Process NAMELIST list elements */
	Token *id;
{
  ref_variable(id);		/* Put it in symtab */
}/*def_namelist_name*/


void				/* stub for future statement-label handler */
def_label(lab)
     Token *lab;
{
}

void
def_parameter(id,val)		/* Process parameter_defn_item */
	Token *id,*val;
{
	int h=id->value.integer;
	Lsymtab *symt;

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

	symt->set_flag = TRUE;
	symt->parameter = TRUE;

		/* Integer parameters: save value in symtab entry.  Other
		   types not saved.  Need these since used in array dims */
	switch(get_type(symt)) {
		case type_INTEGER:
			symt->info.int_value = int_expr_value(val);
#ifdef DEBUG_PARAMETERS
if(debug_latest)
fprintf(list_fd,"\nPARAMETER %s = %d",symt->name,symt->info.int_value);
#endif
			break;
			/* Character parameter: if declared adjustable
			   i.e. *(*) then inherit size of const */
		case type_STRING:
			if(symt->size == size_ADJUSTABLE
			   && datatype_of(val->class) == type_STRING)
			  symt->size = val->size;
			break;
		default:
			break;
	}

	if( highlight != -1 )	/* 13.05.96 Rigo */
	{
#if 1 /* Zsolt Koppany 14-oct-96 */
		put_symbol(PAF_CONS_DEF,
			NULL,
			hashtab[id->value.integer].name,
			current_filename,
			id->line_num,
			id->curr_index,
			0,0,
			(long)0,
			datatype_name(symt->type),NULL,NULL,
			get_comment(current_filename,id->line_num),
			0,0,0,0);
#else
		if( current_module_hash == -1 )
		{
			put_symbol(PAF_CONS_DEF,
					NULL,
					hashtab[id->value.integer].name,
					current_filename,
					id->line_num,
					id->curr_index,
					0,0,
					(long)0,
					datatype_name(symt->type),NULL,NULL,
					get_comment(current_filename,id->line_num),
					0,0,0,0);
		}
		else
		{
			put_symbol(PAF_CONS_DEF,
					hashtab[current_module_hash].name,
					hashtab[id->value.integer].name,
					current_filename,
					id->line_num,
					id->curr_index,
					0,0,
					(long)0,
					datatype_name(symt->type),NULL,NULL,
					get_comment(current_filename,id->line_num),
					0,0,0,0);
		}
#endif /* Zsolt Koppany 14-oct-96 */
	}
}/*def_parameter*/



void    	       /* Installs statement function name in local table */
def_stmt_function(id, args)
	Token *id, *args;
{
	int t,h=id->value.integer;
	Lsymtab *symt;
   	TokenListHeader *TH_ptr;

   	if((symt = (hashtab[h].loc_symtab)) == NULL) {
			/* Symbol is new to local symtab: install it. */

	   symt = install_local(id,h,type_UNDECL,class_STMT_FUNCTION);
	   symt->info.toklist = NULL;
	}
	else {
	  if(storage_class_of(symt->type) == class_VAR) {
	    symt->info.toklist = NULL;
	  }
	}

		/* Save dummy arg list in symbol table */
    	TH_ptr= make_TL_head(id);

	TH_ptr->tokenlist = (args == NULL ? NULL: args->next_token);
	TH_ptr->next = symt->info.toklist;
	symt->info.toklist = TH_ptr;

		/* Reverse the token list for sake of checking phase */
	TH_ptr->tokenlist = reverse_tokenlist(TH_ptr->tokenlist);

	t=datatype_of(symt->type);
		/* Symbol seen before: check it & change class */

		/* check, check, check ... */
	if(storage_class_of(symt->type) == class_VAR)
	   symt->type = type_byte(class_STMT_FUNCTION,t);

	symt->external = TRUE;
}/*def_stmt_function*/




void
do_ASSIGN(id)		/* Process ASSIGN statement */
	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(get_type(symt) != type_INTEGER) {
	      syntax_error(id->line_num,id->col_num,
		"Variable must be an integer: ");
	      msg_tail(symt->name);
	   }
	}
    {		/* set flags for all equivalenced vars */
      Lsymtab *equiv=symt;
      do{
	equiv->set_flag = TRUE;
	equiv = equiv->equiv_link;
      } while(equiv != symt);
    }
}/*do_ASSIGN*/




void
do_assigned_GOTO(id)		/* Process assigned_goto */
	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(get_type(symt) != type_INTEGER) {
	      syntax_error(id->line_num,id->col_num,
		"Variable must be an integer: ");
	      msg_tail(symt->name);
	   }
	}
    {		/* set flags for all equivalenced vars */
      Lsymtab *equiv=symt;
      do{
	if(! equiv->set_flag)
	   equiv->used_before_set = TRUE;
	equiv->used_flag = TRUE;
	equiv = equiv->equiv_link;
      } while(equiv != symt);
    }

}/*do_assigned_GOTO*/





void
do_ENTRY(id,args,hashno)	/* Processes ENTRY statement */
	Token *id,*args;
	int hashno;
{
	int datatype;
	if(hashno == -1) {	/* -1 signifies headerless program */
	    datatype = type_PROGRAM;
	}
	else {
	    datatype = datatype_of(hashtab[hashno].loc_symtab->type);
	}
	switch(datatype) {
	    case type_PROGRAM:
	    case type_BLOCK_DATA:
	    case type_COMMON_BLOCK:
	        syntax_error(id->line_num,NO_COL_NUM,
			"You cannot have an entry statement here");
		break;
	    case type_SUBROUTINE:	/* Subroutine entry */
		def_function(type_SUBROUTINE,size_DEFAULT,id,args);
		break;
	    default:		/* Function entry */
		def_function(type_UNDECL,size_DEFAULT,id,args);
		break;
	}
}/*do_ENTRY*/




	/* This routine checks whether a RETURN statement is valid at
	   the present location, and if it is, looks for possible
	   failure to assign return value of function.
	*/
void
do_RETURN(hashno,keyword)
	int hashno;	/* current module hash number */
	Token *keyword;	/* tok_RETURN, or tok_END if implied RETURN */
{
	int i,datatype;
	if(hashno == -1) {	/* -1 signifies headerless program */
	    datatype = type_PROGRAM;
	}
	else {
	    datatype = datatype_of(hashtab[hashno].loc_symtab->type);
	}
	switch(datatype) {
	    case type_PROGRAM:
	    case type_BLOCK_DATA:
		if(keyword->class == tok_RETURN)
		    syntax_error(keyword->line_num,keyword->col_num,
		    	"You cannot have a RETURN statement here!");
		break;
	    case type_SUBROUTINE:	/* Subroutine return: OK */
		break;
	    default:		/* Function return: check whether entry
				   points have been assigned values. */
		for(i=0; i<loc_symtab_top; i++) {
		    if(storage_class_of(loc_symtab[i].type) == class_VAR
			&& loc_symtab[i].entry_point
			&& ! loc_symtab[i].set_flag ) {
			    warning(keyword->line_num,keyword->col_num,
					loc_symtab[i].name);
			    msg_tail("not set when RETURN encountered");
		    }
		}
		break;
	}

}/*do_RETURN*/

void
equivalence(id1,id2)
     Token *id1, *id2;
{
	int h1=id1->value.integer, h2=id2->value.integer;
	Lsymtab *symt1,*symt2,*temp;

		/* install the variables in symtab if not seen before */
	if( (symt1=hashtab[h1].loc_symtab) == NULL) {
	   symt1 = install_local(id1,h1,type_UNDECL,class_VAR);
	}
	if( (symt2=hashtab[h2].loc_symtab) == NULL) {
	   symt2 = install_local(id2,h2,type_UNDECL,class_VAR);
	}
			/* Check for legality.  Ought to do complementary
			   checks elsewhere.
			 */
	if(symt1 == symt2
	   || symt1->parameter || symt2->parameter
	   || symt1->entry_point || symt2->entry_point
	   || symt1->argument || symt2->argument
	   || symt1->external || symt2->external) {

		syntax_error(id1->line_num,id1->col_num,
			     "illegal to equivalence these");
	}
		/* now swap equiv_links so their equiv lists are united */
	else {
	    temp = symt1->equiv_link;
	    symt1->equiv_link = symt2->equiv_link;
	    symt2->equiv_link = temp;
	}

#define XMAX(x,y) ((x)>(y)?(x):(y))

		/* If either guy is in common, both are in common */
	if(symt1->common_var || symt2->common_var) {
	    Lsymtab *equiv=symt1;
		int common_hash = -1;
		int common_orig_hash = -1;
	    do {
		equiv->common_var = TRUE;
		common_hash = XMAX( common_hash, equiv->common_hash );
		common_orig_hash = XMAX( common_orig_hash, equiv->common_orig_hash );
		equiv = equiv->equiv_link;
	    } while(equiv != symt1);

	    equiv=symt1;
	    do {
		equiv->common_hash = common_hash;
		equiv->common_orig_hash = common_orig_hash;
		equiv = equiv->equiv_link;
	    } while(equiv != symt1);
	}
}

int
get_size(symt,type) /* Returns size of symbol if explicitly declared
		       or declared using IMPLICIT type*size statement.
		       Otherwise returns size_DEFAULT. */
     Lsymtab *symt;
     int type;			/* Datatype: not used at present */
{
  int datasize=symt->size;
  if(datasize != size_DEFAULT)
    return datasize;		/* if declared, use it */
  else {
    int first_char= toupper((int)symt->name[0]);
#if ALLOW_DOLLARSIGNS
    if(first_char == '$')  first_char = 'Z'+1;
#endif
#if ALLOW_UNDERSCORES
    if(first_char == '_')  first_char = 'Z'+2;
#endif

    return implicit_size[first_char - 'A'];
  }
}

int
get_type(symt)	/* Returns data type of symbol, using implicit if necessary */
	Lsymtab *symt;
{
	int datatype = datatype_of(symt->type);

	if(datatype != type_UNDECL)	/* Declared? */
	   return datatype;		/*   Yes: use it */
	else if(storage_class_of(symt->type) == class_SUBPROGRAM
	     && !symt->invoked_as_func )
				/* Function never invoked: assume subr */
	   return type_SUBROUTINE;
	else {
	  int first_char=(int)symt->name[0];
	  if (islower(first_char))
	  {
		first_char = toupper(first_char);
	  }
#if ALLOW_DOLLARSIGNS
	  if(first_char == '$')  first_char = 'Z'+1;
#endif
#if ALLOW_UNDERSCORES
	  if(first_char == '_')  first_char = 'Z'+2;
#endif

	   return implicit_type[first_char - 'A'];
	}
}/*get_type*/


	/* hash_lookup finds identifier in hashtable and returns its
	   index.  If not found, a new hashtable entry is made for it,
	   and the identifier string s is copied to local stringspace.
	*/
unsigned
hash_lookup(s)
	char *s;
{
        unsigned h;
	unsigned long hnum;

	hnum = hash(s);

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

	if(hashtab[h].name == NULL) {
		    hashtab[h].name = new_local_string(s);
		    hashtab[h].loc_symtab = NULL;
		    hashtab[h].glob_symtab = NULL;
		    hashtab[h].com_loc_symtab = NULL;
		    hashtab[h].com_glob_symtab = NULL;
		    hashtab[h].define = 0;
        }
	return h;
}/*hash_lookup*/

void
init_tables()			/* Allocates table space */
{
#ifdef DYNAMIC_TABLES		/* tables will be mallocked at runtime */
	if( ((loc_symtab=(Lsymtab*)SN_calloc(LOCSYMTABSZ,sizeof(Lsymtab)))
		== (Lsymtab*)NULL) ||
	    ((glob_symtab=(Gsymtab*)SN_calloc(GLOBSYMTABSZ,sizeof(Gsymtab)))
		== (Gsymtab*)NULL) ||
	    ((hashtab=(HashTable*)SN_calloc(HASHSZ,sizeof(HashTable)))
		== (HashTable*)NULL) ||
	    ((strspace=(char*)SN_calloc(STRSPACESZ,sizeof(char)))
		== (char*)NULL) ||
	    ((tokenspace=(Token*)SN_calloc(TOKENSPACESZ,sizeof(Token)))
		== (Token*)NULL) ||
	    ((tokheadspace=
	      (TokenListHeader*)SN_calloc(TOKENSPACESZ,sizeof(TokenListHeader)))
		== (TokenListHeader*)NULL) ) {
	  oops_message(OOPS_FATAL,NO_LINE_NUM,NO_COL_NUM,
		       "Cannot malloc space for tables");
	}
#endif
}

void
init_globals()                	/* Clears the global symbol table */
{
	glob_str_bot = STRSPACESZ;
}/*init_globals*/



void
init_symtab()                     /* Clears the local symbol table */
{
	int i,h;
	unsigned long hnum;

	loc_symtab_top = 0;
	loc_str_top = 0;
	token_space_top = 0;
 	token_head_space_top = 0;

		      /* Clears the hash table */
	for(i=0;i<HASHSZ;i++) {
	    hashtab[i].name = NULL;
	    hashtab[i].loc_symtab = NULL;
	    hashtab[i].com_loc_symtab = NULL;
	    hashtab[i].glob_symtab = NULL;
	    hashtab[i].com_glob_symtab = NULL;
	}

		      /* Re-establishes global symbols */
	for(i=0;i<glob_symtab_top;i++) {
	    hnum = hash(glob_symtab[i].name);