--- /dev/null
+! { 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 <jean.gual@cerema.fr>
+!
+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
projects / thirdparty / gcc.git / commitdiff
