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 /* Special expression evaluation cases for Fortran. */
1008 static struct value
*
1009 evaluate_subexp_f (struct type
*expect_type
, struct expression
*exp
,
1010 int *pos
, enum noside noside
)
1012 struct value
*arg1
= NULL
, *arg2
= NULL
;
1019 op
= exp
->elts
[pc
].opcode
;
1025 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
1028 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1029 return eval_op_f_abs (expect_type
, exp
, noside
, arg1
);
1032 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1033 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1034 if (noside
== EVAL_SKIP
)
1035 return eval_skip_value (exp
);
1036 type
= value_type (arg1
);
1037 if (type
->code () != value_type (arg2
)->code ())
1038 error (_("non-matching types for parameters to MOD ()"));
1039 switch (type
->code ())
1044 = target_float_to_host_double (value_contents (arg1
),
1047 = target_float_to_host_double (value_contents (arg2
),
1049 double d3
= fmod (d1
, d2
);
1050 return value_from_host_double (type
, d3
);
1054 LONGEST v1
= value_as_long (arg1
);
1055 LONGEST v2
= value_as_long (arg2
);
1057 error (_("calling MOD (N, 0) is undefined"));
1058 LONGEST v3
= v1
- (v1
/ v2
) * v2
;
1059 return value_from_longest (value_type (arg1
), v3
);
1062 error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type
));
1064 case UNOP_FORTRAN_CEILING
:
1066 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1067 if (noside
== EVAL_SKIP
)
1068 return eval_skip_value (exp
);
1069 type
= value_type (arg1
);
1070 if (type
->code () != TYPE_CODE_FLT
)
1071 error (_("argument to CEILING must be of type float"));
1073 = target_float_to_host_double (value_contents (arg1
),
1076 return value_from_host_double (type
, val
);
1079 case UNOP_FORTRAN_FLOOR
:
1081 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1082 if (noside
== EVAL_SKIP
)
1083 return eval_skip_value (exp
);
1084 type
= value_type (arg1
);
1085 if (type
->code () != TYPE_CODE_FLT
)
1086 error (_("argument to FLOOR must be of type float"));
1088 = target_float_to_host_double (value_contents (arg1
),
1091 return value_from_host_double (type
, val
);
1094 case UNOP_FORTRAN_ALLOCATED
:
1096 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1097 if (noside
== EVAL_SKIP
)
1098 return eval_skip_value (exp
);
1099 type
= check_typedef (value_type (arg1
));
1100 if (type
->code () != TYPE_CODE_ARRAY
)
1101 error (_("ALLOCATED can only be applied to arrays"));
1102 struct type
*result_type
1103 = builtin_f_type (exp
->gdbarch
)->builtin_logical
;
1104 LONGEST result_value
= type_not_allocated (type
) ? 0 : 1;
1105 return value_from_longest (result_type
, result_value
);
1108 case BINOP_FORTRAN_MODULO
:
1110 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1111 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1112 if (noside
== EVAL_SKIP
)
1113 return eval_skip_value (exp
);
1114 type
= value_type (arg1
);
1115 if (type
->code () != value_type (arg2
)->code ())
1116 error (_("non-matching types for parameters to MODULO ()"));
1117 /* MODULO(A, P) = A - FLOOR (A / P) * P */
1118 switch (type
->code ())
1122 LONGEST a
= value_as_long (arg1
);
1123 LONGEST p
= value_as_long (arg2
);
1124 LONGEST result
= a
- (a
/ p
) * p
;
1125 if (result
!= 0 && (a
< 0) != (p
< 0))
1127 return value_from_longest (value_type (arg1
), result
);
1132 = target_float_to_host_double (value_contents (arg1
),
1135 = target_float_to_host_double (value_contents (arg2
),
1137 double result
= fmod (a
, p
);
1138 if (result
!= 0 && (a
< 0.0) != (p
< 0.0))
1140 return value_from_host_double (type
, result
);
1143 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type
));
1146 case FORTRAN_LBOUND
:
1147 case FORTRAN_UBOUND
:
1149 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1152 /* This assertion should be enforced by the expression parser. */
1153 gdb_assert (nargs
== 1 || nargs
== 2);
1155 bool lbound_p
= op
== FORTRAN_LBOUND
;
1157 /* Check that the first argument is array like. */
1158 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1159 type
= check_typedef (value_type (arg1
));
1160 if (type
->code () != TYPE_CODE_ARRAY
)
1163 error (_("LBOUND can only be applied to arrays"));
1165 error (_("UBOUND can only be applied to arrays"));
1169 return fortran_bounds_all_dims (lbound_p
, exp
->gdbarch
, arg1
);
1171 /* User asked for the bounds of a specific dimension of the array. */
1172 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1173 type
= check_typedef (value_type (arg2
));
1174 if (type
->code () != TYPE_CODE_INT
)
1177 error (_("LBOUND second argument should be an integer"));
1179 error (_("UBOUND second argument should be an integer"));
1182 return fortran_bounds_for_dimension (lbound_p
, exp
->gdbarch
, arg1
,
1187 case FORTRAN_ASSOCIATED
:
1189 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1192 /* This assertion should be enforced by the expression parser. */
1193 gdb_assert (nargs
== 1 || nargs
== 2);
1195 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1199 if (noside
== EVAL_SKIP
)
1200 return eval_skip_value (exp
);
1201 return fortran_associated (exp
->gdbarch
, exp
->language_defn
,
1205 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1206 if (noside
== EVAL_SKIP
)
1207 return eval_skip_value (exp
);
1208 return fortran_associated (exp
->gdbarch
, exp
->language_defn
,
1213 case BINOP_FORTRAN_CMPLX
:
1214 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1215 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1216 if (noside
== EVAL_SKIP
)
1217 return eval_skip_value (exp
);
1218 type
= builtin_f_type(exp
->gdbarch
)->builtin_complex_s16
;
1219 return value_literal_complex (arg1
, arg2
, type
);
1221 case UNOP_FORTRAN_KIND
:
1222 arg1
= evaluate_subexp (NULL
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
1223 type
= value_type (arg1
);
1225 switch (type
->code ())
1227 case TYPE_CODE_STRUCT
:
1228 case TYPE_CODE_UNION
:
1229 case TYPE_CODE_MODULE
:
1230 case TYPE_CODE_FUNC
:
1231 error (_("argument to kind must be an intrinsic type"));
1234 if (!TYPE_TARGET_TYPE (type
))
1235 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1236 TYPE_LENGTH (type
));
1237 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1238 TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
1241 case OP_F77_UNDETERMINED_ARGLIST
:
1242 /* Remember that in F77, functions, substring ops and array subscript
1243 operations cannot be disambiguated at parse time. We have made
1244 all array subscript operations, substring operations as well as
1245 function calls come here and we now have to discover what the heck
1246 this thing actually was. If it is a function, we process just as
1247 if we got an OP_FUNCALL. */
1248 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1251 /* First determine the type code we are dealing with. */
1252 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1253 type
= check_typedef (value_type (arg1
));
1254 enum type_code code
= type
->code ();
1256 if (code
== TYPE_CODE_PTR
)
1258 /* Fortran always passes variable to subroutines as pointer.
1259 So we need to look into its target type to see if it is
1260 array, string or function. If it is, we need to switch
1261 to the target value the original one points to. */
1262 struct type
*target_type
= check_typedef (TYPE_TARGET_TYPE (type
));
1264 if (target_type
->code () == TYPE_CODE_ARRAY
1265 || target_type
->code () == TYPE_CODE_STRING
1266 || target_type
->code () == TYPE_CODE_FUNC
)
1268 arg1
= value_ind (arg1
);
1269 type
= check_typedef (value_type (arg1
));
1270 code
= type
->code ();
1276 case TYPE_CODE_ARRAY
:
1277 case TYPE_CODE_STRING
:
1278 return fortran_value_subarray (arg1
, exp
, pos
, nargs
, noside
);
1281 case TYPE_CODE_FUNC
:
1282 case TYPE_CODE_INTERNAL_FUNCTION
:
1284 /* It's a function call. Allocate arg vector, including
1285 space for the function to be called in argvec[0] and a
1286 termination NULL. */
1287 struct value
**argvec
= (struct value
**)
1288 alloca (sizeof (struct value
*) * (nargs
+ 2));
1291 for (; tem
<= nargs
; tem
++)
1293 bool is_internal_func
= (code
== TYPE_CODE_INTERNAL_FUNCTION
);
1295 = fortran_prepare_argument (exp
, pos
, (tem
- 1),
1297 value_type (arg1
), noside
);
1299 argvec
[tem
] = 0; /* signal end of arglist */
1300 if (noside
== EVAL_SKIP
)
1301 return eval_skip_value (exp
);
1302 return evaluate_subexp_do_call (exp
, noside
, argvec
[0],
1303 gdb::make_array_view (argvec
+ 1,
1309 error (_("Cannot perform substring on this type"));
1313 /* Should be unreachable. */
1317 /* Special expression lengths for Fortran. */
1320 operator_length_f (const struct expression
*exp
, int pc
, int *oplenp
,
1326 switch (exp
->elts
[pc
- 1].opcode
)
1329 operator_length_standard (exp
, pc
, oplenp
, argsp
);
1332 case UNOP_FORTRAN_KIND
:
1333 case UNOP_FORTRAN_FLOOR
:
1334 case UNOP_FORTRAN_CEILING
:
1335 case UNOP_FORTRAN_ALLOCATED
:
1340 case BINOP_FORTRAN_CMPLX
:
1341 case BINOP_FORTRAN_MODULO
:
1346 case FORTRAN_ASSOCIATED
:
1347 case FORTRAN_LBOUND
:
1348 case FORTRAN_UBOUND
:
1350 args
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
1353 case OP_F77_UNDETERMINED_ARGLIST
:
1355 args
= 1 + longest_to_int (exp
->elts
[pc
- 2].longconst
);
1363 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1364 the extra argument NAME which is the text that should be printed as the
1365 name of this operation. */
1368 print_unop_subexp_f (struct expression
*exp
, int *pos
,
1369 struct ui_file
*stream
, enum precedence prec
,
1373 fprintf_filtered (stream
, "%s(", name
);
1374 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1375 fputs_filtered (")", stream
);
1378 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1379 the extra argument NAME which is the text that should be printed as the
1380 name of this operation. */
1383 print_binop_subexp_f (struct expression
*exp
, int *pos
,
1384 struct ui_file
*stream
, enum precedence prec
,
1388 fprintf_filtered (stream
, "%s(", name
);
1389 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1390 fputs_filtered (",", stream
);
1391 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1392 fputs_filtered (")", stream
);
1395 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1396 the extra argument NAME which is the text that should be printed as the
1397 name of this operation. */
1400 print_unop_or_binop_subexp_f (struct expression
*exp
, int *pos
,
1401 struct ui_file
*stream
, enum precedence prec
,
1404 unsigned nargs
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
);
1406 fprintf_filtered (stream
, "%s (", name
);
1407 for (unsigned tem
= 0; tem
< nargs
; tem
++)
1410 fputs_filtered (", ", stream
);
1411 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
1413 fputs_filtered (")", stream
);
1416 /* Special expression printing for Fortran. */
1419 print_subexp_f (struct expression
*exp
, int *pos
,
1420 struct ui_file
*stream
, enum precedence prec
)
1423 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
1428 print_subexp_standard (exp
, pos
, stream
, prec
);
1431 case UNOP_FORTRAN_KIND
:
1432 print_unop_subexp_f (exp
, pos
, stream
, prec
, "KIND");
1435 case UNOP_FORTRAN_FLOOR
:
1436 print_unop_subexp_f (exp
, pos
, stream
, prec
, "FLOOR");
1439 case UNOP_FORTRAN_CEILING
:
1440 print_unop_subexp_f (exp
, pos
, stream
, prec
, "CEILING");
1443 case UNOP_FORTRAN_ALLOCATED
:
1444 print_unop_subexp_f (exp
, pos
, stream
, prec
, "ALLOCATED");
1447 case BINOP_FORTRAN_CMPLX
:
1448 print_binop_subexp_f (exp
, pos
, stream
, prec
, "CMPLX");
1451 case BINOP_FORTRAN_MODULO
:
1452 print_binop_subexp_f (exp
, pos
, stream
, prec
, "MODULO");
1455 case FORTRAN_ASSOCIATED
:
1456 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "ASSOCIATED");
1459 case FORTRAN_LBOUND
:
1460 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "LBOUND");
1463 case FORTRAN_UBOUND
:
1464 print_unop_or_binop_subexp_f (exp
, pos
, stream
, prec
, "UBOUND");
1467 case OP_F77_UNDETERMINED_ARGLIST
:
1469 print_subexp_funcall (exp
, pos
, stream
);
1474 /* Special expression dumping for Fortran. */
1477 dump_subexp_body_f (struct expression
*exp
,
1478 struct ui_file
*stream
, int elt
)
1480 int opcode
= exp
->elts
[elt
].opcode
;
1481 int oplen
, nargs
, i
;
1486 return dump_subexp_body_standard (exp
, stream
, elt
);
1488 case UNOP_FORTRAN_KIND
:
1489 case UNOP_FORTRAN_FLOOR
:
1490 case UNOP_FORTRAN_CEILING
:
1491 case UNOP_FORTRAN_ALLOCATED
:
1492 case BINOP_FORTRAN_CMPLX
:
1493 case BINOP_FORTRAN_MODULO
:
1494 operator_length_f (exp
, (elt
+ 1), &oplen
, &nargs
);
1497 case FORTRAN_ASSOCIATED
:
1498 case FORTRAN_LBOUND
:
1499 case FORTRAN_UBOUND
:
1500 operator_length_f (exp
, (elt
+ 3), &oplen
, &nargs
);
1503 case OP_F77_UNDETERMINED_ARGLIST
:
1504 return dump_subexp_body_funcall (exp
, stream
, elt
+ 1);
1508 for (i
= 0; i
< nargs
; i
+= 1)
1509 elt
= dump_subexp (exp
, stream
, elt
);
1514 /* Special expression checking for Fortran. */
1517 operator_check_f (struct expression
*exp
, int pos
,
1518 int (*objfile_func
) (struct objfile
*objfile
,
1522 const union exp_element
*const elts
= exp
->elts
;
1524 switch (elts
[pos
].opcode
)
1526 case UNOP_FORTRAN_KIND
:
1527 case UNOP_FORTRAN_FLOOR
:
1528 case UNOP_FORTRAN_CEILING
:
1529 case UNOP_FORTRAN_ALLOCATED
:
1530 case BINOP_FORTRAN_CMPLX
:
1531 case BINOP_FORTRAN_MODULO
:
1532 case FORTRAN_ASSOCIATED
:
1533 case FORTRAN_LBOUND
:
1534 case FORTRAN_UBOUND
:
1535 /* Any references to objfiles are held in the arguments to this
1536 expression, not within the expression itself, so no additional
1537 checking is required here, the outer expression iteration code
1538 will take care of checking each argument. */
1542 return operator_check_standard (exp
, pos
, objfile_func
, data
);
1548 /* Expression processing for Fortran. */
1549 const struct exp_descriptor
f_language::exp_descriptor_tab
=
1558 /* See language.h. */
1561 f_language::language_arch_info (struct gdbarch
*gdbarch
,
1562 struct language_arch_info
*lai
) const
1564 const struct builtin_f_type
*builtin
= builtin_f_type (gdbarch
);
1566 /* Helper function to allow shorter lines below. */
1567 auto add
= [&] (struct type
* t
)
1569 lai
->add_primitive_type (t
);
1572 add (builtin
->builtin_character
);
1573 add (builtin
->builtin_logical
);
1574 add (builtin
->builtin_logical_s1
);
1575 add (builtin
->builtin_logical_s2
);
1576 add (builtin
->builtin_logical_s8
);
1577 add (builtin
->builtin_real
);
1578 add (builtin
->builtin_real_s8
);
1579 add (builtin
->builtin_real_s16
);
1580 add (builtin
->builtin_complex_s8
);
1581 add (builtin
->builtin_complex_s16
);
1582 add (builtin
->builtin_void
);
1584 lai
->set_string_char_type (builtin
->builtin_character
);
1585 lai
->set_bool_type (builtin
->builtin_logical_s2
, "logical");
1588 /* See language.h. */
1591 f_language::search_name_hash (const char *name
) const
1593 return cp_search_name_hash (name
);
1596 /* See language.h. */
1599 f_language::lookup_symbol_nonlocal (const char *name
,
1600 const struct block
*block
,
1601 const domain_enum domain
) const
1603 return cp_lookup_symbol_nonlocal (this, name
, block
, domain
);
1606 /* See language.h. */
1608 symbol_name_matcher_ftype
*
1609 f_language::get_symbol_name_matcher_inner
1610 (const lookup_name_info
&lookup_name
) const
1612 return cp_get_symbol_name_matcher (lookup_name
);
1615 /* Single instance of the Fortran language class. */
1617 static f_language f_language_defn
;
1620 build_fortran_types (struct gdbarch
*gdbarch
)
1622 struct builtin_f_type
*builtin_f_type
1623 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_f_type
);
1625 builtin_f_type
->builtin_void
1626 = arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
, "void");
1628 builtin_f_type
->builtin_character
1629 = arch_type (gdbarch
, TYPE_CODE_CHAR
, TARGET_CHAR_BIT
, "character");
1631 builtin_f_type
->builtin_logical_s1
1632 = arch_boolean_type (gdbarch
, TARGET_CHAR_BIT
, 1, "logical*1");
1634 builtin_f_type
->builtin_integer_s2
1635 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
), 0,
1638 builtin_f_type
->builtin_integer_s8
1639 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 0,
1642 builtin_f_type
->builtin_logical_s2
1643 = arch_boolean_type (gdbarch
, gdbarch_short_bit (gdbarch
), 1,
1646 builtin_f_type
->builtin_logical_s8
1647 = arch_boolean_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 1,
1650 builtin_f_type
->builtin_integer
1651 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 0,
1654 builtin_f_type
->builtin_logical
1655 = arch_boolean_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1,
1658 builtin_f_type
->builtin_real
1659 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
1660 "real", gdbarch_float_format (gdbarch
));
1661 builtin_f_type
->builtin_real_s8
1662 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
1663 "real*8", gdbarch_double_format (gdbarch
));
1664 auto fmt
= gdbarch_floatformat_for_type (gdbarch
, "real(kind=16)", 128);
1666 builtin_f_type
->builtin_real_s16
1667 = arch_float_type (gdbarch
, 128, "real*16", fmt
);
1668 else if (gdbarch_long_double_bit (gdbarch
) == 128)
1669 builtin_f_type
->builtin_real_s16
1670 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
1671 "real*16", gdbarch_long_double_format (gdbarch
));
1673 builtin_f_type
->builtin_real_s16
1674 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 128, "real*16");
1676 builtin_f_type
->builtin_complex_s8
1677 = init_complex_type ("complex*8", builtin_f_type
->builtin_real
);
1678 builtin_f_type
->builtin_complex_s16
1679 = init_complex_type ("complex*16", builtin_f_type
->builtin_real_s8
);
1681 if (builtin_f_type
->builtin_real_s16
->code () == TYPE_CODE_ERROR
)
1682 builtin_f_type
->builtin_complex_s32
1683 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 256, "complex*32");
1685 builtin_f_type
->builtin_complex_s32
1686 = init_complex_type ("complex*32", builtin_f_type
->builtin_real_s16
);
1688 return builtin_f_type
;
1691 static struct gdbarch_data
*f_type_data
;
1693 const struct builtin_f_type
*
1694 builtin_f_type (struct gdbarch
*gdbarch
)
1696 return (const struct builtin_f_type
*) gdbarch_data (gdbarch
, f_type_data
);
1699 /* Command-list for the "set/show fortran" prefix command. */
1700 static struct cmd_list_element
*set_fortran_list
;
1701 static struct cmd_list_element
*show_fortran_list
;
1703 void _initialize_f_language ();
1705 _initialize_f_language ()
1707 f_type_data
= gdbarch_data_register_post_init (build_fortran_types
);
1709 add_basic_prefix_cmd ("fortran", no_class
,
1710 _("Prefix command for changing Fortran-specific settings."),
1711 &set_fortran_list
, "set fortran ", 0, &setlist
);
1713 add_show_prefix_cmd ("fortran", no_class
,
1714 _("Generic command for showing Fortran-specific settings."),
1715 &show_fortran_list
, "show fortran ", 0, &showlist
);
1717 add_setshow_boolean_cmd ("repack-array-slices", class_vars
,
1718 &repack_array_slices
, _("\
1719 Enable or disable repacking of non-contiguous array slices."), _("\
1720 Show whether non-contiguous array slices are repacked."), _("\
1721 When the user requests a slice of a Fortran array then we can either return\n\
1722 a descriptor that describes the array in place (using the original array data\n\
1723 in its existing location) or the original data can be repacked (copied) to a\n\
1726 When the content of the array slice is contiguous within the original array\n\
1727 then the result will never be repacked, but when the data for the new array\n\
1728 is non-contiguous within the original array repacking will only be performed\n\
1729 when this setting is on."),
1731 show_repack_array_slices
,
1732 &set_fortran_list
, &show_fortran_list
);
1734 /* Debug Fortran's array slicing logic. */
1735 add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance
,
1736 &fortran_array_slicing_debug
, _("\
1737 Set debugging of Fortran array slicing."), _("\
1738 Show debugging of Fortran array slicing."), _("\
1739 When on, debugging of Fortran array slicing is enabled."),
1741 show_fortran_array_slicing_debug
,
1742 &setdebuglist
, &showdebuglist
);
1745 /* Ensures that function argument VALUE is in the appropriate form to
1746 pass to a Fortran function. Returns a possibly new value that should
1747 be used instead of VALUE.
1749 When IS_ARTIFICIAL is true this indicates an artificial argument,
1750 e.g. hidden string lengths which the GNU Fortran argument passing
1751 convention specifies as being passed by value.
1753 When IS_ARTIFICIAL is false, the argument is passed by pointer. If the
1754 value is already in target memory then return a value that is a pointer
1755 to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate
1756 space in the target, copy VALUE in, and return a pointer to the in
1759 static struct value
*
1760 fortran_argument_convert (struct value
*value
, bool is_artificial
)
1764 /* If the value is not in the inferior e.g. registers values,
1765 convenience variables and user input. */
1766 if (VALUE_LVAL (value
) != lval_memory
)
1768 struct type
*type
= value_type (value
);
1769 const int length
= TYPE_LENGTH (type
);
1770 const CORE_ADDR addr
1771 = value_as_long (value_allocate_space_in_inferior (length
));
1772 write_memory (addr
, value_contents (value
), length
);
1774 = value_from_contents_and_address (type
, value_contents (value
),
1776 return value_addr (val
);
1779 return value_addr (value
); /* Program variables, e.g. arrays. */
1784 /* Prepare (and return) an argument value ready for an inferior function
1785 call to a Fortran function. EXP and POS are the expressions describing
1786 the argument to prepare. ARG_NUM is the argument number being
1787 prepared, with 0 being the first argument and so on. FUNC_TYPE is the
1788 type of the function being called.
1790 IS_INTERNAL_CALL_P is true if this is a call to a function of type
1791 TYPE_CODE_INTERNAL_FUNCTION, otherwise this parameter is false.
1793 NOSIDE has its usual meaning for expression parsing (see eval.c).
1795 Arguments in Fortran are normally passed by address, we coerce the
1796 arguments here rather than in value_arg_coerce as otherwise the call to
1797 malloc (to place the non-lvalue parameters in target memory) is hit by
1798 this Fortran specific logic. This results in malloc being called with a
1799 pointer to an integer followed by an attempt to malloc the arguments to
1800 malloc in target memory. Infinite recursion ensues. */
1803 fortran_prepare_argument (struct expression
*exp
, int *pos
,
1804 int arg_num
, bool is_internal_call_p
,
1805 struct type
*func_type
, enum noside noside
)
1807 if (is_internal_call_p
)
1808 return evaluate_subexp_with_coercion (exp
, pos
, noside
);
1810 bool is_artificial
= ((arg_num
>= func_type
->num_fields ())
1812 : TYPE_FIELD_ARTIFICIAL (func_type
, arg_num
));
1814 /* If this is an artificial argument, then either, this is an argument
1815 beyond the end of the known arguments, or possibly, there are no known
1816 arguments (maybe missing debug info).
1818 For these artificial arguments, if the user has prefixed it with '&'
1819 (for address-of), then lets always allow this to succeed, even if the
1820 argument is not actually in inferior memory. This will allow the user
1821 to pass arguments to a Fortran function even when there's no debug
1824 As we already pass the address of non-artificial arguments, all we
1825 need to do if skip the UNOP_ADDR operator in the expression and mark
1826 the argument as non-artificial. */
1827 if (is_artificial
&& exp
->elts
[*pos
].opcode
== UNOP_ADDR
)
1830 is_artificial
= false;
1833 struct value
*arg_val
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
1834 return fortran_argument_convert (arg_val
, is_artificial
);
1840 fortran_preserve_arg_pointer (struct value
*arg
, struct type
*type
)
1842 if (value_type (arg
)->code () == TYPE_CODE_PTR
)
1843 return value_type (arg
);
1850 fortran_adjust_dynamic_array_base_address_hack (struct type
*type
,
1853 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
1855 /* We can't adjust the base address for arrays that have no content. */
1856 if (type_not_allocated (type
) || type_not_associated (type
))
1859 int ndimensions
= calc_f77_array_dims (type
);
1860 LONGEST total_offset
= 0;
1862 /* Walk through each of the dimensions of this array type and figure out
1863 if any of the dimensions are "backwards", that is the base address
1864 for this dimension points to the element at the highest memory
1865 address and the stride is negative. */
1866 struct type
*tmp_type
= type
;
1867 for (int i
= 0 ; i
< ndimensions
; ++i
)
1869 /* Grab the range for this dimension and extract the lower and upper
1871 tmp_type
= check_typedef (tmp_type
);
1872 struct type
*range_type
= tmp_type
->index_type ();
1873 LONGEST lowerbound
, upperbound
, stride
;
1874 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
1875 error ("failed to get range bounds");
1877 /* Figure out the stride for this dimension. */
1878 struct type
*elt_type
= check_typedef (TYPE_TARGET_TYPE (tmp_type
));
1879 stride
= tmp_type
->index_type ()->bounds ()->bit_stride ();
1881 stride
= type_length_units (elt_type
);
1885 = gdbarch_addressable_memory_unit_size (elt_type
->arch ());
1886 stride
/= (unit_size
* 8);
1889 /* If this dimension is "backward" then figure out the offset
1890 adjustment required to point to the element at the lowest memory
1891 address, and add this to the total offset. */
1893 if (stride
< 0 && lowerbound
< upperbound
)
1894 offset
= (upperbound
- lowerbound
) * stride
;
1895 total_offset
+= offset
;
1896 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
1899 /* Adjust the address of this object and return it. */
1900 address
+= total_offset
;