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)
{
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,
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,
--- /dev/null
+! { 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 <damian@archaeologic.codes>
+!
+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
--- /dev/null
+! { 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 <damian@archaeologic.codes>
+!
+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
--- /dev/null
+! { dg-do compile }
+!
+! PR122949 used to fail at line 40
+!
+! Contributed by Damian Rouson <damian@archaeologic.codes>
+!
+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
projects / thirdparty / gcc.git / commitdiff
