gfortran.h: New statement-type ST_FINAL for FINAL declarations.

2008-06-02  Daniel Kraft  <d@domob.eu>

        * gfortran.h:  New statement-type ST_FINAL for FINAL declarations.
        (struct gfc_symbol):  New member f2k_derived.
        (struct gfc_namespace):  New member finalizers, for use in the above
        mentioned f2k_derived namespace.
        (struct gfc_finalizer):  New type defined for finalizers linked list.
        * match.h (gfc_match_final_decl):  New function header.
        * decl.c (gfc_match_derived_decl):  Create f2k_derived namespace
        on constructed symbol node.
        (gfc_match_final_decl):  New function to match a FINAL declaration line.
        * parse.c (decode_statement):  match-call for keyword FINAL.
        (parse_derived):  Parse CONTAINS section and accept FINAL statements.
        * resolve.c (gfc_resolve_finalizers):  New function to resolve
        (that is in this case, check) a list of finalizer procedures.
        (resolve_fl_derived):  Call gfc_resolve_finalizers here.
        * symbol.c (gfc_get_namespace):  Initialize new finalizers to NULL.
        (gfc_free_namespace):  Free finalizers list.
        (gfc_new_symbol):  Initialize new f2k_derived to NULL.
        (gfc_free_symbol):  Free f2k_derived namespace.
        (gfc_free_finalizer):  New function to free a single gfc_finalizer node.
        (gfc_free_finalizer_list):  New function to free a linked list of
        gfc_finalizer nodes.

2008-06-02  Daniel Kraft  <d@domob.eu>

        * finalize_1.f08:  New test.
        * finalize_2.f03:  New test.
        * finalize_3.f03:  New test.
        * finalize_4.f03:  New test.
        * finalize_5.f03:  New test.
        * finalize_6.f90:  New test.
        * finalize_7.f03:  New test.
        * finalize_8.f03:  New test.

From-SVN: r136293

gcc/fortran/ChangeLog

+2008-06-02  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.h:  New statement-type ST_FINAL for FINAL declarations.
+	(struct gfc_symbol):  New member f2k_derived.
+	(struct gfc_namespace):  New member finalizers, for use in the above
+	mentioned f2k_derived namespace.
+	(struct gfc_finalizer):  New type defined for finalizers linked list.
+	* match.h (gfc_match_final_decl):  New function header.
+	* decl.c (gfc_match_derived_decl):  Create f2k_derived namespace on
+	constructed symbol node.
+	(gfc_match_final_decl):  New function to match a FINAL declaration line.
+	* parse.c (decode_statement):  match-call for keyword FINAL.
+	(parse_derived):  Parse CONTAINS section and accept FINAL statements.
+	* resolve.c (gfc_resolve_finalizers):  New function to resolve (that is
+	in this case, check) a list of finalizer procedures.
+	(resolve_fl_derived):  Call gfc_resolve_finalizers here.
+	* symbol.c (gfc_get_namespace):  Initialize new finalizers to NULL.
+	(gfc_free_namespace):  Free finalizers list.
+	(gfc_new_symbol):  Initialize new f2k_derived to NULL.
+	(gfc_free_symbol):  Free f2k_derived namespace.
+	(gfc_free_finalizer):  New function to free a single gfc_finalizer node.
+	(gfc_free_finalizer_list):  New function to free a linked list of
+	gfc_finalizer nodes.
+
 2008-06-02  Daniel Franke  <franke.daniel@gmail.com>
 
 	PR fortran/36375

gcc/fortran/decl.c

@@ -6270,6 +6270,10 @@ gfc_match_derived_decl (void)
   if (attr.is_bind_c != 0)
     sym->attr.is_bind_c = attr.is_bind_c;
 
+  /* Construct the f2k_derived namespace if it is not yet there.  */
+  if (!sym->f2k_derived)
+    sym->f2k_derived = gfc_get_namespace (NULL, 0);
+
   gfc_new_block = sym;
 
   return MATCH_YES;
@@ -6480,3 +6484,105 @@ cleanup:
 
 }
 
+/* Match a FINAL declaration inside a derived type.  */
+
+match
+gfc_match_final_decl (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol* sym;
+  match m;
+  gfc_namespace* module_ns;
+  bool first, last;
+
+  if (gfc_state_stack->state != COMP_DERIVED)
+    {
+      gfc_error ("FINAL declaration at %C must be inside a derived type "
+		 "definition!");
+      return MATCH_ERROR;
+    }
+
+  gcc_assert (gfc_current_block ());
+
+  if (!gfc_state_stack->previous
+      || gfc_state_stack->previous->state != COMP_MODULE)
+    {
+      gfc_error ("Derived type declaration with FINAL at %C must be in the"
+		 " specification part of a MODULE");
+      return MATCH_ERROR;
+    }
+
+  module_ns = gfc_current_ns;
+  gcc_assert (module_ns);
+  gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
+
+  /* Match optional ::, don't care about MATCH_YES or MATCH_NO.  */
+  if (gfc_match (" ::") == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  /* Match the sequence of procedure names.  */
+  first = true;
+  last = false;
+  do
+    {
+      gfc_finalizer* f;
+
+      if (first && gfc_match_eos () == MATCH_YES)
+	{
+	  gfc_error ("Empty FINAL at %C");
+	  return MATCH_ERROR;
+	}
+
+      m = gfc_match_name (name);
+      if (m == MATCH_NO)
+	{
+	  gfc_error ("Expected module procedure name at %C");
+	  return MATCH_ERROR;
+	}
+      else if (m != MATCH_YES)
+	return MATCH_ERROR;
+
+      if (gfc_match_eos () == MATCH_YES)
+	last = true;
+      if (!last && gfc_match_char (',') != MATCH_YES)
+	{
+	  gfc_error ("Expected ',' at %C");
+	  return MATCH_ERROR;
+	}
+
+      if (gfc_get_symbol (name, module_ns, &sym))
+	{
+	  gfc_error ("Unknown procedure name \"%s\" at %C", name);
+	  return MATCH_ERROR;
+	}
+
+      /* Mark the symbol as module procedure.  */
+      if (sym->attr.proc != PROC_MODULE
+	  && gfc_add_procedure (&sym->attr, PROC_MODULE,
+				sym->name, NULL) == FAILURE)
+	return MATCH_ERROR;
+
+      /* Check if we already have this symbol in the list, this is an error.  */
+      for (f = gfc_current_block ()->f2k_derived->finalizers; f; f = f->next)
+	if (f->procedure == sym)
+	  {
+	    gfc_error ("'%s' at %C is already defined as FINAL procedure!",
+		       name);
+	    return MATCH_ERROR;
+	  }
+
+      /* Add this symbol to the list of finalizers.  */
+      gcc_assert (gfc_current_block ()->f2k_derived);
+      ++sym->refs;
+      f = gfc_getmem (sizeof (gfc_finalizer));     
+      f->procedure = sym;
+      f->where = gfc_current_locus;
+      f->next = gfc_current_block ()->f2k_derived->finalizers;
+      gfc_current_block ()->f2k_derived->finalizers = f;
+
+      first = false;
+    }
+  while (!last);
+
+  return MATCH_YES;
+}

gcc/fortran/gfortran.h

@@ -210,7 +210,7 @@ typedef enum
   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_END_FILE, ST_FLUSH, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF,
+  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,
@@ -1014,6 +1014,10 @@ typedef struct gfc_symbol
   gfc_formal_arglist *formal;
   struct gfc_namespace *formal_ns;
 
+  /* The namespace containing type-associated procedure symbols.  */
+  /* TODO: Make this union with formal?  */
+  struct gfc_namespace *f2k_derived;
+
   struct gfc_expr *value;	/* Parameter/Initializer value */
   gfc_array_spec *as;
   struct gfc_symbol *result;	/* function result symbol */
@@ -1151,6 +1155,8 @@ typedef struct gfc_namespace
   gfc_symtree *uop_root;
   /* Tree containing all the common blocks.  */
   gfc_symtree *common_root;
+  /* Linked list of finalizer procedures.  */
+  struct gfc_finalizer *finalizers;
 
   /* If set_flag[letter] is set, an implicit type has been set for letter.  */
   int set_flag[GFC_LETTERS];
@@ -1942,6 +1948,17 @@ typedef struct iterator_stack
 iterator_stack;
 extern iterator_stack *iter_stack;
 
+
+/* Node in the linked list used for storing finalizer procedures.  */
+
+typedef struct gfc_finalizer
+{
+  struct gfc_finalizer* next;
+  gfc_symbol* procedure;
+  locus where; /* Where the FINAL declaration occured.  */
+}
+gfc_finalizer;
+
 /************************ Function prototypes *************************/
 
 /* decl.c */
@@ -2210,6 +2227,8 @@ gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
 
 void copy_formal_args (gfc_symbol *dest, gfc_symbol *src);
 
+void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too  */
+
 /* intrinsic.c */
 extern int gfc_init_expr;
 

gcc/fortran/match.h

@@ -140,6 +140,7 @@ match gfc_match_function_decl (void);
 match gfc_match_entry (void);
 match gfc_match_subroutine (void);
 match gfc_match_derived_decl (void);
+match gfc_match_final_decl (void);
 
 match gfc_match_implicit_none (void);
 match gfc_match_implicit (void);

gcc/fortran/parse.c

@@ -366,6 +366,7 @@ decode_statement (void)
       break;
 
     case 'f':
+      match ("final", gfc_match_final_decl, ST_FINAL);
       match ("flush", gfc_match_flush, ST_FLUSH);
       match ("format", gfc_match_format, ST_FORMAT);
       break;
@@ -1682,6 +1683,7 @@ static void
 parse_derived (void)
 {
   int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
+  int seen_contains, seen_contains_comp;
   gfc_statement st;
   gfc_state_data s;
   gfc_symbol *derived_sym = NULL;
@@ -1697,6 +1699,8 @@ parse_derived (void)
   seen_private = 0;
   seen_sequence = 0;
   seen_component = 0;
+  seen_contains = 0;
+  seen_contains_comp = 0;
 
   compiling_type = 1;
 
@@ -1710,23 +1714,57 @@ parse_derived (void)
 
 	case ST_DATA_DECL:
 	case ST_PROCEDURE:
+	  if (seen_contains)
+	    {
+	      gfc_error ("Components in TYPE at %C must precede CONTAINS");
+	      error_flag = 1;
+	    }
+
 	  accept_statement (st);
 	  seen_component = 1;
 	  break;
 
+	case ST_FINAL:
+	  if (!seen_contains)
+	    {
+	      gfc_error ("FINAL declaration at %C must be inside CONTAINS");
+	      error_flag = 1;
+	    }
+
+	  if (gfc_notify_std (GFC_STD_F2003,
+			      "Fortran 2003:  FINAL procedure declaration"
+			      " at %C") == FAILURE)
+	    error_flag = 1;
+
+	  accept_statement (ST_FINAL);
+	  seen_contains_comp = 1;
+	  break;
+
 	case ST_END_TYPE:
 	  compiling_type = 0;
 
 	  if (!seen_component
 	      && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type "
-			         "definition at %C without components")
+				 "definition at %C without components")
 		  == FAILURE))
 	    error_flag = 1;
 
+	  if (seen_contains && !seen_contains_comp
+	      && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
+				 "definition at %C with empty CONTAINS "
+				 "section") == FAILURE))
+	    error_flag = 1;
+
 	  accept_statement (ST_END_TYPE);
 	  break;
 
 	case ST_PRIVATE:
+	  if (seen_contains)
+	    {
+	      gfc_error ("PRIVATE statement at %C must precede CONTAINS");
+	      error_flag = 1;
+	    }
+
 	  if (gfc_find_state (COMP_MODULE) == FAILURE)
 	    {
 	      gfc_error ("PRIVATE statement in TYPE at %C must be inside "
@@ -1755,6 +1793,12 @@ parse_derived (void)
 	  break;
 
 	case ST_SEQUENCE:
+	  if (seen_contains)
+	    {
+	      gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
+	      error_flag = 1;
+	    }
+
 	  if (seen_component)
 	    {
 	      gfc_error ("SEQUENCE statement at %C must precede "
@@ -1778,6 +1822,22 @@ parse_derived (void)
 			    gfc_current_block ()->name, NULL);
 	  break;
 
+	case ST_CONTAINS:
+	  if (gfc_notify_std (GFC_STD_F2003,
+			      "Fortran 2003:  CONTAINS block in derived type"
+			      " definition at %C") == FAILURE)
+	    error_flag = 1;
+
+	  if (seen_contains)
+	    {
+	      gfc_error ("Already inside a CONTAINS block at %C");
+	      error_flag = 1;
+	    }
+
+	  seen_contains = 1;
+	  accept_statement (ST_CONTAINS);
+	  break;
+
 	default:
 	  unexpected_statement (st);
 	  break;

gcc/fortran/resolve.c

@@ -7439,6 +7439,146 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
 }
 
 
+/* Resolve a list of finalizer procedures.  That is, after they have hopefully
+   been defined and we now know their defined arguments, check that they fulfill
+   the requirements of the standard for procedures used as finalizers.  */
+
+static try
+gfc_resolve_finalizers (gfc_symbol* derived)
+{
+  gfc_finalizer* list;
+  gfc_finalizer** prev_link; /* For removing wrong entries from the list.  */
+  try result = SUCCESS;
+  bool seen_scalar = false;
+
+  if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
+    return SUCCESS;
+
+  /* Walk over the list of finalizer-procedures, check them, and if any one
+     does not fit in with the standard's definition, print an error and remove
+     it from the list.  */
+  prev_link = &derived->f2k_derived->finalizers;
+  for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
+    {
+      gfc_symbol* arg;
+      gfc_finalizer* i;
+      int my_rank;
+
+      /* Check this exists and is a SUBROUTINE.  */
+      if (!list->procedure->attr.subroutine)
+	{
+	  gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
+		     list->procedure->name, &list->where);
+	  goto error;
+	}
+
+      /* We should have exactly one argument.  */
+      if (!list->procedure->formal || list->procedure->formal->next)
+	{
+	  gfc_error ("FINAL procedure at %L must have exactly one argument",
+		     &list->where);
+	  goto error;
+	}
+      arg = list->procedure->formal->sym;
+
+      /* This argument must be of our type.  */
+      if (arg->ts.type != BT_DERIVED || arg->ts.derived != derived)
+	{
+	  gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
+		     &arg->declared_at, derived->name);
+	  goto error;
+	}
+
+      /* It must neither be a pointer nor allocatable nor optional.  */
+      if (arg->attr.pointer)
+	{
+	  gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
+		     &arg->declared_at);
+	  goto error;
+	}
+      if (arg->attr.allocatable)
+	{
+	  gfc_error ("Argument of FINAL procedure at %L must not be"
+		     " ALLOCATABLE", &arg->declared_at);
+	  goto error;
+	}
+      if (arg->attr.optional)
+	{
+	  gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
+		     &arg->declared_at);
+	  goto error;
+	}
+
+      /* It must not be INTENT(OUT).  */
+      if (arg->attr.intent == INTENT_OUT)
+	{
+	  gfc_error ("Argument of FINAL procedure at %L must not be"
+		     " INTENT(OUT)", &arg->declared_at);
+	  goto error;
+	}
+
+      /* Warn if the procedure is non-scalar and not assumed shape.  */
+      if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
+	  && arg->as->type != AS_ASSUMED_SHAPE)
+	gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
+		     " shape argument", &arg->declared_at);
+
+      /* Check that it does not match in kind and rank with a FINAL procedure
+	 defined earlier.  To really loop over the *earlier* declarations,
+	 we need to walk the tail of the list as new ones were pushed at the
+	 front.  */
+      /* TODO: Handle kind parameters once they are implemented.  */
+      my_rank = (arg->as ? arg->as->rank : 0);
+      for (i = list->next; i; i = i->next)
+	{
+	  /* Argument list might be empty; that is an error signalled earlier,
+	     but we nevertheless continued resolving.  */
+	  if (i->procedure->formal)
+	    {
+	      gfc_symbol* i_arg = i->procedure->formal->sym;
+	      const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
+	      if (i_rank == my_rank)
+		{
+		  gfc_error ("FINAL procedure '%s' declared at %L has the same"
+			     " rank (%d) as '%s'",
+			     list->procedure->name, &list->where, my_rank, 
+			     i->procedure->name);
+		  goto error;
+		}
+	    }
+	}
+
+	/* Is this the/a scalar finalizer procedure?  */
+	if (!arg->as || arg->as->rank == 0)
+	  seen_scalar = true;
+
+	prev_link = &list->next;
+	continue;
+
+	/* Remove wrong nodes immediatelly from the list so we don't risk any
+	   troubles in the future when they might fail later expectations.  */
+error:
+	result = FAILURE;
+	i = list;
+	*prev_link = list->next;
+	gfc_free_finalizer (i);
+    }
+
+  /* Warn if we haven't seen a scalar finalizer procedure (but we know there
+     were nodes in the list, must have been for arrays.  It is surely a good
+     idea to have a scalar version there if there's something to finalize.  */
+  if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
+    gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
+		 " defined at %L, suggest also scalar one",
+		 derived->name, &derived->declared_at);
+
+  /* TODO:  Remove this error when finalization is finished.  */
+  gfc_error ("Finalization at %L is not yet implemented", &derived->declared_at);
+
+  return result;
+}
+
+
 /* Resolve the components of a derived type.  */
 
 static try
@@ -7517,6 +7657,10 @@ resolve_fl_derived (gfc_symbol *sym)
 	}
     }
 
+  /* Resolve the finalizer procedures.  */
+  if (gfc_resolve_finalizers (sym) == FAILURE)
+    return FAILURE;
+
   /* Add derived type to the derived type list.  */
   for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
     if (sym == dt_list->derived)

gcc/fortran/symbol.c

@@ -2096,6 +2096,7 @@ gfc_get_namespace (gfc_namespace *parent, int parent_types)
   ns = gfc_getmem (sizeof (gfc_namespace));
   ns->sym_root = NULL;
   ns->uop_root = NULL;
+  ns->finalizers = NULL;
   ns->default_access = ACCESS_UNKNOWN;
   ns->parent = parent;
 
@@ -2284,6 +2285,8 @@ gfc_free_symbol (gfc_symbol *sym)
 
   gfc_free_formal_arglist (sym->formal);
 
+  gfc_free_namespace (sym->f2k_derived);
+
   gfc_free (sym);
 }
 
@@ -2316,6 +2319,7 @@ gfc_new_symbol (const char *name, gfc_namespace *ns)
 
   /* Clear the ptrs we may need.  */
   p->common_block = NULL;
+  p->f2k_derived = NULL;
   
   return p;
 }
@@ -2884,6 +2888,33 @@ gfc_free_equiv_lists (gfc_equiv_list *l)
 }
 
 
+/* Free a finalizer procedure list.  */
+
+void
+gfc_free_finalizer (gfc_finalizer* el)
+{
+  if (el)
+    {
+      --el->procedure->refs;
+      if (!el->procedure->refs)
+	gfc_free_symbol (el->procedure);
+
+      gfc_free (el);
+    }
+}
+
+static void
+gfc_free_finalizer_list (gfc_finalizer* list)
+{
+  while (list)
+    {
+      gfc_finalizer* current = list;
+      list = list->next;
+      gfc_free_finalizer (current);
+    }
+}
+
+
 /* Free a namespace structure and everything below it.  Interface
    lists associated with intrinsic operators are not freed.  These are
    taken care of when a specific name is freed.  */
@@ -2908,6 +2939,7 @@ gfc_free_namespace (gfc_namespace *ns)
   free_sym_tree (ns->sym_root);
   free_uop_tree (ns->uop_root);
   free_common_tree (ns->common_root);
+  gfc_free_finalizer_list (ns->finalizers);
 
   for (cl = ns->cl_list; cl; cl = cl2)
     {

gcc/testsuite/ChangeLog

+2008-06-02  Daniel Kraft  <d@domob.eu>
+
+	* finalize_1.f08:  New test.
+	* finalize_2.f03:  New test.
+	* finalize_3.f03:  New test.
+	* finalize_4.f03:  New test.
+	* finalize_5.f03:  New test.
+	* finalize_6.f90:  New test.
+	* finalize_7.f03:  New test.
+	* finalize_8.f03:  New test.
+
 2008-06-01  Richard Sandiford  <rdsandiford@googlemail.com>
 
 	* gcc.c-torture/execute/ieee/ieee.exp: Load c-torture.exp.

gcc/testsuite/gfortran.dg/finalize_1.f08

+! { dg-do compile }
+
+! Parsing of finalizer procedure definitions.
+! Check that CONTAINS is allowed in TYPE definition; but empty only for F2008
+
+MODULE final_type
+  IMPLICIT NONE
+
+  TYPE :: mytype
+    INTEGER, ALLOCATABLE :: fooarr(:)
+    REAL :: foobar
+  CONTAINS
+  END TYPE mytype
+
+CONTAINS
+  
+  SUBROUTINE bar
+    TYPE :: t
+    CONTAINS ! This is ok
+    END TYPE t
+    ! Nothing
+  END SUBROUTINE bar
+
+END MODULE final_type
+
+PROGRAM finalizer
+  IMPLICIT NONE
+  ! Do nothing here
+END PROGRAM finalizer
+
+! { dg-final { cleanup-modules "final_type" } }

gcc/testsuite/gfortran.dg/finalize_2.f03

+! { dg-do compile }
+! { dg-options "-std=f2003" }
+
+! Parsing of finalizer procedure definitions.
+! Check empty CONTAINS errors out for F2003.
+
+MODULE final_type
+  IMPLICIT NONE
+
+  TYPE :: mytype
+    INTEGER, ALLOCATABLE :: fooarr(:)
+    REAL :: foobar
+  CONTAINS
+  END TYPE mytype ! { dg-error "Fortran 2008" }
+
+END MODULE final_type
+
+PROGRAM finalizer
+  IMPLICIT NONE
+  ! Do nothing here
+END PROGRAM finalizer
+
+! { dg-final { cleanup-modules "final_type" } }

gcc/testsuite/gfortran.dg/finalize_3.f03

+! { dg-do compile }
+
+! Parsing of finalizer procedure definitions.
+! Check that CONTAINS disallows further components and no double CONTAINS
+! is allowed.
+
+MODULE final_type
+  IMPLICIT NONE
+
+  TYPE :: mytype
+    INTEGER, ALLOCATABLE :: fooarr(:)
+    REAL :: foobar
+  CONTAINS
+  CONTAINS ! { dg-error "Already inside a CONTAINS block" }
+    INTEGER :: x ! { dg-error "must precede CONTAINS" }
+  END TYPE mytype
+
+END MODULE final_type
+
+PROGRAM finalizer
+  IMPLICIT NONE
+  ! Do nothing here
+END PROGRAM finalizer
+
+! { dg-final { cleanup-modules "final_type" } }

gcc/testsuite/gfortran.dg/finalize_4.f03

+! { dg-do compile }
+
+! Parsing of finalizer procedure definitions.
+! Check parsing of valid finalizer definitions.
+
+MODULE final_type
+  IMPLICIT NONE
+
+  TYPE :: mytype
+    INTEGER, ALLOCATABLE :: fooarr(:)
+    REAL :: foobar
+  CONTAINS
+    FINAL :: finalize_single
+    FINAL finalize_vector, finalize_matrix
+    ! TODO:  Test with different kind type parameters once they are implemented.
+  END TYPE mytype
+
+CONTAINS
+
+  ELEMENTAL SUBROUTINE finalize_single (el)
+    IMPLICIT NONE
+    TYPE(mytype), INTENT(IN) :: el
+    ! Do nothing in this test
+  END SUBROUTINE finalize_single
+
+  SUBROUTINE finalize_vector (el)
+    IMPLICIT NONE
+    TYPE(mytype), INTENT(INOUT) :: el(:)
+    ! Do nothing in this test
+  END SUBROUTINE finalize_vector
+
+  SUBROUTINE finalize_matrix (el)
+    IMPLICIT NONE
+    TYPE(mytype) :: el(:, :)
+    ! Do nothing in this test
+  END SUBROUTINE finalize_matrix
+
+END MODULE final_type
+
+PROGRAM finalizer
+  USE final_type, ONLY: mytype
+  IMPLICIT NONE
+
+  TYPE(mytype) :: el, vec(42)
+  TYPE(mytype), ALLOCATABLE :: mat(:, :)
+
+  ALLOCATE(mat(2, 3))
+  DEALLOCATE(mat)
+
+END PROGRAM finalizer
+
+! TODO: Remove this once finalization is implemented.
+! { dg-excess-errors "not yet implemented" }
+
+! { dg-final { cleanup-modules "final_type" } }

gcc/testsuite/gfortran.dg/finalize_5.f03

+! { dg-do compile }
+
+! Parsing of finalizer procedure definitions.
+! Check for appropriate errors on invalid final procedures.
+
+MODULE final_type
+  IMPLICIT NONE
+
+  TYPE :: mytype
+    INTEGER, ALLOCATABLE :: fooarr(:)
+    REAL :: foobar
+    FINAL :: finalize_matrix ! { dg-error "must be inside CONTAINS" }
+  CONTAINS
+    FINAL :: ! { dg-error "Empty FINAL" }
+    FINAL ! { dg-error "Empty FINAL" }
+    FINAL :: + ! { dg-error "Expected module procedure name" }
+    FINAL :: iamnot ! { dg-error "is not a SUBROUTINE" }
+    FINAL :: finalize_single finalize_vector ! { dg-error "Expected ','" }
+    FINAL :: finalize_single, finalize_vector
+    FINAL :: finalize_single ! { dg-error "is already defined" }
+    FINAL :: finalize_vector_2 ! { dg-error "has the same rank" }
+    FINAL :: finalize_single_2 ! { dg-error "has the same rank" }
+    FINAL :: bad_function ! { dg-error "is not a SUBROUTINE" }
+    FINAL bad_num_args_1 ! { dg-error "must have exactly one argument" }
+    FINAL bad_num_args_2 ! { dg-error "must have exactly one argument" }
+    FINAL bad_arg_type
+    FINAL :: bad_pointer
+    FINAL :: bad_alloc
+    FINAL :: bad_optional
+    FINAL :: bad_intent_out
+
+    ! TODO:  Test for polymorphism, kind parameters once those are implemented.
+  END TYPE mytype
+
+CONTAINS
+
+  SUBROUTINE finalize_single (el)
+    IMPLICIT NONE
+    TYPE(mytype) :: el
+  END SUBROUTINE finalize_single
+
+  ELEMENTAL SUBROUTINE finalize_single_2 (el)
+    IMPLICIT NONE
+    TYPE(mytype), INTENT(IN) :: el
+  END SUBROUTINE finalize_single_2
+
+  SUBROUTINE finalize_vector (el)
+    IMPLICIT NONE
+    TYPE(mytype), INTENT(INOUT) :: el(:)
+  END SUBROUTINE finalize_vector
+
+  SUBROUTINE finalize_vector_2 (el)
+    IMPLICIT NONE
+    TYPE(mytype), INTENT(IN) :: el(:)
+  END SUBROUTINE finalize_vector_2
+  
+  SUBROUTINE finalize_matrix (el)
+    IMPLICIT NONE
+    TYPE(mytype) :: el(:, :)
+  END SUBROUTINE finalize_matrix
+
+  INTEGER FUNCTION bad_function (el)
+    IMPLICIT NONE
+    TYPE(mytype) :: el
+
+    bad_function = 42
+  END FUNCTION bad_function
+
+  SUBROUTINE bad_num_args_1 ()
+    IMPLICIT NONE
+  END SUBROUTINE bad_num_args_1
+
+  SUBROUTINE bad_num_args_2 (el, x)
+    IMPLICIT NONE
+    TYPE(mytype) :: el
+    COMPLEX :: x
+  END SUBROUTINE bad_num_args_2
+
+  SUBROUTINE bad_arg_type (el) ! { dg-error "must be of type 'mytype'" }
+    IMPLICIT NONE
+    REAL :: el
+  END SUBROUTINE bad_arg_type
+
+  SUBROUTINE bad_pointer (el) ! { dg-error "must not be a POINTER" }
+    IMPLICIT NONE
+    TYPE(mytype), POINTER :: el
+  END SUBROUTINE bad_pointer
+
+  SUBROUTINE bad_alloc (el) ! { dg-error "must not be ALLOCATABLE" }
+    IMPLICIT NONE
+    TYPE(mytype), ALLOCATABLE :: el(:)
+  END SUBROUTINE bad_alloc
+
+  SUBROUTINE bad_optional (el) ! { dg-error "must not be OPTIONAL" }
+    IMPLICIT NONE
+    TYPE(mytype), OPTIONAL :: el
+  END SUBROUTINE bad_optional
+
+  SUBROUTINE bad_intent_out (el) ! { dg-error "must not be INTENT\\(OUT\\)" }
+    IMPLICIT NONE
+    TYPE(mytype), INTENT(OUT) :: el
+  END SUBROUTINE bad_intent_out
+
+END MODULE final_type
+
+PROGRAM finalizer
+  IMPLICIT NONE
+  ! Nothing here, errors above
+END PROGRAM finalizer
+
+! TODO: Remove this once finalization is implemented.
+! { dg-excess-errors "not yet implemented" }
+
+! { dg-final { cleanup-modules "final_type" } }

gcc/testsuite/gfortran.dg/finalize_6.f90

+! { dg-do compile }
+! { dg-options "-std=f95" }
+
+! Parsing of finalizer procedure definitions.
+! Check that CONTAINS/FINAL in derived types is rejected for F95.
+
+MODULE final_type
+  IMPLICIT NONE
+
+  TYPE :: mytype
+    INTEGER :: fooarr(42)
+    REAL :: foobar
+  CONTAINS ! { dg-error "Fortran 2003" }
+    FINAL :: finalize_single ! { dg-error "Fortran 2003" }
+  END TYPE mytype
+
+CONTAINS
+
+  SUBROUTINE finalize_single (el)
+    IMPLICIT NONE
+    TYPE(mytype) :: el
+    ! Do nothing in this test
+  END SUBROUTINE finalize_single
+
+END MODULE final_type
+
+PROGRAM finalizer
+  IMPLICIT NONE
+  ! Do nothing
+END PROGRAM finalizer
+
+! TODO: Remove this once finalization is implemented.
+! { dg-excess-errors "not yet implemented" }
+
+! { dg-final { cleanup-modules "final_type" } }

gcc/testsuite/gfortran.dg/finalize_7.f03

+! { dg-do compile }
+! { dg-options "-Wsurprising" }
+
+! Implementation of finalizer procedures.
+! Check for expected warnings on dubious FINAL constructs.
+
+MODULE final_type
+  IMPLICIT NONE
+
+  TYPE :: type_1
+    INTEGER, ALLOCATABLE :: fooarr(:)
+    REAL :: foobar
+  CONTAINS
+    ! Non-scalar procedures should be assumed shape
+    FINAL :: fin1_scalar
+    FINAL :: fin1_shape_1
+    FINAL :: fin1_shape_2
+  END TYPE type_1
+
+  TYPE :: type_2 ! { dg-warning "Only array FINAL procedures" }
+    REAL :: x
+  CONTAINS
+    ! No scalar finalizer, only array ones
+    FINAL :: fin2_vector
+  END TYPE type_2
+
+CONTAINS
+
+  SUBROUTINE fin1_scalar (el)
+    IMPLICIT NONE
+    TYPE(type_1) :: el
+  END SUBROUTINE fin1_scalar
+
+  SUBROUTINE fin1_shape_1 (v) ! { dg-warning "assumed shape" }
+    IMPLICIT NONE
+    TYPE(type_1) :: v(*)
+  END SUBROUTINE fin1_shape_1
+
+  SUBROUTINE fin1_shape_2 (v) ! { dg-warning "assumed shape" }
+    IMPLICIT NONE
+    TYPE(type_1) :: v(42, 5)
+  END SUBROUTINE fin1_shape_2
+
+  SUBROUTINE fin2_vector (v)
+    IMPLICIT NONE
+    TYPE(type_2) :: v(:)
+  END SUBROUTINE fin2_vector
+
+END MODULE final_type
+
+PROGRAM finalizer
+  IMPLICIT NONE
+  ! Nothing here
+END PROGRAM finalizer
+
+! TODO: Remove this once finalization is implemented.
+! { dg-excess-errors "not yet implemented" }
+
+! { dg-final { cleanup-modules "final_type" } }

gcc/testsuite/gfortran.dg/finalize_8.f03

+! { dg-do compile }
+
+! Parsing of finalizer procedure definitions.
+! Check that FINAL-declarations are only allowed on types defined in the
+! specification part of a module.
+
+MODULE final_type
+  IMPLICIT NONE
+
+CONTAINS
+
+  SUBROUTINE bar
+    IMPLICIT NONE
+
+    TYPE :: mytype
+      INTEGER, ALLOCATABLE :: fooarr(:)
+      REAL :: foobar
+    CONTAINS
+      FINAL :: myfinal ! { dg-error "in the specification part of a MODULE" }
+    END TYPE mytype
+
+  CONTAINS
+
+    SUBROUTINE myfinal (el)
+      TYPE(mytype) :: el
+    END SUBROUTINE myfinal
+
+  END SUBROUTINE bar
+
+END MODULE final_type
+
+PROGRAM finalizer
+  IMPLICIT NONE
+  ! Do nothing here
+END PROGRAM finalizer
+
+! { dg-final { cleanup-modules "final_type" } }