gdb/fortran: add support for 'SIZE' keyword

Add support for the 'SIZE' keyword to the Fortran expression parser.
This returns the number of elements either in an entire array (passing
a single argument to SIZE), or in a particular dimension of an
array (passing two arguments to SIZE).

At this point I have not added support for the optional third argument
to SIZE, which controls the exact integer type of the result.

gdb/ChangeLog:

	* f-exp.y (eval_op_f_array_size): Declare 1 and 2 argument forms
	of this function.
	(expr::fortran_array_size_1arg): New type.
	(expr::fortran_array_size_2arg): Likewise.
	* f-exp.y (exp): Handle FORTRAN_ARRAY_SIZE after parsing
	UNOP_OR_BINOP_INTRINSIC.
	(f77_keywords): Add "size" keyword.
	* f-lang.c (fortran_array_size): New function.
	(eval_op_f_array_size): New function, has a 1 arg and 2 arg form.
	* std-operator.def (FORTRAN_ARRAY_SIZE): New operator.

gdb/testsuite/ChangeLog:

	* gdb.fortran/size.exp: New file.
	* gdb.fortran/size.f90: New file.

8 files changed, 359 insertions, 0 deletions

diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index 59638cc..0a16353 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,5 +1,18 @@
 2021-03-09  Andrew Burgess  <andrew.burgess@embecosm.com>
 
+	* f-exp.y (eval_op_f_array_size): Declare 1 and 2 argument forms
+	of this function.
+	(expr::fortran_array_size_1arg): New type.
+	(expr::fortran_array_size_2arg): Likewise.
+	* f-exp.y (exp): Handle FORTRAN_ARRAY_SIZE after parsing
+	UNOP_OR_BINOP_INTRINSIC.
+	(f77_keywords): Add "size" keyword.
+	* f-lang.c (fortran_array_size): New function.
+	(eval_op_f_array_size): New function, has a 1 arg and 2 arg form.
+	* std-operator.def (FORTRAN_ARRAY_SIZE): New operator.
+
+2021-03-09  Andrew Burgess  <andrew.burgess@embecosm.com>
+
 	* f-exp.h (eval_op_f_rank): Declare.
 	(expr::fortran_rank_operation): New typedef.
 	* f-exp.y (exp): Handle UNOP_FORTRAN_RANK after parsing an
diff --git a/gdb/f-exp.h b/gdb/f-exp.h
index f23c426..fc46c12 100644
--- a/gdb/f-exp.h
+++ b/gdb/f-exp.h
@@ -85,6 +85,30 @@ extern struct value *eval_op_f_rank (struct type *expect_type,
 				     enum exp_opcode op,
 				     struct value *arg1);
 
+/* Implement expression evaluation for Fortran's SIZE keyword. For
+   EXPECT_TYPE, EXP, and NOSIDE see expression::evaluate (in
+   expression.h).  OP will always for FORTRAN_ARRAY_SIZE.  ARG1 is the
+   value passed to SIZE if it is only passed a single argument.  For the
+   two argument form see the overload of this function below.  */
+
+extern struct value *eval_op_f_array_size (struct type *expect_type,
+					   struct expression *exp,
+					   enum noside noside,
+					   enum exp_opcode opcode,
+					   struct value *arg1);
+
+/* An overload of EVAL_OP_F_ARRAY_SIZE above, this version takes two
+   arguments, representing the two values passed to Fortran's SIZE
+   keyword.  */
+
+extern struct value *eval_op_f_array_size (struct type *expect_type,
+					   struct expression *exp,
+					   enum noside noside,
+					   enum exp_opcode opcode,
+					   struct value *arg1,
+					   struct value *arg2);
+
+
 namespace expr
 {
 
@@ -107,6 +131,10 @@ using fortran_associated_2arg = binop_operation<FORTRAN_ASSOCIATED,
 						eval_op_f_associated>;
 using fortran_rank_operation = unop_operation<UNOP_FORTRAN_RANK,
 					      eval_op_f_rank>;
+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>;
 
 /* The Fortran "complex" operation.  */
 class fortran_cmplx_operation
diff --git a/gdb/f-exp.y b/gdb/f-exp.y
index 02e35c8..e652bd9 100644
--- a/gdb/f-exp.y
+++ b/gdb/f-exp.y
@@ -260,6 +260,13 @@ exp	:	UNOP_OR_BINOP_INTRINSIC '('
 			      else
 				pstate->wrap2<fortran_associated_2arg> ();
 			    }
+			  else if ($1 == FORTRAN_ARRAY_SIZE)
+			    {
+			      if (n == 1)
+				pstate->wrap<fortran_array_size_1arg> ();
+			      else
+				pstate->wrap2<fortran_array_size_2arg> ();
+			    }
 			  else
 			    {
 			      std::vector<operation_up> args
@@ -1143,6 +1150,7 @@ static const struct token f77_keywords[] =
   { "allocated", UNOP_INTRINSIC, UNOP_FORTRAN_ALLOCATED, false },
   { "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false },
   { "rank", UNOP_INTRINSIC, UNOP_FORTRAN_RANK, false },
+  { "size", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ARRAY_SIZE, false },
 };
 
 /* Implementation of a dynamically expandable buffer for processing input
diff --git a/gdb/f-lang.c b/gdb/f-lang.c
index d30b13d..a33aef3 100644
--- a/gdb/f-lang.c
+++ b/gdb/f-lang.c
@@ -578,6 +578,103 @@ eval_op_f_associated (struct type *expect_type,
   return fortran_associated (exp->gdbarch, exp->language_defn, arg1, arg2);
 }
 
+/* Implement FORTRAN_ARRAY_SIZE expression, this corresponds to the 'SIZE'
+   keyword.  Both GDBARCH and LANG are extracted from the expression being
+   evaluated.  ARRAY is the value that should be an array, though this will
+   not have been checked before calling this function.  DIM is optional, if
+   present then it should be an integer identifying a dimension of the
+   array to ask about.  As with ARRAY the validity of DIM is not checked
+   before calling this function.
+
+   Return either the total number of elements in ARRAY (when DIM is
+   nullptr), or the number of elements in dimension DIM.  */
+
+static struct value *
+fortran_array_size (struct gdbarch *gdbarch, const language_defn *lang,
+		    struct value *array, struct value *dim_val = nullptr)
+{
+  /* Check that ARRAY is the correct type.  */
+  struct type *array_type = check_typedef (value_type (array));
+  if (array_type->code () != TYPE_CODE_ARRAY)
+    error (_("SIZE can only be applied to arrays"));
+  if (type_not_allocated (array_type) || type_not_associated (array_type))
+    error (_("SIZE can only be used on allocated/associated arrays"));
+
+  int ndimensions = calc_f77_array_dims (array_type);
+  int dim = -1;
+  LONGEST result = 0;
+
+  if (dim_val != nullptr)
+    {
+      if (check_typedef (value_type (dim_val))->code () != TYPE_CODE_INT)
+	error (_("DIM argument to SIZE must be an integer"));
+      dim = (int) value_as_long (dim_val);
+
+      if (dim < 1 || dim > ndimensions)
+	error (_("DIM argument to SIZE must be between 1 and %d"),
+	       ndimensions);
+    }
+
+  /* Now walk over all the dimensions of the array totalling up the
+     elements in each dimension.  */
+  for (int i = ndimensions - 1; i >= 0; --i)
+    {
+      /* If this is the requested dimension then we're done.  Grab the
+	 bounds and return.  */
+      if (i == dim - 1 || dim == -1)
+	{
+	  LONGEST lbound, ubound;
+	  struct type *range = array_type->index_type ();
+
+	  if (!get_discrete_bounds (range, &lbound, &ubound))
+	    error (_("failed to find array bounds"));
+
+	  LONGEST dim_size = (ubound - lbound + 1);
+	  if (result == 0)
+	    result = dim_size;
+	  else
+	    result *= dim_size;
+
+	  if (dim != -1)
+	    break;
+	}
+
+      /* Peel off another dimension of the array.  */
+      array_type = TYPE_TARGET_TYPE (array_type);
+    }
+
+  struct type *result_type
+    = builtin_f_type (gdbarch)->builtin_integer;
+  return value_from_longest (result_type, result);
+}
+
+/* See f-exp.h.  */
+
+struct value *
+eval_op_f_array_size (struct type *expect_type,
+		      struct expression *exp,
+		      enum noside noside,
+		      enum exp_opcode opcode,
+		      struct value *arg1)
+{
+  gdb_assert (opcode == FORTRAN_ARRAY_SIZE);
+  return fortran_array_size (exp->gdbarch, exp->language_defn, arg1);
+}
+
+/* See f-exp.h.  */
+
+struct value *
+eval_op_f_array_size (struct type *expect_type,
+		      struct expression *exp,
+		      enum noside noside,
+		      enum exp_opcode opcode,
+		      struct value *arg1,
+		      struct value *arg2)
+{
+  gdb_assert (opcode == FORTRAN_ARRAY_SIZE);
+  return fortran_array_size (exp->gdbarch, exp->language_defn, arg1, arg2);
+}
+
 /* A helper function for UNOP_ABS.  */
 
 struct value *
diff --git a/gdb/std-operator.def b/gdb/std-operator.def
index 158bd24..b67247f 100644
--- a/gdb/std-operator.def
+++ b/gdb/std-operator.def
@@ -388,3 +388,4 @@ OP (BINOP_FORTRAN_MODULO)
 OP (FORTRAN_LBOUND)
 OP (FORTRAN_UBOUND)
 OP (FORTRAN_ASSOCIATED)
+OP (FORTRAN_ARRAY_SIZE)
\ No newline at end of file
diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog
index f221157..00a7133 100644
--- a/gdb/testsuite/ChangeLog
+++ b/gdb/testsuite/ChangeLog
@@ -1,5 +1,10 @@
 2021-03-09  Andrew Burgess  <andrew.burgess@embecosm.com>
 
+	* gdb.fortran/size.exp: New file.
+	* gdb.fortran/size.f90: New file.
+
+2021-03-09  Andrew Burgess  <andrew.burgess@embecosm.com>
+
 	* gdb.fortran/rank.exp: New file.
 	* gdb.fortran/rank.f90: New file.
 
diff --git a/gdb/testsuite/gdb.fortran/size.exp b/gdb/testsuite/gdb.fortran/size.exp
new file mode 100644
index 0000000..20a9b27
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/size.exp
@@ -0,0 +1,89 @@
+# 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 SIZE 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_size \\((\[^\r\n\]+)\\)" {
+		set command $expect_out(1,string)
+	    }
+	}
+
+	gdb_assert { ![string equal $command ""] } "found a command to run"
+
+	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 size ($var)" \
+	"SIZE can only be used on allocated/associated arrays"
+}
+
+foreach var {an_integer a_real} {
+    gdb_test "p size ($var)" "SIZE can only be applied to arrays"
+}
diff --git a/gdb/testsuite/gdb.fortran/size.f90 b/gdb/testsuite/gdb.fortran/size.f90
new file mode 100644
index 0000000..4b556a7
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/size.f90
@@ -0,0 +1,118 @@
+! 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 (:,:)
+
+  ! Loop counters.
+  integer :: s1, s2
+
+  ! The start of the tests.
+  call test_size (size (array_1d))
+  call test_size (size (array_1d, 1))
+  do s1=1, SIZE (array_1d, 1), 1
+     call test_size (size (array_1d (1:10:s1)))
+     call test_size (size (array_1d (1:10:s1), 1))
+     call test_size (size (array_1d (10:1:-s1)))
+     call test_size (size (array_1d (10:1:-s1), 1))
+  end do
+
+  do s2=1, SIZE (array_2d, 2), 1
+     do s1=1, SIZE (array_2d, 1), 1
+        call test_size (size (array_2d (1:4:s1, 1:3:s2)))
+        call test_size (size (array_2d (4:1:-s1, 1:3:s2)))
+        call test_size (size (array_2d (1:4:s1, 3:1:-s2)))
+        call test_size (size (array_2d (4:1:-s1, 3:1:-s2)))
+
+        call test_size (size (array_2d (1:4:s1, 1:3:s2), 1))
+        call test_size (size (array_2d (4:1:-s1, 1:3:s2), 1))
+        call test_size (size (array_2d (1:4:s1, 3:1:-s2), 1))
+        call test_size (size (array_2d (4:1:-s1, 3:1:-s2), 1))
+
+        call test_size (size (array_2d (1:4:s1, 1:3:s2), 2))
+        call test_size (size (array_2d (4:1:-s1, 1:3:s2), 2))
+        call test_size (size (array_2d (1:4:s1, 3:1:-s2), 2))
+        call test_size (size (array_2d (4:1:-s1, 3:1:-s2), 2))
+     end do
+  end do
+
+  allocate (allocatable_array_1d (-10:-5))
+  call test_size (size (allocatable_array_1d))
+  do s1=1, SIZE (allocatable_array_1d, 1), 1
+     call test_size (size (allocatable_array_1d (-10:-5:s1)))
+     call test_size (size (allocatable_array_1d (-5:-10:-s1)))
+
+     call test_size (size (allocatable_array_1d (-10:-5:s1), 1))
+     call test_size (size (allocatable_array_1d (-5:-10:-s1), 1))
+  end do
+
+  allocate (allocatable_array_2d (-3:3, 8:12))
+  do s2=1, SIZE (allocatable_array_2d, 2), 1
+     do s1=1, SIZE (allocatable_array_2d, 1), 1
+        call test_size (size (allocatable_array_2d (-3:3:s1, 8:12:s2)))
+        call test_size (size (allocatable_array_2d (3:-3:-s1, 8:12:s2)))
+        call test_size (size (allocatable_array_2d (-3:3:s1, 12:8:-s2)))
+        call test_size (size (allocatable_array_2d (3:-3:-s1, 12:8:-s2)))
+
+        call test_size (size (allocatable_array_2d (-3:3:s1, 8:12:s2), 1))
+        call test_size (size (allocatable_array_2d (3:-3:-s1, 8:12:s2), 2))
+        call test_size (size (allocatable_array_2d (-3:3:s1, 12:8:-s2), 1))
+        call test_size (size (allocatable_array_2d (3:-3:-s1, 12:8:-s2), 2))
+     end do
+  end do
+
+  array_1d_p => array_1d
+  call test_size (size (array_1d_p))
+  call test_size (size (array_1d_p, 1))
+
+  array_2d_p => array_2d
+  call test_size (size (array_2d_p))
+  call test_size (size (array_2d_p, 1))
+  call test_size (size (array_2d_p, 2))
+
+  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_size (answer)
+    integer :: answer
+
+    print *,answer	! Test Breakpoint
+  end subroutine test_size
+
+end program test