Andrew Vaught <andyv@firstinter.net>

2004-06-29  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.

Co-Authored-By: Andrew Vaught <andyv@firstinter.net>

From-SVN: r83868

gcc/fortran/ChangeLog

 2004-06-29  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.
+
+2004-06-29  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
 
 	* module.c (mio_gmp_real): Correct writing of negative numbers.
 

gcc/fortran/gfortran.h

@@ -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;
 

gcc/fortran/parse.c

@@ -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);

gcc/fortran/symbol.c

@@ -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;
+}