gcc/testsuite/gfortran.dg/elemental_optional_args_2.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/50981
   4 ! The program used to dereference a NULL pointer when trying to access
   5 ! an optional dummy argument to be passed to an elemental subprocedure.
   6 !
   7 ! Original testcase from Andriy Kostyuk <kostyuk@fias.uni-frankfurt.de>
   8
   9 PROGRAM test
  10   IMPLICIT NONE
  11   REAL(KIND=8), DIMENSION(2) :: aa, rr
  12
  13   aa(1)=10.
  14   aa(2)=11.
  15
  16
  17   ! WRITE(*,*) 'Both f1 and ff work if the optional parameter is present:'
  18
  19   rr=f1(aa,1)
  20   ! WRITE(*,*) ' rr(1)=', rr(1), '  rr(2)=', rr(2)
  21   IF (ANY(rr /= (/ 110, 132 /))) STOP 1
  22
  23   rr=0
  24   rr=ff(aa,1)
  25   ! WRITE(*,*) ' rr(1)=', rr(1), '  rr(2)=', rr(2)
  26   IF (ANY(rr /= (/ 110, 132 /))) STOP 2
  27
  28
  29   ! WRITE(*,*) 'But only f1 works if the optional parameter is absent:'
  30
  31   rr=0
  32   rr=f1(aa)
  33   ! WRITE(*,*) ' rr(1)=', rr(1), '  rr(2)=', rr(2)
  34   IF (ANY(rr /= (/ 110, 132 /))) STOP 3
  35
  36   rr = 0
  37   rr=ff(aa)
  38   ! WRITE(*,*) ' rr(1)=', rr(1), '  rr(2)=', rr(2)
  39   IF (ANY(rr /= (/ 110, 132 /))) STOP 4
  40
  41
  42 CONTAINS
  43
  44     ELEMENTAL REAL(KIND=8) FUNCTION ff(a,b)
  45       IMPLICIT NONE
  46       REAL(KIND=8), INTENT(IN) :: a
  47       INTEGER, INTENT(IN), OPTIONAL :: b
  48       REAL(KIND=8), DIMENSION(2) :: ac
  49       ac(1)=a
  50       ac(2)=a**2
  51       ff=SUM(gg(ac,b))
  52     END FUNCTION ff
  53
  54     ELEMENTAL REAL(KIND=8) FUNCTION f1(a,b)
  55       IMPLICIT NONE
  56       REAL(KIND=8), INTENT(IN) :: a
  57       INTEGER, INTENT(IN), OPTIONAL :: b
  58       REAL(KIND=8), DIMENSION(2) :: ac
  59       ac(1)=a
  60       ac(2)=a**2
  61       f1=gg(ac(1),b)+gg(ac(2),b) ! This is the same as in ff, but without using the elemental feature of gg
  62     END FUNCTION f1
  63
  64     ELEMENTAL REAL(KIND=8) FUNCTION gg(a,b)
  65       IMPLICIT NONE
  66       REAL(KIND=8), INTENT(IN) :: a
  67       INTEGER, INTENT(IN), OPTIONAL :: b
  68       INTEGER ::b1
  69       IF(PRESENT(b)) THEN
  70         b1=b
  71       ELSE
  72         b1=1
  73       ENDIF
  74       gg=a**b1
  75     END FUNCTION gg
  76
  77
  78 END PROGRAM test
  79
  80