2010-11-02 Steven G.

2010-11-02  Steven G. Kargl  < kargl@gcc.gnu.org>
            Tobias Burnus  <burnus@net-b.de>

        PR fortran/45170
        * array.c (gfc_match_array_constructor): Reject deferred type
        parameter (DTP) in type-spec.
        * decl.c (char_len_param_value, match_char_length,
        gfc_match_char_spec, build_sym, variable_decl,
        enumerator_decl): Support DTP.
        * expr.c (check_inquiry): Fix check due to support for DTP.
        * gfortran.h (gfc_typespec): Add Boolean 'deferred'.
        * misc.c (gfc_clear_ts): Set it to false.
        * match.c (gfc_match_allocate): Support DTP.
        * resolve.c (resolve_allocate_expr): Not-implemented error for
        * DTP.
        (resolve_fl_variable): Add DTP constraint check.
        * trans-decl.c (gfc_trans_deferred_vars): Add not-implemented
        error for DTP.

2010-11-02  Steven G. Kargl  < kargl@gcc.gnu.org>
            Tobias Burnus  <burnus@net-b.de>

        PR fortran/45170
        * gfortran.dg/deferred_type_param_1.f90: New.
        * gfortran.dg/deferred_type_param_2.f90: New.
        * gfortran.dg/initialization_1.f90: Update dg-errors.
        * gfortran.dg/initialization_9.f90: Update dg-errors.


Co-Authored-By: Tobias Burnus <burnus@net-b.de>

From-SVN: r166205

gcc/fortran/ChangeLog

@@ -1,3 +1,21 @@
+2010-11-02  Steven G. Kargl  < kargl@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45170
+	* array.c (gfc_match_array_constructor): Reject deferred type
+	parameter (DTP) in type-spec.
+	* decl.c (char_len_param_value, match_char_length,
+	gfc_match_char_spec, build_sym, variable_decl,
+	enumerator_decl): Support DTP.
+	* expr.c (check_inquiry): Fix check due to support for DTP.
+	* gfortran.h (gfc_typespec): Add Boolean 'deferred'.
+	* misc.c (gfc_clear_ts): Set it to false.
+	* match.c (gfc_match_allocate): Support DTP.
+	* resolve.c (resolve_allocate_expr): Not-implemented error for DTP.
+	(resolve_fl_variable): Add DTP constraint check.
+	* trans-decl.c (gfc_trans_deferred_vars): Add not-implemented
+	error for DTP.
+
 2010-11-01  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/46152

gcc/fortran/array.c

@@ -1035,6 +1035,13 @@ gfc_match_array_constructor (gfc_expr **result)
 	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
 			      "including type specification at %C") == FAILURE)
 	    goto cleanup;
+
+	  if (ts.deferred)
+	    {
+	      gfc_error ("Type-spec at %L cannot contain a deferred "
+			 "type parameter", &where);
+	      goto cleanup;
+	    }
 	}
     }
 

gcc/fortran/decl.c

@@ -647,16 +647,27 @@ match_intent_spec (void)
 
 
 /* Matches a character length specification, which is either a
-   specification expression or a '*'.  */
+   specification expression, '*', or ':'.  */
 
 static match
-char_len_param_value (gfc_expr **expr)
+char_len_param_value (gfc_expr **expr, bool *deferred)
 {
   match m;
 
+  *expr = NULL;
+  *deferred = false;
+
   if (gfc_match_char ('*') == MATCH_YES)
+    return MATCH_YES;
+
+  if (gfc_match_char (':') == MATCH_YES)
     {
-      *expr = NULL;
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: deferred type "
+			  "parameter at %C") == FAILURE)
+	return MATCH_ERROR;
+
+      *deferred = true;
+
       return MATCH_YES;
     }
 
@@ -697,11 +708,12 @@ syntax:
    char_len_param_value in parenthesis.  */
 
 static match
-match_char_length (gfc_expr **expr)
+match_char_length (gfc_expr **expr, bool *deferred)
 {
   int length;
   match m;
 
+  *deferred = false; 
   m = gfc_match_char ('*');
   if (m != MATCH_YES)
     return m;
@@ -722,7 +734,7 @@ match_char_length (gfc_expr **expr)
   if (gfc_match_char ('(') == MATCH_NO)
     goto syntax;
 
-  m = char_len_param_value (expr);
+  m = char_len_param_value (expr, deferred);
   if (m != MATCH_YES && gfc_matching_function)
     {
       gfc_undo_symbols ();
@@ -1086,7 +1098,7 @@ verify_c_interop_param (gfc_symbol *sym)
 /* Function called by variable_decl() that adds a name to the symbol table.  */
 
 static gfc_try
-build_sym (const char *name, gfc_charlen *cl,
+build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
 	   gfc_array_spec **as, locus *var_locus)
 {
   symbol_attribute attr;
@@ -1103,7 +1115,10 @@ build_sym (const char *name, gfc_charlen *cl,
     return FAILURE;
 
   if (sym->ts.type == BT_CHARACTER)
-    sym->ts.u.cl = cl;
+    {
+      sym->ts.u.cl = cl;
+      sym->ts.deferred = cl_deferred;
+    }
 
   /* Add dimension attribute if present.  */
   if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
@@ -1710,6 +1725,7 @@ variable_decl (int elem)
   gfc_array_spec *as;
   gfc_array_spec *cp_as; /* Extra copy for Cray Pointees.  */
   gfc_charlen *cl;
+  bool cl_deferred;
   locus var_locus;
   match m;
   gfc_try t;
@@ -1770,10 +1786,11 @@ variable_decl (int elem)
 
   char_len = NULL;
   cl = NULL;
+  cl_deferred = false;
 
   if (current_ts.type == BT_CHARACTER)
     {
-      switch (match_char_length (&char_len))
+      switch (match_char_length (&char_len, &cl_deferred))
 	{
 	case MATCH_YES:
 	  cl = gfc_new_charlen (gfc_current_ns, NULL);
@@ -1794,6 +1811,8 @@ variable_decl (int elem)
 	  else
 	    cl = current_ts.u.cl;
 
+	  cl_deferred = current_ts.deferred;
+
 	  break;
 
 	case MATCH_ERROR:
@@ -1869,7 +1888,7 @@ variable_decl (int elem)
      create a symbol for those yet.  If we fail to create the symbol,
      bail out.  */
   if (gfc_current_state () != COMP_DERIVED
-      && build_sym (name, cl, &as, &var_locus) == FAILURE)
+      && build_sym (name, cl, cl_deferred, &as, &var_locus) == FAILURE)
     {
       m = MATCH_ERROR;
       goto cleanup;
@@ -2277,16 +2296,18 @@ gfc_match_char_spec (gfc_typespec *ts)
   gfc_charlen *cl;
   gfc_expr *len;
   match m;
+  bool deferred;
 
   len = NULL;
   seen_length = 0;
   kind = 0;
   is_iso_c = 0;
+  deferred = false;
 
   /* Try the old-style specification first.  */
   old_char_selector = 0;
 
-  m = match_char_length (&len);
+  m = match_char_length (&len, &deferred);
   if (m != MATCH_NO)
     {
       if (m == MATCH_YES)
@@ -2315,7 +2336,7 @@ gfc_match_char_spec (gfc_typespec *ts)
       if (gfc_match (" , len =") == MATCH_NO)
 	goto rparen;
 
-      m = char_len_param_value (&len);
+      m = char_len_param_value (&len, &deferred);
       if (m == MATCH_NO)
 	goto syntax;
       if (m == MATCH_ERROR)
@@ -2328,7 +2349,7 @@ gfc_match_char_spec (gfc_typespec *ts)
   /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>".  */
   if (gfc_match (" len =") == MATCH_YES)
     {
-      m = char_len_param_value (&len);
+      m = char_len_param_value (&len, &deferred);
       if (m == MATCH_NO)
 	goto syntax;
       if (m == MATCH_ERROR)
@@ -2348,7 +2369,7 @@ gfc_match_char_spec (gfc_typespec *ts)
     }
 
   /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ).  */
-  m = char_len_param_value (&len);
+  m = char_len_param_value (&len, &deferred);
   if (m == MATCH_NO)
     goto syntax;
   if (m == MATCH_ERROR)
@@ -2407,6 +2428,7 @@ done:
 
   ts->u.cl = cl;
   ts->kind = kind == 0 ? gfc_default_character_kind : kind;
+  ts->deferred = deferred;
 
   /* We have to know if it was a c interoperable kind so we can
      do accurate type checking of bind(c) procs, etc.  */
@@ -7449,7 +7471,7 @@ enumerator_decl (void)
   /* OK, we've successfully matched the declaration.  Now put the
      symbol in the current namespace. If we fail to create the symbol,
      bail out.  */
-  if (build_sym (name, NULL, &as, &var_locus) == FAILURE)
+  if (build_sym (name, NULL, false, &as, &var_locus) == FAILURE)
     {
       m = MATCH_ERROR;
       goto cleanup;

gcc/fortran/expr.c

@@ -2292,10 +2292,13 @@ check_inquiry (gfc_expr *e, int not_restricted)
 	   with LEN, as required by the standard.  */
 	if (i == 5 && not_restricted
 	    && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
-	    && ap->expr->symtree->n.sym->ts.u.cl->length == NULL)
+	    && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL
+		|| ap->expr->symtree->n.sym->ts.deferred))
 	  {
-	    gfc_error ("Assumed character length variable '%s' in constant "
+	    gfc_error ("Assumed or deferred character length variable '%s' "
-		       "expression at %L", e->symtree->n.sym->name, &e->where);
+			" in constant expression at %L",
+			ap->expr->symtree->n.sym->name,
+			&ap->expr->where);
 	      return MATCH_ERROR;
 	  }
 	else if (not_restricted && check_init_expr (ap->expr) == FAILURE)

gcc/fortran/gfortran.h

@@ -885,7 +885,7 @@ typedef struct gfc_charlen
   struct gfc_charlen *next;
   bool length_from_typespec; /* Length from explicit array ctor typespec?  */
   tree backend_decl;
-  tree passed_length; /* Length argument explicitelly passed.  */
+  tree passed_length; /* Length argument explicitly passed.  */
 
   int resolved;
 }
@@ -911,6 +911,7 @@ typedef struct
   int is_c_interop;
   int is_iso_c;
   bt f90_type;
+  bool deferred;
 }
 gfc_typespec;
 

gcc/fortran/match.c

@@ -2845,12 +2845,12 @@ gfc_match_allocate (void)
   gfc_typespec ts;
   gfc_symbol *sym;
   match m;
-  locus old_locus;
+  locus old_locus, deferred_locus;
-  bool saw_stat, saw_errmsg, saw_source, saw_mold, b1, b2, b3;
+  bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
 
   head = tail = NULL;
   stat = errmsg = source = mold = tmp = NULL;
-  saw_stat = saw_errmsg = saw_source = saw_mold = false;
+  saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
 
   if (gfc_match_char ('(') != MATCH_YES)
     goto syntax;
@@ -2879,6 +2879,13 @@ gfc_match_allocate (void)
 	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
 			      "ALLOCATE at %L", &old_locus) == FAILURE)
 	    goto cleanup;
+
+	  if (ts.deferred)
+	    {
+	      gfc_error ("Type-spec at %L cannot contain a deferred "
+			 "type parameter", &old_locus);
+	      goto cleanup;
+	    }
 	}
       else
 	{
@@ -2912,6 +2919,12 @@ gfc_match_allocate (void)
 	  goto cleanup;
 	}
 
+      if (tail->expr->ts.deferred)
+	{
+	  saw_deferred = true;
+	  deferred_locus = tail->expr->where;
+	}
+
       /* The ALLOCATE statement had an optional typespec.  Check the
 	 constraints.  */
       if (ts.type != BT_UNKNOWN)
@@ -3095,7 +3108,6 @@ alloc_opt_list:
 	  break;
     }
 
-
   if (gfc_match (" )%t") != MATCH_YES)
     goto syntax;
 
@@ -3107,6 +3119,14 @@ alloc_opt_list:
       goto cleanup;
     }
 
+  /* Check F03:C623,  */
+  if (saw_deferred && ts.type == BT_UNKNOWN && !source)
+    {
+      gfc_error ("Allocate-object at %L with a deferred type parameter "
+		 "requires either a type-spec or SOURCE tag", &deferred_locus);
+      goto cleanup;
+    }
+  
   new_st.op = EXEC_ALLOCATE;
   new_st.expr1 = stat;
   new_st.expr2 = errmsg;

gcc/fortran/misc.c

@@ -77,6 +77,7 @@ gfc_clear_ts (gfc_typespec *ts)
   ts->f90_type = BT_UNKNOWN;
   /* flag that says whether it's from iso_c_binding or not */
   ts->is_iso_c = 0;
+  ts->deferred = false;
 }
 
 

gcc/fortran/resolve.c

@@ -6856,6 +6856,12 @@ check_symbols:
     }
 
 success:
+  if (e->ts.deferred)
+    {
+      gfc_error ("Support for entity at %L with deferred type parameter "
+		 "not yet implemented", &e->where);
+      return FAILURE;
+    }
   return SUCCESS;
 
 failure:
@@ -9371,6 +9377,7 @@ resolve_index_expr (gfc_expr *e)
   return SUCCESS;
 }
 
+
 /* Resolve a charlen structure.  */
 
 static gfc_try
@@ -9684,6 +9691,7 @@ apply_default_init_local (gfc_symbol *sym)
   build_init_assign (sym, init);
 }
 
+
 /* Resolution of common features of flavors variable and procedure.  */
 
 static gfc_try
@@ -9847,12 +9855,22 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
       return FAILURE;
     }
 
+  /* Constraints on deferred type parameter.  */
+  if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
+    {
+      gfc_error ("Entity '%s' at %L has a deferred type parameter and "
+		 "requires either the pointer or allocatable attribute",
+		     sym->name, &sym->declared_at);
+      return FAILURE;
+    }
+
   if (sym->ts.type == BT_CHARACTER)
     {
       /* Make sure that character string variables with assumed length are
 	 dummy arguments.  */
       e = sym->ts.u.cl->length;
-      if (e == NULL && !sym->attr.dummy && !sym->attr.result)
+      if (e == NULL && !sym->attr.dummy && !sym->attr.result
+	  && !sym->ts.deferred)
 	{
 	  gfc_error ("Entity with assumed character length at %L must be a "
 		     "dummy argument or a PARAMETER", &sym->declared_at);

gcc/fortran/trans-decl.c

@@ -3416,6 +3416,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	      gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
 	    }
 	}
+      else if (sym->ts.deferred)
+	gfc_fatal_error ("Deferred type parameter not yet supported");
       else if (sym_has_alloc_comp)
 	gfc_trans_deferred_array (sym, block);
       else if (sym->ts.type == BT_CHARACTER)

gcc/testsuite/ChangeLog

@@ -1,3 +1,12 @@
+2010-11-02  Steven G. Kargl  < kargl@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/45170
+	* gfortran.dg/deferred_type_param_1.f90: New.
+	* gfortran.dg/deferred_type_param_2.f90: New.
+	* gfortran.dg/initialization_1.f90: Update dg-errors.
+	* gfortran.dg/initialization_9.f90: Update dg-errors.
+
 2010-11-02  Richard Guenther  <rguenther@suse.de>
 
 	PR tree-optimization/46149

gcc/testsuite/gfortran.dg/allocate_with_typespec_3.f90

@@ -23,7 +23,7 @@ subroutine implicit_none_test1
    allocate(real(8) :: x4(1))      ! { dg-error "differs from the kind type parameter" }
    allocate(real(4) :: x8(1))      ! { dg-error "differs from the kind type parameter" }
    allocate(double :: d1(1))       ! { dg-error "Error in type-spec at" }
-   allocate(character(:) :: c1(1)) ! { dg-error "Syntax error in CHARACTER declaration" }
+   allocate(character(:) :: c1(1)) ! { dg-error "cannot contain a deferred type parameter" }
    allocate(real :: b(1))          ! { dg-error "is type incompatible" }
 
 end subroutine implicit_none_test1
@@ -50,7 +50,7 @@ subroutine implicit_none_test2
    allocate(real(8) :: x4)      ! { dg-error "differs from the kind type parameter" }
    allocate(real(4) :: x8)      ! { dg-error "differs from the kind type parameter" }
    allocate(double :: d1)       ! { dg-error "Error in type-spec at" }
-   allocate(character(:) :: c1) ! { dg-error "Syntax error in CHARACTER declaration" }
+   allocate(character(:) :: c1) ! { dg-error "cannot contain a deferred type parameter" }
    allocate(real :: b)          ! { dg-error "is type incompatible" }
 
 end subroutine implicit_none_test2
@@ -76,7 +76,7 @@ subroutine implicit_test3
    allocate(real(8) :: x4(1))      ! { dg-error "differs from the kind type parameter" }
    allocate(real(4) :: x8(1))      ! { dg-error "differs from the kind type parameter" }
    allocate(double :: d1(1))       ! { dg-error "Error in type-spec" }
-   allocate(character(:) :: c1(1)) ! { dg-error "Syntax error in CHARACTER declaration" }
+   allocate(character(:) :: c1(1)) ! { dg-error "cannot contain a deferred type parameter" }
    allocate(real :: b(1))          ! { dg-error "is type incompatible" }
 
 end subroutine implicit_test3
@@ -101,7 +101,7 @@ subroutine implicit_test4
    allocate(real(8) :: x4)      ! { dg-error "differs from the kind type parameter" }
    allocate(real(4) :: x8)      ! { dg-error "differs from the kind type parameter" }
    allocate(double :: d1)       ! { dg-error "Error in type-spec at" }
-   allocate(character(:) :: c1) ! { dg-error "Syntax error in CHARACTER declaration" }
+   allocate(character(:) :: c1) ! { dg-error "cannot contain a deferred type parameter" }
    allocate(real :: b)          ! { dg-error "is type incompatible" }
 
 end subroutine implicit_test4

gcc/testsuite/gfortran.dg/deferred_type_param_1.f90

@@ -0,0 +1,12 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+!
+! PR fortran/45170
+!
+! Character deferred type parameter
+!
+implicit none
+character(len=:), allocatable :: str(:) ! { dg-error "Fortran 2003: deferred type parameter" }
+
+character(len=4) :: str2*(:) ! { dg-error "Fortran 2003: deferred type parameter" }
+end

gcc/testsuite/gfortran.dg/deferred_type_param_2.f90

@@ -0,0 +1,62 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+!
+! PR fortran/45170
+!
+! Character deferred type parameter
+!
+
+subroutine one(x, y) ! { dg-error "Entity .y. at .1. has a deferred type parameter" }
+  implicit none
+  character(len=:), pointer :: x
+  character(len=:) :: y
+  character(len=:), allocatable, target :: str2
+  character(len=:), target :: str ! { dg-error "deferred type parameter" }
+end subroutine one
+
+subroutine two()
+  implicit none
+  character(len=:), allocatable, target :: str1(:)
+  character(len=5), save, target :: str2
+  character(len=:), pointer :: pstr => str2
+  character(len=:), pointer :: pstr2(:)
+end subroutine two
+
+subroutine three()
+!  implicit none  ! Disabled because of PR 46152
+  character(len=:), allocatable, target :: str1(:)
+  character(len=5), save, target :: str2
+  character(len=:), pointer :: pstr
+  character(len=:), pointer :: pstr2(:)
+
+  pstr => str2
+  pstr2 => str1
+  str1 = ["abc"]
+  pstr2 => str1
+
+  allocate (character(len=77) :: str1(1)) ! OK ! { dg-error "not yet implemented" }
+  allocate (pstr, source=str2)  ! OK  ! { dg-error "not yet implemented" }
+  allocate (pstr, mold=str2) ! { dg-error "requires either a type-spec or SOURCE tag" }
+  allocate (pstr) ! { dg-error "requires either a type-spec or SOURCE tag" }
+  allocate (character(len=:) :: str1(1)) ! { dg-error "cannot contain a deferred type parameter" }
+
+  str1 = [ character(len=2) :: "abc" ]
+  str1 = [ character(len=:) :: "abc" ] ! { dg-error "cannot contain a deferred type parameter" }
+end subroutine three
+
+subroutine four()
+  implicit none
+  character(len=:), allocatable, target :: str
+  character(len=:), pointer :: pstr
+  pstr => str
+  str = "abc"
+  if(len(pstr) /= len(str) .or. len(str)/= 3) call abort()
+  str = "abcd"
+  if(len(pstr) /= len(str) .or. len(str)/= 4) call abort()
+end subroutine four
+
+subroutine five()
+character(len=4) :: str*(:)
+allocatable :: str
+end subroutine five
+

gcc/testsuite/gfortran.dg/initialization_1.f90

@@ -24,7 +24,7 @@ contains
     real :: z(2, 2)
 
 ! However, this gives a warning because it is an initialization expression.
-    integer :: l1 = len (ch1)     ! { dg-warning "Assumed character length variable" }
+    integer :: l1 = len (ch1)     ! { dg-warning "Assumed or deferred character length variable" }
 
 ! These are warnings because they are gfortran extensions.
     integer :: m3 = size (x, 1)   ! { dg-error "Assumed size array" }

gcc/testsuite/gfortran.dg/initialization_9.f90

@@ -5,7 +5,7 @@
 
    integer function xstrcmp(s1)
      character*(*), intent(in) :: s1
-     integer :: n1 = len(s1)            ! { dg-error "Assumed character length variable" }
+     integer :: n1 = len(s1)  ! { dg-error "Assumed or deferred character length variable" }
      n1 = 1
      return
    end function xstrcmp