1! { dg-do compile } 2 3! Parsing of finalizer procedure definitions. 4! Check for appropriate errors on invalid final procedures. 5 6MODULE final_type 7 IMPLICIT NONE 8 9 TYPE :: mytype 10 INTEGER, ALLOCATABLE :: fooarr(:) 11 REAL :: foobar 12 FINAL :: finalize_matrix ! { dg-error "must be inside a derived type" } 13 CONTAINS 14 FINAL :: ! { dg-error "Empty FINAL" } 15 FINAL ! { dg-error "Empty FINAL" } 16 FINAL :: + ! { dg-error "Expected module procedure name" } 17 FINAL :: iamnot ! { dg-error "is not a SUBROUTINE" } 18 FINAL :: finalize_single finalize_vector ! { dg-error "Expected ','" } 19 FINAL :: finalize_single, finalize_vector 20 FINAL :: finalize_single ! { dg-error "is already defined" } 21 FINAL :: finalize_vector_2 ! { dg-error "has the same rank" } 22 FINAL :: finalize_single_2 ! { dg-error "has the same rank" } 23 FINAL :: bad_function ! { dg-error "is not a SUBROUTINE" } 24 FINAL bad_num_args_1 ! { dg-error "must have exactly one argument" } 25 FINAL bad_num_args_2 ! { dg-error "must have exactly one argument" } 26 FINAL bad_arg_type 27 FINAL :: bad_pointer 28 FINAL :: bad_alloc 29 FINAL :: bad_optional 30 FINAL :: bad_intent_out 31 32 ! TODO: Test for polymorphism, kind parameters once those are implemented. 33 END TYPE mytype 34 35CONTAINS 36 37 SUBROUTINE finalize_single (el) 38 IMPLICIT NONE 39 TYPE(mytype) :: el 40 END SUBROUTINE finalize_single 41 42 ELEMENTAL SUBROUTINE finalize_single_2 (el) 43 IMPLICIT NONE 44 TYPE(mytype), INTENT(IN) :: el 45 END SUBROUTINE finalize_single_2 46 47 SUBROUTINE finalize_vector (el) 48 IMPLICIT NONE 49 TYPE(mytype), INTENT(INOUT) :: el(:) 50 END SUBROUTINE finalize_vector 51 52 SUBROUTINE finalize_vector_2 (el) 53 IMPLICIT NONE 54 TYPE(mytype), INTENT(IN) :: el(:) 55 END SUBROUTINE finalize_vector_2 56 57 SUBROUTINE finalize_matrix (el) 58 IMPLICIT NONE 59 TYPE(mytype) :: el(:, :) 60 END SUBROUTINE finalize_matrix 61 62 INTEGER FUNCTION bad_function (el) 63 IMPLICIT NONE 64 TYPE(mytype) :: el 65 66 bad_function = 42 67 END FUNCTION bad_function 68 69 SUBROUTINE bad_num_args_1 () 70 IMPLICIT NONE 71 END SUBROUTINE bad_num_args_1 72 73 SUBROUTINE bad_num_args_2 (el, x) 74 IMPLICIT NONE 75 TYPE(mytype) :: el 76 COMPLEX :: x 77 END SUBROUTINE bad_num_args_2 78 79 SUBROUTINE bad_arg_type (el) ! { dg-error "must be of type 'mytype'" } 80 IMPLICIT NONE 81 REAL :: el 82 END SUBROUTINE bad_arg_type 83 84 SUBROUTINE bad_pointer (el) ! { dg-error "must not be a POINTER" } 85 IMPLICIT NONE 86 TYPE(mytype), POINTER :: el 87 END SUBROUTINE bad_pointer 88 89 SUBROUTINE bad_alloc (el) ! { dg-error "must not be ALLOCATABLE" } 90 IMPLICIT NONE 91 TYPE(mytype), ALLOCATABLE :: el(:) 92 END SUBROUTINE bad_alloc 93 94 SUBROUTINE bad_optional (el) ! { dg-error "must not be OPTIONAL" } 95 IMPLICIT NONE 96 TYPE(mytype), OPTIONAL :: el 97 END SUBROUTINE bad_optional 98 99 SUBROUTINE bad_intent_out (el) ! { dg-error "must not be INTENT\\(OUT\\)" } 100 IMPLICIT NONE 101 TYPE(mytype), INTENT(OUT) :: el 102 END SUBROUTINE bad_intent_out 103 104END MODULE final_type 105 106PROGRAM finalizer 107 IMPLICIT NONE 108 ! Nothing here, errors above 109END PROGRAM finalizer 110