@@ -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);
@@ -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, const 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;
+}
@@ -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,
+ const 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 */
@@ -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
new file mode 100644
@@ -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/NNNN" *-*-*
+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"
new file mode 100644
@@ -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