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