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 /* A helper function for UNOP_ABS. */
979 static struct value
*
980 eval_op_f_abs (struct type
*expect_type
, struct expression
*exp
,
984 if (noside
== EVAL_SKIP
)
985 return eval_skip_value (exp
);
986 struct type
*type
= value_type (arg1
);
987 switch (type
->code ())
992 = fabs (target_float_to_host_double (value_contents (arg1
),
994 return value_from_host_double (type
, d
);
998 LONGEST l
= value_as_long (arg1
);
1000 return value_from_longest (type
, l
);
1003 error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type
));
1006 /* A helper function for BINOP_MOD. */
1008 static struct value
*
1009 eval_op_f_mod (struct type
*expect_type
, struct expression
*exp
,
1011 struct value
*arg1
, struct value
*arg2
)
1013 if (noside
== EVAL_SKIP
)
1014 return eval_skip_value (exp
);
1015 struct type
*type
= value_type (arg1
);
1016 if (type
->code () != value_type (arg2
)->code ())
1017 error (_("non-matching types for parameters to MOD ()"));
1018 switch (type
->code ())
1023 = target_float_to_host_double (value_contents (arg1
),
1026 = target_float_to_host_double (value_contents (arg2
),
1028 double d3
= fmod (d1
, d2
);
1029 return value_from_host_double (type
, d3
);
1033 LONGEST v1
= value_as_long (arg1
);
1034 LONGEST v2
= value_as_long (arg2
);
1036 error (_("calling MOD (N, 0) is undefined"));
1037 LONGEST v3
= v1
- (v1
/ v2
) * v2
;
1038 return value_from_longest (value_type (arg1
), v3
);
1041 error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type
));
1044 /* A helper function for UNOP_FORTRAN_CEILING. */
1046 static struct value
*
1047 eval_op_f_ceil (struct type
*expect_type
, struct expression
*exp
,
1051 if (noside
== EVAL_SKIP
)
1052 return eval_skip_value (exp
);
1053 struct type
*type
= value_type (arg1
);
1054 if (type
->code () != TYPE_CODE_FLT
)
1055 error (_("argument to CEILING must be of type float"));
1057 = target_float_to_host_double (value_contents (arg1
),
1060 return value_from_host_double (type
, val
);
1063 /* A helper function for UNOP_FORTRAN_FLOOR. */
1065 static struct value
*
1066 eval_op_f_floor (struct type
*expect_type
, struct expression
*exp
,
1070 if (noside
== EVAL_SKIP
)
1071 return eval_skip_value (exp
);
1072 struct type
*type
= value_type (arg1
);
1073 if (type
->code () != TYPE_CODE_FLT
)
1074 error (_("argument to FLOOR must be of type float"));
1076 = target_float_to_host_double (value_contents (arg1
),
1079 return value_from_host_double (type
, val
);
1082 /* A helper function for BINOP_FORTRAN_MODULO. */
1084 static struct value
*
1085 eval_op_f_modulo (struct type
*expect_type
, struct expression
*exp
,
1087 struct value
*arg1
, struct value
*arg2
)
1089 if (noside
== EVAL_SKIP
)
1090 return eval_skip_value (exp
);
1091 struct type
*type
= value_type (arg1
);
1092 if (type
->code () != value_type (arg2
)->code ())
1093 error (_("non-matching types for parameters to MODULO ()"));
1094 /* MODULO(A, P) = A - FLOOR (A / P) * P */
1095 switch (type
->code ())
1099 LONGEST a
= value_as_long (arg1
);
1100 LONGEST p
= value_as_long (arg2
);
1101 LONGEST result
= a
- (a
/ p
) * p
;
1102 if (result
!= 0 && (a
< 0) != (p
< 0))
1104 return value_from_longest (value_type (arg1
), result
);
1109 = target_float_to_host_double (value_contents (arg1
),
1112 = target_float_to_host_double (value_contents (arg2
),
1114 double result
= fmod (a
, p
);
1115 if (result
!= 0 && (a
< 0.0) != (p
< 0.0))
1117 return value_from_host_double (type
, result
);
1120 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type
));
1123 /* A helper function for BINOP_FORTRAN_CMPLX. */
1125 static struct value
*
1126 eval_op_f_cmplx (struct type
*expect_type
, struct expression
*exp
,
1128 struct value
*arg1
, struct value
*arg2
)
1130 if (noside
== EVAL_SKIP
)
1131 return eval_skip_value (exp
);
1132 struct type
*type
= builtin_f_type(exp
->gdbarch
)->builtin_complex_s16
;
1133 return value_literal_complex (arg1
, arg2
, type
);
1136 /* Special expression evaluation cases for Fortran. */
1138 static struct value
*
1139 evaluate_subexp_f (struct type
*expect_type
, struct expression
*exp
,
1140 int *pos
, enum noside noside
)
1142 struct value
*arg1
= NULL
, *arg2
= NULL
;
1149 op
= exp
->elts
[pc
].opcode
;
1155 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
1158 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1159 return eval_op_f_abs (expect_type
, exp
, noside
, arg1
);
1162 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1163 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1164 return eval_op_f_mod (expect_type
, exp
, noside
, arg1
, arg2
);
1166 case UNOP_FORTRAN_CEILING
:
1167 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1168 return eval_op_f_ceil (expect_type
, exp
, noside
, arg1
);
1170 case UNOP_FORTRAN_FLOOR
:
1171 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1172 return eval_op_f_floor (expect_type
, exp
, noside
, arg1
);
1174 case UNOP_FORTRAN_ALLOCATED
:
1176 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1177 if (noside
== EVAL_SKIP
)
1178 return eval_skip_value (exp
);
1179 type
= check_typedef (value_type (arg1
));
1180 if (type
->code () != TYPE_CODE_ARRAY
)
1181 error (_("ALLOCATED can only be applied to arrays"));
1182 struct type
*result_type
1183 = builtin_f_type (exp
->gdbarch
)->builtin_logical
;
1184 LONGEST result_value
= type_not_allocated (type
) ? 0 : 1;
1185 return value_from_longest (result_type
, result_value
);
1188 case BINOP_FORTRAN_MODULO
:
1189 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1190 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1191 return eval_op_f_modulo (expect_type
, exp
, noside
, arg1
, arg2
);
1193 case FORTRAN_LBOUND
:
1194 case FORTRAN_UBOUND
:
1196 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1199 /* This assertion should be enforced by the expression parser. */
1200 gdb_assert (nargs
== 1 || nargs
== 2);
1202 bool lbound_p
= op
== FORTRAN_LBOUND
;
1204 /* Check that the first argument is array like. */
1205 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1206 type
= check_typedef (value_type (arg1
));
1207 if (type
->code () != TYPE_CODE_ARRAY
)
1210 error (_("LBOUND can only be applied to arrays"));
1212 error (_("UBOUND can only be applied to arrays"));
1216 return fortran_bounds_all_dims (lbound_p
, exp
->gdbarch
, arg1
);
1218 /* User asked for the bounds of a specific dimension of the array. */
1219 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1220 type
= check_typedef (value_type (arg2
));
1221 if (type
->code () != TYPE_CODE_INT
)
1224 error (_("LBOUND second argument should be an integer"));
1226 error (_("UBOUND second argument should be an integer"));
1229 return fortran_bounds_for_dimension (lbound_p
, exp
->gdbarch
, arg1
,
1234 case FORTRAN_ASSOCIATED
:
1236 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1239 /* This assertion should be enforced by the expression parser. */
1240 gdb_assert (nargs
== 1 || nargs
== 2);
1242 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1246 if (noside
== EVAL_SKIP
)
1247 return eval_skip_value (exp
);
1248 return fortran_associated (exp
->gdbarch
, exp
->language_defn
,
1252 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1253 if (noside
== EVAL_SKIP
)
1254 return eval_skip_value (exp
);
1255 return fortran_associated (exp
->gdbarch
, exp
->language_defn
,
1260 case BINOP_FORTRAN_CMPLX
:
1261 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1262 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1263 return eval_op_f_cmplx (expect_type
, exp
, noside
, arg1
, arg2
);
1265 case UNOP_FORTRAN_KIND
:
1266 arg1
= evaluate_subexp (NULL
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
1267 type
= value_type (arg1
);
1269 switch (type
->code ())
1271 case TYPE_CODE_STRUCT
:
1272 case TYPE_CODE_UNION
:
1273 case TYPE_CODE_MODULE
:
1274 case TYPE_CODE_FUNC
:
1275 error (_("argument to kind must be an intrinsic type"));
1278 if (!TYPE_TARGET_TYPE (type
))
1279 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1280 TYPE_LENGTH (type
));
1281 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1282 TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
1285 case OP_F77_UNDETERMINED_ARGLIST
:
1286 /* Remember that in F77, functions, substring ops and array subscript
1287 operations cannot be disambiguated at parse time. We have made
1288 all array subscript operations, substring operations as well as
1289 function calls come here and we now have to discover what the heck
1290 this thing actually was. If it is a function, we process just as
1291 if we got an OP_FUNCALL. */
1292 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1295 /* First determine the type code we are dealing with. */
1296 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1297 type
= check_typedef (value_type (arg1
));
1298 enum type_code code
= type
->code ();
1300 if (code
== TYPE_CODE_PTR
)
1302 /* Fortran always passes variable to subroutines as pointer.
1303 So we need to look into its target type to see if it is
1304 array, string or function. If it is, we need to switch
1305 to the target value the original one points to. */
1306 struct type
*target_type
= check_typedef (TYPE_TARGET_TYPE (type
));
1308 if (target_type
->code () == TYPE_CODE_ARRAY
1309 || target_type
->code () == TYPE_CODE_STRING
1310 || target_type
->code () == TYPE_CODE_FUNC
)
1312 arg1
= value_ind (arg1
);
1313 type
= check_typedef (value_type (arg1
));
1314 code
= type
->code ();
1320 case TYPE_CODE_ARRAY
:
1321 case TYPE_CODE_STRING
:
1322 return fortran_value_subarray (arg1
, exp
, pos
, nargs
, noside
);
1325 case TYPE_CODE_FUNC
:
1326 case TYPE_CODE_INTERNAL_FUNCTION
:
1328 /* It's a function call. Allocate arg vector, including
1329 space for the function to be called in argvec[0] and a
1330 termination NULL. */
1331 struct value
**argvec
= (struct value
**)
1332 alloca (sizeof (struct value
*) * (nargs
+ 2));
1335 for (; tem
<= nargs
; tem
++)
1337 bool is_internal_func
= (code
== TYPE_CODE_INTERNAL_FUNCTION
);
1339 = fortran_prepare_argument (exp
, pos
, (tem
- 1),
1341 value_type (arg1
), noside
);
1343 argvec
[tem
] = 0; /* signal end of arglist */
1344 if (noside
== EVAL_SKIP
)
1345 return eval_skip_value (exp
);
1346 return evaluate_subexp_do_call (exp
, noside
, argvec
[0],
1347 gdb::make_array_view (argvec
+ 1,
1353 error (_("Cannot perform substring on this type"));
1357 /* Should be unreachable. */
1361 /* Special expression lengths for Fortran. */
1364 operator_length_f (const struct expression
*exp
, int pc
, int *oplenp
,
1370 switch (exp
->elts
[pc
- 1].opcode
)
1373 operator_length_standard (exp
, pc
, oplenp
, argsp
);
1376 case UNOP_FORTRAN_KIND
:
1377 case UNOP_FORTRAN_FLOOR
:
1378 case UNOP_FORTRAN_CEILING
:
1379 case UNOP_FORTRAN_ALLOCATED
:
1384 case BINOP_FORTRAN_CMPLX
:
1385 case BINOP_FORTRAN_MODULO
:
1390 case FORTRAN_ASSOCIATED
:
1391 case FORTRAN_LBOUND
:
1392 case FORTRAN_UBOUND
:
1394 args
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
1397 case OP_F77_UNDETERMINED_ARGLIST
:
1399 args
= 1 + longest_to_int (exp
->elts
[pc
- 2].longconst
);
1407 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1408 the extra argument NAME which is the text that should be printed as the
1409 name of this operation. */
1412 print_unop_subexp_f (struct expression
*exp
, int *pos
,
1413 struct ui_file
*stream
, enum precedence prec
,
1417 fprintf_filtered (stream
, "%s(", name
);
1418 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1419 fputs_filtered (")", stream
);
1422 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1423 the extra argument NAME which is the text that should be printed as the
1424 name of this operation. */
1427 print_binop_subexp_f (struct expression
*exp
, int *pos
,
1428 struct ui_file
*stream
, enum precedence prec
,
1432 fprintf_filtered (stream
, "%s(", name
);
1433 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1434 fputs_filtered (",", stream
);
1435 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1436 fputs_filtered (")", stream
);
1439 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1440 the extra argument NAME which is the text that should be printed as the
1441 name of this operation. */
1444 print_unop_or_binop_subexp_f (struct expression
*exp
, int *pos
,
1445 struct ui_file
*stream
, enum precedence prec
,
1448 unsigned nargs
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
);
1450 fprintf_filtered (stream
, "%s (", name
);
1451 for (unsigned tem
= 0; tem
< nargs
; tem
++)
1454 fputs_filtered (", ", stream
);
1455 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
1457 fputs_filtered (")", stream
);
1460 /* Special expression printing for Fortran. */
1463 print_subexp_f (struct expression
*exp
, int *pos
,
1464 struct ui_file
*stream
, enum precedence prec
)
1467 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
1472 print_subexp_standard (exp
, pos
, stream
, prec
);
1475 case UNOP_FORTRAN_KIND
:
1476 print_unop_subexp_f (exp
, pos
, stream
, prec
, "KIND");
1479 case UNOP_FORTRAN_FLOOR
:
1480 print_unop_subexp_f (exp
, pos
, stream
, prec
, "FLOOR");
1483 case UNOP_FORTRAN_CEILING
:
1484 print_unop_subexp_f (exp
, pos
, stream
, prec
, "CEILING");
1487 case UNOP_FORTRAN_ALLOCATED
:
1488 print_unop_subexp_f (exp
, pos
, stream
, prec
, "ALLOCATED");
1491 case BINOP_FORTRAN_CMPLX
:
1492 print_binop_subexp_f (exp
, pos
, stream
, prec
, "CMPLX");
1495 case BINOP_FORTRAN_MODULO
:
1496 print_binop_subexp_f (exp
, pos
, stream
, prec
, "MODULO");
1499 case FORTRAN_ASSOCIATED
:
1500 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "ASSOCIATED");
1503 case FORTRAN_LBOUND
:
1504 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "LBOUND");
1507 case FORTRAN_UBOUND
:
1508 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "UBOUND");
1511 case OP_F77_UNDETERMINED_ARGLIST
:
1513 print_subexp_funcall (exp
, pos
, stream
);
1518 /* Special expression dumping for Fortran. */
1521 dump_subexp_body_f (struct expression
*exp
,
1522 struct ui_file
*stream
, int elt
)
1524 int opcode
= exp
->elts
[elt
].opcode
;
1525 int oplen
, nargs
, i
;
1530 return dump_subexp_body_standard (exp
, stream
, elt
);
1532 case UNOP_FORTRAN_KIND
:
1533 case UNOP_FORTRAN_FLOOR
:
1534 case UNOP_FORTRAN_CEILING
:
1535 case UNOP_FORTRAN_ALLOCATED
:
1536 case BINOP_FORTRAN_CMPLX
:
1537 case BINOP_FORTRAN_MODULO
:
1538 operator_length_f (exp
, (elt
+ 1), &oplen
, &nargs
);
1541 case FORTRAN_ASSOCIATED
:
1542 case FORTRAN_LBOUND
:
1543 case FORTRAN_UBOUND
:
1544 operator_length_f (exp
, (elt
+ 3), &oplen
, &nargs
);
1547 case OP_F77_UNDETERMINED_ARGLIST
:
1548 return dump_subexp_body_funcall (exp
, stream
, elt
+ 1);
1552 for (i
= 0; i
< nargs
; i
+= 1)
1553 elt
= dump_subexp (exp
, stream
, elt
);
1558 /* Special expression checking for Fortran. */
1561 operator_check_f (struct expression
*exp
, int pos
,
1562 int (*objfile_func
) (struct objfile
*objfile
,
1566 const union exp_element
*const elts
= exp
->elts
;
1568 switch (elts
[pos
].opcode
)
1570 case UNOP_FORTRAN_KIND
:
1571 case UNOP_FORTRAN_FLOOR
:
1572 case UNOP_FORTRAN_CEILING
:
1573 case UNOP_FORTRAN_ALLOCATED
:
1574 case BINOP_FORTRAN_CMPLX
:
1575 case BINOP_FORTRAN_MODULO
:
1576 case FORTRAN_ASSOCIATED
:
1577 case FORTRAN_LBOUND
:
1578 case FORTRAN_UBOUND
:
1579 /* Any references to objfiles are held in the arguments to this
1580 expression, not within the expression itself, so no additional
1581 checking is required here, the outer expression iteration code
1582 will take care of checking each argument. */
1586 return operator_check_standard (exp
, pos
, objfile_func
, data
);
1592 /* Expression processing for Fortran. */
1593 const struct exp_descriptor
f_language::exp_descriptor_tab
=
1602 /* See language.h. */
1605 f_language::language_arch_info (struct gdbarch
*gdbarch
,
1606 struct language_arch_info
*lai
) const
1608 const struct builtin_f_type
*builtin
= builtin_f_type (gdbarch
);
1610 /* Helper function to allow shorter lines below. */
1611 auto add
= [&] (struct type
* t
)
1613 lai
->add_primitive_type (t
);
1616 add (builtin
->builtin_character
);
1617 add (builtin
->builtin_logical
);
1618 add (builtin
->builtin_logical_s1
);
1619 add (builtin
->builtin_logical_s2
);
1620 add (builtin
->builtin_logical_s8
);
1621 add (builtin
->builtin_real
);
1622 add (builtin
->builtin_real_s8
);
1623 add (builtin
->builtin_real_s16
);
1624 add (builtin
->builtin_complex_s8
);
1625 add (builtin
->builtin_complex_s16
);
1626 add (builtin
->builtin_void
);
1628 lai
->set_string_char_type (builtin
->builtin_character
);
1629 lai
->set_bool_type (builtin
->builtin_logical_s2
, "logical");
1632 /* See language.h. */
1635 f_language::search_name_hash (const char *name
) const
1637 return cp_search_name_hash (name
);
1640 /* See language.h. */
1643 f_language::lookup_symbol_nonlocal (const char *name
,
1644 const struct block
*block
,
1645 const domain_enum domain
) const
1647 return cp_lookup_symbol_nonlocal (this, name
, block
, domain
);
1650 /* See language.h. */
1652 symbol_name_matcher_ftype
*
1653 f_language::get_symbol_name_matcher_inner
1654 (const lookup_name_info
&lookup_name
) const
1656 return cp_get_symbol_name_matcher (lookup_name
);
1659 /* Single instance of the Fortran language class. */
1661 static f_language f_language_defn
;
1664 build_fortran_types (struct gdbarch
*gdbarch
)
1666 struct builtin_f_type
*builtin_f_type
1667 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_f_type
);
1669 builtin_f_type
->builtin_void
1670 = arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
, "void");
1672 builtin_f_type
->builtin_character
1673 = arch_type (gdbarch
, TYPE_CODE_CHAR
, TARGET_CHAR_BIT
, "character");
1675 builtin_f_type
->builtin_logical_s1
1676 = arch_boolean_type (gdbarch
, TARGET_CHAR_BIT
, 1, "logical*1");
1678 builtin_f_type
->builtin_integer_s2
1679 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
), 0,
1682 builtin_f_type
->builtin_integer_s8
1683 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 0,
1686 builtin_f_type
->builtin_logical_s2
1687 = arch_boolean_type (gdbarch
, gdbarch_short_bit (gdbarch
), 1,
1690 builtin_f_type
->builtin_logical_s8
1691 = arch_boolean_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 1,
1694 builtin_f_type
->builtin_integer
1695 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 0,
1698 builtin_f_type
->builtin_logical
1699 = arch_boolean_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1,
1702 builtin_f_type
->builtin_real
1703 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
1704 "real", gdbarch_float_format (gdbarch
));
1705 builtin_f_type
->builtin_real_s8
1706 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
1707 "real*8", gdbarch_double_format (gdbarch
));
1708 auto fmt
= gdbarch_floatformat_for_type (gdbarch
, "real(kind=16)", 128);
1710 builtin_f_type
->builtin_real_s16
1711 = arch_float_type (gdbarch
, 128, "real*16", fmt
);
1712 else if (gdbarch_long_double_bit (gdbarch
) == 128)
1713 builtin_f_type
->builtin_real_s16
1714 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
1715 "real*16", gdbarch_long_double_format (gdbarch
));
1717 builtin_f_type
->builtin_real_s16
1718 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 128, "real*16");
1720 builtin_f_type
->builtin_complex_s8
1721 = init_complex_type ("complex*8", builtin_f_type
->builtin_real
);
1722 builtin_f_type
->builtin_complex_s16
1723 = init_complex_type ("complex*16", builtin_f_type
->builtin_real_s8
);
1725 if (builtin_f_type
->builtin_real_s16
->code () == TYPE_CODE_ERROR
)
1726 builtin_f_type
->builtin_complex_s32
1727 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 256, "complex*32");
1729 builtin_f_type
->builtin_complex_s32
1730 = init_complex_type ("complex*32", builtin_f_type
->builtin_real_s16
);
1732 return builtin_f_type
;
1735 static struct gdbarch_data
*f_type_data
;
1737 const struct builtin_f_type
*
1738 builtin_f_type (struct gdbarch
*gdbarch
)
1740 return (const struct builtin_f_type
*) gdbarch_data (gdbarch
, f_type_data
);
1743 /* Command-list for the "set/show fortran" prefix command. */
1744 static struct cmd_list_element
*set_fortran_list
;
1745 static struct cmd_list_element
*show_fortran_list
;
1747 void _initialize_f_language ();
1749 _initialize_f_language ()
1751 f_type_data
= gdbarch_data_register_post_init (build_fortran_types
);
1753 add_basic_prefix_cmd ("fortran", no_class
,
1754 _("Prefix command for changing Fortran-specific settings."),
1755 &set_fortran_list
, "set fortran ", 0, &setlist
);
1757 add_show_prefix_cmd ("fortran", no_class
,
1758 _("Generic command for showing Fortran-specific settings."),
1759 &show_fortran_list
, "show fortran ", 0, &showlist
);
1761 add_setshow_boolean_cmd ("repack-array-slices", class_vars
,
1762 &repack_array_slices
, _("\
1763 Enable or disable repacking of non-contiguous array slices."), _("\
1764 Show whether non-contiguous array slices are repacked."), _("\
1765 When the user requests a slice of a Fortran array then we can either return\n\
1766 a descriptor that describes the array in place (using the original array data\n\
1767 in its existing location) or the original data can be repacked (copied) to a\n\
1770 When the content of the array slice is contiguous within the original array\n\
1771 then the result will never be repacked, but when the data for the new array\n\
1772 is non-contiguous within the original array repacking will only be performed\n\
1773 when this setting is on."),
1775 show_repack_array_slices
,
1776 &set_fortran_list
, &show_fortran_list
);
1778 /* Debug Fortran's array slicing logic. */
1779 add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance
,
1780 &fortran_array_slicing_debug
, _("\
1781 Set debugging of Fortran array slicing."), _("\
1782 Show debugging of Fortran array slicing."), _("\
1783 When on, debugging of Fortran array slicing is enabled."),
1785 show_fortran_array_slicing_debug
,
1786 &setdebuglist
, &showdebuglist
);
1789 /* Ensures that function argument VALUE is in the appropriate form to
1790 pass to a Fortran function. Returns a possibly new value that should
1791 be used instead of VALUE.
1793 When IS_ARTIFICIAL is true this indicates an artificial argument,
1794 e.g. hidden string lengths which the GNU Fortran argument passing
1795 convention specifies as being passed by value.
1797 When IS_ARTIFICIAL is false, the argument is passed by pointer. If the
1798 value is already in target memory then return a value that is a pointer
1799 to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate
1800 space in the target, copy VALUE in, and return a pointer to the in
1803 static struct value
*
1804 fortran_argument_convert (struct value
*value
, bool is_artificial
)
1808 /* If the value is not in the inferior e.g. registers values,
1809 convenience variables and user input. */
1810 if (VALUE_LVAL (value
) != lval_memory
)
1812 struct type
*type
= value_type (value
);
1813 const int length
= TYPE_LENGTH (type
);
1814 const CORE_ADDR addr
1815 = value_as_long (value_allocate_space_in_inferior (length
));
1816 write_memory (addr
, value_contents (value
), length
);
1818 = value_from_contents_and_address (type
, value_contents (value
),
1820 return value_addr (val
);
1823 return value_addr (value
); /* Program variables, e.g. arrays. */
1828 /* Prepare (and return) an argument value ready for an inferior function
1829 call to a Fortran function. EXP and POS are the expressions describing
1830 the argument to prepare. ARG_NUM is the argument number being
1831 prepared, with 0 being the first argument and so on. FUNC_TYPE is the
1832 type of the function being called.
1834 IS_INTERNAL_CALL_P is true if this is a call to a function of type
1835 TYPE_CODE_INTERNAL_FUNCTION, otherwise this parameter is false.
1837 NOSIDE has its usual meaning for expression parsing (see eval.c).
1839 Arguments in Fortran are normally passed by address, we coerce the
1840 arguments here rather than in value_arg_coerce as otherwise the call to
1841 malloc (to place the non-lvalue parameters in target memory) is hit by
1842 this Fortran specific logic. This results in malloc being called with a
1843 pointer to an integer followed by an attempt to malloc the arguments to
1844 malloc in target memory. Infinite recursion ensues. */
1847 fortran_prepare_argument (struct expression
*exp
, int *pos
,
1848 int arg_num
, bool is_internal_call_p
,
1849 struct type
*func_type
, enum noside noside
)
1851 if (is_internal_call_p
)
1852 return evaluate_subexp_with_coercion (exp
, pos
, noside
);
1854 bool is_artificial
= ((arg_num
>= func_type
->num_fields ())
1856 : TYPE_FIELD_ARTIFICIAL (func_type
, arg_num
));
1858 /* If this is an artificial argument, then either, this is an argument
1859 beyond the end of the known arguments, or possibly, there are no known
1860 arguments (maybe missing debug info).
1862 For these artificial arguments, if the user has prefixed it with '&'
1863 (for address-of), then lets always allow this to succeed, even if the
1864 argument is not actually in inferior memory. This will allow the user
1865 to pass arguments to a Fortran function even when there's no debug
1868 As we already pass the address of non-artificial arguments, all we
1869 need to do if skip the UNOP_ADDR operator in the expression and mark
1870 the argument as non-artificial. */
1871 if (is_artificial
&& exp
->elts
[*pos
].opcode
== UNOP_ADDR
)
1874 is_artificial
= false;
1877 struct value
*arg_val
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
1878 return fortran_argument_convert (arg_val
, is_artificial
);
1884 fortran_preserve_arg_pointer (struct value
*arg
, struct type
*type
)
1886 if (value_type (arg
)->code () == TYPE_CODE_PTR
)
1887 return value_type (arg
);
1894 fortran_adjust_dynamic_array_base_address_hack (struct type
*type
,
1897 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
1899 /* We can't adjust the base address for arrays that have no content. */
1900 if (type_not_allocated (type
) || type_not_associated (type
))
1903 int ndimensions
= calc_f77_array_dims (type
);
1904 LONGEST total_offset
= 0;
1906 /* Walk through each of the dimensions of this array type and figure out
1907 if any of the dimensions are "backwards", that is the base address
1908 for this dimension points to the element at the highest memory
1909 address and the stride is negative. */
1910 struct type
*tmp_type
= type
;
1911 for (int i
= 0 ; i
< ndimensions
; ++i
)
1913 /* Grab the range for this dimension and extract the lower and upper
1915 tmp_type
= check_typedef (tmp_type
);
1916 struct type
*range_type
= tmp_type
->index_type ();
1917 LONGEST lowerbound
, upperbound
, stride
;
1918 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
1919 error ("failed to get range bounds");
1921 /* Figure out the stride for this dimension. */
1922 struct type
*elt_type
= check_typedef (TYPE_TARGET_TYPE (tmp_type
));
1923 stride
= tmp_type
->index_type ()->bounds ()->bit_stride ();
1925 stride
= type_length_units (elt_type
);
1929 = gdbarch_addressable_memory_unit_size (elt_type
->arch ());
1930 stride
/= (unit_size
* 8);
1933 /* If this dimension is "backward" then figure out the offset
1934 adjustment required to point to the element at the lowest memory
1935 address, and add this to the total offset. */
1937 if (stride
< 0 && lowerbound
< upperbound
)
1938 offset
= (upperbound
- lowerbound
) * stride
;
1939 total_offset
+= offset
;
1940 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
1943 /* Adjust the address of this object and return it. */
1944 address
+= total_offset
;