gcc/testsuite/gfortran.dg/assumed_charlen_function_1.f90

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