Imagelibrary/binutils-gdb
1
0
Fork 1
mirror of https://github.com/bminor/binutils-gdb.git synced 2025-12-27 09:38:57 +00:00
Code Issues Packages Projects Releases Wiki Activity

gdb/fotran: add support for the 'shape' keyword

Browse Source 
Add support for the SHAPE keyword to GDB's Fortran expression parser.

gdb/ChangeLog:

	* f-exp.h (eval_op_f_array_shape): Declare.
	(fortran_array_shape_operation): New type.
	* f-exp.y (exp): Handle UNOP_FORTRAN_SHAPE after parsing
	UNOP_INTRINSIC.
	(f77_keywords): Add "shape" keyword.
	* f-lang.c (fortran_array_shape): New function.
	(eval_op_f_array_shape): New function.
	* std-operator.def (UNOP_FORTRAN_SHAPE): New operator.

gdb/testsuite/ChangeLog:

	* gdb.fortran/shape.exp: New file.
	* gdb.fortran/shape.f90: New file.
This commit is contained in:
Andrew Burgess
2021-02-26 11:14:24 +00:00
parent 7ba155b370
commit eef32f5998
8 changed files with 277 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

11
gdb/ChangeLog
View File

@@ -1,3 +1,14 @@
2021-03-09 Andrew Burgess <andrew.burgess@embecosm.com>
* f-exp.h (eval_op_f_array_shape): Declare.
(fortran_array_shape_operation): New type.
* f-exp.y (exp): Handle UNOP_FORTRAN_SHAPE after parsing
UNOP_INTRINSIC.
(f77_keywords): Add "shape" keyword.
* f-lang.c (fortran_array_shape): New function.
(eval_op_f_array_shape): New function.
* std-operator.def (UNOP_FORTRAN_SHAPE): New operator.
2021-03-09 Andrew Burgess <andrew.burgess@embecosm.com>
* f-exp.y (eval_op_f_array_size): Declare 1 and 2 argument forms

12
gdb/f-exp.h
View File

@@ -108,6 +108,16 @@ extern struct value *eval_op_f_array_size (struct type *expect_type,
struct value *arg1,
struct value *arg2);
/* Implement the evaluation of Fortran's SHAPE keyword. EXPECTED_TYPE,
EXP, and NOSIDE are as for expression::evaluate (see expression.h). OP
will always be UNOP_FORTRAN_SHAPE, and ARG1 is the argument being passed
to the expression. */
extern struct value *eval_op_f_array_shape (struct type *expect_type,
struct expression *exp,
enum noside noside,
enum exp_opcode op,
struct value *arg1);
namespace expr
{
@@ -135,6 +145,8 @@ using fortran_array_size_1arg = unop_operation<FORTRAN_ARRAY_SIZE,
eval_op_f_array_size>;
using fortran_array_size_2arg = binop_operation<FORTRAN_ARRAY_SIZE,
eval_op_f_array_size>;
using fortran_array_shape_operation = unop_operation<UNOP_FORTRAN_SHAPE,
eval_op_f_array_shape>;
/* The Fortran "complex" operation. */
class fortran_cmplx_operation

4
gdb/f-exp.y
View File

@@ -330,6 +330,9 @@ exp : UNOP_INTRINSIC '(' exp ')'
case UNOP_FORTRAN_RANK:
pstate->wrap<fortran_rank_operation> ();
break;
case UNOP_FORTRAN_SHAPE:
pstate->wrap<fortran_array_shape_operation> ();
break;
default:
gdb_assert_not_reached ("unhandled intrinsic");
}
@@ -1151,6 +1154,7 @@ static const struct token f77_keywords[] =
{ "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false },
{ "rank", UNOP_INTRINSIC, UNOP_FORTRAN_RANK, false },
{ "size", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ARRAY_SIZE, false },
{ "shape", UNOP_INTRINSIC, UNOP_FORTRAN_SHAPE, false },
};
/* Implementation of a dynamically expandable buffer for processing input

81
gdb/f-lang.c
View File

@@ -675,6 +675,87 @@ eval_op_f_array_size (struct type *expect_type,
return fortran_array_size (exp->gdbarch, exp->language_defn, arg1, arg2);
}
/* Implement UNOP_FORTRAN_SHAPE expression. Both GDBARCH and LANG are
extracted from the expression being evaluated. VAL is the value on
which 'shape' was used, this can be any type.
Return an array of integers. If VAL is not an array then the returned
array should have zero elements. If VAL is an array then the returned
array should have one element per dimension, with the element
containing the extent of that dimension from VAL. */
static struct value *
fortran_array_shape (struct gdbarch *gdbarch, const language_defn *lang,
struct value *val)
{
struct type *val_type = check_typedef (value_type (val));
/* If we are passed an array that is either not allocated, or not
associated, then this is explicitly not allowed according to the
Fortran specification. */
if (val_type->code () == TYPE_CODE_ARRAY
&& (type_not_associated (val_type) || type_not_allocated (val_type)))
error (_("The array passed to SHAPE must be allocated or associated"));
/* The Fortran specification allows non-array types to be passed to this
function, in which case we get back an empty array.
Calculate the number of dimensions for the resulting array. */
int ndimensions = 0;
if (val_type->code () == TYPE_CODE_ARRAY)
ndimensions = calc_f77_array_dims (val_type);
/* Allocate a result value of the correct type. */
struct type *range
= create_static_range_type (nullptr,
builtin_type (gdbarch)->builtin_int,
1, ndimensions);
struct type *elm_type = builtin_f_type (gdbarch)->builtin_integer;
struct type *result_type = create_array_type (nullptr, elm_type, range);
struct value *result = allocate_value (result_type);
LONGEST elm_len = TYPE_LENGTH (elm_type);
/* Walk the array dimensions backwards due to the way the array will be
laid out in memory, the first dimension will be the most inner.
If VAL was not an array then ndimensions will be 0, in which case we
will never go around this loop. */
for (LONGEST dst_offset = elm_len * (ndimensions - 1);
dst_offset >= 0;
dst_offset -= elm_len)
{
LONGEST lbound, ubound;
if (!get_discrete_bounds (val_type->index_type (), &lbound, &ubound))
error (_("failed to find array bounds"));
LONGEST dim_size = (ubound - lbound + 1);
/* And copy the value into the result value. */
struct value *v = value_from_longest (elm_type, dim_size);
gdb_assert (dst_offset + TYPE_LENGTH (value_type (v))
<= TYPE_LENGTH (value_type (result)));
gdb_assert (TYPE_LENGTH (value_type (v)) == elm_len);
value_contents_copy (result, dst_offset, v, 0, elm_len);
/* Peel another dimension of the array. */
val_type = TYPE_TARGET_TYPE (val_type);
}
return result;
}
/* See f-exp.h. */
struct value *
eval_op_f_array_shape (struct type *expect_type, struct expression *exp,
enum noside noside, enum exp_opcode opcode,
struct value *arg1)
{
gdb_assert (opcode == UNOP_FORTRAN_SHAPE);
return fortran_array_shape (exp->gdbarch, exp->language_defn, arg1);
}
/* A helper function for UNOP_ABS. */
struct value *

1
gdb/std-operator.def
View File

@@ -379,6 +379,7 @@ OP (UNOP_FORTRAN_FLOOR)
OP (UNOP_FORTRAN_CEILING)
OP (UNOP_FORTRAN_ALLOCATED)
OP (UNOP_FORTRAN_RANK)
OP (UNOP_FORTRAN_SHAPE)
/* Two operand builtins. */
OP (BINOP_FORTRAN_CMPLX)

5
gdb/testsuite/ChangeLog
View File

@@ -1,3 +1,8 @@
2021-03-09 Andrew Burgess <andrew.burgess@embecosm.com>
* gdb.fortran/shape.exp: New file.
* gdb.fortran/shape.f90: New file.
2021-03-09 Andrew Burgess <andrew.burgess@embecosm.com>
* gdb.fortran/size.exp: New file.

86
gdb/testsuite/gdb.fortran/shape.exp Normal file
View File

@@ -0,0 +1,86 @@
# Copyright 2021 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/> .
# Testing GDB's implementation of SHAPE keyword.
if {[skip_fortran_tests]} { return -1 }
standard_testfile ".f90"
load_lib fortran.exp
if {[prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
{debug f90}]} {
return -1
}
if ![fortran_runto_main] {
untested "could not run to main"
return -1
}
gdb_breakpoint [gdb_get_line_number "Test Breakpoint"]
gdb_breakpoint [gdb_get_line_number "Final Breakpoint"]
# We place a limit on the number of tests that can be run, just in
# case something goes wrong, and GDB gets stuck in an loop here.
set found_final_breakpoint false
set test_count 0
while { $test_count < 500 } {
with_test_prefix "test $test_count" {
incr test_count
gdb_test_multiple "continue" "continue" {
-re -wrap "! Test Breakpoint" {
# We can run a test from here.
}
-re -wrap "! Final Breakpoint" {
# We're done with the tests.
set found_final_breakpoint true
}
}
if ($found_final_breakpoint) {
break
}
# First grab the expected answer.
set answer [get_valueof "" "answer" "**unknown**"]
# Now move up a frame and figure out a command for us to run
# as a test.
set command ""
gdb_test_multiple "up" "up" {
-re -wrap "\r\n\[0-9\]+\[ \t\]+call test_shape \\((\[^\r\n\]+)\\)" {
set command $expect_out(1,string)
}
}
gdb_assert { ![string equal $command ""] } "found a command to run"
set answer [string_to_regexp $answer]
gdb_test "p $command" " = $answer"
}
}
# Ensure we reached the final breakpoint. If more tests have been added
# to the test script, and this starts failing, then the safety 'while'
# loop above might need to be increased.
gdb_assert {$found_final_breakpoint} "ran all compiled in tests"
foreach var {array_1d_p array_2d_p allocatable_array_1d \
allocatable_array_2d} {
gdb_test "p shape ($var)" \
"The array passed to SHAPE must be allocated or associated"
}

77
gdb/testsuite/gdb.fortran/shape.f90 Normal file
View File

@@ -0,0 +1,77 @@
! Copyright 2021 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/>.
!
! Start of test program.
!
program test
! Things to perform tests on.
integer, target :: array_1d (1:10) = 0
integer, target :: array_2d (1:4, 1:3) = 0
integer :: an_integer = 0
real :: a_real = 0.0
integer, pointer :: array_1d_p (:) => null ()
integer, pointer :: array_2d_p (:,:) => null ()
integer, allocatable :: allocatable_array_1d (:)
integer, allocatable :: allocatable_array_2d (:,:)
call test_shape (shape (array_1d))
call test_shape (shape (array_2d))
call test_shape (shape (an_integer))
call test_shape (shape (a_real))
call test_shape (shape (array_1d (1:10:2)))
call test_shape (shape (array_1d (1:10:3)))
call test_shape (shape (array_2d (4:1:-1, 3:1:-1)))
call test_shape (shape (array_2d (4:1:-1, 1:3:2)))
allocate (allocatable_array_1d (-10:-5))
allocate (allocatable_array_2d (-3:3, 8:12))
call test_shape (shape (allocatable_array_1d))
call test_shape (shape (allocatable_array_2d))
call test_shape (shape (allocatable_array_2d (-2, 10:12)))
array_1d_p => array_1d
array_2d_p => array_2d
call test_shape (shape (array_1d_p))
call test_shape (shape (array_2d_p))
deallocate (allocatable_array_1d)
deallocate (allocatable_array_2d)
array_1d_p => null ()
array_2d_p => null ()
print *, "" ! Final Breakpoint
print *, an_integer
print *, a_real
print *, associated (array_1d_p)
print *, associated (array_2d_p)
print *, allocated (allocatable_array_1d)
print *, allocated (allocatable_array_2d)
contains
subroutine test_shape (answer)
integer, dimension (:) :: answer
print *,answer ! Test Breakpoint
end subroutine test_shape
end program test