symtab.c

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

#endif
	    t1 = t1->next_token;
	    t2 = t2->next_token;
	}
}

void
declare_type(id,datatype,size)
	Token *id;
	int datatype;
	long size;
{
	int h=id->value.integer;
	Lsymtab *symt=hashtab[h].loc_symtab;

	if( (symt) == NULL) {
	   symt = install_local(id,h,datatype,class_VAR);
	   symt->size = size;
	}
	else {           /* Symbol has been seen before: check it */

			/* Intrinsic: see if type is consistent */
	  if( symt->intrinsic ) {
	    IntrinsInfo *defn = symt->info.intrins_info;
	    int rettype = defn->result_type,
		argtype = defn->arg_type;
			/* N.B. this test catches many but not all errors */
	    if( (rettype != type_GENERIC && datatype != rettype)
	     || (rettype == type_GENERIC && !((1<<datatype) & argtype)) ){
		    warning(id->line_num,id->col_num,
				"Declared type ");
		    msg_tail(type_name[datatype]);
		    msg_tail(" is invalid for intrinsic function: ");
		    msg_tail(symt->name);
	      }
	  }

	  if(datatype_of(symt->type) != type_UNDECL) {
	      syntax_error(id->line_num,id->col_num,
		"Symbol redeclared: ");
	  	msg_tail(symt->name);
	  }
	  else {
			/* Now give it the declared type */
	      symt->type = type_byte(storage_class_of(symt->type),datatype);
	      symt->size = size;
	  }
	}
				/* Under -port warn if char size > 255 */
	if(port_check) {
	  if(datatype == type_STRING && size > 255)
	    nonportable(id->line_num,id->col_num,
			"character variable length exceeds 255");
	}

	{
		extern int current_struct_hash;

		if( current_struct_hash != -1 )
		{
			if( highlight != -1 )
			{
				put_symbol(PAF_MBR_VAR_DEF,
					hashtab[current_struct_hash].name,
					hashtab[id->value.integer].name,
					current_filename,
					id->line_num,
					id->curr_index,
					0,0,
					(long)PAF_PUBLIC,
					datatype_name(datatype),NULL,NULL,
					get_comment(current_filename,id->line_num),
					0,0,0,0);

				if( datatype == type_RECORD )
				{
					put_symbol(PAF_CLASS_INHERIT,
						hashtab[current_struct_hash].name,
						hashtab[current_record_hash].name,
						current_filename,
						id->line_num,
						id->curr_index,
						0,0,
						(long)PAF_PUBLIC,NULL,NULL,NULL,NULL,
						0,0,0,0);
				}
			}
		}
		else
		{
			if( highlight != -1 && report_local_vars )
			{
				put_symbol(PAF_LOCAL_VAR_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(datatype),NULL,NULL,
					get_comment(current_filename,id->line_num),
					0,0,0,0);
			}
		}
	}

	symt->record_hash = current_record_hash;

}/*declare_type*/


void
def_arg_name(id)		/* Process items in argument list */

	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 {           /* Symbol has been seen before: check it */

	}
	symt->argument = TRUE;
}/*def_arg_name*/


void
def_array_dim(id,arg)	/* Process dimension lists */
	Token *id,*arg;	     /* arg previously defined as int */
{
	int h=id->value.integer;
	Lsymtab *symt;


	if( (symt=hashtab[h].loc_symtab) == NULL) {
	   symt = install_local(id,h,type_UNDECL,class_VAR);
	}
	else {           /* Symbol has been seen before: check it */
	   if(storage_class_of(symt->type) != class_VAR) {
	      syntax_error(id->line_num,id->col_num,
		"Entity cannot be dimensioned: ");
		msg_tail(symt->name);
	      return;
	   }
	}
	symt->array_var = TRUE;
	if(!equivalence_flag){      /* some checking should be done here */
	   if(symt->info.array_dim != 0)
	      syntax_error(id->line_num,id->col_num,
		"Array redimensioned");
	   else
	      symt->info.array_dim = array_dim_info(arg->class,arg->subclass);
	}
}/*def_array_dim*/


void
def_com_block(id,comlist)	/* Process common blocks and save_stmt */
	Token *id, *comlist;

{
	int h=id->value.integer;
	Lsymtab *symt;
	Gsymtab *gsymt;
   	TokenListHeader *TH_ptr;
	extern unsigned true_prev_stmt_line_num;/* set by fortran.y */

		/* Install name in global symbol table */
	if( (gsymt=hashtab[h].com_glob_symtab) == NULL) {
	   gsymt = install_global(h,type_COMMON_BLOCK,class_COMMON_BLOCK);
	   gsymt->info.comlist = NULL;
	}


	if( (symt = hashtab[h].com_loc_symtab) == NULL){
	   symt = install_local(id,h,type_COMMON_BLOCK,class_COMMON_BLOCK);
	   symt->info.toklist = NULL;
	}
	if(pretty_flag) {

		/* Flag declarations of same block in separate statements
		   unless separated only by comments. Use front token
		   of previous tokenlist which is last token of decl. */
	  if(comlist != NULL && symt->info.toklist != NULL
	   && symt->info.toklist->tokenlist->line_num < true_prev_stmt_line_num) {
	    ugly_code(id->line_num,id->col_num,
		"Common block declared in more than one statement");
	  }
	}

		/* Insert the new list onto linked list of token lists */
	if(comlist != NULL) {
	  	/* Will be NULL only for SAVE, in which case skip */
	    TH_ptr= make_TL_head(id);

 	    TH_ptr->tokenlist = comlist->next_token;
	    TH_ptr->next = symt->info.toklist;
            symt->info.toklist = TH_ptr;
	}

   	symt->set_flag = TRUE;
	symt->used_flag = TRUE;
}/*def_com_block*/


void
def_com_variable(id)		/* Process items in common block list */
	Token *id;
{
	extern int current_common_hash;	/* rigo */
	int h=id->value.integer;
	Lsymtab *symt;

	if( (symt=hashtab[h].loc_symtab) == NULL) {
	   symt = install_local(id,h,type_UNDECL,class_VAR);
	}
	else {           /* Symbol has been seen before: check it */
	    if(symt->common_var) {
		syntax_error(id->line_num,id->col_num,
		     "Variable cannot be in two different common blocks");
	    }
	    else if(symt->entry_point || symt->parameter ||
		    symt->argument || symt->external || symt->intrinsic) {
		syntax_error(id->line_num,id->col_num,
		     "Item cannot be placed in common");
		return;
	    }
	    if(symt->size == size_ADJUSTABLE) {	/* CHARACTER *(*) */
	      syntax_error(id->line_num,id->col_num,
		    "Common variable cannot have adjustable size");
	      symt->size = 1;
	    }
	}
    {		/* set flags for all equivalenced vars */
      Lsymtab *equiv=symt;
      do{

	equiv->common_var = TRUE; /* set the flag even if not legit */
	equiv->common_hash = current_common_hash; /* rigo */
	equiv->common_orig_hash = h; /* rigo */
	equiv = equiv->equiv_link;
      } while(equiv != symt);
    }

	if( highlight != -1 )
	{
		if( current_common_hash == -1 )
		{
			put_symbol(PAF_COMMON_MBR_VAR_DEF,
					blank_com_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);
		}
		else
		{
			put_symbol(PAF_COMMON_MBR_VAR_DEF,
					hashtab[current_common_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);
		}
	}
}/*def_com_variable*/


	/* This guy sets the flag in symbol table saying the id is the
	   current module.  It returns the hash code for later reference.
	 */
int
def_curr_module(id)
	Token *id;
{
	int hashno = id->value.integer;
	hashtab[hashno].loc_symtab->is_current_module = TRUE;

	return hashno;
}/*def_curr_module*/




void
def_equiv_name(id)		/* Process equivalence list elements */
	Token *id;
{
  ref_variable(id);		/* Put it in symtab */
	/* No other action needed: processing of equiv pairs is
	   done by equivalence() */
}/*def_equiv_name*/



void
def_ext_name(id)		/* Process external lists */
	Token *id;
{
	int h=id->value.integer;
	Lsymtab *symt;

	if( (symt = hashtab[h].loc_symtab) == NULL){
	   symt = install_local(id,h,type_UNDECL,class_SUBPROGRAM);
	   symt->info.toklist = NULL;
        }
	else {
			/* Symbol seen before: check it & change class */

	    if(storage_class_of(symt->type) == class_VAR) {
	      symt->info.toklist = NULL;
	    }
	    symt->type = type_byte(class_SUBPROGRAM,datatype_of(symt->type));
	}

	if(symt->intrinsic){
	    syntax_error(id->line_num,id->col_num,
		"Cannot declare same subprogram both intrinsic and external:");
	    msg_tail(symt->name);
	}
	else{
	    symt->external = TRUE;
	    if(!symt->argument){
	        TokenListHeader *TH_ptr;
		Gsymtab *gsymt;
		if( (gsymt=hashtab[h].glob_symtab) == NULL) {
	   	    gsymt = install_global(h,type_UNDECL,class_SUBPROGRAM);
	   	    gsymt->info.arglist = NULL;
		}
		TH_ptr=make_TL_head(id);

		TH_ptr->external_decl = TRUE;
		TH_ptr->next = symt->info.toklist;
		symt->info.toklist = TH_ptr;
	     }
	  }
      symt->declared_external = TRUE;
}/*def_ext_name*/



void
def_function(datatype,size,id,args)
				/* Installs function or subroutine name */
	int datatype;                     /* in global table */
	long size;
	Token *id,*args;
{
	int storage_class;
	int h=id->value.integer;
	Lsymtab *symt;
	Gsymtab *gsymt;
	TokenListHeader *TH_ptr;
   	storage_class = class_SUBPROGRAM;

	if((gsymt = (hashtab[h].glob_symtab)) == NULL) {
			/* Symbol is new to global symtab: install it */
	  gsymt = install_global(h,datatype,storage_class);
	  gsymt->size = size;
	  gsymt->info.arglist = NULL;
	}
	else {
			/* Symbol is already in global symtab. Put the
			   declared datatype into symbol table. */
	  gsymt->type = type_byte(storage_class,datatype);
	  gsymt->size = size;
	}

   	if((symt = (hashtab[id->value.integer].loc_symtab)) == NULL) {
			/* Symbol is new to local symtab: install it.
			   Since this is the current routine, it has
			   storage class of a variable. */
	   symt = install_local(id,h,datatype,class_VAR);
	   symt->size = size;
	}
	if(! symt->entry_point)	/* seen before but not as entry */
	   symt->info.toklist = NULL;


		/* Insert the new list onto linked list of token lists */
   	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;

	symt->entry_point = TRUE;

		/* library mode: set the flag so no complaint will
		   be issued if function never invoked.  Also, set
		   used_flag if this is a main program, for same reason. */
	if(library_mode)
		symt->library_module = TRUE;
	if(datatype == type_PROGRAM)
		symt->used_flag = TRUE;


#if 1 /* Zsolt Koppany, map PROGRAM to SUBROUTINE 28-sep-06 */
	if(datatype != type_BLOCK_DATA &&
		hashtab[id->value.integer].name[0] != '%')
#else
	if( datatype != type_PROGRAM && datatype != type_BLOCK_DATA )
#endif /* 1 */
	{
		if( highlight != -1 )
		{
			char	*arl = NULL;

			print_func_argument_list(args,&arl);

			if( datatype == type_SUBROUTINE || datatype == type_PROGRAM)
			{
				cross_scope_type = PAF_SUBR_DEF;
			}
			else
			{
				cross_scope_type = PAF_FUNC_DEF;
			}

			put_symbol(cross_scope_type,
				NULL,
				hashtab[id->value.integer].name,
				current_filename,
				id->line_num,
				id->curr_index,
				0,0,
				(long)0,datatype_name(datatype),
				arl,
				NULL,
				get_comment(current_filename,id->line_num),
				0,0,0,0);
			if (arl)
				ckfree(arl);
		}
	}

}/*def_function*/



void
def_intrins_name(id)		/* Process intrinsic lists */
	Token *id;
{
	int h=id->value.integer;
	Lsymtab *symt;

	if( (symt = hashtab[h].loc_symtab) == NULL){
	   symt = install_local(id,h,type_UNDECL,class_SUBPROGRAM);
	   symt->info.toklist = NULL;
        }
	else {
			/* Symbol seen before: check it & change class */
	  if(storage_class_of(symt->type) == class_VAR) {
	    symt->info.toklist = NULL;
	  }

	  symt->type = type_byte(class_SUBPROGRAM,datatype_of(symt->type));
	}

		/* Place info about intrinsic datatype in local symtab.
		   If not found, it will be treated as external.
		 */

	if(symt->external){
	    syntax_error(id->line_num,id->col_num,
	       "Cannot declare same subprogram both intrinsic and external:");
	    msg_tail(symt->name);
	}
	else{
	  IntrinsInfo *defn;
	  symt->declared_intrinsic = TRUE;
	  if( (defn=find_intrinsic(symt->name)) == NULL ) {
	     warning(id->line_num,id->col_num,
			"Unknown intrinsic function: ");
	     msg_tail(symt->name);
	     msg_tail("Treated as if user-defined");
				/* Here treat as if EXTERNAL declaration */
	     def_ext_name(id);
	     return;
	   }
	   else {