@@ -155,14 +155,16 @@ extern void dump_raw_expression (struct expression *,
struct ui_file *, const char *);
extern void dump_prefix_expression (struct expression *, struct ui_file *);
-/* Flags to indicate which boundarys are set in an OP_RANGE expression. Values
- can be or'ed together. */
+/* Flags to indicate which boundaries are set in an OP_RANGE expression.
+ Additionally, the user can specify a stride. Values can be or'ed
+ together. */
enum range_type
{
SUBARRAY_NO_BOUND = 0x0, /* "( : )" */
SUBARRAY_LOW_BOUND = 0x1, /* "(low:)" */
- SUBARRAY_HIGH_BOUND = 0x2 /* "(:high)" */
+ SUBARRAY_HIGH_BOUND = 0x2, /* "(:high)" */
+ SUBARRAY_STRIDE = 0x4 /* "(::stride)" */
};
#endif /* !defined (EXPRESSION_H) */
@@ -285,6 +285,35 @@ subrange: ':' %prec ABOVE_COMMA
write_exp_elt_opcode (pstate, OP_RANGE); }
;
+/* Each subrange type can have a stride argument. */
+subrange: exp ':' exp ':' exp %prec ABOVE_COMMA
+ { write_exp_elt_opcode (pstate, OP_RANGE);
+ write_exp_elt_longcst (pstate, SUBARRAY_LOW_BOUND
+ | SUBARRAY_HIGH_BOUND
+ | SUBARRAY_STRIDE);
+ write_exp_elt_opcode (pstate, OP_RANGE); }
+ ;
+
+subrange: exp ':' ':' exp %prec ABOVE_COMMA
+ { write_exp_elt_opcode (pstate, OP_RANGE);
+ write_exp_elt_longcst (pstate, SUBARRAY_LOW_BOUND
+ | SUBARRAY_STRIDE);
+ write_exp_elt_opcode (pstate, OP_RANGE); }
+ ;
+
+subrange: ':' exp ':' exp %prec ABOVE_COMMA
+ { write_exp_elt_opcode (pstate, OP_RANGE);
+ write_exp_elt_longcst (pstate, SUBARRAY_HIGH_BOUND
+ | SUBARRAY_STRIDE);
+ write_exp_elt_opcode (pstate, OP_RANGE); }
+ ;
+
+subrange: ':' ':' exp %prec ABOVE_COMMA
+ { write_exp_elt_opcode (pstate, OP_RANGE);
+ write_exp_elt_longcst (pstate, SUBARRAY_STRIDE);
+ write_exp_elt_opcode (pstate, OP_RANGE); }
+ ;
+
complexnum: exp ',' exp
{ }
;
@@ -392,7 +392,7 @@ f77_get_array_dims (const struct type *array_type)
/* F90_VALUE_SLICE is called for each array dimension to calculate the number
of elements as defined by the subscript expression
- array(SLICE_LOW : SLICE_LOW + SLICE_LEN).
+ array(SLICE_LOW : SLICE_LOW + SLICE_LEN : SLICE_STRIDE).
MULTI_DIM is used to determine if we are working on a one-dimensional or
multi-dimensional array. The latter case happens in all slicing operations
following the first subscript that is a range, as a range subscript does not
@@ -400,20 +400,26 @@ f77_get_array_dims (const struct type *array_type)
static struct value *
f90_value_slice (struct value *src_array, LONGEST slice_low, LONGEST slice_len,
- bool multi_dim)
+ LONGEST slice_stride, bool multi_dim)
{
- /* If the array is not multidimensional, we use the generic code path to
- generate the slice. */
- if (!multi_dim)
+ /* If the array is not multidimensional and the stride is one, we can use
+ generic code to generate the slice. */
+ if (!multi_dim && slice_stride == 1)
return value_slice (src_array, slice_low, slice_len);
+ gdb_assert (slice_stride != 0);
+
type *const src_ary_type = check_typedef (value_type (src_array));
type *const src_row_type = check_typedef (TYPE_TARGET_TYPE (src_ary_type));
- type *const src_elm_type = check_typedef (TYPE_TARGET_TYPE (src_row_type));
- type *const src_idx_type = check_typedef (TYPE_INDEX_TYPE (src_row_type));
+ type *const src_tgt_type = multi_dim ? src_row_type : src_ary_type;
+ type *const src_elm_type = check_typedef (TYPE_TARGET_TYPE (src_tgt_type));
+ type *const src_idx_type = check_typedef (TYPE_INDEX_TYPE (src_tgt_type));
+ const LONGEST num_elements = ((slice_len - 1) / slice_stride) + 1;
const LONGEST slice_offset = slice_low - TYPE_LOW_BOUND (src_idx_type);
const LONGEST row_count
- = TYPE_LENGTH (src_ary_type) / TYPE_LENGTH (src_row_type);
+ = TYPE_LENGTH (src_ary_type) / TYPE_LENGTH (src_tgt_type);
+
+ gdb_assert (num_elements >= 0);
/* FIXME-type-allocation: need a way to free this type when we are
done with it. */
@@ -421,25 +427,28 @@ f90_value_slice (struct value *src_array, LONGEST slice_low, LONGEST slice_len,
= create_static_range_type (NULL, TYPE_TARGET_TYPE (src_idx_type),
TYPE_LOW_BOUND (src_idx_type),
TYPE_LOW_BOUND (src_idx_type)
- + slice_len * row_count - 1);
+ + num_elements * row_count - 1);
type *const dst_ary_type
- = create_array_type (NULL, TYPE_TARGET_TYPE (src_row_type), dst_rng_type);
+ = create_array_type (NULL, TYPE_TARGET_TYPE (src_tgt_type), dst_rng_type);
- TYPE_CODE (dst_ary_type) = TYPE_CODE (src_row_type);
+ TYPE_CODE (dst_ary_type) = TYPE_CODE (src_tgt_type);
value *const dst_array = allocate_value (dst_ary_type);
for (LONGEST i = 0; i < row_count; ++i)
- {
- const LONGEST dst_offset = TYPE_LENGTH (src_elm_type) * i * slice_len;
+ for (LONGEST j = 0; j < num_elements; ++j)
+ {
+ const LONGEST dst_offset
+ = TYPE_LENGTH (src_elm_type) * (j + i * num_elements);
- const LONGEST src_offset
- = TYPE_LENGTH (src_row_type) * i
- + TYPE_LENGTH (src_elm_type) * slice_offset;
+ const LONGEST src_offset
+ = TYPE_LENGTH (src_row_type) * i
+ + TYPE_LENGTH (src_elm_type) * j * slice_stride
+ + TYPE_LENGTH (src_elm_type) * slice_offset;
- value_contents_copy (dst_array, dst_offset, src_array, src_offset,
- TYPE_LENGTH (src_elm_type) * slice_len);
- }
+ value_contents_copy (dst_array, dst_offset, src_array, src_offset,
+ TYPE_LENGTH (src_elm_type));
+ }
const LONGEST offset
= TYPE_LENGTH (src_row_type) * row_count
@@ -476,13 +485,15 @@ f90_value_subarray (struct value *array, struct expression *exp, int *pos,
int type;
LONGEST low;
LONGEST high;
+ LONGEST stride;
};
};
subscript (LONGEST index_) : kind (SUBSCRIPT_INDEX), index (index_) {}
- subscript (int type_, LONGEST low_, LONGEST high_) :
- kind (SUBSCRIPT_RANGE), type (type_), low (low_), high (high_) {}
+ subscript (int type_, LONGEST low_, LONGEST high_, LONGEST stride_) :
+ kind (SUBSCRIPT_RANGE), type (type_), low (low_), high (high_),
+ stride (stride_) {}
};
if (nargs != f77_get_array_dims (value_type (array)))
@@ -500,6 +511,7 @@ f90_value_subarray (struct value *array, struct expression *exp, int *pos,
const int type = longest_to_int (exp->elts[*pos + 1].longconst);
LONGEST lo = 0;
LONGEST hi = 0;
+ LONGEST stride = 1;
*pos += 3;
@@ -507,8 +519,11 @@ f90_value_subarray (struct value *array, struct expression *exp, int *pos,
lo = value_as_long (evaluate_subexp (NULL_TYPE, exp, pos, noside));
if ((type & SUBARRAY_HIGH_BOUND) != 0)
hi = value_as_long (evaluate_subexp (NULL_TYPE, exp, pos, noside));
+ if ((type & SUBARRAY_STRIDE) == SUBARRAY_STRIDE)
+ stride = value_as_long (evaluate_subexp (NULL_TYPE, exp, pos,
+ noside));
- subscript_array.emplace_back (type, lo, hi);
+ subscript_array.emplace_back (type, lo, hi, stride);
}
else
{
@@ -538,15 +553,22 @@ f90_value_subarray (struct value *array, struct expression *exp, int *pos,
if ((it->type & SUBARRAY_HIGH_BOUND) == 0)
it->high = hi;
+ if (it->stride == 0)
+ error (_("Stride must not be 0."));
+
if (it->low < lo || it->low > hi || it->high < lo || it->high > hi)
error (_("slice out of range"));
- if (it->high - it->low + 1 < 0)
+ /* For a negative stride the lower boundary must be greater than the
+ upper boundary. For a positive stride the lower boundary must be
+ less than the upper boundary. */
+ if ((it->stride < 0 && (it->low - it->high - 1 < 0))
+ || (it->stride > 0 && (it->high - it->low + 1 < 0)))
error (_("slice out of range"));
new_array = f90_value_slice (new_array, it->low,
it->high - it->low + 1,
- multi_dim);
+ it->stride, multi_dim);
/* A range subscript does not decrease the number of dimensions in
array. Therefore we cannot use VALUE_SUBSCRIPTED_RVALUE anymore
@@ -566,7 +588,7 @@ f90_value_subarray (struct value *array, struct expression *exp, int *pos,
if (it->index < lo || it->index > hi)
error (_("no such vector element"));
- new_array = f90_value_slice (new_array, it->index, 1, multi_dim);
+ new_array = f90_value_slice (new_array, it->index, 1, 1, multi_dim);
}
}
@@ -584,7 +606,9 @@ f90_value_subarray (struct value *array, struct expression *exp, int *pos,
continue;
type *const range_type =
- create_static_range_type (NULL, elt_type, s.low, s.high);
+ create_static_range_type (NULL, elt_type, s.low,
+ s.low + ((s.high - s.low) / s.stride));
+
type *const interim_array_type =
create_array_type (NULL, elt_type, range_type);
@@ -1013,6 +1013,9 @@ operator_length_standard (const struct expression *expr, int endpos,
if ((range_type & SUBARRAY_HIGH_BOUND) != 0)
args++;
+ if ((range_type & SUBARRAY_STRIDE) == SUBARRAY_STRIDE)
+ args++;
+
break;
default:
@@ -250,12 +250,17 @@ gdb_test "p ar4\( 1 \)" " = 1"
gdb_test "p ar4\( 4 \)" " = 4"
-# Check assignment
-gdb_test_no_output "set \$my_ary = ar1\(2:4\)"
-gdb_test "p \$my_ary" " = \\(2, 3, 4\\)" "p my_ary one"
-gdb_test_no_output "set ar1\(2\) = 1"
-gdb_test "p ar1\(2:4\)" " = \\(1, 3, 4\\)"
-gdb_test "p \$my_ary" " = \\(2, 3, 4\\)" "p my_ary two"
+# Check strides
+gdb_test "p ar5(1:6: 3, 1, -6)" " = \\(200, 500\\)"
+gdb_test "p ar5(1:7: 3, 1, -6)" " = \\(200, 500, 800\\)"
+gdb_test "p ar5(6:1:-3, 1, -6)" " = \\(700, 400\\)"
+gdb_test "p ar5(7:1:-3, 1, -6)" " = \\(800, 500, 200\\)"
+gdb_test "p ar5(1, 1, -6:-12:-3)" " = \\(200, 197, 194\\)"
+gdb_test "p ar5(1, 1, -6:-11:-3)" " = \\(200, 197\\)"
+gdb_test "p ar5(1, 1, -12: -6: 3)" " = \\(194, 197, 200\\)"
+gdb_test "p ar5(1, 1, -11: -6: 3)" " = \\(195, 198\\)"
+
+gdb_test "p ar5\(9:2:-2, -6:2:3, -6:-15:-3\)" " = \\(\\( \\( 930, 730, 530, 330\\) \\( 960, 760, 560, 360\\) \\( 990, 790, 590, 390\\) \\) \\( \\( 927, 727, 527, 327\\) \\( 957, 757, 557, 357\\) \\( 987, 787, 587, 387\\) \\) \\( \\( 924, 724, 524, 324\\) \\( 954, 754, 554, 354\\) \\( 984, 784, 584, 384\\) \\) \\( \\( 921, 721, 521, 321\\) \\( 951, 751, 551, 351\\) \\( 981, 781, 581, 381\\) \\) \\)"
# Corner cases and error messages
@@ -273,3 +278,20 @@ gdb_test "p ar2\(3:1, :\)" "slice out of range"
gdb_test "p ar4\(-3:-3\)" " = \\(-3\\)"
gdb_test "p ar4\(-2:-3\)" " = \\(\\)"
gdb_test "p ar4\( 1:-1\)" "slice out of range"
+
+gdb_test "p ar1\(1:3:\)" "A syntax error in expression, near `\\)'."
+gdb_test "p ar1\(1:3:0\)" "Stride must not be 0."
+gdb_test "p ar1\(3:1:2\)" "slice out of range"
+gdb_test "p ar1\(1:3:-2\)" "slice out of range"
+gdb_test "p ar5(1:7:-3, 1, -6)" "slice out of range"
+gdb_test "p ar5(7:1: 3, 1, -6)" "slice out of range"
+gdb_test "p ar5(1,1,-6:-14: 3)" "slice out of range"
+gdb_test "p ar5(1,1,-14:-6:-3)" "slice out of range"
+
+
+# Check assignment
+gdb_test_no_output "set \$my_ary = ar1\(2:4\)"
+gdb_test "p \$my_ary" " = \\(2, 3, 4\\)" "p my_ary one"
+gdb_test_no_output "set ar1\(2\) = 1"
+gdb_test "p ar1\(2:4\)" " = \\(1, 3, 4\\)"
+gdb_test "p \$my_ary" " = \\(2, 3, 4\\)" "p my_ary two"
@@ -18,6 +18,7 @@ subroutine sub
integer, dimension(4,4) :: ar2
integer, dimension(4,4,4) :: ar3
integer, dimension(-4:4) :: ar4
+ integer, dimension(10,-7:3, -15:-5) :: ar5
integer :: i,j,k
! Resulting array ar3 looks like ((( 111, 112, 113, 114,...)))
@@ -35,6 +36,14 @@ subroutine sub
ar4(i) = i
end do
+ do i = 1, 10, 1
+ do j = -7, 3, 1
+ do k = -15, -5, 1
+ ar5(i,j,k) = i*100 + (j+8)*10 + (k+16)
+ end do
+ end do
+ end do
+
ar1(1) = 11 !BP1
return
end