[Patch] C/C++: Fix unused set var warning with omp_clause_affinity [PR100913]

2021-06-14 Thread Tobias Burnus

Rather obvious fix for a warning found by David via cppcheck.

OK?

Tobias

-
Mentor Graphics (Deutschland) GmbH, Arnulfstrasse 201, 80634 München 
Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Frank 
Thürauf
C/C++: Fix unused set var warning with omp_clause_affinity [PR100913]

	PR c/100913
gcc/c/ChangeLog:

	* c-parser.c (c_parser_omp_clause_affinity): No need to set iterator
	var in the error case.

gcc/cp/ChangeLog:

	* parser.c (cp_parser_omp_clause_affinity): No need to set iterator
	var in the error case.

diff --git a/gcc/c/c-parser.c b/gcc/c/c-parser.c
index add33532a60..b90710cba2f 100644
--- a/gcc/c/c-parser.c
+++ b/gcc/c/c-parser.c
@@ -15590,21 +15590,19 @@ c_parser_omp_clause_affinity (c_parser *parser, tree list)
 	  return list;
 	}
 	}
 }
   nl = c_parser_omp_variable_list (parser, clause_loc, OMP_CLAUSE_AFFINITY,
    list);
   if (iterators)
 {
   tree block = pop_scope ();
-  if (iterators == error_mark_node)
-	iterators = NULL_TREE;
-  else
+  if (iterators != error_mark_node)
 	{
 	  TREE_VEC_ELT (iterators, 5) = block;
 	  for (tree c = nl; c != list; c = OMP_CLAUSE_CHAIN (c))
 	OMP_CLAUSE_DECL (c) = build_tree_list (iterators,
 		   OMP_CLAUSE_DECL (c));
 	}
 }
 
   parens.skip_until_found_close (parser);
diff --git a/gcc/cp/parser.c b/gcc/cp/parser.c
index b5af3877e48..d57ddc4560d 100644
--- a/gcc/cp/parser.c
+++ b/gcc/cp/parser.c
@@ -37922,21 +37922,19 @@ cp_parser_omp_clause_affinity (cp_parser *parser, tree list)
 	  return list;
 	}
 	}
 }
   nlist = cp_parser_omp_var_list_no_open (parser, OMP_CLAUSE_AFFINITY,
 	  list, NULL);
   if (iterators)
 {
   tree block = poplevel (1, 1, 0);
-  if (iterators == error_mark_node)
-	iterators = NULL_TREE;
-  else
+  if (iterators != error_mark_node)
 	{
 	  TREE_VEC_ELT (iterators, 5) = block;
 	  for (c = nlist; c != list; c = OMP_CLAUSE_CHAIN (c))
 	OMP_CLAUSE_DECL (c) = build_tree_list (iterators,
 		   OMP_CLAUSE_DECL (c));
 	}
 }
   return nlist;
 }


Re: [Patch] C/C++: Fix unused set var warning with omp_clause_affinity [PR100913]

2021-06-14 Thread Jakub Jelinek via Fortran
On Mon, Jun 14, 2021 at 02:34:53PM +0200, Tobias Burnus wrote:
> Rather obvious fix for a warning found by David via cppcheck.
> 
> OK?
> 
> Tobias
> 
> -
> Mentor Graphics (Deutschland) GmbH, Arnulfstrasse 201, 80634 München 
> Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Frank 
> Thürauf

> C/C++: Fix unused set var warning with omp_clause_affinity [PR100913]
> 
>   PR c/100913
> gcc/c/ChangeLog:
> 
>   * c-parser.c (c_parser_omp_clause_affinity): No need to set iterator
>   var in the error case.
> 
> gcc/cp/ChangeLog:
> 
>   * parser.c (cp_parser_omp_clause_affinity): No need to set iterator
>   var in the error case.

Ok.

Jakub



[committed] Fortran: resolve.c - remove '*XCNEW' based nullifying

2021-06-14 Thread Tobias Burnus

Found this odd code. It starts fine with:
  gfc_ref *ref = gfc_get_ref ();
this uses XCNEW to return nullified memory.

We then operate on
  ref->u.ar
where 'ar' is a struct which is in a 'u'nion which is in gfc_ref.

Hence, 'ref->u.ar' is not a pointer. Hence, the following is a
wasteful way to memset '\0' the struct – which is still '\0'
from the first XCNEW:
  ref->u.ar = *gfc_get_array_ref()

Note the '*' before the XCNEW calling macro gfc_get_array_ref!

Committed as obvious.

Tobias

-
Mentor Graphics (Deutschland) GmbH, Arnulfstrasse 201, 80634 München 
Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Frank 
Thürauf
commit a893b26f7311fe65b604f12a8fa5d5d64f5454e2
Author: Tobias Burnus 
Date:   Mon Jun 14 14:36:20 2021 +0200

Fortran: resolve.c - remove '*XCNEW' based nullifying

gcc/fortran/ChangeLog:

* resolve.c (resolve_variable): Remove *XCNEW used to
nullify nullified memory.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index a37ad665645..45c3ad387ac 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5709,7 +5709,6 @@ resolve_variable (gfc_expr *e)
 	 part_ref.  */
 	  gfc_ref *ref = gfc_get_ref ();
 	  ref->type = REF_ARRAY;
-	  ref->u.ar = *gfc_get_array_ref();
 	  ref->u.ar.type = AR_FULL;
 	  if (sym->as)
 	{


PING: [Patch, fortran v2] PR fortran/92621 Problems with memory handling with allocatable intent(out) arrays with bind(c)

2021-06-14 Thread José Rui Faustino de Sousa via Fortran

*PING*


 Forwarded Message 
Subject: [Patch, fortran v2] PR fortran/92621 Problems with memory 
handling with allocatable intent(out) arrays with bind(c)

Date: Mon, 26 Apr 2021 11:21:25 +
From: José Rui Faustino de Sousa 
To: fortran@gcc.gnu.org, gcc-patc...@gcc.gnu.org

Hi all!

Proposed patch to:

PR92621 - Problems with memory handling with allocatable intent(out) 
arrays with bind(c)


Patch tested only on x86_64-pc-linux-gnu.

The code currently generated tries to deallocate the undefined 
artificial cfi.n pointer before it is associated with the allocatable array.


Since the cfi.n pointer is undefined attempting to free it is really a 
bad idea and it will frequently segfault.


Consequently, since the deallocation is done before the cfi.n pointer is 
associated with anything, the allocatable array is never freed, like it 
should, and it will be passed still allocated causing subsequent 
attempts to allocate it to fail.


Version 2 is basically a ping, fixes a typo, replaces an if block with a 
flag to make reviewing easier and replaces a call to malloc with calloc 
to make Valgrind happy.


Thank you very much.

Best regards,
José Rui

Fortran: Fix segfaults due to freeing undefined pointer [PR92621]

gcc/fortran/ChangeLog:

PR fortran/92621
* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Add code to
deallocate allocatable intent(out) dummy array arguments and
slightly rearrange code.
(gfc_conv_procedure_call): Add a flag to avoid double frees,
removes unnecessary checks for bind(c) objects and obsolete
comments.

libgfortran/ChangeLog:

PR fortran/92621
* runtime/ISO_Fortran_binding.c (gfc_desc_to_cfi_desc): replaces
a call to malloc with calloc to make Valgrind happy.

gcc/testsuite/ChangeLog:

PR fortran/92621
* gfortran.dg/bind-c-intent-out.f90: Changes regex to match the
changes in code generation.
* gfortran.dg/PR92621.f90: Improved new test.



[Patch, fortran V2] PR fortran/100683 - Array initialization refuses valid

2021-06-14 Thread José Rui Faustino de Sousa via Fortran

Hi all!

Update to a proposed patch to:

PR100683 - Array initialization refuses valid

due to errors found by Dominique d'Humieres.

Patch tested only on x86_64-pc-linux-gnu.

Add call to simplify expression before parsing *and* check if the 
expression is still an array after simplification.


Thank you very much.

Best regards,
José Rui

Fortran: Fix bogus error

gcc/fortran/ChangeLog:

PR fortran/100683
* resolve.c (gfc_resolve_expr): Add call to gfc_simplify_expr.

gcc/testsuite/ChangeLog:

PR fortran/100683
* gfortran.dg/PR100683.f90: New test.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index a37ad66..a9518e7 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -7138,8 +7138,10 @@ gfc_resolve_expr (gfc_expr *e)
   /* Also try to expand a constructor.  */
   if (t)
 	{
+	  gfc_simplify_expr(e, 1);
 	  gfc_expression_rank (e);
-	  if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e))
+	  if (e->expr_type == EXPR_ARRAY
+	  && (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e)))
 	gfc_expand_constructor (e, false);
 	}
 
diff --git a/gcc/testsuite/gfortran.dg/PR100683.f90 b/gcc/testsuite/gfortran.dg/PR100683.f90
new file mode 100644
index 000..6929bb5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR100683.f90
@@ -0,0 +1,36 @@
+! { dg-do run }
+!
+! Test the fix for PR100683
+! 
+
+program main_p
+
+  implicit none
+
+  integer:: i
+  integer, parameter :: n = 11
+  integer, parameter :: u(*) = [(i, i=1,n)]
+
+  type :: foo_t
+integer :: i
+  end type foo_t
+
+  type, extends(foo_t) :: bar_t
+integer :: a(n)
+  end type bar_t
+  
+  type(bar_t), parameter :: a(*) = [(bar_t(i, u), i=1,n)]
+  type(bar_t):: b(n) = [(bar_t(i, u), i=1,n)]
+
+  if(any(a(:)%i/=u))   stop 1
+  do i = 1, n
+if(any(a(i)%a/=u)) stop 2
+  end do
+  if(any(b(:)%i/=u))   stop 3
+  do i = 1, n
+if(any(b(i)%a/=u)) stop 4
+  end do
+  stop
+
+end program main_p
+


Re: [Patch ]Fortran/OpenMP: Extend defaultmap clause for OpenMP 5 [PR92568]

2021-06-14 Thread Jakub Jelinek via Fortran
On Wed, Jun 09, 2021 at 02:18:43PM +0200, Tobias Burnus wrote:
> This patch add's OpenMP 5.1's  defaultmap extensions to Fortran.
> 
> There is one odd thing,
>   integer :: ii, it
>   target :: it
> both count as nonallocatable, nonpointer scalars (i.e. category 'scalar').
> But with implicit mapping (and 'defaultmap(default)'), 'it' is mapped
> tofrom due to the TARGET attribute (cf. quote in the PR).

The list in 5.1 2.21.7 is ordered, so if defaultmap is present and is
not default, it takes precedence over TARGET attribute.
So, it above with defaultmap(firstprivate:scalar) will result in
firstprivate(it, ii), while no defaultmap or default for it will result in
map(tofrom: it) firstprivate (ii) (same for ALLOCATABLE/POINTER).

> +   switch ((enum gfc_omp_defaultmap) i)
> + {
> +   case OMP_DFLTMAP_CAT_SCALAR: dfltmap = "SCALAR"; break;
> +   case OMP_DFLTMAP_CAT_AGGREGATE: dfltmap = "AGGREGATE"; break;
> +   case OMP_DFLTMAP_CAT_ALLOCATABLE: dfltmap = "ALLOCATABLE"; break;
> +   case OMP_DFLTMAP_CAT_POINTER: dfltmap = "POINTER"; break;
> +   default: gcc_unreachable ();

Formatting.  case/default should be indented the same as {.

> --- a/gcc/fortran/gfortran.h
> +++ b/gcc/fortran/gfortran.h
> @@ -1241,6 +1241,29 @@ enum gfc_omp_map_op
>OMP_MAP_ALWAYS_TOFROM
>  };
>  
> +enum gfc_omp_defaultmap
> +{
> +  OMP_DFLTMAP_UNSET,
> +  OMP_DFLTMAP_ALLOC,
> +  OMP_DFLTMAP_TO,
> +  OMP_DFLTMAP_FROM,
> +  OMP_DFLTMAP_TOFROM,
> +  OMP_DFLTMAP_FIRSTPRIVATE,
> +  OMP_DFLTMAP_NONE,
> +  OMP_DFLTMAP_DEFAULT,
> +  OMP_DFLTMAP_PRESENT

Any reason not to use full OMP_DEFAULTMAP_ ?  The extra 3 chars
will improve readability I think.
> +};
> +
> +enum gfc_omp_dfltmpap_category

Was this meant to be dfltmap rather than mpap?
I think I'd prefer omp_defaultmap_category

> +{
> +  OMP_DFLTMAP_CAT_UNCATEGORIZED,
> +  OMP_DFLTMAP_CAT_SCALAR,
> +  OMP_DFLTMAP_CAT_AGGREGATE,
> +  OMP_DFLTMAP_CAT_ALLOCATABLE,
> +  OMP_DFLTMAP_CAT_POINTER,
> +  OMP_DFLTMAP_CAT_NUM

And same as above.

> +  switch(clauses->defaultmap[i])

Missing space after switch.

> diff --git a/gcc/testsuite/gfortran.dg/gomp/defaultmap-1.f90 
> b/gcc/testsuite/gfortran.dg/gomp/defaultmap-1.f90
> new file mode 100644
> index 000..299d971f23c

As for the testsuite, I miss the integer, target :: it case
in the gfortran.dg/gomp/defaultmap-*.f90 tests, it is only in the runtime
case if I'm not blind.

Jakub



[Patch, fortran] PR fortran/94104 - Request for diagnostic improvement

2021-06-14 Thread José Rui Faustino de Sousa via Fortran

Hi all!

Proposed patch to:

Bug 94104 - Request for diagnostic improvement

Patch tested only on x86_64-pc-linux-gnu.

Error message improvement. In Fortran 2008 actual arguments to 
procedures having a pointer, with intent attribute in, formal argument 
can also have the target attribute not just pointer.


Thank you very much.

Best regards,
José Rui

Fortran: error message improvement.

PR fortran/94104

gcc/fortran/ChangeLog:

* interface.c (gfc_compare_actual_formal): improve error message.

gcc/testsuite/ChangeLog:

* gfortran.dg/parens_2.f90: update regex.
* gfortran.dg/PR94104a.f90: New test.
* gfortran.dg/PR94104b.f90: New test.

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 9e3e8aa..4cc0708 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -3329,26 +3329,38 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  return false;
 	}
 
-  if (a->expr->expr_type != EXPR_NULL
-	  && compare_pointer (f->sym, a->expr) == 0)
+  if (a->expr->expr_type != EXPR_NULL)
 	{
-	  if (where)
-	gfc_error ("Actual argument for %qs must be a pointer at %L",
-		   f->sym->name, &a->expr->where);
-	  return false;
-	}
+	  int cmp = compare_pointer (f->sym, a->expr);
+	  bool pre2008 = ((gfc_option.allow_std & GFC_STD_F2008) == 0);
+	  
+	  if (pre2008 && cmp == 0)
+	{
+	  if (where)
+		gfc_error ("Actual argument for %qs at %L must be a pointer.",
+			   f->sym->name, &a->expr->where);
+	  return false;
+	}
+	  
+	  if (pre2008 && cmp == 2)
+	{
+	  if (where)
+		gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
+			   "pointer dummy %qs", &a->expr->where,f->sym->name);
+	  return false;
+	}
 
-  if (a->expr->expr_type != EXPR_NULL
-	  && (gfc_option.allow_std & GFC_STD_F2008) == 0
-	  && compare_pointer (f->sym, a->expr) == 2)
-	{
-	  if (where)
-	gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
-		   "pointer dummy %qs", &a->expr->where,f->sym->name);
-	  return false;
+	  if (!pre2008 && cmp == 0)
+	{
+	  if (where)
+		gfc_error ("Actual argument for %qs at %L must be a pointer "
+			   "or a valid target for the dummy pointer in a "
+			   "pointer assignment statement.",
+			   f->sym->name, &a->expr->where);
+	  return false;
+	}
 	}
 
-
   /* Fortran 2008, C1242.  */
   if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
 	{
diff --git a/gcc/testsuite/gfortran.dg/PR94104a.f90 b/gcc/testsuite/gfortran.dg/PR94104a.f90
new file mode 100644
index 000..acde7fe
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR94104a.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+! { dg-shouldfail "Actual argument" }
+!
+! PR fortran/94104
+!
+
+program diag_p
+
+  implicit none
+
+  integer, parameter :: n = 7
+
+  integer :: a(n)
+  integer, target :: b(n)
+
+  a = 1
+  print *, sumf(a) ! { dg-error "Actual argument for 'a' at .1. must be a pointer\\." }
+  print *, sumf(b) ! { dg-error "Fortran 2008: Non-pointer actual argument at .1. to pointer dummy 'a'" }
+  stop
+
+contains
+
+  function sumf(a) result(s)
+integer, pointer, intent(in) :: a(:)
+
+integer :: s
+
+s = sum(a)
+return
+  end function sumf
+
+end program diag_p
+
+
diff --git a/gcc/testsuite/gfortran.dg/PR94104b.f90 b/gcc/testsuite/gfortran.dg/PR94104b.f90
new file mode 100644
index 000..5018da9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR94104b.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+! { dg-shouldfail "Actual argument" }
+!
+! PR fortran/94104
+!
+
+program diag_p
+
+  implicit none
+
+  integer, parameter :: n = 7
+
+  integer :: a(n)
+  integer, target :: b(n)
+
+  a = 1
+  print *, sumf(a) ! { dg-error "Actual argument for 'a' at .1. must be a pointer or a valid target" }
+  print *, sumf(b)
+  stop
+
+contains
+
+  function sumf(a) result(s)
+integer, pointer, intent(in) :: a(:)
+
+integer :: s
+
+s = sum(a)
+return
+  end function sumf
+
+end program diag_p
+
+
diff --git a/gcc/testsuite/gfortran.dg/parens_2.f90 b/gcc/testsuite/gfortran.dg/parens_2.f90
index bc2acd8..dc5965d 100644
--- a/gcc/testsuite/gfortran.dg/parens_2.f90
+++ b/gcc/testsuite/gfortran.dg/parens_2.f90
@@ -2,7 +2,7 @@
 ! { dg-do compile }
 ! Originally contributed by Joost VandeVondele
 INTEGER, POINTER :: I
-CALL S1((I)) ! { dg-error "Actual argument for .i. must be a pointer" }
+CALL S1((I)) ! { dg-error "Actual argument for .i. at .1. must be a pointer or a valid target" }
 CONTAINS
  SUBROUTINE S1(I)
   INTEGER, POINTER ::I


[Patch, fortran V2] PR fortran/93308/93963/94327/94331/97046 problems raised by descriptor handling

2021-06-14 Thread José Rui Faustino de Sousa via Fortran

Hi all!

Update to a proposed patch to:

Bug 93308 - bind(c) subroutine changes lower bound of array argument in 
caller
Bug 93963 - Select rank mishandling allocatable and pointer arguments 
with bind(c)

Bug 94327 - Bind(c) argument attributes are incorrectly set
Bug 94331 - Bind(C) corrupts array descriptors
Bug 97046 - Bad interaction between lbound/ubound, allocatable arrays 
and bind(C) subroutine with dimension(..) parameter


due to errors found in one of the tests by Dominique d'Humieres.

Patch tested only on x86_64-pc-linux-gnu.

Fix attribute handling, which reflect a prior intermediate version of 
the Fortran standard.


CFI descriptors, in most cases, should not be copied out has they can 
corrupt the Fortran descriptor. Bounds will vary and the original 
Fortran bounds are definitively lost on conversion.


Thank you very much.

Best regards,
José Rui

Fortran: Fix attributtes and bounds in ISO_Fortran_binding.

gcc/fortran/ChangeLog:

PR fortran/93308
PR fortran/93963
PR fortran/94327
PR fortran/94331
PR fortran/97046
* trans-decl.c (convert_CFI_desc): Only copy out the descriptor
if necessary.
* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Updated attribute
handling which reflect a previous intermediate version of the
standard. Only copy out the descriptor if necessary.

libgfortran/ChangeLog:

PR fortran/93308
PR fortran/93963
PR fortran/94327
PR fortran/94331
PR fortran/97046
* runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Add code
to verify the descriptor. Correct bounds calculation.
(gfc_desc_to_cfi_desc): Add code to verify the descriptor.

gcc/testsuite/ChangeLog:

PR fortran/93308
PR fortran/93963
PR fortran/94327
PR fortran/94331
PR fortran/97046
* gfortran.dg/ISO_Fortran_binding_1.f90: Add pointer attribute,
this test is still erroneous but now it compiles.
* gfortran.dg/bind_c_array_params_2.f90: Update regex to match
code changes.
* gfortran.dg/PR93308.f90: New test.
* gfortran.dg/PR93963.f90: New test.
* gfortran.dg/PR94327.c: New test.
* gfortran.dg/PR94327.f90: New test.
* gfortran.dg/PR94331.c: New test.
* gfortran.dg/PR94331.f90: New test.
* gfortran.dg/PR97046.f90: New test.
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index c32bd05..97aafe3 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -4526,22 +4526,28 @@ convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym)
   gfc_add_expr_to_block (&outer_block, incoming);
   incoming = gfc_finish_block (&outer_block);
 
-
   /* Convert the gfc descriptor back to the CFI type before going
 	 out of scope, if the CFI type was present at entry.  */
-  gfc_init_block (&outer_block);
-  gfc_init_block (&tmpblock);
-
-  tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
-  outgoing = build_call_expr_loc (input_location,
-			gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
-  gfc_add_expr_to_block (&tmpblock, outgoing);
+  outgoing = NULL_TREE;
+  if ((sym->attr.pointer || sym->attr.allocatable)
+	  && !sym->attr.value
+	  && sym->attr.intent != INTENT_IN)
+	{
+	  gfc_init_block (&outer_block);
+	  gfc_init_block (&tmpblock);
 
-  outgoing = build3_v (COND_EXPR, present,
-			   gfc_finish_block (&tmpblock),
-			   build_empty_stmt (input_location));
-  gfc_add_expr_to_block (&outer_block, outgoing);
-  outgoing = gfc_finish_block (&outer_block);
+	  tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
+	  outgoing = build_call_expr_loc (input_location,
+	  gfor_fndecl_gfc_to_cfi, 2,
+	  tmp, gfc_desc_ptr);
+	  gfc_add_expr_to_block (&tmpblock, outgoing);
+
+	  outgoing = build3_v (COND_EXPR, present,
+			   gfc_finish_block (&tmpblock),
+			   build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&outer_block, outgoing);
+	  outgoing = gfc_finish_block (&outer_block);
+	}
 
   /* Add the lot to the procedure init and finally blocks.  */
   gfc_add_init_cleanup (block, incoming, outgoing);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index de406ad..52e243b 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5501,13 +5501,12 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
 	attribute = 1;
 }
 
-  /* If the formal argument is assumed shape and neither a pointer nor
- allocatable, it is unconditionally CFI_attribute_other.  */
-  if (fsym->as->type == AS_ASSUMED_SHAPE
-  && !fsym->attr.pointer && !fsym->attr.allocatable)
-   cfi_attribute = 2;
+  if (fsym->attr.pointer)
+cfi_attribute = 0;
+  else if (fsym->attr.allocatable)
+cfi_attribute = 1;
   else
-   cfi_attribute = attribute;
+cfi_attribute = 2;
 
   if (e->rank != 0)
 {
@@ -5615,10 +5614,15 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
   gfc_prepend_expr_to_b