symtab.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.



*/

/* symtab.c:

Contains formerly separate modules:
   I. Symtab: symbol table maintenance routines.
  II. Hash:  hash table functions: hash(), kwd_hash(), rehash()
 III. Intrins: handles recognition & data typing of intrinsic functions.


    Copyright (C) 1992 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.


*/

/*
  I. Symtab


		Symbol table routines for Fortran program checker.

	  Shared functions defined:


	   call_func(id,arg)	 Handles function invocations.
	   call_subr(id,arg)	 Handles CALL statements.
	   declare_type(id,datatype,size) Handles TYPE statements.
	   def_arg_name(id)	 Handles func/subr argument lists.
	   def_array_dim(id,arg) Handles dimensioning declarations.
	   def_com_block(id)	 Handles common blocks and SAVE stmts.
	   def_com_variable(id)	 Handles common block lists.
       int def_curr_module(id)	 Identifies symbol as current module.
     	   def_equiv_name(id)	 Initializes equivalence list items.
	   def_ext_name(id)	 Handles external lists.
	   def_function(datatype,size,id,args)
	   		Installs function name in global table.
	   def_intrins_name(id)  Handles intrinsic lists.
	   def_parameter(id,value) Handles parameter_defn_item
	   def_stmt_function(id) Declares a statement function.
	   do_ASSIGN(id)	 Handles ASSIGN stmts.
	   do_assigned_GOTO(id)	 Handles assigned GOTO.
	   do_ENTRY(id,args,hashno) Processes ENTRY statement.
	   do_RETURN(hashno,keyword) Processes RETURN statement.
	   equivalence(id1,id2)	 equivalences two variables
       int get_type(symt)	 Finds out data type of symbol, or uses implicit
				 typing to establish its type.
       int get_size(symt,type)	 Finds out size of symbol's datatype.
	unsigned hash_lookup(s)	 Looks up identifier in hashtable.
	   init_globals()	 Initializes global symbol info.
	   init_symtab()	 Clears local symbol table & removes locals
				 from stringspace. Also restores default
				 implicit data typing.
 Gsymtab* install_global(t,datatype,storage_class) Installs indentifier in
				global symbol table.
 Lsymtab* install_local(id,t,datatype,storage_class) Installs indentifier in
				local symbol table.
ArgListHeader* make_arg_array(t) Converts list of tokens into list of
				 type-flag pairs.
ArgListHeader* make_dummy_arg_array(t) Converts list of tokens into list of
				 type-flag pairs.
ArgListHeader* make_arrayless_alist() Sets up argument list header for
				EXTERNAL decl or subprog as actual arg.
ComListHeader* make_com_array(t) Converts list of common block tokens into
				 list of dimen_info-type pairs.
	   process_lists()	 Places pointer to linked list of arrays in
				 global symbol table
	   ref_array(id,subscrs) Handles array references
	   ref_variable(id)	 Handles accessing variable name.
	   set_implicit_type(type,size,c1,c2) Processes IMPLICIT statement.
	   stmt_function_stmt(id) Finishes processing stmt func defn.
    char * token_name(t)	 Returns ptr to token's symbol's name.
	   use_actual_arg(id)	 Handles using a variable as actual arg.
	   use_io_keyword(id_keywd,id_val,class) Handles i/o control specifier.
	   use_lvalue(id)	 Handles assignment to a variable.
	   use_parameter(id)	 Handles data_constant_value &
				 data_repeat_factor.
	   use_variable(id)	 Sets used-flag for a variable used in expr.

*/

/*  private functions defined:
 arg_count(t)		Counts the number of arguments in a token list.
 call_external(symt,id,arg)	places token list of args into local symtab
 check_intrins_args(arg, defn) Checks call seq of intrinsic functions
 check_stmt_function_args(symt,id,arg)  ditto for statement functions
 find_intrinsic()		Looks up intrinsic functions in table
 find_io_keyword()		Looks up i/o control spec keywords
 reverse_tokenlist(t)		Reverses a linked list of tokens
 make_TL_head();		Initializes a tokenlist header
*/

#include <stdio.h>
#include <string.h>
#include <ctype.h>
#define SYMTAB
#include "ftnchek.h"
#include "symtab.h"
#include "fortran.h"
#include "sn.h"
#include "tcl.h"
#include <stdlib.h>

extern int current_module_hash;
extern int current_record_hash;
extern int report_local_vars;
extern int cross_scope_type;
extern	int	highlight;

PRIVATE
unsigned arg_count();

PRIVATE void
call_external(),
check_intrins_args(),
check_stmt_function_args();

PRIVATE int
find_io_keyword();

PRIVATE Token *
reverse_tokenlist();

PRIVATE TokenListHeader *	/* Initializes a tokenlist header */
make_TL_head();

PRIVATE
ArgListHeader *make_dummy_arg_array(),*make_arg_array(),
 *make_arrayless_alist();

PRIVATE
ComListHeader *make_com_array();

				/* Routines to allocate arglist and comlist
				   stuff are external for Turbo C workaround,
				   otherwise they are local.  */
#ifdef T_ALLOC
#define T_EXTERN extern
#else
#define T_EXTERN
#endif

T_EXTERN ArgListHeader *new_arglistheader();
T_EXTERN ArgListElement *new_arglistelement();
T_EXTERN ComListHeader *new_comlistheader();
T_EXTERN ComListElement *new_comlistelement();

PRIVATE
IntrinsInfo *find_intrinsic();

static char *datatype_name( int datatype );
static void report( Token *id, int typ );
static void print_func_argument_list( Token *t, char **buf);
static void report_name( char *name, Token *id, char *buf );
static void report_class_name( Token *id, char *cname, char *varn );

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

PRIVATE unsigned
arg_count(t)            /* Counts the number of arguments in a token list */
	Token *t;
{
	unsigned count;
	count = 0;
	while(t != NULL){
		count++;
		t = t->next_token;
	}
	return(count);
}

			/* This routine handles the saving of arg lists which
			   is done by call_func and call_subr.  Also called
			   by def_namelist to save its variable list. */
PRIVATE void
call_external(symt,id,arg)
	Lsymtab *symt;
	Token *id,*arg;
{
       	TokenListHeader *TH_ptr;

		/* Insert the new list onto linked list of token lists */
      	TH_ptr= make_TL_head(id);

	TH_ptr->tokenlist = (arg == NULL ? NULL: arg->next_token);
	TH_ptr->next = symt->info.toklist;
	symt->info.toklist = TH_ptr;
} /*call_external*/

void
call_func(id,arg)	/* Process function invocation */
	Token *id, *arg;
{
	int t, h=id->value.integer;
	Lsymtab *symt;
	Gsymtab *gsymt;
	IntrinsInfo *defn;

	if( (symt = (hashtab[h].loc_symtab)) == NULL){
	   symt = install_local(id,h,type_UNDECL,class_SUBPROGRAM);
       	   symt->info.toklist = NULL;
	}

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

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


		/* See if intrinsic.  If so, set flag, save info */
    if(!symt->external && !symt->intrinsic
		&& (defn = find_intrinsic(symt->name)) != NULL) {
			/* First encounter with intrinsic fcn: store info */
		symt->intrinsic = TRUE;
		symt->info.intrins_info = defn;
    }

		/* Update set/used status of variables in arg list.  This
		   is deferred to now to allow intrinsics to be treated
		   as pure functions regardless of pure_function flag. */

	if(arg != NULL) {
	    Token *a=arg;
	    int nonpure = symt->intrinsic?
		(symt->info.intrins_info->intrins_flags&I_NONPURE)
		: ! pure_functions;

  	    while( (a=a->next_token) != NULL) {
	      if(is_true(ID_EXPR,a->subclass)){
		if( nonpure ) {
			     /* Treat impure function like subroutine call */
		  use_actual_arg(a);
		  use_variable(a);
		}
		else {
			     /* Pure-function invocation checks u-b-s */
		  use_function_arg(a);
		}
	      }
	    }
	}

		/* If intrinsic, do checking now.  Otherwise, save arg list
		   to be checked later. */

    if(symt->intrinsic) {
			/* It is intrinsic: check it */
	check_intrins_args(id,arg);
    }
    else {		/* It is not intrinsic: install in global table */
      switch(storage_class_of(symt->type)) {
	case class_SUBPROGRAM:
	  symt->external = TRUE;
	  if((!symt->argument) && (gsymt=(hashtab[h].glob_symtab)) == NULL) {
		gsymt = install_global(h,type_UNDECL,class_SUBPROGRAM);
		gsymt->info.arglist = NULL;
	  }
			/* store arg list in local table */
	  call_external(symt,id,arg);
	  break;
	case class_STMT_FUNCTION:
	  symt->external = TRUE;
	  check_stmt_function_args(symt,id,arg);
	  break;
      }
    }

    symt->used_flag = TRUE;
    symt->invoked_as_func = TRUE;

} /*call_func*/


void
call_subr(id,arg)	/* Process call statements */
	Token *id, *arg;
{
	int t, h=id->value.integer;
	Lsymtab *symt;
	Gsymtab *gsymt;
#ifndef STANDARD_INTRINSICS
	IntrinsInfo *defn;
#endif
	if( (symt = (hashtab[h].loc_symtab)) == NULL){
	   symt = install_local(id,h,type_SUBROUTINE,class_SUBPROGRAM);
   	   symt->info.toklist = NULL;
	}


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

	if(t == type_UNDECL) {
		t = type_SUBROUTINE;
		symt->info.toklist = NULL;
	}
	symt->type = type_byte(class_SUBPROGRAM,t);

	/* Since nonstandard intrinsics include some subroutines,
	   see if it is in intrinsic list.  Or
	   if declared intrinsic, then accept it as such and
	   do checking now.  Otherwise, save arg list
	   to be checked later. */
#ifndef STANDARD_INTRINSICS
    if(!symt->external && !symt->intrinsic
		&& (defn = find_intrinsic(symt->name)) != NULL) {
			/* First encounter with intrinsic fcn: store info */
		symt->intrinsic = TRUE;
		symt->info.intrins_info = defn;
    }
#endif

    if(symt->intrinsic) {
			/* It is intrinsic: check it */
	check_intrins_args(id,arg);
    }
    else {		/* It is not intrinsic: install in global table */
	symt->external = TRUE;
	if((!symt->argument) && (gsymt=(hashtab[h].glob_symtab)) == NULL) {
		gsymt = install_global(h,type_UNDECL,class_SUBPROGRAM);
		gsymt->info.arglist = NULL;
	}
			/* store arg list in local table */
	call_external(symt,id,arg);
    }

	symt->used_flag = TRUE;

}/*call_subr*/

		/* This routine catches syntax errors that have to
		   wait till END is seen.  At the moment, only looks if
		   CHARACTER*(*) declarations are put on the wrong thing.
		   Has to wait since can use it for ENTRY pt.
		   Also checks if things SAVED that shouldn't be.
		 */
void
check_loose_ends(curmodhash)
     int curmodhash;    /* current_module_hash from fortran.y */
{
  int i;
  for(i=0;i<loc_symtab_top;i++) {
    if( datatype_of(loc_symtab[i].type) == type_STRING &&
	loc_symtab[i].size == size_ADJUSTABLE &&
       !(loc_symtab[i].argument ||
	   loc_symtab[i].parameter ||
	     loc_symtab[i].entry_point) ) {
      syntax_error(NO_LINE_NUM,NO_COL_NUM,loc_symtab[i].name);
      msg_tail("cannot be adjustable size in module");
      msg_tail(hashtab[curmodhash].name);
    }
    if(loc_symtab[i].saved &&
        (loc_symtab[i].common_var ||
	 loc_symtab[i].argument ||
	 loc_symtab[i].external ||
	 loc_symtab[i].parameter ||
	 loc_symtab[i].entry_point) ) {
      syntax_error(NO_LINE_NUM,NO_COL_NUM,loc_symtab[i].name);
      msg_tail("cannot be declared in SAVE statement in module");
      msg_tail(hashtab[curmodhash].name);
    }
  }
}

		/* check out consistency of intrinsic argument list */
PRIVATE
void
check_intrins_args(id, arg)
	Token *id;
	Token *arg;
{
	int h=id->value.integer;
	Lsymtab *symt=hashtab[h].loc_symtab;
	IntrinsInfo *defn=symt->info.intrins_info;
	unsigned args_given = ((arg == NULL)?0:arg_count(arg->next_token));
	int numargs;
	unsigned short flags;
	Token *t;

	numargs = defn->num_args;
	flags = defn->intrins_flags;

			/* positive numargs: must agree */
	if( (numargs >= 0 && (args_given != numargs))
			/* 1 or 2 arguments allowed */
	 || (numargs == I_1or2 && (args_given != 1 && args_given != 2))
			/* numargs == -2: 2 or more */
	 || (numargs == I_2up && (args_given < 2))
			/* 0 or 1 argument allowed */
	 || (numargs == I_0or1 && (args_given != 0 && args_given != 1)) ){
		unsigned line_num,col_num;
		if(arg==NULL) {line_num=id->line_num; col_num=id->col_num;}
		else {line_num = arg->line_num; col_num = arg->col_num;}

		syntax_error(line_num,col_num,
		  "wrong number of arguments for intrinsic function");
		msg_tail(defn->name);
	}
	if(arg != NULL) {

	  Token *prev_t,	/* one operand in type propagation  */
	         fake_op;	/* operator in binexpr_type call */

	  arg->next_token = t = reverse_tokenlist(arg->next_token);
				/* Copy type & size info into result */
	  arg->class = t->class;
	  arg->subclass = t->subclass;
	  arg->size = t->size;
	  prev_t = t;

	  while(t != NULL) {
	    if(intrins_arg_cmp(defn,t)) {
				/* Propagate data type thru the list.
				   Resulting type info is stored in
				   args token.  */
	      if(prev_t != t && ! (flags & I_MIXED_ARGS) ) {
				/* Set up a pretend expr term for binexpr */
		fake_op.class = ',';
		fake_op.line_num = prev_t->line_num;
		fake_op.col_num = prev_t->col_num;

		binexpr_type(prev_t,&fake_op,t,arg);
	      }
	      prev_t = t;
	    }
	    t = t->next_token;
	  }/* end while */

	}/* end arg != NULL */
}/* check_intrins_args */


PRIVATE
void
check_stmt_function_args(symt,id,arg)
	Lsymtab *symt;
	Token *id,*arg;
{
	unsigned n1,n2,n;
	int i;
	Token *t1,*t2;

	t1 = symt->info.toklist->tokenlist;
	t2 = ((arg==NULL)? NULL: reverse_tokenlist(arg->next_token));

	n1 = arg_count(t1);
	n2 = arg_count(t2);

	if(n1 != n2) {
	    syntax_error(id->line_num,id->col_num,
		"function invoked with incorrect number of arguments");
	}

	n = (n1 < n2? n1: n2);
	for(i=0; i<n; i++) {
#ifdef OLDSTUFF
	    if( t1->class != t2->class) {
		syntax_error(t2->line_num,t2->col_num,
		  "function argument is of incorrect datatype");
	    }
#else
	    stmt_fun_arg_cmp(symt,t1,t2);