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

login
register
mail settings
Submitter Tobias Burnus
Date Oct. 23, 2010, 8:04 p.m.
Message ID <4CC33FBF.10506@net-b.de>
Download mbox | patch
Permalink /patch/69010/
State New
Headers show

Comments

Tobias Burnus - Oct. 23, 2010, 8:04 p.m.
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
Paul Richard Thomas - Oct. 23, 2010, 8:44 p.m.
Hah!  I missed this one completely....  I'll come back to you first
thing tomorrow because it saves me a lot of effort.

Thanks to you and Steve.

Paul

On Sat, Oct 23, 2010 at 10:04 PM, Tobias Burnus <burnus@net-b.de> 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
>

Patch

2010-10-23  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 (match_type_spec): Clean up.
	(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-10-23  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/allocate_derived_1.f90: Update dg-errors.
	* 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 33c7ba6..94d005f 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 efde1a6..32f546a 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2771,8 +2771,6 @@  match_type_spec (gfc_typespec *ts)
 	}
       return MATCH_YES;
     }
-  else if (m == MATCH_ERROR && gfc_match (" :: ") == MATCH_YES)
-    return MATCH_ERROR;
 
   gfc_current_locus = old_locus;
 
@@ -2807,7 +2805,10 @@  match_type_spec (gfc_typespec *ts)
   if (gfc_match ("character") == MATCH_YES)
     {
       ts->type = BT_CHARACTER;
-      goto char_selector;
+      m = gfc_match_char_spec (ts);
+      if (m == MATCH_NO)
+	m = MATCH_YES;		/* No kind specifier found.  */
+      return m;
     }
 
   if (gfc_match ("logical") == MATCH_YES)
@@ -2836,15 +2837,6 @@  kind_selector:
     m = MATCH_YES;		/* No kind specifier found.  */
 
   return m;
-
-char_selector:
-
-  m = gfc_match_char_spec (ts);
-
-  if (m == MATCH_NO)
-    m = MATCH_YES;		/* No kind specifier found.  */
-
-  return m;
 }
 
 
@@ -2858,12 +2850,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;
@@ -2882,6 +2874,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
 	{
@@ -2915,6 +2914,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)
@@ -3098,7 +3103,6 @@  alloc_opt_list:
 	  break;
     }
 
-
   if (gfc_match (" )%t") != MATCH_YES)
     goto syntax;
 
@@ -3109,6 +3113,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 f2905cd..5127151 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -3415,6 +3415,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/allocate_derived_1.f90 b/gcc/testsuite/gfortran.dg/allocate_derived_1.f90
index b9f6d55..55f8185 100644
--- a/gcc/testsuite/gfortran.dg/allocate_derived_1.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_derived_1.f90
@@ -32,7 +32,7 @@ 
  allocate(t1 :: x(2))
  allocate(t2 :: x(3))
  allocate(t3 :: x(4))
- allocate(tx :: x(5))  ! { dg-error "is not an accessible derived type" }
+ allocate(tx :: x(5))  ! { dg-error "not a nonprocedure pointer" }
  allocate(u0 :: x(6))  ! { dg-error "may not be ABSTRACT" }
  allocate(v1 :: x(7))  ! { dg-error "is type incompatible with typespec" }
 
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