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 /* Special expression evaluation cases for Fortran. */
1046 static struct value
*
1047 evaluate_subexp_f (struct type
*expect_type
, struct expression
*exp
,
1048 int *pos
, enum noside noside
)
1050 struct value
*arg1
= NULL
, *arg2
= NULL
;
1057 op
= exp
->elts
[pc
].opcode
;
1063 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
1066 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1067 return eval_op_f_abs (expect_type
, exp
, noside
, arg1
);
1070 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1071 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1072 return eval_op_f_mod (expect_type
, exp
, noside
, arg1
, arg2
);
1074 case UNOP_FORTRAN_CEILING
:
1076 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1077 if (noside
== EVAL_SKIP
)
1078 return eval_skip_value (exp
);
1079 type
= value_type (arg1
);
1080 if (type
->code () != TYPE_CODE_FLT
)
1081 error (_("argument to CEILING must be of type float"));
1083 = target_float_to_host_double (value_contents (arg1
),
1086 return value_from_host_double (type
, val
);
1089 case UNOP_FORTRAN_FLOOR
:
1091 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1092 if (noside
== EVAL_SKIP
)
1093 return eval_skip_value (exp
);
1094 type
= value_type (arg1
);
1095 if (type
->code () != TYPE_CODE_FLT
)
1096 error (_("argument to FLOOR must be of type float"));
1098 = target_float_to_host_double (value_contents (arg1
),
1101 return value_from_host_double (type
, val
);
1104 case UNOP_FORTRAN_ALLOCATED
:
1106 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1107 if (noside
== EVAL_SKIP
)
1108 return eval_skip_value (exp
);
1109 type
= check_typedef (value_type (arg1
));
1110 if (type
->code () != TYPE_CODE_ARRAY
)
1111 error (_("ALLOCATED can only be applied to arrays"));
1112 struct type
*result_type
1113 = builtin_f_type (exp
->gdbarch
)->builtin_logical
;
1114 LONGEST result_value
= type_not_allocated (type
) ? 0 : 1;
1115 return value_from_longest (result_type
, result_value
);
1118 case BINOP_FORTRAN_MODULO
:
1120 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1121 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1122 if (noside
== EVAL_SKIP
)
1123 return eval_skip_value (exp
);
1124 type
= value_type (arg1
);
1125 if (type
->code () != value_type (arg2
)->code ())
1126 error (_("non-matching types for parameters to MODULO ()"));
1127 /* MODULO(A, P) = A - FLOOR (A / P) * P */
1128 switch (type
->code ())
1132 LONGEST a
= value_as_long (arg1
);
1133 LONGEST p
= value_as_long (arg2
);
1134 LONGEST result
= a
- (a
/ p
) * p
;
1135 if (result
!= 0 && (a
< 0) != (p
< 0))
1137 return value_from_longest (value_type (arg1
), result
);
1142 = target_float_to_host_double (value_contents (arg1
),
1145 = target_float_to_host_double (value_contents (arg2
),
1147 double result
= fmod (a
, p
);
1148 if (result
!= 0 && (a
< 0.0) != (p
< 0.0))
1150 return value_from_host_double (type
, result
);
1153 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type
));
1156 case FORTRAN_LBOUND
:
1157 case FORTRAN_UBOUND
:
1159 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1162 /* This assertion should be enforced by the expression parser. */
1163 gdb_assert (nargs
== 1 || nargs
== 2);
1165 bool lbound_p
= op
== FORTRAN_LBOUND
;
1167 /* Check that the first argument is array like. */
1168 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1169 type
= check_typedef (value_type (arg1
));
1170 if (type
->code () != TYPE_CODE_ARRAY
)
1173 error (_("LBOUND can only be applied to arrays"));
1175 error (_("UBOUND can only be applied to arrays"));
1179 return fortran_bounds_all_dims (lbound_p
, exp
->gdbarch
, arg1
);
1181 /* User asked for the bounds of a specific dimension of the array. */
1182 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1183 type
= check_typedef (value_type (arg2
));
1184 if (type
->code () != TYPE_CODE_INT
)
1187 error (_("LBOUND second argument should be an integer"));
1189 error (_("UBOUND second argument should be an integer"));
1192 return fortran_bounds_for_dimension (lbound_p
, exp
->gdbarch
, arg1
,
1197 case FORTRAN_ASSOCIATED
:
1199 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1202 /* This assertion should be enforced by the expression parser. */
1203 gdb_assert (nargs
== 1 || nargs
== 2);
1205 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1209 if (noside
== EVAL_SKIP
)
1210 return eval_skip_value (exp
);
1211 return fortran_associated (exp
->gdbarch
, exp
->language_defn
,
1215 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1216 if (noside
== EVAL_SKIP
)
1217 return eval_skip_value (exp
);
1218 return fortran_associated (exp
->gdbarch
, exp
->language_defn
,
1223 case BINOP_FORTRAN_CMPLX
:
1224 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1225 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1226 if (noside
== EVAL_SKIP
)
1227 return eval_skip_value (exp
);
1228 type
= builtin_f_type(exp
->gdbarch
)->builtin_complex_s16
;
1229 return value_literal_complex (arg1
, arg2
, type
);
1231 case UNOP_FORTRAN_KIND
:
1232 arg1
= evaluate_subexp (NULL
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
1233 type
= value_type (arg1
);
1235 switch (type
->code ())
1237 case TYPE_CODE_STRUCT
:
1238 case TYPE_CODE_UNION
:
1239 case TYPE_CODE_MODULE
:
1240 case TYPE_CODE_FUNC
:
1241 error (_("argument to kind must be an intrinsic type"));
1244 if (!TYPE_TARGET_TYPE (type
))
1245 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1246 TYPE_LENGTH (type
));
1247 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1248 TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
1251 case OP_F77_UNDETERMINED_ARGLIST
:
1252 /* Remember that in F77, functions, substring ops and array subscript
1253 operations cannot be disambiguated at parse time. We have made
1254 all array subscript operations, substring operations as well as
1255 function calls come here and we now have to discover what the heck
1256 this thing actually was. If it is a function, we process just as
1257 if we got an OP_FUNCALL. */
1258 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1261 /* First determine the type code we are dealing with. */
1262 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1263 type
= check_typedef (value_type (arg1
));
1264 enum type_code code
= type
->code ();
1266 if (code
== TYPE_CODE_PTR
)
1268 /* Fortran always passes variable to subroutines as pointer.
1269 So we need to look into its target type to see if it is
1270 array, string or function. If it is, we need to switch
1271 to the target value the original one points to. */
1272 struct type
*target_type
= check_typedef (TYPE_TARGET_TYPE (type
));
1274 if (target_type
->code () == TYPE_CODE_ARRAY
1275 || target_type
->code () == TYPE_CODE_STRING
1276 || target_type
->code () == TYPE_CODE_FUNC
)
1278 arg1
= value_ind (arg1
);
1279 type
= check_typedef (value_type (arg1
));
1280 code
= type
->code ();
1286 case TYPE_CODE_ARRAY
:
1287 case TYPE_CODE_STRING
:
1288 return fortran_value_subarray (arg1
, exp
, pos
, nargs
, noside
);
1291 case TYPE_CODE_FUNC
:
1292 case TYPE_CODE_INTERNAL_FUNCTION
:
1294 /* It's a function call. Allocate arg vector, including
1295 space for the function to be called in argvec[0] and a
1296 termination NULL. */
1297 struct value
**argvec
= (struct value
**)
1298 alloca (sizeof (struct value
*) * (nargs
+ 2));
1301 for (; tem
<= nargs
; tem
++)
1303 bool is_internal_func
= (code
== TYPE_CODE_INTERNAL_FUNCTION
);
1305 = fortran_prepare_argument (exp
, pos
, (tem
- 1),
1307 value_type (arg1
), noside
);
1309 argvec
[tem
] = 0; /* signal end of arglist */
1310 if (noside
== EVAL_SKIP
)
1311 return eval_skip_value (exp
);
1312 return evaluate_subexp_do_call (exp
, noside
, argvec
[0],
1313 gdb::make_array_view (argvec
+ 1,
1319 error (_("Cannot perform substring on this type"));
1323 /* Should be unreachable. */
1327 /* Special expression lengths for Fortran. */
1330 operator_length_f (const struct expression
*exp
, int pc
, int *oplenp
,
1336 switch (exp
->elts
[pc
- 1].opcode
)
1339 operator_length_standard (exp
, pc
, oplenp
, argsp
);
1342 case UNOP_FORTRAN_KIND
:
1343 case UNOP_FORTRAN_FLOOR
:
1344 case UNOP_FORTRAN_CEILING
:
1345 case UNOP_FORTRAN_ALLOCATED
:
1350 case BINOP_FORTRAN_CMPLX
:
1351 case BINOP_FORTRAN_MODULO
:
1356 case FORTRAN_ASSOCIATED
:
1357 case FORTRAN_LBOUND
:
1358 case FORTRAN_UBOUND
:
1360 args
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
1363 case OP_F77_UNDETERMINED_ARGLIST
:
1365 args
= 1 + longest_to_int (exp
->elts
[pc
- 2].longconst
);
1373 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1374 the extra argument NAME which is the text that should be printed as the
1375 name of this operation. */
1378 print_unop_subexp_f (struct expression
*exp
, int *pos
,
1379 struct ui_file
*stream
, enum precedence prec
,
1383 fprintf_filtered (stream
, "%s(", name
);
1384 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1385 fputs_filtered (")", stream
);
1388 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1389 the extra argument NAME which is the text that should be printed as the
1390 name of this operation. */
1393 print_binop_subexp_f (struct expression
*exp
, int *pos
,
1394 struct ui_file
*stream
, enum precedence prec
,
1398 fprintf_filtered (stream
, "%s(", name
);
1399 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1400 fputs_filtered (",", stream
);
1401 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1402 fputs_filtered (")", stream
);
1405 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1406 the extra argument NAME which is the text that should be printed as the
1407 name of this operation. */
1410 print_unop_or_binop_subexp_f (struct expression
*exp
, int *pos
,
1411 struct ui_file
*stream
, enum precedence prec
,
1414 unsigned nargs
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
);
1416 fprintf_filtered (stream
, "%s (", name
);
1417 for (unsigned tem
= 0; tem
< nargs
; tem
++)
1420 fputs_filtered (", ", stream
);
1421 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
1423 fputs_filtered (")", stream
);
1426 /* Special expression printing for Fortran. */
1429 print_subexp_f (struct expression
*exp
, int *pos
,
1430 struct ui_file
*stream
, enum precedence prec
)
1433 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
1438 print_subexp_standard (exp
, pos
, stream
, prec
);
1441 case UNOP_FORTRAN_KIND
:
1442 print_unop_subexp_f (exp
, pos
, stream
, prec
, "KIND");
1445 case UNOP_FORTRAN_FLOOR
:
1446 print_unop_subexp_f (exp
, pos
, stream
, prec
, "FLOOR");
1449 case UNOP_FORTRAN_CEILING
:
1450 print_unop_subexp_f (exp
, pos
, stream
, prec
, "CEILING");
1453 case UNOP_FORTRAN_ALLOCATED
:
1454 print_unop_subexp_f (exp
, pos
, stream
, prec
, "ALLOCATED");
1457 case BINOP_FORTRAN_CMPLX
:
1458 print_binop_subexp_f (exp
, pos
, stream
, prec
, "CMPLX");
1461 case BINOP_FORTRAN_MODULO
:
1462 print_binop_subexp_f (exp
, pos
, stream
, prec
, "MODULO");
1465 case FORTRAN_ASSOCIATED
:
1466 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "ASSOCIATED");
1469 case FORTRAN_LBOUND
:
1470 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "LBOUND");
1473 case FORTRAN_UBOUND
:
1474 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "UBOUND");
1477 case OP_F77_UNDETERMINED_ARGLIST
:
1479 print_subexp_funcall (exp
, pos
, stream
);
1484 /* Special expression dumping for Fortran. */
1487 dump_subexp_body_f (struct expression
*exp
,
1488 struct ui_file
*stream
, int elt
)
1490 int opcode
= exp
->elts
[elt
].opcode
;
1491 int oplen
, nargs
, i
;
1496 return dump_subexp_body_standard (exp
, stream
, elt
);
1498 case UNOP_FORTRAN_KIND
:
1499 case UNOP_FORTRAN_FLOOR
:
1500 case UNOP_FORTRAN_CEILING
:
1501 case UNOP_FORTRAN_ALLOCATED
:
1502 case BINOP_FORTRAN_CMPLX
:
1503 case BINOP_FORTRAN_MODULO
:
1504 operator_length_f (exp
, (elt
+ 1), &oplen
, &nargs
);
1507 case FORTRAN_ASSOCIATED
:
1508 case FORTRAN_LBOUND
:
1509 case FORTRAN_UBOUND
:
1510 operator_length_f (exp
, (elt
+ 3), &oplen
, &nargs
);
1513 case OP_F77_UNDETERMINED_ARGLIST
:
1514 return dump_subexp_body_funcall (exp
, stream
, elt
+ 1);
1518 for (i
= 0; i
< nargs
; i
+= 1)
1519 elt
= dump_subexp (exp
, stream
, elt
);
1524 /* Special expression checking for Fortran. */
1527 operator_check_f (struct expression
*exp
, int pos
,
1528 int (*objfile_func
) (struct objfile
*objfile
,
1532 const union exp_element
*const elts
= exp
->elts
;
1534 switch (elts
[pos
].opcode
)
1536 case UNOP_FORTRAN_KIND
:
1537 case UNOP_FORTRAN_FLOOR
:
1538 case UNOP_FORTRAN_CEILING
:
1539 case UNOP_FORTRAN_ALLOCATED
:
1540 case BINOP_FORTRAN_CMPLX
:
1541 case BINOP_FORTRAN_MODULO
:
1542 case FORTRAN_ASSOCIATED
:
1543 case FORTRAN_LBOUND
:
1544 case FORTRAN_UBOUND
:
1545 /* Any references to objfiles are held in the arguments to this
1546 expression, not within the expression itself, so no additional
1547 checking is required here, the outer expression iteration code
1548 will take care of checking each argument. */
1552 return operator_check_standard (exp
, pos
, objfile_func
, data
);
1558 /* Expression processing for Fortran. */
1559 const struct exp_descriptor
f_language::exp_descriptor_tab
=
1568 /* See language.h. */
1571 f_language::language_arch_info (struct gdbarch
*gdbarch
,
1572 struct language_arch_info
*lai
) const
1574 const struct builtin_f_type
*builtin
= builtin_f_type (gdbarch
);
1576 /* Helper function to allow shorter lines below. */
1577 auto add
= [&] (struct type
* t
)
1579 lai
->add_primitive_type (t
);
1582 add (builtin
->builtin_character
);
1583 add (builtin
->builtin_logical
);
1584 add (builtin
->builtin_logical_s1
);
1585 add (builtin
->builtin_logical_s2
);
1586 add (builtin
->builtin_logical_s8
);
1587 add (builtin
->builtin_real
);
1588 add (builtin
->builtin_real_s8
);
1589 add (builtin
->builtin_real_s16
);
1590 add (builtin
->builtin_complex_s8
);
1591 add (builtin
->builtin_complex_s16
);
1592 add (builtin
->builtin_void
);
1594 lai
->set_string_char_type (builtin
->builtin_character
);
1595 lai
->set_bool_type (builtin
->builtin_logical_s2
, "logical");
1598 /* See language.h. */
1601 f_language::search_name_hash (const char *name
) const
1603 return cp_search_name_hash (name
);
1606 /* See language.h. */
1609 f_language::lookup_symbol_nonlocal (const char *name
,
1610 const struct block
*block
,
1611 const domain_enum domain
) const
1613 return cp_lookup_symbol_nonlocal (this, name
, block
, domain
);
1616 /* See language.h. */
1618 symbol_name_matcher_ftype
*
1619 f_language::get_symbol_name_matcher_inner
1620 (const lookup_name_info
&lookup_name
) const
1622 return cp_get_symbol_name_matcher (lookup_name
);
1625 /* Single instance of the Fortran language class. */
1627 static f_language f_language_defn
;
1630 build_fortran_types (struct gdbarch
*gdbarch
)
1632 struct builtin_f_type
*builtin_f_type
1633 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_f_type
);
1635 builtin_f_type
->builtin_void
1636 = arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
, "void");
1638 builtin_f_type
->builtin_character
1639 = arch_type (gdbarch
, TYPE_CODE_CHAR
, TARGET_CHAR_BIT
, "character");
1641 builtin_f_type
->builtin_logical_s1
1642 = arch_boolean_type (gdbarch
, TARGET_CHAR_BIT
, 1, "logical*1");
1644 builtin_f_type
->builtin_integer_s2
1645 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
), 0,
1648 builtin_f_type
->builtin_integer_s8
1649 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 0,
1652 builtin_f_type
->builtin_logical_s2
1653 = arch_boolean_type (gdbarch
, gdbarch_short_bit (gdbarch
), 1,
1656 builtin_f_type
->builtin_logical_s8
1657 = arch_boolean_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 1,
1660 builtin_f_type
->builtin_integer
1661 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 0,
1664 builtin_f_type
->builtin_logical
1665 = arch_boolean_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1,
1668 builtin_f_type
->builtin_real
1669 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
1670 "real", gdbarch_float_format (gdbarch
));
1671 builtin_f_type
->builtin_real_s8
1672 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
1673 "real*8", gdbarch_double_format (gdbarch
));
1674 auto fmt
= gdbarch_floatformat_for_type (gdbarch
, "real(kind=16)", 128);
1676 builtin_f_type
->builtin_real_s16
1677 = arch_float_type (gdbarch
, 128, "real*16", fmt
);
1678 else if (gdbarch_long_double_bit (gdbarch
) == 128)
1679 builtin_f_type
->builtin_real_s16
1680 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
1681 "real*16", gdbarch_long_double_format (gdbarch
));
1683 builtin_f_type
->builtin_real_s16
1684 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 128, "real*16");
1686 builtin_f_type
->builtin_complex_s8
1687 = init_complex_type ("complex*8", builtin_f_type
->builtin_real
);
1688 builtin_f_type
->builtin_complex_s16
1689 = init_complex_type ("complex*16", builtin_f_type
->builtin_real_s8
);
1691 if (builtin_f_type
->builtin_real_s16
->code () == TYPE_CODE_ERROR
)
1692 builtin_f_type
->builtin_complex_s32
1693 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 256, "complex*32");
1695 builtin_f_type
->builtin_complex_s32
1696 = init_complex_type ("complex*32", builtin_f_type
->builtin_real_s16
);
1698 return builtin_f_type
;
1701 static struct gdbarch_data
*f_type_data
;
1703 const struct builtin_f_type
*
1704 builtin_f_type (struct gdbarch
*gdbarch
)
1706 return (const struct builtin_f_type
*) gdbarch_data (gdbarch
, f_type_data
);
1709 /* Command-list for the "set/show fortran" prefix command. */
1710 static struct cmd_list_element
*set_fortran_list
;
1711 static struct cmd_list_element
*show_fortran_list
;
1713 void _initialize_f_language ();
1715 _initialize_f_language ()
1717 f_type_data
= gdbarch_data_register_post_init (build_fortran_types
);
1719 add_basic_prefix_cmd ("fortran", no_class
,
1720 _("Prefix command for changing Fortran-specific settings."),
1721 &set_fortran_list
, "set fortran ", 0, &setlist
);
1723 add_show_prefix_cmd ("fortran", no_class
,
1724 _("Generic command for showing Fortran-specific settings."),
1725 &show_fortran_list
, "show fortran ", 0, &showlist
);
1727 add_setshow_boolean_cmd ("repack-array-slices", class_vars
,
1728 &repack_array_slices
, _("\
1729 Enable or disable repacking of non-contiguous array slices."), _("\
1730 Show whether non-contiguous array slices are repacked."), _("\
1731 When the user requests a slice of a Fortran array then we can either return\n\
1732 a descriptor that describes the array in place (using the original array data\n\
1733 in its existing location) or the original data can be repacked (copied) to a\n\
1736 When the content of the array slice is contiguous within the original array\n\
1737 then the result will never be repacked, but when the data for the new array\n\
1738 is non-contiguous within the original array repacking will only be performed\n\
1739 when this setting is on."),
1741 show_repack_array_slices
,
1742 &set_fortran_list
, &show_fortran_list
);
1744 /* Debug Fortran's array slicing logic. */
1745 add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance
,
1746 &fortran_array_slicing_debug
, _("\
1747 Set debugging of Fortran array slicing."), _("\
1748 Show debugging of Fortran array slicing."), _("\
1749 When on, debugging of Fortran array slicing is enabled."),
1751 show_fortran_array_slicing_debug
,
1752 &setdebuglist
, &showdebuglist
);
1755 /* Ensures that function argument VALUE is in the appropriate form to
1756 pass to a Fortran function. Returns a possibly new value that should
1757 be used instead of VALUE.
1759 When IS_ARTIFICIAL is true this indicates an artificial argument,
1760 e.g. hidden string lengths which the GNU Fortran argument passing
1761 convention specifies as being passed by value.
1763 When IS_ARTIFICIAL is false, the argument is passed by pointer. If the
1764 value is already in target memory then return a value that is a pointer
1765 to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate
1766 space in the target, copy VALUE in, and return a pointer to the in
1769 static struct value
*
1770 fortran_argument_convert (struct value
*value
, bool is_artificial
)
1774 /* If the value is not in the inferior e.g. registers values,
1775 convenience variables and user input. */
1776 if (VALUE_LVAL (value
) != lval_memory
)
1778 struct type
*type
= value_type (value
);
1779 const int length
= TYPE_LENGTH (type
);
1780 const CORE_ADDR addr
1781 = value_as_long (value_allocate_space_in_inferior (length
));
1782 write_memory (addr
, value_contents (value
), length
);
1784 = value_from_contents_and_address (type
, value_contents (value
),
1786 return value_addr (val
);
1789 return value_addr (value
); /* Program variables, e.g. arrays. */
1794 /* Prepare (and return) an argument value ready for an inferior function
1795 call to a Fortran function. EXP and POS are the expressions describing
1796 the argument to prepare. ARG_NUM is the argument number being
1797 prepared, with 0 being the first argument and so on. FUNC_TYPE is the
1798 type of the function being called.
1800 IS_INTERNAL_CALL_P is true if this is a call to a function of type
1801 TYPE_CODE_INTERNAL_FUNCTION, otherwise this parameter is false.
1803 NOSIDE has its usual meaning for expression parsing (see eval.c).
1805 Arguments in Fortran are normally passed by address, we coerce the
1806 arguments here rather than in value_arg_coerce as otherwise the call to
1807 malloc (to place the non-lvalue parameters in target memory) is hit by
1808 this Fortran specific logic. This results in malloc being called with a
1809 pointer to an integer followed by an attempt to malloc the arguments to
1810 malloc in target memory. Infinite recursion ensues. */
1813 fortran_prepare_argument (struct expression
*exp
, int *pos
,
1814 int arg_num
, bool is_internal_call_p
,
1815 struct type
*func_type
, enum noside noside
)
1817 if (is_internal_call_p
)
1818 return evaluate_subexp_with_coercion (exp
, pos
, noside
);
1820 bool is_artificial
= ((arg_num
>= func_type
->num_fields ())
1822 : TYPE_FIELD_ARTIFICIAL (func_type
, arg_num
));
1824 /* If this is an artificial argument, then either, this is an argument
1825 beyond the end of the known arguments, or possibly, there are no known
1826 arguments (maybe missing debug info).
1828 For these artificial arguments, if the user has prefixed it with '&'
1829 (for address-of), then lets always allow this to succeed, even if the
1830 argument is not actually in inferior memory. This will allow the user
1831 to pass arguments to a Fortran function even when there's no debug
1834 As we already pass the address of non-artificial arguments, all we
1835 need to do if skip the UNOP_ADDR operator in the expression and mark
1836 the argument as non-artificial. */
1837 if (is_artificial
&& exp
->elts
[*pos
].opcode
== UNOP_ADDR
)
1840 is_artificial
= false;
1843 struct value
*arg_val
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
1844 return fortran_argument_convert (arg_val
, is_artificial
);
1850 fortran_preserve_arg_pointer (struct value
*arg
, struct type
*type
)
1852 if (value_type (arg
)->code () == TYPE_CODE_PTR
)
1853 return value_type (arg
);
1860 fortran_adjust_dynamic_array_base_address_hack (struct type
*type
,
1863 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
1865 /* We can't adjust the base address for arrays that have no content. */
1866 if (type_not_allocated (type
) || type_not_associated (type
))
1869 int ndimensions
= calc_f77_array_dims (type
);
1870 LONGEST total_offset
= 0;
1872 /* Walk through each of the dimensions of this array type and figure out
1873 if any of the dimensions are "backwards", that is the base address
1874 for this dimension points to the element at the highest memory
1875 address and the stride is negative. */
1876 struct type
*tmp_type
= type
;
1877 for (int i
= 0 ; i
< ndimensions
; ++i
)
1879 /* Grab the range for this dimension and extract the lower and upper
1881 tmp_type
= check_typedef (tmp_type
);
1882 struct type
*range_type
= tmp_type
->index_type ();
1883 LONGEST lowerbound
, upperbound
, stride
;
1884 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
1885 error ("failed to get range bounds");
1887 /* Figure out the stride for this dimension. */
1888 struct type
*elt_type
= check_typedef (TYPE_TARGET_TYPE (tmp_type
));
1889 stride
= tmp_type
->index_type ()->bounds ()->bit_stride ();
1891 stride
= type_length_units (elt_type
);
1895 = gdbarch_addressable_memory_unit_size (elt_type
->arch ());
1896 stride
/= (unit_size
* 8);
1899 /* If this dimension is "backward" then figure out the offset
1900 adjustment required to point to the element at the lowest memory
1901 address, and add this to the total offset. */
1903 if (stride
< 0 && lowerbound
< upperbound
)
1904 offset
= (upperbound
- lowerbound
) * stride
;
1905 total_offset
+= offset
;
1906 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
1909 /* Adjust the address of this object and return it. */
1910 address
+= total_offset
;