Patchwork [Fortran] PR 45170 - Implement parsing/resolution of character deferred type parameter

login
register
mail settings
Submitter Tobias Burnus
Date Nov. 2, 2010, 9:09 a.m.
Message ID <4CCFD53B.6060905@net-b.de>
Download mbox | patch
Permalink /patch/69867/
State New
Headers show

Comments

Tobias Burnus - Nov. 2, 2010, 9:09 a.m.
*PING*

I updated the patch by removing the match_type_spec part and the 
gfortran.dg/allocate_derived_1.f90 change as those changes were applied 
as part of Steve's patch at 
http://gcc.gnu.org/ml/fortran/2010-10/msg00285.html

Otherwise, the patch is unchanged. Rediff attached. I have rebuild the 
patch and will regtest it, but I do not expect any failures.

OK for the trunk?

Tobias

On 10/23/2010 10:04 PM, Tobias Burnus wrote:
> As Paul plans to implement "character(len=:)" support, I thought I 
> should update Steve's patch and submit it for review. Steve's posted 
> his patch at http://gcc.gnu.org/ml/fortran/2010-08/msg00181.html
>
> The patch does the parsing and resolving of character deferred 
> (length) type parameter; after/during resolution, the compiler aborts 
> with a not-yet-implemented error.
>
> I have changed some parts around in the patch - and have discovered PR 
> fortran/46152 on the way. Note: The bogus error message changes a bit 
> with and without this patch applied. That should be the part in 
> match_type_spec.
>
> Build and regtested on x86-64-linux.
> OK for the trunk?
>
> Tobias
>
> PS: Note for the actual implementation: For pointers, the length 
> parameter is the one of the target; thus, the length can not be saved 
> in the pointer. For example:
>
> 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
Daniel Kraft - Nov. 2, 2010, 10:49 a.m.
Hi Tobias,

Tobias Burnus wrote:
>  *PING*
> 
> I updated the patch by removing the match_type_spec part and the 
> gfortran.dg/allocate_derived_1.f90 change as those changes were applied 
> as part of Steve's patch at 
> http://gcc.gnu.org/ml/fortran/2010-10/msg00285.html
> 
> Otherwise, the patch is unchanged. Rediff attached. I have rebuild the 
> patch and will regtest it, but I do not expect any failures.
> 
> OK for the trunk?

Yes.  Two comments:

@@ -701,6 +712,7 @@ match_char_length (gfc_expr **expr)
  {
    int length;
    match m;
+  bool deferred = false;

    m = gfc_match_char ('*');
    if (m != MATCH_YES)
@@ -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 ();

It seems that in match_char_length (unlike gfc_match_char_spec) you 
simply ignore the value of deferred...  I wonder whether that can be 
"correct" -- maybe we want a check (or even assert?) that deferred is 
false if it does not need to be handled?

+      else if (sym->ts.deferred)
+	gfc_fatal_error ("Deferred type parameter not yet supported");

Do we need both this check and the one in resolve.c?  It does not hurt, 
though...  Just curious.

Thanks for the patch (to Steve and  you)!
Daniel

Patch

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): 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.

diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 8c74e70..ff0977a 100644
--- a/gcc/fortran/array.c
+++ b/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;
+	    }
 	}
     }
 
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 009b010..701aca7 100644
--- a/gcc/fortran/decl.c
+++ b/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;
     }
 
@@ -701,6 +712,7 @@  match_char_length (gfc_expr **expr)
 {
   int length;
   match m;
+  bool deferred = false;
 
   m = gfc_match_char ('*');
   if (m != MATCH_YES)
@@ -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 ();
@@ -2277,11 +2289,13 @@  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;
@@ -2315,7 +2329,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 +2342,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 +2362,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 +2421,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.  */
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index e567c98..8dfbf73 100644
--- a/gcc/fortran/expr.c
+++ b/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 "
-		       "expression at %L", e->symtree->n.sym->name, &e->where);
+	    gfc_error ("Assumed or deferred character length variable '%s' "
+			" 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)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b96dd64..2d0d4eb 100644
--- a/gcc/fortran/gfortran.h
+++ b/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;
 }
@@ -910,7 +910,8 @@  typedef struct
   struct gfc_symbol *interface;	/* For PROCEDURE declarations.  */
   int is_c_interop;
   int is_iso_c;
-  bt f90_type; 
+  bt f90_type;
+  bool deferred;
 }
 gfc_typespec;
 
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 1b895f0..41818e9 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2845,12 +2845,12 @@  gfc_match_allocate (void)
   gfc_typespec ts;
   gfc_symbol *sym;
   match m;
-  locus old_locus;
-  bool saw_stat, saw_errmsg, saw_source, saw_mold, b1, b2, b3;
+  locus old_locus, deferred_locus;
+  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;
 
@@ -3106,6 +3118,14 @@  alloc_opt_list:
 		  &mold->where, &source->where);
       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;
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index b5e6275..397c872 100644
--- a/gcc/fortran/misc.c
+++ b/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;
 }
 
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 4280555..6e71e13 100644
--- a/gcc/fortran/resolve.c
+++ b/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);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 2c4ebbb..4b668c8 100644
--- a/gcc/fortran/trans-decl.c
+++ b/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)
diff --git a/gcc/testsuite/gfortran.dg/deferred_type_param_1.f90 b/gcc/testsuite/gfortran.dg/deferred_type_param_1.f90
new file mode 100644
index 0000000..59d67f0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/deferred_type_param_1.f90
@@ -0,0 +1,10 @@ 
+! { 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" }
+end
diff --git a/gcc/testsuite/gfortran.dg/deferred_type_param_2.f90 b/gcc/testsuite/gfortran.dg/deferred_type_param_2.f90
new file mode 100644
index 0000000..1e9931a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/deferred_type_param_2.f90
@@ -0,0 +1,56 @@ 
+! { 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
diff --git a/gcc/testsuite/gfortran.dg/initialization_1.f90 b/gcc/testsuite/gfortran.dg/initialization_1.f90
index 63035cc..3ca20ac 100644
--- a/gcc/testsuite/gfortran.dg/initialization_1.f90
+++ b/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" }
diff --git a/gcc/testsuite/gfortran.dg/initialization_9.f90 b/gcc/testsuite/gfortran.dg/initialization_9.f90
index 2341d40..d904047 100644
--- a/gcc/testsuite/gfortran.dg/initialization_9.f90
+++ b/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