diff options
| -rw-r--r-- | gdb/ChangeLog | 17 | ||||
| -rw-r--r-- | gdb/eval.c | 15 | ||||
| -rw-r--r-- | gdb/f-lang.c | 38 | ||||
| -rw-r--r-- | gdb/f-lang.h | 33 | ||||
| -rw-r--r-- | gdb/infcall.c | 7 | ||||
| -rw-r--r-- | gdb/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.fortran/function-calls.exp | 103 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.fortran/function-calls.f90 | 242 |
8 files changed, 457 insertions, 3 deletions
diff --git a/gdb/ChangeLog b/gdb/ChangeLog index 7c4a06f..906af75 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,3 +1,20 @@ +2019-03-06 Richard Bunt <richard.bunt@arm.com> + Dirk Schubert <dirk.schubert@arm.com> + Chris January <chris.january@arm.com> + + * eval.c (evaluate_subexp_standard): Call Fortran argument + wrapping logic. + * f-lang.c (struct value): A value which can be passed into a + Fortran function call. + (fortran_argument_convert): Wrap Fortran arguments in a pointer + where appropriate. + (struct type): Value ready for a Fortran function call. + (fortran_preserve_arg_pointer): Undo check_typedef, the pointer + is needed. + * f-lang.h (fortran_argument_convert): Declaration. + (fortran_preserve_arg_pointer): Declaration. + * infcall.c (value_arg_coerce): Call Fortran argument logic. + 2019-03-05 Tom Tromey <tromey@adacore.com> * python/py-prettyprint.c (print_string_repr): Remove #if. @@ -1987,7 +1987,20 @@ evaluate_subexp_standard (struct type *expect_type, argvec[0] = arg1; tem = 1; for (; tem <= nargs; tem++) - argvec[tem] = evaluate_subexp_with_coercion (exp, pos, noside); + { + argvec[tem] = evaluate_subexp_with_coercion (exp, pos, noside); + /* Arguments in Fortran are passed by address. Coerce the + arguments here rather than in value_arg_coerce as otherwise + the call to malloc to place the non-lvalue parameters in + target memory is hit by this Fortran specific logic. This + results in malloc being called with a pointer to an integer + followed by an attempt to malloc the arguments to malloc in + target memory. Infinite recursion ensues. */ + bool is_artificial = + TYPE_FIELD_ARTIFICIAL (value_type (arg1), tem - 1); + argvec[tem] = fortran_argument_convert (argvec[tem], + is_artificial); + } argvec[tem] = 0; /* signal end of arglist */ if (noside == EVAL_SKIP) return eval_skip_value (exp); diff --git a/gdb/f-lang.c b/gdb/f-lang.c index 4ff828b..6eb9b23 100644 --- a/gdb/f-lang.c +++ b/gdb/f-lang.c @@ -27,6 +27,7 @@ #include "parser-defs.h" #include "language.h" #include "varobj.h" +#include "gdbcore.h" #include "f-lang.h" #include "valprint.h" #include "value.h" @@ -371,3 +372,40 @@ _initialize_f_language (void) { f_type_data = gdbarch_data_register_post_init (build_fortran_types); } + +/* See f-lang.h. */ + +struct value * +fortran_argument_convert (struct value *value, bool is_artificial) +{ + if (!is_artificial) + { + /* If the value is not in the inferior e.g. registers values, + convenience variables and user input. */ + if (VALUE_LVAL (value) != lval_memory) + { + struct type *type = value_type (value); + const int length = TYPE_LENGTH (type); + const CORE_ADDR addr + = value_as_long (value_allocate_space_in_inferior (length)); + write_memory (addr, value_contents (value), length); + struct value *val + = value_from_contents_and_address (type, value_contents (value), + addr); + return value_addr (val); + } + else + return value_addr (value); /* Program variables, e.g. arrays. */ + } + return value; +} + +/* See f-lang.h. */ + +struct type * +fortran_preserve_arg_pointer (struct value *arg, struct type *type) +{ + if (TYPE_CODE (value_type (arg)) == TYPE_CODE_PTR) + return value_type (arg); + return type; +} diff --git a/gdb/f-lang.h b/gdb/f-lang.h index a4ae6a7..5afafb1 100644 --- a/gdb/f-lang.h +++ b/gdb/f-lang.h @@ -82,4 +82,37 @@ struct builtin_f_type /* Return the Fortran type table for the specified architecture. */ extern const struct builtin_f_type *builtin_f_type (struct gdbarch *gdbarch); +/* Ensures that function argument VALUE is in the appropriate form to + pass to a Fortran function. Returns a possibly new value that should + be used instead of VALUE. + + When IS_ARTIFICIAL is true this indicates an artificial argument, + e.g. hidden string lengths which the GNU Fortran argument passing + convention specifies as being passed by value. + + When IS_ARTIFICIAL is false, the argument is passed by pointer. If the + value is already in target memory then return a value that is a pointer + to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate + space in the target, copy VALUE in, and return a pointer to the in + memory copy. */ + +extern struct value *fortran_argument_convert (struct value *value, + bool is_artificial); + +/* Ensures that function argument TYPE is appropriate to inform the debugger + that ARG should be passed as a pointer. Returns the potentially updated + argument type. + + If ARG is of type pointer then the type of ARG is returned, otherwise + TYPE is returned untouched. + + This function exists to augment the types of Fortran function call + parameters to be pointers to the reported value, when the corresponding ARG + has also been wrapped in a pointer (by fortran_argument_convert). This + informs the debugger that these arguments should be passed as a pointer + rather than as the pointed to type. */ + +extern struct type *fortran_preserve_arg_pointer (struct value *arg, + struct type *type); + #endif /* F_LANG_H */ diff --git a/gdb/infcall.c b/gdb/infcall.c index e58ba84..0deb37d 100644 --- a/gdb/infcall.c +++ b/gdb/infcall.c @@ -33,6 +33,7 @@ #include "command.h" #include "dummy-frame.h" #include "ada-lang.h" +#include "f-lang.h" #include "gdbthread.h" #include "event-top.h" #include "observable.h" @@ -130,7 +131,7 @@ show_unwind_on_terminating_exception_p (struct ui_file *file, int from_tty, } /* Perform the standard coercions that are specified - for arguments to be passed to C or Ada functions. + for arguments to be passed to C, Ada or Fortran functions. If PARAM_TYPE is non-NULL, it is the expected parameter type. IS_PROTOTYPED is non-zero if the function declaration is prototyped. @@ -146,9 +147,11 @@ value_arg_coerce (struct gdbarch *gdbarch, struct value *arg, struct type *type = param_type ? check_typedef (param_type) : arg_type; - /* Perform any Ada-specific coercion first. */ + /* Perform any Ada- and Fortran-specific coercion first. */ if (current_language->la_language == language_ada) arg = ada_convert_actual (arg, type); + else if (current_language->la_language == language_fortran) + type = fortran_preserve_arg_pointer (arg, type); /* Force the value to the target if we will need its address. At this point, we could allocate arguments on the stack instead of diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog index 8805fd9..5f2100b 100644 --- a/gdb/testsuite/ChangeLog +++ b/gdb/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2019-03-06 Richard Bunt <richard.bunt@arm.com> + + * gdb.fortran/function-calls.exp: New file. + * gdb.fortran/function-calls.f90: New test. + 2019-03-04 Richard Bunt <richard.bunt@arm.com> * gdb.fortran/short-circuit-argument-list.exp: Remove reliance diff --git a/gdb/testsuite/gdb.fortran/function-calls.exp b/gdb/testsuite/gdb.fortran/function-calls.exp new file mode 100644 index 0000000..9db889a --- /dev/null +++ b/gdb/testsuite/gdb.fortran/function-calls.exp @@ -0,0 +1,103 @@ +# Copyright 2019 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see <http://www.gnu.org/licenses/> . + +# Exercise passing and returning arguments in Fortran. This test case +# is based on the GNU Fortran Argument passing conventions. + +if {[skip_fortran_tests]} { return -1 } + +standard_testfile ".f90" + +if {[prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} {debug f90}]} { + return -1 +} + +if {![runto [gdb_get_line_number "post_init"]]} then { + perror "couldn't run to breakpoint post_init" + continue +} + +# Use inspired by gdb.base/callfuncs.exp. +gdb_test_no_output "set unwindonsignal on" + +# Baseline: function and subroutine call with no arguments. +gdb_test "p no_arg()" " = .TRUE." +gdb_test_no_output "call no_arg_subroutine()" + +# Argument class: literal, inferior variable, convenience variable, +# function call return value, function. +# Paragraph 3: Variables are passed by reference. +gdb_test "p one_arg(.TRUE.)" " = .TRUE." +gdb_test "p one_arg(untrue)" " = .FALSE." +gdb_test_no_output "set \$var = .FALSE." +gdb_test "p one_arg(\$var)" " = .FALSE." +gdb_test "p one_arg(one_arg(.TRUE.))" " = .TRUE." +gdb_test "p one_arg(one_arg(.FALSE.))" " = .FALSE." +gdb_test_no_output "call run(no_arg_subroutine)" + +# Return: constant. +gdb_test "p return_constant()" " = 17" +# Return derived type and call a function in a module. +gdb_test "p derived_types_and_module_calls::build_cart(7,8)" \ + " = \\\( x = 7, y = 8 \\\)" + +# Two hidden arguments. 1. returned string and 2. string length. +# Paragraph 1. +gdb_test "p return_string(returned_string_debugger, 40)" "" +gdb_test "p returned_string_debugger" "'returned in hidden first argument '" + +# Argument type: real(kind=4), complex, array, pointer, derived type, +# derived type with allocatable, nested derived type. +# Paragraph 4: pointer. +gdb_test "p pointer_function(int_pointer)" " = 87" +# Paragraph 4: array. +gdb_test "call array_function(integer_array)" " = 17" +gdb_test "p derived_types_and_module_calls::pass_cart(c)" \ + " = \\\( x = 2, y = 4 \\\)" +# Allocatable elements in a derived type. Technical report ISO/IEC 15581. +gdb_test "p derived_types_and_module_calls::pass_cart_nd(c_nd)" " = 4" +gdb_test "p derived_types_and_module_calls::pass_nested_cart(nested_c)" \ + "= \\\( d = \\\( x = 1, y = 2 \\\), z = 3 \\\)" +# Result within some tolerance. +gdb_test "p real4_argument(real4)" " = 3.${decimal}" + +# Paragraph 2. Complex argument and return. +gdb_test "p complex_argument(fft)" " = \\\(2.${decimal},3.${decimal}\\\)" + +# Function with optional arguments. +# Paragraph 10: Option reference arguments. +gdb_test "p sum_some(1,2,3)" " = 6" + +# There is currently no mechanism to call a function without all +# optional parameters present. +setup_kfail "gdb/24147" *-*-* +gdb_test "p sum_some(1,2)" " = 3" + +# Paragraph 10: optional value arguments. There is insufficient DWARF +# information to reliably make this case work. +setup_kfail "gdb/24305" *-*-* +gdb_test "p one_arg_value(10)" " = 10" + +# DW_AT_artificial formal parameters must be passed manually. This +# assert will fail if the length of the string is wrapped in a pointer. +# Paragraph 7: Character type. +gdb_test "p hidden_string_length('arbitrary string', 16)" " = 16" + +# Several arguments. +gdb_test "p several_arguments(2, 3, 5)" " = 10" +gdb_test "p mix_of_scalar_arguments(5, .TRUE., 3.5)" " = 9" + +# Calling other functions: Recursive call. +gdb_test "p fibonacci(6)" " = 8" diff --git a/gdb/testsuite/gdb.fortran/function-calls.f90 b/gdb/testsuite/gdb.fortran/function-calls.f90 new file mode 100644 index 0000000..d7bcd71 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/function-calls.f90 @@ -0,0 +1,242 @@ +! Copyright 2019 Free Software Foundation, Inc. +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see <http://www.gnu.org/licenses/> . + +! Source code for function-calls.exp. + +subroutine no_arg_subroutine() +end subroutine + +logical function no_arg() + no_arg = .TRUE. +end function + +subroutine run(a) + external :: a + call a() +end subroutine + +logical function one_arg(x) + logical, intent(in) :: x + one_arg = x +end function + +integer(kind=4) function one_arg_value(x) + integer(kind=4), value :: x + one_arg_value = x +end function + +integer(kind=4) function several_arguments(a, b, c) + integer(kind=4), intent(in) :: a + integer(kind=4), intent(in) :: b + integer(kind=4), intent(in) :: c + several_arguments = a + b + c +end function + +integer(kind=4) function mix_of_scalar_arguments(a, b, c) + integer(kind=4), intent(in) :: a + logical(kind=4), intent(in) :: b + real(kind=8), intent(in) :: c + mix_of_scalar_arguments = a + floor(c) + if (b) then + mix_of_scalar_arguments=mix_of_scalar_arguments+1 + end if +end function + +real(kind=4) function real4_argument(a) + real(kind=4), intent(in) :: a + real4_argument = a +end function + +integer(kind=4) function return_constant() + return_constant = 17 +end function + +character(40) function return_string() + return_string='returned in hidden first argument' +end function + +recursive function fibonacci(n) result(item) + integer(kind=4) :: item + integer(kind=4), intent(in) :: n + select case (n) + case (0:1) + item = n + case default + item = fibonacci(n-1) + fibonacci(n-2) + end select +end function + +complex function complex_argument(a) + complex, intent(in) :: a + complex_argument = a +end function + +integer(kind=4) function array_function(a) + integer(kind=4), dimension(11) :: a + array_function = a(ubound(a, 1, 4)) +end function + +integer(kind=4) function pointer_function(int_pointer) + integer, pointer :: int_pointer + pointer_function = int_pointer +end function + +integer(kind=4) function hidden_string_length(string) + character*(*) :: string + hidden_string_length = len(string) +end function + +integer(kind=4) function sum_some(a, b, c) + integer :: a, b + integer, optional :: c + sum_some = a + b + if (present(c)) then + sum_some = sum_some + c + end if +end function + +module derived_types_and_module_calls + type cart + integer :: x + integer :: y + end type + type cart_nd + integer :: x + integer, allocatable :: d(:) + end type + type nested_cart_3d + type(cart) :: d + integer :: z + end type +contains + type(cart) function pass_cart(c) + type(cart) :: c + pass_cart = c + end function + integer(kind=4) function pass_cart_nd(c) + type(cart_nd) :: c + pass_cart_nd = ubound(c%d,1,4) + end function + type(nested_cart_3d) function pass_nested_cart(c) + type(nested_cart_3d) :: c + pass_nested_cart = c + end function + type(cart) function build_cart(x,y) + integer :: x, y + build_cart%x = x + build_cart%y = y + end function +end module + +program function_calls + use derived_types_and_module_calls + implicit none + interface + logical function no_arg() + end function + logical function one_arg(x) + logical, intent(in) :: x + end function + integer(kind=4) function pointer_function(int_pointer) + integer, pointer :: int_pointer + end function + integer(kind=4) function several_arguments(a, b, c) + integer(kind=4), intent(in) :: a + integer(kind=4), intent(in) :: b + integer(kind=4), intent(in) :: c + end function + complex function complex_argument(a) + complex, intent(in) :: a + end function + real(kind=4) function real4_argument(a) + real(kind=4), intent(in) :: a + end function + integer(kind=4) function return_constant() + end function + character(40) function return_string() + end function + integer(kind=4) function one_arg_value(x) + integer(kind=4), value :: x + end function + integer(kind=4) function sum_some(a, b, c) + integer :: a, b + integer, optional :: c + end function + integer(kind=4) function mix_of_scalar_arguments(a, b, c) + integer(kind=4), intent(in) :: a + logical(kind=4), intent(in) :: b + real(kind=8), intent(in) :: c + end function + integer(kind=4) function array_function(a) + integer(kind=4), dimension(11) :: a + end function + integer(kind=4) function hidden_string_length(string) + character*(*) :: string + end function + end interface + logical :: untrue, no_arg_return + complex :: fft, fft_result + integer(kind=4), dimension (11) :: integer_array + real(kind=8) :: real8 + real(kind=4) :: real4 + integer, pointer :: int_pointer + integer, target :: pointee, several_arguments_return + integer(kind=4) :: integer_return + type(cart) :: c, cout + type(cart_nd) :: c_nd + type(nested_cart_3d) :: nested_c + character(40) :: returned_string, returned_string_debugger + real8 = 3.00 + real4 = 9.3 + integer_array = 17 + fft = cmplx(2.1, 3.3) + print *, fft + untrue = .FALSE. + int_pointer => pointee + pointee = 87 + c%x = 2 + c%y = 4 + c_nd%x = 4 + allocate(c_nd%d(4)) + c_nd%d = 6 + nested_c%z = 3 + nested_c%d%x = 1 + nested_c%d%y = 2 + ! Use everything so it is not elided by the compiler. + call no_arg_subroutine() + no_arg_return = no_arg() .AND. one_arg(.FALSE.) + several_arguments_return = several_arguments(1,2,3) + return_constant() + integer_return = array_function(integer_array) + integer_return = mix_of_scalar_arguments(2, untrue, real8) + real4 = real4_argument(3.4) + integer_return = pointer_function(int_pointer) + c = pass_cart(c) + integer_return = pass_cart_nd(c_nd) + nested_c = pass_nested_cart(nested_c) + integer_return = hidden_string_length('string of implicit length') + call run(no_arg_subroutine) + integer_return = one_arg_value(10) + integer_return = sum_some(1,2,3) + returned_string = return_string() + cout = build_cart(4,5) + fft_result = complex_argument(fft) + print *, cout + print *, several_arguments_return + print *, fft_result + print *, real4 + print *, integer_return + print *, returned_string_debugger + deallocate(c_nd%d) ! post_init +end program |