From: Paul Thomas Date: Sun, 8 Feb 2026 07:59:15 +0000 (+0000) Subject: Fortran: [PDT] Fix faults in fiats runtime [PR123545,PR123673,PR122949] X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=d93c8a679b2657729229d7c833308ee6eca7bb91;p=thirdparty%2Fgcc.git Fortran: [PDT] Fix faults in fiats runtime [PR123545,PR123673,PR122949] 2026-02-08 Paul Thomas gcc/fortran PR fortran/123545 PR fortran/123673 * decl.cc (gfc_get_pdt_instance): If a pdt_type component is allocatable or has allocatable components, mark it alloc_comp. (gfc_match_decl_type_spec): Sometimes in compiling contained functions, the symtree for the constructor points to the type instead of the constructor symbol. This corrects itself later in compilation so return MATCH_YES. * trans-decl.cc (gfc_generate_function_code): Unconditionally nullify allocatable components as well as applying the default initializer. * trans-expr.cc (gfc_trans_alloc_subarray_assign): Restrict the freeing of the destination data to non-allocatable expressions and, instead, add the se finalblock to the encompassing final_ block. gcc/testsuite PR fortran/123545 * gfortran.dg/pdt_82.f03: New test. PR fortran/123673 * gfortran.dg/pdt_83.f03: New test. PR fortran/122949 * gfortran.dg/pr122949.f90: New test. --- diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 844e27f007f..e646d6b8f9a 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 +! +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..3fd9e235bdf --- /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 +! +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 +! +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