| ! { dg-do run } |
| ! PR fortran/94788 - this leads to a double free. |
| ! Test case by Juergen Reuter. |
| module iso_varying_string |
| implicit none |
| integer, parameter, private :: GET_BUFFER_LEN = 1 |
| type, public :: varying_string |
| private |
| character(LEN=1), dimension(:), allocatable :: chars |
| end type varying_string |
| |
| interface assignment(=) |
| module procedure op_assign_CH_VS |
| module procedure op_assign_VS_CH |
| end interface assignment(=) |
| |
| interface char |
| module procedure char_auto |
| module procedure char_fixed |
| end interface char |
| |
| interface len |
| module procedure len_ |
| end interface len |
| |
| interface var_str |
| module procedure var_str_ |
| end interface var_str |
| |
| public :: assignment(=) |
| public :: char |
| public :: len |
| public :: var_str |
| |
| private :: op_assign_CH_VS |
| private :: op_assign_VS_CH |
| private :: op_eq_VS_VS |
| private :: op_eq_CH_VS |
| private :: op_eq_VS_CH |
| private :: char_auto |
| private :: char_fixed |
| private :: len_ |
| private :: var_str_ |
| |
| contains |
| |
| elemental function len_ (string) result (length) |
| type(varying_string), intent(in) :: string |
| integer :: length |
| if(ALLOCATED(string%chars)) then |
| length = SIZE(string%chars) |
| else |
| length = 0 |
| endif |
| end function len_ |
| |
| elemental subroutine op_assign_CH_VS (var, exp) |
| character(LEN=*), intent(out) :: var |
| type(varying_string), intent(in) :: exp |
| var = char(exp) |
| end subroutine op_assign_CH_VS |
| |
| elemental subroutine op_assign_VS_CH (var, exp) |
| type(varying_string), intent(out) :: var |
| character(LEN=*), intent(in) :: exp |
| var = var_str(exp) |
| end subroutine op_assign_VS_CH |
| |
| elemental function op_eq_VS_VS (string_a, string_b) result (op_eq) |
| type(varying_string), intent(in) :: string_a |
| type(varying_string), intent(in) :: string_b |
| logical :: op_eq |
| op_eq = char(string_a) == char(string_b) |
| end function op_eq_VS_VS |
| |
| elemental function op_eq_CH_VS (string_a, string_b) result (op_eq) |
| character(LEN=*), intent(in) :: string_a |
| type(varying_string), intent(in) :: string_b |
| logical :: op_eq |
| op_eq = string_a == char(string_b) |
| end function op_eq_CH_VS |
| |
| elemental function op_eq_VS_CH (string_a, string_b) result (op_eq) |
| type(varying_string), intent(in) :: string_a |
| character(LEN=*), intent(in) :: string_b |
| logical :: op_eq |
| op_eq = char(string_a) == string_b |
| end function op_eq_VS_CH |
| |
| |
| pure function char_auto (string) result (char_string) |
| type(varying_string), intent(in) :: string |
| character(LEN=len(string)) :: char_string |
| integer :: i_char |
| forall(i_char = 1:len(string)) |
| char_string(i_char:i_char) = string%chars(i_char) |
| end forall |
| |
| end function char_auto |
| |
| pure function char_fixed (string, length) result (char_string) |
| type(varying_string), intent(in) :: string |
| integer, intent(in) :: length |
| character(LEN=length) :: char_string |
| char_string = char(string) |
| end function char_fixed |
| |
| elemental function var_str_ (char) result (string) |
| character(LEN=*), intent(in) :: char |
| type(varying_string) :: string |
| integer :: length |
| integer :: i_char |
| length = LEN(char) |
| ALLOCATE(string%chars(length)) |
| forall(i_char = 1:length) |
| string%chars(i_char) = char(i_char:i_char) |
| end forall |
| end function var_str_ |
| |
| end module iso_varying_string |
| |
| |
| module parser |
| implicit none |
| private |
| public :: parse_node_t |
| public :: parse_tree_t |
| type :: parse_node_t |
| private |
| end type parse_node_t |
| |
| type :: parse_tree_t |
| private |
| type(parse_node_t), pointer :: root_node => null () |
| contains |
| procedure :: get_root_ptr => parse_tree_get_root_ptr |
| end type parse_tree_t |
| |
| contains |
| function parse_tree_get_root_ptr (parse_tree) result (node) |
| class(parse_tree_t), intent(in) :: parse_tree |
| type(parse_node_t), pointer :: node |
| node => parse_tree%root_node |
| end function parse_tree_get_root_ptr |
| |
| end module parser |
| |
| |
| |
| module rt_data |
| use iso_varying_string, string_t => varying_string |
| use parser, only: parse_node_t |
| implicit none |
| private |
| |
| public :: rt_data_t |
| |
| type :: rt_parse_nodes_t |
| type(parse_node_t), pointer :: weight_expr => null () |
| end type rt_parse_nodes_t |
| |
| type :: rt_data_t |
| type(rt_parse_nodes_t) :: pn |
| type(string_t) :: logfile |
| contains |
| procedure :: global_init => rt_data_global_init |
| procedure :: local_init => rt_data_local_init |
| procedure :: activate => rt_data_activate |
| end type rt_data_t |
| |
| |
| contains |
| |
| subroutine rt_data_global_init (global, logfile) |
| class(rt_data_t), intent(out), target :: global |
| type(string_t), intent(in), optional :: logfile |
| integer :: seed |
| if (present (logfile)) then |
| global%logfile = logfile |
| else |
| global%logfile = "" |
| end if |
| call system_clock (seed) |
| end subroutine rt_data_global_init |
| |
| subroutine rt_data_local_init (local, global, env) |
| class(rt_data_t), intent(inout), target :: local |
| type(rt_data_t), intent(in), target :: global |
| integer, intent(in), optional :: env |
| local%logfile = global%logfile |
| end subroutine rt_data_local_init |
| |
| subroutine rt_data_activate (local) |
| class(rt_data_t), intent(inout), target :: local |
| class(rt_data_t), pointer :: global |
| |
| ! global => local%context |
| ! if (associated (global)) then |
| ! local%logfile = global%logfile |
| ! local%pn = global%pn |
| ! end if |
| end subroutine rt_data_activate |
| |
| end module rt_data |
| |
| module events |
| implicit none |
| private |
| public :: event_t |
| |
| type :: event_config_t |
| end type event_config_t |
| |
| type :: event_t |
| type(event_config_t) :: config |
| end type event_t |
| |
| end module events |
| |
| |
| module simulations |
| use iso_varying_string, string_t => varying_string |
| use events |
| use rt_data |
| |
| implicit none |
| private |
| |
| public :: simulation_t |
| |
| type, extends (event_t) :: entry_t |
| private |
| type(entry_t), pointer :: next => null () |
| end type entry_t |
| |
| type, extends (entry_t) :: alt_entry_t |
| contains |
| procedure :: init_alt => alt_entry_init |
| end type alt_entry_t |
| |
| type :: simulation_t |
| private |
| type(rt_data_t), pointer :: local => null () |
| integer :: n_alt = 0 |
| type(entry_t), dimension(:), allocatable :: entry |
| type(alt_entry_t), dimension(:,:), allocatable :: alt_entry |
| contains |
| procedure :: init => simulation_init |
| end type simulation_t |
| |
| |
| contains |
| |
| subroutine alt_entry_init (entry, local) |
| class(alt_entry_t), intent(inout), target :: entry |
| type(rt_data_t), intent(inout), target :: local |
| integer :: i |
| end subroutine alt_entry_init |
| |
| subroutine simulation_init (simulation, & |
| integrate, generate, local, global, alt_env) |
| class(simulation_t), intent(out), target :: simulation |
| logical, intent(in) :: integrate, generate |
| type(rt_data_t), intent(inout), target :: local |
| type(rt_data_t), intent(inout), optional, target :: global |
| type(rt_data_t), dimension(:), intent(inout), optional, target :: alt_env |
| simulation%local => local |
| allocate (simulation%entry (1)) |
| if (present (alt_env)) then |
| simulation%n_alt = size (alt_env) |
| end if |
| end subroutine simulation_init |
| |
| end module simulations |
| |
| |
| program main_ut |
| use iso_varying_string, string_t => varying_string |
| use parser, only: parse_tree_t |
| use rt_data |
| use simulations |
| implicit none |
| call simulations_10 (6) |
| |
| contains |
| |
| subroutine simulations_10 (u) |
| integer, intent(in) :: u |
| type(rt_data_t), target :: global |
| type(rt_data_t), dimension(1), target :: alt_env |
| type(parse_tree_t) :: pt_weight |
| type(simulation_t), target :: simulation |
| |
| call global%global_init () |
| call alt_env(1)%local_init (global) |
| call alt_env(1)%activate () |
| |
| !!!! This causes the pointer hiccup |
| alt_env(1)%pn%weight_expr => pt_weight%get_root_ptr () |
| call simulation%init (.true., .true., global, alt_env=alt_env) |
| |
| end subroutine simulations_10 |
| |
| end program main_ut |