This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

RFC: Experimental BLOCK implementation


Hi all,

attached is an experimental draft patch to implement the F2008 BLOCK construct. There seem to be some interesting corner cases and interpretations about BLOCK (see http://gcc.gnu.org/bugzilla/show_bug.cgi?id=39626, especially Tobias' pointer), but I'm just trying to get the 'basic' stuff right without caring for now about some peculiarities.

The patch works so far for what I would expect from BLOCK (see the test cases), but misses some checks that only stuff really allowed with a BLOCK is included there, and some other item that I think is wrong at the moment is that variables that get implicitly typed within the block would have only the block as their scope -- this is not in line with the draft standard, AFAIK.

Additionally, I'm not sure if my implementation uses the 'best' and 'cleanest' ways... Comments very welcome! My plan is to work on the missing checks and then submit the revised patch for review.

Yours,
Daniel

--
Done:  Arc-Bar-Cav-Ran-Rog-Sam-Tou-Val-Wiz
To go: Hea-Kni-Mon-Pri
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 151672)
+++ gcc/fortran/decl.c	(working copy)
@@ -5344,8 +5344,8 @@ set_enum_kind(void)
 
 
 /* Match any of the various end-block statements.  Returns the type of
-   END to the caller.  The END INTERFACE, END IF, END DO and END
-   SELECT statements cannot be replaced by a single END statement.  */
+   END to the caller.  The END INTERFACE, END IF, END DO, END SELECT
+   and END BLOCK statements cannot be replaced by a single END statement.  */
 
 match
 gfc_match_end (gfc_statement *st)
@@ -5366,6 +5366,9 @@ gfc_match_end (gfc_statement *st)
   block_name = gfc_current_block () == NULL
 	     ? NULL : gfc_current_block ()->name;
 
+  if (state == COMP_BLOCK && !strcmp (block_name, "block@"))
+    block_name = NULL;
+
   if (state == COMP_CONTAINS || state == COMP_DERIVED_CONTAINS)
     {
       state = gfc_state_stack->previous->state;
@@ -5419,6 +5422,12 @@ gfc_match_end (gfc_statement *st)
       eos_ok = 0;
       break;
 
+    case COMP_BLOCK:
+      *st = ST_END_BLOCK;
+      target = " block";
+      eos_ok = 0;
+      break;
+
     case COMP_IF:
       *st = ST_ENDIF;
       target = " if";
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 151672)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -206,15 +206,17 @@ arith;
 /* Statements.  */
 typedef enum
 {
-  ST_ARITHMETIC_IF, ST_ALLOCATE, ST_ATTR_DECL, ST_BACKSPACE, ST_BLOCK_DATA,
+  ST_ARITHMETIC_IF, ST_ALLOCATE, ST_ATTR_DECL, ST_BACKSPACE,
+  ST_BLOCK, ST_BLOCK_DATA,
   ST_CALL, ST_CASE, ST_CLOSE, ST_COMMON, ST_CONTINUE, ST_CONTAINS, ST_CYCLE,
   ST_DATA, ST_DATA_DECL, ST_DEALLOCATE, ST_DO, ST_ELSE, ST_ELSEIF,
-  ST_ELSEWHERE, ST_END_BLOCK_DATA, ST_ENDDO, ST_IMPLIED_ENDDO,
+  ST_ELSEWHERE, ST_END_BLOCK, ST_END_BLOCK_DATA, ST_ENDDO, ST_IMPLIED_ENDDO,
   ST_END_FILE, ST_FINAL, ST_FLUSH, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF,
   ST_END_INTERFACE, ST_END_MODULE, ST_END_PROGRAM, ST_END_SELECT,
   ST_END_SUBROUTINE, ST_END_WHERE, ST_END_TYPE, ST_ENTRY, ST_EQUIVALENCE,
   ST_EXIT, ST_FORALL, ST_FORALL_BLOCK, ST_FORMAT, ST_FUNCTION, ST_GOTO,
-  ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE, ST_IMPORT, ST_INQUIRE, ST_INTERFACE,
+  ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE, ST_IMPORT,
+  ST_INQUIRE, ST_INTERFACE,
   ST_PARAMETER, ST_MODULE, ST_MODULE_PROC, ST_NAMELIST, ST_NULLIFY, ST_OPEN,
   ST_PAUSE, ST_PRIVATE, ST_PROGRAM, ST_PUBLIC, ST_READ, ST_RETURN, ST_REWIND,
   ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT, 
@@ -1964,7 +1966,7 @@ typedef enum
   EXEC_POINTER_ASSIGN,
   EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, EXEC_ASSIGN_CALL, EXEC_RETURN,
   EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
-  EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT,
+  EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT, EXEC_BLOCK,
   EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_CALL_PPC,
   EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE,
   EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
@@ -2015,6 +2017,7 @@ typedef struct gfc_code
     const char *omp_name;
     gfc_namelist *omp_namelist;
     bool omp_bool;
+    gfc_namespace *ns;
   }
   ext;		/* Points to additional structures required by statement */
 
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(revision 151672)
+++ gcc/fortran/trans-stmt.c	(working copy)
@@ -756,6 +756,36 @@ gfc_trans_arithmetic_if (gfc_code * code
 }
 
 
+/* Translate a BLOCK construct.  This is basically what we would do for a
+   procedure body.  */
+
+tree
+gfc_trans_block_construct (gfc_code* code)
+{
+  gfc_namespace* ns;
+  gfc_symbol* sym;
+  stmtblock_t body;
+  tree tmp;
+
+  ns = code->ext.ns;
+  gcc_assert (ns);
+  sym = ns->proc_name;
+  gcc_assert (sym);
+
+  gcc_assert (!sym->tlink);
+  sym->tlink = sym;
+
+  gfc_start_block (&body);
+  gfc_process_block_locals (ns);
+
+  tmp = gfc_trans_code (ns->code);
+  tmp = gfc_trans_deferred_vars (sym, tmp);
+
+  gfc_add_expr_to_block (&body, tmp);
+  return gfc_finish_block (&body);
+}
+
+
 /* Translate the simple DO construct.  This is where the loop variable has
    integer type and step +-1.  We can't use this in the general case
    because integer overflow and floating point errors could give incorrect
Index: gcc/fortran/trans-stmt.h
===================================================================
--- gcc/fortran/trans-stmt.h	(revision 151672)
+++ gcc/fortran/trans-stmt.h	(working copy)
@@ -43,6 +43,7 @@ tree gfc_trans_call (gfc_code *, bool, t
 tree gfc_trans_return (gfc_code *);
 tree gfc_trans_if (gfc_code *);
 tree gfc_trans_arithmetic_if (gfc_code *);
+tree gfc_trans_block_construct (gfc_code *);
 tree gfc_trans_do (gfc_code *);
 tree gfc_trans_do_while (gfc_code *);
 tree gfc_trans_select (gfc_code *);
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c	(revision 151672)
+++ gcc/fortran/trans.c	(working copy)
@@ -1164,6 +1164,10 @@ gfc_trans_code (gfc_code * code)
 	  res = gfc_trans_arithmetic_if (code);
 	  break;
 
+	case EXEC_BLOCK:
+	  res = gfc_trans_block_construct (code);
+	  break;
+
 	case EXEC_DO:
 	  res = gfc_trans_do (code);
 	  break;
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h	(revision 151672)
+++ gcc/fortran/trans.h	(working copy)
@@ -498,6 +498,12 @@ void gfc_build_io_library_fndecls (void)
 /* Build a function decl for a library function.  */
 tree gfc_build_library_function_decl (tree, tree, int, ...);
 
+/* Process the local variable decls of a block construct.  */
+void gfc_process_block_locals (gfc_namespace*);
+
+/* XXX: comment and position this.  */
+tree gfc_trans_deferred_vars (gfc_symbol*, tree);
+
 /* somewhere! */
 tree pushdecl (tree);
 tree pushdecl_top_level (tree);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 151672)
+++ gcc/fortran/resolve.c	(working copy)
@@ -1101,6 +1101,7 @@ is_illegal_recursion (gfc_symbol* sym, g
 {
   gfc_symbol* proc_sym;
   gfc_symbol* context_proc;
+  gfc_namespace* real_context;
 
   gcc_assert (sym->attr.flavor == FL_PROCEDURE);
 
@@ -1114,11 +1115,20 @@ is_illegal_recursion (gfc_symbol* sym, g
   if (proc_sym->attr.recursive || gfc_option.flag_recursive)
     return false;
 
-  /* Find the context procdure's "real" symbol if it has entries.  */
-  context_proc = (context->entries ? context->entries->sym
-				   : context->proc_name);
-  if (!context_proc)
-    return true;
+  /* Find the context procedure's "real" symbol if it has entries.
+     If we don't find any procedure, this may be a BLOCK construct; recurse
+     on the parent in this case.  */
+  for (real_context = context; real_context;
+       real_context = real_context->parent)
+    {
+      context_proc = (context->entries ? context->entries->sym
+				       : context->proc_name);
+      if (context_proc)
+	break;
+    }
+  /* XXX: Return true was here before?  */
+  if (!real_context)
+    return false;
 
   /* A call from sym's body to itself is recursion, of course.  */
   if (context_proc == proc_sym)
@@ -6838,6 +6848,17 @@ gfc_resolve_forall (gfc_code *code, gfc_
 }
 
 
+/* Resolve a BLOCK construct statement.  */
+
+static void
+resolve_block_construct (gfc_code* code)
+{
+  /* XXX: Do some checks, like the restrictions on the specifications-part
+     for a BLOCK construct.  */
+  code = code;
+}
+
+
 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
    DO code nodes.  */
 
@@ -6875,6 +6896,10 @@ gfc_resolve_blocks (gfc_code *b, gfc_nam
 	  resolve_branch (b->label1, b);
 	  break;
 
+	case EXEC_BLOCK:
+	  resolve_block_construct (b);
+	  break;
+
 	case EXEC_SELECT:
 	case EXEC_FORALL:
 	case EXEC_DO:
@@ -6902,7 +6927,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_nam
 	  break;
 
 	default:
-	  gfc_internal_error ("resolve_block(): Bad block type");
+	  gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
 	}
 
       resolve_code (b->next, ns);
@@ -7066,6 +7091,7 @@ resolve_ordinary_assign (gfc_code *code,
   return false;
 }
 
+
 /* Given a block of code, recursively resolve everything pointed to by this
    code block.  */
 
@@ -7250,7 +7276,7 @@ resolve_code (gfc_code *code, gfc_namesp
 	  break;
 
 	case EXEC_CALL_PPC:
-          resolve_ppc_call (code);
+	  resolve_ppc_call (code);
 	  break;
 
 	case EXEC_SELECT:
@@ -7259,6 +7285,10 @@ resolve_code (gfc_code *code, gfc_namesp
 	  resolve_select (code);
 	  break;
 
+	case EXEC_BLOCK:
+	  gfc_resolve (code->ext.ns);
+	  break;
+
 	case EXEC_DO:
 	  if (code->ext.iterator != NULL)
 	    {
Index: gcc/fortran/st.c
===================================================================
--- gcc/fortran/st.c	(revision 151672)
+++ gcc/fortran/st.c	(working copy)
@@ -110,6 +110,10 @@ gfc_free_statement (gfc_code *p)
     case EXEC_ARITHMETIC_IF:
       break;
 
+    case EXEC_BLOCK:
+      gfc_free_namespace (p->ext.ns);
+      break;
+
     case EXEC_COMPCALL:
     case EXEC_CALL_PPC:
     case EXEC_CALL:
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 151672)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -64,6 +64,10 @@ static GTY(()) tree saved_parent_functio
 static struct pointer_set_t *nonlocal_dummy_decl_pset;
 static GTY(()) tree nonlocal_dummy_decls;
 
+/* Holds the variable DECLs that are locals.  */
+
+static GTY(()) tree saved_local_decls;
+
 /* The namespace of the module we're currently generating.  Only used while
    outputting decls for module variables.  Do not rely on this being set.  */
 
@@ -180,6 +184,16 @@ gfc_add_decl_to_function (tree decl)
   saved_function_decls = decl;
 }
 
+static void
+add_decl_as_local (tree decl)
+{
+  gcc_assert (decl);
+  TREE_USED (decl) = 1;
+  DECL_CONTEXT (decl) = current_function_decl;
+  TREE_CHAIN (decl) = saved_local_decls;
+  saved_local_decls = decl;
+}
+
 
 /* Build a  backend label declaration.  Set TREE_USED for named labels.
    The context of the label is always the current_function_decl.  All
@@ -504,8 +518,11 @@ gfc_finish_var_decl (tree decl, gfc_symb
   if (current_function_decl != NULL_TREE)
     {
       if (sym->ns->proc_name->backend_decl == current_function_decl
-          || sym->result == sym)
+	  || sym->result == sym)
 	gfc_add_decl_to_function (decl);
+      else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
+	/* This is a BLOCK construct.  */
+	add_decl_as_local (decl);
       else
 	gfc_add_decl_to_parent_function (decl);
     }
@@ -3054,7 +3071,7 @@ init_intent_out_dt (gfc_symbol * proc_sy
     Initialization and possibly repacking of dummy arrays.
     Initialization of ASSIGN statement auxiliary variable.  */
 
-static tree
+tree
 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 {
   locus loc;
@@ -4570,4 +4587,28 @@ gfc_generate_block_data (gfc_namespace *
 }
 
 
+/* Process the local variables of a BLOCK construct.  */
+
+void
+gfc_process_block_locals (gfc_namespace* ns)
+{
+  tree decl;
+
+  gcc_assert (saved_local_decls == NULL_TREE);
+  generate_local_vars (ns);
+
+  decl = saved_local_decls;
+  while (decl)
+    {
+      tree next;
+
+      next = TREE_CHAIN (decl);
+      TREE_CHAIN (decl) = NULL_TREE;
+      pushdecl (decl);
+      decl = next;
+    }
+  saved_local_decls = NULL_TREE;
+}
+
+
 #include "gt-fortran-trans-decl.h"
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(revision 151672)
+++ gcc/fortran/match.c	(working copy)
@@ -1705,6 +1705,30 @@ gfc_free_iterator (gfc_iterator *iter, i
 }
 
 
+/* Match a BLOCK statement.  */
+
+match
+gfc_match_block (void)
+{
+  match m;
+
+  if (gfc_match_label () == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  if (gfc_match (" block") != MATCH_YES)
+    return MATCH_NO;
+
+  /* For this to be a correct BLOCK statement, the line must end now.  */
+  m = gfc_match_eos ();
+  if (m == MATCH_ERROR)
+    return MATCH_ERROR;
+  if (m == MATCH_NO)
+    return MATCH_NO;
+
+  return MATCH_YES;
+}
+
+
 /* Match a DO statement.  */
 
 match
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h	(revision 151672)
+++ gcc/fortran/match.h	(working copy)
@@ -69,6 +69,7 @@ match gfc_match_assignment (void);
 match gfc_match_if (gfc_statement *);
 match gfc_match_else (void);
 match gfc_match_elseif (void);
+match gfc_match_block (void);
 match gfc_match_do (void);
 match gfc_match_cycle (void);
 match gfc_match_exit (void);
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c	(revision 151672)
+++ gcc/fortran/parse.c	(working copy)
@@ -289,7 +289,7 @@ decode_statement (void)
   gfc_undo_symbols ();
   gfc_current_locus = old_locus;
 
-  /* Check for the IF, DO, SELECT, WHERE and FORALL statements, which
+  /* Check for the IF, DO, SELECT, WHERE, FORALL and BLOCK statements, which
      might begin with a block label.  The match functions for these
      statements are unusual in that their keyword is not seen before
      the matcher is called.  */
@@ -309,6 +309,10 @@ decode_statement (void)
   gfc_undo_symbols ();
   gfc_current_locus = old_locus;
 
+  /* XXX: Is this really correct, what's the difference between IF/WHERE/FORALL
+     above and DO/SELECT below?  */
+  match (NULL, gfc_match_block, ST_BLOCK);
+
   match (NULL, gfc_match_do, ST_DO);
   match (NULL, gfc_match_select, ST_SELECT_CASE);
 
@@ -932,7 +936,8 @@ next_statement (void)
 
 /* Statements that mark other executable statements.  */
 
-#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
+#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
+  case ST_IF_BLOCK: case ST_BLOCK: \
   case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \
   case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
   case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
@@ -951,7 +956,8 @@ next_statement (void)
    are detected in gfc_match_end().  */
 
 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
-		 case ST_END_PROGRAM: case ST_END_SUBROUTINE
+		 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
+		 case ST_END_BLOCK
 
 
 /* Push a new state onto the stack.  */
@@ -1141,6 +1147,9 @@ gfc_ascii_statement (gfc_statement st)
     case ST_BACKSPACE:
       p = "BACKSPACE";
       break;
+    case ST_BLOCK:
+      p = "BLOCK";
+      break;
     case ST_BLOCK_DATA:
       p = "BLOCK DATA";
       break;
@@ -1189,6 +1198,9 @@ gfc_ascii_statement (gfc_statement st)
     case ST_ELSEWHERE:
       p = "ELSEWHERE";
       break;
+    case ST_END_BLOCK:
+      p = "END BLOCK";
+      break;
     case ST_END_BLOCK_DATA:
       p = "END BLOCK DATA";
       break;
@@ -2907,6 +2919,51 @@ check_do_closure (void)
 }
 
 
+/* Parse a series of contained program units.  */
+
+static void parse_progunit (gfc_statement);
+
+
+/* Parse a BLOCK construct.  */
+
+static void
+parse_block_construct (void)
+{
+  gfc_namespace* parent_ns;
+  gfc_namespace* my_ns;
+  gfc_state_data s;
+
+  gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
+
+  parent_ns = gfc_current_ns;
+  my_ns = gfc_get_namespace (parent_ns, 1);
+  if (gfc_new_block)
+    my_ns->proc_name = gfc_new_block;
+  else
+    {
+      gfc_try t;
+
+      gfc_get_symbol ("block@", my_ns, &my_ns->proc_name);
+      t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
+			  my_ns->proc_name->name, NULL);
+      gcc_assert (t == SUCCESS);
+    }
+  my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
+
+  new_st.op = EXEC_BLOCK;
+  new_st.ext.ns = my_ns;
+  accept_statement (ST_BLOCK);
+
+  push_state (&s, COMP_BLOCK, my_ns->proc_name);
+  gfc_current_ns = my_ns;
+
+  parse_progunit (ST_NONE);
+
+  gfc_current_ns = parent_ns;
+  pop_state ();
+}
+
+
 /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
    handled inside of parse_executable(), because they aren't really
    loop statements.  */
@@ -3300,6 +3357,10 @@ parse_executable (gfc_statement st)
 	    return ST_IMPLIED_ENDDO;
 	  break;
 
+	case ST_BLOCK:
+	  parse_block_construct ();
+	  break;
+
 	case ST_IF_BLOCK:
 	  parse_if_block ();
 	  break;
@@ -3358,11 +3419,6 @@ parse_executable (gfc_statement st)
 }
 
 
-/* Parse a series of contained program units.  */
-
-static void parse_progunit (gfc_statement);
-
-
 /* Fix the symbols for sibling functions.  These are incorrectly added to
    the child namespace as the parser didn't know about this procedure.  */
 
Index: gcc/fortran/parse.h
===================================================================
--- gcc/fortran/parse.h	(revision 151672)
+++ gcc/fortran/parse.h	(working copy)
@@ -29,7 +29,8 @@ along with GCC; see the file COPYING3.  
 typedef enum
 {
   COMP_NONE, COMP_PROGRAM, COMP_MODULE, COMP_SUBROUTINE, COMP_FUNCTION,
-  COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS, COMP_IF,
+  COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS,
+  COMP_BLOCK, COMP_IF,
   COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
   COMP_OMP_STRUCTURED_BLOCK
 }
Index: gcc/testsuite/gfortran.dg/block_2.f08
===================================================================
--- gcc/testsuite/gfortran.dg/block_2.f08	(revision 0)
+++ gcc/testsuite/gfortran.dg/block_2.f08	(revision 0)
@@ -0,0 +1,36 @@
+! { dg-do run }
+! { dg-options "-std=f2008 -fall-intrinsics" }
+
+! More sophisticated BLOCK runtime checks for correct initialization/clean-up.
+
+PROGRAM main
+  IMPLICIT NONE
+  INTEGER :: n
+
+  n = 5
+
+  myblock: BLOCK
+    INTEGER :: arr(n)
+    IF (SIZE (arr) /= 5) CALL abort ()
+    BLOCK
+      INTEGER :: arr(2*n)
+      IF (SIZE (arr) /= 10) CALL abort ()
+    END BLOCK
+    IF (SIZE (arr) /= 5) CALL abort ()
+  END BLOCK
+
+  BLOCK
+    INTEGER, ALLOCATABLE :: arr(:)
+    IF (ALLOCATED (arr)) CALL abort ()
+    ALLOCATE (arr(n))
+    IF (SIZE (arr) /= 5) CALL abort ()
+    ! XXX: Can we check it gets free'ed here?
+  END BLOCK
+
+  BLOCK
+    CHARACTER(LEN=n) :: str
+    IF (LEN (str) /= 5) CALL abort ()
+    str = "123456789"
+    IF (str /= "12345") CALL abort ()
+  END BLOCK
+END PROGRAM main
Index: gcc/testsuite/gfortran.dg/block_4.f08
===================================================================
--- gcc/testsuite/gfortran.dg/block_4.f08	(revision 0)
+++ gcc/testsuite/gfortran.dg/block_4.f08	(revision 0)
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+
+! Check for label mismatch errors with BLOCK statements.
+
+PROGRAM main
+  IMPLICIT NONE
+
+  BLOCK 
+  END BLOCK wrongname ! { dg-error "Syntax error" }
+
+  myname: BLOCK
+  END BLOCK wrongname ! { dg-error "Expected label 'myname'" }
+END PROGRAM main ! { dg-error "Expecting END BLOCK" }
+! { dg-excess-errors "Unexpected end of file" }
Index: gcc/testsuite/gfortran.dg/block_1.f08
===================================================================
--- gcc/testsuite/gfortran.dg/block_1.f08	(revision 0)
+++ gcc/testsuite/gfortran.dg/block_1.f08	(revision 0)
@@ -0,0 +1,34 @@
+! { dg-do run }
+! { dg-options "-std=f2008 -fall-intrinsics" }
+
+! Basic Fortran 2008 BLOCK construct test.
+
+PROGRAM main
+  IMPLICIT NONE
+  INTEGER :: i
+
+  i = 42
+
+  ! Empty block.
+  BLOCK
+  END BLOCK
+
+  ! Block without local variables but name.
+  emptyblock: BLOCK
+    IF (i /= 42) CALL abort ()
+    i = 5
+  END BLOCK ! No label here, should be ok.
+  IF (i /= 5) CALL abort ()
+
+  ! Named block with local variable and nested block.
+  myblock: BLOCK
+    INTEGER :: i
+    i = -1
+    BLOCK
+      IF (i /= -1) CALL abort ()
+      i = -2
+    END BLOCK
+    IF (i /= -2) CALL abort ()
+  END BLOCK myblock ! Matching end-label.
+  IF (i /= 5) CALL abort ()
+END PROGRAM main
Index: gcc/testsuite/gfortran.dg/block_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/block_3.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/block_3.f90	(revision 0)
@@ -0,0 +1,12 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+
+! BLOCK should be rejected without F2008.
+
+PROGRAM main
+  IMPLICIT NONE
+
+  BLOCK ! { dg-error "Fortran 2008" }
+    INTEGER :: i
+  END BLOCK
+END PROGRAM main

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]