public inbox for fortran@gcc.gnu.org
 help / color / mirror / Atom feed
* [Patch, fortran] PR87477 - [meta-bug] [F03] issues concerning the ASSOCIATE statement
@ 2023-06-01 15:20 Paul Richard Thomas
  2023-06-01 17:58 ` Mikael Morin
  0 siblings, 1 reply; 8+ messages in thread
From: Paul Richard Thomas @ 2023-06-01 15:20 UTC (permalink / raw)
  To: fortran, gcc-patches


[-- Attachment #1.1: Type: text/plain, Size: 1043 bytes --]

Hi All,

This started out as the search for a fix to pr109948 and evolved to roll in
5 other prs.

Basically parse_associate was far too clunky and, in anycase, existing
functions in resolve.cc were well capable of doing the determination of the
target expression rank. While I was checking the comments, the lightbulb
flashed with respect to prs 102109/112/190 and the chunk dealing with
function results of unknown type was born.

Thanks to the changes in parse.cc, the problem in pr99326 migrated
upstream to the resolution and the chunklet in resolve.cc was an obvious
fix.

I am minded to s/{ dg-do run}/{ dg-do compile } for all six testcases. At
the testing stage, I wanted to check that the testcases actually did what
they are supposed to do :-)

Bootstraps and regtests OK - good for head?

Paul

PS I need to do some housekeeping on pr87477 now. Some of the blockers have
"fixed themselves" and others are awaiting backporting. I think that there
are only 4 or so left, of which 89645 and 99065 are the most difficult to
deal with.

[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 13255 bytes --]

diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 5e2a95688d2..3947444f17c 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -4919,6 +4919,7 @@ parse_associate (void)
   gfc_state_data s;
   gfc_statement st;
   gfc_association_list* a;
+  gfc_array_spec *as;
 
   gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
 
@@ -4934,8 +4935,7 @@ parse_associate (void)
   for (a = new_st.ext.block.assoc; a; a = a->next)
     {
       gfc_symbol* sym;
-      gfc_ref *ref;
-      gfc_array_ref *array_ref;
+      gfc_expr *target;
 
       if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
 	gcc_unreachable ();
@@ -4952,6 +4952,7 @@ parse_associate (void)
 	 for parsing component references on the associate-name
 	 in case of association to a derived-type.  */
       sym->ts = a->target->ts;
+      target = a->target;
 
       /* Don’t share the character length information between associate
 	 variable and target if the length is not a compile-time constant,
@@ -4971,31 +4972,37 @@ parse_associate (void)
 	       && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT))
 	sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
 
-      /* Check if the target expression is array valued.  This cannot always
-	 be done by looking at target.rank, because that might not have been
-	 set yet.  Therefore traverse the chain of refs, looking for the last
-	 array ref and evaluate that.  */
-      array_ref = NULL;
-      for (ref = a->target->ref; ref; ref = ref->next)
-	if (ref->type == REF_ARRAY)
-	  array_ref = &ref->u.ar;
-      if (array_ref || a->target->rank)
+      /* Check if the target expression is array valued. This cannot be done
+	 by calling gfc_resolve_expr because the context is unavailable.
+	 However, the references can be resolved and the rank of the target
+	 expression set.  */
+      if (target->ref && gfc_resolve_ref (target)
+	  && target->expr_type != EXPR_ARRAY
+	  && target->expr_type != EXPR_COMPCALL)
+	gfc_expression_rank (target);
+
+      /* Determine whether or not function expressions with unknown type are
+	 structure constructors. If so, the function result can be converted
+	 to be a derived type.
+	 TODO: Deal with references to sibling functions that have not yet been
+	 parsed (PRs 89645 and 99065).  */
+      if (target->expr_type == EXPR_FUNCTION && target->ts.type == BT_UNKNOWN)
 	{
-	  gfc_array_spec *as;
-	  int dim, rank = 0;
-	  if (array_ref)
+	  gfc_symbol *derived;
+	  /* The derived type has a leading uppercase character.  */
+	  gfc_find_symbol (gfc_dt_upper_string (target->symtree->name),
+			   my_ns->parent, 1, &derived);
+	  if (derived && derived->attr.flavor == FL_DERIVED)
 	    {
-	      a->rankguessed = 1;
-	      /* Count the dimension, that have a non-scalar extend.  */
-	      for (dim = 0; dim < array_ref->dimen; ++dim)
-		if (array_ref->dimen_type[dim] != DIMEN_ELEMENT
-		    && !(array_ref->dimen_type[dim] == DIMEN_UNKNOWN
-			 && array_ref->end[dim] == NULL
-			 && array_ref->start[dim] != NULL))
-		  ++rank;
+	      sym->ts.type = BT_DERIVED;
+	      sym->ts.u.derived = derived;
 	    }
-	  else
-	    rank = a->target->rank;
+	}
+
+      if (target->rank)
+	{
+	  int rank = 0;
+	  rank = target->rank;
 	  /* When the rank is greater than zero then sym will be an array.  */
 	  if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
 	    {
@@ -5006,8 +5013,8 @@ parse_associate (void)
 		  /* Don't just (re-)set the attr and as in the sym.ts,
 		     because this modifies the target's attr and as.  Copy the
 		     data and do a build_class_symbol.  */
-		  symbol_attribute attr = CLASS_DATA (a->target)->attr;
-		  int corank = gfc_get_corank (a->target);
+		  symbol_attribute attr = CLASS_DATA (target)->attr;
+		  int corank = gfc_get_corank (target);
 		  gfc_typespec type;
 
 		  if (rank || corank)
@@ -5042,7 +5049,7 @@ parse_associate (void)
 	      as = gfc_get_array_spec ();
 	      as->type = AS_DEFERRED;
 	      as->rank = rank;
-	      as->corank = gfc_get_corank (a->target);
+	      as->corank = gfc_get_corank (target);
 	      sym->as = as;
 	      sym->attr.dimension = 1;
 	      if (as->corank)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 83e45f1b693..c0515fd0c97 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -16087,7 +16087,8 @@ resolve_symbol (gfc_symbol *sym)
 
       if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
 	   || as->type == AS_ASSUMED_SHAPE)
-	  && !sym->attr.dummy && !sym->attr.select_type_temporary)
+	  && !sym->attr.dummy && !sym->attr.select_type_temporary
+	  && !sym->attr.associate_var)
 	{
 	  if (as->type == AS_ASSUMED_SIZE)
 	    gfc_error ("Assumed size array at %L must be a dummy argument",
diff --git a/gcc/testsuite/gfortran.dg/associate_54.f90 b/gcc/testsuite/gfortran.dg/associate_54.f90
index 680ad5d14a2..8eb95a710b6 100644
--- a/gcc/testsuite/gfortran.dg/associate_54.f90
+++ b/gcc/testsuite/gfortran.dg/associate_54.f90
@@ -24,7 +24,7 @@ contains
   subroutine test_alter_state1 (obj, a)
     class(test_t), intent(inout) :: obj
     integer, intent(in) :: a
-    associate (state => obj%state(TEST_STATES)) ! { dg-error "is used as array" }
+    associate (state => obj%state(TEST_STATES)) ! { dg-error "as array|no IMPLICIT type" }
 !      state = a
       state(TEST_STATE) = a ! { dg-error "array reference of a non-array" }
     end associate
diff --git a/gcc/testsuite/gfortran.dg/pr102109.f90 b/gcc/testsuite/gfortran.dg/pr102109.f90
new file mode 100644
index 00000000000..8f3cecbe239
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr102109.f90
@@ -0,0 +1,20 @@
+! { dg-do run }
+!
+! Contributed by Brad Richardson  <everythingfunctional@protonmail.com>
+!
+program main
+    type :: sub_obj_t
+        integer :: val
+    end type
+
+    type :: compound_obj_t
+        type(sub_obj_t) :: sub_obj
+    end type
+
+    associate(initial_sub_obj => sub_obj_t(42))
+!        print *, initial_sub_obj%val           ! Used to work with this uncommented
+        associate(obj => compound_obj_t(initial_sub_obj))
+            if (obj%sub_obj%val .ne. 42) stop 1
+        end associate
+    end associate
+end program
diff --git a/gcc/testsuite/gfortran.dg/pr102112.f90 b/gcc/testsuite/gfortran.dg/pr102112.f90
new file mode 100644
index 00000000000..cde9cbf52e2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr102112.f90
@@ -0,0 +1,23 @@
+! { dg-do run }
+!
+! Contributed by Brad Richardson  <everythingfunctional@protonmail.com>
+!
+program main
+    implicit none
+
+    type :: sub_t
+        integer :: val
+    end type
+
+    type :: obj_t
+        type(sub_t) :: sub_obj
+    end type
+
+    associate(initial_sub => sub_t(42))
+        associate(obj => obj_t(initial_sub))
+            associate(sub_obj => obj%sub_obj)
+                if (sub_obj%val .ne. 42) stop 1
+            end associate
+        end associate
+    end associate
+end program
diff --git a/gcc/testsuite/gfortran.dg/pr102190.f90 b/gcc/testsuite/gfortran.dg/pr102190.f90
new file mode 100644
index 00000000000..48968430161
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr102190.f90
@@ -0,0 +1,74 @@
+! { dg-do run }
+!
+! Contributed by Brad Richardson  <everythingfunctional@protonmail.com>
+!
+module sub_m
+    type :: sub_t
+        private
+        integer :: val
+    end type
+
+    interface sub_t
+        module procedure constructor
+    end interface
+
+    interface sub_t_val
+        module procedure t_val
+    end interface
+contains
+    function constructor(val) result(sub)
+        integer, intent(in) :: val
+        type(sub_t) :: sub
+
+        sub%val = val
+    end function
+
+    function t_val(val) result(res)
+        integer :: res
+        type(sub_t), intent(in) :: val
+        res = val%val
+    end function
+end module
+
+module obj_m
+    use sub_m, only: sub_t
+    type :: obj_t
+        private
+        type(sub_t) :: sub_obj_
+    contains
+        procedure :: sub_obj
+    end type
+
+    interface obj_t
+        module procedure constructor
+    end interface
+contains
+    function constructor(sub_obj) result(obj)
+        type(sub_t), intent(in) :: sub_obj
+        type(obj_t) :: obj
+
+        obj%sub_obj_ = sub_obj
+    end function
+
+    function sub_obj(self)
+        class(obj_t), intent(in) :: self
+        type(sub_t) :: sub_obj
+
+        sub_obj = self%sub_obj_
+    end function
+end module
+
+program main
+    use sub_m, only: sub_t, sub_t_val
+    use obj_m, only: obj_t
+    type(sub_t), allocatable :: z
+
+    associate(initial_sub => sub_t(42))
+        associate(obj => obj_t(initial_sub))
+            associate(sub_obj => obj%sub_obj())
+              allocate (z, source = obj%sub_obj())
+            end associate
+        end associate
+    end associate
+    if (sub_t_val (z) .ne. 42) stop 1
+end program
diff --git a/gcc/testsuite/gfortran.dg/pr102532.f90 b/gcc/testsuite/gfortran.dg/pr102532.f90
new file mode 100644
index 00000000000..714379a6ac2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr102532.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+subroutine foo
+   character(:), allocatable :: x[:]
+   associate (y => x(:)(2:)) ! { dg-error "Rank mismatch|deferred type parameter" }
+   end associate
+end
+
+subroutine bar
+   character(:), allocatable :: x[:]
+   associate (y => x(:)(:)) ! { dg-error "Rank mismatch|deferred type parameter" }
+   end associate
+end
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/pr109948.f90 b/gcc/testsuite/gfortran.dg/pr109948.f90
new file mode 100644
index 00000000000..4d963539396
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr109948.f90
@@ -0,0 +1,114 @@
+! { dg-do run }
+!
+! Tests the fix for PR109948
+!
+! Contributed by Rimvydas Jasinskas <rimvydas.jas@gmail.com>
+!
+module mm
+  implicit none
+  interface operator(==)
+    module procedure eq_1_2
+  end interface operator(==)
+  private :: eq_1_2
+contains
+  logical function eq_1_2 (x, y)
+    integer, intent(in) :: x(:)
+    real,    intent(in) :: y(:,:)
+    eq_1_2 = .true.
+  end function eq_1_2
+end module mm
+
+program pr109948
+  use mm
+  implicit none
+  type tlap
+    integer,    allocatable :: z(:)
+  end type tlap
+  type ulap
+    type(tlap) :: u(2)
+  end type ulap
+  integer :: pid = 1
+  call comment0         ! Original problem
+  call comment1
+  call comment3 ([5,4,3,2,1])
+  call comment10
+  call comment11 ([5,4,3,2,1])
+contains
+  subroutine comment0
+    type(tlap) :: y_in
+    integer :: x_out(3) =[0.0,0.0,0.0]
+    y_in%z = [1,-2,3]
+    call foo(y_in, x_out)
+    if (any (x_out .ne. [0, -2, 0])) stop 1
+    call foo(y_in, x_out)
+    if (any (x_out .ne. [1, -2, 3])) stop 2
+  end subroutine comment0
+
+  subroutine foo(y, x)
+    type(tlap) :: y
+    integer :: x(:)
+    associate(z=>y%z)
+      if (pid == 1) then
+        where ( z < 0 ) x(:) = z(:)
+      else
+        where ( z > 0 ) x(:) = z(:)
+    endif
+    pid = pid + 1
+    end associate
+  end subroutine foo
+
+  subroutine comment1
+    type(tlap) :: grib
+    integer :: i
+    grib%z = [3,2,1]
+    associate(k=>grib%z)
+      i = k(1)
+      if (any(k==1)) i = 1
+    end associate
+    if (i .eq. 3) stop 3
+  end subroutine comment1
+
+  subroutine comment3(k_2d)
+    implicit none
+    integer :: k_2d(:)
+    integer :: i
+    associate(k=>k_2d)
+      i = k(1)
+      if (any(k==1)) i = 1
+    end associate
+    if (i .eq. 3) stop 4
+  end subroutine comment3
+
+  subroutine comment11(k_2d)
+    implicit none
+    integer :: k_2d(:)
+    integer :: m(1) = 42
+    real    :: r(1,1) = 3.0
+    if ((m == r) .neqv. .true.) stop 5
+    associate (k=>k_2d)
+      if ((k == r) .neqv. .true.) stop 6  ! failed to find user defined operator
+    end associate
+    associate (k=>k_2d(:))
+      if ((k == r) .neqv. .true.) stop 7
+    end associate
+  end subroutine comment11
+
+  subroutine comment10
+    implicit none
+    type(ulap) :: z(2)
+    integer :: i
+    real    :: r(1,1) = 3.0
+    z(1)%u = [tlap([1,2,3]),tlap([4,5,6])]
+    z(2)%u = [tlap([7,8,9]),tlap([10,11,12])]
+    associate (k=>z(2)%u(1)%z)
+      i = k(1)
+      if (any(k==8)) i = 1
+    end associate
+    if (i .ne. 1) stop 8
+    associate (k=>z(1)%u(2)%z)
+      if ((k == r) .neqv. .true.) stop 9
+      if (any (k .ne. [4,5,6])) stop 10
+    end associate
+  end subroutine comment10
+end program pr109948
+
diff --git a/gcc/testsuite/gfortran.dg/pr99326.f90 b/gcc/testsuite/gfortran.dg/pr99326.f90
new file mode 100644
index 00000000000..75d1f50c238
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr99326.f90
@@ -0,0 +1,26 @@
+! { dg-do compile }
+! internal compiler error: in gfc_build_dummy_array_decl, at
+! fortran/trans-decl.cc:1317
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+program p
+   type t0
+     integer :: i
+   end type
+   type t
+      class(t0), allocatable :: a(:)
+   end type
+   class(t0), allocatable :: arg(:)
+   allocate (arg, source = [t0(1), t0(2)])
+   call s(arg)
+contains
+   subroutine s(x)
+      class(t0) :: x(:)
+      type(t) :: z
+      associate (y => x)
+         z%a = y
+      end associate
+   if (size(z%a) .ne. 2) stop 1
+   end
+end

[-- Attachment #3: Change109948.Logs --]
[-- Type: application/octet-stream, Size: 922 bytes --]

Fortran: Fix some problems blocking associate meta-bug [PR87477]

2023-06-01  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/87477
	* parse.cc (parse_associate): Replace the existing evaluation
	of the target rank with calls to gfc_resolve_ref and
	gfc_expression_rank. Identify untyped target function results
	with structure constructors by finding the appropriate derived
	type.
	* resolve.cc (resolve_symbol): Allow associate variables to be
	assumed shape.

gcc/testsuite/
	PR fortran/87477
	* gfortran.dg/associate_54.f90 : Cope with extra error.

	PR fortran/102109
	* gfortran.dg/pr102109.f90 : New test.

	PR fortran/102112
	* gfortran.dg/pr102112.f90 : New test.

	PR fortran/102190
	* gfortran.dg/pr102190.f90 : New test.

	PR fortran/102532
	* gfortran.dg/pr102532.f90 : New test.

	PR fortran/109948
	* gfortran.dg/pr109948.f90 : New test.

	PR fortran/99326
	* gfortran.dg/pr99326.f90 : New test.

^ permalink raw reply	[flat|nested] 8+ messages in thread
* [Patch, fortran] PR87477 - [meta-bug] [F03] issues concerning the ASSOCIATE statement
@ 2023-03-28 21:04 Paul Richard Thomas
  2023-03-29  8:24 ` Manfred Schwarb
  0 siblings, 1 reply; 8+ messages in thread
From: Paul Richard Thomas @ 2023-03-28 21:04 UTC (permalink / raw)
  To: fortran, gcc-patches


[-- Attachment #1.1: Type: text/plain, Size: 2624 bytes --]

Hi All,

I have made a start on ASSOCIATE issues. Some of the low(-ish) hanging
fruit are already fixed but I have yet to check that they a really fixed
and to close them:
pr102106, pr102111, pr104430, pr106048, pr85510, pr87460, pr92960 & pr93338

The attached patch picks up those PRs involving deferred length characters
in one guise or another. I believe that it is all pretty straightforward.
Structure constructors with allocatable, deferred length, character array
components just weren't implemented and so this is the biggest part of the
patch. I found two other, non-associate PRs(106918 &  105205) that are
fixed and there are probably more.

The chunk in trans-io.cc is something of a kludge, which I will come back
to. Some descriptors come through with a data pointer that looks as if it
should be OK but

I thought to submit this now to get it out of the way. The ratio of PRs
fixed to the size of the patch warrants this. The next stage is going to be
rather messy and so "I might take a little while" (cross talk between
associate and select type, in particular).

Regtests OK - good for mainline?

Cheers

Paul

Fortran: Fix some of the bugs in associate [PR87477]

2023-03-28  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
PR fortran/87477
* trans-array.cc (gfc_conv_expr_descriptor): Guard string len
expression in condition.
(duplicate_allocatable): Make element type more explicit with
'eltype'.
* trans-expr.cc (gfc_get_expr_charlen): Retain last charlen in
'previous' and use if end expression in substring reference is
null.
(gfc_conv_string_length): Use gfc_conv_expr_descriptor if
'expr_flat' is an array.
(gfc_trans_alloc_subarray_assign): If this is a deferred string
length component, store the string length in the hidden comp.
Update the typespec length accordingly. Generate a new type
spec for the call to gfc_duplicate-allocatable in this case.
* trans-io.cc (gfc_trans_transfer): Scalarize transfer of
deferred character array components.


gcc/testsuite/
PR fortran/92994
* gfortran.dg/finalize_51.f90 : Update an error message.

PR fortran/85686
* gfortran.dg/pr85686.f90 : New test

PR fortran/88247
* gfortran.dg/pr88247.f90 : New test

PR fortran/91941
* gfortran.dg/pr91941.f90 : New test

PR fortran/92779
* gfortran.dg/pr92779.f90 : New test

PR fortran/93339
* gfortran.dg/pr93339.f90 : New test

PR fortran/93813
* gfortran.dg/pr93813.f90 : New test

PR fortran/100948
* gfortran.dg/pr100948.f90 : New test

PR fortran/102106
* gfortran.dg/pr102106.f90 : New test

PR fortran/105205
* gfortran.dg/pr105205.f90 : New test

PR fortran/106918
* gfortran.dg/pr106918.f90 : New test

[-- Attachment #2: pr100948.diff --]
[-- Type: application/x-patch, Size: 9830 bytes --]

[-- Attachment #3: pr85686.f90 --]
[-- Type: application/octet-stream, Size: 382 bytes --]

! { dg-do run }
!
! Used to segfault at the write statement.
!
! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
!
  character(20) :: buffer
  call s([" g'day "," bye!! "])
  print *, buffer
  if (trim (buffer) .ne. " a g'day a bye!!") stop 1
contains
  subroutine s(x)
    character(*) :: x(:)
    associate (y => 'a'//x)
      write (buffer, *) y
    end associate
  end
end

[-- Attachment #4: pr88247.f90 --]
[-- Type: application/octet-stream, Size: 647 bytes --]

! { dg-do run }
!
! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
!
program p
   call foo
contains
   subroutine foo
      type t
         character(:), dimension(:), allocatable :: d
      end type t
      type(t), allocatable :: x
      character(5) :: buffer(3)
      allocate (x, source = t (['ab','cd'])) ! Didn't work
      write(buffer(1), *) x%d(2:1:-1)        ! Was found to be broken
      write(buffer(2), *) [x%d(2:1:-1)]      ! Was OK
      associate (y => [x%d(2:1:-1)])
        write(buffer(3), *) y                ! Bug in comment 7
      end associate
      if (any (buffer .ne. " cdab")) stop 1
   end subroutine foo
end

[-- Attachment #5: pr91941.f90 --]
[-- Type: application/octet-stream, Size: 317 bytes --]

! { dg-do-compile }
!
! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
!
program p
   character(:), allocatable :: x(:), z(:)
   x = [' abc', ' xyz']
   z = adjustl(x)
   associate (y => adjustl(x))
      if (any(y .ne. ['abc ', 'xyz '])) stop 1
   end associate
   deallocate(x, z) ! For valgrind testing
end

[-- Attachment #6: pr92779.f90 --]
[-- Type: application/octet-stream, Size: 230 bytes --]

! { dg-do-run }
!
! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
!
program p
   character(3) :: a = 'abc'
   associate (y => spread(trim(a),1,2) // 'd')
      if (any (y .ne. ['abcd','abcd'])) stop 1
   end associate
end

[-- Attachment #7: pr93339.f90 --]
[-- Type: application/octet-stream, Size: 466 bytes --]

! { dg-do-run }
!
! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
!
program p
   type t
      character(:), allocatable :: a(:)
   end type
   type(t) :: x
   x = t(["abc "])                    ! Didn't assign anything
!   allocate (x%a(1), source = 'abc') ! Worked OK
   associate (y => x%a)
         if (any (y .ne. 'abc ')) stop 1
      associate (z => x%a)
         if (any (y .ne. z)) stop 2
      end associate
   end associate
   deallocate (x%a)
end

[-- Attachment #8: pr93813.f90 --]
[-- Type: application/octet-stream, Size: 455 bytes --]

! { dg-do-run }
!
! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
!
program p
   type t
   end type
   type, extends(t) :: t2
   end type
   class(t), allocatable :: x
   associate (y => (x))  ! The parentheses triggered an ICE in select type
      select type (y)
      type is (t2)
          print *, "is T2"
          stop 1
      type is (t)
          print *, "is T"
      class default
          stop 2
      end select
   end associate
end

[-- Attachment #9: pr102106.f90 --]
[-- Type: application/octet-stream, Size: 412 bytes --]

! { dg-do run }
!
! Contributed by Brad Richardson  <everythingfunctional@protonmail.com>
!
program main
    type :: sub_class_t
        integer :: i
    end type

    type :: with_polymorphic_component_t
        class(sub_class_t), allocatable :: sub_obj_
    end type

    associate(obj => with_polymorphic_component_t(sub_class_t(42)))
        if (obj%sub_obj_%i .ne. 42) stop 1
    end associate
end program

[-- Attachment #10: pr106918.f90 --]
[-- Type: application/octet-stream, Size: 469 bytes --]

! { dg-do run }
!
! Contributed by Lionel Guez  <guez@lmd.ens.fr>
!
  character(len = :), allocatable:: attr_name(:)
  character(6) :: buffer
  type coord_def
     character(len = :), allocatable:: attr_name(:)
  end type coord_def
  type(coord_def) coordinates
  attr_name = ["units"]
  write (buffer, *) attr_name
  if (buffer .ne. " units") stop 1
  coordinates = coord_def(attr_name)
  write (buffer, *) coordinates%attr_name
  if (buffer .ne. " units") stop 2
end

[-- Attachment #11: pr105205.f90 --]
[-- Type: application/octet-stream, Size: 566 bytes --]

! { dg-do run }
!
! Contributed by Rich Townsend  <townsend@astro.wisc.edu>
!
program alloc_char_type
   implicit none
   integer, parameter :: start = 1, finish = 4
   character(3) :: check(4)
   type mytype
      character(:), allocatable :: c(:)
   end type mytype
   type(mytype) :: a
   type(mytype) :: b
   integer :: i
   a%c = ['foo','bar','biz','buz
   check = ['foo','bar','biz','buz']
   b = a
   do i = 1, size(b%c)
      if (b%c(i) .ne. check(i)) stop1
   end do
   if (any (a%c .ne. check)) stop 2
   if (any (a%c(start:finish) .ne. check)) stop 3
end

[-- Attachment #12: pr100948.f90 --]
[-- Type: text/x-fortran, Size: 637 bytes --]

! { dg-do-run }
!
! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
!
program p
   type t
      character(:), allocatable :: c(:)
   end type
   type(t), allocatable :: x
!
! Valid test in comment 1
!
   x = t(['ab','cd'])
   associate (y => x%c(:))
      if (any (y .ne. x%c)) stop 1
      if (any (y .ne. ['ab','cd'])) stop 2
   end associate
   deallocate (x)
!
! Allocation with source was found to only copy over one of the array elements
!
   allocate (x, source = t(['ef','gh']))
   associate (y => x%c(:))
      if (any (y .ne. x%c)) stop 3
      if (any (y .ne. ['ef','gh'])) stop 4
   end associate
   deallocate (x)
end

^ permalink raw reply	[flat|nested] 8+ messages in thread
end of thread, other threads:[~2023-06-02  7:46 UTC | newest]

Thread overview: 8+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-06-01 15:20 [Patch, fortran] PR87477 - [meta-bug] [F03] issues concerning the ASSOCIATE statement Paul Richard Thomas
2023-06-01 17:58 ` Mikael Morin
2023-06-02  7:46   ` Paul Richard Thomas
  -- strict thread matches above, loose matches on Subject: below --
2023-03-28 21:04 Paul Richard Thomas
2023-03-29  8:24 ` Manfred Schwarb
2023-03-29  8:53   ` Paul Richard Thomas
2023-04-07  7:02     ` Paul Richard Thomas
2023-04-07  9:40       ` Harald Anlauf

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).