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 /* A helper function for UNOP_ABS. */
1002 eval_op_f_abs (struct type
*expect_type
, struct expression
*exp
,
1004 enum exp_opcode opcode
,
1007 if (noside
== EVAL_SKIP
)
1008 return eval_skip_value (exp
);
1009 struct type
*type
= value_type (arg1
);
1010 switch (type
->code ())
1015 = fabs (target_float_to_host_double (value_contents (arg1
),
1016 value_type (arg1
)));
1017 return value_from_host_double (type
, d
);
1021 LONGEST l
= value_as_long (arg1
);
1023 return value_from_longest (type
, l
);
1026 error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type
));
1029 /* A helper function for BINOP_MOD. */
1032 eval_op_f_mod (struct type
*expect_type
, struct expression
*exp
,
1034 enum exp_opcode opcode
,
1035 struct value
*arg1
, struct value
*arg2
)
1037 if (noside
== EVAL_SKIP
)
1038 return eval_skip_value (exp
);
1039 struct type
*type
= value_type (arg1
);
1040 if (type
->code () != value_type (arg2
)->code ())
1041 error (_("non-matching types for parameters to MOD ()"));
1042 switch (type
->code ())
1047 = target_float_to_host_double (value_contents (arg1
),
1050 = target_float_to_host_double (value_contents (arg2
),
1052 double d3
= fmod (d1
, d2
);
1053 return value_from_host_double (type
, d3
);
1057 LONGEST v1
= value_as_long (arg1
);
1058 LONGEST v2
= value_as_long (arg2
);
1060 error (_("calling MOD (N, 0) is undefined"));
1061 LONGEST v3
= v1
- (v1
/ v2
) * v2
;
1062 return value_from_longest (value_type (arg1
), v3
);
1065 error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type
));
1068 /* A helper function for UNOP_FORTRAN_CEILING. */
1071 eval_op_f_ceil (struct type
*expect_type
, struct expression
*exp
,
1073 enum exp_opcode opcode
,
1076 if (noside
== EVAL_SKIP
)
1077 return eval_skip_value (exp
);
1078 struct type
*type
= value_type (arg1
);
1079 if (type
->code () != TYPE_CODE_FLT
)
1080 error (_("argument to CEILING must be of type float"));
1082 = target_float_to_host_double (value_contents (arg1
),
1085 return value_from_host_double (type
, val
);
1088 /* A helper function for UNOP_FORTRAN_FLOOR. */
1091 eval_op_f_floor (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 FLOOR 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 BINOP_FORTRAN_MODULO. */
1111 eval_op_f_modulo (struct type
*expect_type
, struct expression
*exp
,
1113 enum exp_opcode opcode
,
1114 struct value
*arg1
, struct value
*arg2
)
1116 if (noside
== EVAL_SKIP
)
1117 return eval_skip_value (exp
);
1118 struct type
*type
= value_type (arg1
);
1119 if (type
->code () != value_type (arg2
)->code ())
1120 error (_("non-matching types for parameters to MODULO ()"));
1121 /* MODULO(A, P) = A - FLOOR (A / P) * P */
1122 switch (type
->code ())
1126 LONGEST a
= value_as_long (arg1
);
1127 LONGEST p
= value_as_long (arg2
);
1128 LONGEST result
= a
- (a
/ p
) * p
;
1129 if (result
!= 0 && (a
< 0) != (p
< 0))
1131 return value_from_longest (value_type (arg1
), result
);
1136 = target_float_to_host_double (value_contents (arg1
),
1139 = target_float_to_host_double (value_contents (arg2
),
1141 double result
= fmod (a
, p
);
1142 if (result
!= 0 && (a
< 0.0) != (p
< 0.0))
1144 return value_from_host_double (type
, result
);
1147 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type
));
1150 /* A helper function for BINOP_FORTRAN_CMPLX. */
1153 eval_op_f_cmplx (struct type
*expect_type
, struct expression
*exp
,
1155 enum exp_opcode opcode
,
1156 struct value
*arg1
, struct value
*arg2
)
1158 if (noside
== EVAL_SKIP
)
1159 return eval_skip_value (exp
);
1160 struct type
*type
= builtin_f_type(exp
->gdbarch
)->builtin_complex_s16
;
1161 return value_literal_complex (arg1
, arg2
, type
);
1164 /* A helper function for UNOP_FORTRAN_KIND. */
1167 eval_op_f_kind (struct type
*expect_type
, struct expression
*exp
,
1169 enum exp_opcode opcode
,
1172 struct type
*type
= value_type (arg1
);
1174 switch (type
->code ())
1176 case TYPE_CODE_STRUCT
:
1177 case TYPE_CODE_UNION
:
1178 case TYPE_CODE_MODULE
:
1179 case TYPE_CODE_FUNC
:
1180 error (_("argument to kind must be an intrinsic type"));
1183 if (!TYPE_TARGET_TYPE (type
))
1184 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1185 TYPE_LENGTH (type
));
1186 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1187 TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
1190 /* A helper function for UNOP_FORTRAN_ALLOCATED. */
1192 static struct value
*
1193 eval_op_f_allocated (struct type
*expect_type
, struct expression
*exp
,
1194 enum noside noside
, enum exp_opcode op
,
1197 struct type
*type
= check_typedef (value_type (arg1
));
1198 if (type
->code () != TYPE_CODE_ARRAY
)
1199 error (_("ALLOCATED can only be applied to arrays"));
1200 struct type
*result_type
1201 = builtin_f_type (exp
->gdbarch
)->builtin_logical
;
1202 LONGEST result_value
= type_not_allocated (type
) ? 0 : 1;
1203 return value_from_longest (result_type
, result_value
);
1206 /* Special expression evaluation cases for Fortran. */
1208 static struct value
*
1209 evaluate_subexp_f (struct type
*expect_type
, struct expression
*exp
,
1210 int *pos
, enum noside noside
)
1212 struct value
*arg1
= NULL
, *arg2
= NULL
;
1219 op
= exp
->elts
[pc
].opcode
;
1225 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
1228 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1229 return eval_op_f_abs (expect_type
, exp
, noside
, op
, arg1
);
1232 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1233 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1234 return eval_op_f_mod (expect_type
, exp
, noside
, op
, arg1
, arg2
);
1236 case UNOP_FORTRAN_CEILING
:
1237 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1238 return eval_op_f_ceil (expect_type
, exp
, noside
, op
, arg1
);
1240 case UNOP_FORTRAN_FLOOR
:
1241 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1242 return eval_op_f_floor (expect_type
, exp
, noside
, op
, arg1
);
1244 case UNOP_FORTRAN_ALLOCATED
:
1246 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1247 if (noside
== EVAL_SKIP
)
1248 return eval_skip_value (exp
);
1249 return eval_op_f_allocated (expect_type
, exp
, noside
, op
, arg1
);
1252 case BINOP_FORTRAN_MODULO
:
1253 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1254 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1255 return eval_op_f_modulo (expect_type
, exp
, noside
, op
, arg1
, arg2
);
1257 case FORTRAN_LBOUND
:
1258 case FORTRAN_UBOUND
:
1260 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1263 /* This assertion should be enforced by the expression parser. */
1264 gdb_assert (nargs
== 1 || nargs
== 2);
1266 bool lbound_p
= op
== FORTRAN_LBOUND
;
1268 /* Check that the first argument is array like. */
1269 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1270 fortran_require_array (value_type (arg1
), lbound_p
);
1273 return fortran_bounds_all_dims (lbound_p
, exp
->gdbarch
, arg1
);
1275 /* User asked for the bounds of a specific dimension of the array. */
1276 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1277 type
= check_typedef (value_type (arg2
));
1278 if (type
->code () != TYPE_CODE_INT
)
1281 error (_("LBOUND second argument should be an integer"));
1283 error (_("UBOUND second argument should be an integer"));
1286 return fortran_bounds_for_dimension (lbound_p
, exp
->gdbarch
, arg1
,
1291 case FORTRAN_ASSOCIATED
:
1293 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1296 /* This assertion should be enforced by the expression parser. */
1297 gdb_assert (nargs
== 1 || nargs
== 2);
1299 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1303 if (noside
== EVAL_SKIP
)
1304 return eval_skip_value (exp
);
1305 return fortran_associated (exp
->gdbarch
, exp
->language_defn
,
1309 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1310 if (noside
== EVAL_SKIP
)
1311 return eval_skip_value (exp
);
1312 return fortran_associated (exp
->gdbarch
, exp
->language_defn
,
1317 case BINOP_FORTRAN_CMPLX
:
1318 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1319 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1320 return eval_op_f_cmplx (expect_type
, exp
, noside
, op
, arg1
, arg2
);
1322 case UNOP_FORTRAN_KIND
:
1323 arg1
= evaluate_subexp (NULL
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
1324 return eval_op_f_kind (expect_type
, exp
, noside
, op
, arg1
);
1326 case OP_F77_UNDETERMINED_ARGLIST
:
1327 /* Remember that in F77, functions, substring ops and array subscript
1328 operations cannot be disambiguated at parse time. We have made
1329 all array subscript operations, substring operations as well as
1330 function calls come here and we now have to discover what the heck
1331 this thing actually was. If it is a function, we process just as
1332 if we got an OP_FUNCALL. */
1333 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1336 /* First determine the type code we are dealing with. */
1337 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1338 type
= check_typedef (value_type (arg1
));
1339 enum type_code code
= type
->code ();
1341 if (code
== TYPE_CODE_PTR
)
1343 /* Fortran always passes variable to subroutines as pointer.
1344 So we need to look into its target type to see if it is
1345 array, string or function. If it is, we need to switch
1346 to the target value the original one points to. */
1347 struct type
*target_type
= check_typedef (TYPE_TARGET_TYPE (type
));
1349 if (target_type
->code () == TYPE_CODE_ARRAY
1350 || target_type
->code () == TYPE_CODE_STRING
1351 || target_type
->code () == TYPE_CODE_FUNC
)
1353 arg1
= value_ind (arg1
);
1354 type
= check_typedef (value_type (arg1
));
1355 code
= type
->code ();
1361 case TYPE_CODE_ARRAY
:
1362 case TYPE_CODE_STRING
:
1363 return fortran_value_subarray (arg1
, exp
, pos
, nargs
, noside
);
1366 case TYPE_CODE_FUNC
:
1367 case TYPE_CODE_INTERNAL_FUNCTION
:
1369 /* It's a function call. Allocate arg vector, including
1370 space for the function to be called in argvec[0] and a
1371 termination NULL. */
1372 struct value
**argvec
= (struct value
**)
1373 alloca (sizeof (struct value
*) * (nargs
+ 2));
1376 for (; tem
<= nargs
; tem
++)
1378 bool is_internal_func
= (code
== TYPE_CODE_INTERNAL_FUNCTION
);
1380 = fortran_prepare_argument (exp
, pos
, (tem
- 1),
1382 value_type (arg1
), noside
);
1384 argvec
[tem
] = 0; /* signal end of arglist */
1385 if (noside
== EVAL_SKIP
)
1386 return eval_skip_value (exp
);
1387 return evaluate_subexp_do_call (exp
, noside
, argvec
[0],
1388 gdb::make_array_view (argvec
+ 1,
1394 error (_("Cannot perform substring on this type"));
1398 /* Should be unreachable. */
1405 /* Called from evaluate to perform array indexing, and sub-range
1406 extraction, for Fortran. As well as arrays this function also
1407 handles strings as they can be treated like arrays of characters.
1408 ARRAY is the array or string being accessed. EXP and NOSIDE are as
1412 fortran_undetermined::value_subarray (value
*array
,
1413 struct expression
*exp
,
1416 type
*original_array_type
= check_typedef (value_type (array
));
1417 bool is_string_p
= original_array_type
->code () == TYPE_CODE_STRING
;
1418 const std::vector
<operation_up
> &ops
= std::get
<1> (m_storage
);
1419 int nargs
= ops
.size ();
1421 /* Perform checks for ARRAY not being available. The somewhat overly
1422 complex logic here is just to keep backward compatibility with the
1423 errors that we used to get before FORTRAN_VALUE_SUBARRAY was
1424 rewritten. Maybe a future task would streamline the error messages we
1425 get here, and update all the expected test results. */
1426 if (ops
[0]->opcode () != OP_RANGE
)
1428 if (type_not_associated (original_array_type
))
1429 error (_("no such vector element (vector not associated)"));
1430 else if (type_not_allocated (original_array_type
))
1431 error (_("no such vector element (vector not allocated)"));
1435 if (type_not_associated (original_array_type
))
1436 error (_("array not associated"));
1437 else if (type_not_allocated (original_array_type
))
1438 error (_("array not allocated"));
1441 /* First check that the number of dimensions in the type we are slicing
1442 matches the number of arguments we were passed. */
1443 int ndimensions
= calc_f77_array_dims (original_array_type
);
1444 if (nargs
!= ndimensions
)
1445 error (_("Wrong number of subscripts"));
1447 /* This will be initialised below with the type of the elements held in
1449 struct type
*inner_element_type
;
1451 /* Extract the types of each array dimension from the original array
1452 type. We need these available so we can fill in the default upper and
1453 lower bounds if the user requested slice doesn't provide that
1454 information. Additionally unpacking the dimensions like this gives us
1455 the inner element type. */
1456 std::vector
<struct type
*> dim_types
;
1458 dim_types
.reserve (ndimensions
);
1459 struct type
*type
= original_array_type
;
1460 for (int i
= 0; i
< ndimensions
; ++i
)
1462 dim_types
.push_back (type
);
1463 type
= TYPE_TARGET_TYPE (type
);
1465 /* TYPE is now the inner element type of the array, we start the new
1466 array slice off as this type, then as we process the requested slice
1467 (from the user) we wrap new types around this to build up the final
1469 inner_element_type
= type
;
1472 /* As we analyse the new slice type we need to understand if the data
1473 being referenced is contiguous. Do decide this we must track the size
1474 of an element at each dimension of the new slice array. Initially the
1475 elements of the inner most dimension of the array are the same inner
1476 most elements as the original ARRAY. */
1477 LONGEST slice_element_size
= TYPE_LENGTH (inner_element_type
);
1479 /* Start off assuming all data is contiguous, this will be set to false
1480 if access to any dimension results in non-contiguous data. */
1481 bool is_all_contiguous
= true;
1483 /* The TOTAL_OFFSET is the distance in bytes from the start of the
1484 original ARRAY to the start of the new slice. This is calculated as
1485 we process the information from the user. */
1486 LONGEST total_offset
= 0;
1488 /* A structure representing information about each dimension of the
1493 slice_dim (LONGEST l
, LONGEST h
, LONGEST s
, struct type
*idx
)
1500 /* The low bound for this dimension of the slice. */
1503 /* The high bound for this dimension of the slice. */
1506 /* The byte stride for this dimension of the slice. */
1512 /* The dimensions of the resulting slice. */
1513 std::vector
<slice_dim
> slice_dims
;
1515 /* Process the incoming arguments. These arguments are in the reverse
1516 order to the array dimensions, that is the first argument refers to
1517 the last array dimension. */
1518 if (fortran_array_slicing_debug
)
1519 debug_printf ("Processing array access:\n");
1520 for (int i
= 0; i
< nargs
; ++i
)
1522 /* For each dimension of the array the user will have either provided
1523 a ranged access with optional lower bound, upper bound, and
1524 stride, or the user will have supplied a single index. */
1525 struct type
*dim_type
= dim_types
[ndimensions
- (i
+ 1)];
1526 fortran_range_operation
*range_op
1527 = dynamic_cast<fortran_range_operation
*> (ops
[i
].get ());
1528 if (range_op
!= nullptr)
1530 enum range_flag range_flag
= range_op
->get_flags ();
1532 LONGEST low
, high
, stride
;
1533 low
= high
= stride
= 0;
1535 if ((range_flag
& RANGE_LOW_BOUND_DEFAULT
) == 0)
1536 low
= value_as_long (range_op
->evaluate0 (exp
, noside
));
1538 low
= f77_get_lowerbound (dim_type
);
1539 if ((range_flag
& RANGE_HIGH_BOUND_DEFAULT
) == 0)
1540 high
= value_as_long (range_op
->evaluate1 (exp
, noside
));
1542 high
= f77_get_upperbound (dim_type
);
1543 if ((range_flag
& RANGE_HAS_STRIDE
) == RANGE_HAS_STRIDE
)
1544 stride
= value_as_long (range_op
->evaluate2 (exp
, noside
));
1549 error (_("stride must not be 0"));
1551 /* Get information about this dimension in the original ARRAY. */
1552 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
1553 struct type
*index_type
= dim_type
->index_type ();
1554 LONGEST lb
= f77_get_lowerbound (dim_type
);
1555 LONGEST ub
= f77_get_upperbound (dim_type
);
1556 LONGEST sd
= index_type
->bit_stride ();
1558 sd
= TYPE_LENGTH (target_type
) * 8;
1560 if (fortran_array_slicing_debug
)
1562 debug_printf ("|-> Range access\n");
1563 std::string str
= type_to_string (dim_type
);
1564 debug_printf ("| |-> Type: %s\n", str
.c_str ());
1565 debug_printf ("| |-> Array:\n");
1566 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
1567 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
1568 debug_printf ("| | |-> Bit stride: %s\n", plongest (sd
));
1569 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
/ 8));
1570 debug_printf ("| | |-> Type size: %s\n",
1571 pulongest (TYPE_LENGTH (dim_type
)));
1572 debug_printf ("| | '-> Target type size: %s\n",
1573 pulongest (TYPE_LENGTH (target_type
)));
1574 debug_printf ("| |-> Accessing:\n");
1575 debug_printf ("| | |-> Low bound: %s\n",
1577 debug_printf ("| | |-> High bound: %s\n",
1579 debug_printf ("| | '-> Element stride: %s\n",
1583 /* Check the user hasn't asked for something invalid. */
1584 if (high
> ub
|| low
< lb
)
1585 error (_("array subscript out of bounds"));
1587 /* Calculate what this dimension of the new slice array will look
1588 like. OFFSET is the byte offset from the start of the
1589 previous (more outer) dimension to the start of this
1590 dimension. E_COUNT is the number of elements in this
1591 dimension. REMAINDER is the number of elements remaining
1592 between the last included element and the upper bound. For
1593 example an access '1:6:2' will include elements 1, 3, 5 and
1594 have a remainder of 1 (element #6). */
1595 LONGEST lowest
= std::min (low
, high
);
1596 LONGEST offset
= (sd
/ 8) * (lowest
- lb
);
1597 LONGEST e_count
= std::abs (high
- low
) + 1;
1598 e_count
= (e_count
+ (std::abs (stride
) - 1)) / std::abs (stride
);
1599 LONGEST new_low
= 1;
1600 LONGEST new_high
= new_low
+ e_count
- 1;
1601 LONGEST new_stride
= (sd
* stride
) / 8;
1602 LONGEST last_elem
= low
+ ((e_count
- 1) * stride
);
1603 LONGEST remainder
= high
- last_elem
;
1606 offset
+= std::abs (remainder
) * TYPE_LENGTH (target_type
);
1608 error (_("incorrect stride and boundary combination"));
1610 else if (stride
< 0)
1611 error (_("incorrect stride and boundary combination"));
1613 /* Is the data within this dimension contiguous? It is if the
1614 newly computed stride is the same size as a single element of
1616 bool is_dim_contiguous
= (new_stride
== slice_element_size
);
1617 is_all_contiguous
&= is_dim_contiguous
;
1619 if (fortran_array_slicing_debug
)
1621 debug_printf ("| '-> Results:\n");
1622 debug_printf ("| |-> Offset = %s\n", plongest (offset
));
1623 debug_printf ("| |-> Elements = %s\n", plongest (e_count
));
1624 debug_printf ("| |-> Low bound = %s\n", plongest (new_low
));
1625 debug_printf ("| |-> High bound = %s\n",
1626 plongest (new_high
));
1627 debug_printf ("| |-> Byte stride = %s\n",
1628 plongest (new_stride
));
1629 debug_printf ("| |-> Last element = %s\n",
1630 plongest (last_elem
));
1631 debug_printf ("| |-> Remainder = %s\n",
1632 plongest (remainder
));
1633 debug_printf ("| '-> Contiguous = %s\n",
1634 (is_dim_contiguous
? "Yes" : "No"));
1637 /* Figure out how big (in bytes) an element of this dimension of
1638 the new array slice will be. */
1639 slice_element_size
= std::abs (new_stride
* e_count
);
1641 slice_dims
.emplace_back (new_low
, new_high
, new_stride
,
1644 /* Update the total offset. */
1645 total_offset
+= offset
;
1649 /* There is a single index for this dimension. */
1651 = value_as_long (ops
[i
]->evaluate_with_coercion (exp
, noside
));
1653 /* Get information about this dimension in the original ARRAY. */
1654 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
1655 struct type
*index_type
= dim_type
->index_type ();
1656 LONGEST lb
= f77_get_lowerbound (dim_type
);
1657 LONGEST ub
= f77_get_upperbound (dim_type
);
1658 LONGEST sd
= index_type
->bit_stride () / 8;
1660 sd
= TYPE_LENGTH (target_type
);
1662 if (fortran_array_slicing_debug
)
1664 debug_printf ("|-> Index access\n");
1665 std::string str
= type_to_string (dim_type
);
1666 debug_printf ("| |-> Type: %s\n", str
.c_str ());
1667 debug_printf ("| |-> Array:\n");
1668 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
1669 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
1670 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
));
1671 debug_printf ("| | |-> Type size: %s\n",
1672 pulongest (TYPE_LENGTH (dim_type
)));
1673 debug_printf ("| | '-> Target type size: %s\n",
1674 pulongest (TYPE_LENGTH (target_type
)));
1675 debug_printf ("| '-> Accessing:\n");
1676 debug_printf ("| '-> Index: %s\n",
1680 /* If the array has actual content then check the index is in
1681 bounds. An array without content (an unbound array) doesn't
1682 have a known upper bound, so don't error check in that
1685 || (dim_type
->index_type ()->bounds ()->high
.kind () != PROP_UNDEFINED
1687 || (VALUE_LVAL (array
) != lval_memory
1688 && dim_type
->index_type ()->bounds ()->high
.kind () == PROP_UNDEFINED
))
1690 if (type_not_associated (dim_type
))
1691 error (_("no such vector element (vector not associated)"));
1692 else if (type_not_allocated (dim_type
))
1693 error (_("no such vector element (vector not allocated)"));
1695 error (_("no such vector element"));
1698 /* Calculate using the type stride, not the target type size. */
1699 LONGEST offset
= sd
* (index
- lb
);
1700 total_offset
+= offset
;
1704 /* Build a type that represents the new array slice in the target memory
1705 of the original ARRAY, this type makes use of strides to correctly
1706 find only those elements that are part of the new slice. */
1707 struct type
*array_slice_type
= inner_element_type
;
1708 for (const auto &d
: slice_dims
)
1710 /* Create the range. */
1711 dynamic_prop p_low
, p_high
, p_stride
;
1713 p_low
.set_const_val (d
.low
);
1714 p_high
.set_const_val (d
.high
);
1715 p_stride
.set_const_val (d
.stride
);
1717 struct type
*new_range
1718 = create_range_type_with_stride ((struct type
*) NULL
,
1719 TYPE_TARGET_TYPE (d
.index
),
1720 &p_low
, &p_high
, 0, &p_stride
,
1723 = create_array_type (nullptr, array_slice_type
, new_range
);
1726 if (fortran_array_slicing_debug
)
1728 debug_printf ("'-> Final result:\n");
1729 debug_printf (" |-> Type: %s\n",
1730 type_to_string (array_slice_type
).c_str ());
1731 debug_printf (" |-> Total offset: %s\n",
1732 plongest (total_offset
));
1733 debug_printf (" |-> Base address: %s\n",
1734 core_addr_to_string (value_address (array
)));
1735 debug_printf (" '-> Contiguous = %s\n",
1736 (is_all_contiguous
? "Yes" : "No"));
1739 /* Should we repack this array slice? */
1740 if (!is_all_contiguous
&& (repack_array_slices
|| is_string_p
))
1742 /* Build a type for the repacked slice. */
1743 struct type
*repacked_array_type
= inner_element_type
;
1744 for (const auto &d
: slice_dims
)
1746 /* Create the range. */
1747 dynamic_prop p_low
, p_high
, p_stride
;
1749 p_low
.set_const_val (d
.low
);
1750 p_high
.set_const_val (d
.high
);
1751 p_stride
.set_const_val (TYPE_LENGTH (repacked_array_type
));
1753 struct type
*new_range
1754 = create_range_type_with_stride ((struct type
*) NULL
,
1755 TYPE_TARGET_TYPE (d
.index
),
1756 &p_low
, &p_high
, 0, &p_stride
,
1759 = create_array_type (nullptr, repacked_array_type
, new_range
);
1762 /* Now copy the elements from the original ARRAY into the packed
1763 array value DEST. */
1764 struct value
*dest
= allocate_value (repacked_array_type
);
1765 if (value_lazy (array
)
1766 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
1767 > TYPE_LENGTH (check_typedef (value_type (array
)))))
1769 fortran_array_walker
<fortran_lazy_array_repacker_impl
> p
1770 (array_slice_type
, value_address (array
) + total_offset
, dest
);
1775 fortran_array_walker
<fortran_array_repacker_impl
> p
1776 (array_slice_type
, value_address (array
) + total_offset
,
1777 total_offset
, array
, dest
);
1784 if (VALUE_LVAL (array
) == lval_memory
)
1786 /* If the value we're taking a slice from is not yet loaded, or
1787 the requested slice is outside the values content range then
1788 just create a new lazy value pointing at the memory where the
1789 contents we're looking for exist. */
1790 if (value_lazy (array
)
1791 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
1792 > TYPE_LENGTH (check_typedef (value_type (array
)))))
1793 array
= value_at_lazy (array_slice_type
,
1794 value_address (array
) + total_offset
);
1796 array
= value_from_contents_and_address (array_slice_type
,
1797 (value_contents (array
)
1799 (value_address (array
)
1802 else if (!value_lazy (array
))
1803 array
= value_from_component (array
, array_slice_type
, total_offset
);
1805 error (_("cannot subscript arrays that are not in memory"));
1812 fortran_undetermined::evaluate (struct type
*expect_type
,
1813 struct expression
*exp
,
1816 value
*callee
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
, noside
);
1817 struct type
*type
= check_typedef (value_type (callee
));
1818 enum type_code code
= type
->code ();
1820 if (code
== TYPE_CODE_PTR
)
1822 /* Fortran always passes variable to subroutines as pointer.
1823 So we need to look into its target type to see if it is
1824 array, string or function. If it is, we need to switch
1825 to the target value the original one points to. */
1826 struct type
*target_type
= check_typedef (TYPE_TARGET_TYPE (type
));
1828 if (target_type
->code () == TYPE_CODE_ARRAY
1829 || target_type
->code () == TYPE_CODE_STRING
1830 || target_type
->code () == TYPE_CODE_FUNC
)
1832 callee
= value_ind (callee
);
1833 type
= check_typedef (value_type (callee
));
1834 code
= type
->code ();
1840 case TYPE_CODE_ARRAY
:
1841 case TYPE_CODE_STRING
:
1842 return value_subarray (callee
, exp
, noside
);
1845 case TYPE_CODE_FUNC
:
1846 case TYPE_CODE_INTERNAL_FUNCTION
:
1848 /* It's a function call. Allocate arg vector, including
1849 space for the function to be called in argvec[0] and a
1850 termination NULL. */
1851 const std::vector
<operation_up
> &actual (std::get
<1> (m_storage
));
1852 std::vector
<value
*> argvec (actual
.size ());
1853 bool is_internal_func
= (code
== TYPE_CODE_INTERNAL_FUNCTION
);
1854 for (int tem
= 0; tem
< argvec
.size (); tem
++)
1855 argvec
[tem
] = fortran_prepare_argument (exp
, actual
[tem
].get (),
1856 tem
, is_internal_func
,
1857 value_type (callee
),
1859 return evaluate_subexp_do_call (exp
, noside
, callee
, argvec
,
1860 nullptr, expect_type
);
1864 error (_("Cannot perform substring on this type"));
1868 } /* namespace expr */
1870 /* Special expression lengths for Fortran. */
1873 operator_length_f (const struct expression
*exp
, int pc
, int *oplenp
,
1879 switch (exp
->elts
[pc
- 1].opcode
)
1882 operator_length_standard (exp
, pc
, oplenp
, argsp
);
1885 case UNOP_FORTRAN_KIND
:
1886 case UNOP_FORTRAN_FLOOR
:
1887 case UNOP_FORTRAN_CEILING
:
1888 case UNOP_FORTRAN_ALLOCATED
:
1893 case BINOP_FORTRAN_CMPLX
:
1894 case BINOP_FORTRAN_MODULO
:
1899 case FORTRAN_ASSOCIATED
:
1900 case FORTRAN_LBOUND
:
1901 case FORTRAN_UBOUND
:
1903 args
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
1906 case OP_F77_UNDETERMINED_ARGLIST
:
1908 args
= 1 + longest_to_int (exp
->elts
[pc
- 2].longconst
);
1916 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1917 the extra argument NAME which is the text that should be printed as the
1918 name of this operation. */
1921 print_unop_subexp_f (struct expression
*exp
, int *pos
,
1922 struct ui_file
*stream
, enum precedence prec
,
1926 fprintf_filtered (stream
, "%s(", name
);
1927 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1928 fputs_filtered (")", stream
);
1931 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1932 the extra argument NAME which is the text that should be printed as the
1933 name of this operation. */
1936 print_binop_subexp_f (struct expression
*exp
, int *pos
,
1937 struct ui_file
*stream
, enum precedence prec
,
1941 fprintf_filtered (stream
, "%s(", name
);
1942 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1943 fputs_filtered (",", stream
);
1944 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1945 fputs_filtered (")", stream
);
1948 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1949 the extra argument NAME which is the text that should be printed as the
1950 name of this operation. */
1953 print_unop_or_binop_subexp_f (struct expression
*exp
, int *pos
,
1954 struct ui_file
*stream
, enum precedence prec
,
1957 unsigned nargs
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
);
1959 fprintf_filtered (stream
, "%s (", name
);
1960 for (unsigned tem
= 0; tem
< nargs
; tem
++)
1963 fputs_filtered (", ", stream
);
1964 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
1966 fputs_filtered (")", stream
);
1969 /* Special expression printing for Fortran. */
1972 print_subexp_f (struct expression
*exp
, int *pos
,
1973 struct ui_file
*stream
, enum precedence prec
)
1976 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
1981 print_subexp_standard (exp
, pos
, stream
, prec
);
1984 case UNOP_FORTRAN_KIND
:
1985 print_unop_subexp_f (exp
, pos
, stream
, prec
, "KIND");
1988 case UNOP_FORTRAN_FLOOR
:
1989 print_unop_subexp_f (exp
, pos
, stream
, prec
, "FLOOR");
1992 case UNOP_FORTRAN_CEILING
:
1993 print_unop_subexp_f (exp
, pos
, stream
, prec
, "CEILING");
1996 case UNOP_FORTRAN_ALLOCATED
:
1997 print_unop_subexp_f (exp
, pos
, stream
, prec
, "ALLOCATED");
2000 case BINOP_FORTRAN_CMPLX
:
2001 print_binop_subexp_f (exp
, pos
, stream
, prec
, "CMPLX");
2004 case BINOP_FORTRAN_MODULO
:
2005 print_binop_subexp_f (exp
, pos
, stream
, prec
, "MODULO");
2008 case FORTRAN_ASSOCIATED
:
2009 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "ASSOCIATED");
2012 case FORTRAN_LBOUND
:
2013 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "LBOUND");
2016 case FORTRAN_UBOUND
:
2017 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "UBOUND");
2020 case OP_F77_UNDETERMINED_ARGLIST
:
2022 print_subexp_funcall (exp
, pos
, stream
);
2027 /* Special expression dumping for Fortran. */
2030 dump_subexp_body_f (struct expression
*exp
,
2031 struct ui_file
*stream
, int elt
)
2033 int opcode
= exp
->elts
[elt
].opcode
;
2034 int oplen
, nargs
, i
;
2039 return dump_subexp_body_standard (exp
, stream
, elt
);
2041 case UNOP_FORTRAN_KIND
:
2042 case UNOP_FORTRAN_FLOOR
:
2043 case UNOP_FORTRAN_CEILING
:
2044 case UNOP_FORTRAN_ALLOCATED
:
2045 case BINOP_FORTRAN_CMPLX
:
2046 case BINOP_FORTRAN_MODULO
:
2047 operator_length_f (exp
, (elt
+ 1), &oplen
, &nargs
);
2050 case FORTRAN_ASSOCIATED
:
2051 case FORTRAN_LBOUND
:
2052 case FORTRAN_UBOUND
:
2053 operator_length_f (exp
, (elt
+ 3), &oplen
, &nargs
);
2056 case OP_F77_UNDETERMINED_ARGLIST
:
2057 return dump_subexp_body_funcall (exp
, stream
, elt
+ 1);
2061 for (i
= 0; i
< nargs
; i
+= 1)
2062 elt
= dump_subexp (exp
, stream
, elt
);
2067 /* Special expression checking for Fortran. */
2070 operator_check_f (struct expression
*exp
, int pos
,
2071 int (*objfile_func
) (struct objfile
*objfile
,
2075 const union exp_element
*const elts
= exp
->elts
;
2077 switch (elts
[pos
].opcode
)
2079 case UNOP_FORTRAN_KIND
:
2080 case UNOP_FORTRAN_FLOOR
:
2081 case UNOP_FORTRAN_CEILING
:
2082 case UNOP_FORTRAN_ALLOCATED
:
2083 case BINOP_FORTRAN_CMPLX
:
2084 case BINOP_FORTRAN_MODULO
:
2085 case FORTRAN_ASSOCIATED
:
2086 case FORTRAN_LBOUND
:
2087 case FORTRAN_UBOUND
:
2088 /* Any references to objfiles are held in the arguments to this
2089 expression, not within the expression itself, so no additional
2090 checking is required here, the outer expression iteration code
2091 will take care of checking each argument. */
2095 return operator_check_standard (exp
, pos
, objfile_func
, data
);
2101 /* Expression processing for Fortran. */
2102 const struct exp_descriptor
f_language::exp_descriptor_tab
=
2111 /* See language.h. */
2114 f_language::language_arch_info (struct gdbarch
*gdbarch
,
2115 struct language_arch_info
*lai
) const
2117 const struct builtin_f_type
*builtin
= builtin_f_type (gdbarch
);
2119 /* Helper function to allow shorter lines below. */
2120 auto add
= [&] (struct type
* t
)
2122 lai
->add_primitive_type (t
);
2125 add (builtin
->builtin_character
);
2126 add (builtin
->builtin_logical
);
2127 add (builtin
->builtin_logical_s1
);
2128 add (builtin
->builtin_logical_s2
);
2129 add (builtin
->builtin_logical_s8
);
2130 add (builtin
->builtin_real
);
2131 add (builtin
->builtin_real_s8
);
2132 add (builtin
->builtin_real_s16
);
2133 add (builtin
->builtin_complex_s8
);
2134 add (builtin
->builtin_complex_s16
);
2135 add (builtin
->builtin_void
);
2137 lai
->set_string_char_type (builtin
->builtin_character
);
2138 lai
->set_bool_type (builtin
->builtin_logical_s2
, "logical");
2141 /* See language.h. */
2144 f_language::search_name_hash (const char *name
) const
2146 return cp_search_name_hash (name
);
2149 /* See language.h. */
2152 f_language::lookup_symbol_nonlocal (const char *name
,
2153 const struct block
*block
,
2154 const domain_enum domain
) const
2156 return cp_lookup_symbol_nonlocal (this, name
, block
, domain
);
2159 /* See language.h. */
2161 symbol_name_matcher_ftype
*
2162 f_language::get_symbol_name_matcher_inner
2163 (const lookup_name_info
&lookup_name
) const
2165 return cp_get_symbol_name_matcher (lookup_name
);
2168 /* Single instance of the Fortran language class. */
2170 static f_language f_language_defn
;
2173 build_fortran_types (struct gdbarch
*gdbarch
)
2175 struct builtin_f_type
*builtin_f_type
2176 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_f_type
);
2178 builtin_f_type
->builtin_void
2179 = arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
, "void");
2181 builtin_f_type
->builtin_character
2182 = arch_type (gdbarch
, TYPE_CODE_CHAR
, TARGET_CHAR_BIT
, "character");
2184 builtin_f_type
->builtin_logical_s1
2185 = arch_boolean_type (gdbarch
, TARGET_CHAR_BIT
, 1, "logical*1");
2187 builtin_f_type
->builtin_integer_s2
2188 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
), 0,
2191 builtin_f_type
->builtin_integer_s8
2192 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 0,
2195 builtin_f_type
->builtin_logical_s2
2196 = arch_boolean_type (gdbarch
, gdbarch_short_bit (gdbarch
), 1,
2199 builtin_f_type
->builtin_logical_s8
2200 = arch_boolean_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 1,
2203 builtin_f_type
->builtin_integer
2204 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 0,
2207 builtin_f_type
->builtin_logical
2208 = arch_boolean_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1,
2211 builtin_f_type
->builtin_real
2212 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
2213 "real", gdbarch_float_format (gdbarch
));
2214 builtin_f_type
->builtin_real_s8
2215 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
2216 "real*8", gdbarch_double_format (gdbarch
));
2217 auto fmt
= gdbarch_floatformat_for_type (gdbarch
, "real(kind=16)", 128);
2219 builtin_f_type
->builtin_real_s16
2220 = arch_float_type (gdbarch
, 128, "real*16", fmt
);
2221 else if (gdbarch_long_double_bit (gdbarch
) == 128)
2222 builtin_f_type
->builtin_real_s16
2223 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
2224 "real*16", gdbarch_long_double_format (gdbarch
));
2226 builtin_f_type
->builtin_real_s16
2227 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 128, "real*16");
2229 builtin_f_type
->builtin_complex_s8
2230 = init_complex_type ("complex*8", builtin_f_type
->builtin_real
);
2231 builtin_f_type
->builtin_complex_s16
2232 = init_complex_type ("complex*16", builtin_f_type
->builtin_real_s8
);
2234 if (builtin_f_type
->builtin_real_s16
->code () == TYPE_CODE_ERROR
)
2235 builtin_f_type
->builtin_complex_s32
2236 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 256, "complex*32");
2238 builtin_f_type
->builtin_complex_s32
2239 = init_complex_type ("complex*32", builtin_f_type
->builtin_real_s16
);
2241 return builtin_f_type
;
2244 static struct gdbarch_data
*f_type_data
;
2246 const struct builtin_f_type
*
2247 builtin_f_type (struct gdbarch
*gdbarch
)
2249 return (const struct builtin_f_type
*) gdbarch_data (gdbarch
, f_type_data
);
2252 /* Command-list for the "set/show fortran" prefix command. */
2253 static struct cmd_list_element
*set_fortran_list
;
2254 static struct cmd_list_element
*show_fortran_list
;
2256 void _initialize_f_language ();
2258 _initialize_f_language ()
2260 f_type_data
= gdbarch_data_register_post_init (build_fortran_types
);
2262 add_basic_prefix_cmd ("fortran", no_class
,
2263 _("Prefix command for changing Fortran-specific settings."),
2264 &set_fortran_list
, "set fortran ", 0, &setlist
);
2266 add_show_prefix_cmd ("fortran", no_class
,
2267 _("Generic command for showing Fortran-specific settings."),
2268 &show_fortran_list
, "show fortran ", 0, &showlist
);
2270 add_setshow_boolean_cmd ("repack-array-slices", class_vars
,
2271 &repack_array_slices
, _("\
2272 Enable or disable repacking of non-contiguous array slices."), _("\
2273 Show whether non-contiguous array slices are repacked."), _("\
2274 When the user requests a slice of a Fortran array then we can either return\n\
2275 a descriptor that describes the array in place (using the original array data\n\
2276 in its existing location) or the original data can be repacked (copied) to a\n\
2279 When the content of the array slice is contiguous within the original array\n\
2280 then the result will never be repacked, but when the data for the new array\n\
2281 is non-contiguous within the original array repacking will only be performed\n\
2282 when this setting is on."),
2284 show_repack_array_slices
,
2285 &set_fortran_list
, &show_fortran_list
);
2287 /* Debug Fortran's array slicing logic. */
2288 add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance
,
2289 &fortran_array_slicing_debug
, _("\
2290 Set debugging of Fortran array slicing."), _("\
2291 Show debugging of Fortran array slicing."), _("\
2292 When on, debugging of Fortran array slicing is enabled."),
2294 show_fortran_array_slicing_debug
,
2295 &setdebuglist
, &showdebuglist
);
2298 /* Ensures that function argument VALUE is in the appropriate form to
2299 pass to a Fortran function. Returns a possibly new value that should
2300 be used instead of VALUE.
2302 When IS_ARTIFICIAL is true this indicates an artificial argument,
2303 e.g. hidden string lengths which the GNU Fortran argument passing
2304 convention specifies as being passed by value.
2306 When IS_ARTIFICIAL is false, the argument is passed by pointer. If the
2307 value is already in target memory then return a value that is a pointer
2308 to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate
2309 space in the target, copy VALUE in, and return a pointer to the in
2312 static struct value
*
2313 fortran_argument_convert (struct value
*value
, bool is_artificial
)
2317 /* If the value is not in the inferior e.g. registers values,
2318 convenience variables and user input. */
2319 if (VALUE_LVAL (value
) != lval_memory
)
2321 struct type
*type
= value_type (value
);
2322 const int length
= TYPE_LENGTH (type
);
2323 const CORE_ADDR addr
2324 = value_as_long (value_allocate_space_in_inferior (length
));
2325 write_memory (addr
, value_contents (value
), length
);
2327 = value_from_contents_and_address (type
, value_contents (value
),
2329 return value_addr (val
);
2332 return value_addr (value
); /* Program variables, e.g. arrays. */
2337 /* Prepare (and return) an argument value ready for an inferior function
2338 call to a Fortran function. EXP and POS are the expressions describing
2339 the argument to prepare. ARG_NUM is the argument number being
2340 prepared, with 0 being the first argument and so on. FUNC_TYPE is the
2341 type of the function being called.
2343 IS_INTERNAL_CALL_P is true if this is a call to a function of type
2344 TYPE_CODE_INTERNAL_FUNCTION, otherwise this parameter is false.
2346 NOSIDE has its usual meaning for expression parsing (see eval.c).
2348 Arguments in Fortran are normally passed by address, we coerce the
2349 arguments here rather than in value_arg_coerce as otherwise the call to
2350 malloc (to place the non-lvalue parameters in target memory) is hit by
2351 this Fortran specific logic. This results in malloc being called with a
2352 pointer to an integer followed by an attempt to malloc the arguments to
2353 malloc in target memory. Infinite recursion ensues. */
2356 fortran_prepare_argument (struct expression
*exp
, int *pos
,
2357 int arg_num
, bool is_internal_call_p
,
2358 struct type
*func_type
, enum noside noside
)
2360 if (is_internal_call_p
)
2361 return evaluate_subexp_with_coercion (exp
, pos
, noside
);
2363 bool is_artificial
= ((arg_num
>= func_type
->num_fields ())
2365 : TYPE_FIELD_ARTIFICIAL (func_type
, arg_num
));
2367 /* If this is an artificial argument, then either, this is an argument
2368 beyond the end of the known arguments, or possibly, there are no known
2369 arguments (maybe missing debug info).
2371 For these artificial arguments, if the user has prefixed it with '&'
2372 (for address-of), then lets always allow this to succeed, even if the
2373 argument is not actually in inferior memory. This will allow the user
2374 to pass arguments to a Fortran function even when there's no debug
2377 As we already pass the address of non-artificial arguments, all we
2378 need to do if skip the UNOP_ADDR operator in the expression and mark
2379 the argument as non-artificial. */
2380 if (is_artificial
&& exp
->elts
[*pos
].opcode
== UNOP_ADDR
)
2383 is_artificial
= false;
2386 struct value
*arg_val
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
2387 return fortran_argument_convert (arg_val
, is_artificial
);
2390 /* Prepare (and return) an argument value ready for an inferior function
2391 call to a Fortran function. EXP and POS are the expressions describing
2392 the argument to prepare. ARG_NUM is the argument number being
2393 prepared, with 0 being the first argument and so on. FUNC_TYPE is the
2394 type of the function being called.
2396 IS_INTERNAL_CALL_P is true if this is a call to a function of type
2397 TYPE_CODE_INTERNAL_FUNCTION, otherwise this parameter is false.
2399 NOSIDE has its usual meaning for expression parsing (see eval.c).
2401 Arguments in Fortran are normally passed by address, we coerce the
2402 arguments here rather than in value_arg_coerce as otherwise the call to
2403 malloc (to place the non-lvalue parameters in target memory) is hit by
2404 this Fortran specific logic. This results in malloc being called with a
2405 pointer to an integer followed by an attempt to malloc the arguments to
2406 malloc in target memory. Infinite recursion ensues. */
2409 fortran_prepare_argument (struct expression
*exp
,
2410 expr::operation
*subexp
,
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 subexp
->evaluate_with_coercion (exp
, 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. */
2436 expr::unop_addr_operation
*addrop
2437 = dynamic_cast<expr::unop_addr_operation
*> (subexp
);
2438 if (addrop
!= nullptr)
2440 subexp
= addrop
->get_expression ().get ();
2441 is_artificial
= false;
2445 struct value
*arg_val
= subexp
->evaluate_with_coercion (exp
, noside
);
2446 return fortran_argument_convert (arg_val
, is_artificial
);
2452 fortran_preserve_arg_pointer (struct value
*arg
, struct type
*type
)
2454 if (value_type (arg
)->code () == TYPE_CODE_PTR
)
2455 return value_type (arg
);
2462 fortran_adjust_dynamic_array_base_address_hack (struct type
*type
,
2465 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
2467 /* We can't adjust the base address for arrays that have no content. */
2468 if (type_not_allocated (type
) || type_not_associated (type
))
2471 int ndimensions
= calc_f77_array_dims (type
);
2472 LONGEST total_offset
= 0;
2474 /* Walk through each of the dimensions of this array type and figure out
2475 if any of the dimensions are "backwards", that is the base address
2476 for this dimension points to the element at the highest memory
2477 address and the stride is negative. */
2478 struct type
*tmp_type
= type
;
2479 for (int i
= 0 ; i
< ndimensions
; ++i
)
2481 /* Grab the range for this dimension and extract the lower and upper
2483 tmp_type
= check_typedef (tmp_type
);
2484 struct type
*range_type
= tmp_type
->index_type ();
2485 LONGEST lowerbound
, upperbound
, stride
;
2486 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
2487 error ("failed to get range bounds");
2489 /* Figure out the stride for this dimension. */
2490 struct type
*elt_type
= check_typedef (TYPE_TARGET_TYPE (tmp_type
));
2491 stride
= tmp_type
->index_type ()->bounds ()->bit_stride ();
2493 stride
= type_length_units (elt_type
);
2497 = gdbarch_addressable_memory_unit_size (elt_type
->arch ());
2498 stride
/= (unit_size
* 8);
2501 /* If this dimension is "backward" then figure out the offset
2502 adjustment required to point to the element at the lowest memory
2503 address, and add this to the total offset. */
2505 if (stride
< 0 && lowerbound
< upperbound
)
2506 offset
= (upperbound
- lowerbound
) * stride
;
2507 total_offset
+= offset
;
2508 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
2511 /* Adjust the address of this object and return it. */
2512 address
+= total_offset
;