Hello All, PRs 123545 and 123673 are somewhat intertwined. The patch fixes them both. PR122949 has been fixed by another patch somewhere along the way and the testcase ensures that it remains fixed.
The first chunk in the patch is completely obvious and it is rather surprising that it wasn't picked up earlier (mea maxima culpa!). The second chunk fixes the problems caused by moving or deleting chunks of code in the modules and, where appropriate , repositioning in the main program. The faults result from the unusual way in which pdt_types are generated from their template and are triggered when the pdt_type is first encountered in a component in a contained procedure. The third chunk delays the freeing of the destination component until after it has been made use of by being deep copied downstream. Regtested on FC43/x86_64. OK for mainline? Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 844e27f007f..ca307a62639 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -4302,6 +4302,12 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
c2->ts.u.derived->refs++;
gfc_set_sym_referenced (c2->ts.u.derived);
+ /* If the component is allocatable or the parent has allocatable
+ components, make sure that the new instance also is marked as
+ having allocatable components. */
+ if (c2->attr.allocatable || c2->ts.u.derived->attr.alloc_comp)
+ instance->attr.alloc_comp = 1;
+
/* Set extension level. */
if (c2->ts.u.derived->attr.extension == 255)
{
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index b3262729c98..ac675944aeb 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -8299,7 +8299,8 @@ gfc_generate_function_code (gfc_namespace * ns)
gfc_free_expr (init_exp);
gfc_add_expr_to_block (&init, tmp);
}
- else if (rsym->ts.u.derived->attr.alloc_comp)
+
+ if (rsym->ts.u.derived->attr.alloc_comp)
{
rank = rsym->as ? rsym->as->rank : 0;
tmp = gfc_nullify_alloc_comp (rsym->ts.u.derived, result,
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index cc32d5dbb64..7949d936078 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9681,12 +9681,15 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &se.post);
- if (final_block && expr->expr_type == EXPR_ARRAY)
+ if (final_block && !cm->attr.allocatable
+ && expr->expr_type == EXPR_ARRAY)
{
tree data_ptr;
data_ptr = gfc_conv_descriptor_data_get (dest);
gfc_add_expr_to_block (final_block, gfc_call_free (data_ptr));
}
+ else if (final_block && cm->attr.allocatable)
+ gfc_add_block_to_block (final_block, &se.finalblock);
if (expr->expr_type != EXPR_VARIABLE)
gfc_conv_descriptor_data_set (&block, se.expr,
diff --git a/gcc/testsuite/gfortran.dg/pdt_82.f03 b/gcc/testsuite/gfortran.dg/pdt_82.f03
new file mode 100644
index 00000000000..123cad44818
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_82.f03
@@ -0,0 +1,112 @@
+! { dg-do run }
+!
+! Test the fix for pr123545, which caused the errors below. Although some of thses errors are
+! not checked here, it has been verified that they are fixed by the patch for the main fault.
+!
+! Contributed by Damian Rouson <[email protected]>
+!
+module julienne_m
+ implicit none
+
+ type string_t
+ character(len=:), allocatable :: string_
+ end type
+
+ type file_t
+ type(string_t), allocatable :: lines_(:)
+ end type
+
+ interface file_t ! If this generic interface was removed, a
+ module procedure from_lines ! segmentation fault resulted during or just after
+ end interface ! the first executable statement in the main program.
+
+contains
+
+ function get_json_value(self ) result(value_)
+ type(string_t), intent(in) :: self
+ real value_
+ read(self%string_, fmt=*) value_
+! print *," value_ ", value_
+ end function
+
+ pure function from_lines(lines) result(file_object)
+ type(string_t), intent(in) :: lines(:)
+ type(file_t) file_object
+ file_object%lines_ = lines
+ end function
+
+end module
+
+module fiats_m
+ use julienne_m
+ implicit none
+
+ type hyperparameters_t(k)
+ integer, kind :: k = kind(1.)
+ real(k) :: learning_rate_ = real(1.5,k)
+ end type
+
+ interface hyperparameters_t
+ module procedure hyperparameters_from_json
+ end interface
+
+ type, extends(file_t) :: training_configuration_t(m)
+ integer, kind :: m = kind(1.)
+ type(hyperparameters_t(m)) hyperparameters_
+ end type
+
+contains
+
+ function hyperparameters_from_json(lines) result(hyperparameters)
+ type(string_t), intent(in) :: lines(:)
+ type(hyperparameters_t) hyperparameters
+ hyperparameters%learning_rate_ = get_json_value(lines(1))
+ end function
+
+ pure function hyperparameters_to_json(self) result(lines)
+ type(hyperparameters_t), intent(in) :: self
+ type(string_t), allocatable :: lines(:)
+ integer, parameter :: max_width= 18
+ character(len=max_width) learning_rate_string
+ write(learning_rate_string,*) self%learning_rate_
+ lines = [string_t(learning_rate_string)]
+ end function
+
+ pure function training_configuration_from_components(hyperparameters) result(training_configuration)
+ type(hyperparameters_t), intent(in) :: hyperparameters
+ type(training_configuration_t) training_configuration
+ training_configuration%hyperparameters_ = hyperparameters
+ training_configuration%file_t = file_t([hyperparameters_to_json(training_configuration%hyperparameters_)])
+ end function
+
+ function training_configuration_from_file(line) result(training_configuration)
+ character(len=*), intent(in) :: line
+ type(training_configuration_t) training_configuration
+ training_configuration%file_t = file_t([string_t(line)])
+ training_configuration%hyperparameters_ = hyperparameters_from_json(training_configuration%file_t%lines_)
+ end function
+
+end module
+
+ use fiats_m
+ implicit none
+
+ call test
+
+contains
+
+ subroutine test
+ type(training_configuration_t) training_configuration, from_json
+
+ training_configuration = training_configuration_from_components(hyperparameters_t(learning_rate_=1.))
+
+ ! Removing the above assignment eliminated the segmentation fault even though the segmentation fault
+ ! occured when executing the assignment below, which does not reference the object defined above.
+ ! Alternatively, changing the above line to an `associate` statement gave the compile-time
+ ! message: "Error: Invalid kind for REAL at (1)", where the "1" is between `use` and `fiats_m` in
+ ! the above use statement.
+
+ from_json = training_configuration_from_file('1.00000000')
+ if (int (1d6 * from_json%hyperparameters_%learning_rate_) /= 1000000) stop 1
+ end
+end
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/pdt_83.f03 b/gcc/testsuite/gfortran.dg/pdt_83.f03
new file mode 100644
index 00000000000..ab054a26aad
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_83.f03
@@ -0,0 +1,105 @@
+! { dg-do run }
+!
+! Test the fix for pr123673, which caused the errors below. Although some of thses errors are
+! not checked here, it has been verified that they are fixed by the patch for the main fault.
+!
+! Contributed by Damian Rouson <[email protected]>
+!
+module input_output_pair_m
+ implicit none
+
+ ! Moving the contents of this module to the main program caused several
+ ! compile-time errors that do not occur with other brands.
+
+ type tensor_t(k)
+ integer, kind :: k = kind(1.)
+ real(k), allocatable :: values_(:)
+ end type
+
+ type input_output_pair_t(k)
+ integer, kind :: k = kind(1.)
+ type(tensor_t(k)) inputs_, expected_outputs_
+ end type
+
+contains
+
+ ! Moving just the function below to become an internal subprogram in the main program
+ ! caused similar compile-time errors to those mentioned above
+
+ type(input_output_pair_t) elemental function input_output_pair(inputs, expected_outputs)
+ type(tensor_t), intent(in) :: inputs, expected_outputs
+ input_output_pair%inputs_ = inputs
+ input_output_pair%expected_outputs_ = expected_outputs
+ end function
+
+end module
+
+program trainable_network_test
+ use input_output_pair_m
+ implicit none
+
+ type bin_t
+ integer first_, last_
+ end type
+
+ ! Removing the mini_batch_t's all instances of 'k' below caused
+ ! the following compile-time error on the above 'use' statement:
+ ! "Cannot convert TYPE(input_output_pair_t) to TYPE(Pdtinput_output_pair_t_4) at (1)",
+ ! where "1" is positiioned just after 'use'
+
+ type mini_batch_t(k)
+ integer, kind :: k = kind(1.)
+ type(input_output_pair_t(k)), allocatable :: input_output_pairs_(:)
+ end type
+
+ type(input_output_pair_t), allocatable :: input_output_pairs(:)
+ type(bin_t), allocatable :: bins(:)
+ type(mini_batch_t) mini_batch_1
+ integer, parameter :: num_pairs = 10 ! 7 is the mininum value that causes segmentation fault
+ integer, parameter :: n_bins = 5 ! 2 is the mininum value that causes segmentation fault
+ integer p, b
+
+ input_output_pairs = input_output_pair( &
+ [(tensor_t([real (p, kind (1.0)), &
+ real (p *10, kind (1.0))]), p = 1, num_pairs)], &
+ [(tensor_t([real (p *20, kind (1.0)), &
+ real (p *30, kind (1.0))]), p = 1, num_pairs)])
+ bins = [(bin(num_pairs, n_bins, b), b = 1, n_bins)]
+
+ ! The assignment statement below caused a segmentation fault with gfortran.
+ ! Converting the assignment to an 'associate' statement also caused a seg fault.
+
+ mini_batch_1 = mini_batch(input_output_pairs(bins(n_bins)%first_:bins(n_bins)%last_))
+
+ if (any (mini_batch_1%input_output_pairs_(bins(1)%first_)%inputs_%values_ /= [9.0, 90.0])) stop 1
+ if (any (mini_batch_1%input_output_pairs_(bins(1)%last_)%inputs_%values_ /= [10.0, 100.0])) stop 2
+
+ associate (mini_batch_2 => &
+ mini_batch(input_output_pairs(bins(n_bins-1)%first_:bins(n_bins-1)%last_)))
+ if (any (mini_batch_2%input_output_pairs_(bins(1)%first_)%inputs_%values_ /= [7.0, 70.0])) stop 3
+ if (any (mini_batch_2%input_output_pairs_(bins(1)%last_)%inputs_%values_ /= [8.0, 80.0])) stop 4
+ end associate
+
+ deallocate (bins, input_output_pairs, mini_batch_1%input_output_pairs_)
+
+contains
+
+ type(bin_t) function bin(num_items, num_bins, bin_number)
+ integer num_items, num_bins, bin_number
+ associate(remainder => mod(num_items, num_bins), items_per_bin => num_items/num_bins)
+ if (bin_number <= remainder) then
+ bin%first_ = 1 + (bin_number-1)*(items_per_bin+1)
+ bin%last_ = bin_number*(items_per_bin+1)
+ else
+ bin%first_ = 1 + (remainder-1)*(items_per_bin+1) + 1 + (bin_number-remainder)*items_per_bin
+ bin%last_ = remainder*(items_per_bin+1) + (bin_number-remainder)*items_per_bin
+ end if
+ end associate
+ end function
+
+ type(mini_batch_t) function mini_batch(input_output_pairs)
+ type(input_output_pair_t) input_output_pairs(:)
+ mini_batch%input_output_pairs_ = input_output_pairs
+ end function
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/pr122949.f90 b/gcc/testsuite/gfortran.dg/pr122949.f90
new file mode 100644
index 00000000000..ead8e9f0f78
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr122949.f90
@@ -0,0 +1,44 @@
+! { dg-do compile }
+!
+! PR122949 used to fail at line 40
+!
+! Contributed by Damian Rouson <[email protected]>
+!
+module tensors_m
+ implicit none
+
+ type scalar_t
+ contains
+ generic :: operator(.grad.) => grad
+ procedure grad
+ end type
+
+ type vector_t
+ contains
+ procedure grid
+ end type
+
+contains
+ function grad(self) result(gradient)
+ class(scalar_t), intent(in) :: self
+ type(vector_t) gradient
+ gradient = vector_t()
+ end function
+
+ function grid(self) result(x)
+ class(vector_t) self
+ real x
+ x = 42.0
+ end function
+end module
+
+ use tensors_m
+ implicit none
+ type(scalar_t) :: s = scalar_t()
+
+ associate(grad_s => .grad. s)
+ associate(grad_s_grid => grad_s%grid()) ! "Error: Invalid association target at (1)"
+ if (int (grad_s_grid) /= 42) stop 1
+ end associate
+ end associate
+end
