http://sourceware.org/ml/gdb-patches/2016-02/msg00843.html

Subject: [PATCH v2 1/6] fortran: allow multi-dimensional subarrays

From: Christoph Weinmann <christoph.t.weinmann@intel.com>

Add an argument count for subrange expressions in Fortran.

Based on the counted value calculate a new array with the

elements specified by the user.  First parse the user input,

secondly copy the desired array values into the return

array, thirdly re-create the necessary ranges and bounds.

1|  program prog

2|    integer :: ary(10,5) = (/ (i,i=1,10) (j, j=1,5) /)

3|  end program prog

(gdb) print ary(2:4,1:3)

old> Syntax error in expression near ':3'

new> $3 = ( ( 21, 31, 41) ( 22, 32, 42) ( 23, 33, 43) )

2013-11-25  Christoph Weinmann  <christoph.t.weinmann@intel.com>

	* eval.c (multi_f77_subscript): Remove function.

	* eval.c (evaluate_subrange_expr): When evaluating

	an array or string expression, call

	value_f90_subarray.

	* eval.c (value_f90_subarray): Add argument parsing

	and compute result array based on user input.

	* f-exp.y: Increment argument counter for every subrange

	expression entered by the user.

	* valops.c (value_slice): Call value_slice_1 with

	additional default argument.

	* valops.c (value_slice_1): Add functionality to

	copy and return result values based on input.

	* value.h: Add function definition.

Signed-off-by: Christoph Weinmann <christoph.t.weinmann@intel.com>

---

 gdb/eval.c   | 309 ++++++++++++++++++++++++++++++++++++++++++++++-------------

 gdb/f-exp.y  |   2 +

 gdb/valops.c | 157 ++++++++++++++++++++++++------

 gdb/value.h  |   2 +

 4 files changed, 375 insertions(+), 95 deletions(-)

diff --git a/gdb/eval.c b/gdb/eval.c

index 78ad946..c9f325f 100644

--- a/gdb/eval.c

+++ b/gdb/eval.c

@@ -399,29 +399,253 @@ init_array_element (struct value *array, struct value *element,

   return index;

 }

+/* Evaluates any operation on Fortran arrays or strings with at least

+   one user provided parameter.  Expects the input ARRAY to be either

+   an array, or a string.  Evaluates EXP by incrementing POS, and

+   writes the content from the elt stack into a local struct.  NARGS

+   specifies number of literal or range arguments the user provided.

+   NARGS must be the same number as ARRAY has dimensions.  */

+

 static struct value *

-value_f90_subarray (struct value *array,

-		    struct expression *exp, int *pos, enum noside noside)

+value_f90_subarray (struct value *array, struct expression *exp,

+		    int *pos, int nargs, enum noside noside)

 {

-  int pc = (*pos) + 1;

+  int i, dim_count = 0;

   LONGEST low_bound, high_bound;

   struct type *range = check_typedef (TYPE_INDEX_TYPE (value_type (array)));

-  enum f90_range_type range_type

-    = (enum f90_range_type) longest_to_int (exp->elts[pc].longconst);

- 

-  *pos += 3;

+  struct value *new_array = array;

+  struct type *array_type = check_typedef (value_type (new_array));

+  struct type *temp_type;

+

+  /* Local struct to hold user data for Fortran subarray dimensions.  */

+  struct subscript_store

+  {

+    /* For every dimension, we are either working on a range or an index

+       expression, so we store this info separately for later.  */

+    enum

+    {

+      SUBSCRIPT_RANGE,    /* e.g. "(lowbound:highbound)"  */

+      SUBSCRIPT_INDEX    /* e.g. "(literal)"  */

+    } kind;

+

+    /* We also store either the lower and upper bound info, or the index

+       number.  Before evaluation of the input values, we do not know if we are

+       actually working on a range of ranges, or an index in a range.  So as a

+       first step we store all input in a union.  The array calculation itself

+       deals with this later on.  */

+    union

+    {

+      struct subscript_range

+      {

+        enum f90_range_type f90_range_type;

+        LONGEST low, high;

+      }

+      range;

+      LONGEST number;

+    };

+  } *subscript_array;

+

+  /* Check if the number of arguments provided by the user matches

+     the number of dimension of the array.  A string has only one

+     dimension.  */

+  if (nargs != calc_f77_array_dims (value_type (new_array)))

+    error (_("Wrong number of subscripts"));

+

+  subscript_array = alloca (sizeof (*subscript_array) * nargs);

+

+  /* Parse the user input into the SUBSCRIPT_ARRAY to store it.  We need

+     to evaluate it first, as the input is from left-to-right.  The

+     array is stored from right-to-left.  So we have to use the user

+     input in reverse order.  Later on, we need the input information to

+     re-calculate the output array.  For multi-dimensional arrays, we

+     can be dealing with any possible combination of ranges and indices

+     for every dimension.  */

+  for (i = 0; i < nargs; i++)

+    {

+      struct subscript_store *index = &subscript_array[i];

-  if (range_type == LOW_BOUND_DEFAULT || range_type == BOTH_BOUND_DEFAULT)

-    low_bound = TYPE_LOW_BOUND (range);

-  else

-    low_bound = value_as_long (evaluate_subexp (NULL_TYPE, exp, pos, noside));

+      /* The user input is a range, with or without lower and upper bound.

+	 E.g.: "p arry(2:5)", "p arry( :5)", "p arry( : )", etc.  */

+      if (exp->elts[*pos].opcode == OP_F90_RANGE)

+	{

+	  int pc = (*pos) + 1;

+	  struct subscript_range *range;

+

+	  index->kind = SUBSCRIPT_RANGE;

+	  range = &index->range;

+

+	  *pos += 3;

+	  range->f90_range_type = longest_to_int (exp->elts[pc].longconst);

+

+	  /* If a lower bound was provided by the user, the bit has been

+	     set and we can assign the value from the elt stack.  Same for

+	     upper bound.  */

+	  if ((range->f90_range_type == HIGH_BOUND_DEFAULT)

+	      || range->f90_range_type == NONE_BOUND_DEFAULT)

+	    range->low = value_as_long (evaluate_subexp (NULL_TYPE, exp,

+							 pos, noside));

+	  if ((range->f90_range_type == LOW_BOUND_DEFAULT)

+	      || range->f90_range_type == NONE_BOUND_DEFAULT)

+	    range->high = value_as_long (evaluate_subexp (NULL_TYPE, exp,

+							  pos, noside));

+	}

+      /* User input is an index.  E.g.: "p arry(5)".  */

+      else

+	{

+	  struct value *val;

-  if (range_type == HIGH_BOUND_DEFAULT || range_type == BOTH_BOUND_DEFAULT)

-    high_bound = TYPE_HIGH_BOUND (range);

-  else

-    high_bound = value_as_long (evaluate_subexp (NULL_TYPE, exp, pos, noside));

+	  index->kind = SUBSCRIPT_INDEX;

+

+	  /* Evaluate each subscript; it must be a legal integer in F77.  This

+	     ensures the validity of the provided index.  */

+	  val = evaluate_subexp_with_coercion (exp, pos, noside);

+	  index->number = value_as_long (val);

+	}

+

+    }

+

+  /* Traverse the array from right to left and evaluate each corresponding

+     user input.  VALUE_SUBSCRIPT is called for every index, until a range

+     expression is evaluated.  After a range expression has been evaluated,

+     every subsequent expression is also treated as a range.  */

+  for (i = nargs - 1; i >= 0; i--)

+    {

+      struct subscript_store *index = &subscript_array[i];

+      struct type *index_type = TYPE_INDEX_TYPE (array_type);

+

+      switch (index->kind)

+	{

+	case SUBSCRIPT_RANGE:

+	  {

+

+	    /* When we hit the first range specified by the user, we must

+	       treat any subsequent user entry as a range.  We simply

+	       increment DIM_COUNT which tells us how many times we are

+	       calling VALUE_SLICE_1.  */

+	    struct subscript_range *range = &index->range;

+

+	    /* If no lower bound was provided by the user, we take the

+	       default boundary.  Same for the high bound.  */

+	    if ((range->f90_range_type == LOW_BOUND_DEFAULT)

+		|| (range->f90_range_type == BOTH_BOUND_DEFAULT))

+	      range->low = TYPE_LOW_BOUND (index_type);

+

+	    if ((range->f90_range_type == HIGH_BOUND_DEFAULT)

+		|| (range->f90_range_type == BOTH_BOUND_DEFAULT))

+	      range->high = TYPE_HIGH_BOUND (index_type);

+

+	    /* Both user provided low and high bound have to be inside the

+	       array bounds.  Throw an error if not.  */

+	    if (range->low < TYPE_LOW_BOUND (index_type)

+		|| range->low > TYPE_HIGH_BOUND (index_type)

+		|| range->high < TYPE_LOW_BOUND (index_type)

+		|| range->high > TYPE_HIGH_BOUND (index_type))

+	      error (_("provided bound(s) outside array bound(s)"));

+

+	    /* DIM_COUNT counts every user argument that is treated as a range.

+	       This is necessary for expressions like 'print array(7, 8:9).

+	       Here the first argument is a literal, but must be treated as a

+	       range argument to allow the correct output representation.  */

+	    dim_count++;

+

+	    new_array

+	      = value_slice_1 (new_array,

+			       longest_to_int (range->low),

+			       longest_to_int (range->high - range->low + 1),

+			       dim_count);

+	  }

+	  break;

+

+	case SUBSCRIPT_INDEX:

+	  {

+	    /* DIM_COUNT only stays '0' when no range argument was processed

+	       before, starting from the last dimension.  This way we can

+	       reduce the number of dimensions from the result array.

+	       However, if a range has been processed before an index, we

+	       treat the index like a range with equal low- and high bounds

+	       to get the value offset right.  */

+	    if (dim_count == 0)

+	      new_array

+	        = value_subscripted_rvalue (new_array, index->number,

+					    f77_get_lowerbound (value_type

+								  (new_array)));

+	    else

+	      {

+		/* Check for valid index input.  */

+		if (index->number < TYPE_LOW_BOUND (index_type)

+		    || index->number > TYPE_HIGH_BOUND (index_type))

+		  error (_("error no such vector element"));

+

+		dim_count++;

+		new_array = value_slice_1 (new_array,

+					   longest_to_int (index->number),

+					   1, /* length is '1' element  */

+					   dim_count);

+	      }

+

+	  }

+	  break;

+	}

+    }

+

+  /* With DIM_COUNT > 1 we currently have a one dimensional array, but expect

+     an array of arrays, depending on how many ranges have been provided by

+     the user.  So we need to rebuild the array dimensions for printing it

+     correctly.

+     Starting from right to left in the user input, after we hit the first

+     range argument every subsequent argument is also treated as a range.

+     E.g.:

+     "p ary(3, 7, 2:15)" in Fortran has only 1 dimension, but we calculated 3

+     ranges.

+     "p ary(3, 7:12, 4)" in Fortran has only 1 dimension, but we calculated 2

+     ranges.

+     "p ary(2:4, 5, 7)" in Fortran has only 1 dimension, and we calculated 1

+     range.  */

+  if (dim_count > 1)

+    {

+      struct value *v = NULL;

-  return value_slice (array, low_bound, high_bound - low_bound + 1);

+      temp_type = TYPE_TARGET_TYPE (value_type (new_array));

+

+      /* Every SUBSCRIPT_RANGE in the user input signifies an actual range in

+	 the output array.  So we traverse the SUBSCRIPT_ARRAY again, looking

+	 for a range entry.  When we find one, we use the range info to create

+	 an additional range_type to set the correct bounds and dimensions for

+	 the output array.  */

+      for (i = 0; i < nargs; i++)

+	{

+	  struct subscript_store *index = &subscript_array[i];

+

+	  if (index->kind == SUBSCRIPT_RANGE)

+	    {

+	      struct type *range_type, *interim_array_type;

+

+	      range_type

+		= create_static_range_type (NULL,

+				     temp_type,

+				     1,

+				     index->range.high - index->range.low + 1);

+

+	      interim_array_type = create_array_type (NULL,

+						      temp_type,

+						      range_type);

+

+	      /* For some reason the type code of the contents is missing, so

+		 reset it from the original array.  */

+	      TYPE_CODE (interim_array_type)

+		= TYPE_CODE (value_type (new_array));

+

+	      v = allocate_value (interim_array_type);

+

+	      temp_type = value_type (v);

+	    }

+

+	}

+      value_contents_copy (v, 0, new_array, 0, TYPE_LENGTH (temp_type));

+      return v;

+    }

+

+  return new_array;

 }

@@ -1810,14 +2034,11 @@ evaluate_subexp_standard (struct type *expect_type,

       switch (code)

 	{

 	case TYPE_CODE_ARRAY:

-	  if (exp->elts[*pos].opcode == OP_F90_RANGE)

-	    return value_f90_subarray (arg1, exp, pos, noside);

-	  else

-	    goto multi_f77_subscript;

+	  return value_f90_subarray (arg1, exp, pos, nargs, noside);

 	case TYPE_CODE_STRING:

 	  if (exp->elts[*pos].opcode == OP_F90_RANGE)

-	    return value_f90_subarray (arg1, exp, pos, noside);

+	    return value_f90_subarray (arg1, exp, pos, 1, noside);

 	  else

 	    {

 	      arg2 = evaluate_subexp_with_coercion (exp, pos, noside);

@@ -2222,49 +2443,6 @@ evaluate_subexp_standard (struct type *expect_type,

 	}

       return (arg1);

-    multi_f77_subscript:

-      {

-	LONGEST subscript_array[MAX_FORTRAN_DIMS];

-	int ndimensions = 1, i;

-	struct value *array = arg1;

-

-	if (nargs > MAX_FORTRAN_DIMS)

-	  error (_("Too many subscripts for F77 (%d Max)"), MAX_FORTRAN_DIMS);

-

-	ndimensions = calc_f77_array_dims (type);

-

-	if (nargs != ndimensions)

-	  error (_("Wrong number of subscripts"));

-

-	gdb_assert (nargs > 0);

-

-	/* Now that we know we have a legal array subscript expression 

-	   let us actually find out where this element exists in the array.  */

-

-	/* Take array indices left to right.  */

-	for (i = 0; i < nargs; i++)

-	  {

-	    /* Evaluate each subscript; it must be a legal integer in F77.  */

-	    arg2 = evaluate_subexp_with_coercion (exp, pos, noside);

-

-	    /* Fill in the subscript array.  */

-

-	    subscript_array[i] = value_as_long (arg2);

-	  }

-

-	/* Internal type of array is arranged right to left.  */

-	for (i = nargs; i > 0; i--)

-	  {

-	    struct type *array_type = check_typedef (value_type (array));

-	    LONGEST index = subscript_array[i - 1];

-

-	    array = value_subscripted_rvalue (array, index,

-					      f77_get_lowerbound (array_type));

-	  }

-

-	return array;

-      }

-

     case BINOP_LOGICAL_AND:

       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);

       if (noside == EVAL_SKIP)

@@ -3121,6 +3299,9 @@ calc_f77_array_dims (struct type *array_type)

   int ndimen = 1;

   struct type *tmp_type;

+  if (TYPE_CODE (array_type) == TYPE_CODE_STRING)

+    return 1;

+

   if ((TYPE_CODE (array_type) != TYPE_CODE_ARRAY))

     error (_("Can't get dimensions for a non-array type"));

diff --git a/gdb/f-exp.y b/gdb/f-exp.y

index 4faac32..9343abb 100644

--- a/gdb/f-exp.y

+++ b/gdb/f-exp.y

@@ -308,6 +308,8 @@ arglist :	subrange

 arglist	:	arglist ',' exp   %prec ABOVE_COMMA

 			{ arglist_len++; }

+	|	arglist ',' subrange	%prec ABOVE_COMMA

+			{ arglist_len++; }

 	;

 /* There are four sorts of subrange types in F90.  */

diff --git a/gdb/valops.c b/gdb/valops.c

index 5a244a9..09ea877 100644

--- a/gdb/valops.c

+++ b/gdb/valops.c

@@ -3759,56 +3759,151 @@ value_of_this_silent (const struct language_defn *lang)

 struct value *

 value_slice (struct value *array, int lowbound, int length)

 {

+  /* Pass unaltered arguments to VALUE_SLICE_1, plus a CALL_COUNT of '1' as we

+     are only considering the highest dimension, or we are working on a one

+     dimensional array.  So we call VALUE_SLICE_1 exactly once.  */

+  return value_slice_1 (array, lowbound, length, 1);

+}

+

+/* CALL_COUNT is used to determine if we are calling the function once, e.g.

+   we are working on the current dimension of ARRAY, or if we are calling

+   the function repeatedly.  In the later case we need to take elements

+   from the TARGET_TYPE of ARRAY.

+   With a CALL_COUNT greater than 1 we calculate the offsets for every element

+   that should be in the result array.  Then we fetch the contents and then

+   copy them into the result array.  The result array will have one dimension

+   less than the input array, so later on we need to recreate the indices and

+   ranges in the calling function.  */

+

+struct value *

+value_slice_1 (struct value *array, int lowbound, int length, int call_count)

+{

   struct type *slice_range_type, *slice_type, *range_type;

-  LONGEST lowerbound, upperbound;

-  struct value *slice;

-  struct type *array_type;

+  struct type *array_type = check_typedef (value_type (array));

+  struct type *elt_type = check_typedef (TYPE_TARGET_TYPE (array_type));

+  unsigned int elt_size, elt_offs;

+  LONGEST elt_stride, ary_high_bound, ary_low_bound;

+  struct value *v;

+  int slice_range_size, i = 0, row_count = 1, elem_count = 1;

-  array_type = check_typedef (value_type (array));

+  /* Check for legacy code if we are actually dealing with an array or

+     string.  */

   if (TYPE_CODE (array_type) != TYPE_CODE_ARRAY

       && TYPE_CODE (array_type) != TYPE_CODE_STRING)

     error (_("cannot take slice of non-array"));

-  range_type = TYPE_INDEX_TYPE (array_type);

-  if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)

-    error (_("slice from bad array or bitstring"));

+  ary_low_bound = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (array_type));

+  ary_high_bound = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (array_type));

+

+  /* When we are working on a multi-dimensional array, we need to get the

+     attributes of the underlying type.  */

+  if (call_count > 1)

+    {

+      elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));

+      row_count = TYPE_LENGTH (array_type)

+		    / TYPE_LENGTH (TYPE_TARGET_TYPE (array_type));

+    }

+

+  elem_count = length;

+  elt_size = TYPE_LENGTH (elt_type);

+  elt_offs = longest_to_int (lowbound - ary_low_bound);

+  elt_stride = TYPE_LENGTH (TYPE_INDEX_TYPE (array_type));

+

+  elt_offs *= elt_size;

+

+  /* Check for valid user input.  In case of Fortran this was already done

+     in the calling function.  */

+  if (call_count == 1

+	&& (!TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (array_type)

+	      && elt_offs >= TYPE_LENGTH (array_type)))

+    error (_("no such vector element"));

-  if (lowbound < lowerbound || length < 0

-      || lowbound + length - 1 > upperbound)

-    error (_("slice out of range"));

+  /* CALL_COUNT is 1 when we are dealing either with the highest dimension

+     of the array, or a one dimensional array.  Set RANGE_TYPE accordingly.

+     In both cases we calculate how many rows/elements will be in the output

+     array by setting slice_range_size.  */

+  if (call_count == 1)

+    {

+      range_type = TYPE_INDEX_TYPE (array_type);

+      slice_range_size = elem_count;

+

+      /* Check if the array bounds are valid.  */

+      if (get_discrete_bounds (range_type, &ary_low_bound, &ary_high_bound) < 0)

+	error (_("slice from bad array or bitstring"));

+    }

+  /* When CALL_COUNT is greater than 1, we are dealing with an array of arrays.

+     So we need to get the type below the current one and set the RANGE_TYPE

+     accordingly.  */

+  else

+    {

+      range_type = TYPE_INDEX_TYPE (TYPE_TARGET_TYPE (array_type));

+      slice_range_size = (ary_low_bound + row_count - 1) * (elem_count);

+      ary_low_bound = TYPE_LOW_BOUND (range_type);

+    }

   /* FIXME-type-allocation: need a way to free this type when we are

-     done with it.  */

-  slice_range_type = create_static_range_type ((struct type *) NULL,

-					       TYPE_TARGET_TYPE (range_type),

-					       lowbound,

-					       lowbound + length - 1);

+      done with it.  */

+  slice_range_type = create_static_range_type (NULL, TYPE_TARGET_TYPE (range_type),

+					ary_low_bound, slice_range_size);

   {

-    struct type *element_type = TYPE_TARGET_TYPE (array_type);

-    LONGEST offset

-      = (lowbound - lowerbound) * TYPE_LENGTH (check_typedef (element_type));

+    struct type *element_type;

+

+    /* When CALL_COUNT equals 1 we can use the legacy code for subarrays.  */

+    if (call_count == 1)

+      {

+	element_type = TYPE_TARGET_TYPE (array_type);

-    slice_type = create_array_type ((struct type *) NULL,

-				    element_type,

-				    slice_range_type);

-    TYPE_CODE (slice_type) = TYPE_CODE (array_type);

+	slice_type = create_array_type (NULL, element_type, slice_range_type);

+

+	TYPE_CODE (slice_type) = TYPE_CODE (array_type);

+

+	if (VALUE_LVAL (array) == lval_memory && value_lazy (array))

+	  v = allocate_value_lazy (slice_type);

+	else

+	  {

+	    v = allocate_value (slice_type);

+	    value_contents_copy (v,

+				 value_embedded_offset (v),

+				 array,

+				 value_embedded_offset (array) + elt_offs,

+				 elt_size * longest_to_int (length));

+	  }

-    if (VALUE_LVAL (array) == lval_memory && value_lazy (array))

-      slice = allocate_value_lazy (slice_type);

+      }

+    /* When CALL_COUNT is larger than 1 we are working on a range of ranges.

+       So we copy the relevant elements into the new array we return.  */

     else

       {

-	slice = allocate_value (slice_type);

-	value_contents_copy (slice, 0, array, offset,

-			     type_length_units (slice_type));

+	LONGEST dst_offset = 0;

+	LONGEST src_row_length = TYPE_LENGTH (TYPE_TARGET_TYPE (array_type));

+

+	element_type = TYPE_TARGET_TYPE (TYPE_TARGET_TYPE (array_type));

+	slice_type = create_array_type (NULL, element_type, slice_range_type);

+

+	TYPE_CODE (slice_type) = TYPE_CODE (TYPE_TARGET_TYPE (array_type));

+

+	v = allocate_value (slice_type);

+	for (i = 0; i < longest_to_int (row_count); i++)

+	  {

+	    /* Fetches the contents of ARRAY and copies them into V.  */

+	    value_contents_copy (v,

+				 dst_offset,

+				 array,

+				 elt_offs,

+				 elt_size * elem_count);

+	    elt_offs += src_row_length;

+	    dst_offset += elt_size * elem_count;

+	  }

       }

-    set_value_component_location (slice, array);

-    VALUE_FRAME_ID (slice) = VALUE_FRAME_ID (array);

-    set_value_offset (slice, value_offset (array) + offset);

+    set_value_component_location (v, array);

+    VALUE_REGNUM (v) = VALUE_REGNUM (array);

+    VALUE_FRAME_ID (v) = VALUE_FRAME_ID (array);

+    set_value_offset (v, value_offset (array) + elt_offs);

   }

-  return slice;

+  return v;

 }

 /* Create a value for a FORTRAN complex number.  Currently most of the

diff --git a/gdb/value.h b/gdb/value.h

index 2eac5ef..3400460 100644

--- a/gdb/value.h

+++ b/gdb/value.h

@@ -1056,6 +1056,8 @@ extern struct value *varying_to_slice (struct value *);

 extern struct value *value_slice (struct value *, int, int);

+extern struct value *value_slice_1 (struct value *, int, int, int);

+

 extern struct value *value_literal_complex (struct value *, struct value *,

 					    struct type *);

-- 

2.5.0