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"
44 /* Whether GDB should repack array slices created by the user. */
45 static bool repack_array_slices
= false;
47 /* Implement 'show fortran repack-array-slices'. */
49 show_repack_array_slices (struct ui_file
*file
, int from_tty
,
50 struct cmd_list_element
*c
, const char *value
)
52 fprintf_filtered (file
, _("Repacking of Fortran array slices is %s.\n"),
56 /* Debugging of Fortran's array slicing. */
57 static bool fortran_array_slicing_debug
= false;
59 /* Implement 'show debug fortran-array-slicing'. */
61 show_fortran_array_slicing_debug (struct ui_file
*file
, int from_tty
,
62 struct cmd_list_element
*c
,
65 fprintf_filtered (file
, _("Debugging of Fortran array slicing is %s.\n"),
71 static value
*fortran_prepare_argument (struct expression
*exp
, int *pos
,
72 int arg_num
, bool is_internal_call_p
,
73 struct type
*func_type
,
76 /* Return the encoding that should be used for the character type
80 f_language::get_encoding (struct type
*type
)
84 switch (TYPE_LENGTH (type
))
87 encoding
= target_charset (type
->arch ());
90 if (type_byte_order (type
) == BFD_ENDIAN_BIG
)
91 encoding
= "UTF-32BE";
93 encoding
= "UTF-32LE";
97 error (_("unrecognized character type"));
105 /* Table of operators and their precedences for printing expressions. */
107 const struct op_print
f_language::op_print_tab
[] =
109 {"+", BINOP_ADD
, PREC_ADD
, 0},
110 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
111 {"-", BINOP_SUB
, PREC_ADD
, 0},
112 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
113 {"*", BINOP_MUL
, PREC_MUL
, 0},
114 {"/", BINOP_DIV
, PREC_MUL
, 0},
115 {"DIV", BINOP_INTDIV
, PREC_MUL
, 0},
116 {"MOD", BINOP_REM
, PREC_MUL
, 0},
117 {"=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
118 {".OR.", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
119 {".AND.", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
120 {".NOT.", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
121 {".EQ.", BINOP_EQUAL
, PREC_EQUAL
, 0},
122 {".NE.", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
123 {".LE.", BINOP_LEQ
, PREC_ORDER
, 0},
124 {".GE.", BINOP_GEQ
, PREC_ORDER
, 0},
125 {".GT.", BINOP_GTR
, PREC_ORDER
, 0},
126 {".LT.", BINOP_LESS
, PREC_ORDER
, 0},
127 {"**", UNOP_IND
, PREC_PREFIX
, 0},
128 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
129 {NULL
, OP_NULL
, PREC_REPEAT
, 0}
133 /* Create an array containing the lower bounds (when LBOUND_P is true) or
134 the upper bounds (when LBOUND_P is false) of ARRAY (which must be of
135 array type). GDBARCH is the current architecture. */
137 static struct value
*
138 fortran_bounds_all_dims (bool lbound_p
,
139 struct gdbarch
*gdbarch
,
142 type
*array_type
= check_typedef (value_type (array
));
143 int ndimensions
= calc_f77_array_dims (array_type
);
145 /* Allocate a result value of the correct type. */
147 = create_static_range_type (nullptr,
148 builtin_type (gdbarch
)->builtin_int
,
150 struct type
*elm_type
= builtin_type (gdbarch
)->builtin_long_long
;
151 struct type
*result_type
= create_array_type (nullptr, elm_type
, range
);
152 struct value
*result
= allocate_value (result_type
);
154 /* Walk the array dimensions backwards due to the way the array will be
155 laid out in memory, the first dimension will be the most inner. */
156 LONGEST elm_len
= TYPE_LENGTH (elm_type
);
157 for (LONGEST dst_offset
= elm_len
* (ndimensions
- 1);
159 dst_offset
-= elm_len
)
163 /* Grab the required bound. */
165 b
= f77_get_lowerbound (array_type
);
167 b
= f77_get_upperbound (array_type
);
169 /* And copy the value into the result value. */
170 struct value
*v
= value_from_longest (elm_type
, b
);
171 gdb_assert (dst_offset
+ TYPE_LENGTH (value_type (v
))
172 <= TYPE_LENGTH (value_type (result
)));
173 gdb_assert (TYPE_LENGTH (value_type (v
)) == elm_len
);
174 value_contents_copy (result
, dst_offset
, v
, 0, elm_len
);
176 /* Peel another dimension of the array. */
177 array_type
= TYPE_TARGET_TYPE (array_type
);
183 /* Return the lower bound (when LBOUND_P is true) or the upper bound (when
184 LBOUND_P is false) for dimension DIM_VAL (which must be an integer) of
185 ARRAY (which must be an array). GDBARCH is the current architecture. */
187 static struct value
*
188 fortran_bounds_for_dimension (bool lbound_p
,
189 struct gdbarch
*gdbarch
,
191 struct value
*dim_val
)
193 /* Check the requested dimension is valid for this array. */
194 type
*array_type
= check_typedef (value_type (array
));
195 int ndimensions
= calc_f77_array_dims (array_type
);
196 long dim
= value_as_long (dim_val
);
197 if (dim
< 1 || dim
> ndimensions
)
200 error (_("LBOUND dimension must be from 1 to %d"), ndimensions
);
202 error (_("UBOUND dimension must be from 1 to %d"), ndimensions
);
205 /* The type for the result. */
206 struct type
*bound_type
= builtin_type (gdbarch
)->builtin_long_long
;
208 /* Walk the dimensions backwards, due to the ordering in which arrays are
209 laid out the first dimension is the most inner. */
210 for (int i
= ndimensions
- 1; i
>= 0; --i
)
212 /* If this is the requested dimension then we're done. Grab the
213 bounds and return. */
219 b
= f77_get_lowerbound (array_type
);
221 b
= f77_get_upperbound (array_type
);
223 return value_from_longest (bound_type
, b
);
226 /* Peel off another dimension of the array. */
227 array_type
= TYPE_TARGET_TYPE (array_type
);
230 gdb_assert_not_reached ("failed to find matching dimension");
234 /* Return the number of dimensions for a Fortran array or string. */
237 calc_f77_array_dims (struct type
*array_type
)
240 struct type
*tmp_type
;
242 if ((array_type
->code () == TYPE_CODE_STRING
))
245 if ((array_type
->code () != TYPE_CODE_ARRAY
))
246 error (_("Can't get dimensions for a non-array type"));
248 tmp_type
= array_type
;
250 while ((tmp_type
= TYPE_TARGET_TYPE (tmp_type
)))
252 if (tmp_type
->code () == TYPE_CODE_ARRAY
)
258 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
259 slices. This is a base class for two alternative repacking mechanisms,
260 one for when repacking from a lazy value, and one for repacking from a
261 non-lazy (already loaded) value. */
262 class fortran_array_repacker_base_impl
263 : public fortran_array_walker_base_impl
266 /* Constructor, DEST is the value we are repacking into. */
267 fortran_array_repacker_base_impl (struct value
*dest
)
272 /* When we start processing the inner most dimension, this is where we
273 will be creating values for each element as we load them and then copy
274 them into the M_DEST value. Set a value mark so we can free these
276 void start_dimension (bool inner_p
)
280 gdb_assert (m_mark
== nullptr);
281 m_mark
= value_mark ();
285 /* When we finish processing the inner most dimension free all temporary
286 value that were created. */
287 void finish_dimension (bool inner_p
, bool last_p
)
291 gdb_assert (m_mark
!= nullptr);
292 value_free_to_mark (m_mark
);
298 /* Copy the contents of array element ELT into M_DEST at the next
300 void copy_element_to_dest (struct value
*elt
)
302 value_contents_copy (m_dest
, m_dest_offset
, elt
, 0,
303 TYPE_LENGTH (value_type (elt
)));
304 m_dest_offset
+= TYPE_LENGTH (value_type (elt
));
307 /* The value being written to. */
308 struct value
*m_dest
;
310 /* The byte offset in M_DEST at which the next element should be
312 LONGEST m_dest_offset
;
314 /* Set with a call to VALUE_MARK, and then reset after calling
315 VALUE_FREE_TO_MARK. */
316 struct value
*m_mark
= nullptr;
319 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
320 slices. This class is specialised for repacking an array slice from a
321 lazy array value, as such it does not require the parent array value to
322 be loaded into GDB's memory; the parent value could be huge, while the
323 slice could be tiny. */
324 class fortran_lazy_array_repacker_impl
325 : public fortran_array_repacker_base_impl
328 /* Constructor. TYPE is the type of the slice being loaded from the
329 parent value, so this type will correctly reflect the strides required
330 to find all of the elements from the parent value. ADDRESS is the
331 address in target memory of value matching TYPE, and DEST is the value
332 we are repacking into. */
333 explicit fortran_lazy_array_repacker_impl (struct type
*type
,
336 : fortran_array_repacker_base_impl (dest
),
340 /* Create a lazy value in target memory representing a single element,
341 then load the element into GDB's memory and copy the contents into the
342 destination value. */
343 void process_element (struct type
*elt_type
, LONGEST elt_off
, bool last_p
)
345 copy_element_to_dest (value_at_lazy (elt_type
, m_addr
+ elt_off
));
349 /* The address in target memory where the parent value starts. */
353 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
354 slices. This class is specialised for repacking an array slice from a
355 previously loaded (non-lazy) array value, as such it fetches the
356 element values from the contents of the parent value. */
357 class fortran_array_repacker_impl
358 : public fortran_array_repacker_base_impl
361 /* Constructor. TYPE is the type for the array slice within the parent
362 value, as such it has stride values as required to find the elements
363 within the original parent value. ADDRESS is the address in target
364 memory of the value matching TYPE. BASE_OFFSET is the offset from
365 the start of VAL's content buffer to the start of the object of TYPE,
366 VAL is the parent object from which we are loading the value, and
367 DEST is the value into which we are repacking. */
368 explicit fortran_array_repacker_impl (struct type
*type
, CORE_ADDR address
,
370 struct value
*val
, struct value
*dest
)
371 : fortran_array_repacker_base_impl (dest
),
372 m_base_offset (base_offset
),
375 gdb_assert (!value_lazy (val
));
378 /* Extract an element of ELT_TYPE at offset (M_BASE_OFFSET + ELT_OFF)
379 from the content buffer of M_VAL then copy this extracted value into
380 the repacked destination value. */
381 void process_element (struct type
*elt_type
, LONGEST elt_off
, bool last_p
)
384 = value_from_component (m_val
, elt_type
, (elt_off
+ m_base_offset
));
385 copy_element_to_dest (elt
);
389 /* The offset into the content buffer of M_VAL to the start of the slice
391 LONGEST m_base_offset
;
393 /* The parent value from which we are extracting a slice. */
397 /* Called from evaluate_subexp_standard to perform array indexing, and
398 sub-range extraction, for Fortran. As well as arrays this function
399 also handles strings as they can be treated like arrays of characters.
400 ARRAY is the array or string being accessed. EXP, POS, and NOSIDE are
401 as for evaluate_subexp_standard, and NARGS is the number of arguments
402 in this access (e.g. 'array (1,2,3)' would be NARGS 3). */
404 static struct value
*
405 fortran_value_subarray (struct value
*array
, struct expression
*exp
,
406 int *pos
, int nargs
, enum noside noside
)
408 type
*original_array_type
= check_typedef (value_type (array
));
409 bool is_string_p
= original_array_type
->code () == TYPE_CODE_STRING
;
411 /* Perform checks for ARRAY not being available. The somewhat overly
412 complex logic here is just to keep backward compatibility with the
413 errors that we used to get before FORTRAN_VALUE_SUBARRAY was
414 rewritten. Maybe a future task would streamline the error messages we
415 get here, and update all the expected test results. */
416 if (exp
->elts
[*pos
].opcode
!= OP_RANGE
)
418 if (type_not_associated (original_array_type
))
419 error (_("no such vector element (vector not associated)"));
420 else if (type_not_allocated (original_array_type
))
421 error (_("no such vector element (vector not allocated)"));
425 if (type_not_associated (original_array_type
))
426 error (_("array not associated"));
427 else if (type_not_allocated (original_array_type
))
428 error (_("array not allocated"));
431 /* First check that the number of dimensions in the type we are slicing
432 matches the number of arguments we were passed. */
433 int ndimensions
= calc_f77_array_dims (original_array_type
);
434 if (nargs
!= ndimensions
)
435 error (_("Wrong number of subscripts"));
437 /* This will be initialised below with the type of the elements held in
439 struct type
*inner_element_type
;
441 /* Extract the types of each array dimension from the original array
442 type. We need these available so we can fill in the default upper and
443 lower bounds if the user requested slice doesn't provide that
444 information. Additionally unpacking the dimensions like this gives us
445 the inner element type. */
446 std::vector
<struct type
*> dim_types
;
448 dim_types
.reserve (ndimensions
);
449 struct type
*type
= original_array_type
;
450 for (int i
= 0; i
< ndimensions
; ++i
)
452 dim_types
.push_back (type
);
453 type
= TYPE_TARGET_TYPE (type
);
455 /* TYPE is now the inner element type of the array, we start the new
456 array slice off as this type, then as we process the requested slice
457 (from the user) we wrap new types around this to build up the final
459 inner_element_type
= type
;
462 /* As we analyse the new slice type we need to understand if the data
463 being referenced is contiguous. Do decide this we must track the size
464 of an element at each dimension of the new slice array. Initially the
465 elements of the inner most dimension of the array are the same inner
466 most elements as the original ARRAY. */
467 LONGEST slice_element_size
= TYPE_LENGTH (inner_element_type
);
469 /* Start off assuming all data is contiguous, this will be set to false
470 if access to any dimension results in non-contiguous data. */
471 bool is_all_contiguous
= true;
473 /* The TOTAL_OFFSET is the distance in bytes from the start of the
474 original ARRAY to the start of the new slice. This is calculated as
475 we process the information from the user. */
476 LONGEST total_offset
= 0;
478 /* A structure representing information about each dimension of the
483 slice_dim (LONGEST l
, LONGEST h
, LONGEST s
, struct type
*idx
)
490 /* The low bound for this dimension of the slice. */
493 /* The high bound for this dimension of the slice. */
496 /* The byte stride for this dimension of the slice. */
502 /* The dimensions of the resulting slice. */
503 std::vector
<slice_dim
> slice_dims
;
505 /* Process the incoming arguments. These arguments are in the reverse
506 order to the array dimensions, that is the first argument refers to
507 the last array dimension. */
508 if (fortran_array_slicing_debug
)
509 debug_printf ("Processing array access:\n");
510 for (int i
= 0; i
< nargs
; ++i
)
512 /* For each dimension of the array the user will have either provided
513 a ranged access with optional lower bound, upper bound, and
514 stride, or the user will have supplied a single index. */
515 struct type
*dim_type
= dim_types
[ndimensions
- (i
+ 1)];
516 if (exp
->elts
[*pos
].opcode
== OP_RANGE
)
519 enum range_flag range_flag
= (enum range_flag
) exp
->elts
[pc
].longconst
;
522 LONGEST low
, high
, stride
;
523 low
= high
= stride
= 0;
525 if ((range_flag
& RANGE_LOW_BOUND_DEFAULT
) == 0)
526 low
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
528 low
= f77_get_lowerbound (dim_type
);
529 if ((range_flag
& RANGE_HIGH_BOUND_DEFAULT
) == 0)
530 high
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
532 high
= f77_get_upperbound (dim_type
);
533 if ((range_flag
& RANGE_HAS_STRIDE
) == RANGE_HAS_STRIDE
)
534 stride
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
539 error (_("stride must not be 0"));
541 /* Get information about this dimension in the original ARRAY. */
542 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
543 struct type
*index_type
= dim_type
->index_type ();
544 LONGEST lb
= f77_get_lowerbound (dim_type
);
545 LONGEST ub
= f77_get_upperbound (dim_type
);
546 LONGEST sd
= index_type
->bit_stride ();
548 sd
= TYPE_LENGTH (target_type
) * 8;
550 if (fortran_array_slicing_debug
)
552 debug_printf ("|-> Range access\n");
553 std::string str
= type_to_string (dim_type
);
554 debug_printf ("| |-> Type: %s\n", str
.c_str ());
555 debug_printf ("| |-> Array:\n");
556 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
557 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
558 debug_printf ("| | |-> Bit stride: %s\n", plongest (sd
));
559 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
/ 8));
560 debug_printf ("| | |-> Type size: %s\n",
561 pulongest (TYPE_LENGTH (dim_type
)));
562 debug_printf ("| | '-> Target type size: %s\n",
563 pulongest (TYPE_LENGTH (target_type
)));
564 debug_printf ("| |-> Accessing:\n");
565 debug_printf ("| | |-> Low bound: %s\n",
567 debug_printf ("| | |-> High bound: %s\n",
569 debug_printf ("| | '-> Element stride: %s\n",
573 /* Check the user hasn't asked for something invalid. */
574 if (high
> ub
|| low
< lb
)
575 error (_("array subscript out of bounds"));
577 /* Calculate what this dimension of the new slice array will look
578 like. OFFSET is the byte offset from the start of the
579 previous (more outer) dimension to the start of this
580 dimension. E_COUNT is the number of elements in this
581 dimension. REMAINDER is the number of elements remaining
582 between the last included element and the upper bound. For
583 example an access '1:6:2' will include elements 1, 3, 5 and
584 have a remainder of 1 (element #6). */
585 LONGEST lowest
= std::min (low
, high
);
586 LONGEST offset
= (sd
/ 8) * (lowest
- lb
);
587 LONGEST e_count
= std::abs (high
- low
) + 1;
588 e_count
= (e_count
+ (std::abs (stride
) - 1)) / std::abs (stride
);
590 LONGEST new_high
= new_low
+ e_count
- 1;
591 LONGEST new_stride
= (sd
* stride
) / 8;
592 LONGEST last_elem
= low
+ ((e_count
- 1) * stride
);
593 LONGEST remainder
= high
- last_elem
;
596 offset
+= std::abs (remainder
) * TYPE_LENGTH (target_type
);
598 error (_("incorrect stride and boundary combination"));
601 error (_("incorrect stride and boundary combination"));
603 /* Is the data within this dimension contiguous? It is if the
604 newly computed stride is the same size as a single element of
606 bool is_dim_contiguous
= (new_stride
== slice_element_size
);
607 is_all_contiguous
&= is_dim_contiguous
;
609 if (fortran_array_slicing_debug
)
611 debug_printf ("| '-> Results:\n");
612 debug_printf ("| |-> Offset = %s\n", plongest (offset
));
613 debug_printf ("| |-> Elements = %s\n", plongest (e_count
));
614 debug_printf ("| |-> Low bound = %s\n", plongest (new_low
));
615 debug_printf ("| |-> High bound = %s\n",
616 plongest (new_high
));
617 debug_printf ("| |-> Byte stride = %s\n",
618 plongest (new_stride
));
619 debug_printf ("| |-> Last element = %s\n",
620 plongest (last_elem
));
621 debug_printf ("| |-> Remainder = %s\n",
622 plongest (remainder
));
623 debug_printf ("| '-> Contiguous = %s\n",
624 (is_dim_contiguous
? "Yes" : "No"));
627 /* Figure out how big (in bytes) an element of this dimension of
628 the new array slice will be. */
629 slice_element_size
= std::abs (new_stride
* e_count
);
631 slice_dims
.emplace_back (new_low
, new_high
, new_stride
,
634 /* Update the total offset. */
635 total_offset
+= offset
;
639 /* There is a single index for this dimension. */
641 = value_as_long (evaluate_subexp_with_coercion (exp
, pos
, noside
));
643 /* Get information about this dimension in the original ARRAY. */
644 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
645 struct type
*index_type
= dim_type
->index_type ();
646 LONGEST lb
= f77_get_lowerbound (dim_type
);
647 LONGEST ub
= f77_get_upperbound (dim_type
);
648 LONGEST sd
= index_type
->bit_stride () / 8;
650 sd
= TYPE_LENGTH (target_type
);
652 if (fortran_array_slicing_debug
)
654 debug_printf ("|-> Index access\n");
655 std::string str
= type_to_string (dim_type
);
656 debug_printf ("| |-> Type: %s\n", str
.c_str ());
657 debug_printf ("| |-> Array:\n");
658 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
659 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
660 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
));
661 debug_printf ("| | |-> Type size: %s\n",
662 pulongest (TYPE_LENGTH (dim_type
)));
663 debug_printf ("| | '-> Target type size: %s\n",
664 pulongest (TYPE_LENGTH (target_type
)));
665 debug_printf ("| '-> Accessing:\n");
666 debug_printf ("| '-> Index: %s\n",
670 /* If the array has actual content then check the index is in
671 bounds. An array without content (an unbound array) doesn't
672 have a known upper bound, so don't error check in that
675 || (dim_type
->index_type ()->bounds ()->high
.kind () != PROP_UNDEFINED
677 || (VALUE_LVAL (array
) != lval_memory
678 && dim_type
->index_type ()->bounds ()->high
.kind () == PROP_UNDEFINED
))
680 if (type_not_associated (dim_type
))
681 error (_("no such vector element (vector not associated)"));
682 else if (type_not_allocated (dim_type
))
683 error (_("no such vector element (vector not allocated)"));
685 error (_("no such vector element"));
688 /* Calculate using the type stride, not the target type size. */
689 LONGEST offset
= sd
* (index
- lb
);
690 total_offset
+= offset
;
694 if (noside
== EVAL_SKIP
)
697 /* Build a type that represents the new array slice in the target memory
698 of the original ARRAY, this type makes use of strides to correctly
699 find only those elements that are part of the new slice. */
700 struct type
*array_slice_type
= inner_element_type
;
701 for (const auto &d
: slice_dims
)
703 /* Create the range. */
704 dynamic_prop p_low
, p_high
, p_stride
;
706 p_low
.set_const_val (d
.low
);
707 p_high
.set_const_val (d
.high
);
708 p_stride
.set_const_val (d
.stride
);
710 struct type
*new_range
711 = create_range_type_with_stride ((struct type
*) NULL
,
712 TYPE_TARGET_TYPE (d
.index
),
713 &p_low
, &p_high
, 0, &p_stride
,
716 = create_array_type (nullptr, array_slice_type
, new_range
);
719 if (fortran_array_slicing_debug
)
721 debug_printf ("'-> Final result:\n");
722 debug_printf (" |-> Type: %s\n",
723 type_to_string (array_slice_type
).c_str ());
724 debug_printf (" |-> Total offset: %s\n",
725 plongest (total_offset
));
726 debug_printf (" |-> Base address: %s\n",
727 core_addr_to_string (value_address (array
)));
728 debug_printf (" '-> Contiguous = %s\n",
729 (is_all_contiguous
? "Yes" : "No"));
732 /* Should we repack this array slice? */
733 if (!is_all_contiguous
&& (repack_array_slices
|| is_string_p
))
735 /* Build a type for the repacked slice. */
736 struct type
*repacked_array_type
= inner_element_type
;
737 for (const auto &d
: slice_dims
)
739 /* Create the range. */
740 dynamic_prop p_low
, p_high
, p_stride
;
742 p_low
.set_const_val (d
.low
);
743 p_high
.set_const_val (d
.high
);
744 p_stride
.set_const_val (TYPE_LENGTH (repacked_array_type
));
746 struct type
*new_range
747 = create_range_type_with_stride ((struct type
*) NULL
,
748 TYPE_TARGET_TYPE (d
.index
),
749 &p_low
, &p_high
, 0, &p_stride
,
752 = create_array_type (nullptr, repacked_array_type
, new_range
);
755 /* Now copy the elements from the original ARRAY into the packed
757 struct value
*dest
= allocate_value (repacked_array_type
);
758 if (value_lazy (array
)
759 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
760 > TYPE_LENGTH (check_typedef (value_type (array
)))))
762 fortran_array_walker
<fortran_lazy_array_repacker_impl
> p
763 (array_slice_type
, value_address (array
) + total_offset
, dest
);
768 fortran_array_walker
<fortran_array_repacker_impl
> p
769 (array_slice_type
, value_address (array
) + total_offset
,
770 total_offset
, array
, dest
);
777 if (VALUE_LVAL (array
) == lval_memory
)
779 /* If the value we're taking a slice from is not yet loaded, or
780 the requested slice is outside the values content range then
781 just create a new lazy value pointing at the memory where the
782 contents we're looking for exist. */
783 if (value_lazy (array
)
784 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
785 > TYPE_LENGTH (check_typedef (value_type (array
)))))
786 array
= value_at_lazy (array_slice_type
,
787 value_address (array
) + total_offset
);
789 array
= value_from_contents_and_address (array_slice_type
,
790 (value_contents (array
)
792 (value_address (array
)
795 else if (!value_lazy (array
))
796 array
= value_from_component (array
, array_slice_type
, total_offset
);
798 error (_("cannot subscript arrays that are not in memory"));
804 /* Evaluate FORTRAN_ASSOCIATED expressions. Both GDBARCH and LANG are
805 extracted from the expression being evaluated. POINTER is the required
806 first argument to the 'associated' keyword, and TARGET is the optional
807 second argument, this will be nullptr if the user only passed one
808 argument to their use of 'associated'. */
810 static struct value
*
811 fortran_associated (struct gdbarch
*gdbarch
, const language_defn
*lang
,
812 struct value
*pointer
, struct value
*target
= nullptr)
814 struct type
*result_type
= language_bool_type (lang
, gdbarch
);
816 /* All Fortran pointers should have the associated property, this is
817 how we know the pointer is pointing at something or not. */
818 struct type
*pointer_type
= check_typedef (value_type (pointer
));
819 if (TYPE_ASSOCIATED_PROP (pointer_type
) == nullptr
820 && pointer_type
->code () != TYPE_CODE_PTR
)
821 error (_("ASSOCIATED can only be applied to pointers"));
823 /* Get an address from POINTER. Fortran (or at least gfortran) models
824 array pointers as arrays with a dynamic data address, so we need to
825 use two approaches here, for real pointers we take the contents of the
826 pointer as an address. For non-pointers we take the address of the
828 CORE_ADDR pointer_addr
;
829 if (pointer_type
->code () == TYPE_CODE_PTR
)
830 pointer_addr
= value_as_address (pointer
);
832 pointer_addr
= value_address (pointer
);
834 /* The single argument case, is POINTER associated with anything? */
835 if (target
== nullptr)
837 bool is_associated
= false;
839 /* If POINTER is an actual pointer and doesn't have an associated
840 property then we need to figure out whether this pointer is
841 associated by looking at the value of the pointer itself. We make
842 the assumption that a non-associated pointer will be set to 0.
843 This is probably true for most targets, but might not be true for
845 if (pointer_type
->code () == TYPE_CODE_PTR
846 && TYPE_ASSOCIATED_PROP (pointer_type
) == nullptr)
847 is_associated
= (pointer_addr
!= 0);
849 is_associated
= !type_not_associated (pointer_type
);
850 return value_from_longest (result_type
, is_associated
? 1 : 0);
853 /* The two argument case, is POINTER associated with TARGET? */
855 struct type
*target_type
= check_typedef (value_type (target
));
857 struct type
*pointer_target_type
;
858 if (pointer_type
->code () == TYPE_CODE_PTR
)
859 pointer_target_type
= TYPE_TARGET_TYPE (pointer_type
);
861 pointer_target_type
= pointer_type
;
863 struct type
*target_target_type
;
864 if (target_type
->code () == TYPE_CODE_PTR
)
865 target_target_type
= TYPE_TARGET_TYPE (target_type
);
867 target_target_type
= target_type
;
869 if (pointer_target_type
->code () != target_target_type
->code ()
870 || (pointer_target_type
->code () != TYPE_CODE_ARRAY
871 && (TYPE_LENGTH (pointer_target_type
)
872 != TYPE_LENGTH (target_target_type
))))
873 error (_("arguments to associated must be of same type and kind"));
875 /* If TARGET is not in memory, or the original pointer is specifically
876 known to be not associated with anything, then the answer is obviously
877 false. Alternatively, if POINTER is an actual pointer and has no
878 associated property, then we have to check if its associated by
879 looking the value of the pointer itself. We make the assumption that
880 a non-associated pointer will be set to 0. This is probably true for
881 most targets, but might not be true for everyone. */
882 if (value_lval_const (target
) != lval_memory
883 || type_not_associated (pointer_type
)
884 || (TYPE_ASSOCIATED_PROP (pointer_type
) == nullptr
885 && pointer_type
->code () == TYPE_CODE_PTR
886 && pointer_addr
== 0))
887 return value_from_longest (result_type
, 0);
889 /* See the comment for POINTER_ADDR above. */
890 CORE_ADDR target_addr
;
891 if (target_type
->code () == TYPE_CODE_PTR
)
892 target_addr
= value_as_address (target
);
894 target_addr
= value_address (target
);
896 /* Wrap the following checks inside a do { ... } while (false) loop so
897 that we can use `break' to jump out of the loop. */
898 bool is_associated
= false;
901 /* If the addresses are different then POINTER is definitely not
902 pointing at TARGET. */
903 if (pointer_addr
!= target_addr
)
906 /* If POINTER is a real pointer (i.e. not an array pointer, which are
907 implemented as arrays with a dynamic content address), then this
908 is all the checking that is needed. */
909 if (pointer_type
->code () == TYPE_CODE_PTR
)
911 is_associated
= true;
915 /* We have an array pointer. Check the number of dimensions. */
916 int pointer_dims
= calc_f77_array_dims (pointer_type
);
917 int target_dims
= calc_f77_array_dims (target_type
);
918 if (pointer_dims
!= target_dims
)
921 /* Now check that every dimension has the same upper bound, lower
922 bound, and stride value. */
924 while (dim
< pointer_dims
)
926 LONGEST pointer_lowerbound
, pointer_upperbound
, pointer_stride
;
927 LONGEST target_lowerbound
, target_upperbound
, target_stride
;
929 pointer_type
= check_typedef (pointer_type
);
930 target_type
= check_typedef (target_type
);
932 struct type
*pointer_range
= pointer_type
->index_type ();
933 struct type
*target_range
= target_type
->index_type ();
935 if (!get_discrete_bounds (pointer_range
, &pointer_lowerbound
,
936 &pointer_upperbound
))
939 if (!get_discrete_bounds (target_range
, &target_lowerbound
,
943 if (pointer_lowerbound
!= target_lowerbound
944 || pointer_upperbound
!= target_upperbound
)
947 /* Figure out the stride (in bits) for both pointer and target.
948 If either doesn't have a stride then we take the element size,
949 but we need to convert to bits (hence the * 8). */
950 pointer_stride
= pointer_range
->bounds ()->bit_stride ();
951 if (pointer_stride
== 0)
953 = type_length_units (check_typedef
954 (TYPE_TARGET_TYPE (pointer_type
))) * 8;
955 target_stride
= target_range
->bounds ()->bit_stride ();
956 if (target_stride
== 0)
958 = type_length_units (check_typedef
959 (TYPE_TARGET_TYPE (target_type
))) * 8;
960 if (pointer_stride
!= target_stride
)
966 if (dim
< pointer_dims
)
969 is_associated
= true;
973 return value_from_longest (result_type
, is_associated
? 1 : 0);
977 /* Special expression evaluation cases for Fortran. */
979 static struct value
*
980 evaluate_subexp_f (struct type
*expect_type
, struct expression
*exp
,
981 int *pos
, enum noside noside
)
983 struct value
*arg1
= NULL
, *arg2
= NULL
;
990 op
= exp
->elts
[pc
].opcode
;
996 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
999 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1000 if (noside
== EVAL_SKIP
)
1001 return eval_skip_value (exp
);
1002 type
= value_type (arg1
);
1003 switch (type
->code ())
1008 = fabs (target_float_to_host_double (value_contents (arg1
),
1009 value_type (arg1
)));
1010 return value_from_host_double (type
, d
);
1014 LONGEST l
= value_as_long (arg1
);
1016 return value_from_longest (type
, l
);
1019 error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type
));
1022 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1023 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1024 if (noside
== EVAL_SKIP
)
1025 return eval_skip_value (exp
);
1026 type
= value_type (arg1
);
1027 if (type
->code () != value_type (arg2
)->code ())
1028 error (_("non-matching types for parameters to MOD ()"));
1029 switch (type
->code ())
1034 = target_float_to_host_double (value_contents (arg1
),
1037 = target_float_to_host_double (value_contents (arg2
),
1039 double d3
= fmod (d1
, d2
);
1040 return value_from_host_double (type
, d3
);
1044 LONGEST v1
= value_as_long (arg1
);
1045 LONGEST v2
= value_as_long (arg2
);
1047 error (_("calling MOD (N, 0) is undefined"));
1048 LONGEST v3
= v1
- (v1
/ v2
) * v2
;
1049 return value_from_longest (value_type (arg1
), v3
);
1052 error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type
));
1054 case UNOP_FORTRAN_CEILING
:
1056 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1057 if (noside
== EVAL_SKIP
)
1058 return eval_skip_value (exp
);
1059 type
= value_type (arg1
);
1060 if (type
->code () != TYPE_CODE_FLT
)
1061 error (_("argument to CEILING must be of type float"));
1063 = target_float_to_host_double (value_contents (arg1
),
1066 return value_from_host_double (type
, val
);
1069 case UNOP_FORTRAN_FLOOR
:
1071 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1072 if (noside
== EVAL_SKIP
)
1073 return eval_skip_value (exp
);
1074 type
= value_type (arg1
);
1075 if (type
->code () != TYPE_CODE_FLT
)
1076 error (_("argument to FLOOR must be of type float"));
1078 = target_float_to_host_double (value_contents (arg1
),
1081 return value_from_host_double (type
, val
);
1084 case UNOP_FORTRAN_ALLOCATED
:
1086 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1087 if (noside
== EVAL_SKIP
)
1088 return eval_skip_value (exp
);
1089 type
= check_typedef (value_type (arg1
));
1090 if (type
->code () != TYPE_CODE_ARRAY
)
1091 error (_("ALLOCATED can only be applied to arrays"));
1092 struct type
*result_type
1093 = builtin_f_type (exp
->gdbarch
)->builtin_logical
;
1094 LONGEST result_value
= type_not_allocated (type
) ? 0 : 1;
1095 return value_from_longest (result_type
, result_value
);
1098 case BINOP_FORTRAN_MODULO
:
1100 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1101 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1102 if (noside
== EVAL_SKIP
)
1103 return eval_skip_value (exp
);
1104 type
= value_type (arg1
);
1105 if (type
->code () != value_type (arg2
)->code ())
1106 error (_("non-matching types for parameters to MODULO ()"));
1107 /* MODULO(A, P) = A - FLOOR (A / P) * P */
1108 switch (type
->code ())
1112 LONGEST a
= value_as_long (arg1
);
1113 LONGEST p
= value_as_long (arg2
);
1114 LONGEST result
= a
- (a
/ p
) * p
;
1115 if (result
!= 0 && (a
< 0) != (p
< 0))
1117 return value_from_longest (value_type (arg1
), result
);
1122 = target_float_to_host_double (value_contents (arg1
),
1125 = target_float_to_host_double (value_contents (arg2
),
1127 double result
= fmod (a
, p
);
1128 if (result
!= 0 && (a
< 0.0) != (p
< 0.0))
1130 return value_from_host_double (type
, result
);
1133 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type
));
1136 case FORTRAN_LBOUND
:
1137 case FORTRAN_UBOUND
:
1139 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1142 /* This assertion should be enforced by the expression parser. */
1143 gdb_assert (nargs
== 1 || nargs
== 2);
1145 bool lbound_p
= op
== FORTRAN_LBOUND
;
1147 /* Check that the first argument is array like. */
1148 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1149 type
= check_typedef (value_type (arg1
));
1150 if (type
->code () != TYPE_CODE_ARRAY
)
1153 error (_("LBOUND can only be applied to arrays"));
1155 error (_("UBOUND can only be applied to arrays"));
1159 return fortran_bounds_all_dims (lbound_p
, exp
->gdbarch
, arg1
);
1161 /* User asked for the bounds of a specific dimension of the array. */
1162 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1163 type
= check_typedef (value_type (arg2
));
1164 if (type
->code () != TYPE_CODE_INT
)
1167 error (_("LBOUND second argument should be an integer"));
1169 error (_("UBOUND second argument should be an integer"));
1172 return fortran_bounds_for_dimension (lbound_p
, exp
->gdbarch
, arg1
,
1177 case FORTRAN_ASSOCIATED
:
1179 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1182 /* This assertion should be enforced by the expression parser. */
1183 gdb_assert (nargs
== 1 || nargs
== 2);
1185 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1189 if (noside
== EVAL_SKIP
)
1190 return eval_skip_value (exp
);
1191 return fortran_associated (exp
->gdbarch
, exp
->language_defn
,
1195 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1196 if (noside
== EVAL_SKIP
)
1197 return eval_skip_value (exp
);
1198 return fortran_associated (exp
->gdbarch
, exp
->language_defn
,
1203 case BINOP_FORTRAN_CMPLX
:
1204 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1205 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1206 if (noside
== EVAL_SKIP
)
1207 return eval_skip_value (exp
);
1208 type
= builtin_f_type(exp
->gdbarch
)->builtin_complex_s16
;
1209 return value_literal_complex (arg1
, arg2
, type
);
1211 case UNOP_FORTRAN_KIND
:
1212 arg1
= evaluate_subexp (NULL
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
1213 type
= value_type (arg1
);
1215 switch (type
->code ())
1217 case TYPE_CODE_STRUCT
:
1218 case TYPE_CODE_UNION
:
1219 case TYPE_CODE_MODULE
:
1220 case TYPE_CODE_FUNC
:
1221 error (_("argument to kind must be an intrinsic type"));
1224 if (!TYPE_TARGET_TYPE (type
))
1225 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1226 TYPE_LENGTH (type
));
1227 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1228 TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
1231 case OP_F77_UNDETERMINED_ARGLIST
:
1232 /* Remember that in F77, functions, substring ops and array subscript
1233 operations cannot be disambiguated at parse time. We have made
1234 all array subscript operations, substring operations as well as
1235 function calls come here and we now have to discover what the heck
1236 this thing actually was. If it is a function, we process just as
1237 if we got an OP_FUNCALL. */
1238 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1241 /* First determine the type code we are dealing with. */
1242 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1243 type
= check_typedef (value_type (arg1
));
1244 enum type_code code
= type
->code ();
1246 if (code
== TYPE_CODE_PTR
)
1248 /* Fortran always passes variable to subroutines as pointer.
1249 So we need to look into its target type to see if it is
1250 array, string or function. If it is, we need to switch
1251 to the target value the original one points to. */
1252 struct type
*target_type
= check_typedef (TYPE_TARGET_TYPE (type
));
1254 if (target_type
->code () == TYPE_CODE_ARRAY
1255 || target_type
->code () == TYPE_CODE_STRING
1256 || target_type
->code () == TYPE_CODE_FUNC
)
1258 arg1
= value_ind (arg1
);
1259 type
= check_typedef (value_type (arg1
));
1260 code
= type
->code ();
1266 case TYPE_CODE_ARRAY
:
1267 case TYPE_CODE_STRING
:
1268 return fortran_value_subarray (arg1
, exp
, pos
, nargs
, noside
);
1271 case TYPE_CODE_FUNC
:
1272 case TYPE_CODE_INTERNAL_FUNCTION
:
1274 /* It's a function call. Allocate arg vector, including
1275 space for the function to be called in argvec[0] and a
1276 termination NULL. */
1277 struct value
**argvec
= (struct value
**)
1278 alloca (sizeof (struct value
*) * (nargs
+ 2));
1281 for (; tem
<= nargs
; tem
++)
1283 bool is_internal_func
= (code
== TYPE_CODE_INTERNAL_FUNCTION
);
1285 = fortran_prepare_argument (exp
, pos
, (tem
- 1),
1287 value_type (arg1
), noside
);
1289 argvec
[tem
] = 0; /* signal end of arglist */
1290 if (noside
== EVAL_SKIP
)
1291 return eval_skip_value (exp
);
1292 return evaluate_subexp_do_call (exp
, noside
, argvec
[0],
1293 gdb::make_array_view (argvec
+ 1,
1299 error (_("Cannot perform substring on this type"));
1303 /* Should be unreachable. */
1307 /* Special expression lengths for Fortran. */
1310 operator_length_f (const struct expression
*exp
, int pc
, int *oplenp
,
1316 switch (exp
->elts
[pc
- 1].opcode
)
1319 operator_length_standard (exp
, pc
, oplenp
, argsp
);
1322 case UNOP_FORTRAN_KIND
:
1323 case UNOP_FORTRAN_FLOOR
:
1324 case UNOP_FORTRAN_CEILING
:
1325 case UNOP_FORTRAN_ALLOCATED
:
1330 case BINOP_FORTRAN_CMPLX
:
1331 case BINOP_FORTRAN_MODULO
:
1336 case FORTRAN_ASSOCIATED
:
1337 case FORTRAN_LBOUND
:
1338 case FORTRAN_UBOUND
:
1340 args
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
1343 case OP_F77_UNDETERMINED_ARGLIST
:
1345 args
= 1 + longest_to_int (exp
->elts
[pc
- 2].longconst
);
1353 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1354 the extra argument NAME which is the text that should be printed as the
1355 name of this operation. */
1358 print_unop_subexp_f (struct expression
*exp
, int *pos
,
1359 struct ui_file
*stream
, enum precedence prec
,
1363 fprintf_filtered (stream
, "%s(", name
);
1364 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1365 fputs_filtered (")", stream
);
1368 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1369 the extra argument NAME which is the text that should be printed as the
1370 name of this operation. */
1373 print_binop_subexp_f (struct expression
*exp
, int *pos
,
1374 struct ui_file
*stream
, enum precedence prec
,
1378 fprintf_filtered (stream
, "%s(", name
);
1379 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1380 fputs_filtered (",", stream
);
1381 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1382 fputs_filtered (")", stream
);
1385 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1386 the extra argument NAME which is the text that should be printed as the
1387 name of this operation. */
1390 print_unop_or_binop_subexp_f (struct expression
*exp
, int *pos
,
1391 struct ui_file
*stream
, enum precedence prec
,
1394 unsigned nargs
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
);
1396 fprintf_filtered (stream
, "%s (", name
);
1397 for (unsigned tem
= 0; tem
< nargs
; tem
++)
1400 fputs_filtered (", ", stream
);
1401 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
1403 fputs_filtered (")", stream
);
1406 /* Special expression printing for Fortran. */
1409 print_subexp_f (struct expression
*exp
, int *pos
,
1410 struct ui_file
*stream
, enum precedence prec
)
1413 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
1418 print_subexp_standard (exp
, pos
, stream
, prec
);
1421 case UNOP_FORTRAN_KIND
:
1422 print_unop_subexp_f (exp
, pos
, stream
, prec
, "KIND");
1425 case UNOP_FORTRAN_FLOOR
:
1426 print_unop_subexp_f (exp
, pos
, stream
, prec
, "FLOOR");
1429 case UNOP_FORTRAN_CEILING
:
1430 print_unop_subexp_f (exp
, pos
, stream
, prec
, "CEILING");
1433 case UNOP_FORTRAN_ALLOCATED
:
1434 print_unop_subexp_f (exp
, pos
, stream
, prec
, "ALLOCATED");
1437 case BINOP_FORTRAN_CMPLX
:
1438 print_binop_subexp_f (exp
, pos
, stream
, prec
, "CMPLX");
1441 case BINOP_FORTRAN_MODULO
:
1442 print_binop_subexp_f (exp
, pos
, stream
, prec
, "MODULO");
1445 case FORTRAN_ASSOCIATED
:
1446 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "ASSOCIATED");
1449 case FORTRAN_LBOUND
:
1450 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "LBOUND");
1453 case FORTRAN_UBOUND
:
1454 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "UBOUND");
1457 case OP_F77_UNDETERMINED_ARGLIST
:
1459 print_subexp_funcall (exp
, pos
, stream
);
1464 /* Special expression dumping for Fortran. */
1467 dump_subexp_body_f (struct expression
*exp
,
1468 struct ui_file
*stream
, int elt
)
1470 int opcode
= exp
->elts
[elt
].opcode
;
1471 int oplen
, nargs
, i
;
1476 return dump_subexp_body_standard (exp
, stream
, elt
);
1478 case UNOP_FORTRAN_KIND
:
1479 case UNOP_FORTRAN_FLOOR
:
1480 case UNOP_FORTRAN_CEILING
:
1481 case UNOP_FORTRAN_ALLOCATED
:
1482 case BINOP_FORTRAN_CMPLX
:
1483 case BINOP_FORTRAN_MODULO
:
1484 operator_length_f (exp
, (elt
+ 1), &oplen
, &nargs
);
1487 case FORTRAN_ASSOCIATED
:
1488 case FORTRAN_LBOUND
:
1489 case FORTRAN_UBOUND
:
1490 operator_length_f (exp
, (elt
+ 3), &oplen
, &nargs
);
1493 case OP_F77_UNDETERMINED_ARGLIST
:
1494 return dump_subexp_body_funcall (exp
, stream
, elt
+ 1);
1498 for (i
= 0; i
< nargs
; i
+= 1)
1499 elt
= dump_subexp (exp
, stream
, elt
);
1504 /* Special expression checking for Fortran. */
1507 operator_check_f (struct expression
*exp
, int pos
,
1508 int (*objfile_func
) (struct objfile
*objfile
,
1512 const union exp_element
*const elts
= exp
->elts
;
1514 switch (elts
[pos
].opcode
)
1516 case UNOP_FORTRAN_KIND
:
1517 case UNOP_FORTRAN_FLOOR
:
1518 case UNOP_FORTRAN_CEILING
:
1519 case UNOP_FORTRAN_ALLOCATED
:
1520 case BINOP_FORTRAN_CMPLX
:
1521 case BINOP_FORTRAN_MODULO
:
1522 case FORTRAN_ASSOCIATED
:
1523 case FORTRAN_LBOUND
:
1524 case FORTRAN_UBOUND
:
1525 /* Any references to objfiles are held in the arguments to this
1526 expression, not within the expression itself, so no additional
1527 checking is required here, the outer expression iteration code
1528 will take care of checking each argument. */
1532 return operator_check_standard (exp
, pos
, objfile_func
, data
);
1538 /* Expression processing for Fortran. */
1539 const struct exp_descriptor
f_language::exp_descriptor_tab
=
1548 /* See language.h. */
1551 f_language::language_arch_info (struct gdbarch
*gdbarch
,
1552 struct language_arch_info
*lai
) const
1554 const struct builtin_f_type
*builtin
= builtin_f_type (gdbarch
);
1556 /* Helper function to allow shorter lines below. */
1557 auto add
= [&] (struct type
* t
)
1559 lai
->add_primitive_type (t
);
1562 add (builtin
->builtin_character
);
1563 add (builtin
->builtin_logical
);
1564 add (builtin
->builtin_logical_s1
);
1565 add (builtin
->builtin_logical_s2
);
1566 add (builtin
->builtin_logical_s8
);
1567 add (builtin
->builtin_real
);
1568 add (builtin
->builtin_real_s8
);
1569 add (builtin
->builtin_real_s16
);
1570 add (builtin
->builtin_complex_s8
);
1571 add (builtin
->builtin_complex_s16
);
1572 add (builtin
->builtin_void
);
1574 lai
->set_string_char_type (builtin
->builtin_character
);
1575 lai
->set_bool_type (builtin
->builtin_logical_s2
, "logical");
1578 /* See language.h. */
1581 f_language::search_name_hash (const char *name
) const
1583 return cp_search_name_hash (name
);
1586 /* See language.h. */
1589 f_language::lookup_symbol_nonlocal (const char *name
,
1590 const struct block
*block
,
1591 const domain_enum domain
) const
1593 return cp_lookup_symbol_nonlocal (this, name
, block
, domain
);
1596 /* See language.h. */
1598 symbol_name_matcher_ftype
*
1599 f_language::get_symbol_name_matcher_inner
1600 (const lookup_name_info
&lookup_name
) const
1602 return cp_get_symbol_name_matcher (lookup_name
);
1605 /* Single instance of the Fortran language class. */
1607 static f_language f_language_defn
;
1610 build_fortran_types (struct gdbarch
*gdbarch
)
1612 struct builtin_f_type
*builtin_f_type
1613 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_f_type
);
1615 builtin_f_type
->builtin_void
1616 = arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
, "void");
1618 builtin_f_type
->builtin_character
1619 = arch_type (gdbarch
, TYPE_CODE_CHAR
, TARGET_CHAR_BIT
, "character");
1621 builtin_f_type
->builtin_logical_s1
1622 = arch_boolean_type (gdbarch
, TARGET_CHAR_BIT
, 1, "logical*1");
1624 builtin_f_type
->builtin_integer_s2
1625 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
), 0,
1628 builtin_f_type
->builtin_integer_s8
1629 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 0,
1632 builtin_f_type
->builtin_logical_s2
1633 = arch_boolean_type (gdbarch
, gdbarch_short_bit (gdbarch
), 1,
1636 builtin_f_type
->builtin_logical_s8
1637 = arch_boolean_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 1,
1640 builtin_f_type
->builtin_integer
1641 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 0,
1644 builtin_f_type
->builtin_logical
1645 = arch_boolean_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1,
1648 builtin_f_type
->builtin_real
1649 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
1650 "real", gdbarch_float_format (gdbarch
));
1651 builtin_f_type
->builtin_real_s8
1652 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
1653 "real*8", gdbarch_double_format (gdbarch
));
1654 auto fmt
= gdbarch_floatformat_for_type (gdbarch
, "real(kind=16)", 128);
1656 builtin_f_type
->builtin_real_s16
1657 = arch_float_type (gdbarch
, 128, "real*16", fmt
);
1658 else if (gdbarch_long_double_bit (gdbarch
) == 128)
1659 builtin_f_type
->builtin_real_s16
1660 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
1661 "real*16", gdbarch_long_double_format (gdbarch
));
1663 builtin_f_type
->builtin_real_s16
1664 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 128, "real*16");
1666 builtin_f_type
->builtin_complex_s8
1667 = init_complex_type ("complex*8", builtin_f_type
->builtin_real
);
1668 builtin_f_type
->builtin_complex_s16
1669 = init_complex_type ("complex*16", builtin_f_type
->builtin_real_s8
);
1671 if (builtin_f_type
->builtin_real_s16
->code () == TYPE_CODE_ERROR
)
1672 builtin_f_type
->builtin_complex_s32
1673 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 256, "complex*32");
1675 builtin_f_type
->builtin_complex_s32
1676 = init_complex_type ("complex*32", builtin_f_type
->builtin_real_s16
);
1678 return builtin_f_type
;
1681 static struct gdbarch_data
*f_type_data
;
1683 const struct builtin_f_type
*
1684 builtin_f_type (struct gdbarch
*gdbarch
)
1686 return (const struct builtin_f_type
*) gdbarch_data (gdbarch
, f_type_data
);
1689 /* Command-list for the "set/show fortran" prefix command. */
1690 static struct cmd_list_element
*set_fortran_list
;
1691 static struct cmd_list_element
*show_fortran_list
;
1693 void _initialize_f_language ();
1695 _initialize_f_language ()
1697 f_type_data
= gdbarch_data_register_post_init (build_fortran_types
);
1699 add_basic_prefix_cmd ("fortran", no_class
,
1700 _("Prefix command for changing Fortran-specific settings."),
1701 &set_fortran_list
, "set fortran ", 0, &setlist
);
1703 add_show_prefix_cmd ("fortran", no_class
,
1704 _("Generic command for showing Fortran-specific settings."),
1705 &show_fortran_list
, "show fortran ", 0, &showlist
);
1707 add_setshow_boolean_cmd ("repack-array-slices", class_vars
,
1708 &repack_array_slices
, _("\
1709 Enable or disable repacking of non-contiguous array slices."), _("\
1710 Show whether non-contiguous array slices are repacked."), _("\
1711 When the user requests a slice of a Fortran array then we can either return\n\
1712 a descriptor that describes the array in place (using the original array data\n\
1713 in its existing location) or the original data can be repacked (copied) to a\n\
1716 When the content of the array slice is contiguous within the original array\n\
1717 then the result will never be repacked, but when the data for the new array\n\
1718 is non-contiguous within the original array repacking will only be performed\n\
1719 when this setting is on."),
1721 show_repack_array_slices
,
1722 &set_fortran_list
, &show_fortran_list
);
1724 /* Debug Fortran's array slicing logic. */
1725 add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance
,
1726 &fortran_array_slicing_debug
, _("\
1727 Set debugging of Fortran array slicing."), _("\
1728 Show debugging of Fortran array slicing."), _("\
1729 When on, debugging of Fortran array slicing is enabled."),
1731 show_fortran_array_slicing_debug
,
1732 &setdebuglist
, &showdebuglist
);
1735 /* Ensures that function argument VALUE is in the appropriate form to
1736 pass to a Fortran function. Returns a possibly new value that should
1737 be used instead of VALUE.
1739 When IS_ARTIFICIAL is true this indicates an artificial argument,
1740 e.g. hidden string lengths which the GNU Fortran argument passing
1741 convention specifies as being passed by value.
1743 When IS_ARTIFICIAL is false, the argument is passed by pointer. If the
1744 value is already in target memory then return a value that is a pointer
1745 to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate
1746 space in the target, copy VALUE in, and return a pointer to the in
1749 static struct value
*
1750 fortran_argument_convert (struct value
*value
, bool is_artificial
)
1754 /* If the value is not in the inferior e.g. registers values,
1755 convenience variables and user input. */
1756 if (VALUE_LVAL (value
) != lval_memory
)
1758 struct type
*type
= value_type (value
);
1759 const int length
= TYPE_LENGTH (type
);
1760 const CORE_ADDR addr
1761 = value_as_long (value_allocate_space_in_inferior (length
));
1762 write_memory (addr
, value_contents (value
), length
);
1764 = value_from_contents_and_address (type
, value_contents (value
),
1766 return value_addr (val
);
1769 return value_addr (value
); /* Program variables, e.g. arrays. */
1774 /* Prepare (and return) an argument value ready for an inferior function
1775 call to a Fortran function. EXP and POS are the expressions describing
1776 the argument to prepare. ARG_NUM is the argument number being
1777 prepared, with 0 being the first argument and so on. FUNC_TYPE is the
1778 type of the function being called.
1780 IS_INTERNAL_CALL_P is true if this is a call to a function of type
1781 TYPE_CODE_INTERNAL_FUNCTION, otherwise this parameter is false.
1783 NOSIDE has its usual meaning for expression parsing (see eval.c).
1785 Arguments in Fortran are normally passed by address, we coerce the
1786 arguments here rather than in value_arg_coerce as otherwise the call to
1787 malloc (to place the non-lvalue parameters in target memory) is hit by
1788 this Fortran specific logic. This results in malloc being called with a
1789 pointer to an integer followed by an attempt to malloc the arguments to
1790 malloc in target memory. Infinite recursion ensues. */
1793 fortran_prepare_argument (struct expression
*exp
, int *pos
,
1794 int arg_num
, bool is_internal_call_p
,
1795 struct type
*func_type
, enum noside noside
)
1797 if (is_internal_call_p
)
1798 return evaluate_subexp_with_coercion (exp
, pos
, noside
);
1800 bool is_artificial
= ((arg_num
>= func_type
->num_fields ())
1802 : TYPE_FIELD_ARTIFICIAL (func_type
, arg_num
));
1804 /* If this is an artificial argument, then either, this is an argument
1805 beyond the end of the known arguments, or possibly, there are no known
1806 arguments (maybe missing debug info).
1808 For these artificial arguments, if the user has prefixed it with '&'
1809 (for address-of), then lets always allow this to succeed, even if the
1810 argument is not actually in inferior memory. This will allow the user
1811 to pass arguments to a Fortran function even when there's no debug
1814 As we already pass the address of non-artificial arguments, all we
1815 need to do if skip the UNOP_ADDR operator in the expression and mark
1816 the argument as non-artificial. */
1817 if (is_artificial
&& exp
->elts
[*pos
].opcode
== UNOP_ADDR
)
1820 is_artificial
= false;
1823 struct value
*arg_val
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
1824 return fortran_argument_convert (arg_val
, is_artificial
);
1830 fortran_preserve_arg_pointer (struct value
*arg
, struct type
*type
)
1832 if (value_type (arg
)->code () == TYPE_CODE_PTR
)
1833 return value_type (arg
);
1840 fortran_adjust_dynamic_array_base_address_hack (struct type
*type
,
1843 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
1845 /* We can't adjust the base address for arrays that have no content. */
1846 if (type_not_allocated (type
) || type_not_associated (type
))
1849 int ndimensions
= calc_f77_array_dims (type
);
1850 LONGEST total_offset
= 0;
1852 /* Walk through each of the dimensions of this array type and figure out
1853 if any of the dimensions are "backwards", that is the base address
1854 for this dimension points to the element at the highest memory
1855 address and the stride is negative. */
1856 struct type
*tmp_type
= type
;
1857 for (int i
= 0 ; i
< ndimensions
; ++i
)
1859 /* Grab the range for this dimension and extract the lower and upper
1861 tmp_type
= check_typedef (tmp_type
);
1862 struct type
*range_type
= tmp_type
->index_type ();
1863 LONGEST lowerbound
, upperbound
, stride
;
1864 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
1865 error ("failed to get range bounds");
1867 /* Figure out the stride for this dimension. */
1868 struct type
*elt_type
= check_typedef (TYPE_TARGET_TYPE (tmp_type
));
1869 stride
= tmp_type
->index_type ()->bounds ()->bit_stride ();
1871 stride
= type_length_units (elt_type
);
1875 = gdbarch_addressable_memory_unit_size (elt_type
->arch ());
1876 stride
/= (unit_size
* 8);
1879 /* If this dimension is "backward" then figure out the offset
1880 adjustment required to point to the element at the lowest memory
1881 address, and add this to the total offset. */
1883 if (stride
< 0 && lowerbound
< upperbound
)
1884 offset
= (upperbound
- lowerbound
) * stride
;
1885 total_offset
+= offset
;
1886 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
1889 /* Adjust the address of this object and return it. */
1890 address
+= total_offset
;