]> git.pld-linux.org Git - packages/gdb.git/blame - gdb-vla-intel-fortran-strides.patch
- up to 8.3
[packages/gdb.git] / gdb-vla-intel-fortran-strides.patch
CommitLineData
4b0e5c1b
AM
1From FEDORA_PATCHES Mon Sep 17 00:00:00 2001
2From: Fedora GDB patches <invalid@email.com>
3Date: Fri, 27 Oct 2017 21:07:50 +0200
4Subject: gdb-vla-intel-fortran-strides.patch
5
4b0e5c1b
AM
6;; VLA (Fortran dynamic arrays) from Intel + archer-jankratochvil-vla tests.
7;;=push
8
140f8057
JR
9git diff --stat -p gdb/master...gdb/users/bheckel/fortran-strides
10dbfd7140bf4c0500d1f5d192be781f83f78f7922
11
12 gdb/dwarf2loc.c | 46 ++-
13 gdb/dwarf2loc.h | 6 +
14 gdb/dwarf2read.c | 13 +-
15 gdb/eval.c | 391 +++++++++++++++++++++-----
16 gdb/expprint.c | 20 +-
17 gdb/expression.h | 18 +-
18 gdb/f-exp.y | 42 ++-
19 gdb/f-valprint.c | 8 +-
20 gdb/gdbtypes.c | 34 ++-
21 gdb/gdbtypes.h | 18 +-
22 gdb/parse.c | 24 +-
23 gdb/rust-exp.y | 12 +-
24 gdb/rust-lang.c | 17 +-
25 gdb/testsuite/gdb.fortran/static-arrays.exp | 421 ++++++++++++++++++++++++++++
26 gdb/testsuite/gdb.fortran/static-arrays.f90 | 55 ++++
27 gdb/testsuite/gdb.fortran/vla-ptype.exp | 4 +
28 gdb/testsuite/gdb.fortran/vla-sizeof.exp | 4 +
29 gdb/testsuite/gdb.fortran/vla-stride.exp | 44 +++
30 gdb/testsuite/gdb.fortran/vla-stride.f90 | 29 ++
31 gdb/testsuite/gdb.fortran/vla.f90 | 10 +
32 gdb/valarith.c | 10 +-
33 gdb/valops.c | 197 +++++++++++--
34 gdb/value.h | 2 +
35 23 files changed, 1242 insertions(+), 183 deletions(-)
36
4b0e5c1b 37diff --git a/gdb/dwarf2loc.c b/gdb/dwarf2loc.c
4b0e5c1b
AM
38--- a/gdb/dwarf2loc.c
39+++ b/gdb/dwarf2loc.c
77d10998 40@@ -2429,11 +2429,14 @@ dwarf2_locexpr_baton_eval (const struct dwarf2_locexpr_baton *dlbaton,
140f8057
JR
41 /* See dwarf2loc.h. */
42
43 int
44-dwarf2_evaluate_property (const struct dynamic_prop *prop,
45+dwarf2_evaluate_property_signed (const struct dynamic_prop *prop,
46 struct frame_info *frame,
47 struct property_addr_info *addr_stack,
48- CORE_ADDR *value)
49+ CORE_ADDR *value,
50+ int is_signed)
51 {
52+ int rc = 0;
53+
54 if (prop == NULL)
55 return 0;
56
77d10998 57@@ -2457,7 +2460,7 @@ dwarf2_evaluate_property (const struct dynamic_prop *prop,
140f8057
JR
58
59 *value = value_as_address (val);
60 }
61- return 1;
62+ rc = 1;
63 }
64 }
65 break;
77d10998 66@@ -2479,7 +2482,7 @@ dwarf2_evaluate_property (const struct dynamic_prop *prop,
140f8057
JR
67 if (!value_optimized_out (val))
68 {
69 *value = value_as_address (val);
70- return 1;
71+ rc = 1;
72 }
73 }
74 }
77d10998 75@@ -2487,8 +2490,8 @@ dwarf2_evaluate_property (const struct dynamic_prop *prop,
140f8057
JR
76
77 case PROP_CONST:
78 *value = prop->data.const_val;
79- return 1;
80-
81+ rc = 1;
82+ break;
83 case PROP_ADDR_OFFSET:
84 {
85 struct dwarf2_property_baton *baton
77d10998 86@@ -2509,11 +2512,38 @@ dwarf2_evaluate_property (const struct dynamic_prop *prop,
140f8057
JR
87 val = value_at (baton->offset_info.type,
88 pinfo->addr + baton->offset_info.offset);
89 *value = value_as_address (val);
90- return 1;
91+ rc = 1;
92 }
93+ break;
4b0e5c1b
AM
94 }
95
96- return 0;
140f8057
JR
97+ if (rc == 1 && is_signed == 1)
98+ {
99+ /* If we have a valid return candidate and it's value is signed,
100+ we have to sign-extend the value because CORE_ADDR on 64bit machine has
101+ 8 bytes but address size of an 32bit application is 4 bytes. */
102+ struct gdbarch * gdbarch = target_gdbarch ();
103+ const int addr_bit = gdbarch_addr_bit (gdbarch);
104+ const CORE_ADDR neg_mask = ((~0) << (addr_bit - 1));
105+
106+ /* Check if signed bit is set and sign-extend values. */
107+ if (*value & (neg_mask))
108+ *value |= (neg_mask );
4b0e5c1b 109+ }
140f8057
JR
110+ return rc;
111+}
4b0e5c1b 112+
140f8057
JR
113+int
114+dwarf2_evaluate_property (const struct dynamic_prop *prop,
115+ struct frame_info *frame,
116+ struct property_addr_info *addr_stack,
117+ CORE_ADDR *value)
118+{
119+ return dwarf2_evaluate_property_signed (prop,
120+ frame,
121+ addr_stack,
122+ value,
123+ 0);
124 }
125
126 /* See dwarf2loc.h. */
4b0e5c1b 127diff --git a/gdb/dwarf2loc.h b/gdb/dwarf2loc.h
4b0e5c1b
AM
128--- a/gdb/dwarf2loc.h
129+++ b/gdb/dwarf2loc.h
130@@ -143,6 +143,12 @@ int dwarf2_evaluate_property (const struct dynamic_prop *prop,
140f8057
JR
131 struct property_addr_info *addr_stack,
132 CORE_ADDR *value);
133
134+int dwarf2_evaluate_property_signed (const struct dynamic_prop *prop,
135+ struct frame_info *frame,
136+ struct property_addr_info *addr_stack,
137+ CORE_ADDR *value,
138+ int is_signed);
139+
140 /* A helper for the compiler interface that compiles a single dynamic
141 property to C code.
142
4b0e5c1b 143diff --git a/gdb/dwarf2read.c b/gdb/dwarf2read.c
4b0e5c1b
AM
144--- a/gdb/dwarf2read.c
145+++ b/gdb/dwarf2read.c
77d10998 146@@ -17752,7 +17752,7 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu)
140f8057
JR
147 struct type *base_type, *orig_base_type;
148 struct type *range_type;
149 struct attribute *attr;
150- struct dynamic_prop low, high;
151+ struct dynamic_prop low, high, stride;
152 int low_default_is_valid;
153 int high_bound_is_count = 0;
154 const char *name;
77d10998 155@@ -17772,7 +17772,9 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu)
140f8057
JR
156
157 low.kind = PROP_CONST;
158 high.kind = PROP_CONST;
159+ stride.kind = PROP_CONST;
160 high.data.const_val = 0;
161+ stride.data.const_val = 0;
162
163 /* Set LOW_DEFAULT_IS_VALID if current language and DWARF version allow
164 omitting DW_AT_lower_bound. */
77d10998 165@@ -17805,6 +17807,14 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu)
140f8057
JR
166 break;
167 }
168
169+ attr = dwarf2_attr (die, DW_AT_byte_stride, cu);
170+ if (attr)
171+ if (!attr_to_dynamic_prop (attr, die, cu, &stride))
ed003b1c
AM
172+ complaint (_("Missing DW_AT_byte_stride "
173+ "- DIE at 0x%s [in module %s]"),
174+ sect_offset_str (die->sect_off),
175+ objfile_name (cu->per_cu->dwarf2_per_objfile->objfile));
140f8057
JR
176+
177 attr = dwarf2_attr (die, DW_AT_lower_bound, cu);
178 if (attr)
179 attr_to_dynamic_prop (attr, die, cu, &low);
77d10998 180@@ -17897,7 +17907,7 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu)
140f8057
JR
181 && !TYPE_UNSIGNED (base_type) && (high.data.const_val & negative_mask))
182 high.data.const_val |= negative_mask;
183
184- range_type = create_range_type (NULL, orig_base_type, &low, &high);
185+ range_type = create_range_type (NULL, orig_base_type, &low, &high, &stride);
186
187 if (high_bound_is_count)
188 TYPE_RANGE_DATA (range_type)->flag_upper_bound_is_count = 1;
4b0e5c1b 189diff --git a/gdb/eval.c b/gdb/eval.c
4b0e5c1b
AM
190--- a/gdb/eval.c
191+++ b/gdb/eval.c
77d10998 192@@ -377,29 +377,324 @@ init_array_element (struct value *array, struct value *element,
140f8057
JR
193 return index;
194 }
195
196+/* Evaluates any operation on Fortran arrays or strings with at least
197+ one user provided parameter. Expects the input ARRAY to be either
198+ an array, or a string. Evaluates EXP by incrementing POS, and
199+ writes the content from the elt stack into a local struct. NARGS
200+ specifies number of literal or range arguments the user provided.
201+ NARGS must be the same number as ARRAY has dimensions. */
202+
203 static struct value *
204-value_f90_subarray (struct value *array,
205- struct expression *exp, int *pos, enum noside noside)
206+value_f90_subarray (struct value *array, struct expression *exp,
207+ int *pos, int nargs, enum noside noside)
208 {
209- int pc = (*pos) + 1;
77d10998 210- LONGEST low_bound, high_bound;
140f8057
JR
211- struct type *range = check_typedef (TYPE_INDEX_TYPE (value_type (array)));
212- enum range_type range_type
213- = (enum range_type) longest_to_int (exp->elts[pc].longconst);
214-
215- *pos += 3;
4b0e5c1b
AM
216-
217- if (range_type == LOW_BOUND_DEFAULT || range_type == BOTH_BOUND_DEFAULT)
218- low_bound = TYPE_LOW_BOUND (range);
219- else
220- low_bound = value_as_long (evaluate_subexp (NULL_TYPE, exp, pos, noside));
77d10998 221+ int i, dim_count = 0;
140f8057
JR
222+ struct value *new_array = array;
223+ struct type *array_type = check_typedef (value_type (new_array));
224+ struct type *elt_type;
225+
77d10998 226+ typedef struct
140f8057
JR
227+ {
228+ enum range_type f90_range_type;
229+ LONGEST low, high, stride;
230+ } subscript_range;
231+
232+ typedef enum subscript_kind
233+ {
234+ SUBSCRIPT_RANGE, /* e.g. "(lowbound:highbound)" */
235+ SUBSCRIPT_INDEX /* e.g. "(literal)" */
236+ } kind;
237+
238+ /* Local struct to hold user data for Fortran subarray dimensions. */
239+ struct subscript_store
240+ {
241+ /* For every dimension, we are either working on a range or an index
242+ expression, so we store this info separately for later. */
243+ enum subscript_kind kind;
244+
245+ /* We also store either the lower and upper bound info, or the index
246+ number. Before evaluation of the input values, we do not know if we are
247+ actually working on a range of ranges, or an index in a range. So as a
248+ first step we store all input in a union. The array calculation itself
249+ deals with this later on. */
250+ union element_range
251+ {
252+ subscript_range range;
253+ LONGEST number;
254+ } U;
255+ } *subscript_array;
256+
257+ /* Check if the number of arguments provided by the user matches
258+ the number of dimension of the array. A string has only one
259+ dimension. */
260+ if (nargs != calc_f77_array_dims (value_type (new_array)))
261+ error (_("Wrong number of subscripts"));
262+
263+ subscript_array = (struct subscript_store*) alloca (sizeof (*subscript_array) * nargs);
264+
265+ /* Parse the user input into the SUBSCRIPT_ARRAY to store it. We need
266+ to evaluate it first, as the input is from left-to-right. The
267+ array is stored from right-to-left. So we have to use the user
268+ input in reverse order. Later on, we need the input information to
269+ re-calculate the output array. For multi-dimensional arrays, we
270+ can be dealing with any possible combination of ranges and indices
271+ for every dimension. */
272+ for (i = 0; i < nargs; i++)
273+ {
274+ struct subscript_store *index = &subscript_array[i];
77d10998 275+
140f8057
JR
276+ /* The user input is a range, with or without lower and upper bound.
277+ E.g.: "p arry(2:5)", "p arry( :5)", "p arry( : )", etc. */
278+ if (exp->elts[*pos].opcode == OP_RANGE)
279+ {
280+ int pc = (*pos) + 1;
281+ subscript_range *range;
4b0e5c1b 282+
140f8057
JR
283+ index->kind = SUBSCRIPT_RANGE;
284+ range = &index->U.range;
285+
286+ *pos += 3;
287+ range->f90_range_type = (enum range_type) exp->elts[pc].longconst;
288+
289+ /* If a lower bound was provided by the user, the bit has been
290+ set and we can assign the value from the elt stack. Same for
291+ upper bound. */
292+ if ((range->f90_range_type & SUBARRAY_LOW_BOUND)
293+ == SUBARRAY_LOW_BOUND)
294+ range->low = value_as_long (evaluate_subexp (NULL_TYPE, exp,
295+ pos, noside));
296+ if ((range->f90_range_type & SUBARRAY_HIGH_BOUND)
297+ == SUBARRAY_HIGH_BOUND)
298+ range->high = value_as_long (evaluate_subexp (NULL_TYPE, exp,
299+ pos, noside));
300+
301+ /* Assign the user's stride value if provided. */
302+ if ((range->f90_range_type & SUBARRAY_STRIDE) == SUBARRAY_STRIDE)
303+ range->stride = value_as_long (evaluate_subexp (NULL_TYPE, exp,
304+ pos, noside));
305+
306+ /* Assign the default stride value '1'. */
307+ else
308+ range->stride = 1;
77d10998
AM
309
310- if (range_type == HIGH_BOUND_DEFAULT || range_type == BOTH_BOUND_DEFAULT)
311- high_bound = TYPE_HIGH_BOUND (range);
312- else
313- high_bound = value_as_long (evaluate_subexp (NULL_TYPE, exp, pos, noside));
140f8057
JR
314+ /* Check the provided stride value is illegal, aka '0'. */
315+ if (range->stride == 0)
316+ error (_("Stride must not be 0"));
317+ }
318+ /* User input is an index. E.g.: "p arry(5)". */
319+ else
320+ {
321+ struct value *val;
322+
323+ index->kind = SUBSCRIPT_INDEX;
324+
325+ /* Evaluate each subscript; it must be a legal integer in F77. This
326+ ensures the validity of the provided index. */
327+ val = evaluate_subexp_with_coercion (exp, pos, noside);
328+ index->U.number = value_as_long (val);
329+ }
330+
331+ }
332+
333+ /* Traverse the array from right to left and set the high and low bounds
334+ for later use. */
335+ for (i = nargs - 1; i >= 0; i--)
336+ {
337+ struct subscript_store *index = &subscript_array[i];
338+ struct type *index_type = TYPE_INDEX_TYPE (array_type);
339+
340+ switch (index->kind)
341+ {
342+ case SUBSCRIPT_RANGE:
343+ {
344+
345+ /* When we hit the first range specified by the user, we must
346+ treat any subsequent user entry as a range. We simply
347+ increment DIM_COUNT which tells us how many times we are
348+ calling VALUE_SLICE_1. */
349+ subscript_range *range = &index->U.range;
350+
351+ /* If no lower bound was provided by the user, we take the
352+ default boundary. Same for the high bound. */
353+ if ((range->f90_range_type & SUBARRAY_LOW_BOUND) == 0)
354+ range->low = TYPE_LOW_BOUND (index_type);
355+
356+ if ((range->f90_range_type & SUBARRAY_HIGH_BOUND) == 0)
357+ range->high = TYPE_HIGH_BOUND (index_type);
358+
359+ /* Both user provided low and high bound have to be inside the
360+ array bounds. Throw an error if not. */
361+ if (range->low < TYPE_LOW_BOUND (index_type)
362+ || range->low > TYPE_HIGH_BOUND (index_type)
363+ || range->high < TYPE_LOW_BOUND (index_type)
364+ || range->high > TYPE_HIGH_BOUND (index_type))
365+ error (_("provided bound(s) outside array bound(s)"));
366+
367+ /* For a negative stride the lower boundary must be larger than the
368+ upper boundary.
369+ For a positive stride the lower boundary must be smaller than the
370+ upper boundary. */
371+ if ((range->stride < 0 && range->low < range->high)
372+ || (range->stride > 0 && range->low > range->high))
373+ error (_("Wrong value provided for stride and boundaries"));
374+
375+ }
376+ break;
377+
378+ case SUBSCRIPT_INDEX:
379+ break;
4b0e5c1b 380+
140f8057
JR
381+ }
382+
383+ array_type = TYPE_TARGET_TYPE (array_type);
384+ }
385+
386+ /* Reset ARRAY_TYPE before slicing.*/
387+ array_type = check_typedef (value_type (new_array));
388+
389+ /* Traverse the array from right to left and evaluate each corresponding
390+ user input. VALUE_SUBSCRIPT is called for every index, until a range
391+ expression is evaluated. After a range expression has been evaluated,
392+ every subsequent expression is also treated as a range. */
393+ for (i = nargs - 1; i >= 0; i--)
394+ {
395+ struct subscript_store *index = &subscript_array[i];
396+ struct type *index_type = TYPE_INDEX_TYPE (array_type);
397+
398+ switch (index->kind)
399+ {
400+ case SUBSCRIPT_RANGE:
401+ {
402+
403+ /* When we hit the first range specified by the user, we must
404+ treat any subsequent user entry as a range. We simply
405+ increment DIM_COUNT which tells us how many times we are
406+ calling VALUE_SLICE_1. */
407+ subscript_range *range = &index->U.range;
408+
409+ /* DIM_COUNT counts every user argument that is treated as a range.
410+ This is necessary for expressions like 'print array(7, 8:9).
411+ Here the first argument is a literal, but must be treated as a
412+ range argument to allow the correct output representation. */
413+ dim_count++;
414+
415+ new_array
416+ = value_slice_1 (new_array, range->low,
417+ range->high - range->low + 1,
418+ range->stride, dim_count);
419+ }
420+ break;
421+
422+ case SUBSCRIPT_INDEX:
423+ {
424+ /* DIM_COUNT only stays '0' when no range argument was processed
425+ before, starting from the last dimension. This way we can
426+ reduce the number of dimensions from the result array.
427+ However, if a range has been processed before an index, we
428+ treat the index like a range with equal low- and high bounds
429+ to get the value offset right. */
430+ if (dim_count == 0)
431+ new_array
432+ = value_subscripted_rvalue (new_array, index->U.number,
433+ f77_get_lowerbound (value_type
434+ (new_array)));
435+ else
436+ {
437+ dim_count++;
438+
439+ /* We might end up here, because we have to treat the provided
440+ index like a range. But now VALUE_SUBSCRIPTED_RVALUE
441+ cannot do the range checks for us. So we have to make sure
442+ ourselves that the user provided index is inside the
443+ array bounds. Throw an error if not. */
444+ if (index->U.number < TYPE_LOW_BOUND (index_type)
445+ && index->U.number > TYPE_HIGH_BOUND (index_type))
446+ error (_("provided bound(s) outside array bound(s)"));
447+
448+ if (index->U.number > TYPE_LOW_BOUND (index_type)
449+ && index->U.number > TYPE_HIGH_BOUND (index_type))
450+ error (_("provided bound(s) outside array bound(s)"));
451+
452+ new_array = value_slice_1 (new_array,
453+ index->U.number,
454+ 1, /* COUNT is '1' element */
455+ 1, /* STRIDE set to '1' */
456+ dim_count);
457+ }
458+
459+ }
460+ break;
461+ }
462+ array_type = TYPE_TARGET_TYPE (array_type);
463+ }
464+
465+ /* With DIM_COUNT > 1 we currently have a one dimensional array, but expect
466+ an array of arrays, depending on how many ranges have been provided by
467+ the user. So we need to rebuild the array dimensions for printing it
468+ correctly.
469+ Starting from right to left in the user input, after we hit the first
470+ range argument every subsequent argument is also treated as a range.
471+ E.g.:
472+ "p ary(3, 7, 2:15)" in Fortran has only 1 dimension, but we calculated 3
473+ ranges.
474+ "p ary(3, 7:12, 4)" in Fortran has only 1 dimension, but we calculated 2
475+ ranges.
476+ "p ary(2:4, 5, 7)" in Fortran has only 1 dimension, and we calculated 1
477+ range. */
478+ if (dim_count > 1)
479+ {
480+ struct value *v = NULL;
481+
482+ elt_type = TYPE_TARGET_TYPE (value_type (new_array));
77d10998
AM
483
484- return value_slice (array, low_bound, high_bound - low_bound + 1);
140f8057
JR
485+ /* Every SUBSCRIPT_RANGE in the user input signifies an actual range in
486+ the output array. So we traverse the SUBSCRIPT_ARRAY again, looking
487+ for a range entry. When we find one, we use the range info to create
488+ an additional range_type to set the correct bounds and dimensions for
489+ the output array. In addition, we may have a stride value that is not
490+ '1', forcing us to adjust the number of elements in a range, according
491+ to the stride value. */
492+ for (i = 0; i < nargs; i++)
493+ {
494+ struct subscript_store *index = &subscript_array[i];
495+
496+ if (index->kind == SUBSCRIPT_RANGE)
497+ {
498+ struct type *range_type, *interim_array_type;
499+
500+ int new_length;
77d10998 501+
140f8057
JR
502+ /* The length of a sub-dimension with all elements between the
503+ bounds plus the start element itself. It may be modified by
504+ a user provided stride value. */
505+ new_length = index->U.range.high - index->U.range.low;
506+
507+ new_length /= index->U.range.stride;
508+
509+ range_type
510+ = create_static_range_type (NULL,
511+ elt_type,
512+ index->U.range.low,
513+ index->U.range.low + new_length);
514+
515+ interim_array_type = create_array_type (NULL,
516+ elt_type,
517+ range_type);
518+
519+ TYPE_CODE (interim_array_type)
520+ = TYPE_CODE (value_type (new_array));
521+
522+ v = allocate_value (interim_array_type);
523+
524+ elt_type = value_type (v);
525+ }
526+
527+ }
528+ value_contents_copy (v, 0, new_array, 0, TYPE_LENGTH (elt_type));
529+ return v;
530+ }
531+
532+ return new_array;
533 }
534
535
77d10998
AM
536@@ -1242,19 +1537,6 @@ evaluate_funcall (type *expect_type, expression *exp, int *pos,
537 return eval_call (exp, noside, nargs, argvec, var_func_name, expect_type);
538 }
539
540-/* Helper for skipping all the arguments in an undetermined argument list.
541- This function was designed for use in the OP_F77_UNDETERMINED_ARGLIST
542- case of evaluate_subexp_standard as multiple, but not all, code paths
543- require a generic skip. */
544-
545-static void
546-skip_undetermined_arglist (int nargs, struct expression *exp, int *pos,
547- enum noside noside)
548-{
549- for (int i = 0; i < nargs; ++i)
550- evaluate_subexp (NULL_TYPE, exp, pos, noside);
551-}
552-
553 struct value *
554 evaluate_subexp_standard (struct type *expect_type,
555 struct expression *exp, int *pos,
556@@ -1949,33 +2231,8 @@ evaluate_subexp_standard (struct type *expect_type,
140f8057
JR
557 switch (code)
558 {
559 case TYPE_CODE_ARRAY:
560- if (exp->elts[*pos].opcode == OP_RANGE)
561- return value_f90_subarray (arg1, exp, pos, noside);
562- else
77d10998
AM
563- {
564- if (noside == EVAL_SKIP)
565- {
566- skip_undetermined_arglist (nargs, exp, pos, noside);
567- /* Return the dummy value with the correct type. */
568- return arg1;
569- }
570- goto multi_f77_subscript;
571- }
140f8057
JR
572-
573 case TYPE_CODE_STRING:
574- if (exp->elts[*pos].opcode == OP_RANGE)
575- return value_f90_subarray (arg1, exp, pos, noside);
576- else
577- {
77d10998
AM
578- if (noside == EVAL_SKIP)
579- {
580- skip_undetermined_arglist (nargs, exp, pos, noside);
581- /* Return the dummy value with the correct type. */
582- return arg1;
583- }
140f8057
JR
584- arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
585- return value_subscript (arg1, value_as_long (arg2));
586- }
587+ return value_f90_subarray (arg1, exp, pos, nargs, noside);
588
589 case TYPE_CODE_PTR:
590 case TYPE_CODE_FUNC:
77d10998 591@@ -2372,49 +2629,6 @@ evaluate_subexp_standard (struct type *expect_type,
140f8057
JR
592 }
593 return (arg1);
594
595- multi_f77_subscript:
596- {
597- LONGEST subscript_array[MAX_FORTRAN_DIMS];
598- int ndimensions = 1, i;
599- struct value *array = arg1;
600-
601- if (nargs > MAX_FORTRAN_DIMS)
602- error (_("Too many subscripts for F77 (%d Max)"), MAX_FORTRAN_DIMS);
603-
604- ndimensions = calc_f77_array_dims (type);
605-
606- if (nargs != ndimensions)
607- error (_("Wrong number of subscripts"));
608-
609- gdb_assert (nargs > 0);
610-
611- /* Now that we know we have a legal array subscript expression
612- let us actually find out where this element exists in the array. */
613-
614- /* Take array indices left to right. */
615- for (i = 0; i < nargs; i++)
616- {
617- /* Evaluate each subscript; it must be a legal integer in F77. */
618- arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
619-
620- /* Fill in the subscript array. */
621-
622- subscript_array[i] = value_as_long (arg2);
623- }
624-
625- /* Internal type of array is arranged right to left. */
626- for (i = nargs; i > 0; i--)
627- {
628- struct type *array_type = check_typedef (value_type (array));
629- LONGEST index = subscript_array[i - 1];
630-
631- array = value_subscripted_rvalue (array, index,
632- f77_get_lowerbound (array_type));
633- }
634-
635- return array;
636- }
637-
638 case BINOP_LOGICAL_AND:
639 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
640 if (noside == EVAL_SKIP)
77d10998 641@@ -3334,6 +3548,9 @@ calc_f77_array_dims (struct type *array_type)
140f8057
JR
642 int ndimen = 1;
643 struct type *tmp_type;
644
645+ if (TYPE_CODE (array_type) == TYPE_CODE_STRING)
646+ return 1;
647+
648 if ((TYPE_CODE (array_type) != TYPE_CODE_ARRAY))
649 error (_("Can't get dimensions for a non-array type"));
650
4b0e5c1b 651diff --git a/gdb/expprint.c b/gdb/expprint.c
4b0e5c1b
AM
652--- a/gdb/expprint.c
653+++ b/gdb/expprint.c
ed003b1c
AM
654@@ -578,17 +578,14 @@ print_subexp_standard (struct expression *exp, int *pos,
655 longest_to_int (exp->elts[pc + 1].longconst);
140f8057
JR
656 *pos += 2;
657
ed003b1c
AM
658- if (range_type == NONE_BOUND_DEFAULT_EXCLUSIVE
659- || range_type == LOW_BOUND_DEFAULT_EXCLUSIVE)
660+ if ((range_type & SUBARRAY_HIGH_BOUND_EXCLUSIVE)
661+ == SUBARRAY_HIGH_BOUND_EXCLUSIVE)
662 fputs_filtered ("EXCLUSIVE_", stream);
140f8057
JR
663 fputs_filtered ("RANGE(", stream);
664- if (range_type == HIGH_BOUND_DEFAULT
ed003b1c
AM
665- || range_type == NONE_BOUND_DEFAULT
666- || range_type == NONE_BOUND_DEFAULT_EXCLUSIVE)
140f8057
JR
667+ if ((range_type & SUBARRAY_LOW_BOUND) == SUBARRAY_LOW_BOUND)
668 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
669 fputs_filtered ("..", stream);
670- if (range_type == LOW_BOUND_DEFAULT
671- || range_type == NONE_BOUND_DEFAULT)
672+ if ((range_type & SUBARRAY_HIGH_BOUND) == SUBARRAY_HIGH_BOUND)
673 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
674 fputs_filtered (")", stream);
675 return;
77d10998 676@@ -1105,22 +1102,24 @@ dump_subexp_body_standard (struct expression *exp,
140f8057
JR
677
678 switch (range_type)
679 {
680- case BOTH_BOUND_DEFAULT:
681+ case SUBARRAY_NONE_BOUND:
682 fputs_filtered ("Range '..'", stream);
683 break;
684- case LOW_BOUND_DEFAULT:
685+ case SUBARRAY_HIGH_BOUND:
686 fputs_filtered ("Range '..EXP'", stream);
687 break;
ed003b1c
AM
688- case LOW_BOUND_DEFAULT_EXCLUSIVE:
689- fputs_filtered ("ExclusiveRange '..EXP'", stream);
690- break;
140f8057
JR
691- case HIGH_BOUND_DEFAULT:
692+ case SUBARRAY_LOW_BOUND:
693 fputs_filtered ("Range 'EXP..'", stream);
694 break;
695- case NONE_BOUND_DEFAULT:
ed003b1c
AM
696+ case (SUBARRAY_LOW_BOUND
697+ | SUBARRAY_HIGH_BOUND
698+ | SUBARRAY_HIGH_BOUND_EXCLUSIVE):
699+ fputs_filtered ("ExclusiveRange '..EXP'", stream);
700+ break;
140f8057
JR
701+ case (SUBARRAY_LOW_BOUND | SUBARRAY_HIGH_BOUND):
702 fputs_filtered ("Range 'EXP..EXP'", stream);
703 break;
ed003b1c
AM
704- case NONE_BOUND_DEFAULT_EXCLUSIVE:
705+ case (SUBARRAY_HIGH_BOUND | SUBARRAY_HIGH_BOUND_EXCLUSIVE):
706 fputs_filtered ("ExclusiveRange 'EXP..EXP'", stream);
707 break;
140f8057 708 default:
77d10998 709@@ -1128,11 +1127,9 @@ dump_subexp_body_standard (struct expression *exp,
140f8057
JR
710 break;
711 }
712
713- if (range_type == HIGH_BOUND_DEFAULT
714- || range_type == NONE_BOUND_DEFAULT)
715+ if ((range_type & SUBARRAY_LOW_BOUND) == SUBARRAY_LOW_BOUND)
716 elt = dump_subexp (exp, stream, elt);
717- if (range_type == LOW_BOUND_DEFAULT
718- || range_type == NONE_BOUND_DEFAULT)
719+ if ((range_type & SUBARRAY_HIGH_BOUND) == SUBARRAY_HIGH_BOUND)
720 elt = dump_subexp (exp, stream, elt);
721 }
722 break;
4b0e5c1b 723diff --git a/gdb/expression.h b/gdb/expression.h
4b0e5c1b
AM
724--- a/gdb/expression.h
725+++ b/gdb/expression.h
77d10998 726@@ -150,28 +150,27 @@ extern void dump_raw_expression (struct expression *,
140f8057
JR
727 struct ui_file *, const char *);
728 extern void dump_prefix_expression (struct expression *, struct ui_file *);
729
730-/* In an OP_RANGE expression, either bound could be empty, indicating
731- that its value is by default that of the corresponding bound of the
ed003b1c
AM
732- array or string. Also, the upper end of the range can be exclusive
733- or inclusive. So we have six sorts of subrange. This enumeration
734- type is to identify this. */
735+/* In an OP_RANGE expression, either bound can be provided by the
736+ user, or not. In addition to this, the user can also specify a
737+ stride value to indicated only certain elements of the array.
738+ Also, the upper end of the range can be exclusive or inclusive.
739+ This enumeration type is to identify this. */
740
140f8057 741 enum range_type
ed003b1c
AM
742-{
743- /* Neither the low nor the high bound was given -- so this refers to
744- the entire available range. */
745- BOTH_BOUND_DEFAULT,
746- /* The low bound was not given and the high bound is inclusive. */
747- LOW_BOUND_DEFAULT,
748- /* The high bound was not given and the low bound in inclusive. */
749- HIGH_BOUND_DEFAULT,
750- /* Both bounds were given and both are inclusive. */
751- NONE_BOUND_DEFAULT,
752- /* The low bound was not given and the high bound is exclusive. */
753- NONE_BOUND_DEFAULT_EXCLUSIVE,
754- /* Both bounds were given. The low bound is inclusive and the high
755- bound is exclusive. */
756- LOW_BOUND_DEFAULT_EXCLUSIVE,
757-};
758+ {
140f8057
JR
759+ SUBARRAY_NONE_BOUND = 0x0, /* "( : )" */
760+ SUBARRAY_LOW_BOUND = 0x1, /* "(low:)" */
761+ SUBARRAY_HIGH_BOUND = 0x2, /* "(:high)" */
ed003b1c
AM
762+ SUBARRAY_STRIDE = 0x4, /* "(::stride)" */
763+ /* The low bound was not given and the high bound is exclusive.
764+ In this case we always use (SUBARRAY_HIGH_BOUND |
765+ SUBARRAY_HIGH_BOUND_EXCLUSIVE). */
766+ SUBARRAY_HIGH_BOUND_EXCLUSIVE = 0x8,
767+ /* Both bounds were given. The low bound is inclusive and the high
768+ bound is exclusive. In this case, we use (SUBARRAY_LOW_BOUND |
769+ SUBARRAY_HIGH_BOUND | SUBARRAY_HIGH_BOUND_EXCLUSIVE). */
770+ // SUBARRAY_LOW_BOUND_EXCLUSIVE = (SUBARRAY_LOW_BOUND
771+ // | SUBARRAY_HIGH_BOUND_EXCLUSIVE),
772+ };
140f8057
JR
773
774 #endif /* !defined (EXPRESSION_H) */
4b0e5c1b 775diff --git a/gdb/f-exp.y b/gdb/f-exp.y
4b0e5c1b
AM
776--- a/gdb/f-exp.y
777+++ b/gdb/f-exp.y
778@@ -257,31 +257,63 @@ arglist : subrange
140f8057
JR
779
780 arglist : arglist ',' exp %prec ABOVE_COMMA
781 { arglist_len++; }
782+ | arglist ',' subrange %prec ABOVE_COMMA
783+ { arglist_len++; }
784 ;
785
786 /* There are four sorts of subrange types in F90. */
787
788 subrange: exp ':' exp %prec ABOVE_COMMA
789- { write_exp_elt_opcode (pstate, OP_RANGE);
790- write_exp_elt_longcst (pstate, NONE_BOUND_DEFAULT);
791+ { write_exp_elt_opcode (pstate, OP_RANGE);
792+ write_exp_elt_longcst (pstate,
793+ SUBARRAY_LOW_BOUND | SUBARRAY_HIGH_BOUND);
794 write_exp_elt_opcode (pstate, OP_RANGE); }
795 ;
796
797 subrange: exp ':' %prec ABOVE_COMMA
798 { write_exp_elt_opcode (pstate, OP_RANGE);
799- write_exp_elt_longcst (pstate, HIGH_BOUND_DEFAULT);
800+ write_exp_elt_longcst (pstate, SUBARRAY_LOW_BOUND);
801 write_exp_elt_opcode (pstate, OP_RANGE); }
802 ;
803
804 subrange: ':' exp %prec ABOVE_COMMA
805 { write_exp_elt_opcode (pstate, OP_RANGE);
806- write_exp_elt_longcst (pstate, LOW_BOUND_DEFAULT);
807+ write_exp_elt_longcst (pstate, SUBARRAY_HIGH_BOUND);
808 write_exp_elt_opcode (pstate, OP_RANGE); }
809 ;
810
811 subrange: ':' %prec ABOVE_COMMA
812 { write_exp_elt_opcode (pstate, OP_RANGE);
813- write_exp_elt_longcst (pstate, BOTH_BOUND_DEFAULT);
814+ write_exp_elt_longcst (pstate, SUBARRAY_NONE_BOUND);
815+ write_exp_elt_opcode (pstate, OP_RANGE); }
816+ ;
817+
818+/* Each subrange type can have a stride argument. */
819+subrange: exp ':' exp ':' exp %prec ABOVE_COMMA
820+ { write_exp_elt_opcode (pstate, OP_RANGE);
821+ write_exp_elt_longcst (pstate, SUBARRAY_LOW_BOUND
822+ | SUBARRAY_HIGH_BOUND
823+ | SUBARRAY_STRIDE);
824+ write_exp_elt_opcode (pstate, OP_RANGE); }
825+ ;
826+
827+subrange: exp ':' ':' exp %prec ABOVE_COMMA
828+ { write_exp_elt_opcode (pstate, OP_RANGE);
829+ write_exp_elt_longcst (pstate, SUBARRAY_LOW_BOUND
830+ | SUBARRAY_STRIDE);
831+ write_exp_elt_opcode (pstate, OP_RANGE); }
832+ ;
833+
834+subrange: ':' exp ':' exp %prec ABOVE_COMMA
835+ { write_exp_elt_opcode (pstate, OP_RANGE);
836+ write_exp_elt_longcst (pstate, SUBARRAY_HIGH_BOUND
837+ | SUBARRAY_STRIDE);
838+ write_exp_elt_opcode (pstate, OP_RANGE); }
839+ ;
840+
841+subrange: ':' ':' exp %prec ABOVE_COMMA
842+ { write_exp_elt_opcode (pstate, OP_RANGE);
843+ write_exp_elt_longcst (pstate, SUBARRAY_STRIDE);
844 write_exp_elt_opcode (pstate, OP_RANGE); }
845 ;
846
4b0e5c1b 847diff --git a/gdb/f-valprint.c b/gdb/f-valprint.c
4b0e5c1b
AM
848--- a/gdb/f-valprint.c
849+++ b/gdb/f-valprint.c
850@@ -119,8 +119,14 @@ f77_print_array_1 (int nss, int ndimensions, struct type *type,
140f8057
JR
851
852 if (nss != ndimensions)
853 {
854- size_t dim_size = TYPE_LENGTH (TYPE_TARGET_TYPE (type));
855+ size_t dim_size;
856 size_t offs = 0;
857+ LONGEST byte_stride = abs (TYPE_BYTE_STRIDE (range_type));
858+
859+ if (byte_stride)
860+ dim_size = byte_stride;
861+ else
862+ dim_size = TYPE_LENGTH (TYPE_TARGET_TYPE (type));
863
864 for (i = lowerbound;
865 (i < upperbound + 1 && (*elts) < options->print_max);
4b0e5c1b 866diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
4b0e5c1b
AM
867--- a/gdb/gdbtypes.c
868+++ b/gdb/gdbtypes.c
77d10998 869@@ -911,7 +911,8 @@ operator== (const range_bounds &l, const range_bounds &r)
140f8057
JR
870 struct type *
871 create_range_type (struct type *result_type, struct type *index_type,
872 const struct dynamic_prop *low_bound,
873- const struct dynamic_prop *high_bound)
874+ const struct dynamic_prop *high_bound,
875+ const struct dynamic_prop *stride)
876 {
877 if (result_type == NULL)
878 result_type = alloc_type_copy (index_type);
77d10998 879@@ -926,6 +927,7 @@ create_range_type (struct type *result_type, struct type *index_type,
140f8057
JR
880 TYPE_ZALLOC (result_type, sizeof (struct range_bounds));
881 TYPE_RANGE_DATA (result_type)->low = *low_bound;
882 TYPE_RANGE_DATA (result_type)->high = *high_bound;
883+ TYPE_RANGE_DATA (result_type)->stride = *stride;
884
885 if (low_bound->kind == PROP_CONST && low_bound->data.const_val >= 0)
886 TYPE_UNSIGNED (result_type) = 1;
77d10998 887@@ -954,7 +956,7 @@ struct type *
140f8057
JR
888 create_static_range_type (struct type *result_type, struct type *index_type,
889 LONGEST low_bound, LONGEST high_bound)
890 {
891- struct dynamic_prop low, high;
892+ struct dynamic_prop low, high, stride;
893
894 low.kind = PROP_CONST;
895 low.data.const_val = low_bound;
77d10998 896@@ -962,7 +964,11 @@ create_static_range_type (struct type *result_type, struct type *index_type,
140f8057
JR
897 high.kind = PROP_CONST;
898 high.data.const_val = high_bound;
899
900- result_type = create_range_type (result_type, index_type, &low, &high);
901+ stride.kind = PROP_CONST;
902+ stride.data.const_val = 0;
903+
904+ result_type = create_range_type (result_type, index_type,
905+ &low, &high, &stride);
906
907 return result_type;
908 }
77d10998 909@@ -1180,16 +1186,20 @@ create_array_type_with_stride (struct type *result_type,
140f8057
JR
910 && (!type_not_associated (result_type)
911 && !type_not_allocated (result_type)))
912 {
913- LONGEST low_bound, high_bound;
914+ LONGEST low_bound, high_bound, byte_stride;
915
916 if (get_discrete_bounds (range_type, &low_bound, &high_bound) < 0)
917 low_bound = high_bound = 0;
918 element_type = check_typedef (element_type);
919+ byte_stride = abs (TYPE_BYTE_STRIDE (range_type));
920+
921 /* Be careful when setting the array length. Ada arrays can be
922 empty arrays with the high_bound being smaller than the low_bound.
923 In such cases, the array length should be zero. */
924 if (high_bound < low_bound)
925 TYPE_LENGTH (result_type) = 0;
926+ else if (byte_stride > 0)
927+ TYPE_LENGTH (result_type) = byte_stride * (high_bound - low_bound + 1);
928 else if (bit_stride > 0)
929 TYPE_LENGTH (result_type) =
930 (bit_stride * (high_bound - low_bound + 1) + 7) / 8;
77d10998 931@@ -1990,12 +2000,12 @@ resolve_dynamic_range (struct type *dyn_range_type,
140f8057
JR
932 CORE_ADDR value;
933 struct type *static_range_type, *static_target_type;
934 const struct dynamic_prop *prop;
935- struct dynamic_prop low_bound, high_bound;
936+ struct dynamic_prop low_bound, high_bound, stride;
937
938 gdb_assert (TYPE_CODE (dyn_range_type) == TYPE_CODE_RANGE);
939
940 prop = &TYPE_RANGE_DATA (dyn_range_type)->low;
941- if (dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
942+ if (dwarf2_evaluate_property_signed (prop, NULL, addr_stack, &value, 1))
943 {
944 low_bound.kind = PROP_CONST;
945 low_bound.data.const_val = value;
77d10998 946@@ -2007,7 +2017,7 @@ resolve_dynamic_range (struct type *dyn_range_type,
140f8057
JR
947 }
948
949 prop = &TYPE_RANGE_DATA (dyn_range_type)->high;
950- if (dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
951+ if (dwarf2_evaluate_property_signed (prop, NULL, addr_stack, &value, 1))
952 {
953 high_bound.kind = PROP_CONST;
954 high_bound.data.const_val = value;
77d10998 955@@ -2022,12 +2032,20 @@ resolve_dynamic_range (struct type *dyn_range_type,
140f8057
JR
956 high_bound.data.const_val = 0;
957 }
958
959+ prop = &TYPE_RANGE_DATA (dyn_range_type)->stride;
960+ if (dwarf2_evaluate_property_signed (prop, NULL, addr_stack, &value, 1))
961+ {
962+ stride.kind = PROP_CONST;
963+ stride.data.const_val = value;
964+ }
965+
966 static_target_type
967 = resolve_dynamic_type_internal (TYPE_TARGET_TYPE (dyn_range_type),
968 addr_stack, 0);
969 static_range_type = create_range_type (copy_type (dyn_range_type),
970 static_target_type,
971- &low_bound, &high_bound);
972+ &low_bound, &high_bound, &stride);
973+
974 TYPE_RANGE_DATA (static_range_type)->flag_bound_evaluated = 1;
975 return static_range_type;
976 }
4b0e5c1b 977diff --git a/gdb/gdbtypes.h b/gdb/gdbtypes.h
4b0e5c1b
AM
978--- a/gdb/gdbtypes.h
979+++ b/gdb/gdbtypes.h
77d10998 980@@ -614,6 +614,10 @@ struct range_bounds
140f8057
JR
981
982 struct dynamic_prop high;
983
984+ /* * Stride of range. */
985+
986+ struct dynamic_prop stride;
987+
988 /* True if HIGH range bound contains the number of elements in the
989 subrange. This affects how the final hight bound is computed. */
990
77d10998 991@@ -778,7 +782,6 @@ struct main_type
140f8057
JR
992 /* * Union member used for range types. */
993
994 struct range_bounds *bounds;
995-
996 } flds_bnds;
997
998 /* * Slot to point to additional language-specific fields of this
77d10998 999@@ -1327,6 +1330,15 @@ extern bool set_type_align (struct type *, ULONGEST);
140f8057
JR
1000 TYPE_RANGE_DATA(range_type)->high.kind
1001 #define TYPE_LOW_BOUND_KIND(range_type) \
1002 TYPE_RANGE_DATA(range_type)->low.kind
1003+#define TYPE_BYTE_STRIDE(range_type) \
1004+ TYPE_RANGE_DATA(range_type)->stride.data.const_val
1005+#define TYPE_BYTE_STRIDE_BLOCK(range_type) \
1006+ TYPE_RANGE_DATA(range_type)->stride.data.locexpr
1007+#define TYPE_BYTE_STRIDE_LOCLIST(range_type) \
1008+ TYPE_RANGE_DATA(range_type)->stride.data.loclist
1009+#define TYPE_BYTE_STRIDE_KIND(range_type) \
1010+ TYPE_RANGE_DATA(range_type)->stride.kind
1011+
1012
1013 /* Property accessors for the type data location. */
1014 #define TYPE_DATA_LOCATION(thistype) \
77d10998 1015@@ -1361,6 +1373,9 @@ extern bool set_type_align (struct type *, ULONGEST);
140f8057
JR
1016 TYPE_HIGH_BOUND_UNDEFINED(TYPE_INDEX_TYPE(arraytype))
1017 #define TYPE_ARRAY_LOWER_BOUND_IS_UNDEFINED(arraytype) \
1018 TYPE_LOW_BOUND_UNDEFINED(TYPE_INDEX_TYPE(arraytype))
1019+#define TYPE_ARRAY_STRIDE_IS_UNDEFINED(arraytype) \
1020+ (TYPE_BYTE_STRIDE(TYPE_INDEX_TYPE(arraytype)) == 0)
1021+
1022
1023 #define TYPE_ARRAY_UPPER_BOUND_VALUE(arraytype) \
1024 (TYPE_HIGH_BOUND(TYPE_INDEX_TYPE((arraytype))))
77d10998 1025@@ -1896,6 +1911,7 @@ extern struct type *create_array_type_with_stride
4b0e5c1b 1026 struct dynamic_prop *, unsigned int);
140f8057
JR
1027
1028 extern struct type *create_range_type (struct type *, struct type *,
140f8057 1029+ const struct dynamic_prop *,
4b0e5c1b 1030 const struct dynamic_prop *,
140f8057
JR
1031 const struct dynamic_prop *);
1032
4b0e5c1b 1033diff --git a/gdb/parse.c b/gdb/parse.c
4b0e5c1b
AM
1034--- a/gdb/parse.c
1035+++ b/gdb/parse.c
ed003b1c 1036@@ -989,24 +989,20 @@ operator_length_standard (const struct expression *expr, int endpos,
140f8057
JR
1037
1038 case OP_RANGE:
1039 oplen = 3;
1040+ args = 0;
1041 range_type = (enum range_type)
1042 longest_to_int (expr->elts[endpos - 2].longconst);
1043
1044- switch (range_type)
1045- {
1046- case LOW_BOUND_DEFAULT:
ed003b1c 1047- case LOW_BOUND_DEFAULT_EXCLUSIVE:
140f8057
JR
1048- case HIGH_BOUND_DEFAULT:
1049- args = 1;
1050- break;
1051- case BOTH_BOUND_DEFAULT:
1052- args = 0;
1053- break;
1054- case NONE_BOUND_DEFAULT:
ed003b1c 1055- case NONE_BOUND_DEFAULT_EXCLUSIVE:
140f8057
JR
1056- args = 2;
1057- break;
1058- }
1059+ /* Increment the argument counter for each argument
1060+ provided by the user. */
1061+ if ((range_type & SUBARRAY_LOW_BOUND) == SUBARRAY_LOW_BOUND)
1062+ args++;
1063+
1064+ if ((range_type & SUBARRAY_HIGH_BOUND) == SUBARRAY_HIGH_BOUND)
1065+ args++;
1066+
1067+ if ((range_type & SUBARRAY_STRIDE) == SUBARRAY_STRIDE)
1068+ args++;
1069
1070 break;
1071
4b0e5c1b 1072diff --git a/gdb/rust-exp.y b/gdb/rust-exp.y
4b0e5c1b
AM
1073--- a/gdb/rust-exp.y
1074+++ b/gdb/rust-exp.y
77d10998 1075@@ -2475,24 +2475,28 @@ rust_parser::convert_ast_to_expression (const struct rust_op *operation,
140f8057
JR
1076
1077 case OP_RANGE:
1078 {
1079- enum range_type kind = BOTH_BOUND_DEFAULT;
1080+ enum range_type kind = SUBARRAY_NONE_BOUND;
1081
1082 if (operation->left.op != NULL)
1083 {
77d10998 1084 convert_ast_to_expression (operation->left.op, top);
140f8057
JR
1085- kind = HIGH_BOUND_DEFAULT;
1086+ kind = SUBARRAY_LOW_BOUND;
1087 }
1088 if (operation->right.op != NULL)
1089 {
77d10998 1090 convert_ast_to_expression (operation->right.op, top);
140f8057 1091- if (kind == BOTH_BOUND_DEFAULT)
ed003b1c
AM
1092- kind = (operation->inclusive
1093- ? LOW_BOUND_DEFAULT : LOW_BOUND_DEFAULT_EXCLUSIVE);
1094+ if (kind == SUBARRAY_NONE_BOUND)
1095+ {
1096+ kind = (range_type) SUBARRAY_HIGH_BOUND;
1097+ if (!operation->inclusive)
1098+ kind = (range_type) (kind | SUBARRAY_HIGH_BOUND_EXCLUSIVE);
1099+ }
1100 else
1101 {
140f8057 1102- gdb_assert (kind == HIGH_BOUND_DEFAULT);
ed003b1c
AM
1103- kind = (operation->inclusive
1104- ? NONE_BOUND_DEFAULT : NONE_BOUND_DEFAULT_EXCLUSIVE);
1105+ gdb_assert (kind == SUBARRAY_LOW_BOUND);
1106+ kind = (range_type) (kind | SUBARRAY_HIGH_BOUND);
1107+ if (!operation->inclusive)
1108+ kind = (range_type) (kind | SUBARRAY_HIGH_BOUND_EXCLUSIVE);
1109 }
140f8057 1110 }
ed003b1c 1111 else
4b0e5c1b 1112diff --git a/gdb/rust-lang.c b/gdb/rust-lang.c
4b0e5c1b
AM
1113--- a/gdb/rust-lang.c
1114+++ b/gdb/rust-lang.c
77d10998 1115@@ -1193,13 +1193,11 @@ rust_range (struct expression *exp, int *pos, enum noside noside)
140f8057
JR
1116 kind = (enum range_type) longest_to_int (exp->elts[*pos + 1].longconst);
1117 *pos += 3;
1118
ed003b1c
AM
1119- if (kind == HIGH_BOUND_DEFAULT || kind == NONE_BOUND_DEFAULT
1120- || kind == NONE_BOUND_DEFAULT_EXCLUSIVE)
140f8057
JR
1121+ if ((kind & SUBARRAY_LOW_BOUND) == SUBARRAY_LOW_BOUND)
1122 low = evaluate_subexp (NULL_TYPE, exp, pos, noside);
ed003b1c
AM
1123- if (kind == LOW_BOUND_DEFAULT || kind == LOW_BOUND_DEFAULT_EXCLUSIVE
1124- || kind == NONE_BOUND_DEFAULT || kind == NONE_BOUND_DEFAULT_EXCLUSIVE)
140f8057
JR
1125+ if ((kind & SUBARRAY_HIGH_BOUND) == SUBARRAY_HIGH_BOUND)
1126 high = evaluate_subexp (NULL_TYPE, exp, pos, noside);
ed003b1c
AM
1127- bool inclusive = (kind == NONE_BOUND_DEFAULT || kind == LOW_BOUND_DEFAULT);
1128+ bool inclusive = (!((kind & SUBARRAY_HIGH_BOUND_EXCLUSIVE) == SUBARRAY_HIGH_BOUND_EXCLUSIVE));
140f8057
JR
1129
1130 if (noside == EVAL_SKIP)
ed003b1c 1131 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
77d10998 1132@@ -1288,7 +1286,7 @@ rust_compute_range (struct type *type, struct value *range,
140f8057
JR
1133
1134 *low = 0;
1135 *high = 0;
1136- *kind = BOTH_BOUND_DEFAULT;
1137+ *kind = SUBARRAY_NONE_BOUND;
1138
1139 if (TYPE_NFIELDS (type) == 0)
1140 return;
77d10998 1141@@ -1296,15 +1294,14 @@ rust_compute_range (struct type *type, struct value *range,
140f8057
JR
1142 i = 0;
1143 if (strcmp (TYPE_FIELD_NAME (type, 0), "start") == 0)
1144 {
1145- *kind = HIGH_BOUND_DEFAULT;
1146+ *kind = SUBARRAY_LOW_BOUND;
1147 *low = value_as_long (value_field (range, 0));
1148 ++i;
1149 }
1150 if (TYPE_NFIELDS (type) > i
1151 && strcmp (TYPE_FIELD_NAME (type, i), "end") == 0)
1152 {
1153- *kind = (*kind == BOTH_BOUND_DEFAULT
1154- ? LOW_BOUND_DEFAULT : NONE_BOUND_DEFAULT);
1155+ *kind = (range_type) (*kind | SUBARRAY_HIGH_BOUND);
1156 *high = value_as_long (value_field (range, i));
ed003b1c
AM
1157
1158 if (rust_inclusive_range_type_p (type))
77d10998 1159@@ -1322,7 +1319,7 @@ rust_subscript (struct expression *exp, int *pos, enum noside noside,
140f8057
JR
1160 struct type *rhstype;
1161 LONGEST low, high_bound;
1162 /* Initialized to appease the compiler. */
1163- enum range_type kind = BOTH_BOUND_DEFAULT;
1164+ enum range_type kind = SUBARRAY_NONE_BOUND;
1165 LONGEST high = 0;
1166 int want_slice = 0;
1167
77d10998 1168@@ -1420,7 +1417,7 @@ rust_subscript (struct expression *exp, int *pos, enum noside noside,
140f8057
JR
1169 error (_("Cannot subscript non-array type"));
1170
1171 if (want_slice
1172- && (kind == BOTH_BOUND_DEFAULT || kind == LOW_BOUND_DEFAULT))
1173+ && ((kind & SUBARRAY_LOW_BOUND) != SUBARRAY_LOW_BOUND))
1174 low = low_bound;
1175 if (low < 0)
1176 error (_("Index less than zero"));
77d10998 1177@@ -1438,7 +1435,7 @@ rust_subscript (struct expression *exp, int *pos, enum noside noside,
140f8057
JR
1178 CORE_ADDR addr;
1179 struct value *addrval, *tem;
1180
1181- if (kind == BOTH_BOUND_DEFAULT || kind == HIGH_BOUND_DEFAULT)
1182+ if ((kind & SUBARRAY_HIGH_BOUND) != SUBARRAY_HIGH_BOUND)
1183 high = high_bound;
1184 if (high < 0)
1185 error (_("High index less than zero"));
4b0e5c1b
AM
1186diff --git a/gdb/testsuite/gdb.fortran/static-arrays.exp b/gdb/testsuite/gdb.fortran/static-arrays.exp
1187new file mode 100644
4b0e5c1b
AM
1188--- /dev/null
1189+++ b/gdb/testsuite/gdb.fortran/static-arrays.exp
140f8057
JR
1190@@ -0,0 +1,421 @@
1191+# Copyright 2015 Free Software Foundation, Inc.
1192+#
1193+# Contributed by Intel Corp. <christoph.t.weinmann@intel.com>
1194+#
1195+# This program is free software; you can redistribute it and/or modify
1196+# it under the terms of the GNU General Public License as published by
1197+# the Free Software Foundation; either version 3 of the License, or
1198+# (at your option) any later version.
1199+#
1200+# This program is distributed in the hope that it will be useful,
1201+# but WITHOUT ANY WARRANTY; without even the implied warranty of
1202+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1203+# GNU General Public License for more details.
1204+#
1205+# You should have received a copy of the GNU General Public License
1206+# along with this program. If not, see <http://www.gnu.org/licenses/>.
1207+
1208+standard_testfile static-arrays.f90
1209+
1210+if { [prepare_for_testing $testfile.exp $testfile $srcfile {debug f90}] } {
1211+ return -1
1212+}
1213+
1214+if ![runto MAIN__] then {
1215+ perror "couldn't run to breakpoint MAIN__"
1216+ continue
1217+}
1218+
1219+gdb_breakpoint [gdb_get_line_number "BP1"]
1220+gdb_continue_to_breakpoint "BP1" ".*BP1.*"
1221+
1222+# Tests subarrays of one dimensional arrays with subrange variations
1223+gdb_test "print ar1" "\\$\[0-9\]+ = \\(1, 2, 3, 4, 5, 6, 7, 8, 9\\)" \
1224+ "print ar1."
1225+gdb_test "print ar1\(4:7\)" "\\$\[0-9\]+ = \\(4, 5, 6, 7\\)" \
1226+ "print ar1\(4:7\)"
1227+gdb_test "print ar1\(8:\)" "\\$\[0-9\]+ = \\(8, 9\\).*" \
1228+ "print ar1\(8:\)"
1229+gdb_test "print ar1\(:3\)" "\\$\[0-9\]+ = \\(1, 2, 3\\).*" \
1230+ "print ar1\(:3\)"
1231+gdb_test "print ar1\(:\)" "\\$\[0-9\]+ = \\(1, 2, 3, 4, 5, 6, 7, 8, 9\\)" \
1232+ "print ar1\(:\)"
1233+
1234+# Check assignment
1235+gdb_test_no_output "set \$my_ary = ar1\(3:8\)"
1236+gdb_test "print \$my_ary" \
1237+ "\\$\[0-9\]+ = \\(3, 4, 5, 6, 7, 8\\)" \
1238+ "Assignment of subarray to variable"
1239+gdb_test_no_output "set ar1\(5\) = 42"
1240+ gdb_test "print ar1\(3:8\)" \
1241+ "\\$\[0-9\]+ = \\(3, 4, 42, 6, 7, 8\\)" \
1242+ "print ar1\(3:8\) after assignment"
1243+gdb_test "print \$my_ary" \
1244+ "\\$\[0-9\]+ = \\(3, 4, 5, 6, 7, 8\\)" \
1245+ "Assignment of subarray to variable after original array changed"
1246+
1247+# Test for subarrays of one dimensional arrays with literals
1248+ gdb_test "print ar1\(3\)" "\\$\[0-9\]+ = 3" \
1249+ "print ar1\(3\)"
1250+
1251+# Tests for subranges of 2 dimensional arrays with subrange variations
1252+gdb_test "print ar2\(2:3, 3:4\)" \
1253+ "\\$\[0-9\]+ = \\(\\( 23, 33\\) \\( 24, 34\\) \\)" \
1254+ "print ar2\(2:3, 3:4\)."
1255+gdb_test "print ar2\(8:9,8:\)" \
1256+ "\\$\[0-9\]+ = \\(\\( 88, 98\\) \\( 89, 99\\) \\)" \
1257+ "print ar2\(8:9,8:\)"
1258+gdb_test "print ar2\(8:9,:2\)" \
1259+ "\\$\[0-9\]+ = \\(\\( 81, 91\\) \\( 82, 92\\) \\)" \
1260+ "print ar2\(8:9,:2\)"
1261+
1262+gdb_test "print ar2\(8:,8:9\)" \
1263+ "\\$\[0-9\]+ = \\(\\( 88, 98\\) \\( 89, 99\\) \\)" \
1264+ "print ar2\(8:,8:9\)"
1265+gdb_test "print ar2\(8:,8:\)" \
1266+ "\\$\[0-9\]+ = \\(\\( 88, 98\\) \\( 89, 99\\) \\)" \
1267+ "print ar2\(8:,8:\)"
1268+gdb_test "print ar2\(8:,:2\)" \
1269+ "\\$\[0-9\]+ = \\(\\( 81, 91\\) \\( 82, 92\\) \\)" \
1270+ "print ar2\(8:,:2\)"
1271+
1272+gdb_test "print ar2\(:2,2:3\)" \
1273+ "\\$\[0-9\]+ = \\(\\( 12, 22\\) \\( 13, 23\\) \\)" \
1274+ "print ar2\(:2,2:3\)"
1275+gdb_test "print ar2\(:2,8:\)" \
1276+ "\\$\[0-9\]+ = \\(\\( 18, 28\\) \\( 19, 29\\) \\)" \
1277+ "print ar2\(:2,8:\)"
1278+gdb_test "print ar2\(:2,:2\)" \
1279+ "\\$\[0-9\]+ = \\(\\( 11, 21\\) \\( 12, 22\\) \\)" \
1280+ "print ar2\(:2,:2\)"
1281+
1282+# Test subranges of 2 dimensional arrays with literals and subrange variations
1283+gdb_test "print ar2\(7, 3:6\)" \
1284+ "\\$\[0-9\]+ = \\(73, 74, 75, 76\\)" \
1285+ "print ar2\(7, 3:6\)"
1286+gdb_test "print ar2\(7,8:\)" \
1287+ "\\$\[0-9\]+ = \\(78, 79\\)" \
1288+ "print ar2\(7,8:\)"
1289+gdb_test "print ar2\(7,:2\)" \
1290+ "\\$\[0-9\]+ = \\(71, 72\\)" \
1291+ "print ar2\(7,:2\)"
1292+
1293+gdb_test "print ar2\(7:8,4\)" \
1294+ "\\$\[0-9\]+ = \\(74, 84\\)" \
1295+ "print ar2(7:8,4\)"
1296+gdb_test "print ar2\(8:,4\)" \
1297+ "\\$\[0-9\]+ = \\(84, 94\\)" \
1298+ "print ar2\(8:,4\)"
1299+gdb_test "print ar2\(:2,4\)" \
1300+ "\\$\[0-9\]+ = \\(14, 24\\)" \
1301+ "print ar2\(:2,4\)"
1302+gdb_test "print ar2\(3,4\)" \
1303+ "\\$\[0-9\]+ = 34" \
1304+ "print ar2\(3,4\)"
1305+
1306+# Test subarrays of 3 dimensional arrays with literals and subrange variations
1307+gdb_test "print ar3\(2:4,3:4,7:8\)" \
1308+ "\\$\[0-9\]+ = \\(\\( \\( 237, 337, 437\\) \\( 247, 347, 447\\)\
1309+ \\) \\( \\( 238, 338, 438\\) \\( 248, 348, 448\\) \\) \\)" \
1310+ "print ar3\(2:4,3:4,7:8\)"
1311+gdb_test "print ar3\(2:3,4:5,8:\)" \
1312+ "\\$\[0-9\]+ = \\(\\( \\( 248, 348\\) \\( 258, 358\\) \\) \\(\
1313+ \\( 249, 349\\) \\( 259, 359\\) \\) \\)" \
1314+ "print ar3\(2:3,4:5,8:\)"
1315+gdb_test "print ar3\(2:3,4:5,:2\)" \
1316+ "\\$\[0-9\]+ = \\(\\( \\( 241, 341\\) \\( 251, 351\\) \\) \\(\
1317+ \\( 242, 342\\) \\( 252, 352\\) \\) \\)" \
1318+ "print ar3\(2:3,4:5,:2\)"
1319+
1320+gdb_test "print ar3\(2:3,8:,7:8\)" \
1321+ "\\$\[0-9\]+ = \\(\\( \\( 287, 387\\) \\( 297, 397\\) \\) \\(\
1322+ \\( 288, 388\\) \\( 298, 398\\) \\) \\)" \
1323+ "print ar3\(2:3,8:,7:8\)"
1324+gdb_test "print ar3\(2:3,8:,8:\)" \
1325+ "\\$\[0-9\]+ = \\(\\( \\( 288, 388\\) \\( 298, 398\\) \\) \\(\
1326+ \\( 289, 389\\) \\( 299, 399\\) \\) \\)" \
1327+ "print ar3\(2:3,8:,8:\)"
1328+gdb_test "print ar3\(2:3,8:,:2\)" \
1329+ "\\$\[0-9\]+ = \\(\\( \\( 281, 381\\) \\( 291, 391\\) \\) \\(\
1330+ \\( 282, 382\\) \\( 292, 392\\) \\) \\)" \
1331+ "print ar3\(2:3,8:,:2\)"
1332+
1333+gdb_test "print ar3\(2:3,:2,7:8\)" \
1334+ "\\$\[0-9\]+ = \\(\\( \\( 217, 317\\) \\( 227, 327\\) \\) \\(\
1335+ \\( 218, 318\\) \\( 228, 328\\) \\) \\)" \
1336+ "print ar3\(2:3,:2,7:8\)"
1337+gdb_test "print ar3\(2:3,:2,8:\)" \
1338+ "\\$\[0-9\]+ = \\(\\( \\( 218, 318\\) \\( 228, 328\\) \\) \\(\
1339+ \\( 219, 319\\) \\( 229, 329\\) \\) \\)" \
1340+ "print ar3\(2:3,:2,8:\)"
1341+gdb_test "print ar3\(2:3,:2,:2\)" \
1342+ "\\$\[0-9\]+ = \\(\\( \\( 211, 311\\) \\( 221, 321\\) \\) \\(\
1343+ \\( 212, 312\\) \\( 222, 322\\) \\) \\)" \
1344+ "print ar3\(2:3,:2,:2\)"
1345+
1346+gdb_test "print ar3\(8:,3:4,7:8\)" \
1347+ "\\$\[0-9\]+ = \\(\\( \\( 837, 937\\) \\( 847, 947\\) \\) \\(\
1348+ \\( 838, 938\\) \\( 848, 948\\) \\) \\)" \
1349+ "print ar3\(8:,3:4,7:8\)"
1350+gdb_test "print ar3\(8:,4:5,8:\)" \
1351+ "\\$\[0-9\]+ = \\(\\( \\( 848, 948\\) \\( 858, 958\\) \\) \\(\
1352+ \\( 849, 949\\) \\( 859, 959\\) \\) \\)" \
1353+ "print ar3\(8:,4:5,8:\)"
1354+gdb_test "print ar3\(8:,4:5,:2\)" \
1355+ "\\$\[0-9\]+ = \\(\\( \\( 841, 941\\) \\( 851, 951\\) \\) \\(\
1356+ \\( 842, 942\\) \\( 852, 952\\) \\) \\)" \
1357+ "print ar3\(8:,4:5,:2\)"
1358+
1359+gdb_test "print ar3\(8:,8:,7:8\)" \
1360+ "\\$\[0-9\]+ = \\(\\( \\( 887, 987\\) \\( 897, 997\\) \\) \\(\
1361+ \\( 888, 988\\) \\( 898, 998\\) \\) \\)" \
1362+ "print ar3\(8:,8:,7:8\)"
1363+gdb_test "print ar3\(8:,8:,8:\)" \
1364+ "\\$\[0-9\]+ = \\(\\( \\( 888, 988\\) \\( 898, 998\\) \\) \\(\
1365+ \\( 889, 989\\) \\( 899, 999\\) \\) \\)" \
1366+ "print ar3\(8:,8:,8:\)"
1367+gdb_test "print ar3\(8:,8:,:2\)" \
1368+ "\\$\[0-9\]+ = \\(\\( \\( 881, 981\\) \\( 891, 991\\) \\) \\(\
1369+ \\( 882, 982\\) \\( 892, 992\\) \\) \\)" \
1370+ "print ar3\(8:,8:,:2\)"
1371+
1372+gdb_test "print ar3\(8:,:2,7:8\)" \
1373+ "\\$\[0-9\]+ = \\(\\( \\( 817, 917\\) \\( 827, 927\\) \\) \\(\
1374+ \\( 818, 918\\) \\( 828, 928\\) \\) \\)" \
1375+ "print ar3\(8:,:2,7:8\)"
1376+gdb_test "print ar3\(8:,:2,8:\)" \
1377+ "\\$\[0-9\]+ = \\(\\( \\( 818, 918\\) \\( 828, 928\\) \\) \\(\
1378+ \\( 819, 919\\) \\( 829, 929\\) \\) \\)" \
1379+ "print ar3\(8:,:2,8:\)"
1380+gdb_test "print ar3\(8:,:2,:2\)" \
1381+ "\\$\[0-9\]+ = \\(\\( \\( 811, 911\\) \\( 821, 921\\) \\) \\(\
1382+ \\( 812, 912\\) \\( 822, 922\\) \\) \\)" \
1383+ "print ar3\(8:,:2,:2\)"
1384+
1385+
1386+gdb_test "print ar3\(:2,3:4,7:8\)" \
1387+ "\\$\[0-9\]+ = \\(\\( \\( 137, 237\\) \\( 147, 247\\) \\) \\(\
1388+ \\( 138, 238\\) \\( 148, 248\\) \\) \\)" \
1389+ "print ar3 \(:2,3:4,7:8\)."
1390+gdb_test "print ar3\(:2,3:4,8:\)" \
1391+ "\\$\[0-9\]+ = \\(\\( \\( 138, 238\\) \\( 148, 248\\) \\) \\(\
1392+ \\( 139, 239\\) \\( 149, 249\\) \\) \\)" \
1393+ "print ar3\(:2,3:4,8:\)"
1394+gdb_test "print ar3\(:2,3:4,:2\)" \
1395+ "\\$\[0-9\]+ = \\(\\( \\( 131, 231\\) \\( 141, 241\\) \\) \\(\
1396+ \\( 132, 232\\) \\( 142, 242\\) \\) \\)" \
1397+ "print ar3\(:2,3:4,:2\)"
1398+
1399+gdb_test "print ar3\(:2,8:,7:8\)" "\\$\[0-9\]+ = \\(\\( \\( 187, 287\\) \\(\
1400+ 197, 297\\) \\) \\( \\( 188, 288\\) \\( 198, 298\\) \\) \\)" \
1401+ "print ar3\(:2,8:,7:8\)"
1402+gdb_test "print ar3\(:2,8:,8:\)" "\\$\[0-9\]+ = \\(\\( \\( 188, 288\\) \\( 198,\
1403+ 298\\) \\) \\( \\( 189, 289\\) \\( 199, 299\\) \\) \\)" \
1404+ "print ar3\(:2,8:,8:\)"
1405+gdb_test "print ar3\(:2,8:,:2\)" "\\$\[0-9\]+ = \\(\\( \\( 181, 281\\) \\( 191,\
1406+ 291\\) \\) \\( \\( 182, 282\\) \\( 192, 292\\) \\) \\)" \
1407+ "print ar3\(:2,8:,:2\)"
1408+
1409+gdb_test "print ar3\(:2,:2,7:8\)" \
1410+ "\\$\[0-9\]+ = \\(\\( \\( 117, 217\\) \\( 127, 227\\) \\) \\(\
1411+ \\( 118, 218\\) \\( 128, 228\\) \\) \\)" \
1412+ "print ar3\(:2,:2,7:8\)"
1413+gdb_test "print ar3\(:2,:2,8:\)" \
1414+ "\\$\[0-9\]+ = \\(\\( \\( 118, 218\\) \\( 128, 228\\) \\) \\(\
1415+ \\( 119, 219\\) \\( 129, 229\\) \\) \\)" \
1416+ "print ar3\(:2,:2,8:\)"
1417+gdb_test "print ar3\(:2,:2,:2\)" \
1418+ "\\$\[0-9\]+ = \\(\\( \\( 111, 211\\) \\( 121, 221\\) \\) \\(\
1419+ \\( 112, 212\\) \\( 122, 222\\) \\) \\)" \
1420+ "print ar3\(:2,:2,:2\)"
1421+
1422+#Tests for subarrays of 3 dimensional arrays with literals and subranges
1423+gdb_test "print ar3\(3,3:4,7:8\)" \
1424+ "\\$\[0-9\]+ = \\(\\( 337, 347\\) \\( 338, 348\\) \\)" \
1425+ "print ar3\(3,3:4,7:8\)"
1426+gdb_test "print ar3\(3,4:5,8:\)" \
1427+ "\\$\[0-9\]+ = \\(\\( 348, 358\\) \\( 349, 359\\) \\)" \
1428+ "print ar3\(3,4:5,8:\)"
1429+gdb_test "print ar3\(3,4:5,:2\)" \
1430+ "\\$\[0-9\]+ = \\(\\( 341, 351\\) \\( 342, 352\\) \\)" \
1431+ "print ar3\(3,4:5,:2\)"
1432+gdb_test "print ar3\(3,4:5,3\)" \
1433+ "\\$\[0-9\]+ = \\(343, 353\\)" \
1434+ "print ar3\(3,4:5,3\)"
1435+
1436+gdb_test "print ar3\(2,8:,7:8\)" \
1437+ "\\$\[0-9\]+ = \\(\\( 287, 297\\) \\( 288, 298\\) \\)" \
1438+ "print ar3\(2,8:,7:8\)"
1439+gdb_test "print ar3\(2,8:,8:\)" \
1440+ "\\$\[0-9\]+ = \\(\\( 288, 298\\) \\( 289, 299\\) \\)" \
1441+ "print ar3\(2,8:,8:\)"
1442+gdb_test "print ar3\(2,8:,:2\)"\
1443+ "\\$\[0-9\]+ = \\(\\( 281, 291\\) \\( 282, 292\\) \\)" \
1444+ "print ar3\(2,8:,:2\)"
1445+gdb_test "print ar3\(2,8:,3\)" \
1446+ "\\$\[0-9\]+ = \\(283, 293\\)" \
1447+ "print ar3\(2,8:,3\)"
1448+
1449+gdb_test "print ar3\(2,:2,7:8\)" \
1450+ "\\$\[0-9\]+ = \\(\\( 217, 227\\) \\( 218, 228\\) \\)" \
1451+ "print ar3\(2,:2,7:8\)"
1452+gdb_test "print ar3\(2,:2,8:\)" \
1453+ "\\$\[0-9\]+ = \\(\\( 218, 228\\) \\( 219, 229\\) \\)" \
1454+ "print ar3\(2,:2,8:\)"
1455+gdb_test "print ar3\(2,:2,:2\)" \
1456+ "\\$\[0-9\]+ = \\(\\( 211, 221\\) \\( 212, 222\\) \\)" \
1457+ "print ar3\(2,:2,:2\)"
1458+gdb_test "print ar3\(2,:2,3\)" \
1459+ "\\$\[0-9\]+ = \\(213, 223\\)" \
1460+ "print ar3\(2,:2,3\)"
1461+
1462+gdb_test "print ar3\(3,4,7:8\)" \
1463+ "\\$\[0-9\]+ = \\(347, 348\\)" \
1464+ "print ar3\(3,4,7:8\)"
1465+gdb_test "print ar3\(3,4,8:\)" \
1466+ "\\$\[0-9\]+ = \\(348, 349\\)" \
1467+i "print ar3\(3,4,8:\)"
1468+gdb_test "print ar3\(3,4,:2\)" \
1469+ "\\$\[0-9\]+ = \\(341, 342\\)" \
1470+ "print ar3\(3,4,:2\)"
1471+gdb_test "print ar3\(5,6,7\)" \
1472+ "\\$\[0-9\]+ = 567" \
1473+ "print ar3\(5,6,7\)"
1474+
1475+gdb_test "print ar3\(3:4,6,7:8\)" \
1476+ "\\$\[0-9\]+ = \\(\\( 367, 467\\) \\( 368, 468\\) \\)" \
1477+ "print ar3\(3:4,6,7:8\)"
1478+gdb_test "print ar3\(3:4,6,8:\)" \
1479+ "\\$\[0-9\]+ = \\(\\( 368, 468\\) \\( 369, 469\\) \\)" \
1480+ "print ar3\(3:4,6,8:\)"
1481+gdb_test "print ar3\(3:4,6,:2\)" \
1482+ "\\$\[0-9\]+ = \\(\\( 361, 461\\) \\( 362, 462\\) \\)" \
1483+ "print ar3\(3:4,6,:2\)"
1484+gdb_test "print ar3\(3:4,6,5\)" \
1485+ "\\$\[0-9\]+ = \\(365, 465\\)" \
1486+ "print ar3\(3:4,6,5\)"
1487+
1488+gdb_test "print ar3\(8:,6,7:8\)" \
1489+ "\\$\[0-9\]+ = \\(\\( 867, 967\\) \\( 868, 968\\) \\)" \
1490+ "print ar3\(8:,6,7:8\)"
1491+gdb_test "print ar3\(8:,6,8:\)" \
1492+ "\\$\[0-9\]+ = \\(\\( 868, 968\\) \\( 869, 969\\) \\)" \
1493+ "print ar3\(8:,6,8:\)"
1494+gdb_test "print ar3\(8:,6,:2\)" \
1495+ "\\$\[0-9\]+ = \\(\\( 861, 961\\) \\( 862, 962\\) \\)" \
1496+ "print ar3\(8:,6,:2\)"
1497+gdb_test "print ar3\(8:,6,5\)" \
1498+ "\\$\[0-9\]+ = \\(865, 965\\)" \
1499+ "print ar3\(8:,6,5\)"
1500+
1501+gdb_test "print ar3\(:2,6,7:8\)" \
1502+ "\\$\[0-9\]+ = \\(\\( 167, 267\\) \\( 168, 268\\) \\)" \
1503+ "print ar3\(:2,6,7:8\)"
1504+gdb_test "print ar3\(:2,6,8:\)" \
1505+ "\\$\[0-9\]+ = \\(\\( 168, 268\\) \\( 169, 269\\) \\)" \
1506+ "print ar3\(:2,6,8:\)"
1507+gdb_test "print ar3\(:2,6,:2\)" \
1508+ "\\$\[0-9\]+ = \\(\\( 161, 261\\) \\( 162, 262\\) \\)" \
1509+ "print ar3\(:2,6,:2\)"
1510+gdb_test "print ar3\(:2,6,5\)" \
1511+ "\\$\[0-9\]+ = \\(165, 265\\)" \
1512+ "print ar3\(:2,6,5\)"
1513+
1514+gdb_test "print ar3\(3:4,5:6,4\)" \
1515+ "\\$\[0-9\]+ = \\(\\( 354, 454\\) \\( 364, 464\\) \\)" \
1516+ "print ar2\(3:4,5:6,4\)"
1517+gdb_test "print ar3\(8:,5:6,4\)" \
1518+ "\\$\[0-9\]+ = \\(\\( 854, 954\\) \\( 864, 964\\) \\)" \
1519+ "print ar2\(8:,5:6,4\)"
1520+gdb_test "print ar3\(:2,5:6,4\)" \
1521+ "\\$\[0-9\]+ = \\(\\( 154, 254\\) \\( 164, 264\\) \\)" \
1522+ "print ar2\(:2,5:6,4\)"
1523+
1524+# Stride > 1
1525+gdb_test "print ar1\(2:6:2\)" \
1526+ "\\$\[0-9\]+ = \\(2, 4, 6\\)" \
1527+ "print ar1\(2:6:2\)"
1528+gdb_test "print ar2\(2:6:2,3:4\)" \
1529+ "\\$\[0-9\]+ = \\(\\( 23, 43, 63\\) \\( 24, 44, 64\\) \\)" \
1530+ "print ar2\(2:6:2,3:4\)"
1531+gdb_test "print ar2\(2:6:2,3\)" \
1532+ "\\$\[0-9\]+ = \\(23, 43, 63\\)" \
1533+ "print ar2\(2:6:2,3\)"
1534+gdb_test "print ar3\(2:6:2,3:5:2,4:7:3\)" \
1535+ "\\$\[0-9\]+ = \\(\\( \\( 234, 434, 634\\) \\( 254, 454, 654\\)\
1536+ \\) \\( \\( 237, 437, 637\\) \\( 257, 457, 657\\) \\) \\)" \
1537+ "print ar3\(2:6:2,3:5:2,4:7:3\)"
1538+gdb_test "print ar3\(2:6:2,5,4:7:3\)" \
1539+ "\\$\[0-9\]+ = \\(\\( 254, 454, 654\\) \\( 257, 457, 657\\)\
1540+ \\)" \
1541+ "print ar3\(2:6:2,5,4:7:3\)"
1542+
1543+# Stride < 0
1544+gdb_test "print ar1\(8:2:-2\)" \
1545+ "\\$\[0-9\]+ = \\(8, 6, 4, 2\\)" \
1546+ "print ar1\(8:2:-2\)"
1547+gdb_test "print ar2\(8:2:-2,3:4\)" \
1548+ "\\$\[0-9\]+ = \\(\\( 83, 63, 43, 23\\) \\( 84, 64, 44, 24\\)\
1549+ \\)" \
1550+ "print ar2\(8:2:-2,3:4\)"
1551+gdb_test "print ar2\(2:6:2,3\)" \
1552+ "\\$\[0-9\]+ = \\(23, 43, 63\\)" \
1553+ "print ar2\(2:6:2,3\)"
1554+gdb_test "print ar3\(2:3,7:3:-4,4:7:3\)" \
1555+ "\\$\[0-9\]+ = \\(\\( \\( 274, 374\\) \\( 234, 334\\) \\) \\(\
1556+ \\( 277, 377\\) \\( 237, 337\\) \\) \\)" \
1557+ "print ar3\(2:3,7:3:-4,4:7:3\)"
1558+gdb_test "print ar3\(2:6:2,5,7:4:-3\)" \
1559+ "\\$\[0-9\]+ = \\(\\( 257, 457, 657\\) \\( 254, 454, 654\\)\
1560+ \\)" \
1561+ "print ar3\(2:6:2,5,7:4:-3\)"
1562+
1563+# Tests with negative and mixed indices
1564+gdb_test "p ar4\(2:4, -2:1, -15:-14\)" \
1565+ "\\$\[0-9\]+ = \\(\\( \\( 261, 361, 461\\) \\( 271, 371, 471\\)\
1566+ \\( 281, 381, 481\\) \\( 291, 391, 491\\) \\) \\( \\( 262,\
1567+ 362, 462\\) \\( 272, 372, 472\\) \\( 282, 382, 482\\) \\( 292,\
1568+ 392, 492\\) \\) \\)" \
1569+ "print ar4(2:4, -2:1, -15:-14)"
1570+
1571+gdb_test "p ar4\(7,-6:2:3,-7\)" \
1572+ "\\$\[0-9\]+ = \\(729, 759, 789\\)" \
1573+ "print ar4(7,-6:2:3,-7)"
1574+
1575+gdb_test "p ar4\(9:2:-2, -6:2:3, -6:-15:-3\)" \
1576+ "\\$\[0-9\]+ = \\(\\( \\( 930, 730, 530, 330\\) \\( 960, 760,\
1577+ 560, 360\\) \\( 990, 790, 590, 390\\) \\) \\( \\( 927, 727,\
1578+ 527, 327\\) \\( 957, 757, 557, 357\\) \\( 987, 787, 587,\
1579+ 387\\) \\) \\( \\( 924, 724, 524, 324\\) \\( 954, 754, 554,\
1580+ 354\\) \\( 984, 784, 584, 384\\) \\) \\( \\( 921, 721, 521,\
1581+ 321\\) \\( 951, 751, 551, 351\\) \\( 981, 781, 581, 381\\) \\)\
1582+ \\)" \
1583+ "print ar4(9:2:-2, -6:2:3, -6:-15:-3)"
1584+
1585+gdb_test "p ar4\(:,:,:\)" \
1586+ "\\$\[0-9\]+ = \\(\\( \\( 111, 211, 311, 411, 511, 611, 711,\
1587+ 811, .*" \
1588+ "print ar4(:,:,:)"
1589+
1590+# Provoke error messages for bad user input
1591+gdb_test "print ar1\(0:4\)" \
1592+ "provided bound\\(s\\) outside array bound\\(s\\)" \
1593+ "print ar1\(0:4\)"
1594+gdb_test "print ar1\(8:12\)" \
1595+ "provided bound\\(s\\) outside array bound\\(s\\)" \
1596+ "print ar1\(8:12\)"
1597+gdb_test "print ar1\(8:2:\)" \
1598+ "A syntax error in expression, near `\\)'." \
1599+ "print ar1\(8:2:\)"
1600+gdb_test "print ar1\(8:2:2\)" \
1601+ "Wrong value provided for stride and boundaries" \
1602+ "print ar1\(8:2:2\)"
1603+gdb_test "print ar1\(2:8:-2\)" \
1604+ "Wrong value provided for stride and boundaries" \
1605+ "print ar1\(2:8:-2\)"
1606+gdb_test "print ar1\(2:7:0\)" \
1607+ "Stride must not be 0" \
1608+ "print ar1\(2:7:0\)"
1609+gdb_test "print ar1\(3:7\) = 42" \
1610+ "Invalid cast." \
1611+ "Assignment of value to subarray"
4b0e5c1b
AM
1612diff --git a/gdb/testsuite/gdb.fortran/static-arrays.f90 b/gdb/testsuite/gdb.fortran/static-arrays.f90
1613new file mode 100644
4b0e5c1b
AM
1614--- /dev/null
1615+++ b/gdb/testsuite/gdb.fortran/static-arrays.f90
140f8057
JR
1616@@ -0,0 +1,55 @@
1617+! Copyright 2015 Free Software Foundation, Inc.
1618+!
1619+! Contributed by Intel Corp. <christoph.t.weinmann@intel.com>
1620+!
1621+! This program is free software; you can redistribute it and/or modify
1622+! it under the terms of the GNU General Public License as published by
1623+! the Free Software Foundation; either version 3 of the License, or
1624+! (at your option) any later version.
1625+!
1626+! This program is distributed in the hope that it will be useful,
1627+! but WITHOUT ANY WARRANTY; without even the implied warranty of
1628+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1629+! GNU General Public License for more details.
1630+!
1631+! You should have received a copy of the GNU General Public License
1632+! along with this program. If not, see <http://www.gnu.org/licenses/>.
1633+
1634+subroutine sub
1635+ integer, dimension(9) :: ar1
1636+ integer, dimension(9,9) :: ar2
1637+ integer, dimension(9,9,9) :: ar3
1638+ integer, dimension(10,-7:3, -15:-5) :: ar4
1639+ integer :: i,j,k
1640+
1641+ ar1 = 1
1642+ ar2 = 1
1643+ ar3 = 1
1644+ ar4 = 4
1645+
1646+ ! Resulting array ar3 looks like ((( 111, 112, 113, 114,...)))
1647+ do i = 1, 9, 1
1648+ ar1(i) = i
1649+ do j = 1, 9, 1
1650+ ar2(i,j) = i*10 + j
1651+ do k = 1, 9, 1
1652+ ar3(i,j,k) = i*100 + j*10 + k
1653+ end do
1654+ end do
1655+ end do
1656+
1657+ do i = 1, 10, 1
1658+ do j = -7, 3, 1
1659+ do k = -15, -5, 1
1660+ ar4(i,j,k) = i*100 + (j+8)*10 + (k+16)
1661+ end do
1662+ end do
1663+ end do
1664+
1665+ ar1(1) = 11 !BP1
1666+ return
1667+end
1668+
1669+program testprog
1670+ call sub
1671+end
4b0e5c1b 1672diff --git a/gdb/testsuite/gdb.fortran/vla-ptype.exp b/gdb/testsuite/gdb.fortran/vla-ptype.exp
4b0e5c1b
AM
1673--- a/gdb/testsuite/gdb.fortran/vla-ptype.exp
1674+++ b/gdb/testsuite/gdb.fortran/vla-ptype.exp
1675@@ -98,3 +98,7 @@ gdb_test "ptype vla2" "type = <not allocated>" "ptype vla2 not allocated"
140f8057
JR
1676 gdb_test "ptype vla2(5, 45, 20)" \
1677 "no such vector element \\\(vector not allocated\\\)" \
1678 "ptype vla2(5, 45, 20) not allocated"
1679+
1680+gdb_breakpoint [gdb_get_line_number "vla1-neg-bounds"]
1681+gdb_continue_to_breakpoint "vla1-neg-bounds"
1682+gdb_test "ptype vla1" "type = $real \\(-2:1,-5:4,-3:-1\\)" "ptype vla1 negative bounds"
4b0e5c1b 1683diff --git a/gdb/testsuite/gdb.fortran/vla-sizeof.exp b/gdb/testsuite/gdb.fortran/vla-sizeof.exp
4b0e5c1b
AM
1684--- a/gdb/testsuite/gdb.fortran/vla-sizeof.exp
1685+++ b/gdb/testsuite/gdb.fortran/vla-sizeof.exp
1686@@ -44,3 +44,7 @@ gdb_test "print sizeof(pvla)" " = 0" "print sizeof non-associated pvla"
140f8057
JR
1687 gdb_breakpoint [gdb_get_line_number "pvla-associated"]
1688 gdb_continue_to_breakpoint "pvla-associated"
1689 gdb_test "print sizeof(pvla)" " = 4000" "print sizeof associated pvla"
1690+
1691+gdb_breakpoint [gdb_get_line_number "vla1-neg-bounds"]
1692+gdb_continue_to_breakpoint "vla1-neg-bounds"
1693+gdb_test "print sizeof(vla1)" " = 480" "print sizeof vla1 negative bounds"
4b0e5c1b
AM
1694diff --git a/gdb/testsuite/gdb.fortran/vla-stride.exp b/gdb/testsuite/gdb.fortran/vla-stride.exp
1695new file mode 100644
4b0e5c1b
AM
1696--- /dev/null
1697+++ b/gdb/testsuite/gdb.fortran/vla-stride.exp
140f8057
JR
1698@@ -0,0 +1,44 @@
1699+# Copyright 2016 Free Software Foundation, Inc.
1700+
1701+# This program is free software; you can redistribute it and/or modify
1702+# it under the terms of the GNU General Public License as published by
1703+# the Free Software Foundation; either version 3 of the License, or
1704+# (at your option) any later version.
1705+#
1706+# This program is distributed in the hope that it will be useful,
1707+# but WITHOUT ANY WARRANTY; without even the implied warranty of
1708+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1709+# GNU General Public License for more details.
1710+#
1711+# You should have received a copy of the GNU General Public License
1712+# along with this program. If not, see <http://www.gnu.org/licenses/>.
1713+
1714+standard_testfile ".f90"
1715+
1716+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
1717+ {debug f90 quiet}] } {
1718+ return -1
1719+}
1720+
1721+if ![runto MAIN__] then {
1722+ perror "couldn't run to breakpoint MAIN__"
1723+ continue
1724+}
1725+
1726+gdb_breakpoint [gdb_get_line_number "re-reverse-elements"]
1727+gdb_continue_to_breakpoint "re-reverse-elements"
1728+gdb_test "print pvla" " = \\\(1, 2, 3, 4, 5, 6, 7, 8, 9, 10\\\)" \
1729+ "print re-reverse-elements"
1730+gdb_test "print pvla(1)" " = 1" "print first re-reverse-element"
1731+gdb_test "print pvla(10)" " = 10" "print last re-reverse-element"
1732+
1733+gdb_breakpoint [gdb_get_line_number "odd-elements"]
1734+gdb_continue_to_breakpoint "odd-elements"
1735+gdb_test "print pvla" " = \\\(1, 3, 5, 7, 9\\\)" "print odd-elements"
1736+gdb_test "print pvla(1)" " = 1" "print first odd-element"
1737+gdb_test "print pvla(5)" " = 9" "print last odd-element"
1738+
1739+gdb_breakpoint [gdb_get_line_number "single-element"]
1740+gdb_continue_to_breakpoint "single-element"
1741+gdb_test "print pvla" " = \\\(5\\\)" "print single-element"
1742+gdb_test "print pvla(1)" " = 5" "print one single-element"
4b0e5c1b
AM
1743diff --git a/gdb/testsuite/gdb.fortran/vla-stride.f90 b/gdb/testsuite/gdb.fortran/vla-stride.f90
1744new file mode 100644
4b0e5c1b
AM
1745--- /dev/null
1746+++ b/gdb/testsuite/gdb.fortran/vla-stride.f90
140f8057
JR
1747@@ -0,0 +1,29 @@
1748+! Copyright 2016 Free Software Foundation, Inc.
1749+!
1750+! This program is free software; you can redistribute it and/or modify
1751+! it under the terms of the GNU General Public License as published by
1752+! the Free Software Foundation; either version 3 of the License, or
1753+! (at your option) any later version.
1754+!
1755+! This program is distributed in the hope that it will be useful,
1756+! but WITHOUT ANY WARRANTY; without even the implied warranty of
1757+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1758+! GNU General Public License for more details.
1759+!
1760+! You should have received a copy of the GNU General Public License
1761+! along with this program. If not, see <http://www.gnu.org/licenses/>.
1762+
1763+program vla_stride
1764+ integer, target, allocatable :: vla (:)
1765+ integer, pointer :: pvla (:)
1766+
1767+ allocate(vla(10))
1768+ vla = (/ (I, I = 1,10) /)
1769+
1770+ pvla => vla(10:1:-1)
1771+ pvla => pvla(10:1:-1)
1772+ pvla => vla(1:10:2) ! re-reverse-elements
1773+ pvla => vla(5:4:-2) ! odd-elements
1774+
1775+ pvla => null() ! single-element
1776+end program vla_stride
4b0e5c1b 1777diff --git a/gdb/testsuite/gdb.fortran/vla.f90 b/gdb/testsuite/gdb.fortran/vla.f90
4b0e5c1b
AM
1778--- a/gdb/testsuite/gdb.fortran/vla.f90
1779+++ b/gdb/testsuite/gdb.fortran/vla.f90
1780@@ -54,4 +54,14 @@ program vla
140f8057
JR
1781
1782 allocate (vla3 (2,2)) ! vla2-deallocated
1783 vla3(:,:) = 13
1784+
1785+ allocate (vla1 (-2:1, -5:4, -3:-1))
1786+ l = allocated(vla1)
1787+
1788+ vla1(:, :, :) = 1
1789+ vla1(-2, -3, -1) = -231
1790+
1791+ deallocate (vla1) ! vla1-neg-bounds
1792+ l = allocated(vla1)
1793+
1794 end program vla
4b0e5c1b 1795diff --git a/gdb/valarith.c b/gdb/valarith.c
4b0e5c1b
AM
1796--- a/gdb/valarith.c
1797+++ b/gdb/valarith.c
77d10998 1798@@ -187,11 +187,17 @@ value_subscripted_rvalue (struct value *array, LONGEST index, int lowerbound)
140f8057
JR
1799 struct type *array_type = check_typedef (value_type (array));
1800 struct type *elt_type = check_typedef (TYPE_TARGET_TYPE (array_type));
1801 ULONGEST elt_size = type_length_units (elt_type);
1802- ULONGEST elt_offs = elt_size * (index - lowerbound);
1803+ LONGEST elt_offs = index - lowerbound;
1804+ LONGEST elt_stride = TYPE_BYTE_STRIDE (TYPE_INDEX_TYPE (array_type));
1805+
1806+ if (elt_stride != 0)
1807+ elt_offs *= elt_stride;
1808+ else
1809+ elt_offs *= elt_size;
1810
77d10998
AM
1811 if (index < lowerbound
1812 || (!TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (array_type)
1813- && elt_offs >= type_length_units (array_type))
1814+ && abs (elt_offs) >= type_length_units (array_type))
1815 || (VALUE_LVAL (array) != lval_memory
1816 && TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (array_type)))
140f8057 1817 {
4b0e5c1b 1818diff --git a/gdb/valops.c b/gdb/valops.c
4b0e5c1b
AM
1819--- a/gdb/valops.c
1820+++ b/gdb/valops.c
77d10998 1821@@ -3792,56 +3792,195 @@ value_of_this_silent (const struct language_defn *lang)
4b0e5c1b 1822
140f8057
JR
1823 struct value *
1824 value_slice (struct value *array, int lowbound, int length)
4b0e5c1b 1825+{
140f8057
JR
1826+ /* Pass unaltered arguments to VALUE_SLICE_1, plus a default stride
1827+ value of '1', which returns every element between LOWBOUND and
1828+ (LOWBOUND + LENGTH). We also provide a default CALL_COUNT of '1'
1829+ as we are only considering the highest dimension, or we are
1830+ working on a one dimensional array. So we call VALUE_SLICE_1
1831+ exactly once. */
1832+ return value_slice_1 (array, lowbound, length, 1, 1);
1833+}
1834+
1835+/* VALUE_SLICE_1 is called for each array dimension to calculate the number
1836+ of elements as defined by the subscript expression.
1837+ CALL_COUNT is used to determine if we are calling the function once, e.g.
1838+ we are working on the current dimension of ARRAY, or if we are calling
1839+ the function repeatedly. In the later case we need to take elements
1840+ from the TARGET_TYPE of ARRAY.
1841+ With a CALL_COUNT greater than 1 we calculate the offsets for every element
1842+ that should be in the result array. Then we fetch the contents and then
1843+ copy them into the result array. The result array will have one dimension
1844+ less than the input array, so later on we need to recreate the indices and
1845+ ranges in the calling function. */
1846+
1847+struct value *
1848+value_slice_1 (struct value *array, int lowbound, int length,
1849+ int stride_length, int call_count)
4b0e5c1b 1850 {
140f8057
JR
1851 struct type *slice_range_type, *slice_type, *range_type;
1852- LONGEST lowerbound, upperbound;
1853- struct value *slice;
1854- struct type *array_type;
1855+ struct type *array_type = check_typedef (value_type (array));
1856+ struct type *elt_type = check_typedef (TYPE_TARGET_TYPE (array_type));
1857+ unsigned int elt_size, elt_offs;
1858+ LONGEST ary_high_bound, ary_low_bound;
1859+ struct value *v;
1860+ int slice_range_size, i = 0, row_count = 1, elem_count = 1;
1861
1862- array_type = check_typedef (value_type (array));
1863+ /* Check for legacy code if we are actually dealing with an array or
1864+ string. */
1865 if (TYPE_CODE (array_type) != TYPE_CODE_ARRAY
1866 && TYPE_CODE (array_type) != TYPE_CODE_STRING)
1867 error (_("cannot take slice of non-array"));
1868
1869- range_type = TYPE_INDEX_TYPE (array_type);
1870- if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
1871- error (_("slice from bad array or bitstring"));
140f8057
JR
1872+ ary_low_bound = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (array_type));
1873+ ary_high_bound = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (array_type));
1874+
1875+ /* When we are working on a multi-dimensional array, we need to get the
1876+ attributes of the underlying type. */
1877+ if (call_count > 1)
1878+ {
1879+ ary_low_bound = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (elt_type));
1880+ ary_high_bound = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (elt_type));
1881+ elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
1882+ row_count = TYPE_LENGTH (array_type)
1883+ / TYPE_LENGTH (TYPE_TARGET_TYPE (array_type));
1884+ }
1885+
1886+ /* With a stride of '1', the number of elements per result row is equal to
1887+ the LENGTH of the subarray. With non-default stride values, we skip
1888+ elements, but have to add the start element to the total number of
1889+ elements per row. */
1890+ if (stride_length == 1)
1891+ elem_count = length;
1892+ else
1893+ elem_count = ((length - 1) / stride_length) + 1;
1894+
1895+ elt_size = TYPE_LENGTH (elt_type);
1896+ elt_offs = lowbound - ary_low_bound;
4b0e5c1b
AM
1897
1898- if (lowbound < lowerbound || length < 0
1899- || lowbound + length - 1 > upperbound)
1900- error (_("slice out of range"));
140f8057
JR
1901+ elt_offs *= elt_size;
1902+
1903+ /* Check for valid user input. In case of Fortran this was already done
1904+ in the calling function. */
1905+ if (call_count == 1
1906+ && (!TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (array_type)
1907+ && elt_offs >= TYPE_LENGTH (array_type)))
1908+ error (_("no such vector element"));
1909+
1910+ /* CALL_COUNT is 1 when we are dealing either with the highest dimension
1911+ of the array, or a one dimensional array. Set RANGE_TYPE accordingly.
1912+ In both cases we calculate how many rows/elements will be in the output
1913+ array by setting slice_range_size. */
1914+ if (call_count == 1)
1915+ {
1916+ range_type = TYPE_INDEX_TYPE (array_type);
1917+ slice_range_size = ary_low_bound + elem_count - 1;
1918+
1919+ /* Check if the array bounds are valid. */
1920+ if (get_discrete_bounds (range_type, &ary_low_bound, &ary_high_bound) < 0)
1921+ error (_("slice from bad array or bitstring"));
1922+ }
1923+ /* When CALL_COUNT is greater than 1, we are dealing with an array of arrays.
1924+ So we need to get the type below the current one and set the RANGE_TYPE
1925+ accordingly. */
1926+ else
1927+ {
1928+ range_type = TYPE_INDEX_TYPE (TYPE_TARGET_TYPE (array_type));
1929+ slice_range_size = ary_low_bound + (row_count * elem_count) - 1;
1930+ ary_low_bound = TYPE_LOW_BOUND (range_type);
1931+ }
1932
1933 /* FIXME-type-allocation: need a way to free this type when we are
1934- done with it. */
1935- slice_range_type = create_static_range_type ((struct type *) NULL,
1936- TYPE_TARGET_TYPE (range_type),
1937- lowbound,
1938- lowbound + length - 1);
1939+ done with it. */
1940
1941+ slice_range_type = create_static_range_type (NULL, TYPE_TARGET_TYPE (range_type),
1942+ ary_low_bound, slice_range_size);
1943 {
1944- struct type *element_type = TYPE_TARGET_TYPE (array_type);
1945- LONGEST offset
1946- = (lowbound - lowerbound) * TYPE_LENGTH (check_typedef (element_type));
140f8057
JR
1947+ struct type *element_type;
1948+
1949+ /* When both CALL_COUNT and STRIDE_LENGTH equal 1, we can use the legacy
1950+ code for subarrays. */
1951+ if (call_count == 1 && stride_length == 1)
1952+ {
1953+ element_type = TYPE_TARGET_TYPE (array_type);
1954+
1955+ slice_type = create_array_type (NULL, element_type, slice_range_type);
4b0e5c1b
AM
1956
1957- slice_type = create_array_type ((struct type *) NULL,
1958- element_type,
1959- slice_range_type);
1960- TYPE_CODE (slice_type) = TYPE_CODE (array_type);
140f8057 1961+ TYPE_CODE (slice_type) = TYPE_CODE (array_type);
4b0e5c1b
AM
1962
1963- if (VALUE_LVAL (array) == lval_memory && value_lazy (array))
1964- slice = allocate_value_lazy (slice_type);
140f8057
JR
1965+ if (VALUE_LVAL (array) == lval_memory && value_lazy (array))
1966+ v = allocate_value_lazy (slice_type);
1967+ else
1968+ {
1969+ v = allocate_value (slice_type);
1970+ value_contents_copy (v,
1971+ value_embedded_offset (v),
1972+ array,
1973+ value_embedded_offset (array) + elt_offs,
1974+ elt_size * longest_to_int (length));
1975+ }
4b0e5c1b 1976+
140f8057
JR
1977+ }
1978+ /* With a CALL_COUNT or STRIDE_LENGTH are greater than 1 we are working
1979+ on a range of ranges. So we copy the relevant elements into the
1980+ new array we return. */
1981 else
1982 {
1983- slice = allocate_value (slice_type);
1984- value_contents_copy (slice, 0, array, offset,
1985- type_length_units (slice_type));
1986+ int j, offs_store = elt_offs;
1987+ LONGEST dst_offset = 0;
1988+ LONGEST src_row_length = TYPE_LENGTH (TYPE_TARGET_TYPE (array_type));
1989+
1990+ if (call_count == 1)
1991+ {
1992+ /* When CALL_COUNT is equal to 1 we are working on the current range
1993+ and use these elements directly. */
1994+ element_type = TYPE_TARGET_TYPE (array_type);
1995+ }
1996+ else
1997+ {
1998+ /* Working on an array of arrays, the type of the elements is the type
1999+ of the subarrays' type. */
2000+ element_type = TYPE_TARGET_TYPE (TYPE_TARGET_TYPE (array_type));
2001+ }
2002+
2003+ slice_type = create_array_type (NULL, element_type, slice_range_type);
2004+
2005+ /* If we have a one dimensional array, we copy its TYPE_CODE. For a
2006+ multi dimensional array we copy the embedded type's TYPE_CODE. */
2007+ if (call_count == 1)
2008+ TYPE_CODE (slice_type) = TYPE_CODE (array_type);
2009+ else
2010+ TYPE_CODE (slice_type) = TYPE_CODE (TYPE_TARGET_TYPE (array_type));
2011+
2012+ v = allocate_value (slice_type);
2013+
2014+ /* Iterate through the rows of the outer array and set the new offset
2015+ for each row. */
2016+ for (i = 0; i < row_count; i++)
2017+ {
2018+ elt_offs = offs_store + i * src_row_length;
2019+
2020+ /* Iterate through the elements in each row to copy only those. */
2021+ for (j = 1; j <= elem_count; j++)
2022+ {
2023+ /* Fetches the contents of ARRAY and copies them into V. */
2024+ value_contents_copy (v, dst_offset, array, elt_offs, elt_size);
2025+ elt_offs += elt_size * stride_length;
2026+ dst_offset += elt_size;
2027+ }
2028+ }
2029 }
2030
2031- set_value_component_location (slice, array);
2032- set_value_offset (slice, value_offset (array) + offset);
2033+ set_value_component_location (v, array);
2034+ if (VALUE_LVAL (v) == lval_register)
2035+ {
2036+ VALUE_REGNUM (v) = VALUE_REGNUM (array);
2037+ VALUE_NEXT_FRAME_ID (v) = VALUE_NEXT_FRAME_ID (array);
2038+ }
2039+ set_value_offset (v, value_offset (array) + elt_offs);
2040 }
2041
2042- return slice;
2043+ return v;
2044 }
2045
2046 /* Create a value for a FORTRAN complex number. Currently most of the
4b0e5c1b 2047diff --git a/gdb/value.h b/gdb/value.h
4b0e5c1b
AM
2048--- a/gdb/value.h
2049+++ b/gdb/value.h
ed003b1c 2050@@ -1139,6 +1139,8 @@ extern struct value *varying_to_slice (struct value *);
140f8057
JR
2051
2052 extern struct value *value_slice (struct value *, int, int);
2053
2054+extern struct value *value_slice_1 (struct value *, int, int, int, int);
2055+
2056 extern struct value *value_literal_complex (struct value *, struct value *,
2057 struct type *);
2058
This page took 0.465086 seconds and 4 git commands to generate.