diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index df109bd4054..57191665412 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -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; diff --git a/gcc/testsuite/gfortran.dg/finalize_59.f90 b/gcc/testsuite/gfortran.dg/finalize_59.f90 new file mode 100644 index 00000000000..8be5f7123a1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_59.f90 @@ -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 +! +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