re PR fortran/38936 ([F03] ASSOCIATE construct / improved SELECT TYPE (a=>expr))

2010-08-17  Daniel Kraft  <d@domob.eu>

	PR fortran/38936
	* gfortran.h (struct gfc_association_list): New member `where'.
	(gfc_is_associate_pointer) New method.
	* match.c (gfc_match_associate): Remember locus for each associate
	name matched and do not try to set variable flag.
	* parse.c (parse_associate): Use remembered locus for symbols.
	* primary.c (match_variable): Instead of variable-flag check for
	associate names set it for all such names used.
	* symbol.c (gfc_is_associate_pointer): New method.
	* resolve.c (resolve_block_construct): Don't generate assignments
	to give associate-names their values.
	(resolve_fl_var_and_proc): Allow associate-names to be deferred-shape.
	(resolve_symbol): Set some more attributes for associate variables,
	set variable flag here and check it and don't try to build an
	explicitely shaped array-spec for array associate variables.
	* trans-expr.c (gfc_conv_variable): Dereference in case of association
	to scalar variable.
	* trans-types.c (gfc_is_nodesc_array): Handle array association symbols.
	(gfc_sym_type): Return pointer type for association to scalar vars.
	* trans-decl.c (gfc_get_symbol_decl): Defer association symbols.
	(trans_associate_var): New method.
	(gfc_trans_deferred_vars): Handle association symbols.

2010-08-17  Daniel Kraft  <d@domob.eu>

	PR fortran/38936
	* gfortran.dg/associate_1.f03: Extended to test newly supported
	features like association to variables.
	* gfortran.dg/associate_3.f03: Removed check for illegal change
	of associate-name here...
	* gfortran.dg/associate_5.f03: ...and added it here.
	* gfortran.dg/associate_6.f03: No longer XFAIL'ed.
	* gfortran.dg/associate_7.f03: New test.

From-SVN: r163295

6 files changed, 107 insertions, 11 deletions

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c42c1b2d5b7..760b5f1259f 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,14 @@
+2010-08-17  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/38936
+	* gfortran.dg/associate_1.f03: Extended to test newly supported
+	features like association to variables.
+	* gfortran.dg/associate_3.f03: Removed check for illegal change
+	of associate-name here...
+	* gfortran.dg/associate_5.f03: ...and added it here.
+	* gfortran.dg/associate_6.f03: No longer XFAIL'ed.
+	* gfortran.dg/associate_7.f03: New test.
+
 2010-08-15  Kaz Kojima  <kkojima@gcc.gnu.org>
 
 	* gcc.dg/tree-ssa/pr42585.c: Skip dump scan on sh.
diff --git a/gcc/testsuite/gfortran.dg/associate_1.f03 b/gcc/testsuite/gfortran.dg/associate_1.f03
index 0b3081b241b..4cb727f0b5a 100644
--- a/gcc/testsuite/gfortran.dg/associate_1.f03
+++ b/gcc/testsuite/gfortran.dg/associate_1.f03
@@ -1,5 +1,5 @@
 ! { dg-do run }
-! { dg-options "-std=f2003 -fall-intrinsics" }
+! { dg-options "-std=f2003 -fall-intrinsics -cpp" }
 
 ! PR fortran/38936
 ! Check the basic semantics of the ASSOCIATE construct.
@@ -8,6 +8,13 @@ PROGRAM main
   IMPLICIT NONE
   REAL :: a, b, c
   INTEGER, ALLOCATABLE :: arr(:)
+  INTEGER :: mat(3, 3)
+
+  TYPE :: myt
+    INTEGER :: comp
+  END TYPE myt
+
+  TYPE(myt) :: tp
 
   a = -2.0
   b = 3.0
@@ -20,9 +27,6 @@ PROGRAM main
     IF (ABS (t - a - b) > 1.0e-3) CALL abort ()
   END ASSOCIATE
 
-  ! TODO: Test association to variables when that is supported.
-  ! TODO: Test association to derived types.
-
   ! Test association to arrays.
   ALLOCATE (arr(3))
   arr = (/ 1, 2, 3 /)
@@ -34,6 +38,12 @@ PROGRAM main
     IF (ANY (xyz /= (/ 1, 3, 5 /))) CALL abort ()
   END ASSOCIATE
 
+  ! Target is vector-indexed.
+  ASSOCIATE (foo => arr((/ 3, 1 /)))
+    IF (LBOUND (foo, 1) /= 1 .OR. UBOUND (foo, 1) /= 2) CALL abort ()
+    IF (foo(1) /= 3 .OR. foo(2) /= 1) CALL abort ()
+  END ASSOCIATE
+
   ! Named and nested associate.
   myname: ASSOCIATE (x => a - b * c)
     ASSOCIATE (y => 2.0 * x)
@@ -49,6 +59,33 @@ PROGRAM main
     END ASSOCIATE
   END ASSOCIATE
 
+  ! Association to variables.
+  mat = 0
+  mat(2, 2) = 5;
+  ASSOCIATE (x => arr(2), y => mat(2:3, 1:2))
+    IF (x /= 2) CALL abort ()
+    IF (ANY (LBOUND (y) /= (/ 1, 1 /) .OR. UBOUND (y) /= (/ 2, 2 /))) &
+      CALL abort ()
+    IF (y(1, 2) /= 5) CALL abort ()
+
+    x = 7
+    y = 8
+  END ASSOCIATE
+  IF (arr(2) /= 7 .OR. ANY (mat(2:3, 1:2) /= 8)) CALL abort ()
+
+  ! Association to derived type and component.
+  tp = myt (1)
+  ASSOCIATE (x => tp, y => tp%comp)
+    ! FIXME: Parsing of derived-type associate names, tests with x.
+    IF (y /= 1) CALL abort ()
+    y = 5
+  END ASSOCIATE
+  IF (tp%comp /= 5) CALL abort ()
+
+  ! Association to character variables.
+  ! FIXME: Enable character test, once this works.
+  !CALL test_char (5)
+
 CONTAINS
 
   FUNCTION func ()
@@ -56,4 +93,21 @@ CONTAINS
     func = (/ 1, 3, 5 /)
   END FUNCTION func
 
+#if 0
+  ! Test association to character variable with automatic length.
+  SUBROUTINE test_char (n)
+    INTEGER, INTENT(IN) :: n
+
+    CHARACTER(LEN=n) :: str
+
+    str = "foobar"
+    ASSOCIATE (my => str)
+      IF (LEN (my) /= n) CALL abort ()
+      IF (my /= "fooba") CALL abort ()
+      my = "abcdef"
+    END ASSOCIATE
+    IF (str /= "abcde") CALL abort ()
+  END SUBROUTINE test_char
+#endif
+
 END PROGRAM main
diff --git a/gcc/testsuite/gfortran.dg/associate_3.f03 b/gcc/testsuite/gfortran.dg/associate_3.f03
index f8a49052a1a..20a375dcfd1 100644
--- a/gcc/testsuite/gfortran.dg/associate_3.f03
+++ b/gcc/testsuite/gfortran.dg/associate_3.f03
@@ -31,10 +31,6 @@ PROGRAM main
   ASSOCIATE (a => 1, b => 2, a => 3) ! { dg-error "Duplicate name 'a'" }
 
   ASSOCIATE (a => 5)
-    a = 4 ! { dg-error "variable definition context" }
-  ENd ASSOCIATE
-
-  ASSOCIATE (a => 5)
     INTEGER :: b ! { dg-error "Unexpected data declaration statement" }
   END ASSOCIATE
 END PROGRAM main ! { dg-error "Expecting END ASSOCIATE" }
diff --git a/gcc/testsuite/gfortran.dg/associate_5.f03 b/gcc/testsuite/gfortran.dg/associate_5.f03
index ca62f944545..31cc144d5a9 100644
--- a/gcc/testsuite/gfortran.dg/associate_5.f03
+++ b/gcc/testsuite/gfortran.dg/associate_5.f03
@@ -6,8 +6,21 @@
 
 PROGRAM main
   IMPLICIT NONE
+  INTEGER :: nontarget
+  INTEGER :: arr(3)
+  INTEGER, POINTER :: ptr
 
   ASSOCIATE (a => 5) ! { dg-error "is used as array" }
     PRINT *, a(3)
   END ASSOCIATE
+
+  ASSOCIATE (a => nontarget)
+    ptr => a ! { dg-error "neither TARGET nor POINTER" }
+  END ASSOCIATE
+
+  ASSOCIATE (a => 5, & ! { dg-error "variable definition context" }
+             b => arr((/ 1, 3 /))) ! { dg-error "variable definition context" }
+    a = 4
+    b = 7
+  END ASSOCIATE
 END PROGRAM main
diff --git a/gcc/testsuite/gfortran.dg/associate_6.f03 b/gcc/testsuite/gfortran.dg/associate_6.f03
index bf30fa3f7cb..ba0e5c09809 100644
--- a/gcc/testsuite/gfortran.dg/associate_6.f03
+++ b/gcc/testsuite/gfortran.dg/associate_6.f03
@@ -7,8 +7,6 @@
 
 ! Contributed by Daniel Kraft, d@domob.eu.
 
-! FIXME: XFAIL'ed because this is not yet implemented 'correctly'.
-
 MODULE m
   IMPLICIT NONE
 
@@ -31,8 +29,11 @@ PROGRAM main
 
   ASSOCIATE (arr => func (4))
     ! func should only be called once here, not again for the bounds!
+
+    IF (LBOUND (arr, 1) /= 1 .OR. UBOUND (arr, 1) /= 4) CALL abort ()
+    IF (arr(1) /= 1 .OR. arr(4) /= 4) CALL abort ()
   END ASSOCIATE
 END PROGRAM main
 ! { dg-final { cleanup-modules "m" } }
-! { dg-final { scan-tree-dump-times "func" 2 "original" { xfail *-*-* } } }
+! { dg-final { scan-tree-dump-times "func" 2 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/associate_7.f03 b/gcc/testsuite/gfortran.dg/associate_7.f03
new file mode 100644
index 00000000000..6fd3f343d00
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_7.f03
@@ -0,0 +1,21 @@
+! { dg-do run }
+! { dg-options "-std=f2003 -fall-intrinsics" }
+
+! PR fortran/38936
+! Check association and pointers.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+PROGRAM main
+  IMPLICIT NONE
+  INTEGER, TARGET :: tgt
+  INTEGER, POINTER :: ptr
+
+  tgt = 1
+  ASSOCIATE (x => tgt)
+    ptr => x
+    IF (ptr /= 1) CALL abort ()
+    ptr = 2
+  END ASSOCIATE
+  IF (tgt /= 2) CALL abort ()
+END PROGRAM main