1 /* Fortran language support routines for GDB, the GNU debugger.
3 Copyright (C) 1993-2021 Free Software Foundation, Inc.
5 Contributed by Motorola. Adapted from the C parser by Farooq Butt
6 (fmbutt@engage.sps.mot.com).
8 This file is part of GDB.
10 This program is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 3 of the License, or
13 (at your option) any later version.
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 You should have received a copy of the GNU General Public License
21 along with this program. If not, see <http://www.gnu.org/licenses/>. */
26 #include "expression.h"
27 #include "parser-defs.h"
34 #include "cp-support.h"
37 #include "target-float.h"
40 #include "f-array-walker.h"
45 /* Whether GDB should repack array slices created by the user. */
46 static bool repack_array_slices
= false;
48 /* Implement 'show fortran repack-array-slices'. */
50 show_repack_array_slices (struct ui_file
*file
, int from_tty
,
51 struct cmd_list_element
*c
, const char *value
)
53 fprintf_filtered (file
, _("Repacking of Fortran array slices is %s.\n"),
57 /* Debugging of Fortran's array slicing. */
58 static bool fortran_array_slicing_debug
= false;
60 /* Implement 'show debug fortran-array-slicing'. */
62 show_fortran_array_slicing_debug (struct ui_file
*file
, int from_tty
,
63 struct cmd_list_element
*c
,
66 fprintf_filtered (file
, _("Debugging of Fortran array slicing is %s.\n"),
72 static value
*fortran_prepare_argument (struct expression
*exp
, int *pos
,
73 int arg_num
, bool is_internal_call_p
,
74 struct type
*func_type
,
76 static value
*fortran_prepare_argument (struct expression
*exp
,
77 expr::operation
*subexp
,
78 int arg_num
, bool is_internal_call_p
,
79 struct type
*func_type
, enum noside noside
);
81 /* Return the encoding that should be used for the character type
85 f_language::get_encoding (struct type
*type
)
89 switch (TYPE_LENGTH (type
))
92 encoding
= target_charset (type
->arch ());
95 if (type_byte_order (type
) == BFD_ENDIAN_BIG
)
96 encoding
= "UTF-32BE";
98 encoding
= "UTF-32LE";
102 error (_("unrecognized character type"));
110 /* Table of operators and their precedences for printing expressions. */
112 const struct op_print
f_language::op_print_tab
[] =
114 {"+", BINOP_ADD
, PREC_ADD
, 0},
115 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
116 {"-", BINOP_SUB
, PREC_ADD
, 0},
117 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
118 {"*", BINOP_MUL
, PREC_MUL
, 0},
119 {"/", BINOP_DIV
, PREC_MUL
, 0},
120 {"DIV", BINOP_INTDIV
, PREC_MUL
, 0},
121 {"MOD", BINOP_REM
, PREC_MUL
, 0},
122 {"=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
123 {".OR.", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
124 {".AND.", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
125 {".NOT.", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
126 {".EQ.", BINOP_EQUAL
, PREC_EQUAL
, 0},
127 {".NE.", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
128 {".LE.", BINOP_LEQ
, PREC_ORDER
, 0},
129 {".GE.", BINOP_GEQ
, PREC_ORDER
, 0},
130 {".GT.", BINOP_GTR
, PREC_ORDER
, 0},
131 {".LT.", BINOP_LESS
, PREC_ORDER
, 0},
132 {"**", UNOP_IND
, PREC_PREFIX
, 0},
133 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
134 {NULL
, OP_NULL
, PREC_REPEAT
, 0}
138 /* A helper function for the "bound" intrinsics that checks that TYPE
139 is an array. LBOUND_P is true for lower bound; this is used for
140 the error message, if any. */
143 fortran_require_array (struct type
*type
, bool lbound_p
)
145 type
= check_typedef (type
);
146 if (type
->code () != TYPE_CODE_ARRAY
)
149 error (_("LBOUND can only be applied to arrays"));
151 error (_("UBOUND can only be applied to arrays"));
155 /* Create an array containing the lower bounds (when LBOUND_P is true) or
156 the upper bounds (when LBOUND_P is false) of ARRAY (which must be of
157 array type). GDBARCH is the current architecture. */
159 static struct value
*
160 fortran_bounds_all_dims (bool lbound_p
,
161 struct gdbarch
*gdbarch
,
164 type
*array_type
= check_typedef (value_type (array
));
165 int ndimensions
= calc_f77_array_dims (array_type
);
167 /* Allocate a result value of the correct type. */
169 = create_static_range_type (nullptr,
170 builtin_type (gdbarch
)->builtin_int
,
172 struct type
*elm_type
= builtin_type (gdbarch
)->builtin_long_long
;
173 struct type
*result_type
= create_array_type (nullptr, elm_type
, range
);
174 struct value
*result
= allocate_value (result_type
);
176 /* Walk the array dimensions backwards due to the way the array will be
177 laid out in memory, the first dimension will be the most inner. */
178 LONGEST elm_len
= TYPE_LENGTH (elm_type
);
179 for (LONGEST dst_offset
= elm_len
* (ndimensions
- 1);
181 dst_offset
-= elm_len
)
185 /* Grab the required bound. */
187 b
= f77_get_lowerbound (array_type
);
189 b
= f77_get_upperbound (array_type
);
191 /* And copy the value into the result value. */
192 struct value
*v
= value_from_longest (elm_type
, b
);
193 gdb_assert (dst_offset
+ TYPE_LENGTH (value_type (v
))
194 <= TYPE_LENGTH (value_type (result
)));
195 gdb_assert (TYPE_LENGTH (value_type (v
)) == elm_len
);
196 value_contents_copy (result
, dst_offset
, v
, 0, elm_len
);
198 /* Peel another dimension of the array. */
199 array_type
= TYPE_TARGET_TYPE (array_type
);
205 /* Return the lower bound (when LBOUND_P is true) or the upper bound (when
206 LBOUND_P is false) for dimension DIM_VAL (which must be an integer) of
207 ARRAY (which must be an array). GDBARCH is the current architecture. */
209 static struct value
*
210 fortran_bounds_for_dimension (bool lbound_p
,
211 struct gdbarch
*gdbarch
,
213 struct value
*dim_val
)
215 /* Check the requested dimension is valid for this array. */
216 type
*array_type
= check_typedef (value_type (array
));
217 int ndimensions
= calc_f77_array_dims (array_type
);
218 long dim
= value_as_long (dim_val
);
219 if (dim
< 1 || dim
> ndimensions
)
222 error (_("LBOUND dimension must be from 1 to %d"), ndimensions
);
224 error (_("UBOUND dimension must be from 1 to %d"), ndimensions
);
227 /* The type for the result. */
228 struct type
*bound_type
= builtin_type (gdbarch
)->builtin_long_long
;
230 /* Walk the dimensions backwards, due to the ordering in which arrays are
231 laid out the first dimension is the most inner. */
232 for (int i
= ndimensions
- 1; i
>= 0; --i
)
234 /* If this is the requested dimension then we're done. Grab the
235 bounds and return. */
241 b
= f77_get_lowerbound (array_type
);
243 b
= f77_get_upperbound (array_type
);
245 return value_from_longest (bound_type
, b
);
248 /* Peel off another dimension of the array. */
249 array_type
= TYPE_TARGET_TYPE (array_type
);
252 gdb_assert_not_reached ("failed to find matching dimension");
256 /* Return the number of dimensions for a Fortran array or string. */
259 calc_f77_array_dims (struct type
*array_type
)
262 struct type
*tmp_type
;
264 if ((array_type
->code () == TYPE_CODE_STRING
))
267 if ((array_type
->code () != TYPE_CODE_ARRAY
))
268 error (_("Can't get dimensions for a non-array type"));
270 tmp_type
= array_type
;
272 while ((tmp_type
= TYPE_TARGET_TYPE (tmp_type
)))
274 if (tmp_type
->code () == TYPE_CODE_ARRAY
)
280 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
281 slices. This is a base class for two alternative repacking mechanisms,
282 one for when repacking from a lazy value, and one for repacking from a
283 non-lazy (already loaded) value. */
284 class fortran_array_repacker_base_impl
285 : public fortran_array_walker_base_impl
288 /* Constructor, DEST is the value we are repacking into. */
289 fortran_array_repacker_base_impl (struct value
*dest
)
294 /* When we start processing the inner most dimension, this is where we
295 will be creating values for each element as we load them and then copy
296 them into the M_DEST value. Set a value mark so we can free these
298 void start_dimension (bool inner_p
)
302 gdb_assert (m_mark
== nullptr);
303 m_mark
= value_mark ();
307 /* When we finish processing the inner most dimension free all temporary
308 value that were created. */
309 void finish_dimension (bool inner_p
, bool last_p
)
313 gdb_assert (m_mark
!= nullptr);
314 value_free_to_mark (m_mark
);
320 /* Copy the contents of array element ELT into M_DEST at the next
322 void copy_element_to_dest (struct value
*elt
)
324 value_contents_copy (m_dest
, m_dest_offset
, elt
, 0,
325 TYPE_LENGTH (value_type (elt
)));
326 m_dest_offset
+= TYPE_LENGTH (value_type (elt
));
329 /* The value being written to. */
330 struct value
*m_dest
;
332 /* The byte offset in M_DEST at which the next element should be
334 LONGEST m_dest_offset
;
336 /* Set with a call to VALUE_MARK, and then reset after calling
337 VALUE_FREE_TO_MARK. */
338 struct value
*m_mark
= nullptr;
341 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
342 slices. This class is specialised for repacking an array slice from a
343 lazy array value, as such it does not require the parent array value to
344 be loaded into GDB's memory; the parent value could be huge, while the
345 slice could be tiny. */
346 class fortran_lazy_array_repacker_impl
347 : public fortran_array_repacker_base_impl
350 /* Constructor. TYPE is the type of the slice being loaded from the
351 parent value, so this type will correctly reflect the strides required
352 to find all of the elements from the parent value. ADDRESS is the
353 address in target memory of value matching TYPE, and DEST is the value
354 we are repacking into. */
355 explicit fortran_lazy_array_repacker_impl (struct type
*type
,
358 : fortran_array_repacker_base_impl (dest
),
362 /* Create a lazy value in target memory representing a single element,
363 then load the element into GDB's memory and copy the contents into the
364 destination value. */
365 void process_element (struct type
*elt_type
, LONGEST elt_off
, bool last_p
)
367 copy_element_to_dest (value_at_lazy (elt_type
, m_addr
+ elt_off
));
371 /* The address in target memory where the parent value starts. */
375 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
376 slices. This class is specialised for repacking an array slice from a
377 previously loaded (non-lazy) array value, as such it fetches the
378 element values from the contents of the parent value. */
379 class fortran_array_repacker_impl
380 : public fortran_array_repacker_base_impl
383 /* Constructor. TYPE is the type for the array slice within the parent
384 value, as such it has stride values as required to find the elements
385 within the original parent value. ADDRESS is the address in target
386 memory of the value matching TYPE. BASE_OFFSET is the offset from
387 the start of VAL's content buffer to the start of the object of TYPE,
388 VAL is the parent object from which we are loading the value, and
389 DEST is the value into which we are repacking. */
390 explicit fortran_array_repacker_impl (struct type
*type
, CORE_ADDR address
,
392 struct value
*val
, struct value
*dest
)
393 : fortran_array_repacker_base_impl (dest
),
394 m_base_offset (base_offset
),
397 gdb_assert (!value_lazy (val
));
400 /* Extract an element of ELT_TYPE at offset (M_BASE_OFFSET + ELT_OFF)
401 from the content buffer of M_VAL then copy this extracted value into
402 the repacked destination value. */
403 void process_element (struct type
*elt_type
, LONGEST elt_off
, bool last_p
)
406 = value_from_component (m_val
, elt_type
, (elt_off
+ m_base_offset
));
407 copy_element_to_dest (elt
);
411 /* The offset into the content buffer of M_VAL to the start of the slice
413 LONGEST m_base_offset
;
415 /* The parent value from which we are extracting a slice. */
419 /* Called from evaluate_subexp_standard to perform array indexing, and
420 sub-range extraction, for Fortran. As well as arrays this function
421 also handles strings as they can be treated like arrays of characters.
422 ARRAY is the array or string being accessed. EXP, POS, and NOSIDE are
423 as for evaluate_subexp_standard, and NARGS is the number of arguments
424 in this access (e.g. 'array (1,2,3)' would be NARGS 3). */
426 static struct value
*
427 fortran_value_subarray (struct value
*array
, struct expression
*exp
,
428 int *pos
, int nargs
, enum noside noside
)
430 type
*original_array_type
= check_typedef (value_type (array
));
431 bool is_string_p
= original_array_type
->code () == TYPE_CODE_STRING
;
433 /* Perform checks for ARRAY not being available. The somewhat overly
434 complex logic here is just to keep backward compatibility with the
435 errors that we used to get before FORTRAN_VALUE_SUBARRAY was
436 rewritten. Maybe a future task would streamline the error messages we
437 get here, and update all the expected test results. */
438 if (exp
->elts
[*pos
].opcode
!= OP_RANGE
)
440 if (type_not_associated (original_array_type
))
441 error (_("no such vector element (vector not associated)"));
442 else if (type_not_allocated (original_array_type
))
443 error (_("no such vector element (vector not allocated)"));
447 if (type_not_associated (original_array_type
))
448 error (_("array not associated"));
449 else if (type_not_allocated (original_array_type
))
450 error (_("array not allocated"));
453 /* First check that the number of dimensions in the type we are slicing
454 matches the number of arguments we were passed. */
455 int ndimensions
= calc_f77_array_dims (original_array_type
);
456 if (nargs
!= ndimensions
)
457 error (_("Wrong number of subscripts"));
459 /* This will be initialised below with the type of the elements held in
461 struct type
*inner_element_type
;
463 /* Extract the types of each array dimension from the original array
464 type. We need these available so we can fill in the default upper and
465 lower bounds if the user requested slice doesn't provide that
466 information. Additionally unpacking the dimensions like this gives us
467 the inner element type. */
468 std::vector
<struct type
*> dim_types
;
470 dim_types
.reserve (ndimensions
);
471 struct type
*type
= original_array_type
;
472 for (int i
= 0; i
< ndimensions
; ++i
)
474 dim_types
.push_back (type
);
475 type
= TYPE_TARGET_TYPE (type
);
477 /* TYPE is now the inner element type of the array, we start the new
478 array slice off as this type, then as we process the requested slice
479 (from the user) we wrap new types around this to build up the final
481 inner_element_type
= type
;
484 /* As we analyse the new slice type we need to understand if the data
485 being referenced is contiguous. Do decide this we must track the size
486 of an element at each dimension of the new slice array. Initially the
487 elements of the inner most dimension of the array are the same inner
488 most elements as the original ARRAY. */
489 LONGEST slice_element_size
= TYPE_LENGTH (inner_element_type
);
491 /* Start off assuming all data is contiguous, this will be set to false
492 if access to any dimension results in non-contiguous data. */
493 bool is_all_contiguous
= true;
495 /* The TOTAL_OFFSET is the distance in bytes from the start of the
496 original ARRAY to the start of the new slice. This is calculated as
497 we process the information from the user. */
498 LONGEST total_offset
= 0;
500 /* A structure representing information about each dimension of the
505 slice_dim (LONGEST l
, LONGEST h
, LONGEST s
, struct type
*idx
)
512 /* The low bound for this dimension of the slice. */
515 /* The high bound for this dimension of the slice. */
518 /* The byte stride for this dimension of the slice. */
524 /* The dimensions of the resulting slice. */
525 std::vector
<slice_dim
> slice_dims
;
527 /* Process the incoming arguments. These arguments are in the reverse
528 order to the array dimensions, that is the first argument refers to
529 the last array dimension. */
530 if (fortran_array_slicing_debug
)
531 debug_printf ("Processing array access:\n");
532 for (int i
= 0; i
< nargs
; ++i
)
534 /* For each dimension of the array the user will have either provided
535 a ranged access with optional lower bound, upper bound, and
536 stride, or the user will have supplied a single index. */
537 struct type
*dim_type
= dim_types
[ndimensions
- (i
+ 1)];
538 if (exp
->elts
[*pos
].opcode
== OP_RANGE
)
541 enum range_flag range_flag
= (enum range_flag
) exp
->elts
[pc
].longconst
;
544 LONGEST low
, high
, stride
;
545 low
= high
= stride
= 0;
547 if ((range_flag
& RANGE_LOW_BOUND_DEFAULT
) == 0)
548 low
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
550 low
= f77_get_lowerbound (dim_type
);
551 if ((range_flag
& RANGE_HIGH_BOUND_DEFAULT
) == 0)
552 high
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
554 high
= f77_get_upperbound (dim_type
);
555 if ((range_flag
& RANGE_HAS_STRIDE
) == RANGE_HAS_STRIDE
)
556 stride
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
561 error (_("stride must not be 0"));
563 /* Get information about this dimension in the original ARRAY. */
564 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
565 struct type
*index_type
= dim_type
->index_type ();
566 LONGEST lb
= f77_get_lowerbound (dim_type
);
567 LONGEST ub
= f77_get_upperbound (dim_type
);
568 LONGEST sd
= index_type
->bit_stride ();
570 sd
= TYPE_LENGTH (target_type
) * 8;
572 if (fortran_array_slicing_debug
)
574 debug_printf ("|-> Range access\n");
575 std::string str
= type_to_string (dim_type
);
576 debug_printf ("| |-> Type: %s\n", str
.c_str ());
577 debug_printf ("| |-> Array:\n");
578 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
579 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
580 debug_printf ("| | |-> Bit stride: %s\n", plongest (sd
));
581 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
/ 8));
582 debug_printf ("| | |-> Type size: %s\n",
583 pulongest (TYPE_LENGTH (dim_type
)));
584 debug_printf ("| | '-> Target type size: %s\n",
585 pulongest (TYPE_LENGTH (target_type
)));
586 debug_printf ("| |-> Accessing:\n");
587 debug_printf ("| | |-> Low bound: %s\n",
589 debug_printf ("| | |-> High bound: %s\n",
591 debug_printf ("| | '-> Element stride: %s\n",
595 /* Check the user hasn't asked for something invalid. */
596 if (high
> ub
|| low
< lb
)
597 error (_("array subscript out of bounds"));
599 /* Calculate what this dimension of the new slice array will look
600 like. OFFSET is the byte offset from the start of the
601 previous (more outer) dimension to the start of this
602 dimension. E_COUNT is the number of elements in this
603 dimension. REMAINDER is the number of elements remaining
604 between the last included element and the upper bound. For
605 example an access '1:6:2' will include elements 1, 3, 5 and
606 have a remainder of 1 (element #6). */
607 LONGEST lowest
= std::min (low
, high
);
608 LONGEST offset
= (sd
/ 8) * (lowest
- lb
);
609 LONGEST e_count
= std::abs (high
- low
) + 1;
610 e_count
= (e_count
+ (std::abs (stride
) - 1)) / std::abs (stride
);
612 LONGEST new_high
= new_low
+ e_count
- 1;
613 LONGEST new_stride
= (sd
* stride
) / 8;
614 LONGEST last_elem
= low
+ ((e_count
- 1) * stride
);
615 LONGEST remainder
= high
- last_elem
;
618 offset
+= std::abs (remainder
) * TYPE_LENGTH (target_type
);
620 error (_("incorrect stride and boundary combination"));
623 error (_("incorrect stride and boundary combination"));
625 /* Is the data within this dimension contiguous? It is if the
626 newly computed stride is the same size as a single element of
628 bool is_dim_contiguous
= (new_stride
== slice_element_size
);
629 is_all_contiguous
&= is_dim_contiguous
;
631 if (fortran_array_slicing_debug
)
633 debug_printf ("| '-> Results:\n");
634 debug_printf ("| |-> Offset = %s\n", plongest (offset
));
635 debug_printf ("| |-> Elements = %s\n", plongest (e_count
));
636 debug_printf ("| |-> Low bound = %s\n", plongest (new_low
));
637 debug_printf ("| |-> High bound = %s\n",
638 plongest (new_high
));
639 debug_printf ("| |-> Byte stride = %s\n",
640 plongest (new_stride
));
641 debug_printf ("| |-> Last element = %s\n",
642 plongest (last_elem
));
643 debug_printf ("| |-> Remainder = %s\n",
644 plongest (remainder
));
645 debug_printf ("| '-> Contiguous = %s\n",
646 (is_dim_contiguous
? "Yes" : "No"));
649 /* Figure out how big (in bytes) an element of this dimension of
650 the new array slice will be. */
651 slice_element_size
= std::abs (new_stride
* e_count
);
653 slice_dims
.emplace_back (new_low
, new_high
, new_stride
,
656 /* Update the total offset. */
657 total_offset
+= offset
;
661 /* There is a single index for this dimension. */
663 = value_as_long (evaluate_subexp_with_coercion (exp
, pos
, noside
));
665 /* Get information about this dimension in the original ARRAY. */
666 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
667 struct type
*index_type
= dim_type
->index_type ();
668 LONGEST lb
= f77_get_lowerbound (dim_type
);
669 LONGEST ub
= f77_get_upperbound (dim_type
);
670 LONGEST sd
= index_type
->bit_stride () / 8;
672 sd
= TYPE_LENGTH (target_type
);
674 if (fortran_array_slicing_debug
)
676 debug_printf ("|-> Index access\n");
677 std::string str
= type_to_string (dim_type
);
678 debug_printf ("| |-> Type: %s\n", str
.c_str ());
679 debug_printf ("| |-> Array:\n");
680 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
681 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
682 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
));
683 debug_printf ("| | |-> Type size: %s\n",
684 pulongest (TYPE_LENGTH (dim_type
)));
685 debug_printf ("| | '-> Target type size: %s\n",
686 pulongest (TYPE_LENGTH (target_type
)));
687 debug_printf ("| '-> Accessing:\n");
688 debug_printf ("| '-> Index: %s\n",
692 /* If the array has actual content then check the index is in
693 bounds. An array without content (an unbound array) doesn't
694 have a known upper bound, so don't error check in that
697 || (dim_type
->index_type ()->bounds ()->high
.kind () != PROP_UNDEFINED
699 || (VALUE_LVAL (array
) != lval_memory
700 && dim_type
->index_type ()->bounds ()->high
.kind () == PROP_UNDEFINED
))
702 if (type_not_associated (dim_type
))
703 error (_("no such vector element (vector not associated)"));
704 else if (type_not_allocated (dim_type
))
705 error (_("no such vector element (vector not allocated)"));
707 error (_("no such vector element"));
710 /* Calculate using the type stride, not the target type size. */
711 LONGEST offset
= sd
* (index
- lb
);
712 total_offset
+= offset
;
716 if (noside
== EVAL_SKIP
)
719 /* Build a type that represents the new array slice in the target memory
720 of the original ARRAY, this type makes use of strides to correctly
721 find only those elements that are part of the new slice. */
722 struct type
*array_slice_type
= inner_element_type
;
723 for (const auto &d
: slice_dims
)
725 /* Create the range. */
726 dynamic_prop p_low
, p_high
, p_stride
;
728 p_low
.set_const_val (d
.low
);
729 p_high
.set_const_val (d
.high
);
730 p_stride
.set_const_val (d
.stride
);
732 struct type
*new_range
733 = create_range_type_with_stride ((struct type
*) NULL
,
734 TYPE_TARGET_TYPE (d
.index
),
735 &p_low
, &p_high
, 0, &p_stride
,
738 = create_array_type (nullptr, array_slice_type
, new_range
);
741 if (fortran_array_slicing_debug
)
743 debug_printf ("'-> Final result:\n");
744 debug_printf (" |-> Type: %s\n",
745 type_to_string (array_slice_type
).c_str ());
746 debug_printf (" |-> Total offset: %s\n",
747 plongest (total_offset
));
748 debug_printf (" |-> Base address: %s\n",
749 core_addr_to_string (value_address (array
)));
750 debug_printf (" '-> Contiguous = %s\n",
751 (is_all_contiguous
? "Yes" : "No"));
754 /* Should we repack this array slice? */
755 if (!is_all_contiguous
&& (repack_array_slices
|| is_string_p
))
757 /* Build a type for the repacked slice. */
758 struct type
*repacked_array_type
= inner_element_type
;
759 for (const auto &d
: slice_dims
)
761 /* Create the range. */
762 dynamic_prop p_low
, p_high
, p_stride
;
764 p_low
.set_const_val (d
.low
);
765 p_high
.set_const_val (d
.high
);
766 p_stride
.set_const_val (TYPE_LENGTH (repacked_array_type
));
768 struct type
*new_range
769 = create_range_type_with_stride ((struct type
*) NULL
,
770 TYPE_TARGET_TYPE (d
.index
),
771 &p_low
, &p_high
, 0, &p_stride
,
774 = create_array_type (nullptr, repacked_array_type
, new_range
);
777 /* Now copy the elements from the original ARRAY into the packed
779 struct value
*dest
= allocate_value (repacked_array_type
);
780 if (value_lazy (array
)
781 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
782 > TYPE_LENGTH (check_typedef (value_type (array
)))))
784 fortran_array_walker
<fortran_lazy_array_repacker_impl
> p
785 (array_slice_type
, value_address (array
) + total_offset
, dest
);
790 fortran_array_walker
<fortran_array_repacker_impl
> p
791 (array_slice_type
, value_address (array
) + total_offset
,
792 total_offset
, array
, dest
);
799 if (VALUE_LVAL (array
) == lval_memory
)
801 /* If the value we're taking a slice from is not yet loaded, or
802 the requested slice is outside the values content range then
803 just create a new lazy value pointing at the memory where the
804 contents we're looking for exist. */
805 if (value_lazy (array
)
806 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
807 > TYPE_LENGTH (check_typedef (value_type (array
)))))
808 array
= value_at_lazy (array_slice_type
,
809 value_address (array
) + total_offset
);
811 array
= value_from_contents_and_address (array_slice_type
,
812 (value_contents (array
)
814 (value_address (array
)
817 else if (!value_lazy (array
))
818 array
= value_from_component (array
, array_slice_type
, total_offset
);
820 error (_("cannot subscript arrays that are not in memory"));
826 /* Evaluate FORTRAN_ASSOCIATED expressions. Both GDBARCH and LANG are
827 extracted from the expression being evaluated. POINTER is the required
828 first argument to the 'associated' keyword, and TARGET is the optional
829 second argument, this will be nullptr if the user only passed one
830 argument to their use of 'associated'. */
832 static struct value
*
833 fortran_associated (struct gdbarch
*gdbarch
, const language_defn
*lang
,
834 struct value
*pointer
, struct value
*target
= nullptr)
836 struct type
*result_type
= language_bool_type (lang
, gdbarch
);
838 /* All Fortran pointers should have the associated property, this is
839 how we know the pointer is pointing at something or not. */
840 struct type
*pointer_type
= check_typedef (value_type (pointer
));
841 if (TYPE_ASSOCIATED_PROP (pointer_type
) == nullptr
842 && pointer_type
->code () != TYPE_CODE_PTR
)
843 error (_("ASSOCIATED can only be applied to pointers"));
845 /* Get an address from POINTER. Fortran (or at least gfortran) models
846 array pointers as arrays with a dynamic data address, so we need to
847 use two approaches here, for real pointers we take the contents of the
848 pointer as an address. For non-pointers we take the address of the
850 CORE_ADDR pointer_addr
;
851 if (pointer_type
->code () == TYPE_CODE_PTR
)
852 pointer_addr
= value_as_address (pointer
);
854 pointer_addr
= value_address (pointer
);
856 /* The single argument case, is POINTER associated with anything? */
857 if (target
== nullptr)
859 bool is_associated
= false;
861 /* If POINTER is an actual pointer and doesn't have an associated
862 property then we need to figure out whether this pointer is
863 associated by looking at the value of the pointer itself. We make
864 the assumption that a non-associated pointer will be set to 0.
865 This is probably true for most targets, but might not be true for
867 if (pointer_type
->code () == TYPE_CODE_PTR
868 && TYPE_ASSOCIATED_PROP (pointer_type
) == nullptr)
869 is_associated
= (pointer_addr
!= 0);
871 is_associated
= !type_not_associated (pointer_type
);
872 return value_from_longest (result_type
, is_associated
? 1 : 0);
875 /* The two argument case, is POINTER associated with TARGET? */
877 struct type
*target_type
= check_typedef (value_type (target
));
879 struct type
*pointer_target_type
;
880 if (pointer_type
->code () == TYPE_CODE_PTR
)
881 pointer_target_type
= TYPE_TARGET_TYPE (pointer_type
);
883 pointer_target_type
= pointer_type
;
885 struct type
*target_target_type
;
886 if (target_type
->code () == TYPE_CODE_PTR
)
887 target_target_type
= TYPE_TARGET_TYPE (target_type
);
889 target_target_type
= target_type
;
891 if (pointer_target_type
->code () != target_target_type
->code ()
892 || (pointer_target_type
->code () != TYPE_CODE_ARRAY
893 && (TYPE_LENGTH (pointer_target_type
)
894 != TYPE_LENGTH (target_target_type
))))
895 error (_("arguments to associated must be of same type and kind"));
897 /* If TARGET is not in memory, or the original pointer is specifically
898 known to be not associated with anything, then the answer is obviously
899 false. Alternatively, if POINTER is an actual pointer and has no
900 associated property, then we have to check if its associated by
901 looking the value of the pointer itself. We make the assumption that
902 a non-associated pointer will be set to 0. This is probably true for
903 most targets, but might not be true for everyone. */
904 if (value_lval_const (target
) != lval_memory
905 || type_not_associated (pointer_type
)
906 || (TYPE_ASSOCIATED_PROP (pointer_type
) == nullptr
907 && pointer_type
->code () == TYPE_CODE_PTR
908 && pointer_addr
== 0))
909 return value_from_longest (result_type
, 0);
911 /* See the comment for POINTER_ADDR above. */
912 CORE_ADDR target_addr
;
913 if (target_type
->code () == TYPE_CODE_PTR
)
914 target_addr
= value_as_address (target
);
916 target_addr
= value_address (target
);
918 /* Wrap the following checks inside a do { ... } while (false) loop so
919 that we can use `break' to jump out of the loop. */
920 bool is_associated
= false;
923 /* If the addresses are different then POINTER is definitely not
924 pointing at TARGET. */
925 if (pointer_addr
!= target_addr
)
928 /* If POINTER is a real pointer (i.e. not an array pointer, which are
929 implemented as arrays with a dynamic content address), then this
930 is all the checking that is needed. */
931 if (pointer_type
->code () == TYPE_CODE_PTR
)
933 is_associated
= true;
937 /* We have an array pointer. Check the number of dimensions. */
938 int pointer_dims
= calc_f77_array_dims (pointer_type
);
939 int target_dims
= calc_f77_array_dims (target_type
);
940 if (pointer_dims
!= target_dims
)
943 /* Now check that every dimension has the same upper bound, lower
944 bound, and stride value. */
946 while (dim
< pointer_dims
)
948 LONGEST pointer_lowerbound
, pointer_upperbound
, pointer_stride
;
949 LONGEST target_lowerbound
, target_upperbound
, target_stride
;
951 pointer_type
= check_typedef (pointer_type
);
952 target_type
= check_typedef (target_type
);
954 struct type
*pointer_range
= pointer_type
->index_type ();
955 struct type
*target_range
= target_type
->index_type ();
957 if (!get_discrete_bounds (pointer_range
, &pointer_lowerbound
,
958 &pointer_upperbound
))
961 if (!get_discrete_bounds (target_range
, &target_lowerbound
,
965 if (pointer_lowerbound
!= target_lowerbound
966 || pointer_upperbound
!= target_upperbound
)
969 /* Figure out the stride (in bits) for both pointer and target.
970 If either doesn't have a stride then we take the element size,
971 but we need to convert to bits (hence the * 8). */
972 pointer_stride
= pointer_range
->bounds ()->bit_stride ();
973 if (pointer_stride
== 0)
975 = type_length_units (check_typedef
976 (TYPE_TARGET_TYPE (pointer_type
))) * 8;
977 target_stride
= target_range
->bounds ()->bit_stride ();
978 if (target_stride
== 0)
980 = type_length_units (check_typedef
981 (TYPE_TARGET_TYPE (target_type
))) * 8;
982 if (pointer_stride
!= target_stride
)
988 if (dim
< pointer_dims
)
991 is_associated
= true;
995 return value_from_longest (result_type
, is_associated
? 1 : 0);
999 eval_op_f_associated (struct type
*expect_type
,
1000 struct expression
*exp
,
1002 enum exp_opcode opcode
,
1005 return fortran_associated (exp
->gdbarch
, exp
->language_defn
, arg1
);
1009 eval_op_f_associated (struct type
*expect_type
,
1010 struct expression
*exp
,
1012 enum exp_opcode opcode
,
1016 return fortran_associated (exp
->gdbarch
, exp
->language_defn
, arg1
, arg2
);
1019 /* A helper function for UNOP_ABS. */
1022 eval_op_f_abs (struct type
*expect_type
, struct expression
*exp
,
1024 enum exp_opcode opcode
,
1027 if (noside
== EVAL_SKIP
)
1028 return eval_skip_value (exp
);
1029 struct type
*type
= value_type (arg1
);
1030 switch (type
->code ())
1035 = fabs (target_float_to_host_double (value_contents (arg1
),
1036 value_type (arg1
)));
1037 return value_from_host_double (type
, d
);
1041 LONGEST l
= value_as_long (arg1
);
1043 return value_from_longest (type
, l
);
1046 error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type
));
1049 /* A helper function for BINOP_MOD. */
1052 eval_op_f_mod (struct type
*expect_type
, struct expression
*exp
,
1054 enum exp_opcode opcode
,
1055 struct value
*arg1
, struct value
*arg2
)
1057 if (noside
== EVAL_SKIP
)
1058 return eval_skip_value (exp
);
1059 struct type
*type
= value_type (arg1
);
1060 if (type
->code () != value_type (arg2
)->code ())
1061 error (_("non-matching types for parameters to MOD ()"));
1062 switch (type
->code ())
1067 = target_float_to_host_double (value_contents (arg1
),
1070 = target_float_to_host_double (value_contents (arg2
),
1072 double d3
= fmod (d1
, d2
);
1073 return value_from_host_double (type
, d3
);
1077 LONGEST v1
= value_as_long (arg1
);
1078 LONGEST v2
= value_as_long (arg2
);
1080 error (_("calling MOD (N, 0) is undefined"));
1081 LONGEST v3
= v1
- (v1
/ v2
) * v2
;
1082 return value_from_longest (value_type (arg1
), v3
);
1085 error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type
));
1088 /* A helper function for UNOP_FORTRAN_CEILING. */
1091 eval_op_f_ceil (struct type
*expect_type
, struct expression
*exp
,
1093 enum exp_opcode opcode
,
1096 if (noside
== EVAL_SKIP
)
1097 return eval_skip_value (exp
);
1098 struct type
*type
= value_type (arg1
);
1099 if (type
->code () != TYPE_CODE_FLT
)
1100 error (_("argument to CEILING must be of type float"));
1102 = target_float_to_host_double (value_contents (arg1
),
1105 return value_from_host_double (type
, val
);
1108 /* A helper function for UNOP_FORTRAN_FLOOR. */
1111 eval_op_f_floor (struct type
*expect_type
, struct expression
*exp
,
1113 enum exp_opcode opcode
,
1116 if (noside
== EVAL_SKIP
)
1117 return eval_skip_value (exp
);
1118 struct type
*type
= value_type (arg1
);
1119 if (type
->code () != TYPE_CODE_FLT
)
1120 error (_("argument to FLOOR must be of type float"));
1122 = target_float_to_host_double (value_contents (arg1
),
1125 return value_from_host_double (type
, val
);
1128 /* A helper function for BINOP_FORTRAN_MODULO. */
1131 eval_op_f_modulo (struct type
*expect_type
, struct expression
*exp
,
1133 enum exp_opcode opcode
,
1134 struct value
*arg1
, struct value
*arg2
)
1136 if (noside
== EVAL_SKIP
)
1137 return eval_skip_value (exp
);
1138 struct type
*type
= value_type (arg1
);
1139 if (type
->code () != value_type (arg2
)->code ())
1140 error (_("non-matching types for parameters to MODULO ()"));
1141 /* MODULO(A, P) = A - FLOOR (A / P) * P */
1142 switch (type
->code ())
1146 LONGEST a
= value_as_long (arg1
);
1147 LONGEST p
= value_as_long (arg2
);
1148 LONGEST result
= a
- (a
/ p
) * p
;
1149 if (result
!= 0 && (a
< 0) != (p
< 0))
1151 return value_from_longest (value_type (arg1
), result
);
1156 = target_float_to_host_double (value_contents (arg1
),
1159 = target_float_to_host_double (value_contents (arg2
),
1161 double result
= fmod (a
, p
);
1162 if (result
!= 0 && (a
< 0.0) != (p
< 0.0))
1164 return value_from_host_double (type
, result
);
1167 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type
));
1170 /* A helper function for BINOP_FORTRAN_CMPLX. */
1173 eval_op_f_cmplx (struct type
*expect_type
, struct expression
*exp
,
1175 enum exp_opcode opcode
,
1176 struct value
*arg1
, struct value
*arg2
)
1178 if (noside
== EVAL_SKIP
)
1179 return eval_skip_value (exp
);
1180 struct type
*type
= builtin_f_type(exp
->gdbarch
)->builtin_complex_s16
;
1181 return value_literal_complex (arg1
, arg2
, type
);
1184 /* A helper function for UNOP_FORTRAN_KIND. */
1187 eval_op_f_kind (struct type
*expect_type
, struct expression
*exp
,
1189 enum exp_opcode opcode
,
1192 struct type
*type
= value_type (arg1
);
1194 switch (type
->code ())
1196 case TYPE_CODE_STRUCT
:
1197 case TYPE_CODE_UNION
:
1198 case TYPE_CODE_MODULE
:
1199 case TYPE_CODE_FUNC
:
1200 error (_("argument to kind must be an intrinsic type"));
1203 if (!TYPE_TARGET_TYPE (type
))
1204 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1205 TYPE_LENGTH (type
));
1206 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1207 TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
1210 /* A helper function for UNOP_FORTRAN_ALLOCATED. */
1213 eval_op_f_allocated (struct type
*expect_type
, struct expression
*exp
,
1214 enum noside noside
, enum exp_opcode op
,
1217 struct type
*type
= check_typedef (value_type (arg1
));
1218 if (type
->code () != TYPE_CODE_ARRAY
)
1219 error (_("ALLOCATED can only be applied to arrays"));
1220 struct type
*result_type
1221 = builtin_f_type (exp
->gdbarch
)->builtin_logical
;
1222 LONGEST result_value
= type_not_allocated (type
) ? 0 : 1;
1223 return value_from_longest (result_type
, result_value
);
1226 /* Special expression evaluation cases for Fortran. */
1228 static struct value
*
1229 evaluate_subexp_f (struct type
*expect_type
, struct expression
*exp
,
1230 int *pos
, enum noside noside
)
1232 struct value
*arg1
= NULL
, *arg2
= NULL
;
1239 op
= exp
->elts
[pc
].opcode
;
1245 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
1248 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1249 return eval_op_f_abs (expect_type
, exp
, noside
, op
, arg1
);
1252 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1253 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1254 return eval_op_f_mod (expect_type
, exp
, noside
, op
, arg1
, arg2
);
1256 case UNOP_FORTRAN_CEILING
:
1257 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1258 return eval_op_f_ceil (expect_type
, exp
, noside
, op
, arg1
);
1260 case UNOP_FORTRAN_FLOOR
:
1261 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1262 return eval_op_f_floor (expect_type
, exp
, noside
, op
, arg1
);
1264 case UNOP_FORTRAN_ALLOCATED
:
1266 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1267 if (noside
== EVAL_SKIP
)
1268 return eval_skip_value (exp
);
1269 return eval_op_f_allocated (expect_type
, exp
, noside
, op
, arg1
);
1272 case BINOP_FORTRAN_MODULO
:
1273 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1274 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1275 return eval_op_f_modulo (expect_type
, exp
, noside
, op
, arg1
, arg2
);
1277 case FORTRAN_LBOUND
:
1278 case FORTRAN_UBOUND
:
1280 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1283 /* This assertion should be enforced by the expression parser. */
1284 gdb_assert (nargs
== 1 || nargs
== 2);
1286 bool lbound_p
= op
== FORTRAN_LBOUND
;
1288 /* Check that the first argument is array like. */
1289 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1290 fortran_require_array (value_type (arg1
), lbound_p
);
1293 return fortran_bounds_all_dims (lbound_p
, exp
->gdbarch
, arg1
);
1295 /* User asked for the bounds of a specific dimension of the array. */
1296 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1297 type
= check_typedef (value_type (arg2
));
1298 if (type
->code () != TYPE_CODE_INT
)
1301 error (_("LBOUND second argument should be an integer"));
1303 error (_("UBOUND second argument should be an integer"));
1306 return fortran_bounds_for_dimension (lbound_p
, exp
->gdbarch
, arg1
,
1311 case FORTRAN_ASSOCIATED
:
1313 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1316 /* This assertion should be enforced by the expression parser. */
1317 gdb_assert (nargs
== 1 || nargs
== 2);
1319 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1323 if (noside
== EVAL_SKIP
)
1324 return eval_skip_value (exp
);
1325 return fortran_associated (exp
->gdbarch
, exp
->language_defn
,
1329 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1330 if (noside
== EVAL_SKIP
)
1331 return eval_skip_value (exp
);
1332 return fortran_associated (exp
->gdbarch
, exp
->language_defn
,
1337 case BINOP_FORTRAN_CMPLX
:
1338 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1339 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1340 return eval_op_f_cmplx (expect_type
, exp
, noside
, op
, arg1
, arg2
);
1342 case UNOP_FORTRAN_KIND
:
1343 arg1
= evaluate_subexp (NULL
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
1344 return eval_op_f_kind (expect_type
, exp
, noside
, op
, arg1
);
1346 case OP_F77_UNDETERMINED_ARGLIST
:
1347 /* Remember that in F77, functions, substring ops and array subscript
1348 operations cannot be disambiguated at parse time. We have made
1349 all array subscript operations, substring operations as well as
1350 function calls come here and we now have to discover what the heck
1351 this thing actually was. If it is a function, we process just as
1352 if we got an OP_FUNCALL. */
1353 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1356 /* First determine the type code we are dealing with. */
1357 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1358 type
= check_typedef (value_type (arg1
));
1359 enum type_code code
= type
->code ();
1361 if (code
== TYPE_CODE_PTR
)
1363 /* Fortran always passes variable to subroutines as pointer.
1364 So we need to look into its target type to see if it is
1365 array, string or function. If it is, we need to switch
1366 to the target value the original one points to. */
1367 struct type
*target_type
= check_typedef (TYPE_TARGET_TYPE (type
));
1369 if (target_type
->code () == TYPE_CODE_ARRAY
1370 || target_type
->code () == TYPE_CODE_STRING
1371 || target_type
->code () == TYPE_CODE_FUNC
)
1373 arg1
= value_ind (arg1
);
1374 type
= check_typedef (value_type (arg1
));
1375 code
= type
->code ();
1381 case TYPE_CODE_ARRAY
:
1382 case TYPE_CODE_STRING
:
1383 return fortran_value_subarray (arg1
, exp
, pos
, nargs
, noside
);
1386 case TYPE_CODE_FUNC
:
1387 case TYPE_CODE_INTERNAL_FUNCTION
:
1389 /* It's a function call. Allocate arg vector, including
1390 space for the function to be called in argvec[0] and a
1391 termination NULL. */
1392 struct value
**argvec
= (struct value
**)
1393 alloca (sizeof (struct value
*) * (nargs
+ 2));
1396 for (; tem
<= nargs
; tem
++)
1398 bool is_internal_func
= (code
== TYPE_CODE_INTERNAL_FUNCTION
);
1400 = fortran_prepare_argument (exp
, pos
, (tem
- 1),
1402 value_type (arg1
), noside
);
1404 argvec
[tem
] = 0; /* signal end of arglist */
1405 if (noside
== EVAL_SKIP
)
1406 return eval_skip_value (exp
);
1407 return evaluate_subexp_do_call (exp
, noside
, argvec
[0],
1408 gdb::make_array_view (argvec
+ 1,
1414 error (_("Cannot perform substring on this type"));
1418 /* Should be unreachable. */
1425 /* Called from evaluate to perform array indexing, and sub-range
1426 extraction, for Fortran. As well as arrays this function also
1427 handles strings as they can be treated like arrays of characters.
1428 ARRAY is the array or string being accessed. EXP and NOSIDE are as
1432 fortran_undetermined::value_subarray (value
*array
,
1433 struct expression
*exp
,
1436 type
*original_array_type
= check_typedef (value_type (array
));
1437 bool is_string_p
= original_array_type
->code () == TYPE_CODE_STRING
;
1438 const std::vector
<operation_up
> &ops
= std::get
<1> (m_storage
);
1439 int nargs
= ops
.size ();
1441 /* Perform checks for ARRAY not being available. The somewhat overly
1442 complex logic here is just to keep backward compatibility with the
1443 errors that we used to get before FORTRAN_VALUE_SUBARRAY was
1444 rewritten. Maybe a future task would streamline the error messages we
1445 get here, and update all the expected test results. */
1446 if (ops
[0]->opcode () != OP_RANGE
)
1448 if (type_not_associated (original_array_type
))
1449 error (_("no such vector element (vector not associated)"));
1450 else if (type_not_allocated (original_array_type
))
1451 error (_("no such vector element (vector not allocated)"));
1455 if (type_not_associated (original_array_type
))
1456 error (_("array not associated"));
1457 else if (type_not_allocated (original_array_type
))
1458 error (_("array not allocated"));
1461 /* First check that the number of dimensions in the type we are slicing
1462 matches the number of arguments we were passed. */
1463 int ndimensions
= calc_f77_array_dims (original_array_type
);
1464 if (nargs
!= ndimensions
)
1465 error (_("Wrong number of subscripts"));
1467 /* This will be initialised below with the type of the elements held in
1469 struct type
*inner_element_type
;
1471 /* Extract the types of each array dimension from the original array
1472 type. We need these available so we can fill in the default upper and
1473 lower bounds if the user requested slice doesn't provide that
1474 information. Additionally unpacking the dimensions like this gives us
1475 the inner element type. */
1476 std::vector
<struct type
*> dim_types
;
1478 dim_types
.reserve (ndimensions
);
1479 struct type
*type
= original_array_type
;
1480 for (int i
= 0; i
< ndimensions
; ++i
)
1482 dim_types
.push_back (type
);
1483 type
= TYPE_TARGET_TYPE (type
);
1485 /* TYPE is now the inner element type of the array, we start the new
1486 array slice off as this type, then as we process the requested slice
1487 (from the user) we wrap new types around this to build up the final
1489 inner_element_type
= type
;
1492 /* As we analyse the new slice type we need to understand if the data
1493 being referenced is contiguous. Do decide this we must track the size
1494 of an element at each dimension of the new slice array. Initially the
1495 elements of the inner most dimension of the array are the same inner
1496 most elements as the original ARRAY. */
1497 LONGEST slice_element_size
= TYPE_LENGTH (inner_element_type
);
1499 /* Start off assuming all data is contiguous, this will be set to false
1500 if access to any dimension results in non-contiguous data. */
1501 bool is_all_contiguous
= true;
1503 /* The TOTAL_OFFSET is the distance in bytes from the start of the
1504 original ARRAY to the start of the new slice. This is calculated as
1505 we process the information from the user. */
1506 LONGEST total_offset
= 0;
1508 /* A structure representing information about each dimension of the
1513 slice_dim (LONGEST l
, LONGEST h
, LONGEST s
, struct type
*idx
)
1520 /* The low bound for this dimension of the slice. */
1523 /* The high bound for this dimension of the slice. */
1526 /* The byte stride for this dimension of the slice. */
1532 /* The dimensions of the resulting slice. */
1533 std::vector
<slice_dim
> slice_dims
;
1535 /* Process the incoming arguments. These arguments are in the reverse
1536 order to the array dimensions, that is the first argument refers to
1537 the last array dimension. */
1538 if (fortran_array_slicing_debug
)
1539 debug_printf ("Processing array access:\n");
1540 for (int i
= 0; i
< nargs
; ++i
)
1542 /* For each dimension of the array the user will have either provided
1543 a ranged access with optional lower bound, upper bound, and
1544 stride, or the user will have supplied a single index. */
1545 struct type
*dim_type
= dim_types
[ndimensions
- (i
+ 1)];
1546 fortran_range_operation
*range_op
1547 = dynamic_cast<fortran_range_operation
*> (ops
[i
].get ());
1548 if (range_op
!= nullptr)
1550 enum range_flag range_flag
= range_op
->get_flags ();
1552 LONGEST low
, high
, stride
;
1553 low
= high
= stride
= 0;
1555 if ((range_flag
& RANGE_LOW_BOUND_DEFAULT
) == 0)
1556 low
= value_as_long (range_op
->evaluate0 (exp
, noside
));
1558 low
= f77_get_lowerbound (dim_type
);
1559 if ((range_flag
& RANGE_HIGH_BOUND_DEFAULT
) == 0)
1560 high
= value_as_long (range_op
->evaluate1 (exp
, noside
));
1562 high
= f77_get_upperbound (dim_type
);
1563 if ((range_flag
& RANGE_HAS_STRIDE
) == RANGE_HAS_STRIDE
)
1564 stride
= value_as_long (range_op
->evaluate2 (exp
, noside
));
1569 error (_("stride must not be 0"));
1571 /* Get information about this dimension in the original ARRAY. */
1572 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
1573 struct type
*index_type
= dim_type
->index_type ();
1574 LONGEST lb
= f77_get_lowerbound (dim_type
);
1575 LONGEST ub
= f77_get_upperbound (dim_type
);
1576 LONGEST sd
= index_type
->bit_stride ();
1578 sd
= TYPE_LENGTH (target_type
) * 8;
1580 if (fortran_array_slicing_debug
)
1582 debug_printf ("|-> Range access\n");
1583 std::string str
= type_to_string (dim_type
);
1584 debug_printf ("| |-> Type: %s\n", str
.c_str ());
1585 debug_printf ("| |-> Array:\n");
1586 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
1587 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
1588 debug_printf ("| | |-> Bit stride: %s\n", plongest (sd
));
1589 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
/ 8));
1590 debug_printf ("| | |-> Type size: %s\n",
1591 pulongest (TYPE_LENGTH (dim_type
)));
1592 debug_printf ("| | '-> Target type size: %s\n",
1593 pulongest (TYPE_LENGTH (target_type
)));
1594 debug_printf ("| |-> Accessing:\n");
1595 debug_printf ("| | |-> Low bound: %s\n",
1597 debug_printf ("| | |-> High bound: %s\n",
1599 debug_printf ("| | '-> Element stride: %s\n",
1603 /* Check the user hasn't asked for something invalid. */
1604 if (high
> ub
|| low
< lb
)
1605 error (_("array subscript out of bounds"));
1607 /* Calculate what this dimension of the new slice array will look
1608 like. OFFSET is the byte offset from the start of the
1609 previous (more outer) dimension to the start of this
1610 dimension. E_COUNT is the number of elements in this
1611 dimension. REMAINDER is the number of elements remaining
1612 between the last included element and the upper bound. For
1613 example an access '1:6:2' will include elements 1, 3, 5 and
1614 have a remainder of 1 (element #6). */
1615 LONGEST lowest
= std::min (low
, high
);
1616 LONGEST offset
= (sd
/ 8) * (lowest
- lb
);
1617 LONGEST e_count
= std::abs (high
- low
) + 1;
1618 e_count
= (e_count
+ (std::abs (stride
) - 1)) / std::abs (stride
);
1619 LONGEST new_low
= 1;
1620 LONGEST new_high
= new_low
+ e_count
- 1;
1621 LONGEST new_stride
= (sd
* stride
) / 8;
1622 LONGEST last_elem
= low
+ ((e_count
- 1) * stride
);
1623 LONGEST remainder
= high
- last_elem
;
1626 offset
+= std::abs (remainder
) * TYPE_LENGTH (target_type
);
1628 error (_("incorrect stride and boundary combination"));
1630 else if (stride
< 0)
1631 error (_("incorrect stride and boundary combination"));
1633 /* Is the data within this dimension contiguous? It is if the
1634 newly computed stride is the same size as a single element of
1636 bool is_dim_contiguous
= (new_stride
== slice_element_size
);
1637 is_all_contiguous
&= is_dim_contiguous
;
1639 if (fortran_array_slicing_debug
)
1641 debug_printf ("| '-> Results:\n");
1642 debug_printf ("| |-> Offset = %s\n", plongest (offset
));
1643 debug_printf ("| |-> Elements = %s\n", plongest (e_count
));
1644 debug_printf ("| |-> Low bound = %s\n", plongest (new_low
));
1645 debug_printf ("| |-> High bound = %s\n",
1646 plongest (new_high
));
1647 debug_printf ("| |-> Byte stride = %s\n",
1648 plongest (new_stride
));
1649 debug_printf ("| |-> Last element = %s\n",
1650 plongest (last_elem
));
1651 debug_printf ("| |-> Remainder = %s\n",
1652 plongest (remainder
));
1653 debug_printf ("| '-> Contiguous = %s\n",
1654 (is_dim_contiguous
? "Yes" : "No"));
1657 /* Figure out how big (in bytes) an element of this dimension of
1658 the new array slice will be. */
1659 slice_element_size
= std::abs (new_stride
* e_count
);
1661 slice_dims
.emplace_back (new_low
, new_high
, new_stride
,
1664 /* Update the total offset. */
1665 total_offset
+= offset
;
1669 /* There is a single index for this dimension. */
1671 = value_as_long (ops
[i
]->evaluate_with_coercion (exp
, noside
));
1673 /* Get information about this dimension in the original ARRAY. */
1674 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
1675 struct type
*index_type
= dim_type
->index_type ();
1676 LONGEST lb
= f77_get_lowerbound (dim_type
);
1677 LONGEST ub
= f77_get_upperbound (dim_type
);
1678 LONGEST sd
= index_type
->bit_stride () / 8;
1680 sd
= TYPE_LENGTH (target_type
);
1682 if (fortran_array_slicing_debug
)
1684 debug_printf ("|-> Index access\n");
1685 std::string str
= type_to_string (dim_type
);
1686 debug_printf ("| |-> Type: %s\n", str
.c_str ());
1687 debug_printf ("| |-> Array:\n");
1688 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
1689 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
1690 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
));
1691 debug_printf ("| | |-> Type size: %s\n",
1692 pulongest (TYPE_LENGTH (dim_type
)));
1693 debug_printf ("| | '-> Target type size: %s\n",
1694 pulongest (TYPE_LENGTH (target_type
)));
1695 debug_printf ("| '-> Accessing:\n");
1696 debug_printf ("| '-> Index: %s\n",
1700 /* If the array has actual content then check the index is in
1701 bounds. An array without content (an unbound array) doesn't
1702 have a known upper bound, so don't error check in that
1705 || (dim_type
->index_type ()->bounds ()->high
.kind () != PROP_UNDEFINED
1707 || (VALUE_LVAL (array
) != lval_memory
1708 && dim_type
->index_type ()->bounds ()->high
.kind () == PROP_UNDEFINED
))
1710 if (type_not_associated (dim_type
))
1711 error (_("no such vector element (vector not associated)"));
1712 else if (type_not_allocated (dim_type
))
1713 error (_("no such vector element (vector not allocated)"));
1715 error (_("no such vector element"));
1718 /* Calculate using the type stride, not the target type size. */
1719 LONGEST offset
= sd
* (index
- lb
);
1720 total_offset
+= offset
;
1724 /* Build a type that represents the new array slice in the target memory
1725 of the original ARRAY, this type makes use of strides to correctly
1726 find only those elements that are part of the new slice. */
1727 struct type
*array_slice_type
= inner_element_type
;
1728 for (const auto &d
: slice_dims
)
1730 /* Create the range. */
1731 dynamic_prop p_low
, p_high
, p_stride
;
1733 p_low
.set_const_val (d
.low
);
1734 p_high
.set_const_val (d
.high
);
1735 p_stride
.set_const_val (d
.stride
);
1737 struct type
*new_range
1738 = create_range_type_with_stride ((struct type
*) NULL
,
1739 TYPE_TARGET_TYPE (d
.index
),
1740 &p_low
, &p_high
, 0, &p_stride
,
1743 = create_array_type (nullptr, array_slice_type
, new_range
);
1746 if (fortran_array_slicing_debug
)
1748 debug_printf ("'-> Final result:\n");
1749 debug_printf (" |-> Type: %s\n",
1750 type_to_string (array_slice_type
).c_str ());
1751 debug_printf (" |-> Total offset: %s\n",
1752 plongest (total_offset
));
1753 debug_printf (" |-> Base address: %s\n",
1754 core_addr_to_string (value_address (array
)));
1755 debug_printf (" '-> Contiguous = %s\n",
1756 (is_all_contiguous
? "Yes" : "No"));
1759 /* Should we repack this array slice? */
1760 if (!is_all_contiguous
&& (repack_array_slices
|| is_string_p
))
1762 /* Build a type for the repacked slice. */
1763 struct type
*repacked_array_type
= inner_element_type
;
1764 for (const auto &d
: slice_dims
)
1766 /* Create the range. */
1767 dynamic_prop p_low
, p_high
, p_stride
;
1769 p_low
.set_const_val (d
.low
);
1770 p_high
.set_const_val (d
.high
);
1771 p_stride
.set_const_val (TYPE_LENGTH (repacked_array_type
));
1773 struct type
*new_range
1774 = create_range_type_with_stride ((struct type
*) NULL
,
1775 TYPE_TARGET_TYPE (d
.index
),
1776 &p_low
, &p_high
, 0, &p_stride
,
1779 = create_array_type (nullptr, repacked_array_type
, new_range
);
1782 /* Now copy the elements from the original ARRAY into the packed
1783 array value DEST. */
1784 struct value
*dest
= allocate_value (repacked_array_type
);
1785 if (value_lazy (array
)
1786 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
1787 > TYPE_LENGTH (check_typedef (value_type (array
)))))
1789 fortran_array_walker
<fortran_lazy_array_repacker_impl
> p
1790 (array_slice_type
, value_address (array
) + total_offset
, dest
);
1795 fortran_array_walker
<fortran_array_repacker_impl
> p
1796 (array_slice_type
, value_address (array
) + total_offset
,
1797 total_offset
, array
, dest
);
1804 if (VALUE_LVAL (array
) == lval_memory
)
1806 /* If the value we're taking a slice from is not yet loaded, or
1807 the requested slice is outside the values content range then
1808 just create a new lazy value pointing at the memory where the
1809 contents we're looking for exist. */
1810 if (value_lazy (array
)
1811 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
1812 > TYPE_LENGTH (check_typedef (value_type (array
)))))
1813 array
= value_at_lazy (array_slice_type
,
1814 value_address (array
) + total_offset
);
1816 array
= value_from_contents_and_address (array_slice_type
,
1817 (value_contents (array
)
1819 (value_address (array
)
1822 else if (!value_lazy (array
))
1823 array
= value_from_component (array
, array_slice_type
, total_offset
);
1825 error (_("cannot subscript arrays that are not in memory"));
1832 fortran_undetermined::evaluate (struct type
*expect_type
,
1833 struct expression
*exp
,
1836 value
*callee
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
, noside
);
1837 struct type
*type
= check_typedef (value_type (callee
));
1838 enum type_code code
= type
->code ();
1840 if (code
== TYPE_CODE_PTR
)
1842 /* Fortran always passes variable to subroutines as pointer.
1843 So we need to look into its target type to see if it is
1844 array, string or function. If it is, we need to switch
1845 to the target value the original one points to. */
1846 struct type
*target_type
= check_typedef (TYPE_TARGET_TYPE (type
));
1848 if (target_type
->code () == TYPE_CODE_ARRAY
1849 || target_type
->code () == TYPE_CODE_STRING
1850 || target_type
->code () == TYPE_CODE_FUNC
)
1852 callee
= value_ind (callee
);
1853 type
= check_typedef (value_type (callee
));
1854 code
= type
->code ();
1860 case TYPE_CODE_ARRAY
:
1861 case TYPE_CODE_STRING
:
1862 return value_subarray (callee
, exp
, noside
);
1865 case TYPE_CODE_FUNC
:
1866 case TYPE_CODE_INTERNAL_FUNCTION
:
1868 /* It's a function call. Allocate arg vector, including
1869 space for the function to be called in argvec[0] and a
1870 termination NULL. */
1871 const std::vector
<operation_up
> &actual (std::get
<1> (m_storage
));
1872 std::vector
<value
*> argvec (actual
.size ());
1873 bool is_internal_func
= (code
== TYPE_CODE_INTERNAL_FUNCTION
);
1874 for (int tem
= 0; tem
< argvec
.size (); tem
++)
1875 argvec
[tem
] = fortran_prepare_argument (exp
, actual
[tem
].get (),
1876 tem
, is_internal_func
,
1877 value_type (callee
),
1879 return evaluate_subexp_do_call (exp
, noside
, callee
, argvec
,
1880 nullptr, expect_type
);
1884 error (_("Cannot perform substring on this type"));
1889 fortran_bound_1arg::evaluate (struct type
*expect_type
,
1890 struct expression
*exp
,
1893 bool lbound_p
= std::get
<0> (m_storage
) == FORTRAN_LBOUND
;
1894 value
*arg1
= std::get
<1> (m_storage
)->evaluate (nullptr, exp
, noside
);
1895 fortran_require_array (value_type (arg1
), lbound_p
);
1896 return fortran_bounds_all_dims (lbound_p
, exp
->gdbarch
, arg1
);
1900 fortran_bound_2arg::evaluate (struct type
*expect_type
,
1901 struct expression
*exp
,
1904 bool lbound_p
= std::get
<0> (m_storage
) == FORTRAN_LBOUND
;
1905 value
*arg1
= std::get
<1> (m_storage
)->evaluate (nullptr, exp
, noside
);
1906 fortran_require_array (value_type (arg1
), lbound_p
);
1908 /* User asked for the bounds of a specific dimension of the array. */
1909 value
*arg2
= std::get
<2> (m_storage
)->evaluate (nullptr, exp
, noside
);
1910 struct type
*type
= check_typedef (value_type (arg2
));
1911 if (type
->code () != TYPE_CODE_INT
)
1914 error (_("LBOUND second argument should be an integer"));
1916 error (_("UBOUND second argument should be an integer"));
1919 return fortran_bounds_for_dimension (lbound_p
, exp
->gdbarch
, arg1
, arg2
);
1922 } /* namespace expr */
1924 /* Special expression lengths for Fortran. */
1927 operator_length_f (const struct expression
*exp
, int pc
, int *oplenp
,
1933 switch (exp
->elts
[pc
- 1].opcode
)
1936 operator_length_standard (exp
, pc
, oplenp
, argsp
);
1939 case UNOP_FORTRAN_KIND
:
1940 case UNOP_FORTRAN_FLOOR
:
1941 case UNOP_FORTRAN_CEILING
:
1942 case UNOP_FORTRAN_ALLOCATED
:
1947 case BINOP_FORTRAN_CMPLX
:
1948 case BINOP_FORTRAN_MODULO
:
1953 case FORTRAN_ASSOCIATED
:
1954 case FORTRAN_LBOUND
:
1955 case FORTRAN_UBOUND
:
1957 args
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
1960 case OP_F77_UNDETERMINED_ARGLIST
:
1962 args
= 1 + longest_to_int (exp
->elts
[pc
- 2].longconst
);
1970 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1971 the extra argument NAME which is the text that should be printed as the
1972 name of this operation. */
1975 print_unop_subexp_f (struct expression
*exp
, int *pos
,
1976 struct ui_file
*stream
, enum precedence prec
,
1980 fprintf_filtered (stream
, "%s(", name
);
1981 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1982 fputs_filtered (")", stream
);
1985 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1986 the extra argument NAME which is the text that should be printed as the
1987 name of this operation. */
1990 print_binop_subexp_f (struct expression
*exp
, int *pos
,
1991 struct ui_file
*stream
, enum precedence prec
,
1995 fprintf_filtered (stream
, "%s(", name
);
1996 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1997 fputs_filtered (",", stream
);
1998 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1999 fputs_filtered (")", stream
);
2002 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
2003 the extra argument NAME which is the text that should be printed as the
2004 name of this operation. */
2007 print_unop_or_binop_subexp_f (struct expression
*exp
, int *pos
,
2008 struct ui_file
*stream
, enum precedence prec
,
2011 unsigned nargs
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
);
2013 fprintf_filtered (stream
, "%s (", name
);
2014 for (unsigned tem
= 0; tem
< nargs
; tem
++)
2017 fputs_filtered (", ", stream
);
2018 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
2020 fputs_filtered (")", stream
);
2023 /* Special expression printing for Fortran. */
2026 print_subexp_f (struct expression
*exp
, int *pos
,
2027 struct ui_file
*stream
, enum precedence prec
)
2030 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
2035 print_subexp_standard (exp
, pos
, stream
, prec
);
2038 case UNOP_FORTRAN_KIND
:
2039 print_unop_subexp_f (exp
, pos
, stream
, prec
, "KIND");
2042 case UNOP_FORTRAN_FLOOR
:
2043 print_unop_subexp_f (exp
, pos
, stream
, prec
, "FLOOR");
2046 case UNOP_FORTRAN_CEILING
:
2047 print_unop_subexp_f (exp
, pos
, stream
, prec
, "CEILING");
2050 case UNOP_FORTRAN_ALLOCATED
:
2051 print_unop_subexp_f (exp
, pos
, stream
, prec
, "ALLOCATED");
2054 case BINOP_FORTRAN_CMPLX
:
2055 print_binop_subexp_f (exp
, pos
, stream
, prec
, "CMPLX");
2058 case BINOP_FORTRAN_MODULO
:
2059 print_binop_subexp_f (exp
, pos
, stream
, prec
, "MODULO");
2062 case FORTRAN_ASSOCIATED
:
2063 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "ASSOCIATED");
2066 case FORTRAN_LBOUND
:
2067 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "LBOUND");
2070 case FORTRAN_UBOUND
:
2071 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "UBOUND");
2074 case OP_F77_UNDETERMINED_ARGLIST
:
2076 print_subexp_funcall (exp
, pos
, stream
);
2081 /* Special expression dumping for Fortran. */
2084 dump_subexp_body_f (struct expression
*exp
,
2085 struct ui_file
*stream
, int elt
)
2087 int opcode
= exp
->elts
[elt
].opcode
;
2088 int oplen
, nargs
, i
;
2093 return dump_subexp_body_standard (exp
, stream
, elt
);
2095 case UNOP_FORTRAN_KIND
:
2096 case UNOP_FORTRAN_FLOOR
:
2097 case UNOP_FORTRAN_CEILING
:
2098 case UNOP_FORTRAN_ALLOCATED
:
2099 case BINOP_FORTRAN_CMPLX
:
2100 case BINOP_FORTRAN_MODULO
:
2101 operator_length_f (exp
, (elt
+ 1), &oplen
, &nargs
);
2104 case FORTRAN_ASSOCIATED
:
2105 case FORTRAN_LBOUND
:
2106 case FORTRAN_UBOUND
:
2107 operator_length_f (exp
, (elt
+ 3), &oplen
, &nargs
);
2110 case OP_F77_UNDETERMINED_ARGLIST
:
2111 return dump_subexp_body_funcall (exp
, stream
, elt
+ 1);
2115 for (i
= 0; i
< nargs
; i
+= 1)
2116 elt
= dump_subexp (exp
, stream
, elt
);
2121 /* Special expression checking for Fortran. */
2124 operator_check_f (struct expression
*exp
, int pos
,
2125 int (*objfile_func
) (struct objfile
*objfile
,
2129 const union exp_element
*const elts
= exp
->elts
;
2131 switch (elts
[pos
].opcode
)
2133 case UNOP_FORTRAN_KIND
:
2134 case UNOP_FORTRAN_FLOOR
:
2135 case UNOP_FORTRAN_CEILING
:
2136 case UNOP_FORTRAN_ALLOCATED
:
2137 case BINOP_FORTRAN_CMPLX
:
2138 case BINOP_FORTRAN_MODULO
:
2139 case FORTRAN_ASSOCIATED
:
2140 case FORTRAN_LBOUND
:
2141 case FORTRAN_UBOUND
:
2142 /* Any references to objfiles are held in the arguments to this
2143 expression, not within the expression itself, so no additional
2144 checking is required here, the outer expression iteration code
2145 will take care of checking each argument. */
2149 return operator_check_standard (exp
, pos
, objfile_func
, data
);
2155 /* Expression processing for Fortran. */
2156 const struct exp_descriptor
f_language::exp_descriptor_tab
=
2165 /* See language.h. */
2168 f_language::language_arch_info (struct gdbarch
*gdbarch
,
2169 struct language_arch_info
*lai
) const
2171 const struct builtin_f_type
*builtin
= builtin_f_type (gdbarch
);
2173 /* Helper function to allow shorter lines below. */
2174 auto add
= [&] (struct type
* t
)
2176 lai
->add_primitive_type (t
);
2179 add (builtin
->builtin_character
);
2180 add (builtin
->builtin_logical
);
2181 add (builtin
->builtin_logical_s1
);
2182 add (builtin
->builtin_logical_s2
);
2183 add (builtin
->builtin_logical_s8
);
2184 add (builtin
->builtin_real
);
2185 add (builtin
->builtin_real_s8
);
2186 add (builtin
->builtin_real_s16
);
2187 add (builtin
->builtin_complex_s8
);
2188 add (builtin
->builtin_complex_s16
);
2189 add (builtin
->builtin_void
);
2191 lai
->set_string_char_type (builtin
->builtin_character
);
2192 lai
->set_bool_type (builtin
->builtin_logical_s2
, "logical");
2195 /* See language.h. */
2198 f_language::search_name_hash (const char *name
) const
2200 return cp_search_name_hash (name
);
2203 /* See language.h. */
2206 f_language::lookup_symbol_nonlocal (const char *name
,
2207 const struct block
*block
,
2208 const domain_enum domain
) const
2210 return cp_lookup_symbol_nonlocal (this, name
, block
, domain
);
2213 /* See language.h. */
2215 symbol_name_matcher_ftype
*
2216 f_language::get_symbol_name_matcher_inner
2217 (const lookup_name_info
&lookup_name
) const
2219 return cp_get_symbol_name_matcher (lookup_name
);
2222 /* Single instance of the Fortran language class. */
2224 static f_language f_language_defn
;
2227 build_fortran_types (struct gdbarch
*gdbarch
)
2229 struct builtin_f_type
*builtin_f_type
2230 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_f_type
);
2232 builtin_f_type
->builtin_void
2233 = arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
, "void");
2235 builtin_f_type
->builtin_character
2236 = arch_type (gdbarch
, TYPE_CODE_CHAR
, TARGET_CHAR_BIT
, "character");
2238 builtin_f_type
->builtin_logical_s1
2239 = arch_boolean_type (gdbarch
, TARGET_CHAR_BIT
, 1, "logical*1");
2241 builtin_f_type
->builtin_integer_s2
2242 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
), 0,
2245 builtin_f_type
->builtin_integer_s8
2246 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 0,
2249 builtin_f_type
->builtin_logical_s2
2250 = arch_boolean_type (gdbarch
, gdbarch_short_bit (gdbarch
), 1,
2253 builtin_f_type
->builtin_logical_s8
2254 = arch_boolean_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 1,
2257 builtin_f_type
->builtin_integer
2258 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 0,
2261 builtin_f_type
->builtin_logical
2262 = arch_boolean_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1,
2265 builtin_f_type
->builtin_real
2266 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
2267 "real", gdbarch_float_format (gdbarch
));
2268 builtin_f_type
->builtin_real_s8
2269 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
2270 "real*8", gdbarch_double_format (gdbarch
));
2271 auto fmt
= gdbarch_floatformat_for_type (gdbarch
, "real(kind=16)", 128);
2273 builtin_f_type
->builtin_real_s16
2274 = arch_float_type (gdbarch
, 128, "real*16", fmt
);
2275 else if (gdbarch_long_double_bit (gdbarch
) == 128)
2276 builtin_f_type
->builtin_real_s16
2277 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
2278 "real*16", gdbarch_long_double_format (gdbarch
));
2280 builtin_f_type
->builtin_real_s16
2281 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 128, "real*16");
2283 builtin_f_type
->builtin_complex_s8
2284 = init_complex_type ("complex*8", builtin_f_type
->builtin_real
);
2285 builtin_f_type
->builtin_complex_s16
2286 = init_complex_type ("complex*16", builtin_f_type
->builtin_real_s8
);
2288 if (builtin_f_type
->builtin_real_s16
->code () == TYPE_CODE_ERROR
)
2289 builtin_f_type
->builtin_complex_s32
2290 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 256, "complex*32");
2292 builtin_f_type
->builtin_complex_s32
2293 = init_complex_type ("complex*32", builtin_f_type
->builtin_real_s16
);
2295 return builtin_f_type
;
2298 static struct gdbarch_data
*f_type_data
;
2300 const struct builtin_f_type
*
2301 builtin_f_type (struct gdbarch
*gdbarch
)
2303 return (const struct builtin_f_type
*) gdbarch_data (gdbarch
, f_type_data
);
2306 /* Command-list for the "set/show fortran" prefix command. */
2307 static struct cmd_list_element
*set_fortran_list
;
2308 static struct cmd_list_element
*show_fortran_list
;
2310 void _initialize_f_language ();
2312 _initialize_f_language ()
2314 f_type_data
= gdbarch_data_register_post_init (build_fortran_types
);
2316 add_basic_prefix_cmd ("fortran", no_class
,
2317 _("Prefix command for changing Fortran-specific settings."),
2318 &set_fortran_list
, "set fortran ", 0, &setlist
);
2320 add_show_prefix_cmd ("fortran", no_class
,
2321 _("Generic command for showing Fortran-specific settings."),
2322 &show_fortran_list
, "show fortran ", 0, &showlist
);
2324 add_setshow_boolean_cmd ("repack-array-slices", class_vars
,
2325 &repack_array_slices
, _("\
2326 Enable or disable repacking of non-contiguous array slices."), _("\
2327 Show whether non-contiguous array slices are repacked."), _("\
2328 When the user requests a slice of a Fortran array then we can either return\n\
2329 a descriptor that describes the array in place (using the original array data\n\
2330 in its existing location) or the original data can be repacked (copied) to a\n\
2333 When the content of the array slice is contiguous within the original array\n\
2334 then the result will never be repacked, but when the data for the new array\n\
2335 is non-contiguous within the original array repacking will only be performed\n\
2336 when this setting is on."),
2338 show_repack_array_slices
,
2339 &set_fortran_list
, &show_fortran_list
);
2341 /* Debug Fortran's array slicing logic. */
2342 add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance
,
2343 &fortran_array_slicing_debug
, _("\
2344 Set debugging of Fortran array slicing."), _("\
2345 Show debugging of Fortran array slicing."), _("\
2346 When on, debugging of Fortran array slicing is enabled."),
2348 show_fortran_array_slicing_debug
,
2349 &setdebuglist
, &showdebuglist
);
2352 /* Ensures that function argument VALUE is in the appropriate form to
2353 pass to a Fortran function. Returns a possibly new value that should
2354 be used instead of VALUE.
2356 When IS_ARTIFICIAL is true this indicates an artificial argument,
2357 e.g. hidden string lengths which the GNU Fortran argument passing
2358 convention specifies as being passed by value.
2360 When IS_ARTIFICIAL is false, the argument is passed by pointer. If the
2361 value is already in target memory then return a value that is a pointer
2362 to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate
2363 space in the target, copy VALUE in, and return a pointer to the in
2366 static struct value
*
2367 fortran_argument_convert (struct value
*value
, bool is_artificial
)
2371 /* If the value is not in the inferior e.g. registers values,
2372 convenience variables and user input. */
2373 if (VALUE_LVAL (value
) != lval_memory
)
2375 struct type
*type
= value_type (value
);
2376 const int length
= TYPE_LENGTH (type
);
2377 const CORE_ADDR addr
2378 = value_as_long (value_allocate_space_in_inferior (length
));
2379 write_memory (addr
, value_contents (value
), length
);
2381 = value_from_contents_and_address (type
, value_contents (value
),
2383 return value_addr (val
);
2386 return value_addr (value
); /* Program variables, e.g. arrays. */
2391 /* Prepare (and return) an argument value ready for an inferior function
2392 call to a Fortran function. EXP and POS are the expressions describing
2393 the argument to prepare. ARG_NUM is the argument number being
2394 prepared, with 0 being the first argument and so on. FUNC_TYPE is the
2395 type of the function being called.
2397 IS_INTERNAL_CALL_P is true if this is a call to a function of type
2398 TYPE_CODE_INTERNAL_FUNCTION, otherwise this parameter is false.
2400 NOSIDE has its usual meaning for expression parsing (see eval.c).
2402 Arguments in Fortran are normally passed by address, we coerce the
2403 arguments here rather than in value_arg_coerce as otherwise the call to
2404 malloc (to place the non-lvalue parameters in target memory) is hit by
2405 this Fortran specific logic. This results in malloc being called with a
2406 pointer to an integer followed by an attempt to malloc the arguments to
2407 malloc in target memory. Infinite recursion ensues. */
2410 fortran_prepare_argument (struct expression
*exp
, int *pos
,
2411 int arg_num
, bool is_internal_call_p
,
2412 struct type
*func_type
, enum noside noside
)
2414 if (is_internal_call_p
)
2415 return evaluate_subexp_with_coercion (exp
, pos
, noside
);
2417 bool is_artificial
= ((arg_num
>= func_type
->num_fields ())
2419 : TYPE_FIELD_ARTIFICIAL (func_type
, arg_num
));
2421 /* If this is an artificial argument, then either, this is an argument
2422 beyond the end of the known arguments, or possibly, there are no known
2423 arguments (maybe missing debug info).
2425 For these artificial arguments, if the user has prefixed it with '&'
2426 (for address-of), then lets always allow this to succeed, even if the
2427 argument is not actually in inferior memory. This will allow the user
2428 to pass arguments to a Fortran function even when there's no debug
2431 As we already pass the address of non-artificial arguments, all we
2432 need to do if skip the UNOP_ADDR operator in the expression and mark
2433 the argument as non-artificial. */
2434 if (is_artificial
&& exp
->elts
[*pos
].opcode
== UNOP_ADDR
)
2437 is_artificial
= false;
2440 struct value
*arg_val
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
2441 return fortran_argument_convert (arg_val
, is_artificial
);
2444 /* Prepare (and return) an argument value ready for an inferior function
2445 call to a Fortran function. EXP and POS are the expressions describing
2446 the argument to prepare. ARG_NUM is the argument number being
2447 prepared, with 0 being the first argument and so on. FUNC_TYPE is the
2448 type of the function being called.
2450 IS_INTERNAL_CALL_P is true if this is a call to a function of type
2451 TYPE_CODE_INTERNAL_FUNCTION, otherwise this parameter is false.
2453 NOSIDE has its usual meaning for expression parsing (see eval.c).
2455 Arguments in Fortran are normally passed by address, we coerce the
2456 arguments here rather than in value_arg_coerce as otherwise the call to
2457 malloc (to place the non-lvalue parameters in target memory) is hit by
2458 this Fortran specific logic. This results in malloc being called with a
2459 pointer to an integer followed by an attempt to malloc the arguments to
2460 malloc in target memory. Infinite recursion ensues. */
2463 fortran_prepare_argument (struct expression
*exp
,
2464 expr::operation
*subexp
,
2465 int arg_num
, bool is_internal_call_p
,
2466 struct type
*func_type
, enum noside noside
)
2468 if (is_internal_call_p
)
2469 return subexp
->evaluate_with_coercion (exp
, noside
);
2471 bool is_artificial
= ((arg_num
>= func_type
->num_fields ())
2473 : TYPE_FIELD_ARTIFICIAL (func_type
, arg_num
));
2475 /* If this is an artificial argument, then either, this is an argument
2476 beyond the end of the known arguments, or possibly, there are no known
2477 arguments (maybe missing debug info).
2479 For these artificial arguments, if the user has prefixed it with '&'
2480 (for address-of), then lets always allow this to succeed, even if the
2481 argument is not actually in inferior memory. This will allow the user
2482 to pass arguments to a Fortran function even when there's no debug
2485 As we already pass the address of non-artificial arguments, all we
2486 need to do if skip the UNOP_ADDR operator in the expression and mark
2487 the argument as non-artificial. */
2490 expr::unop_addr_operation
*addrop
2491 = dynamic_cast<expr::unop_addr_operation
*> (subexp
);
2492 if (addrop
!= nullptr)
2494 subexp
= addrop
->get_expression ().get ();
2495 is_artificial
= false;
2499 struct value
*arg_val
= subexp
->evaluate_with_coercion (exp
, noside
);
2500 return fortran_argument_convert (arg_val
, is_artificial
);
2506 fortran_preserve_arg_pointer (struct value
*arg
, struct type
*type
)
2508 if (value_type (arg
)->code () == TYPE_CODE_PTR
)
2509 return value_type (arg
);
2516 fortran_adjust_dynamic_array_base_address_hack (struct type
*type
,
2519 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
2521 /* We can't adjust the base address for arrays that have no content. */
2522 if (type_not_allocated (type
) || type_not_associated (type
))
2525 int ndimensions
= calc_f77_array_dims (type
);
2526 LONGEST total_offset
= 0;
2528 /* Walk through each of the dimensions of this array type and figure out
2529 if any of the dimensions are "backwards", that is the base address
2530 for this dimension points to the element at the highest memory
2531 address and the stride is negative. */
2532 struct type
*tmp_type
= type
;
2533 for (int i
= 0 ; i
< ndimensions
; ++i
)
2535 /* Grab the range for this dimension and extract the lower and upper
2537 tmp_type
= check_typedef (tmp_type
);
2538 struct type
*range_type
= tmp_type
->index_type ();
2539 LONGEST lowerbound
, upperbound
, stride
;
2540 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
2541 error ("failed to get range bounds");
2543 /* Figure out the stride for this dimension. */
2544 struct type
*elt_type
= check_typedef (TYPE_TARGET_TYPE (tmp_type
));
2545 stride
= tmp_type
->index_type ()->bounds ()->bit_stride ();
2547 stride
= type_length_units (elt_type
);
2551 = gdbarch_addressable_memory_unit_size (elt_type
->arch ());
2552 stride
/= (unit_size
* 8);
2555 /* If this dimension is "backward" then figure out the offset
2556 adjustment required to point to the element at the lowest memory
2557 address, and add this to the total offset. */
2559 if (stride
< 0 && lowerbound
< upperbound
)
2560 offset
= (upperbound
- lowerbound
) * stride
;
2561 total_offset
+= offset
;
2562 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
2565 /* Adjust the address of this object and return it. */
2566 address
+= total_offset
;