gcc/testsuite/gfortran.dg/assumed_charlen_function_1.f90

   1 ! { dg-do compile }
   2 ! { dg-options "-std=legacy" }
   3 ! Tests the patch for PRs 25084, 20852, 25085 and 25086, all of
   4 ! which involve assumed character length functions.
   5 ! Compiled from original PR testcases, which were all contributed
   6 ! by Joost VandeVondele  <jv244@cam.ac.uk>
   7 !
   8 ! PR25084 - the error is not here but in any use of .IN.
   9 ! It is OK to define an assumed character length function
  10 ! in an interface but it cannot be invoked (5.1.1.5).
  11
  12 MODULE M1
  13  TYPE  SET
  14   INTEGER  CARD
  15  END  TYPE  SET
  16 END MODULE M1
  17
  18 MODULE  INTEGER_SETS
  19  INTERFACE  OPERATOR  (.IN.)
  20   FUNCTION ELEMENT(X,A) ! { dg-error "cannot be assumed character length" }
  21      USE M1
  22      CHARACTER(LEN=*)      :: ELEMENT
  23      INTEGER, INTENT(IN)   ::  X
  24      TYPE(SET), INTENT(IN) ::   A
  25   END FUNCTION ELEMENT
  26  END  INTERFACE
  27 END MODULE
  28
  29 ! 5.1.1.5 of the Standard: A function name declared with an asterisk
  30 ! char-len-param shall not be array-valued, pointer-valued, recursive
  31 ! or pure
  32 !
  33 ! PR20852
  34 RECURSIVE FUNCTION TEST() ! { dg-error "cannot be recursive" }
  35  CHARACTER(LEN=*) :: TEST
  36  TEST = ""
  37 END FUNCTION
  38
  39 !PR25085
  40 FUNCTION F1()             ! { dg-error "cannot be array-valued" }
  41   CHARACTER(LEN=*), DIMENSION(10) :: F1
  42   F1 = ""
  43 END FUNCTION F1
  44
  45 !PR25086
  46 FUNCTION F2() result(f4)  ! { dg-error "cannot be pointer-valued" }
  47   CHARACTER(LEN=*), POINTER  :: f4
  48   f4 = ""
  49 END FUNCTION F2
  50
  51 !PR?????
  52 pure FUNCTION F3()        ! { dg-error "cannot be pure" }
  53   CHARACTER(LEN=*)  :: F3
  54   F3 = ""
  55 END FUNCTION F3
  56
  57 function not_OK (ch)
  58   character(*) not_OK, ch ! OK in an external function
  59   not_OK = ch
  60 end function not_OK
  61
  62   use m1
  63
  64   character(4) :: answer
  65   character(*), external :: not_OK
  66   integer :: i
  67   type (set) :: z
  68
  69   interface
  70     function ext (i)
  71       character(*) :: ext
  72       integer :: i
  73     end function ext
  74   end interface
  75
  76   answer = not_OK ("unOK") ! { dg-error "since it is not a dummy" }
  77
  78 END
  79