gcc/testsuite/gfortran.fortran-torture/execute/equiv_5.f

   1 C  This testcase was miscompiled on i?86/x86_64, the scheduler
   2 C  swapped write to DMACH(1) with following read from SMALL(1),
   3 C  at -O2+, as the front-end didn't signal in any way this kind
   4 C  of type punning is ok.
   5 C  The testcase is from blas, http://www.netlib.org/blas/d1mach.f
   6
   7       DOUBLE PRECISION FUNCTION D1MACH(I)
   8       INTEGER*4 I
   9 C
  10 C  DOUBLE-PRECISION MACHINE CONSTANTS
  11 C  D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
  12 C  D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
  13 C  D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING.
  14 C  D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING.
  15 C  D1MACH( 5) = LOG10(B)
  16 C
  17       INTEGER*4 SMALL(2)
  18       INTEGER*4 LARGE(2)
  19       INTEGER*4 RIGHT(2)
  20       INTEGER*4 DIVER(2)
  21       INTEGER*4 LOG10(2)
  22       INTEGER*4 SC, CRAY1(38), J
  23       COMMON /D9MACH/ CRAY1
  24       SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC
  25       DOUBLE PRECISION DMACH(5)
  26       EQUIVALENCE (DMACH(1),SMALL(1))
  27       EQUIVALENCE (DMACH(2),LARGE(1))
  28       EQUIVALENCE (DMACH(3),RIGHT(1))
  29       EQUIVALENCE (DMACH(4),DIVER(1))
  30       EQUIVALENCE (DMACH(5),LOG10(1))
  31 C  THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES.
  32 C  R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF
  33 C  D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR
  34 C  MANY MACHINES YET.
  35 C  TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
  36 C  ON THE NEXT LINE
  37       DATA SC/0/
  38 C  AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
  39 C  CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
  40 C          mail netlib@research.bell-labs.com
  41 C          send old1mach from blas
  42 C  PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
  43 C
  44 C     MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
  45 C      DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 /
  46 C      DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 /
  47 C      DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 /
  48 C      DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 /
  49 C      DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/
  50 C
  51 C     MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
  52 C     32-BIT INTEGER*4S.
  53 C      DATA SMALL(1),SMALL(2) /    8388608,           0 /
  54 C      DATA LARGE(1),LARGE(2) / 2147483647,          -1 /
  55 C      DATA RIGHT(1),RIGHT(2) /  612368384,           0 /
  56 C      DATA DIVER(1),DIVER(2) /  620756992,           0 /
  57 C      DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/
  58 C
  59 C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
  60 C      DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 /
  61 C      DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 /
  62 C      DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 /
  63 C      DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 /
  64 C      DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/
  65 C
  66 C     ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES.
  67       IF (SC .NE. 987) THEN
  68          DMACH(1) = 1.D13
  69          IF (      SMALL(1) .EQ. 1117925532
  70      *       .AND. SMALL(2) .EQ. -448790528) THEN
  71 *           *** IEEE BIG ENDIAN ***
  72             SMALL(1) = 1048576
  73             SMALL(2) = 0
  74             LARGE(1) = 2146435071
  75             LARGE(2) = -1
  76             RIGHT(1) = 1017118720
  77             RIGHT(2) = 0
  78             DIVER(1) = 1018167296
  79             DIVER(2) = 0
  80             LOG10(1) = 1070810131
  81             LOG10(2) = 1352628735
  82          ELSE IF ( SMALL(2) .EQ. 1117925532
  83      *       .AND. SMALL(1) .EQ. -448790528) THEN
  84 *           *** IEEE LITTLE ENDIAN ***
  85             SMALL(2) = 1048576
  86             SMALL(1) = 0
  87             LARGE(2) = 2146435071
  88             LARGE(1) = -1
  89             RIGHT(2) = 1017118720
  90             RIGHT(1) = 0
  91             DIVER(2) = 1018167296
  92             DIVER(1) = 0
  93             LOG10(2) = 1070810131
  94             LOG10(1) = 1352628735
  95          ELSE IF ( SMALL(1) .EQ. -2065213935
  96      *       .AND. SMALL(2) .EQ. 10752) THEN
  97 *               *** VAX WITH D_FLOATING ***
  98             SMALL(1) = 128
  99             SMALL(2) = 0
 100             LARGE(1) = -32769
 101             LARGE(2) = -1
 102             RIGHT(1) = 9344
 103             RIGHT(2) = 0
 104             DIVER(1) = 9472
 105             DIVER(2) = 0
 106             LOG10(1) = 546979738
 107             LOG10(2) = -805796613
 108          ELSE IF ( SMALL(1) .EQ. 1267827943
 109      *       .AND. SMALL(2) .EQ. 704643072) THEN
 110 *               *** IBM MAINFRAME ***
 111             SMALL(1) = 1048576
 112             SMALL(2) = 0
 113             LARGE(1) = 2147483647
 114             LARGE(2) = -1
 115             RIGHT(1) = 856686592
 116             RIGHT(2) = 0
 117             DIVER(1) = 873463808
 118             DIVER(2) = 0
 119             LOG10(1) = 1091781651
 120             LOG10(2) = 1352628735
 121          ELSE IF ( SMALL(1) .EQ. 1120022684
 122      *       .AND. SMALL(2) .EQ. -448790528) THEN
 123 *           *** CONVEX C-1 ***
 124             SMALL(1) = 1048576
 125             SMALL(2) = 0
 126             LARGE(1) = 2147483647
 127             LARGE(2) = -1
 128             RIGHT(1) = 1019215872
 129             RIGHT(2) = 0
 130             DIVER(1) = 1020264448
 131             DIVER(2) = 0
 132             LOG10(1) = 1072907283
 133             LOG10(2) = 1352628735
 134          ELSE IF ( SMALL(1) .EQ. 815547074
 135      *       .AND. SMALL(2) .EQ. 58688) THEN
 136 *           *** VAX G-FLOATING ***
 137             SMALL(1) = 16
 138             SMALL(2) = 0
 139             LARGE(1) = -32769
 140             LARGE(2) = -1
 141             RIGHT(1) = 15552
 142             RIGHT(2) = 0
 143             DIVER(1) = 15568
 144             DIVER(2) = 0
 145             LOG10(1) = 1142112243
 146             LOG10(2) = 2046775455
 147          ELSE
 148             DMACH(2) = 1.D27 + 1
 149             DMACH(3) = 1.D27
 150             LARGE(2) = LARGE(2) - RIGHT(2)
 151             IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN
 152                CRAY1(1) = 67291416
 153                DO 10 J = 1, 20
 154                   CRAY1(J+1) = CRAY1(J) + CRAY1(J)
 155  10               CONTINUE
 156                CRAY1(22) = CRAY1(21) + 321322
 157                DO 20 J = 22, 37
 158                   CRAY1(J+1) = CRAY1(J) + CRAY1(J)
 159  20               CONTINUE
 160                IF (CRAY1(38) .EQ. SMALL(1)) THEN
 161 *                  *** CRAY ***
 162                   CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0)
 163                   SMALL(2) = 0
 164                   CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215)
 165                   CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214)
 166                   CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0)
 167                   RIGHT(2) = 0
 168                   CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0)
 169                   DIVER(2) = 0
 170                   CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215)
 171                   CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388)
 172                ELSE
 173                   WRITE(*,9000)
 174                   STOP 779
 175                   END IF
 176             ELSE
 177                WRITE(*,9000)
 178                STOP 779
 179                END IF
 180             END IF
 181          SC = 987
 182          END IF
 183 *    SANITY CHECK
 184       IF (DMACH(4) .GE. 1.0D0) STOP 778
 185       IF (I .LT. 1 .OR. I .GT. 5) THEN
 186          WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.'
 187          STOP
 188          END IF
 189       D1MACH = DMACH(I)
 190       RETURN
 191  9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/
 192      *' appropriate for your machine.')
 193 * /* Standard C source for D1MACH -- remove the * in column 1 */
 194 *#include <stdio.h>
 195 *#include <float.h>
 196 *#include <math.h>
 197 *double d1mach_(long *i)
 198 *{
 199 *       switch(*i){
 200 *         case 1: return DBL_MIN;
 201 *         case 2: return DBL_MAX;
 202 *         case 3: return DBL_EPSILON/FLT_RADIX;
 203 *         case 4: return DBL_EPSILON;
 204 *         case 5: return log10((double)FLT_RADIX);
 205 *         }
 206 *       fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i);
 207 *       exit(1); return 0; /* some compilers demand return values */
 208 *}
 209       END
 210       SUBROUTINE I1MCRY(A, A1, B, C, D)
 211 **** SPECIAL COMPUTATION FOR OLD CRAY MACHINES ****
 212       INTEGER*4 A, A1, B, C, D
 213       A1 = 16777216*B + C
 214       A = 16777216*A1 + D
 215       END
 216
 217       PROGRAM MAIN
 218       DOUBLE PRECISION D1MACH
 219       EXTERNAL D1MACH
 220       PRINT *,D1MACH(1)
 221       PRINT *,D1MACH(2)
 222       PRINT *,D1MACH(3)
 223       PRINT *,D1MACH(4)
 224       PRINT *,D1MACH(5)
 225       END