Skip to content

Commit

Permalink
Fortran: Pointer fcn results must not be finalized [PR117897]
Browse files Browse the repository at this point in the history 
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)
  • Loading branch information
Paul Thomas committed Dec 17, 2024
1 parent 3e057db commit 9b720ef
Show file tree
Hide file tree
Showing 2 changed files with 253 additions and 1 deletion.
9 changes: 8 additions & 1 deletion gcc/fortran/trans-expr.cc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11881,13 +11881,20 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
&& (expr2->ts.type == BT_CLASS || gfc_may_be_finalized (expr2->ts)))
{
expr2->must_finalize = 1;
/* F2023 7.5.6.3: If an executable construct references a nonpointer
function, the result is finalized after execution of the innermost
executable construct containing the reference. */
if (expr2->expr_type == EXPR_FUNCTION
&& (gfc_expr_attr (expr2).pointer
|| (expr2->ts.type == BT_CLASS && CLASS_DATA (expr2)->attr.class_pointer)))
expr2->must_finalize = 0;
/* F2008 4.5.6.3 para 5: If an executable construct references a
structure constructor or array constructor, the entity created by
the constructor is finalized after execution of the innermost
executable construct containing the reference.
These finalizations were later deleted by the Combined Techical
Corrigenda 1 TO 4 for fortran 2008 (f08/0011). */
if (gfc_notification_std (GFC_STD_F2018_DEL)
else if (gfc_notification_std (GFC_STD_F2018_DEL)
&& (expr2->expr_type == EXPR_STRUCTURE
|| expr2->expr_type == EXPR_ARRAY))
expr2->must_finalize = 0;
Expand Down
245 changes: 245 additions & 0 deletions gcc/testsuite/gfortran.dg/finalize_59.f90
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,245 @@
! { dg-do run }
!
! Test the fix for PR117897 in which the rhs of the pointer assignment at line
! 216 below was marked as being finalizable, contrary to F2023 7.5.6.3 for
! ordinary assignment and certainly wrong in this context.
!
! Contributed by Jean Gual <[email protected]>
!
Module Uef_Classe_Vector
! Ce module implemente le vector de la STL du C++
Private
CHARACTER (len=3), Parameter :: UEF_PAR_CHAINE_NON_RENSEIGNEE = "N_R"
real, parameter :: UEF_par_vector_progression_ratio = 2
Integer, parameter :: UEF_par_vector_initial_lenght = 10

Type, abstract, public :: Uef_Vector_element
Logical, public :: m_Element_pointe = .false.
End type Uef_Vector_element

Type, private :: Uef_Pointeur_element ! Classe pointeur
Class (Uef_Vector_element), public, pointer :: m_ptr_element => null()
End type Uef_Pointeur_element

Type, public :: Uef_Vector ! Vecteur des classes pointeur
integer , private :: m_position_fin = 0
type(Uef_Pointeur_element), private, allocatable, dimension(:) :: m_les_pointeur_element
Character (:), private, allocatable :: m_label
Class (Uef_Vector_element), allocatable, private :: m_type_element
logical ,private :: m_polymorphe = .false.
Contains
PROCEDURE :: create => Vector_create
PROCEDURE :: add => Vector_add
PROCEDURE :: Pointer => Vector_pointer
PROCEDURE :: size => vector_size
End Type Uef_Vector

Contains
!--------------------
! Vector_create : Cree un vector non deja alloue avec une taille initiale eventuelle
!--------------------
Subroutine Vector_create(le_vector, label, type_element, opt_taille, opt_polymorphe)
! parametres en entree/sortie
Class(Uef_Vector),intent (inout) :: le_vector
Character (len=*),intent(in) :: label
Class (Uef_Vector_element),intent(in) :: type_element
Integer, intent(in), optional :: opt_taille
Logical, intent(in), optional :: opt_polymorphe

! parametres locaux
integer :: taille_initiale
!
!-----DEBUT-----------------------------------------------------------------------------------------------------------------------
! write (*,*) "create:", label
if (allocated(le_vector%m_les_pointeur_element)) then
Call Uef_assert(.false., "Vector_create : vecteur deja cree :"// le_vector%m_label)
endif

if (present(opt_taille)) then
taille_initiale = max( 1, opt_taille )
else
taille_initiale = UEF_par_vector_initial_lenght
endif

if (present(opt_polymorphe)) then
le_vector%m_polymorphe = opt_polymorphe
endif

allocate( le_vector%m_les_pointeur_element(1:taille_initiale))
le_vector%m_position_fin = 0
le_vector%m_label = label
allocate (le_vector%m_type_element, source = type_element)
End Subroutine Vector_create
!--------------------
! Vector_add : ajoute une copie d'un element a la fin du vecteur
!--------------------
Subroutine Vector_add(le_vector, l_element)
! parametres en entree/sortie
Class(Uef_Vector),intent(inout) :: le_vector
Class(Uef_Vector_element), intent(in) :: l_element

! parametres locaux
type(Uef_Pointeur_element) :: le_ptr_element
!
!-----DEBUT-----------------------------------------------------------------------------------------------------------------------
!
! write (*,*) "ajout:", le_vector%m_label
if ( .not. allocated(le_vector%m_les_pointeur_element) ) Then
Call Vector_create(le_vector, label= UEF_PAR_CHAINE_NON_RENSEIGNEE, type_element = l_element)
End if
if ( .not. same_type_as (l_element,le_vector%m_type_element).and. .not. le_vector%m_polymorphe) then
Call Uef_assert(.false., "Vector_add : element de type incorrect pour :"// le_vector%m_label)
End if

if ( le_vector%m_position_fin >= size(le_vector%m_les_pointeur_element) ) then
call vector_increase_size( le_vector, le_vector%m_position_fin+1 )
endif

le_vector%m_position_fin = le_vector%m_position_fin + 1
allocate (le_ptr_element%m_ptr_element, source = l_element)
le_vector%m_les_pointeur_element(le_vector%m_position_fin) = le_ptr_element
End Subroutine Vector_add
!--------------------
! vector_size : retourne le nombre d'elements effectifs du vector
!--------------------
Pure Integer Function vector_size(le_vector)
! parametres en entree
Class(Uef_Vector), intent (in) :: le_vector
!
!-----DEBUT-----------------------------------------------------------------------------------------------------------------------
vector_size = le_vector%m_position_fin
End Function vector_size
!--------------------
! Vector_pointer : pointe sur une valeur
!--------------------
Function Vector_pointer( le_vector, position_element )
! parametres en entree/sortie
Class(Uef_Vector),intent(inout) :: le_vector
integer,intent (in) :: position_element
! parametres en sortie
Class(Uef_Vector_element), Pointer :: Vector_pointer
!
!-----DEBUT-----------------------------------------------------------------------------------------------------------------------
!
if ( position_element < 1 .or. position_element > le_vector%m_position_fin ) then
write (*,*) "Vector_pointer : pointage impossible de ", le_vector%m_label, " position_element:",&
position_element," size:",le_vector%m_position_fin
Call Uef_assert(.false., "Vector_pointer : pointage impossible dans "// le_vector%m_label)
else
le_vector%m_les_pointeur_element(position_element)%m_ptr_element%m_Element_pointe =.true.
Vector_pointer => le_vector%m_les_pointeur_element(position_element)%m_ptr_element
endif
End Function Vector_pointer
!--------------------
! vector_increase_size : augmente la taille du vector
!--------------------
Subroutine vector_increase_size( le_vector, taille_demandee )
! parametres en entree/sortie
Class(Uef_Vector),intent(inout) :: le_vector
integer,intent(in) :: taille_demandee
! Parametres en locaux
integer :: Nouvelle_taille, taille_actuelle
type(Uef_Pointeur_element),dimension (:), allocatable:: tmp_vector
!
!-----DEBUT-----------------------------------------------------------------------------------------------------------------------
!
taille_actuelle = size(le_vector%m_les_pointeur_element)
Nouvelle_taille = max(taille_demandee, nint( UEF_par_vector_progression_ratio * taille_actuelle))

if (Nouvelle_taille > taille_actuelle) then
allocate(tmp_vector(1:Nouvelle_taille))
tmp_vector(1:taille_actuelle) = le_vector%m_les_pointeur_element(1:le_vector%m_position_fin)
call move_alloc(from = tmp_vector , to = le_vector%m_les_pointeur_element)
endif
End Subroutine vector_increase_size
!------------------------
Subroutine Uef_Assert (assertion, message)
!--------------------
! traitement des assertions
!--------------------
! Parametres en entree
Logical, Intent(in) :: assertion
Character (len = *) , intent(in):: message
!-------------------------------------------------------------------------------------------------
if (.not. assertion ) Then

write(*,*) message
write(*,*) " ARRET PREMATURE : PREVENIR LE GESTIONNAIRE"
stop
End if
End Subroutine Uef_Assert

End Module Uef_Classe_Vector

Program Cds_Principal
Use Uef_Classe_vector
!
!--------------------------------------------------------------------------------------------------
TYPE, extends(Uef_Vector_element), abstract :: Cds_Materiau
Character (len=8) :: m_Nom_materiau = "12345678"
Type(Uef_Vector) :: m_Les_situations
END TYPE Cds_Materiau

Type, extends (Cds_Materiau) :: Cds_Materiau_Acier_EC
Double precision :: m_Fyk = 0.00
End type Cds_Materiau_Acier_EC

Type(Uef_Vector) :: Cds_Mod_Les_materiaux
Type (Cds_Materiau_Acier_EC) :: acier_ec
Class (Cds_Materiau), pointer :: pt_materiau
Character *(8) :: nom_materiau
!-------------------------------------------------------------------------------------------------
CaLL Cds_Mod_Les_materiaux%Add (acier_ec)
nom_materiau = "12345678"
pt_materiau => Get_pt_materiau_nom (Cds_Mod_Les_materiaux, nom_materiau)
contains

Function Get_Pt_Materiau_nom (vecteur, nom_materiau)
!--------------------
! Fonction :
!--------------------
! Parametres en entree
Character *(8), Intent (in) :: nom_materiau
Type (Uef_Vector) , Intent (inout) :: vecteur

! Parametres en sortie
Class (Cds_Materiau),pointer :: Get_Pt_Materiau_nom

! Parametres locaux
Integer :: no_materiau

Class (Uef_Vector_element),pointer :: pt_vector_element
!--------------------
do no_materiau = 1 , vecteur%size()
pt_vector_element => vecteur%Pointer(no_materiau)
! this instruction did not work
Get_Pt_Materiau_nom => Cds_pt_materiau(pt_vector_element)

if (trim (Get_Pt_Materiau_nom%m_Nom_materiau) /= '12345678') stop 1
if (Get_Pt_Materiau_nom%m_Nom_materiau == nom_materiau) Then
return
End if
End do
Get_Pt_Materiau_nom => null()
End Function Get_Pt_Materiau_nom
!
!--------------------
function Cds_Pt_Materiau(vector_element)
!--------------------
! Fonction : pointage de la valeur
!--------------------

! Parametres en entree
Class (Uef_Vector_element),intent(in),target :: vector_element
! Parametres en sortie
Class(Cds_Materiau), pointer :: Cds_Pt_Materiau
!-----------------------------------------------------------------------------------------------
select type(vector_element)
Class is (Cds_Materiau)
Cds_Pt_Materiau => vector_element
class default
stop 2
end select
End Function Cds_Pt_Materiau

End Program Cds_Principal

0 comments on commit 9b720ef

Please sign in to comment.