diff mbox series

Fortran: Various CLASS + assumed-rank fixed [PR102541]

Message ID b62166a0-3b2b-8f79-0d55-dae6f912b167@codesourcery.com
State New
Headers show
Series Fortran: Various CLASS + assumed-rank fixed [PR102541] | expand

Commit Message

Tobias Burnus Oct. 1, 2021, 12:43 a.m. UTC 
Hi all,

this patch fixes a bunch of issues with CLASS.

  * * *

Side remark: I disliked the way CLASS is represented when it was introduced;
when writing the testcase for this PR and kept fixing the testcase fallout,
I started to hate it!
I am sure that there are more issues – but I tried hard not too look closer
at surrounding code to avoid hitting more issues.
(If you look for a project, I think if you put attributes on separate lines,
like a separate "POINTER :: var" line, you have a high chance to hit the
error.)

  * * *

What I found rather puzzling is that the 'optional' argument could be either
on sym->attr.optional or on CLASS_DATA (sym)->attr.optional. I think one
occurs for 'foo2' and the other for 'foo4' - not that I understand why it
differs.

I think it is otherwise straight forward. Regarding the original issue:

In order to detect an assumed-size argument to an assumed-rank array,
the last dimension has 'ubound = -1' to indicate an assume-size array;
for those size(x, dim=rank(x)-1) == -1 and size(x) < 0

However, when the dummy argument (and hence: actual argument) is either
a pointer or an allocatable, the bound is passed as is (in particular,
"-1" is a valid ubound and size(x) >= 0). – However, if the actual
argument is unallocated/not associated, rank(var) still is supposed to
work - hence, it has to be set.

The last two items did work before - but not for CLASS -> CLASS. Additionally,
the ubound = -1 had an issue for CLASS -> TYPE as the code assumed that
expr->ref is the whole array ("var(full-array-ref)") but for CLASS the
expr->ref is a component and only expr->ref->next is the array ref.
("var%_data(full-array-ref)").

OK for mainline?

Tobias

-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955

Comments

Tobias Burnus Oct. 6, 2021, 10:24 a.m. UTC | #1 
Early ping for this patch.

(I still plan to review Harald's pending patch soon, unless someone
beats me:
https://gcc.gnu.org/pipermail/gcc-patches/2021-October/580810.html )

On 01.10.21 02:43, Tobias Burnus wrote:
> Hi all,
>
> this patch fixes a bunch of issues with CLASS.
>
>  * * *
>
> Side remark: I disliked the way CLASS is represented when it was
> introduced;
> when writing the testcase for this PR and kept fixing the testcase
> fallout,
> I started to hate it!
> I am sure that there are more issues – but I tried hard not too look
> closer
> at surrounding code to avoid hitting more issues.
> (If you look for a project, I think if you put attributes on separate
> lines,
> like a separate "POINTER :: var" line, you have a high chance to hit the
> error.)
>
>  * * *
>
> What I found rather puzzling is that the 'optional' argument could be
> either
> on sym->attr.optional or on CLASS_DATA (sym)->attr.optional. I think one
> occurs for 'foo2' and the other for 'foo4' - not that I understand why it
> differs.
>
> I think it is otherwise straight forward. Regarding the original issue:
>
> In order to detect an assumed-size argument to an assumed-rank array,
> the last dimension has 'ubound = -1' to indicate an assume-size array;
> for those size(x, dim=rank(x)-1) == -1 and size(x) < 0
>
> However, when the dummy argument (and hence: actual argument) is either
> a pointer or an allocatable, the bound is passed as is (in particular,
> "-1" is a valid ubound and size(x) >= 0). – However, if the actual
> argument is unallocated/not associated, rank(var) still is supposed to
> work - hence, it has to be set.
>
> The last two items did work before - but not for CLASS -> CLASS.
> Additionally,
> the ubound = -1 had an issue for CLASS -> TYPE as the code assumed that
> expr->ref is the whole array ("var(full-array-ref)") but for CLASS the
> expr->ref is a component and only expr->ref->next is the array ref.
> ("var%_data(full-array-ref)").
>
> OK for mainline?
>
> Tobias
>
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
Harald Anlauf Oct. 10, 2021, 7:27 p.m. UTC | #2 
Hi Tobias,

just some random remarks from initially browsing your patch.

- leftover from debugging?

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 1c24556c299..8a82e55d1f9 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1,3 +1,4 @@
+#pragma GCC optimize(0)

- code that could be shortened/made slightly more readable:

@@ -2723,7 +2728,13 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
         else
           {
             codimension = comp->attr.codimension;
-           pointer = comp->attr.pointer;
+           if (expr->ts.type == BT_CLASS
+               && comp->name[0] == '_' && comp->name[1] == 'd'
+               && comp->name[2] == 'a' && comp->name[3] == 't'
+               && comp->name[4] == 'a' && comp->name[5] == '\0')

Is there a reason to not use strcmp (comp->name, "_data") == 0?

Cheers,
Harald

Am 01.10.21 um 02:43 schrieb Tobias Burnus:
> Hi all,
>
> this patch fixes a bunch of issues with CLASS.
>
>   * * *
>
> Side remark: I disliked the way CLASS is represented when it was
> introduced;
> when writing the testcase for this PR and kept fixing the testcase fallout,
> I started to hate it!
> I am sure that there are more issues – but I tried hard not too look closer
> at surrounding code to avoid hitting more issues.
> (If you look for a project, I think if you put attributes on separate
> lines,
> like a separate "POINTER :: var" line, you have a high chance to hit the
> error.)
>
>   * * *
>
> What I found rather puzzling is that the 'optional' argument could be
> either
> on sym->attr.optional or on CLASS_DATA (sym)->attr.optional. I think one
> occurs for 'foo2' and the other for 'foo4' - not that I understand why it
> differs.
>
> I think it is otherwise straight forward. Regarding the original issue:
>
> In order to detect an assumed-size argument to an assumed-rank array,
> the last dimension has 'ubound = -1' to indicate an assume-size array;
> for those size(x, dim=rank(x)-1) == -1 and size(x) < 0
>
> However, when the dummy argument (and hence: actual argument) is either
> a pointer or an allocatable, the bound is passed as is (in particular,
> "-1" is a valid ubound and size(x) >= 0). – However, if the actual
> argument is unallocated/not associated, rank(var) still is supposed to
> work - hence, it has to be set.
>
> The last two items did work before - but not for CLASS -> CLASS.
> Additionally,
> the ubound = -1 had an issue for CLASS -> TYPE as the code assumed that
> expr->ref is the whole array ("var(full-array-ref)") but for CLASS the
> expr->ref is a component and only expr->ref->next is the array ref.
> ("var%_data(full-array-ref)").
>
> OK for mainline?
>
> Tobias
>
> -----------------
> Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201,
> 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer:
> Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München;
> Registergericht München, HRB 106955
Tobias Burnus Oct. 11, 2021, 11:32 a.m. UTC | #3 
Hi Harald,

On 10.10.21 21:27, Harald Anlauf via Fortran wrote:
> just some random remarks from initially browsing your patch.
Thanks for browsing the patch :-)
> - leftover from debugging?
Yes.
> - code that could be shortened/made slightly more readable:
> ...
> Is there a reason to not use strcmp (comp->name, "_data") == 0?

Just (pre-mature) optimization. I think the latter is clearer; I will
change it.

Tobias


-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
Tobias Burnus Oct. 11, 2021, 8:13 p.m. UTC | #4 
PING**2

On 06.10.21 12:24, Tobias Burnus wrote:
> Early ping for this patch.
I do note that Harald browsed the patch (thanks!) and had two remarks,
cf. https://gcc.gnu.org/pipermail/gcc-patches/2021-October/581256.html
(I intent to fix the two nits – as mentioned in the reply to Harald's
email.)
> (I still plan to review Harald's pending patch soon, unless someone
> beats me:
> https://gcc.gnu.org/pipermail/gcc-patches/2021-October/580810.html )

Jerry was faster – thanks for that review!

Tobias

> On 01.10.21 02:43, Tobias Burnus wrote:
>> Hi all,
>>
>> this patch fixes a bunch of issues with CLASS.
>>
>>  * * *
>>
>> Side remark: I disliked the way CLASS is represented when it was
>> introduced;
>> when writing the testcase for this PR and kept fixing the testcase
>> fallout,
>> I started to hate it!
>> I am sure that there are more issues – but I tried hard not too look
>> closer
>> at surrounding code to avoid hitting more issues.
>> (If you look for a project, I think if you put attributes on separate
>> lines,
>> like a separate "POINTER :: var" line, you have a high chance to hit the
>> error.)
>>
>>  * * *
>>
>> What I found rather puzzling is that the 'optional' argument could be
>> either
>> on sym->attr.optional or on CLASS_DATA (sym)->attr.optional. I think one
>> occurs for 'foo2' and the other for 'foo4' - not that I understand
>> why it
>> differs.
>>
>> I think it is otherwise straight forward. Regarding the original issue:
>>
>> In order to detect an assumed-size argument to an assumed-rank array,
>> the last dimension has 'ubound = -1' to indicate an assume-size array;
>> for those size(x, dim=rank(x)-1) == -1 and size(x) < 0
>>
>> However, when the dummy argument (and hence: actual argument) is either
>> a pointer or an allocatable, the bound is passed as is (in particular,
>> "-1" is a valid ubound and size(x) >= 0). – However, if the actual
>> argument is unallocated/not associated, rank(var) still is supposed to
>> work - hence, it has to be set.
>>
>> The last two items did work before - but not for CLASS -> CLASS.
>> Additionally,
>> the ubound = -1 had an issue for CLASS -> TYPE as the code assumed that
>> expr->ref is the whole array ("var(full-array-ref)") but for CLASS the
>> expr->ref is a component and only expr->ref->next is the array ref.
>> ("var%_data(full-array-ref)").
>>
>> OK for mainline?
>>
>> Tobias
>>
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
Harald Anlauf Oct. 11, 2021, 8:20 p.m. UTC | #5 
Hi Tobias,

Am 01.10.21 um 02:43 schrieb Tobias Burnus:
> Hi all,
>
> this patch fixes a bunch of issues with CLASS.
>
>   * * *

besides my previous minor remarks I do not have further comments.
I played around a little but did not find any (new) obstacles.

> OK for mainline?

OK from my side.

Thanks for the patch!

Harald

> Tobias
>
> -----------------
> Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201,
> 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer:
> Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München;
> Registergericht München, HRB 106955
diff mbox series

Patch

Fortran: Various CLASS + assumed-rank fixed [PR102541]

Starting point was PR102541, were a previous patch caused an invalid
e->ref access for class. When testing, it turned out that for
CLASS to CLASS the code was never executed - additionally, issues
appeared for optional and a bogus error for -fcheck=all. In particular:

There were a bunch of issues related to optional CLASS, can have the
'attr.dummy' set in CLASS_DATA (sym) - but sometimes also in 'sym'!?!
Additionally, gfc_variable_attr could return pointer = 1 for nonpointers
when the expr is no longer "var" but "var%_data".

	PR fortran/102541

gcc/fortran/ChangeLog:

	* check.c (gfc_check_present): Handle optional CLASS.
	* interface.c (gfc_compare_actual_formal): Likewise.
	* trans-array.c (gfc_trans_g77_array): Likewise.
	* trans-decl.c (gfc_build_dummy_array_decl): Likewise.
	* trans-types.c (gfc_sym_type): Likewise.
	* primary.c (gfc_variable_attr): Fixes for dummy and
	pointer when 'class%_data' is passed.
	* trans-expr.c (set_dtype_for_unallocated, gfc_conv_procedure_call):
	For assumed-rank dummy, fix setting rank for dealloc/notassoc actual
	and setting ubound to -1 for assumed-size actuals.

gcc/testsuite/ChangeLog:

	* gfortran.dg/assumed_rank_24.f90: New test.

 gcc/fortran/check.c                           |   4 +-
 gcc/fortran/interface.c                       |   9 +-
 gcc/fortran/primary.c                         |  20 +++-
 gcc/fortran/trans-array.c                     |   4 +-
 gcc/fortran/trans-decl.c                      |   3 +-
 gcc/fortran/trans-expr.c                      |  81 ++++++++-------
 gcc/fortran/trans-types.c                     |   3 +-
 gcc/testsuite/gfortran.dg/assumed_rank_24.f90 | 137 ++++++++++++++++++++++++++
 8 files changed, 213 insertions(+), 48 deletions(-)

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index f31ad68053b..677209ee95e 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -4530,7 +4530,9 @@  gfc_check_present (gfc_expr *a)
       return false;
     }
 
-  if (!sym->attr.optional)
+  /* For CLASS, the optional attribute might be set at either location. */
+  if ((sym->ts.type != BT_CLASS || !CLASS_DATA (sym)->attr.optional)
+      && !sym->attr.optional)
     {
       gfc_error ("%qs argument of %qs intrinsic at %L must be of "
 		 "an OPTIONAL dummy variable",
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index a2fea0e97b8..34a0fddffe2 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -3546,8 +3546,13 @@  gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 		       "at %L", where);
 	  return false;
 	}
-      if (!f->sym->attr.optional
-	  || (in_statement_function && f->sym->attr.optional))
+      /* For CLASS, the optional attribute might be set at either location. */
+      if (((f->sym->ts.type != BT_CLASS || !CLASS_DATA (f->sym)->attr.optional)
+	   && !f->sym->attr.optional)
+	  || (in_statement_function
+	      && (f->sym->attr.optional
+		  || (f->sym->ts.type == BT_CLASS
+		      && CLASS_DATA (f->sym)->attr.optional))))
 	{
 	  if (where)
 	    gfc_error ("Missing actual argument for argument %qs at %L",
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 56a78d6f89f..8d29b252fa4 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2627,7 +2627,7 @@  check_substring:
 symbol_attribute
 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
 {
-  int dimension, codimension, pointer, allocatable, target;
+  int dimension, codimension, pointer, allocatable, target, optional;
   symbol_attribute attr;
   gfc_ref *ref;
   gfc_symbol *sym;
@@ -2640,12 +2640,14 @@  gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
   sym = expr->symtree->n.sym;
   attr = sym->attr;
 
+  optional = attr.optional;
   if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived)
     {
       dimension = CLASS_DATA (sym)->attr.dimension;
       codimension = CLASS_DATA (sym)->attr.codimension;
       pointer = CLASS_DATA (sym)->attr.class_pointer;
       allocatable = CLASS_DATA (sym)->attr.allocatable;
+      optional |= CLASS_DATA (sym)->attr.optional;
     }
   else
     {
@@ -2667,6 +2669,7 @@  gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
     if (ref->type == REF_INQUIRY)
       {
 	has_inquiry_part = true;
+	optional = false;
 	break;
       }
 
@@ -2684,12 +2687,13 @@  gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
 	  case AR_SECTION:
 	    allocatable = pointer = 0;
 	    dimension = 1;
+	    optional = false;
 	    break;
 
 	  case AR_ELEMENT:
 	    /* Handle coarrays.  */
 	    if (ref->u.ar.dimen > 0)
-	      allocatable = pointer = 0;
+	      allocatable = pointer = optional = false;
 	    break;
 
 	  case AR_UNKNOWN:
@@ -2702,6 +2706,7 @@  gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
 	break;
 
       case REF_COMPONENT:
+	optional = false;
 	comp = ref->u.c.component;
 	attr = comp->attr;
 	if (ts != NULL && !has_inquiry_part)
@@ -2723,7 +2728,13 @@  gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
 	else
 	  {
 	    codimension = comp->attr.codimension;
-	    pointer = comp->attr.pointer;
+	    if (expr->ts.type == BT_CLASS
+		&& comp->name[0] == '_' && comp->name[1] == 'd'
+		&& comp->name[2] == 'a' && comp->name[3] == 't'
+		&& comp->name[4] == 'a' && comp->name[5] == '\0')
+	      pointer = comp->attr.class_pointer;
+	    else
+	      pointer = comp->attr.pointer;
 	    allocatable = comp->attr.allocatable;
 	  }
 	if (pointer || attr.proc_pointer)
@@ -2733,7 +2744,7 @@  gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
 
       case REF_INQUIRY:
       case REF_SUBSTRING:
-	allocatable = pointer = 0;
+	allocatable = pointer = optional = false;
 	break;
       }
 
@@ -2743,6 +2754,7 @@  gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
   attr.allocatable = allocatable;
   attr.target = target;
   attr.save = sym->attr.save;
+  attr.optional = optional;
 
   return attr;
 }
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index b8061f37772..c403ff28488 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -6550,7 +6550,9 @@  gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
 
   /* Add the initialization code to the start of the function.  */
 
-  if (sym->attr.optional || sym->attr.not_always_present)
+  if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
+      || sym->attr.optional
+      || sym->attr.not_always_present)
     {
       tree nullify;
       if (TREE_CODE (parm) != PARM_DECL)
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index c758d26febf..87455f8ce25 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1303,7 +1303,8 @@  gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
   DECL_EXTERNAL (decl) = 0;
 
   /* Avoid uninitialized warnings for optional dummy arguments.  */
-  if (sym->attr.optional)
+  if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
+      || sym->attr.optional)
     suppress_warning (decl);
 
   /* We should never get deferred shape arrays here.  We used to because of
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 1c24556c299..8a82e55d1f9 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1,3 +1,4 @@ 
+#pragma GCC optimize(0)
 /* Expression translation
    Copyright (C) 2002-2021 Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
@@ -5454,7 +5455,8 @@  set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
 
   if (POINTER_TYPE_P (TREE_TYPE (desc)))
     desc = build_fold_indirect_ref_loc (input_location, desc);
-
+  if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
+    desc = gfc_class_data_get (desc);
   if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
     return;
 
@@ -6533,43 +6535,6 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
 					  sym->name, NULL);
 
-	      /* Special case for assumed-rank arrays. */
-	      if (!sym->attr.is_bind_c && e && fsym && fsym->as
-		  && fsym->as->type == AS_ASSUMED_RANK
-		  && e->rank != -1)
-		{
-		  if ((gfc_expr_attr (e).pointer
-		      || gfc_expr_attr (e).allocatable)
-		      && ((fsym->ts.type == BT_CLASS
-			   && (CLASS_DATA (fsym)->attr.class_pointer
-			       || CLASS_DATA (fsym)->attr.allocatable))
-			  || (fsym->ts.type != BT_CLASS
-			      && (fsym->attr.pointer || fsym->attr.allocatable))))
-		    {
-		      /* Unallocated allocatable arrays and unassociated pointer
-			 arrays need their dtype setting if they are argument
-			 associated with assumed rank dummies. However, if the
-			 dummy is nonallocate/nonpointer, the user may not
-			 pass those. Hence, it can be skipped.  */
-		      set_dtype_for_unallocated (&parmse, e);
-		    }
-		  else if (e->expr_type == EXPR_VARIABLE
-			   && e->ref
-			   && e->ref->u.ar.type == AR_FULL
-			   && e->symtree->n.sym->attr.dummy
-			   && e->symtree->n.sym->as
-			   && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
-		    {
-		      tree minus_one;
-		      tmp = build_fold_indirect_ref_loc (input_location,
-							 parmse.expr);
-		      minus_one = build_int_cst (gfc_array_index_type, -1);
-		      gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
-						      gfc_rank_cst[e->rank - 1],
-						      minus_one);
- 		    }
-		}
-
 	      /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
 		 allocated on entry, it must be deallocated.  */
 	      if (fsym && fsym->attr.allocatable
@@ -6621,6 +6586,46 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		}
 	    }
 	}
+      /* Special case for an assumed-rank dummy argument. */
+      if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
+	  && (fsym->ts.type == BT_CLASS
+	      ? (CLASS_DATA (fsym)->as
+		 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
+	      : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
+	{
+	  if (fsym->ts.type == BT_CLASS
+	      ? (CLASS_DATA (fsym)->attr.class_pointer
+		 || CLASS_DATA (fsym)->attr.allocatable)
+	      : (fsym->attr.pointer || fsym->attr.allocatable))
+	    {
+	      /* Unallocated allocatable arrays and unassociated pointer
+		 arrays need their dtype setting if they are argument
+		 associated with assumed rank dummies to set the rank.  */
+	      set_dtype_for_unallocated (&parmse, e);
+	    }
+	  else if (e->expr_type == EXPR_VARIABLE
+		   && e->symtree->n.sym->attr.dummy
+		   && (e->ts.type == BT_CLASS
+		       ? (e->ref && e->ref->next
+			  && e->ref->next->type == REF_ARRAY
+			  && e->ref->next->u.ar.type == AR_FULL
+			  && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
+		       : (e->ref && e->ref->type == REF_ARRAY
+			  && e->ref->u.ar.type == AR_FULL
+			  && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
+	    {
+	      /* Assumed-size actual to assumed-rank dummy requires
+		 dim[rank-1].ubound = -1. */
+	      tree minus_one;
+	      tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
+	      if (fsym->ts.type == BT_CLASS)
+		tmp = gfc_class_data_get (tmp);
+	      minus_one = build_int_cst (gfc_array_index_type, -1);
+	      gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
+					      gfc_rank_cst[e->rank - 1],
+					      minus_one);
+	    }
+	}
 
       /* The case with fsym->attr.optional is that of a user subroutine
 	 with an interface indicating an optional argument.  When we call
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 1c78a906397..220976babb8 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -2342,7 +2342,8 @@  gfc_sym_type (gfc_symbol * sym)
     {
       /* We must use pointer types for potentially absent variables.  The
 	 optimizers assume a reference type argument is never NULL.  */
-      if (sym->attr.optional
+      if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
+	  || sym->attr.optional
 	  || (sym->ns->proc_name && sym->ns->proc_name->attr.entry_master))
 	type = build_pointer_type (type);
       else
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_24.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_24.f90
new file mode 100644
index 00000000000..d91b5ecdc46
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_24.f90
@@ -0,0 +1,137 @@ 
+! { dg-do run }
+! { dg-additional-options "-fcheck=all" }
+module m
+  implicit none (external, type)
+contains
+  subroutine cl(x)
+    class(*) :: x(..)
+    if (rank(x) /= 1) stop 1
+    if (ubound(x, dim=1) /= -1) stop 2
+    select rank (x)
+      rank (1)
+      select type (x)
+        type is (integer)
+          ! ok
+        class default
+          stop 3
+      end select
+    end select
+  end subroutine
+  subroutine tp(x)
+    type(*) :: x(..)
+    if (rank(x) /= 1) stop 4
+    if (ubound(x, dim=1) /= -1) stop 5
+  end subroutine
+
+  subroutine foo (ccc, ddd, sss, ttt)
+    integer  :: sss(*), ttt(*)
+    class(*) :: ccc(*), ddd(*)
+    call cl(sss)
+    call tp(ttt)
+    call cl(ccc)
+    call tp(ddd)
+  end
+
+  subroutine foo2 (ccc, ddd, sss, ttt, ispresent)
+    integer  :: sss(*), ttt(*)
+    class(*) :: ccc(*), ddd(*)
+    optional :: ccc, ddd, sss, ttt
+    logical, value :: ispresent
+    if (present(ccc) .neqv. ispresent) stop 6
+    if (present(ccc)) then
+      call cl(sss)
+      call tp(ttt)
+      call cl(ccc)
+      call tp(ddd)
+    end if
+  end
+end
+
+module m2
+  implicit none (external, type)
+contains
+  subroutine cl2(x)
+    class(*), allocatable :: x(..)
+    if (rank(x) /= 1) stop 7
+    if (.not. allocated (x)) &
+      return
+    if (lbound(x, dim=1) /= -2) stop 8
+    if (ubound(x, dim=1) /= -1) stop 9
+    if (size  (x, dim=1) /= 2) stop 10
+    select rank (x)
+      rank (1)
+      select type (x)
+        type is (integer)
+          ! ok
+        class default
+          stop 11
+      end select
+    end select
+  end subroutine
+
+  subroutine tp2(x)
+    class(*), pointer :: x(..)
+    if (rank(x) /= 1) stop 12
+    if (.not. associated (x)) &
+      return
+    if (lbound(x, dim=1) /= -2) stop 13
+    if (ubound(x, dim=1) /= -1) stop 14
+    if (size  (x, dim=1) /= 2) stop 15
+    select rank (x)
+      rank (1)
+      select type (x)
+        type is (integer)
+          ! ok
+        class default
+          stop 16
+      end select
+    end select
+  end subroutine
+
+  subroutine foo3 (ccc, ddd, sss, ttt)
+    class(*), allocatable  :: sss(:)
+    class(*), pointer      :: ttt(:)
+    class(*), allocatable :: ccc(:)
+    class(*), pointer     :: ddd(:)
+    call cl2(sss)
+    call tp2(ttt)
+    call cl2(ccc)
+    call tp2(ddd)
+  end
+
+  subroutine foo4 (ccc, ddd, sss, ttt, ispresent)
+    class(*), allocatable, optional  :: sss(:)
+    class(*), pointer, optional      :: ttt(:)
+    class(*), allocatable, optional :: ccc(:)
+    class(*), pointer, optional     :: ddd(:)
+    logical, value :: ispresent
+    if (present(ccc) .neqv. ispresent) stop 17
+    if (present(ccc)) then
+      call cl2(sss)
+      call tp2(ttt)
+      call cl2(ccc)
+      call tp2(ddd)
+    end if
+  end
+end
+
+use m
+use m2
+implicit none (external, type)
+integer :: a(1),b(1),c(1),d(1)
+class(*),allocatable :: aa(:),cc(:)
+class(*),pointer :: bb(:),dd(:)
+call foo (a,b,c,d)
+call foo2 (a,b,c,d, .true.)
+call foo2 (ispresent=.false.)
+
+nullify(bb,dd)
+call foo3 (aa,bb,cc,dd)
+call foo4 (aa,bb,cc,dd, .true.)
+call foo4 (ispresent=.false.)
+allocate(integer :: aa(-2:-1), bb(-2:-1), cc(-2:-1), dd(-2:-1))
+call foo3 (aa,bb,cc,dd)
+call foo4 (aa,bb,cc,dd, .true.)
+call foo4 (ispresent=.false.)
+deallocate(aa,bb,cc,dd)
+end