Skip to content

Commit 9b720ef

Browse files
author
Paul Thomas
committed
Fortran: Pointer fcn results must not be finalized [PR117897]
2024-12-15 Paul Thomas <[email protected]> gcc/fortran PR fortran/117897 * trans-expr.cc (gfc_trans_assignment_1): RHS pointer function results must not be finalized. gcc/testsuite/ PR fortran/117897 * gfortran.dg/finalize_59.f90: New test. (cherry picked from commit a87bf1d)
1 parent 3e057db commit 9b720ef

File tree

2 files changed

+253
-1
lines changed

2 files changed

+253
-1
lines changed

‎gcc/fortran/trans-expr.cc‎

Lines changed: 8 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -11881,13 +11881,20 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
1188111881
&& (expr2->ts.type == BT_CLASS || gfc_may_be_finalized (expr2->ts)))
1188211882
{
1188311883
expr2->must_finalize = 1;
11884+
/* F2023 7.5.6.3: If an executable construct references a nonpointer
11885+
function, the result is finalized after execution of the innermost
11886+
executable construct containing the reference. */
11887+
if (expr2->expr_type == EXPR_FUNCTION
11888+
&& (gfc_expr_attr (expr2).pointer
11889+
|| (expr2->ts.type == BT_CLASS && CLASS_DATA (expr2)->attr.class_pointer)))
11890+
expr2->must_finalize = 0;
1188411891
/* F2008 4.5.6.3 para 5: If an executable construct references a
1188511892
structure constructor or array constructor, the entity created by
1188611893
the constructor is finalized after execution of the innermost
1188711894
executable construct containing the reference.
1188811895
These finalizations were later deleted by the Combined Techical
1188911896
Corrigenda 1 TO 4 for fortran 2008 (f08/0011). */
11890-
if (gfc_notification_std (GFC_STD_F2018_DEL)
11897+
else if (gfc_notification_std (GFC_STD_F2018_DEL)
1189111898
&& (expr2->expr_type == EXPR_STRUCTURE
1189211899
|| expr2->expr_type == EXPR_ARRAY))
1189311900
expr2->must_finalize = 0;

‎gcc/testsuite/gfortran.dg/finalize_59.f90‎

Lines changed: 245 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,245 @@
1+
! { dg-do run }
2+
!
3+
! Test the fix for PR117897 in which the rhs of the pointer assignment at line
4+
! 216 below was marked as being finalizable, contrary to F2023 7.5.6.3 for
5+
! ordinary assignment and certainly wrong in this context.
6+
!
7+
! Contributed by Jean Gual <[email protected]>
8+
!
9+
Module Uef_Classe_Vector
10+
! Ce module implemente le vector de la STL du C++
11+
Private
12+
CHARACTER (len=3), Parameter :: UEF_PAR_CHAINE_NON_RENSEIGNEE = "N_R"
13+
real, parameter :: UEF_par_vector_progression_ratio = 2
14+
Integer, parameter :: UEF_par_vector_initial_lenght = 10
15+
16+
Type, abstract, public :: Uef_Vector_element
17+
Logical, public :: m_Element_pointe = .false.
18+
End type Uef_Vector_element
19+
20+
Type, private :: Uef_Pointeur_element ! Classe pointeur
21+
Class (Uef_Vector_element), public, pointer :: m_ptr_element => null()
22+
End type Uef_Pointeur_element
23+
24+
Type, public :: Uef_Vector ! Vecteur des classes pointeur
25+
integer , private :: m_position_fin = 0
26+
type(Uef_Pointeur_element), private, allocatable, dimension(:) :: m_les_pointeur_element
27+
Character (:), private, allocatable :: m_label
28+
Class (Uef_Vector_element), allocatable, private :: m_type_element
29+
logical ,private :: m_polymorphe = .false.
30+
Contains
31+
PROCEDURE :: create => Vector_create
32+
PROCEDURE :: add => Vector_add
33+
PROCEDURE :: Pointer => Vector_pointer
34+
PROCEDURE :: size => vector_size
35+
End Type Uef_Vector
36+
37+
Contains
38+
!--------------------
39+
! Vector_create : Cree un vector non deja alloue avec une taille initiale eventuelle
40+
!--------------------
41+
Subroutine Vector_create(le_vector, label, type_element, opt_taille, opt_polymorphe)
42+
! parametres en entree/sortie
43+
Class(Uef_Vector),intent (inout) :: le_vector
44+
Character (len=*),intent(in) :: label
45+
Class (Uef_Vector_element),intent(in) :: type_element
46+
Integer, intent(in), optional :: opt_taille
47+
Logical, intent(in), optional :: opt_polymorphe
48+
49+
! parametres locaux
50+
integer :: taille_initiale
51+
!
52+
!-----DEBUT-----------------------------------------------------------------------------------------------------------------------
53+
! write (*,*) "create:", label
54+
if (allocated(le_vector%m_les_pointeur_element)) then
55+
Call Uef_assert(.false., "Vector_create : vecteur deja cree :"// le_vector%m_label)
56+
endif
57+
58+
if (present(opt_taille)) then
59+
taille_initiale = max( 1, opt_taille )
60+
else
61+
taille_initiale = UEF_par_vector_initial_lenght
62+
endif
63+
64+
if (present(opt_polymorphe)) then
65+
le_vector%m_polymorphe = opt_polymorphe
66+
endif
67+
68+
allocate( le_vector%m_les_pointeur_element(1:taille_initiale))
69+
le_vector%m_position_fin = 0
70+
le_vector%m_label = label
71+
allocate (le_vector%m_type_element, source = type_element)
72+
End Subroutine Vector_create
73+
!--------------------
74+
! Vector_add : ajoute une copie d'un element a la fin du vecteur
75+
!--------------------
76+
Subroutine Vector_add(le_vector, l_element)
77+
! parametres en entree/sortie
78+
Class(Uef_Vector),intent(inout) :: le_vector
79+
Class(Uef_Vector_element), intent(in) :: l_element
80+
81+
! parametres locaux
82+
type(Uef_Pointeur_element) :: le_ptr_element
83+
!
84+
!-----DEBUT-----------------------------------------------------------------------------------------------------------------------
85+
!
86+
! write (*,*) "ajout:", le_vector%m_label
87+
if ( .not. allocated(le_vector%m_les_pointeur_element) ) Then
88+
Call Vector_create(le_vector, label= UEF_PAR_CHAINE_NON_RENSEIGNEE, type_element = l_element)
89+
End if
90+
if ( .not. same_type_as (l_element,le_vector%m_type_element).and. .not. le_vector%m_polymorphe) then
91+
Call Uef_assert(.false., "Vector_add : element de type incorrect pour :"// le_vector%m_label)
92+
End if
93+
94+
if ( le_vector%m_position_fin >= size(le_vector%m_les_pointeur_element) ) then
95+
call vector_increase_size( le_vector, le_vector%m_position_fin+1 )
96+
endif
97+
98+
le_vector%m_position_fin = le_vector%m_position_fin + 1
99+
allocate (le_ptr_element%m_ptr_element, source = l_element)
100+
le_vector%m_les_pointeur_element(le_vector%m_position_fin) = le_ptr_element
101+
End Subroutine Vector_add
102+
!--------------------
103+
! vector_size : retourne le nombre d'elements effectifs du vector
104+
!--------------------
105+
Pure Integer Function vector_size(le_vector)
106+
! parametres en entree
107+
Class(Uef_Vector), intent (in) :: le_vector
108+
!
109+
!-----DEBUT-----------------------------------------------------------------------------------------------------------------------
110+
vector_size = le_vector%m_position_fin
111+
End Function vector_size
112+
!--------------------
113+
! Vector_pointer : pointe sur une valeur
114+
!--------------------
115+
Function Vector_pointer( le_vector, position_element )
116+
! parametres en entree/sortie
117+
Class(Uef_Vector),intent(inout) :: le_vector
118+
integer,intent (in) :: position_element
119+
! parametres en sortie
120+
Class(Uef_Vector_element), Pointer :: Vector_pointer
121+
!
122+
!-----DEBUT-----------------------------------------------------------------------------------------------------------------------
123+
!
124+
if ( position_element < 1 .or. position_element > le_vector%m_position_fin ) then
125+
write (*,*) "Vector_pointer : pointage impossible de ", le_vector%m_label, " position_element:",&
126+
position_element," size:",le_vector%m_position_fin
127+
Call Uef_assert(.false., "Vector_pointer : pointage impossible dans "// le_vector%m_label)
128+
else
129+
le_vector%m_les_pointeur_element(position_element)%m_ptr_element%m_Element_pointe =.true.
130+
Vector_pointer => le_vector%m_les_pointeur_element(position_element)%m_ptr_element
131+
endif
132+
End Function Vector_pointer
133+
!--------------------
134+
! vector_increase_size : augmente la taille du vector
135+
!--------------------
136+
Subroutine vector_increase_size( le_vector, taille_demandee )
137+
! parametres en entree/sortie
138+
Class(Uef_Vector),intent(inout) :: le_vector
139+
integer,intent(in) :: taille_demandee
140+
! Parametres en locaux
141+
integer :: Nouvelle_taille, taille_actuelle
142+
type(Uef_Pointeur_element),dimension (:), allocatable:: tmp_vector
143+
!
144+
!-----DEBUT-----------------------------------------------------------------------------------------------------------------------
145+
!
146+
taille_actuelle = size(le_vector%m_les_pointeur_element)
147+
Nouvelle_taille = max(taille_demandee, nint( UEF_par_vector_progression_ratio * taille_actuelle))
148+
149+
if (Nouvelle_taille > taille_actuelle) then
150+
allocate(tmp_vector(1:Nouvelle_taille))
151+
tmp_vector(1:taille_actuelle) = le_vector%m_les_pointeur_element(1:le_vector%m_position_fin)
152+
call move_alloc(from = tmp_vector , to = le_vector%m_les_pointeur_element)
153+
endif
154+
End Subroutine vector_increase_size
155+
!------------------------
156+
Subroutine Uef_Assert (assertion, message)
157+
!--------------------
158+
! traitement des assertions
159+
!--------------------
160+
! Parametres en entree
161+
Logical, Intent(in) :: assertion
162+
Character (len = *) , intent(in):: message
163+
!-------------------------------------------------------------------------------------------------
164+
if (.not. assertion ) Then
165+
166+
write(*,*) message
167+
write(*,*) " ARRET PREMATURE : PREVENIR LE GESTIONNAIRE"
168+
stop
169+
End if
170+
End Subroutine Uef_Assert
171+
172+
End Module Uef_Classe_Vector
173+
174+
Program Cds_Principal
175+
Use Uef_Classe_vector
176+
!
177+
!--------------------------------------------------------------------------------------------------
178+
TYPE, extends(Uef_Vector_element), abstract :: Cds_Materiau
179+
Character (len=8) :: m_Nom_materiau = "12345678"
180+
Type(Uef_Vector) :: m_Les_situations
181+
END TYPE Cds_Materiau
182+
183+
Type, extends (Cds_Materiau) :: Cds_Materiau_Acier_EC
184+
Double precision :: m_Fyk = 0.00
185+
End type Cds_Materiau_Acier_EC
186+
187+
Type(Uef_Vector) :: Cds_Mod_Les_materiaux
188+
Type (Cds_Materiau_Acier_EC) :: acier_ec
189+
Class (Cds_Materiau), pointer :: pt_materiau
190+
Character *(8) :: nom_materiau
191+
!-------------------------------------------------------------------------------------------------
192+
CaLL Cds_Mod_Les_materiaux%Add (acier_ec)
193+
nom_materiau = "12345678"
194+
pt_materiau => Get_pt_materiau_nom (Cds_Mod_Les_materiaux, nom_materiau)
195+
contains
196+
197+
Function Get_Pt_Materiau_nom (vecteur, nom_materiau)
198+
!--------------------
199+
! Fonction :
200+
!--------------------
201+
! Parametres en entree
202+
Character *(8), Intent (in) :: nom_materiau
203+
Type (Uef_Vector) , Intent (inout) :: vecteur
204+
205+
! Parametres en sortie
206+
Class (Cds_Materiau),pointer :: Get_Pt_Materiau_nom
207+
208+
! Parametres locaux
209+
Integer :: no_materiau
210+
211+
Class (Uef_Vector_element),pointer :: pt_vector_element
212+
!--------------------
213+
do no_materiau = 1 , vecteur%size()
214+
pt_vector_element => vecteur%Pointer(no_materiau)
215+
! this instruction did not work
216+
Get_Pt_Materiau_nom => Cds_pt_materiau(pt_vector_element)
217+
218+
if (trim (Get_Pt_Materiau_nom%m_Nom_materiau) /= '12345678') stop 1
219+
if (Get_Pt_Materiau_nom%m_Nom_materiau == nom_materiau) Then
220+
return
221+
End if
222+
End do
223+
Get_Pt_Materiau_nom => null()
224+
End Function Get_Pt_Materiau_nom
225+
!
226+
!--------------------
227+
function Cds_Pt_Materiau(vector_element)
228+
!--------------------
229+
! Fonction : pointage de la valeur
230+
!--------------------
231+
232+
! Parametres en entree
233+
Class (Uef_Vector_element),intent(in),target :: vector_element
234+
! Parametres en sortie
235+
Class(Cds_Materiau), pointer :: Cds_Pt_Materiau
236+
!-----------------------------------------------------------------------------------------------
237+
select type(vector_element)
238+
Class is (Cds_Materiau)
239+
Cds_Pt_Materiau => vector_element
240+
class default
241+
stop 2
242+
end select
243+
End Function Cds_Pt_Materiau
244+
245+
End Program Cds_Principal

0 commit comments

Comments
 (0)