f95-lang.c (gfc_get_alias_set): New function.

	* f95-lang.c (gfc_get_alias_set): New function.
	(LANG_HOOKS_GET_ALIAS_SET): Define.

	* gfortran.fortran-torture/execute/equiv_5.f: New test.

From-SVN: r112416

4 files changed, 255 insertions, 0 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index e5245db..b6e4cae 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,8 @@
+2006-03-27  Jakub Jelinek  <jakub@redhat.com>
+
+	* f95-lang.c (gfc_get_alias_set): New function.
+	(LANG_HOOKS_GET_ALIAS_SET): Define.
+
 2006-03-25  Steven G. Kargl  <kargls@comcast.net>
 
 	PR fortran/26816
diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c
index 6722117..7257924 100644
--- a/gcc/fortran/f95-lang.c
+++ b/gcc/fortran/f95-lang.c
@@ -99,6 +99,7 @@ void insert_block (tree);
 static void gfc_clear_binding_stack (void);
 static void gfc_be_parse_file (int);
 static void gfc_expand_function (tree);
+static HOST_WIDE_INT gfc_get_alias_set (tree);
 
 #undef LANG_HOOKS_NAME
 #undef LANG_HOOKS_INIT
@@ -116,6 +117,7 @@ static void gfc_expand_function (tree);
 #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
 #undef LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION
 #undef LANG_HOOKS_CLEAR_BINDING_STACK
+#undef LANG_HOOKS_GET_ALIAS_SET
 #undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE
 #undef LANG_HOOKS_OMP_PREDETERMINED_SHARING
 #undef LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR
@@ -139,6 +141,7 @@ static void gfc_expand_function (tree);
 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE gfc_signed_or_unsigned_type
 #define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION gfc_expand_function
 #define LANG_HOOKS_CLEAR_BINDING_STACK     gfc_clear_binding_stack
+#define LANG_HOOKS_GET_ALIAS_SET	   gfc_get_alias_set
 #define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE	gfc_omp_privatize_by_reference
 #define LANG_HOOKS_OMP_PREDETERMINED_SHARING	gfc_omp_predetermined_sharing
 #define LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR	gfc_omp_disregard_value_expr
@@ -694,6 +697,24 @@ gfc_mark_addressable (tree exp)
       }
 }
 
+/* Return the typed-based alias set for T, which may be an expression
+   or a type.  Return -1 if we don't do anything special.  */
+
+static HOST_WIDE_INT
+gfc_get_alias_set (tree t)
+{
+  tree u;
+
+  /* Permit type-punning when accessing an EQUIVALENCEd variable or
+     mixed type entry master's return value.  */
+  for (u = t; handled_component_p (u); u = TREE_OPERAND (u, 0))
+    if (TREE_CODE (u) == COMPONENT_REF
+	&& TREE_CODE (TREE_TYPE (TREE_OPERAND (u, 0))) == UNION_TYPE)
+      return 0;
+
+  return -1;
+}
+
 /* press the big red button - garbage (ggc) collection is on */
 
 int ggc_p = 1;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 2d03afb..2358532 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2006-03-27  Jakub Jelinek  <jakub@redhat.com>
+
+	* gfortran.fortran-torture/execute/equiv_5.f: New test.
+
 2006-03-26  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR libgfortran/26661
diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/equiv_5.f b/gcc/testsuite/gfortran.fortran-torture/execute/equiv_5.f
new file mode 100644
index 0000000..b20797e
--- /dev/null
+++ b/gcc/testsuite/gfortran.fortran-torture/execute/equiv_5.f
@@ -0,0 +1,225 @@
+C  This testcase was miscompiled on i?86/x86_64, the scheduler
+C  swapped write to DMACH(1) with following read from SMALL(1),
+C  at -O2+, as the front-end didn't signal in any way this kind
+C  of type punning is ok.
+C  The testcase is from blas, http://www.netlib.org/blas/d1mach.f
+
+      DOUBLE PRECISION FUNCTION D1MACH(I)
+      INTEGER I
+C
+C  DOUBLE-PRECISION MACHINE CONSTANTS
+C  D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
+C  D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
+C  D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING.
+C  D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING.
+C  D1MACH( 5) = LOG10(B)
+C
+      INTEGER SMALL(2)
+      INTEGER LARGE(2)
+      INTEGER RIGHT(2)
+      INTEGER DIVER(2)
+      INTEGER LOG10(2)
+      INTEGER SC, CRAY1(38), J
+      COMMON /D9MACH/ CRAY1
+      SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC
+      DOUBLE PRECISION DMACH(5)
+      EQUIVALENCE (DMACH(1),SMALL(1))
+      EQUIVALENCE (DMACH(2),LARGE(1))
+      EQUIVALENCE (DMACH(3),RIGHT(1))
+      EQUIVALENCE (DMACH(4),DIVER(1))
+      EQUIVALENCE (DMACH(5),LOG10(1))
+C  THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES.
+C  R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF
+C  D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR
+C  MANY MACHINES YET.
+C  TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
+C  ON THE NEXT LINE
+      DATA SC/0/
+C  AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
+C  CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
+C          mail netlib@research.bell-labs.com
+C          send old1mach from blas
+C  PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
+C
+C     MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
+C      DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 /
+C      DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 /
+C      DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 /
+C      DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 /
+C      DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/
+C
+C     MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
+C     32-BIT INTEGERS.
+C      DATA SMALL(1),SMALL(2) /    8388608,           0 /
+C      DATA LARGE(1),LARGE(2) / 2147483647,          -1 /
+C      DATA RIGHT(1),RIGHT(2) /  612368384,           0 /
+C      DATA DIVER(1),DIVER(2) /  620756992,           0 /
+C      DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/
+C
+C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
+C      DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 /
+C      DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 /
+C      DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 /
+C      DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 /
+C      DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/
+C
+C     ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES.
+      IF (SC .NE. 987) THEN
+         DMACH(1) = 1.D13
+         IF (      SMALL(1) .EQ. 1117925532
+     *       .AND. SMALL(2) .EQ. -448790528) THEN
+*           *** IEEE BIG ENDIAN ***
+            SMALL(1) = 1048576
+            SMALL(2) = 0
+            LARGE(1) = 2146435071
+            LARGE(2) = -1
+            RIGHT(1) = 1017118720
+            RIGHT(2) = 0
+            DIVER(1) = 1018167296
+            DIVER(2) = 0
+            LOG10(1) = 1070810131
+            LOG10(2) = 1352628735
+         ELSE IF ( SMALL(2) .EQ. 1117925532
+     *       .AND. SMALL(1) .EQ. -448790528) THEN
+*           *** IEEE LITTLE ENDIAN ***
+            SMALL(2) = 1048576
+            SMALL(1) = 0
+            LARGE(2) = 2146435071
+            LARGE(1) = -1
+            RIGHT(2) = 1017118720
+            RIGHT(1) = 0
+            DIVER(2) = 1018167296
+            DIVER(1) = 0
+            LOG10(2) = 1070810131
+            LOG10(1) = 1352628735
+         ELSE IF ( SMALL(1) .EQ. -2065213935
+     *       .AND. SMALL(2) .EQ. 10752) THEN
+*               *** VAX WITH D_FLOATING ***
+            SMALL(1) = 128
+            SMALL(2) = 0
+            LARGE(1) = -32769
+            LARGE(2) = -1
+            RIGHT(1) = 9344
+            RIGHT(2) = 0
+            DIVER(1) = 9472
+            DIVER(2) = 0
+            LOG10(1) = 546979738
+            LOG10(2) = -805796613
+         ELSE IF ( SMALL(1) .EQ. 1267827943
+     *       .AND. SMALL(2) .EQ. 704643072) THEN
+*               *** IBM MAINFRAME ***
+            SMALL(1) = 1048576
+            SMALL(2) = 0
+            LARGE(1) = 2147483647
+            LARGE(2) = -1
+            RIGHT(1) = 856686592
+            RIGHT(2) = 0
+            DIVER(1) = 873463808
+            DIVER(2) = 0
+            LOG10(1) = 1091781651
+            LOG10(2) = 1352628735
+         ELSE IF ( SMALL(1) .EQ. 1120022684
+     *       .AND. SMALL(2) .EQ. -448790528) THEN
+*           *** CONVEX C-1 ***
+            SMALL(1) = 1048576
+            SMALL(2) = 0
+            LARGE(1) = 2147483647
+            LARGE(2) = -1
+            RIGHT(1) = 1019215872
+            RIGHT(2) = 0
+            DIVER(1) = 1020264448
+            DIVER(2) = 0
+            LOG10(1) = 1072907283
+            LOG10(2) = 1352628735
+         ELSE IF ( SMALL(1) .EQ. 815547074
+     *       .AND. SMALL(2) .EQ. 58688) THEN
+*           *** VAX G-FLOATING ***
+            SMALL(1) = 16
+            SMALL(2) = 0
+            LARGE(1) = -32769
+            LARGE(2) = -1
+            RIGHT(1) = 15552
+            RIGHT(2) = 0
+            DIVER(1) = 15568
+            DIVER(2) = 0
+            LOG10(1) = 1142112243
+            LOG10(2) = 2046775455
+         ELSE
+            DMACH(2) = 1.D27 + 1
+            DMACH(3) = 1.D27
+            LARGE(2) = LARGE(2) - RIGHT(2)
+            IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN
+               CRAY1(1) = 67291416
+               DO 10 J = 1, 20
+                  CRAY1(J+1) = CRAY1(J) + CRAY1(J)
+ 10               CONTINUE
+               CRAY1(22) = CRAY1(21) + 321322
+               DO 20 J = 22, 37
+                  CRAY1(J+1) = CRAY1(J) + CRAY1(J)
+ 20               CONTINUE
+               IF (CRAY1(38) .EQ. SMALL(1)) THEN
+*                  *** CRAY ***
+                  CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0)
+                  SMALL(2) = 0
+                  CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215)
+                  CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214)
+                  CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0)
+                  RIGHT(2) = 0
+                  CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0)
+                  DIVER(2) = 0
+                  CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215)
+                  CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388)
+               ELSE
+                  WRITE(*,9000)
+                  STOP 779
+                  END IF
+            ELSE
+               WRITE(*,9000)
+               STOP 779
+               END IF
+            END IF
+         SC = 987
+         END IF
+*    SANITY CHECK
+      IF (DMACH(4) .GE. 1.0D0) STOP 778
+      IF (I .LT. 1 .OR. I .GT. 5) THEN
+         WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.'
+         STOP
+         END IF
+      D1MACH = DMACH(I)
+      RETURN
+ 9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/
+     *' appropriate for your machine.')
+* /* Standard C source for D1MACH -- remove the * in column 1 */
+*#include <stdio.h>
+*#include <float.h>
+*#include <math.h>
+*double d1mach_(long *i)
+*{
+*	switch(*i){
+*	  case 1: return DBL_MIN;
+*	  case 2: return DBL_MAX;
+*	  case 3: return DBL_EPSILON/FLT_RADIX;
+*	  case 4: return DBL_EPSILON;
+*	  case 5: return log10((double)FLT_RADIX);
+*	  }
+*	fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i);
+*	exit(1); return 0; /* some compilers demand return values */
+*}
+      END
+      SUBROUTINE I1MCRY(A, A1, B, C, D)
+**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES ****
+      INTEGER A, A1, B, C, D
+      A1 = 16777216*B + C
+      A = 16777216*A1 + D
+      END
+
+      PROGRAM MAIN
+      DOUBLE PRECISION D1MACH
+      EXTERNAL D1MACH
+      PRINT *,D1MACH(1)
+      PRINT *,D1MACH(2)
+      PRINT *,D1MACH(3)
+      PRINT *,D1MACH(4)
+      PRINT *,D1MACH(5)
+      END