gfortran.h (gfc_namespace): Add new field is_block_data.

fortran/
* gfortran.h (gfc_namespace): Add new field is_block_data.
* parse.c (accept_statement): Remove special handling for BLOCK DATA.
(parse_block_data): Record BLOCK DATA name, set is_block_data field.
* trans.c (gfc_generate_code): Handle BLOCK DATA units.
* trans.h (gfc_generate_block_data): Add prototype.
* trans-decl.c (gfc_generate_block_data): New function.

testsuite/
* gfortran.dg/blockdata_1.f90: New test.

From-SVN: r86796

gcc/fortran/ChangeLog

+2004-08-30  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortran.h (gfc_namespace): Add new field is_block_data.
+	* parse.c (accept_statement): Remove special handling for BLOCK DATA.
+	(parse_block_data): Record BLOCK DATA name, set is_block_data field.
+	* trans.c (gfc_generate_code): Handle BLOCK DATA units.
+	* trans.h (gfc_generate_block_data): Add prototype.
+	* trans-decl.c (gfc_generate_block_data): New function.
+
 2004-08-29  Richard Henderson  <rth@redhat.com>
 
 	* trans-const.c (gfc_conv_mpz_to_tree): Use mpz_export.

gcc/fortran/gfortran.h

@@ -804,6 +804,9 @@ typedef struct gfc_namespace
 
   /* A list of all alternate entry points to this procedure (or NULL).  */
   gfc_entry_list *entries;
+
+  /* Set to 1 if namespace is a BLOCK DATA program unit.  */
+  int is_block_data;
 }
 gfc_namespace;
 

gcc/fortran/parse.c

@@ -1058,24 +1058,6 @@ accept_statement (gfc_statement st)
 
       break;
 
-    case ST_BLOCK_DATA:
-      {
-        gfc_symbol *block_data = NULL;
-        symbol_attribute attr;
-
-        gfc_get_symbol ("_BLOCK_DATA__", gfc_current_ns, &block_data);
-        gfc_clear_attr (&attr);
-        attr.flavor = FL_PROCEDURE;
-        attr.proc = PROC_UNKNOWN;
-        attr.subroutine = 1;
-        attr.access = ACCESS_PUBLIC;
-        block_data->attr = attr;
-        gfc_current_ns->proc_name = block_data;
-        gfc_commit_symbols ();
-      }
-
-      break;
-
     case ST_ENTRY:
     case_executable:
     case_exec_markers:
@@ -2410,6 +2392,9 @@ parse_block_data (void)
   static int blank_block=0;
   gfc_gsymbol *s;
 
+  gfc_current_ns->proc_name = gfc_new_block;
+  gfc_current_ns->is_block_data = 1;
+
   if (gfc_new_block == NULL)
     {
       if (blank_block)

gcc/fortran/trans-decl.c

@@ -2350,4 +2350,30 @@ gfc_generate_constructors (void)
 #endif
 }
 
+/* Translates a BLOCK DATA program unit. This means emitting the
+   commons contained therein plus their initializations. We also emit
+   a globally visible symbol to make sure that each BLOCK DATA program
+   unit remains unique.  */
+
+void
+gfc_generate_block_data (gfc_namespace * ns)
+{
+  tree decl;
+  tree id;
+
+  gfc_trans_common (ns);
+
+  if (ns->proc_name)
+    id = gfc_sym_mangled_function_id (ns->proc_name);
+  else
+    id = get_identifier ("__BLOCK_DATA__");
+
+  decl = build_decl (VAR_DECL, id, gfc_array_index_type);
+  TREE_PUBLIC (decl) = 1;
+  TREE_STATIC (decl) = 1;
+
+  pushdecl (decl);
+  rest_of_decl_compilation (decl, 1, 0);
+}
+
 #include "gt-fortran-trans-decl.h"

gcc/fortran/trans.c

@@ -647,6 +647,12 @@ gfc_generate_code (gfc_namespace * ns)
   gfc_symbol *main_program = NULL;
   symbol_attribute attr;
 
+  if (ns->is_block_data)
+    {
+      gfc_generate_block_data (ns);
+      return;
+    }
+
   /* Main program subroutine.  */
   if (!ns->proc_name)
     {

gcc/fortran/trans.h

@@ -396,6 +396,8 @@ tree gfc_advance_chain (tree, int);
 void gfc_create_function_decl (gfc_namespace *);
 /* Generate the code for a function.  */
 void gfc_generate_function_code (gfc_namespace *);
+/* Output a BLOCK DATA program unit.  */
+void gfc_generate_block_data (gfc_namespace *);
 /* Output a decl for a module variable.  */
 void gfc_generate_module_vars (gfc_namespace *);
 

gcc/testsuite/ChangeLog

+2004-08-30  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortran.dg/blockdata_1.f90: New test.
+
 2004-08-30  Richard Henderson  <rth@redhat.com>
 
 	* g++.dg/other/offsetof1.C: Use __builtin_offsetof.

gcc/testsuite/gfortran.dg/blockdata_1.f90

+! { dg-do run }
+! tests basic block data functionality
+! we didn't allow multiple block data program units
+block data 
+ common /a/ y(3)
+ data y /3*1./
+end
+
+blockdata d1
+ common /a/ w(3)
+ common /b/ u
+ data u /1./
+end blockdata d1
+
+block data d2
+ common /b/ u
+ common j
+ data j /1/
+end block data d2
+!
+! begin testing code
+common /a/ x(3)
+common /b/ y
+common i
+
+if (any(x /= 1.)) call abort ()
+if (y /= 1. .or. i /= 1) call abort ()
+end