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
,
77 /* Return the encoding that should be used for the character type
81 f_language::get_encoding (struct type
*type
)
85 switch (TYPE_LENGTH (type
))
88 encoding
= target_charset (type
->arch ());
91 if (type_byte_order (type
) == BFD_ENDIAN_BIG
)
92 encoding
= "UTF-32BE";
94 encoding
= "UTF-32LE";
98 error (_("unrecognized character type"));
106 /* Table of operators and their precedences for printing expressions. */
108 const struct op_print
f_language::op_print_tab
[] =
110 {"+", BINOP_ADD
, PREC_ADD
, 0},
111 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
112 {"-", BINOP_SUB
, PREC_ADD
, 0},
113 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
114 {"*", BINOP_MUL
, PREC_MUL
, 0},
115 {"/", BINOP_DIV
, PREC_MUL
, 0},
116 {"DIV", BINOP_INTDIV
, PREC_MUL
, 0},
117 {"MOD", BINOP_REM
, PREC_MUL
, 0},
118 {"=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
119 {".OR.", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
120 {".AND.", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
121 {".NOT.", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
122 {".EQ.", BINOP_EQUAL
, PREC_EQUAL
, 0},
123 {".NE.", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
124 {".LE.", BINOP_LEQ
, PREC_ORDER
, 0},
125 {".GE.", BINOP_GEQ
, PREC_ORDER
, 0},
126 {".GT.", BINOP_GTR
, PREC_ORDER
, 0},
127 {".LT.", BINOP_LESS
, PREC_ORDER
, 0},
128 {"**", UNOP_IND
, PREC_PREFIX
, 0},
129 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
130 {NULL
, OP_NULL
, PREC_REPEAT
, 0}
134 /* A helper function for the "bound" intrinsics that checks that TYPE
135 is an array. LBOUND_P is true for lower bound; this is used for
136 the error message, if any. */
139 fortran_require_array (struct type
*type
, bool lbound_p
)
141 type
= check_typedef (type
);
142 if (type
->code () != TYPE_CODE_ARRAY
)
145 error (_("LBOUND can only be applied to arrays"));
147 error (_("UBOUND can only be applied to arrays"));
151 /* Create an array containing the lower bounds (when LBOUND_P is true) or
152 the upper bounds (when LBOUND_P is false) of ARRAY (which must be of
153 array type). GDBARCH is the current architecture. */
155 static struct value
*
156 fortran_bounds_all_dims (bool lbound_p
,
157 struct gdbarch
*gdbarch
,
160 type
*array_type
= check_typedef (value_type (array
));
161 int ndimensions
= calc_f77_array_dims (array_type
);
163 /* Allocate a result value of the correct type. */
165 = create_static_range_type (nullptr,
166 builtin_type (gdbarch
)->builtin_int
,
168 struct type
*elm_type
= builtin_type (gdbarch
)->builtin_long_long
;
169 struct type
*result_type
= create_array_type (nullptr, elm_type
, range
);
170 struct value
*result
= allocate_value (result_type
);
172 /* Walk the array dimensions backwards due to the way the array will be
173 laid out in memory, the first dimension will be the most inner. */
174 LONGEST elm_len
= TYPE_LENGTH (elm_type
);
175 for (LONGEST dst_offset
= elm_len
* (ndimensions
- 1);
177 dst_offset
-= elm_len
)
181 /* Grab the required bound. */
183 b
= f77_get_lowerbound (array_type
);
185 b
= f77_get_upperbound (array_type
);
187 /* And copy the value into the result value. */
188 struct value
*v
= value_from_longest (elm_type
, b
);
189 gdb_assert (dst_offset
+ TYPE_LENGTH (value_type (v
))
190 <= TYPE_LENGTH (value_type (result
)));
191 gdb_assert (TYPE_LENGTH (value_type (v
)) == elm_len
);
192 value_contents_copy (result
, dst_offset
, v
, 0, elm_len
);
194 /* Peel another dimension of the array. */
195 array_type
= TYPE_TARGET_TYPE (array_type
);
201 /* Return the lower bound (when LBOUND_P is true) or the upper bound (when
202 LBOUND_P is false) for dimension DIM_VAL (which must be an integer) of
203 ARRAY (which must be an array). GDBARCH is the current architecture. */
205 static struct value
*
206 fortran_bounds_for_dimension (bool lbound_p
,
207 struct gdbarch
*gdbarch
,
209 struct value
*dim_val
)
211 /* Check the requested dimension is valid for this array. */
212 type
*array_type
= check_typedef (value_type (array
));
213 int ndimensions
= calc_f77_array_dims (array_type
);
214 long dim
= value_as_long (dim_val
);
215 if (dim
< 1 || dim
> ndimensions
)
218 error (_("LBOUND dimension must be from 1 to %d"), ndimensions
);
220 error (_("UBOUND dimension must be from 1 to %d"), ndimensions
);
223 /* The type for the result. */
224 struct type
*bound_type
= builtin_type (gdbarch
)->builtin_long_long
;
226 /* Walk the dimensions backwards, due to the ordering in which arrays are
227 laid out the first dimension is the most inner. */
228 for (int i
= ndimensions
- 1; i
>= 0; --i
)
230 /* If this is the requested dimension then we're done. Grab the
231 bounds and return. */
237 b
= f77_get_lowerbound (array_type
);
239 b
= f77_get_upperbound (array_type
);
241 return value_from_longest (bound_type
, b
);
244 /* Peel off another dimension of the array. */
245 array_type
= TYPE_TARGET_TYPE (array_type
);
248 gdb_assert_not_reached ("failed to find matching dimension");
252 /* Return the number of dimensions for a Fortran array or string. */
255 calc_f77_array_dims (struct type
*array_type
)
258 struct type
*tmp_type
;
260 if ((array_type
->code () == TYPE_CODE_STRING
))
263 if ((array_type
->code () != TYPE_CODE_ARRAY
))
264 error (_("Can't get dimensions for a non-array type"));
266 tmp_type
= array_type
;
268 while ((tmp_type
= TYPE_TARGET_TYPE (tmp_type
)))
270 if (tmp_type
->code () == TYPE_CODE_ARRAY
)
276 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
277 slices. This is a base class for two alternative repacking mechanisms,
278 one for when repacking from a lazy value, and one for repacking from a
279 non-lazy (already loaded) value. */
280 class fortran_array_repacker_base_impl
281 : public fortran_array_walker_base_impl
284 /* Constructor, DEST is the value we are repacking into. */
285 fortran_array_repacker_base_impl (struct value
*dest
)
290 /* When we start processing the inner most dimension, this is where we
291 will be creating values for each element as we load them and then copy
292 them into the M_DEST value. Set a value mark so we can free these
294 void start_dimension (bool inner_p
)
298 gdb_assert (m_mark
== nullptr);
299 m_mark
= value_mark ();
303 /* When we finish processing the inner most dimension free all temporary
304 value that were created. */
305 void finish_dimension (bool inner_p
, bool last_p
)
309 gdb_assert (m_mark
!= nullptr);
310 value_free_to_mark (m_mark
);
316 /* Copy the contents of array element ELT into M_DEST at the next
318 void copy_element_to_dest (struct value
*elt
)
320 value_contents_copy (m_dest
, m_dest_offset
, elt
, 0,
321 TYPE_LENGTH (value_type (elt
)));
322 m_dest_offset
+= TYPE_LENGTH (value_type (elt
));
325 /* The value being written to. */
326 struct value
*m_dest
;
328 /* The byte offset in M_DEST at which the next element should be
330 LONGEST m_dest_offset
;
332 /* Set with a call to VALUE_MARK, and then reset after calling
333 VALUE_FREE_TO_MARK. */
334 struct value
*m_mark
= nullptr;
337 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
338 slices. This class is specialised for repacking an array slice from a
339 lazy array value, as such it does not require the parent array value to
340 be loaded into GDB's memory; the parent value could be huge, while the
341 slice could be tiny. */
342 class fortran_lazy_array_repacker_impl
343 : public fortran_array_repacker_base_impl
346 /* Constructor. TYPE is the type of the slice being loaded from the
347 parent value, so this type will correctly reflect the strides required
348 to find all of the elements from the parent value. ADDRESS is the
349 address in target memory of value matching TYPE, and DEST is the value
350 we are repacking into. */
351 explicit fortran_lazy_array_repacker_impl (struct type
*type
,
354 : fortran_array_repacker_base_impl (dest
),
358 /* Create a lazy value in target memory representing a single element,
359 then load the element into GDB's memory and copy the contents into the
360 destination value. */
361 void process_element (struct type
*elt_type
, LONGEST elt_off
, bool last_p
)
363 copy_element_to_dest (value_at_lazy (elt_type
, m_addr
+ elt_off
));
367 /* The address in target memory where the parent value starts. */
371 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
372 slices. This class is specialised for repacking an array slice from a
373 previously loaded (non-lazy) array value, as such it fetches the
374 element values from the contents of the parent value. */
375 class fortran_array_repacker_impl
376 : public fortran_array_repacker_base_impl
379 /* Constructor. TYPE is the type for the array slice within the parent
380 value, as such it has stride values as required to find the elements
381 within the original parent value. ADDRESS is the address in target
382 memory of the value matching TYPE. BASE_OFFSET is the offset from
383 the start of VAL's content buffer to the start of the object of TYPE,
384 VAL is the parent object from which we are loading the value, and
385 DEST is the value into which we are repacking. */
386 explicit fortran_array_repacker_impl (struct type
*type
, CORE_ADDR address
,
388 struct value
*val
, struct value
*dest
)
389 : fortran_array_repacker_base_impl (dest
),
390 m_base_offset (base_offset
),
393 gdb_assert (!value_lazy (val
));
396 /* Extract an element of ELT_TYPE at offset (M_BASE_OFFSET + ELT_OFF)
397 from the content buffer of M_VAL then copy this extracted value into
398 the repacked destination value. */
399 void process_element (struct type
*elt_type
, LONGEST elt_off
, bool last_p
)
402 = value_from_component (m_val
, elt_type
, (elt_off
+ m_base_offset
));
403 copy_element_to_dest (elt
);
407 /* The offset into the content buffer of M_VAL to the start of the slice
409 LONGEST m_base_offset
;
411 /* The parent value from which we are extracting a slice. */
415 /* Called from evaluate_subexp_standard to perform array indexing, and
416 sub-range extraction, for Fortran. As well as arrays this function
417 also handles strings as they can be treated like arrays of characters.
418 ARRAY is the array or string being accessed. EXP, POS, and NOSIDE are
419 as for evaluate_subexp_standard, and NARGS is the number of arguments
420 in this access (e.g. 'array (1,2,3)' would be NARGS 3). */
422 static struct value
*
423 fortran_value_subarray (struct value
*array
, struct expression
*exp
,
424 int *pos
, int nargs
, enum noside noside
)
426 type
*original_array_type
= check_typedef (value_type (array
));
427 bool is_string_p
= original_array_type
->code () == TYPE_CODE_STRING
;
429 /* Perform checks for ARRAY not being available. The somewhat overly
430 complex logic here is just to keep backward compatibility with the
431 errors that we used to get before FORTRAN_VALUE_SUBARRAY was
432 rewritten. Maybe a future task would streamline the error messages we
433 get here, and update all the expected test results. */
434 if (exp
->elts
[*pos
].opcode
!= OP_RANGE
)
436 if (type_not_associated (original_array_type
))
437 error (_("no such vector element (vector not associated)"));
438 else if (type_not_allocated (original_array_type
))
439 error (_("no such vector element (vector not allocated)"));
443 if (type_not_associated (original_array_type
))
444 error (_("array not associated"));
445 else if (type_not_allocated (original_array_type
))
446 error (_("array not allocated"));
449 /* First check that the number of dimensions in the type we are slicing
450 matches the number of arguments we were passed. */
451 int ndimensions
= calc_f77_array_dims (original_array_type
);
452 if (nargs
!= ndimensions
)
453 error (_("Wrong number of subscripts"));
455 /* This will be initialised below with the type of the elements held in
457 struct type
*inner_element_type
;
459 /* Extract the types of each array dimension from the original array
460 type. We need these available so we can fill in the default upper and
461 lower bounds if the user requested slice doesn't provide that
462 information. Additionally unpacking the dimensions like this gives us
463 the inner element type. */
464 std::vector
<struct type
*> dim_types
;
466 dim_types
.reserve (ndimensions
);
467 struct type
*type
= original_array_type
;
468 for (int i
= 0; i
< ndimensions
; ++i
)
470 dim_types
.push_back (type
);
471 type
= TYPE_TARGET_TYPE (type
);
473 /* TYPE is now the inner element type of the array, we start the new
474 array slice off as this type, then as we process the requested slice
475 (from the user) we wrap new types around this to build up the final
477 inner_element_type
= type
;
480 /* As we analyse the new slice type we need to understand if the data
481 being referenced is contiguous. Do decide this we must track the size
482 of an element at each dimension of the new slice array. Initially the
483 elements of the inner most dimension of the array are the same inner
484 most elements as the original ARRAY. */
485 LONGEST slice_element_size
= TYPE_LENGTH (inner_element_type
);
487 /* Start off assuming all data is contiguous, this will be set to false
488 if access to any dimension results in non-contiguous data. */
489 bool is_all_contiguous
= true;
491 /* The TOTAL_OFFSET is the distance in bytes from the start of the
492 original ARRAY to the start of the new slice. This is calculated as
493 we process the information from the user. */
494 LONGEST total_offset
= 0;
496 /* A structure representing information about each dimension of the
501 slice_dim (LONGEST l
, LONGEST h
, LONGEST s
, struct type
*idx
)
508 /* The low bound for this dimension of the slice. */
511 /* The high bound for this dimension of the slice. */
514 /* The byte stride for this dimension of the slice. */
520 /* The dimensions of the resulting slice. */
521 std::vector
<slice_dim
> slice_dims
;
523 /* Process the incoming arguments. These arguments are in the reverse
524 order to the array dimensions, that is the first argument refers to
525 the last array dimension. */
526 if (fortran_array_slicing_debug
)
527 debug_printf ("Processing array access:\n");
528 for (int i
= 0; i
< nargs
; ++i
)
530 /* For each dimension of the array the user will have either provided
531 a ranged access with optional lower bound, upper bound, and
532 stride, or the user will have supplied a single index. */
533 struct type
*dim_type
= dim_types
[ndimensions
- (i
+ 1)];
534 if (exp
->elts
[*pos
].opcode
== OP_RANGE
)
537 enum range_flag range_flag
= (enum range_flag
) exp
->elts
[pc
].longconst
;
540 LONGEST low
, high
, stride
;
541 low
= high
= stride
= 0;
543 if ((range_flag
& RANGE_LOW_BOUND_DEFAULT
) == 0)
544 low
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
546 low
= f77_get_lowerbound (dim_type
);
547 if ((range_flag
& RANGE_HIGH_BOUND_DEFAULT
) == 0)
548 high
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
550 high
= f77_get_upperbound (dim_type
);
551 if ((range_flag
& RANGE_HAS_STRIDE
) == RANGE_HAS_STRIDE
)
552 stride
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
557 error (_("stride must not be 0"));
559 /* Get information about this dimension in the original ARRAY. */
560 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
561 struct type
*index_type
= dim_type
->index_type ();
562 LONGEST lb
= f77_get_lowerbound (dim_type
);
563 LONGEST ub
= f77_get_upperbound (dim_type
);
564 LONGEST sd
= index_type
->bit_stride ();
566 sd
= TYPE_LENGTH (target_type
) * 8;
568 if (fortran_array_slicing_debug
)
570 debug_printf ("|-> Range access\n");
571 std::string str
= type_to_string (dim_type
);
572 debug_printf ("| |-> Type: %s\n", str
.c_str ());
573 debug_printf ("| |-> Array:\n");
574 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
575 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
576 debug_printf ("| | |-> Bit stride: %s\n", plongest (sd
));
577 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
/ 8));
578 debug_printf ("| | |-> Type size: %s\n",
579 pulongest (TYPE_LENGTH (dim_type
)));
580 debug_printf ("| | '-> Target type size: %s\n",
581 pulongest (TYPE_LENGTH (target_type
)));
582 debug_printf ("| |-> Accessing:\n");
583 debug_printf ("| | |-> Low bound: %s\n",
585 debug_printf ("| | |-> High bound: %s\n",
587 debug_printf ("| | '-> Element stride: %s\n",
591 /* Check the user hasn't asked for something invalid. */
592 if (high
> ub
|| low
< lb
)
593 error (_("array subscript out of bounds"));
595 /* Calculate what this dimension of the new slice array will look
596 like. OFFSET is the byte offset from the start of the
597 previous (more outer) dimension to the start of this
598 dimension. E_COUNT is the number of elements in this
599 dimension. REMAINDER is the number of elements remaining
600 between the last included element and the upper bound. For
601 example an access '1:6:2' will include elements 1, 3, 5 and
602 have a remainder of 1 (element #6). */
603 LONGEST lowest
= std::min (low
, high
);
604 LONGEST offset
= (sd
/ 8) * (lowest
- lb
);
605 LONGEST e_count
= std::abs (high
- low
) + 1;
606 e_count
= (e_count
+ (std::abs (stride
) - 1)) / std::abs (stride
);
608 LONGEST new_high
= new_low
+ e_count
- 1;
609 LONGEST new_stride
= (sd
* stride
) / 8;
610 LONGEST last_elem
= low
+ ((e_count
- 1) * stride
);
611 LONGEST remainder
= high
- last_elem
;
614 offset
+= std::abs (remainder
) * TYPE_LENGTH (target_type
);
616 error (_("incorrect stride and boundary combination"));
619 error (_("incorrect stride and boundary combination"));
621 /* Is the data within this dimension contiguous? It is if the
622 newly computed stride is the same size as a single element of
624 bool is_dim_contiguous
= (new_stride
== slice_element_size
);
625 is_all_contiguous
&= is_dim_contiguous
;
627 if (fortran_array_slicing_debug
)
629 debug_printf ("| '-> Results:\n");
630 debug_printf ("| |-> Offset = %s\n", plongest (offset
));
631 debug_printf ("| |-> Elements = %s\n", plongest (e_count
));
632 debug_printf ("| |-> Low bound = %s\n", plongest (new_low
));
633 debug_printf ("| |-> High bound = %s\n",
634 plongest (new_high
));
635 debug_printf ("| |-> Byte stride = %s\n",
636 plongest (new_stride
));
637 debug_printf ("| |-> Last element = %s\n",
638 plongest (last_elem
));
639 debug_printf ("| |-> Remainder = %s\n",
640 plongest (remainder
));
641 debug_printf ("| '-> Contiguous = %s\n",
642 (is_dim_contiguous
? "Yes" : "No"));
645 /* Figure out how big (in bytes) an element of this dimension of
646 the new array slice will be. */
647 slice_element_size
= std::abs (new_stride
* e_count
);
649 slice_dims
.emplace_back (new_low
, new_high
, new_stride
,
652 /* Update the total offset. */
653 total_offset
+= offset
;
657 /* There is a single index for this dimension. */
659 = value_as_long (evaluate_subexp_with_coercion (exp
, pos
, noside
));
661 /* Get information about this dimension in the original ARRAY. */
662 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
663 struct type
*index_type
= dim_type
->index_type ();
664 LONGEST lb
= f77_get_lowerbound (dim_type
);
665 LONGEST ub
= f77_get_upperbound (dim_type
);
666 LONGEST sd
= index_type
->bit_stride () / 8;
668 sd
= TYPE_LENGTH (target_type
);
670 if (fortran_array_slicing_debug
)
672 debug_printf ("|-> Index access\n");
673 std::string str
= type_to_string (dim_type
);
674 debug_printf ("| |-> Type: %s\n", str
.c_str ());
675 debug_printf ("| |-> Array:\n");
676 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
677 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
678 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
));
679 debug_printf ("| | |-> Type size: %s\n",
680 pulongest (TYPE_LENGTH (dim_type
)));
681 debug_printf ("| | '-> Target type size: %s\n",
682 pulongest (TYPE_LENGTH (target_type
)));
683 debug_printf ("| '-> Accessing:\n");
684 debug_printf ("| '-> Index: %s\n",
688 /* If the array has actual content then check the index is in
689 bounds. An array without content (an unbound array) doesn't
690 have a known upper bound, so don't error check in that
693 || (dim_type
->index_type ()->bounds ()->high
.kind () != PROP_UNDEFINED
695 || (VALUE_LVAL (array
) != lval_memory
696 && dim_type
->index_type ()->bounds ()->high
.kind () == PROP_UNDEFINED
))
698 if (type_not_associated (dim_type
))
699 error (_("no such vector element (vector not associated)"));
700 else if (type_not_allocated (dim_type
))
701 error (_("no such vector element (vector not allocated)"));
703 error (_("no such vector element"));
706 /* Calculate using the type stride, not the target type size. */
707 LONGEST offset
= sd
* (index
- lb
);
708 total_offset
+= offset
;
712 if (noside
== EVAL_SKIP
)
715 /* Build a type that represents the new array slice in the target memory
716 of the original ARRAY, this type makes use of strides to correctly
717 find only those elements that are part of the new slice. */
718 struct type
*array_slice_type
= inner_element_type
;
719 for (const auto &d
: slice_dims
)
721 /* Create the range. */
722 dynamic_prop p_low
, p_high
, p_stride
;
724 p_low
.set_const_val (d
.low
);
725 p_high
.set_const_val (d
.high
);
726 p_stride
.set_const_val (d
.stride
);
728 struct type
*new_range
729 = create_range_type_with_stride ((struct type
*) NULL
,
730 TYPE_TARGET_TYPE (d
.index
),
731 &p_low
, &p_high
, 0, &p_stride
,
734 = create_array_type (nullptr, array_slice_type
, new_range
);
737 if (fortran_array_slicing_debug
)
739 debug_printf ("'-> Final result:\n");
740 debug_printf (" |-> Type: %s\n",
741 type_to_string (array_slice_type
).c_str ());
742 debug_printf (" |-> Total offset: %s\n",
743 plongest (total_offset
));
744 debug_printf (" |-> Base address: %s\n",
745 core_addr_to_string (value_address (array
)));
746 debug_printf (" '-> Contiguous = %s\n",
747 (is_all_contiguous
? "Yes" : "No"));
750 /* Should we repack this array slice? */
751 if (!is_all_contiguous
&& (repack_array_slices
|| is_string_p
))
753 /* Build a type for the repacked slice. */
754 struct type
*repacked_array_type
= inner_element_type
;
755 for (const auto &d
: slice_dims
)
757 /* Create the range. */
758 dynamic_prop p_low
, p_high
, p_stride
;
760 p_low
.set_const_val (d
.low
);
761 p_high
.set_const_val (d
.high
);
762 p_stride
.set_const_val (TYPE_LENGTH (repacked_array_type
));
764 struct type
*new_range
765 = create_range_type_with_stride ((struct type
*) NULL
,
766 TYPE_TARGET_TYPE (d
.index
),
767 &p_low
, &p_high
, 0, &p_stride
,
770 = create_array_type (nullptr, repacked_array_type
, new_range
);
773 /* Now copy the elements from the original ARRAY into the packed
775 struct value
*dest
= allocate_value (repacked_array_type
);
776 if (value_lazy (array
)
777 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
778 > TYPE_LENGTH (check_typedef (value_type (array
)))))
780 fortran_array_walker
<fortran_lazy_array_repacker_impl
> p
781 (array_slice_type
, value_address (array
) + total_offset
, dest
);
786 fortran_array_walker
<fortran_array_repacker_impl
> p
787 (array_slice_type
, value_address (array
) + total_offset
,
788 total_offset
, array
, dest
);
795 if (VALUE_LVAL (array
) == lval_memory
)
797 /* If the value we're taking a slice from is not yet loaded, or
798 the requested slice is outside the values content range then
799 just create a new lazy value pointing at the memory where the
800 contents we're looking for exist. */
801 if (value_lazy (array
)
802 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
803 > TYPE_LENGTH (check_typedef (value_type (array
)))))
804 array
= value_at_lazy (array_slice_type
,
805 value_address (array
) + total_offset
);
807 array
= value_from_contents_and_address (array_slice_type
,
808 (value_contents (array
)
810 (value_address (array
)
813 else if (!value_lazy (array
))
814 array
= value_from_component (array
, array_slice_type
, total_offset
);
816 error (_("cannot subscript arrays that are not in memory"));
822 /* Evaluate FORTRAN_ASSOCIATED expressions. Both GDBARCH and LANG are
823 extracted from the expression being evaluated. POINTER is the required
824 first argument to the 'associated' keyword, and TARGET is the optional
825 second argument, this will be nullptr if the user only passed one
826 argument to their use of 'associated'. */
828 static struct value
*
829 fortran_associated (struct gdbarch
*gdbarch
, const language_defn
*lang
,
830 struct value
*pointer
, struct value
*target
= nullptr)
832 struct type
*result_type
= language_bool_type (lang
, gdbarch
);
834 /* All Fortran pointers should have the associated property, this is
835 how we know the pointer is pointing at something or not. */
836 struct type
*pointer_type
= check_typedef (value_type (pointer
));
837 if (TYPE_ASSOCIATED_PROP (pointer_type
) == nullptr
838 && pointer_type
->code () != TYPE_CODE_PTR
)
839 error (_("ASSOCIATED can only be applied to pointers"));
841 /* Get an address from POINTER. Fortran (or at least gfortran) models
842 array pointers as arrays with a dynamic data address, so we need to
843 use two approaches here, for real pointers we take the contents of the
844 pointer as an address. For non-pointers we take the address of the
846 CORE_ADDR pointer_addr
;
847 if (pointer_type
->code () == TYPE_CODE_PTR
)
848 pointer_addr
= value_as_address (pointer
);
850 pointer_addr
= value_address (pointer
);
852 /* The single argument case, is POINTER associated with anything? */
853 if (target
== nullptr)
855 bool is_associated
= false;
857 /* If POINTER is an actual pointer and doesn't have an associated
858 property then we need to figure out whether this pointer is
859 associated by looking at the value of the pointer itself. We make
860 the assumption that a non-associated pointer will be set to 0.
861 This is probably true for most targets, but might not be true for
863 if (pointer_type
->code () == TYPE_CODE_PTR
864 && TYPE_ASSOCIATED_PROP (pointer_type
) == nullptr)
865 is_associated
= (pointer_addr
!= 0);
867 is_associated
= !type_not_associated (pointer_type
);
868 return value_from_longest (result_type
, is_associated
? 1 : 0);
871 /* The two argument case, is POINTER associated with TARGET? */
873 struct type
*target_type
= check_typedef (value_type (target
));
875 struct type
*pointer_target_type
;
876 if (pointer_type
->code () == TYPE_CODE_PTR
)
877 pointer_target_type
= TYPE_TARGET_TYPE (pointer_type
);
879 pointer_target_type
= pointer_type
;
881 struct type
*target_target_type
;
882 if (target_type
->code () == TYPE_CODE_PTR
)
883 target_target_type
= TYPE_TARGET_TYPE (target_type
);
885 target_target_type
= target_type
;
887 if (pointer_target_type
->code () != target_target_type
->code ()
888 || (pointer_target_type
->code () != TYPE_CODE_ARRAY
889 && (TYPE_LENGTH (pointer_target_type
)
890 != TYPE_LENGTH (target_target_type
))))
891 error (_("arguments to associated must be of same type and kind"));
893 /* If TARGET is not in memory, or the original pointer is specifically
894 known to be not associated with anything, then the answer is obviously
895 false. Alternatively, if POINTER is an actual pointer and has no
896 associated property, then we have to check if its associated by
897 looking the value of the pointer itself. We make the assumption that
898 a non-associated pointer will be set to 0. This is probably true for
899 most targets, but might not be true for everyone. */
900 if (value_lval_const (target
) != lval_memory
901 || type_not_associated (pointer_type
)
902 || (TYPE_ASSOCIATED_PROP (pointer_type
) == nullptr
903 && pointer_type
->code () == TYPE_CODE_PTR
904 && pointer_addr
== 0))
905 return value_from_longest (result_type
, 0);
907 /* See the comment for POINTER_ADDR above. */
908 CORE_ADDR target_addr
;
909 if (target_type
->code () == TYPE_CODE_PTR
)
910 target_addr
= value_as_address (target
);
912 target_addr
= value_address (target
);
914 /* Wrap the following checks inside a do { ... } while (false) loop so
915 that we can use `break' to jump out of the loop. */
916 bool is_associated
= false;
919 /* If the addresses are different then POINTER is definitely not
920 pointing at TARGET. */
921 if (pointer_addr
!= target_addr
)
924 /* If POINTER is a real pointer (i.e. not an array pointer, which are
925 implemented as arrays with a dynamic content address), then this
926 is all the checking that is needed. */
927 if (pointer_type
->code () == TYPE_CODE_PTR
)
929 is_associated
= true;
933 /* We have an array pointer. Check the number of dimensions. */
934 int pointer_dims
= calc_f77_array_dims (pointer_type
);
935 int target_dims
= calc_f77_array_dims (target_type
);
936 if (pointer_dims
!= target_dims
)
939 /* Now check that every dimension has the same upper bound, lower
940 bound, and stride value. */
942 while (dim
< pointer_dims
)
944 LONGEST pointer_lowerbound
, pointer_upperbound
, pointer_stride
;
945 LONGEST target_lowerbound
, target_upperbound
, target_stride
;
947 pointer_type
= check_typedef (pointer_type
);
948 target_type
= check_typedef (target_type
);
950 struct type
*pointer_range
= pointer_type
->index_type ();
951 struct type
*target_range
= target_type
->index_type ();
953 if (!get_discrete_bounds (pointer_range
, &pointer_lowerbound
,
954 &pointer_upperbound
))
957 if (!get_discrete_bounds (target_range
, &target_lowerbound
,
961 if (pointer_lowerbound
!= target_lowerbound
962 || pointer_upperbound
!= target_upperbound
)
965 /* Figure out the stride (in bits) for both pointer and target.
966 If either doesn't have a stride then we take the element size,
967 but we need to convert to bits (hence the * 8). */
968 pointer_stride
= pointer_range
->bounds ()->bit_stride ();
969 if (pointer_stride
== 0)
971 = type_length_units (check_typedef
972 (TYPE_TARGET_TYPE (pointer_type
))) * 8;
973 target_stride
= target_range
->bounds ()->bit_stride ();
974 if (target_stride
== 0)
976 = type_length_units (check_typedef
977 (TYPE_TARGET_TYPE (target_type
))) * 8;
978 if (pointer_stride
!= target_stride
)
984 if (dim
< pointer_dims
)
987 is_associated
= true;
991 return value_from_longest (result_type
, is_associated
? 1 : 0);
995 /* A helper function for UNOP_ABS. */
998 eval_op_f_abs (struct type
*expect_type
, struct expression
*exp
,
1000 enum exp_opcode opcode
,
1003 if (noside
== EVAL_SKIP
)
1004 return eval_skip_value (exp
);
1005 struct type
*type
= value_type (arg1
);
1006 switch (type
->code ())
1011 = fabs (target_float_to_host_double (value_contents (arg1
),
1012 value_type (arg1
)));
1013 return value_from_host_double (type
, d
);
1017 LONGEST l
= value_as_long (arg1
);
1019 return value_from_longest (type
, l
);
1022 error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type
));
1025 /* A helper function for BINOP_MOD. */
1028 eval_op_f_mod (struct type
*expect_type
, struct expression
*exp
,
1030 enum exp_opcode opcode
,
1031 struct value
*arg1
, struct value
*arg2
)
1033 if (noside
== EVAL_SKIP
)
1034 return eval_skip_value (exp
);
1035 struct type
*type
= value_type (arg1
);
1036 if (type
->code () != value_type (arg2
)->code ())
1037 error (_("non-matching types for parameters to MOD ()"));
1038 switch (type
->code ())
1043 = target_float_to_host_double (value_contents (arg1
),
1046 = target_float_to_host_double (value_contents (arg2
),
1048 double d3
= fmod (d1
, d2
);
1049 return value_from_host_double (type
, d3
);
1053 LONGEST v1
= value_as_long (arg1
);
1054 LONGEST v2
= value_as_long (arg2
);
1056 error (_("calling MOD (N, 0) is undefined"));
1057 LONGEST v3
= v1
- (v1
/ v2
) * v2
;
1058 return value_from_longest (value_type (arg1
), v3
);
1061 error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type
));
1064 /* A helper function for UNOP_FORTRAN_CEILING. */
1067 eval_op_f_ceil (struct type
*expect_type
, struct expression
*exp
,
1069 enum exp_opcode opcode
,
1072 if (noside
== EVAL_SKIP
)
1073 return eval_skip_value (exp
);
1074 struct type
*type
= value_type (arg1
);
1075 if (type
->code () != TYPE_CODE_FLT
)
1076 error (_("argument to CEILING must be of type float"));
1078 = target_float_to_host_double (value_contents (arg1
),
1081 return value_from_host_double (type
, val
);
1084 /* A helper function for UNOP_FORTRAN_FLOOR. */
1087 eval_op_f_floor (struct type
*expect_type
, struct expression
*exp
,
1089 enum exp_opcode opcode
,
1092 if (noside
== EVAL_SKIP
)
1093 return eval_skip_value (exp
);
1094 struct type
*type
= value_type (arg1
);
1095 if (type
->code () != TYPE_CODE_FLT
)
1096 error (_("argument to FLOOR must be of type float"));
1098 = target_float_to_host_double (value_contents (arg1
),
1101 return value_from_host_double (type
, val
);
1104 /* A helper function for BINOP_FORTRAN_MODULO. */
1107 eval_op_f_modulo (struct type
*expect_type
, struct expression
*exp
,
1109 enum exp_opcode opcode
,
1110 struct value
*arg1
, struct value
*arg2
)
1112 if (noside
== EVAL_SKIP
)
1113 return eval_skip_value (exp
);
1114 struct type
*type
= value_type (arg1
);
1115 if (type
->code () != value_type (arg2
)->code ())
1116 error (_("non-matching types for parameters to MODULO ()"));
1117 /* MODULO(A, P) = A - FLOOR (A / P) * P */
1118 switch (type
->code ())
1122 LONGEST a
= value_as_long (arg1
);
1123 LONGEST p
= value_as_long (arg2
);
1124 LONGEST result
= a
- (a
/ p
) * p
;
1125 if (result
!= 0 && (a
< 0) != (p
< 0))
1127 return value_from_longest (value_type (arg1
), result
);
1132 = target_float_to_host_double (value_contents (arg1
),
1135 = target_float_to_host_double (value_contents (arg2
),
1137 double result
= fmod (a
, p
);
1138 if (result
!= 0 && (a
< 0.0) != (p
< 0.0))
1140 return value_from_host_double (type
, result
);
1143 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type
));
1146 /* A helper function for BINOP_FORTRAN_CMPLX. */
1149 eval_op_f_cmplx (struct type
*expect_type
, struct expression
*exp
,
1151 enum exp_opcode opcode
,
1152 struct value
*arg1
, struct value
*arg2
)
1154 if (noside
== EVAL_SKIP
)
1155 return eval_skip_value (exp
);
1156 struct type
*type
= builtin_f_type(exp
->gdbarch
)->builtin_complex_s16
;
1157 return value_literal_complex (arg1
, arg2
, type
);
1160 /* A helper function for UNOP_FORTRAN_KIND. */
1163 eval_op_f_kind (struct type
*expect_type
, struct expression
*exp
,
1165 enum exp_opcode opcode
,
1168 struct type
*type
= value_type (arg1
);
1170 switch (type
->code ())
1172 case TYPE_CODE_STRUCT
:
1173 case TYPE_CODE_UNION
:
1174 case TYPE_CODE_MODULE
:
1175 case TYPE_CODE_FUNC
:
1176 error (_("argument to kind must be an intrinsic type"));
1179 if (!TYPE_TARGET_TYPE (type
))
1180 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1181 TYPE_LENGTH (type
));
1182 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1183 TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
1186 /* A helper function for UNOP_FORTRAN_ALLOCATED. */
1188 static struct value
*
1189 eval_op_f_allocated (struct type
*expect_type
, struct expression
*exp
,
1190 enum noside noside
, enum exp_opcode op
,
1193 struct type
*type
= check_typedef (value_type (arg1
));
1194 if (type
->code () != TYPE_CODE_ARRAY
)
1195 error (_("ALLOCATED can only be applied to arrays"));
1196 struct type
*result_type
1197 = builtin_f_type (exp
->gdbarch
)->builtin_logical
;
1198 LONGEST result_value
= type_not_allocated (type
) ? 0 : 1;
1199 return value_from_longest (result_type
, result_value
);
1202 /* Special expression evaluation cases for Fortran. */
1204 static struct value
*
1205 evaluate_subexp_f (struct type
*expect_type
, struct expression
*exp
,
1206 int *pos
, enum noside noside
)
1208 struct value
*arg1
= NULL
, *arg2
= NULL
;
1215 op
= exp
->elts
[pc
].opcode
;
1221 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
1224 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1225 return eval_op_f_abs (expect_type
, exp
, noside
, op
, arg1
);
1228 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1229 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1230 return eval_op_f_mod (expect_type
, exp
, noside
, op
, arg1
, arg2
);
1232 case UNOP_FORTRAN_CEILING
:
1233 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1234 return eval_op_f_ceil (expect_type
, exp
, noside
, op
, arg1
);
1236 case UNOP_FORTRAN_FLOOR
:
1237 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1238 return eval_op_f_floor (expect_type
, exp
, noside
, op
, arg1
);
1240 case UNOP_FORTRAN_ALLOCATED
:
1242 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1243 if (noside
== EVAL_SKIP
)
1244 return eval_skip_value (exp
);
1245 return eval_op_f_allocated (expect_type
, exp
, noside
, op
, arg1
);
1248 case BINOP_FORTRAN_MODULO
:
1249 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1250 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1251 return eval_op_f_modulo (expect_type
, exp
, noside
, op
, arg1
, arg2
);
1253 case FORTRAN_LBOUND
:
1254 case FORTRAN_UBOUND
:
1256 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1259 /* This assertion should be enforced by the expression parser. */
1260 gdb_assert (nargs
== 1 || nargs
== 2);
1262 bool lbound_p
= op
== FORTRAN_LBOUND
;
1264 /* Check that the first argument is array like. */
1265 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1266 fortran_require_array (value_type (arg1
), lbound_p
);
1269 return fortran_bounds_all_dims (lbound_p
, exp
->gdbarch
, arg1
);
1271 /* User asked for the bounds of a specific dimension of the array. */
1272 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1273 type
= check_typedef (value_type (arg2
));
1274 if (type
->code () != TYPE_CODE_INT
)
1277 error (_("LBOUND second argument should be an integer"));
1279 error (_("UBOUND second argument should be an integer"));
1282 return fortran_bounds_for_dimension (lbound_p
, exp
->gdbarch
, arg1
,
1287 case FORTRAN_ASSOCIATED
:
1289 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1292 /* This assertion should be enforced by the expression parser. */
1293 gdb_assert (nargs
== 1 || nargs
== 2);
1295 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1299 if (noside
== EVAL_SKIP
)
1300 return eval_skip_value (exp
);
1301 return fortran_associated (exp
->gdbarch
, exp
->language_defn
,
1305 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1306 if (noside
== EVAL_SKIP
)
1307 return eval_skip_value (exp
);
1308 return fortran_associated (exp
->gdbarch
, exp
->language_defn
,
1313 case BINOP_FORTRAN_CMPLX
:
1314 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1315 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1316 return eval_op_f_cmplx (expect_type
, exp
, noside
, op
, arg1
, arg2
);
1318 case UNOP_FORTRAN_KIND
:
1319 arg1
= evaluate_subexp (NULL
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
1320 return eval_op_f_kind (expect_type
, exp
, noside
, op
, arg1
);
1322 case OP_F77_UNDETERMINED_ARGLIST
:
1323 /* Remember that in F77, functions, substring ops and array subscript
1324 operations cannot be disambiguated at parse time. We have made
1325 all array subscript operations, substring operations as well as
1326 function calls come here and we now have to discover what the heck
1327 this thing actually was. If it is a function, we process just as
1328 if we got an OP_FUNCALL. */
1329 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1332 /* First determine the type code we are dealing with. */
1333 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1334 type
= check_typedef (value_type (arg1
));
1335 enum type_code code
= type
->code ();
1337 if (code
== TYPE_CODE_PTR
)
1339 /* Fortran always passes variable to subroutines as pointer.
1340 So we need to look into its target type to see if it is
1341 array, string or function. If it is, we need to switch
1342 to the target value the original one points to. */
1343 struct type
*target_type
= check_typedef (TYPE_TARGET_TYPE (type
));
1345 if (target_type
->code () == TYPE_CODE_ARRAY
1346 || target_type
->code () == TYPE_CODE_STRING
1347 || target_type
->code () == TYPE_CODE_FUNC
)
1349 arg1
= value_ind (arg1
);
1350 type
= check_typedef (value_type (arg1
));
1351 code
= type
->code ();
1357 case TYPE_CODE_ARRAY
:
1358 case TYPE_CODE_STRING
:
1359 return fortran_value_subarray (arg1
, exp
, pos
, nargs
, noside
);
1362 case TYPE_CODE_FUNC
:
1363 case TYPE_CODE_INTERNAL_FUNCTION
:
1365 /* It's a function call. Allocate arg vector, including
1366 space for the function to be called in argvec[0] and a
1367 termination NULL. */
1368 struct value
**argvec
= (struct value
**)
1369 alloca (sizeof (struct value
*) * (nargs
+ 2));
1372 for (; tem
<= nargs
; tem
++)
1374 bool is_internal_func
= (code
== TYPE_CODE_INTERNAL_FUNCTION
);
1376 = fortran_prepare_argument (exp
, pos
, (tem
- 1),
1378 value_type (arg1
), noside
);
1380 argvec
[tem
] = 0; /* signal end of arglist */
1381 if (noside
== EVAL_SKIP
)
1382 return eval_skip_value (exp
);
1383 return evaluate_subexp_do_call (exp
, noside
, argvec
[0],
1384 gdb::make_array_view (argvec
+ 1,
1390 error (_("Cannot perform substring on this type"));
1394 /* Should be unreachable. */
1398 /* Special expression lengths for Fortran. */
1401 operator_length_f (const struct expression
*exp
, int pc
, int *oplenp
,
1407 switch (exp
->elts
[pc
- 1].opcode
)
1410 operator_length_standard (exp
, pc
, oplenp
, argsp
);
1413 case UNOP_FORTRAN_KIND
:
1414 case UNOP_FORTRAN_FLOOR
:
1415 case UNOP_FORTRAN_CEILING
:
1416 case UNOP_FORTRAN_ALLOCATED
:
1421 case BINOP_FORTRAN_CMPLX
:
1422 case BINOP_FORTRAN_MODULO
:
1427 case FORTRAN_ASSOCIATED
:
1428 case FORTRAN_LBOUND
:
1429 case FORTRAN_UBOUND
:
1431 args
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
1434 case OP_F77_UNDETERMINED_ARGLIST
:
1436 args
= 1 + longest_to_int (exp
->elts
[pc
- 2].longconst
);
1444 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1445 the extra argument NAME which is the text that should be printed as the
1446 name of this operation. */
1449 print_unop_subexp_f (struct expression
*exp
, int *pos
,
1450 struct ui_file
*stream
, enum precedence prec
,
1454 fprintf_filtered (stream
, "%s(", name
);
1455 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1456 fputs_filtered (")", stream
);
1459 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1460 the extra argument NAME which is the text that should be printed as the
1461 name of this operation. */
1464 print_binop_subexp_f (struct expression
*exp
, int *pos
,
1465 struct ui_file
*stream
, enum precedence prec
,
1469 fprintf_filtered (stream
, "%s(", name
);
1470 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1471 fputs_filtered (",", stream
);
1472 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1473 fputs_filtered (")", stream
);
1476 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1477 the extra argument NAME which is the text that should be printed as the
1478 name of this operation. */
1481 print_unop_or_binop_subexp_f (struct expression
*exp
, int *pos
,
1482 struct ui_file
*stream
, enum precedence prec
,
1485 unsigned nargs
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
);
1487 fprintf_filtered (stream
, "%s (", name
);
1488 for (unsigned tem
= 0; tem
< nargs
; tem
++)
1491 fputs_filtered (", ", stream
);
1492 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
1494 fputs_filtered (")", stream
);
1497 /* Special expression printing for Fortran. */
1500 print_subexp_f (struct expression
*exp
, int *pos
,
1501 struct ui_file
*stream
, enum precedence prec
)
1504 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
1509 print_subexp_standard (exp
, pos
, stream
, prec
);
1512 case UNOP_FORTRAN_KIND
:
1513 print_unop_subexp_f (exp
, pos
, stream
, prec
, "KIND");
1516 case UNOP_FORTRAN_FLOOR
:
1517 print_unop_subexp_f (exp
, pos
, stream
, prec
, "FLOOR");
1520 case UNOP_FORTRAN_CEILING
:
1521 print_unop_subexp_f (exp
, pos
, stream
, prec
, "CEILING");
1524 case UNOP_FORTRAN_ALLOCATED
:
1525 print_unop_subexp_f (exp
, pos
, stream
, prec
, "ALLOCATED");
1528 case BINOP_FORTRAN_CMPLX
:
1529 print_binop_subexp_f (exp
, pos
, stream
, prec
, "CMPLX");
1532 case BINOP_FORTRAN_MODULO
:
1533 print_binop_subexp_f (exp
, pos
, stream
, prec
, "MODULO");
1536 case FORTRAN_ASSOCIATED
:
1537 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "ASSOCIATED");
1540 case FORTRAN_LBOUND
:
1541 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "LBOUND");
1544 case FORTRAN_UBOUND
:
1545 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "UBOUND");
1548 case OP_F77_UNDETERMINED_ARGLIST
:
1550 print_subexp_funcall (exp
, pos
, stream
);
1555 /* Special expression dumping for Fortran. */
1558 dump_subexp_body_f (struct expression
*exp
,
1559 struct ui_file
*stream
, int elt
)
1561 int opcode
= exp
->elts
[elt
].opcode
;
1562 int oplen
, nargs
, i
;
1567 return dump_subexp_body_standard (exp
, stream
, elt
);
1569 case UNOP_FORTRAN_KIND
:
1570 case UNOP_FORTRAN_FLOOR
:
1571 case UNOP_FORTRAN_CEILING
:
1572 case UNOP_FORTRAN_ALLOCATED
:
1573 case BINOP_FORTRAN_CMPLX
:
1574 case BINOP_FORTRAN_MODULO
:
1575 operator_length_f (exp
, (elt
+ 1), &oplen
, &nargs
);
1578 case FORTRAN_ASSOCIATED
:
1579 case FORTRAN_LBOUND
:
1580 case FORTRAN_UBOUND
:
1581 operator_length_f (exp
, (elt
+ 3), &oplen
, &nargs
);
1584 case OP_F77_UNDETERMINED_ARGLIST
:
1585 return dump_subexp_body_funcall (exp
, stream
, elt
+ 1);
1589 for (i
= 0; i
< nargs
; i
+= 1)
1590 elt
= dump_subexp (exp
, stream
, elt
);
1595 /* Special expression checking for Fortran. */
1598 operator_check_f (struct expression
*exp
, int pos
,
1599 int (*objfile_func
) (struct objfile
*objfile
,
1603 const union exp_element
*const elts
= exp
->elts
;
1605 switch (elts
[pos
].opcode
)
1607 case UNOP_FORTRAN_KIND
:
1608 case UNOP_FORTRAN_FLOOR
:
1609 case UNOP_FORTRAN_CEILING
:
1610 case UNOP_FORTRAN_ALLOCATED
:
1611 case BINOP_FORTRAN_CMPLX
:
1612 case BINOP_FORTRAN_MODULO
:
1613 case FORTRAN_ASSOCIATED
:
1614 case FORTRAN_LBOUND
:
1615 case FORTRAN_UBOUND
:
1616 /* Any references to objfiles are held in the arguments to this
1617 expression, not within the expression itself, so no additional
1618 checking is required here, the outer expression iteration code
1619 will take care of checking each argument. */
1623 return operator_check_standard (exp
, pos
, objfile_func
, data
);
1629 /* Expression processing for Fortran. */
1630 const struct exp_descriptor
f_language::exp_descriptor_tab
=
1639 /* See language.h. */
1642 f_language::language_arch_info (struct gdbarch
*gdbarch
,
1643 struct language_arch_info
*lai
) const
1645 const struct builtin_f_type
*builtin
= builtin_f_type (gdbarch
);
1647 /* Helper function to allow shorter lines below. */
1648 auto add
= [&] (struct type
* t
)
1650 lai
->add_primitive_type (t
);
1653 add (builtin
->builtin_character
);
1654 add (builtin
->builtin_logical
);
1655 add (builtin
->builtin_logical_s1
);
1656 add (builtin
->builtin_logical_s2
);
1657 add (builtin
->builtin_logical_s8
);
1658 add (builtin
->builtin_real
);
1659 add (builtin
->builtin_real_s8
);
1660 add (builtin
->builtin_real_s16
);
1661 add (builtin
->builtin_complex_s8
);
1662 add (builtin
->builtin_complex_s16
);
1663 add (builtin
->builtin_void
);
1665 lai
->set_string_char_type (builtin
->builtin_character
);
1666 lai
->set_bool_type (builtin
->builtin_logical_s2
, "logical");
1669 /* See language.h. */
1672 f_language::search_name_hash (const char *name
) const
1674 return cp_search_name_hash (name
);
1677 /* See language.h. */
1680 f_language::lookup_symbol_nonlocal (const char *name
,
1681 const struct block
*block
,
1682 const domain_enum domain
) const
1684 return cp_lookup_symbol_nonlocal (this, name
, block
, domain
);
1687 /* See language.h. */
1689 symbol_name_matcher_ftype
*
1690 f_language::get_symbol_name_matcher_inner
1691 (const lookup_name_info
&lookup_name
) const
1693 return cp_get_symbol_name_matcher (lookup_name
);
1696 /* Single instance of the Fortran language class. */
1698 static f_language f_language_defn
;
1701 build_fortran_types (struct gdbarch
*gdbarch
)
1703 struct builtin_f_type
*builtin_f_type
1704 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_f_type
);
1706 builtin_f_type
->builtin_void
1707 = arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
, "void");
1709 builtin_f_type
->builtin_character
1710 = arch_type (gdbarch
, TYPE_CODE_CHAR
, TARGET_CHAR_BIT
, "character");
1712 builtin_f_type
->builtin_logical_s1
1713 = arch_boolean_type (gdbarch
, TARGET_CHAR_BIT
, 1, "logical*1");
1715 builtin_f_type
->builtin_integer_s2
1716 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
), 0,
1719 builtin_f_type
->builtin_integer_s8
1720 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 0,
1723 builtin_f_type
->builtin_logical_s2
1724 = arch_boolean_type (gdbarch
, gdbarch_short_bit (gdbarch
), 1,
1727 builtin_f_type
->builtin_logical_s8
1728 = arch_boolean_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 1,
1731 builtin_f_type
->builtin_integer
1732 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 0,
1735 builtin_f_type
->builtin_logical
1736 = arch_boolean_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1,
1739 builtin_f_type
->builtin_real
1740 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
1741 "real", gdbarch_float_format (gdbarch
));
1742 builtin_f_type
->builtin_real_s8
1743 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
1744 "real*8", gdbarch_double_format (gdbarch
));
1745 auto fmt
= gdbarch_floatformat_for_type (gdbarch
, "real(kind=16)", 128);
1747 builtin_f_type
->builtin_real_s16
1748 = arch_float_type (gdbarch
, 128, "real*16", fmt
);
1749 else if (gdbarch_long_double_bit (gdbarch
) == 128)
1750 builtin_f_type
->builtin_real_s16
1751 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
1752 "real*16", gdbarch_long_double_format (gdbarch
));
1754 builtin_f_type
->builtin_real_s16
1755 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 128, "real*16");
1757 builtin_f_type
->builtin_complex_s8
1758 = init_complex_type ("complex*8", builtin_f_type
->builtin_real
);
1759 builtin_f_type
->builtin_complex_s16
1760 = init_complex_type ("complex*16", builtin_f_type
->builtin_real_s8
);
1762 if (builtin_f_type
->builtin_real_s16
->code () == TYPE_CODE_ERROR
)
1763 builtin_f_type
->builtin_complex_s32
1764 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 256, "complex*32");
1766 builtin_f_type
->builtin_complex_s32
1767 = init_complex_type ("complex*32", builtin_f_type
->builtin_real_s16
);
1769 return builtin_f_type
;
1772 static struct gdbarch_data
*f_type_data
;
1774 const struct builtin_f_type
*
1775 builtin_f_type (struct gdbarch
*gdbarch
)
1777 return (const struct builtin_f_type
*) gdbarch_data (gdbarch
, f_type_data
);
1780 /* Command-list for the "set/show fortran" prefix command. */
1781 static struct cmd_list_element
*set_fortran_list
;
1782 static struct cmd_list_element
*show_fortran_list
;
1784 void _initialize_f_language ();
1786 _initialize_f_language ()
1788 f_type_data
= gdbarch_data_register_post_init (build_fortran_types
);
1790 add_basic_prefix_cmd ("fortran", no_class
,
1791 _("Prefix command for changing Fortran-specific settings."),
1792 &set_fortran_list
, "set fortran ", 0, &setlist
);
1794 add_show_prefix_cmd ("fortran", no_class
,
1795 _("Generic command for showing Fortran-specific settings."),
1796 &show_fortran_list
, "show fortran ", 0, &showlist
);
1798 add_setshow_boolean_cmd ("repack-array-slices", class_vars
,
1799 &repack_array_slices
, _("\
1800 Enable or disable repacking of non-contiguous array slices."), _("\
1801 Show whether non-contiguous array slices are repacked."), _("\
1802 When the user requests a slice of a Fortran array then we can either return\n\
1803 a descriptor that describes the array in place (using the original array data\n\
1804 in its existing location) or the original data can be repacked (copied) to a\n\
1807 When the content of the array slice is contiguous within the original array\n\
1808 then the result will never be repacked, but when the data for the new array\n\
1809 is non-contiguous within the original array repacking will only be performed\n\
1810 when this setting is on."),
1812 show_repack_array_slices
,
1813 &set_fortran_list
, &show_fortran_list
);
1815 /* Debug Fortran's array slicing logic. */
1816 add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance
,
1817 &fortran_array_slicing_debug
, _("\
1818 Set debugging of Fortran array slicing."), _("\
1819 Show debugging of Fortran array slicing."), _("\
1820 When on, debugging of Fortran array slicing is enabled."),
1822 show_fortran_array_slicing_debug
,
1823 &setdebuglist
, &showdebuglist
);
1826 /* Ensures that function argument VALUE is in the appropriate form to
1827 pass to a Fortran function. Returns a possibly new value that should
1828 be used instead of VALUE.
1830 When IS_ARTIFICIAL is true this indicates an artificial argument,
1831 e.g. hidden string lengths which the GNU Fortran argument passing
1832 convention specifies as being passed by value.
1834 When IS_ARTIFICIAL is false, the argument is passed by pointer. If the
1835 value is already in target memory then return a value that is a pointer
1836 to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate
1837 space in the target, copy VALUE in, and return a pointer to the in
1840 static struct value
*
1841 fortran_argument_convert (struct value
*value
, bool is_artificial
)
1845 /* If the value is not in the inferior e.g. registers values,
1846 convenience variables and user input. */
1847 if (VALUE_LVAL (value
) != lval_memory
)
1849 struct type
*type
= value_type (value
);
1850 const int length
= TYPE_LENGTH (type
);
1851 const CORE_ADDR addr
1852 = value_as_long (value_allocate_space_in_inferior (length
));
1853 write_memory (addr
, value_contents (value
), length
);
1855 = value_from_contents_and_address (type
, value_contents (value
),
1857 return value_addr (val
);
1860 return value_addr (value
); /* Program variables, e.g. arrays. */
1865 /* Prepare (and return) an argument value ready for an inferior function
1866 call to a Fortran function. EXP and POS are the expressions describing
1867 the argument to prepare. ARG_NUM is the argument number being
1868 prepared, with 0 being the first argument and so on. FUNC_TYPE is the
1869 type of the function being called.
1871 IS_INTERNAL_CALL_P is true if this is a call to a function of type
1872 TYPE_CODE_INTERNAL_FUNCTION, otherwise this parameter is false.
1874 NOSIDE has its usual meaning for expression parsing (see eval.c).
1876 Arguments in Fortran are normally passed by address, we coerce the
1877 arguments here rather than in value_arg_coerce as otherwise the call to
1878 malloc (to place the non-lvalue parameters in target memory) is hit by
1879 this Fortran specific logic. This results in malloc being called with a
1880 pointer to an integer followed by an attempt to malloc the arguments to
1881 malloc in target memory. Infinite recursion ensues. */
1884 fortran_prepare_argument (struct expression
*exp
, int *pos
,
1885 int arg_num
, bool is_internal_call_p
,
1886 struct type
*func_type
, enum noside noside
)
1888 if (is_internal_call_p
)
1889 return evaluate_subexp_with_coercion (exp
, pos
, noside
);
1891 bool is_artificial
= ((arg_num
>= func_type
->num_fields ())
1893 : TYPE_FIELD_ARTIFICIAL (func_type
, arg_num
));
1895 /* If this is an artificial argument, then either, this is an argument
1896 beyond the end of the known arguments, or possibly, there are no known
1897 arguments (maybe missing debug info).
1899 For these artificial arguments, if the user has prefixed it with '&'
1900 (for address-of), then lets always allow this to succeed, even if the
1901 argument is not actually in inferior memory. This will allow the user
1902 to pass arguments to a Fortran function even when there's no debug
1905 As we already pass the address of non-artificial arguments, all we
1906 need to do if skip the UNOP_ADDR operator in the expression and mark
1907 the argument as non-artificial. */
1908 if (is_artificial
&& exp
->elts
[*pos
].opcode
== UNOP_ADDR
)
1911 is_artificial
= false;
1914 struct value
*arg_val
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
1915 return fortran_argument_convert (arg_val
, is_artificial
);
1921 fortran_preserve_arg_pointer (struct value
*arg
, struct type
*type
)
1923 if (value_type (arg
)->code () == TYPE_CODE_PTR
)
1924 return value_type (arg
);
1931 fortran_adjust_dynamic_array_base_address_hack (struct type
*type
,
1934 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
1936 /* We can't adjust the base address for arrays that have no content. */
1937 if (type_not_allocated (type
) || type_not_associated (type
))
1940 int ndimensions
= calc_f77_array_dims (type
);
1941 LONGEST total_offset
= 0;
1943 /* Walk through each of the dimensions of this array type and figure out
1944 if any of the dimensions are "backwards", that is the base address
1945 for this dimension points to the element at the highest memory
1946 address and the stride is negative. */
1947 struct type
*tmp_type
= type
;
1948 for (int i
= 0 ; i
< ndimensions
; ++i
)
1950 /* Grab the range for this dimension and extract the lower and upper
1952 tmp_type
= check_typedef (tmp_type
);
1953 struct type
*range_type
= tmp_type
->index_type ();
1954 LONGEST lowerbound
, upperbound
, stride
;
1955 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
1956 error ("failed to get range bounds");
1958 /* Figure out the stride for this dimension. */
1959 struct type
*elt_type
= check_typedef (TYPE_TARGET_TYPE (tmp_type
));
1960 stride
= tmp_type
->index_type ()->bounds ()->bit_stride ();
1962 stride
= type_length_units (elt_type
);
1966 = gdbarch_addressable_memory_unit_size (elt_type
->arch ());
1967 stride
/= (unit_size
* 8);
1970 /* If this dimension is "backward" then figure out the offset
1971 adjustment required to point to the element at the lowest memory
1972 address, and add this to the total offset. */
1974 if (stride
< 0 && lowerbound
< upperbound
)
1975 offset
= (upperbound
- lowerbound
) * stride
;
1976 total_offset
+= offset
;
1977 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
1980 /* Adjust the address of this object and return it. */
1981 address
+= total_offset
;