[gfortran] Add a global symbol table

[Tobias Schlüter <tobias dot schlueter at physik dot uni-muenchen dot de>]

At present we have absymal error reporting if a global symbol is reused,
e.g.
[tobi@marktplatz tests]$ cat dbl.f90
subroutine a
end subroutine a

subroutine a
end subroutine a
[tobi@marktplatz tests]$ gfortran dbl.f90
/tmp/ccbz40st.s: Assembler messages:
/tmp/ccbz40st.s:14: Error: symbol `a_' is already defined
this patch, ported from g95, fixes this. Wit the patch we report:
[tobi@marktplatz tests]$ ~/src/gcc/build-clean/gcc/f951 dbl.f90 -quiet
 In file dbl.f90:4

subroutine a
           1
 In file dbl.f90:1

subroutine a
           2
Error: Global name 'a' at (1) is already being used as a SUBROUTINE at (2)

This is achieved by keeping a table of global symbols. A possible future
application for this might be checking if external subroutines are
called with consistent argument list. Additionally, the disallowed case
of two empty BLOCK DATA is caught.

The case where the name of a COMMON collides with another global name is
not yet caught, as there are other outstanding problems with the
handling of COMMON names (they shouldn't be added to namespaces), so a
rewrite of the handling of their names is inevitable, anyway.

Compiled and tested on i686-pc-linux.

- Tobi

2004-06-25  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
	Andrew Vaught  <andyv@firstinter.net>

	* gfortran.h (gfc_gsymbol): New typedef.
	(gfc_gsym_root): New variable.
	(gfc_get_gsymbol, gfc_find_gsym): New prototypes.
	* parse.c (global_used): New function.
	(parse_block_data): Check for double empty BLOCK DATA,
	use global symbol table.
	(parse_module): Use global symbol table.
	(add_global_procedure, add_global_program): New functions.
	(gfc_parse_file): Use global symbol table.
	* symbol.c (gfc_gsym_root): New variable.
	(gfc_find_gsym, gsym_compare, gfc_get_gsymbol): New
	functions.

Index: gfortran.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.13
diff -u -p -r1.13 gfortran.h
--- gfortran.h  14 Jun 2004 15:56:48 -0000      1.13
+++ gfortran.h  25 Jun 2004 19:00:06 -0000
@@ -720,6 +720,24 @@ gfc_namespace;

 extern gfc_namespace *gfc_current_ns;

+/* Global symbols are symbols of global scope. Currently we only use
+   this to detect collisions already when parsing.
+   TODO: Extend to verify procedure calls.  */
+
+typedef struct gfc_gsymbol
+{
+  BBT_HEADER(gfc_gsymbol);
+
+  char name[GFC_MAX_SYMBOL_LEN+1];
+  enum { GSYM_UNKNOWN=1, GSYM_PROGRAM, GSYM_FUNCTION, GSYM_SUBROUTINE,
+        GSYM_MODULE, GSYM_COMMON, GSYM_BLOCK_DATA } type;
+
+  int defined, used;
+  locus where;
+}
+gfc_gsymbol;
+
+extern gfc_gsymbol *gfc_gsym_root;

 /* Information on interfaces being built.  */
 typedef struct
@@ -1490,6 +1508,9 @@ void gfc_save_all (gfc_namespace *);

 void gfc_symbol_state (void);

+gfc_gsymbol *gfc_get_gsymbol (char *);
+gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, char *);
+
 /* intrinsic.c */
 extern int gfc_init_expr;

Index: parse.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/parse.c,v
retrieving revision 1.7
diff -u -p -r1.7 parse.c
--- parse.c     27 May 2004 12:35:12 -0000      1.7
+++ parse.c     25 Jun 2004 19:00:08 -0000
@@ -2319,12 +2319,79 @@ done:
 }


+/* Come here to complain about a global symbol already in use as
+   something else.  */
+
+static void
+global_used (gfc_gsymbol *sym, locus *where)
+{
+  const char *name;
+
+  if (where == NULL)
+    where = &gfc_current_locus;
+
+  switch(sym->type)
+    {
+    case GSYM_PROGRAM:
+      name = "PROGRAM";
+      break;
+    case GSYM_FUNCTION:
+      name = "FUNCTION";
+      break;
+    case GSYM_SUBROUTINE:
+      name = "SUBROUTINE";
+      break;
+    case GSYM_COMMON:
+      name = "COMMON";
+      break;
+    case GSYM_BLOCK_DATA:
+      name = "BLOCK DATA";
+      break;
+    case GSYM_MODULE:
+      name = "MODULE";
+      break;
+    default:
+      gfc_internal_error ("gfc_gsymbol_type(): Bad type");
+      name = NULL;
+    }
+
+  gfc_error("Global name '%s' at %L is already being used as a %s at %L",
+           gfc_new_block->name, where, name, &sym->where);
+}
+
+
 /* Parse a block data program unit.  */

 static void
 parse_block_data (void)
 {
   gfc_statement st;
+  static locus blank_locus;
+  static int blank_block=0;
+  gfc_gsymbol *s;
+
+  if (gfc_new_block == NULL)
+    {
+      if (blank_block)
+       gfc_error ("Blank BLOCK DATA at %C conflicts with "
+                  "prior BLOCK DATA at %L", &blank_locus);
+      else
+       {
+         blank_block = 1;
+         blank_locus = gfc_current_locus;
+       }
+    }
+  else
+    {
+      s = gfc_get_gsymbol (gfc_new_block->name);
+      if (s->type != GSYM_UNKNOWN)
+       global_used(s, NULL);
+      else
+       {
+         s->type = GSYM_BLOCK_DATA;
+         s->where = gfc_current_locus;
+       }
+    }

   st = parse_spec (ST_NONE);

@@ -2344,6 +2411,16 @@ static void
 parse_module (void)
 {
   gfc_statement st;
+  gfc_gsymbol *s;
+
+  s = gfc_get_gsymbol (gfc_new_block->name);
+  if (s->type != GSYM_UNKNOWN)
+    global_used(s, NULL);
+  else
+    {
+      s->type = GSYM_MODULE;
+      s->where = gfc_current_locus;
+    }

   st = parse_spec (ST_NONE);

@@ -2372,6 +2449,46 @@ loop:
 }


+/* Add a procedure name to the global symbol table.  */
+
+static void
+add_global_procedure (int sub)
+{
+  gfc_gsymbol *s;
+
+  s = gfc_get_gsymbol(gfc_new_block->name);
+
+  if (s->type != GSYM_UNKNOWN)
+    global_used(s, NULL);
+  else
+    {
+      s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
+      s->where = gfc_current_locus;
+    }
+}
+
+
+/* Add a program to the global symbol table.  */
+
+static void
+add_global_program (void)
+{
+  gfc_gsymbol *s;
+
+  if (gfc_new_block == NULL)
+    return;
+  s = gfc_get_gsymbol (gfc_new_block->name);
+
+  if (s->type != GSYM_UNKNOWN)
+    global_used(s, NULL);
+  else
+    {
+      s->type = GSYM_PROGRAM;
+      s->where = gfc_current_locus;
+    }
+}
+
+
 /* Top level parser.  */

 try
@@ -2415,16 +2532,19 @@ loop:

       push_state (&s, COMP_PROGRAM, gfc_new_block);
       accept_statement (st);
+      add_global_program ();
       parse_progunit (ST_NONE);
       break;

     case ST_SUBROUTINE:
+      add_global_procedure (1);
       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
       accept_statement (st);
       parse_progunit (ST_NONE);
       break;

     case ST_FUNCTION:
+      add_global_procedure (0);
       push_state (&s, COMP_FUNCTION, gfc_new_block);
       accept_statement (st);
       parse_progunit (ST_NONE);
Index: symbol.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/symbol.c,v
retrieving revision 1.5
diff -u -p -r1.5 symbol.c
--- symbol.c    27 May 2004 12:35:12 -0000      1.5
+++ symbol.c    25 Jun 2004 19:00:08 -0000
@@ -88,6 +88,8 @@ static int next_dummy_order = 1;

 gfc_namespace *gfc_current_ns;

+gfc_gsymbol *gfc_gsym_root = NULL;
+
 static gfc_symbol *changed_syms = NULL;


@@ -2419,3 +2421,63 @@ gfc_symbol_state(void) {
 }
 #endif

+
+/************** Global symbol handling ************/
+
+
+/* Search a tree for the global symbol.  */
+
+gfc_gsymbol *
+gfc_find_gsymbol (gfc_gsymbol *symbol, char *name)
+{
+  gfc_gsymbol *s;
+
+  if (symbol == NULL)
+    return NULL;
+  if (strcmp (symbol->name, name) == 0)
+    return symbol;
+
+  s = gfc_find_gsymbol (symbol->left, name);
+  if (s != NULL)
+    return s;
+
+  s = gfc_find_gsymbol (symbol->right, name);
+  if (s != NULL)
+    return s;
+
+  return NULL;
+}
+
+
+/* Compare two global symbols. Used for managing the BB tree.  */
+
+static int
+gsym_compare (void * _s1, void * _s2)
+{
+  gfc_gsymbol *s1, *s2;
+
+  s1 = (gfc_gsymbol *)_s1;
+  s2 = (gfc_gsymbol *)_s2;
+  return strcmp(s1->name, s2->name);
+}
+
+
+/* Get a global symbol, creating it if it doesn't exist.  */
+
+gfc_gsymbol *
+gfc_get_gsymbol (char *name)
+{
+  gfc_gsymbol *s;
+
+  s = gfc_find_gsymbol (gfc_gsym_root, name);
+  if (s != NULL)
+    return s;
+
+  s = gfc_getmem (sizeof (gfc_gsymbol));
+  s->type = GSYM_UNKNOWN;
+  strcpy (s->name, name);
+
+  gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
+
+  return s;
+}