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 struct value
*fortran_argument_convert (struct value
*value
,
74 /* Return the encoding that should be used for the character type
78 f_language::get_encoding (struct type
*type
)
82 switch (TYPE_LENGTH (type
))
85 encoding
= target_charset (get_type_arch (type
));
88 if (type_byte_order (type
) == BFD_ENDIAN_BIG
)
89 encoding
= "UTF-32BE";
91 encoding
= "UTF-32LE";
95 error (_("unrecognized character type"));
103 /* Table of operators and their precedences for printing expressions. */
105 const struct op_print
f_language::op_print_tab
[] =
107 {"+", BINOP_ADD
, PREC_ADD
, 0},
108 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
109 {"-", BINOP_SUB
, PREC_ADD
, 0},
110 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
111 {"*", BINOP_MUL
, PREC_MUL
, 0},
112 {"/", BINOP_DIV
, PREC_MUL
, 0},
113 {"DIV", BINOP_INTDIV
, PREC_MUL
, 0},
114 {"MOD", BINOP_REM
, PREC_MUL
, 0},
115 {"=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
116 {".OR.", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
117 {".AND.", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
118 {".NOT.", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
119 {".EQ.", BINOP_EQUAL
, PREC_EQUAL
, 0},
120 {".NE.", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
121 {".LE.", BINOP_LEQ
, PREC_ORDER
, 0},
122 {".GE.", BINOP_GEQ
, PREC_ORDER
, 0},
123 {".GT.", BINOP_GTR
, PREC_ORDER
, 0},
124 {".LT.", BINOP_LESS
, PREC_ORDER
, 0},
125 {"**", UNOP_IND
, PREC_PREFIX
, 0},
126 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
127 {NULL
, OP_NULL
, PREC_REPEAT
, 0}
131 /* Return the number of dimensions for a Fortran array or string. */
134 calc_f77_array_dims (struct type
*array_type
)
137 struct type
*tmp_type
;
139 if ((array_type
->code () == TYPE_CODE_STRING
))
142 if ((array_type
->code () != TYPE_CODE_ARRAY
))
143 error (_("Can't get dimensions for a non-array type"));
145 tmp_type
= array_type
;
147 while ((tmp_type
= TYPE_TARGET_TYPE (tmp_type
)))
149 if (tmp_type
->code () == TYPE_CODE_ARRAY
)
155 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
156 slices. This is a base class for two alternative repacking mechanisms,
157 one for when repacking from a lazy value, and one for repacking from a
158 non-lazy (already loaded) value. */
159 class fortran_array_repacker_base_impl
160 : public fortran_array_walker_base_impl
163 /* Constructor, DEST is the value we are repacking into. */
164 fortran_array_repacker_base_impl (struct value
*dest
)
169 /* When we start processing the inner most dimension, this is where we
170 will be creating values for each element as we load them and then copy
171 them into the M_DEST value. Set a value mark so we can free these
173 void start_dimension (bool inner_p
)
177 gdb_assert (m_mark
== nullptr);
178 m_mark
= value_mark ();
182 /* When we finish processing the inner most dimension free all temporary
183 value that were created. */
184 void finish_dimension (bool inner_p
, bool last_p
)
188 gdb_assert (m_mark
!= nullptr);
189 value_free_to_mark (m_mark
);
195 /* Copy the contents of array element ELT into M_DEST at the next
197 void copy_element_to_dest (struct value
*elt
)
199 value_contents_copy (m_dest
, m_dest_offset
, elt
, 0,
200 TYPE_LENGTH (value_type (elt
)));
201 m_dest_offset
+= TYPE_LENGTH (value_type (elt
));
204 /* The value being written to. */
205 struct value
*m_dest
;
207 /* The byte offset in M_DEST at which the next element should be
209 LONGEST m_dest_offset
;
211 /* Set with a call to VALUE_MARK, and then reset after calling
212 VALUE_FREE_TO_MARK. */
213 struct value
*m_mark
= nullptr;
216 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
217 slices. This class is specialised for repacking an array slice from a
218 lazy array value, as such it does not require the parent array value to
219 be loaded into GDB's memory; the parent value could be huge, while the
220 slice could be tiny. */
221 class fortran_lazy_array_repacker_impl
222 : public fortran_array_repacker_base_impl
225 /* Constructor. TYPE is the type of the slice being loaded from the
226 parent value, so this type will correctly reflect the strides required
227 to find all of the elements from the parent value. ADDRESS is the
228 address in target memory of value matching TYPE, and DEST is the value
229 we are repacking into. */
230 explicit fortran_lazy_array_repacker_impl (struct type
*type
,
233 : fortran_array_repacker_base_impl (dest
),
237 /* Create a lazy value in target memory representing a single element,
238 then load the element into GDB's memory and copy the contents into the
239 destination value. */
240 void process_element (struct type
*elt_type
, LONGEST elt_off
, bool last_p
)
242 copy_element_to_dest (value_at_lazy (elt_type
, m_addr
+ elt_off
));
246 /* The address in target memory where the parent value starts. */
250 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
251 slices. This class is specialised for repacking an array slice from a
252 previously loaded (non-lazy) array value, as such it fetches the
253 element values from the contents of the parent value. */
254 class fortran_array_repacker_impl
255 : public fortran_array_repacker_base_impl
258 /* Constructor. TYPE is the type for the array slice within the parent
259 value, as such it has stride values as required to find the elements
260 within the original parent value. ADDRESS is the address in target
261 memory of the value matching TYPE. BASE_OFFSET is the offset from
262 the start of VAL's content buffer to the start of the object of TYPE,
263 VAL is the parent object from which we are loading the value, and
264 DEST is the value into which we are repacking. */
265 explicit fortran_array_repacker_impl (struct type
*type
, CORE_ADDR address
,
267 struct value
*val
, struct value
*dest
)
268 : fortran_array_repacker_base_impl (dest
),
269 m_base_offset (base_offset
),
272 gdb_assert (!value_lazy (val
));
275 /* Extract an element of ELT_TYPE at offset (M_BASE_OFFSET + ELT_OFF)
276 from the content buffer of M_VAL then copy this extracted value into
277 the repacked destination value. */
278 void process_element (struct type
*elt_type
, LONGEST elt_off
, bool last_p
)
281 = value_from_component (m_val
, elt_type
, (elt_off
+ m_base_offset
));
282 copy_element_to_dest (elt
);
286 /* The offset into the content buffer of M_VAL to the start of the slice
288 LONGEST m_base_offset
;
290 /* The parent value from which we are extracting a slice. */
294 /* Called from evaluate_subexp_standard to perform array indexing, and
295 sub-range extraction, for Fortran. As well as arrays this function
296 also handles strings as they can be treated like arrays of characters.
297 ARRAY is the array or string being accessed. EXP, POS, and NOSIDE are
298 as for evaluate_subexp_standard, and NARGS is the number of arguments
299 in this access (e.g. 'array (1,2,3)' would be NARGS 3). */
301 static struct value
*
302 fortran_value_subarray (struct value
*array
, struct expression
*exp
,
303 int *pos
, int nargs
, enum noside noside
)
305 type
*original_array_type
= check_typedef (value_type (array
));
306 bool is_string_p
= original_array_type
->code () == TYPE_CODE_STRING
;
308 /* Perform checks for ARRAY not being available. The somewhat overly
309 complex logic here is just to keep backward compatibility with the
310 errors that we used to get before FORTRAN_VALUE_SUBARRAY was
311 rewritten. Maybe a future task would streamline the error messages we
312 get here, and update all the expected test results. */
313 if (exp
->elts
[*pos
].opcode
!= OP_RANGE
)
315 if (type_not_associated (original_array_type
))
316 error (_("no such vector element (vector not associated)"));
317 else if (type_not_allocated (original_array_type
))
318 error (_("no such vector element (vector not allocated)"));
322 if (type_not_associated (original_array_type
))
323 error (_("array not associated"));
324 else if (type_not_allocated (original_array_type
))
325 error (_("array not allocated"));
328 /* First check that the number of dimensions in the type we are slicing
329 matches the number of arguments we were passed. */
330 int ndimensions
= calc_f77_array_dims (original_array_type
);
331 if (nargs
!= ndimensions
)
332 error (_("Wrong number of subscripts"));
334 /* This will be initialised below with the type of the elements held in
336 struct type
*inner_element_type
;
338 /* Extract the types of each array dimension from the original array
339 type. We need these available so we can fill in the default upper and
340 lower bounds if the user requested slice doesn't provide that
341 information. Additionally unpacking the dimensions like this gives us
342 the inner element type. */
343 std::vector
<struct type
*> dim_types
;
345 dim_types
.reserve (ndimensions
);
346 struct type
*type
= original_array_type
;
347 for (int i
= 0; i
< ndimensions
; ++i
)
349 dim_types
.push_back (type
);
350 type
= TYPE_TARGET_TYPE (type
);
352 /* TYPE is now the inner element type of the array, we start the new
353 array slice off as this type, then as we process the requested slice
354 (from the user) we wrap new types around this to build up the final
356 inner_element_type
= type
;
359 /* As we analyse the new slice type we need to understand if the data
360 being referenced is contiguous. Do decide this we must track the size
361 of an element at each dimension of the new slice array. Initially the
362 elements of the inner most dimension of the array are the same inner
363 most elements as the original ARRAY. */
364 LONGEST slice_element_size
= TYPE_LENGTH (inner_element_type
);
366 /* Start off assuming all data is contiguous, this will be set to false
367 if access to any dimension results in non-contiguous data. */
368 bool is_all_contiguous
= true;
370 /* The TOTAL_OFFSET is the distance in bytes from the start of the
371 original ARRAY to the start of the new slice. This is calculated as
372 we process the information from the user. */
373 LONGEST total_offset
= 0;
375 /* A structure representing information about each dimension of the
380 slice_dim (LONGEST l
, LONGEST h
, LONGEST s
, struct type
*idx
)
387 /* The low bound for this dimension of the slice. */
390 /* The high bound for this dimension of the slice. */
393 /* The byte stride for this dimension of the slice. */
399 /* The dimensions of the resulting slice. */
400 std::vector
<slice_dim
> slice_dims
;
402 /* Process the incoming arguments. These arguments are in the reverse
403 order to the array dimensions, that is the first argument refers to
404 the last array dimension. */
405 if (fortran_array_slicing_debug
)
406 debug_printf ("Processing array access:\n");
407 for (int i
= 0; i
< nargs
; ++i
)
409 /* For each dimension of the array the user will have either provided
410 a ranged access with optional lower bound, upper bound, and
411 stride, or the user will have supplied a single index. */
412 struct type
*dim_type
= dim_types
[ndimensions
- (i
+ 1)];
413 if (exp
->elts
[*pos
].opcode
== OP_RANGE
)
416 enum range_flag range_flag
= (enum range_flag
) exp
->elts
[pc
].longconst
;
419 LONGEST low
, high
, stride
;
420 low
= high
= stride
= 0;
422 if ((range_flag
& RANGE_LOW_BOUND_DEFAULT
) == 0)
423 low
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
425 low
= f77_get_lowerbound (dim_type
);
426 if ((range_flag
& RANGE_HIGH_BOUND_DEFAULT
) == 0)
427 high
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
429 high
= f77_get_upperbound (dim_type
);
430 if ((range_flag
& RANGE_HAS_STRIDE
) == RANGE_HAS_STRIDE
)
431 stride
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
436 error (_("stride must not be 0"));
438 /* Get information about this dimension in the original ARRAY. */
439 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
440 struct type
*index_type
= dim_type
->index_type ();
441 LONGEST lb
= f77_get_lowerbound (dim_type
);
442 LONGEST ub
= f77_get_upperbound (dim_type
);
443 LONGEST sd
= index_type
->bit_stride ();
445 sd
= TYPE_LENGTH (target_type
) * 8;
447 if (fortran_array_slicing_debug
)
449 debug_printf ("|-> Range access\n");
450 std::string str
= type_to_string (dim_type
);
451 debug_printf ("| |-> Type: %s\n", str
.c_str ());
452 debug_printf ("| |-> Array:\n");
453 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
454 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
455 debug_printf ("| | |-> Bit stride: %s\n", plongest (sd
));
456 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
/ 8));
457 debug_printf ("| | |-> Type size: %s\n",
458 pulongest (TYPE_LENGTH (dim_type
)));
459 debug_printf ("| | '-> Target type size: %s\n",
460 pulongest (TYPE_LENGTH (target_type
)));
461 debug_printf ("| |-> Accessing:\n");
462 debug_printf ("| | |-> Low bound: %s\n",
464 debug_printf ("| | |-> High bound: %s\n",
466 debug_printf ("| | '-> Element stride: %s\n",
470 /* Check the user hasn't asked for something invalid. */
471 if (high
> ub
|| low
< lb
)
472 error (_("array subscript out of bounds"));
474 /* Calculate what this dimension of the new slice array will look
475 like. OFFSET is the byte offset from the start of the
476 previous (more outer) dimension to the start of this
477 dimension. E_COUNT is the number of elements in this
478 dimension. REMAINDER is the number of elements remaining
479 between the last included element and the upper bound. For
480 example an access '1:6:2' will include elements 1, 3, 5 and
481 have a remainder of 1 (element #6). */
482 LONGEST lowest
= std::min (low
, high
);
483 LONGEST offset
= (sd
/ 8) * (lowest
- lb
);
484 LONGEST e_count
= std::abs (high
- low
) + 1;
485 e_count
= (e_count
+ (std::abs (stride
) - 1)) / std::abs (stride
);
487 LONGEST new_high
= new_low
+ e_count
- 1;
488 LONGEST new_stride
= (sd
* stride
) / 8;
489 LONGEST last_elem
= low
+ ((e_count
- 1) * stride
);
490 LONGEST remainder
= high
- last_elem
;
493 offset
+= std::abs (remainder
) * TYPE_LENGTH (target_type
);
495 error (_("incorrect stride and boundary combination"));
498 error (_("incorrect stride and boundary combination"));
500 /* Is the data within this dimension contiguous? It is if the
501 newly computed stride is the same size as a single element of
503 bool is_dim_contiguous
= (new_stride
== slice_element_size
);
504 is_all_contiguous
&= is_dim_contiguous
;
506 if (fortran_array_slicing_debug
)
508 debug_printf ("| '-> Results:\n");
509 debug_printf ("| |-> Offset = %s\n", plongest (offset
));
510 debug_printf ("| |-> Elements = %s\n", plongest (e_count
));
511 debug_printf ("| |-> Low bound = %s\n", plongest (new_low
));
512 debug_printf ("| |-> High bound = %s\n",
513 plongest (new_high
));
514 debug_printf ("| |-> Byte stride = %s\n",
515 plongest (new_stride
));
516 debug_printf ("| |-> Last element = %s\n",
517 plongest (last_elem
));
518 debug_printf ("| |-> Remainder = %s\n",
519 plongest (remainder
));
520 debug_printf ("| '-> Contiguous = %s\n",
521 (is_dim_contiguous
? "Yes" : "No"));
524 /* Figure out how big (in bytes) an element of this dimension of
525 the new array slice will be. */
526 slice_element_size
= std::abs (new_stride
* e_count
);
528 slice_dims
.emplace_back (new_low
, new_high
, new_stride
,
531 /* Update the total offset. */
532 total_offset
+= offset
;
536 /* There is a single index for this dimension. */
538 = value_as_long (evaluate_subexp_with_coercion (exp
, pos
, noside
));
540 /* Get information about this dimension in the original ARRAY. */
541 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
542 struct type
*index_type
= dim_type
->index_type ();
543 LONGEST lb
= f77_get_lowerbound (dim_type
);
544 LONGEST ub
= f77_get_upperbound (dim_type
);
545 LONGEST sd
= index_type
->bit_stride () / 8;
547 sd
= TYPE_LENGTH (target_type
);
549 if (fortran_array_slicing_debug
)
551 debug_printf ("|-> Index access\n");
552 std::string str
= type_to_string (dim_type
);
553 debug_printf ("| |-> Type: %s\n", str
.c_str ());
554 debug_printf ("| |-> Array:\n");
555 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
556 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
557 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
));
558 debug_printf ("| | |-> Type size: %s\n",
559 pulongest (TYPE_LENGTH (dim_type
)));
560 debug_printf ("| | '-> Target type size: %s\n",
561 pulongest (TYPE_LENGTH (target_type
)));
562 debug_printf ("| '-> Accessing:\n");
563 debug_printf ("| '-> Index: %s\n",
567 /* If the array has actual content then check the index is in
568 bounds. An array without content (an unbound array) doesn't
569 have a known upper bound, so don't error check in that
572 || (dim_type
->index_type ()->bounds ()->high
.kind () != PROP_UNDEFINED
574 || (VALUE_LVAL (array
) != lval_memory
575 && dim_type
->index_type ()->bounds ()->high
.kind () == PROP_UNDEFINED
))
577 if (type_not_associated (dim_type
))
578 error (_("no such vector element (vector not associated)"));
579 else if (type_not_allocated (dim_type
))
580 error (_("no such vector element (vector not allocated)"));
582 error (_("no such vector element"));
585 /* Calculate using the type stride, not the target type size. */
586 LONGEST offset
= sd
* (index
- lb
);
587 total_offset
+= offset
;
591 if (noside
== EVAL_SKIP
)
594 /* Build a type that represents the new array slice in the target memory
595 of the original ARRAY, this type makes use of strides to correctly
596 find only those elements that are part of the new slice. */
597 struct type
*array_slice_type
= inner_element_type
;
598 for (const auto &d
: slice_dims
)
600 /* Create the range. */
601 dynamic_prop p_low
, p_high
, p_stride
;
603 p_low
.set_const_val (d
.low
);
604 p_high
.set_const_val (d
.high
);
605 p_stride
.set_const_val (d
.stride
);
607 struct type
*new_range
608 = create_range_type_with_stride ((struct type
*) NULL
,
609 TYPE_TARGET_TYPE (d
.index
),
610 &p_low
, &p_high
, 0, &p_stride
,
613 = create_array_type (nullptr, array_slice_type
, new_range
);
616 if (fortran_array_slicing_debug
)
618 debug_printf ("'-> Final result:\n");
619 debug_printf (" |-> Type: %s\n",
620 type_to_string (array_slice_type
).c_str ());
621 debug_printf (" |-> Total offset: %s\n",
622 plongest (total_offset
));
623 debug_printf (" |-> Base address: %s\n",
624 core_addr_to_string (value_address (array
)));
625 debug_printf (" '-> Contiguous = %s\n",
626 (is_all_contiguous
? "Yes" : "No"));
629 /* Should we repack this array slice? */
630 if (!is_all_contiguous
&& (repack_array_slices
|| is_string_p
))
632 /* Build a type for the repacked slice. */
633 struct type
*repacked_array_type
= inner_element_type
;
634 for (const auto &d
: slice_dims
)
636 /* Create the range. */
637 dynamic_prop p_low
, p_high
, p_stride
;
639 p_low
.set_const_val (d
.low
);
640 p_high
.set_const_val (d
.high
);
641 p_stride
.set_const_val (TYPE_LENGTH (repacked_array_type
));
643 struct type
*new_range
644 = create_range_type_with_stride ((struct type
*) NULL
,
645 TYPE_TARGET_TYPE (d
.index
),
646 &p_low
, &p_high
, 0, &p_stride
,
649 = create_array_type (nullptr, repacked_array_type
, new_range
);
652 /* Now copy the elements from the original ARRAY into the packed
654 struct value
*dest
= allocate_value (repacked_array_type
);
655 if (value_lazy (array
)
656 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
657 > TYPE_LENGTH (check_typedef (value_type (array
)))))
659 fortran_array_walker
<fortran_lazy_array_repacker_impl
> p
660 (array_slice_type
, value_address (array
) + total_offset
, dest
);
665 fortran_array_walker
<fortran_array_repacker_impl
> p
666 (array_slice_type
, value_address (array
) + total_offset
,
667 total_offset
, array
, dest
);
674 if (VALUE_LVAL (array
) == lval_memory
)
676 /* If the value we're taking a slice from is not yet loaded, or
677 the requested slice is outside the values content range then
678 just create a new lazy value pointing at the memory where the
679 contents we're looking for exist. */
680 if (value_lazy (array
)
681 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
682 > TYPE_LENGTH (check_typedef (value_type (array
)))))
683 array
= value_at_lazy (array_slice_type
,
684 value_address (array
) + total_offset
);
686 array
= value_from_contents_and_address (array_slice_type
,
687 (value_contents (array
)
689 (value_address (array
)
692 else if (!value_lazy (array
))
693 array
= value_from_component (array
, array_slice_type
, total_offset
);
695 error (_("cannot subscript arrays that are not in memory"));
701 /* Special expression evaluation cases for Fortran. */
703 static struct value
*
704 evaluate_subexp_f (struct type
*expect_type
, struct expression
*exp
,
705 int *pos
, enum noside noside
)
707 struct value
*arg1
= NULL
, *arg2
= NULL
;
714 op
= exp
->elts
[pc
].opcode
;
720 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
723 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
724 if (noside
== EVAL_SKIP
)
725 return eval_skip_value (exp
);
726 type
= value_type (arg1
);
727 switch (type
->code ())
732 = fabs (target_float_to_host_double (value_contents (arg1
),
734 return value_from_host_double (type
, d
);
738 LONGEST l
= value_as_long (arg1
);
740 return value_from_longest (type
, l
);
743 error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type
));
746 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
747 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
748 if (noside
== EVAL_SKIP
)
749 return eval_skip_value (exp
);
750 type
= value_type (arg1
);
751 if (type
->code () != value_type (arg2
)->code ())
752 error (_("non-matching types for parameters to MOD ()"));
753 switch (type
->code ())
758 = target_float_to_host_double (value_contents (arg1
),
761 = target_float_to_host_double (value_contents (arg2
),
763 double d3
= fmod (d1
, d2
);
764 return value_from_host_double (type
, d3
);
768 LONGEST v1
= value_as_long (arg1
);
769 LONGEST v2
= value_as_long (arg2
);
771 error (_("calling MOD (N, 0) is undefined"));
772 LONGEST v3
= v1
- (v1
/ v2
) * v2
;
773 return value_from_longest (value_type (arg1
), v3
);
776 error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type
));
778 case UNOP_FORTRAN_CEILING
:
780 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
781 if (noside
== EVAL_SKIP
)
782 return eval_skip_value (exp
);
783 type
= value_type (arg1
);
784 if (type
->code () != TYPE_CODE_FLT
)
785 error (_("argument to CEILING must be of type float"));
787 = target_float_to_host_double (value_contents (arg1
),
790 return value_from_host_double (type
, val
);
793 case UNOP_FORTRAN_FLOOR
:
795 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
796 if (noside
== EVAL_SKIP
)
797 return eval_skip_value (exp
);
798 type
= value_type (arg1
);
799 if (type
->code () != TYPE_CODE_FLT
)
800 error (_("argument to FLOOR must be of type float"));
802 = target_float_to_host_double (value_contents (arg1
),
805 return value_from_host_double (type
, val
);
808 case BINOP_FORTRAN_MODULO
:
810 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
811 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
812 if (noside
== EVAL_SKIP
)
813 return eval_skip_value (exp
);
814 type
= value_type (arg1
);
815 if (type
->code () != value_type (arg2
)->code ())
816 error (_("non-matching types for parameters to MODULO ()"));
817 /* MODULO(A, P) = A - FLOOR (A / P) * P */
818 switch (type
->code ())
822 LONGEST a
= value_as_long (arg1
);
823 LONGEST p
= value_as_long (arg2
);
824 LONGEST result
= a
- (a
/ p
) * p
;
825 if (result
!= 0 && (a
< 0) != (p
< 0))
827 return value_from_longest (value_type (arg1
), result
);
832 = target_float_to_host_double (value_contents (arg1
),
835 = target_float_to_host_double (value_contents (arg2
),
837 double result
= fmod (a
, p
);
838 if (result
!= 0 && (a
< 0.0) != (p
< 0.0))
840 return value_from_host_double (type
, result
);
843 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type
));
846 case BINOP_FORTRAN_CMPLX
:
847 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
848 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
849 if (noside
== EVAL_SKIP
)
850 return eval_skip_value (exp
);
851 type
= builtin_f_type(exp
->gdbarch
)->builtin_complex_s16
;
852 return value_literal_complex (arg1
, arg2
, type
);
854 case UNOP_FORTRAN_KIND
:
855 arg1
= evaluate_subexp (NULL
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
856 type
= value_type (arg1
);
858 switch (type
->code ())
860 case TYPE_CODE_STRUCT
:
861 case TYPE_CODE_UNION
:
862 case TYPE_CODE_MODULE
:
864 error (_("argument to kind must be an intrinsic type"));
867 if (!TYPE_TARGET_TYPE (type
))
868 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
870 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
871 TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
874 case OP_F77_UNDETERMINED_ARGLIST
:
875 /* Remember that in F77, functions, substring ops and array subscript
876 operations cannot be disambiguated at parse time. We have made
877 all array subscript operations, substring operations as well as
878 function calls come here and we now have to discover what the heck
879 this thing actually was. If it is a function, we process just as
880 if we got an OP_FUNCALL. */
881 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
884 /* First determine the type code we are dealing with. */
885 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
886 type
= check_typedef (value_type (arg1
));
887 enum type_code code
= type
->code ();
889 if (code
== TYPE_CODE_PTR
)
891 /* Fortran always passes variable to subroutines as pointer.
892 So we need to look into its target type to see if it is
893 array, string or function. If it is, we need to switch
894 to the target value the original one points to. */
895 struct type
*target_type
= check_typedef (TYPE_TARGET_TYPE (type
));
897 if (target_type
->code () == TYPE_CODE_ARRAY
898 || target_type
->code () == TYPE_CODE_STRING
899 || target_type
->code () == TYPE_CODE_FUNC
)
901 arg1
= value_ind (arg1
);
902 type
= check_typedef (value_type (arg1
));
903 code
= type
->code ();
909 case TYPE_CODE_ARRAY
:
910 case TYPE_CODE_STRING
:
911 return fortran_value_subarray (arg1
, exp
, pos
, nargs
, noside
);
915 case TYPE_CODE_INTERNAL_FUNCTION
:
917 /* It's a function call. Allocate arg vector, including
918 space for the function to be called in argvec[0] and a
920 struct value
**argvec
= (struct value
**)
921 alloca (sizeof (struct value
*) * (nargs
+ 2));
924 for (; tem
<= nargs
; tem
++)
926 argvec
[tem
] = evaluate_subexp_with_coercion (exp
, pos
, noside
);
927 /* Arguments in Fortran are passed by address. Coerce the
928 arguments here rather than in value_arg_coerce as
929 otherwise the call to malloc to place the non-lvalue
930 parameters in target memory is hit by this Fortran
931 specific logic. This results in malloc being called
932 with a pointer to an integer followed by an attempt to
933 malloc the arguments to malloc in target memory.
934 Infinite recursion ensues. */
935 if (code
== TYPE_CODE_PTR
|| code
== TYPE_CODE_FUNC
)
938 = TYPE_FIELD_ARTIFICIAL (value_type (arg1
), tem
- 1);
939 argvec
[tem
] = fortran_argument_convert (argvec
[tem
],
943 argvec
[tem
] = 0; /* signal end of arglist */
944 if (noside
== EVAL_SKIP
)
945 return eval_skip_value (exp
);
946 return evaluate_subexp_do_call (exp
, noside
, argvec
[0],
947 gdb::make_array_view (argvec
+ 1,
953 error (_("Cannot perform substring on this type"));
957 /* Should be unreachable. */
961 /* Special expression lengths for Fortran. */
964 operator_length_f (const struct expression
*exp
, int pc
, int *oplenp
,
970 switch (exp
->elts
[pc
- 1].opcode
)
973 operator_length_standard (exp
, pc
, oplenp
, argsp
);
976 case UNOP_FORTRAN_KIND
:
977 case UNOP_FORTRAN_FLOOR
:
978 case UNOP_FORTRAN_CEILING
:
983 case BINOP_FORTRAN_CMPLX
:
984 case BINOP_FORTRAN_MODULO
:
989 case OP_F77_UNDETERMINED_ARGLIST
:
991 args
= 1 + longest_to_int (exp
->elts
[pc
- 2].longconst
);
999 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1000 the extra argument NAME which is the text that should be printed as the
1001 name of this operation. */
1004 print_unop_subexp_f (struct expression
*exp
, int *pos
,
1005 struct ui_file
*stream
, enum precedence prec
,
1009 fprintf_filtered (stream
, "%s(", name
);
1010 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1011 fputs_filtered (")", stream
);
1014 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1015 the extra argument NAME which is the text that should be printed as the
1016 name of this operation. */
1019 print_binop_subexp_f (struct expression
*exp
, int *pos
,
1020 struct ui_file
*stream
, enum precedence prec
,
1024 fprintf_filtered (stream
, "%s(", name
);
1025 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1026 fputs_filtered (",", stream
);
1027 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1028 fputs_filtered (")", stream
);
1031 /* Special expression printing for Fortran. */
1034 print_subexp_f (struct expression
*exp
, int *pos
,
1035 struct ui_file
*stream
, enum precedence prec
)
1038 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
1043 print_subexp_standard (exp
, pos
, stream
, prec
);
1046 case UNOP_FORTRAN_KIND
:
1047 print_unop_subexp_f (exp
, pos
, stream
, prec
, "KIND");
1050 case UNOP_FORTRAN_FLOOR
:
1051 print_unop_subexp_f (exp
, pos
, stream
, prec
, "FLOOR");
1054 case UNOP_FORTRAN_CEILING
:
1055 print_unop_subexp_f (exp
, pos
, stream
, prec
, "CEILING");
1058 case BINOP_FORTRAN_CMPLX
:
1059 print_binop_subexp_f (exp
, pos
, stream
, prec
, "CMPLX");
1062 case BINOP_FORTRAN_MODULO
:
1063 print_binop_subexp_f (exp
, pos
, stream
, prec
, "MODULO");
1066 case OP_F77_UNDETERMINED_ARGLIST
:
1068 print_subexp_funcall (exp
, pos
, stream
);
1073 /* Special expression dumping for Fortran. */
1076 dump_subexp_body_f (struct expression
*exp
,
1077 struct ui_file
*stream
, int elt
)
1079 int opcode
= exp
->elts
[elt
].opcode
;
1080 int oplen
, nargs
, i
;
1085 return dump_subexp_body_standard (exp
, stream
, elt
);
1087 case UNOP_FORTRAN_KIND
:
1088 case UNOP_FORTRAN_FLOOR
:
1089 case UNOP_FORTRAN_CEILING
:
1090 case BINOP_FORTRAN_CMPLX
:
1091 case BINOP_FORTRAN_MODULO
:
1092 operator_length_f (exp
, (elt
+ 1), &oplen
, &nargs
);
1095 case OP_F77_UNDETERMINED_ARGLIST
:
1096 return dump_subexp_body_funcall (exp
, stream
, elt
+ 1);
1100 for (i
= 0; i
< nargs
; i
+= 1)
1101 elt
= dump_subexp (exp
, stream
, elt
);
1106 /* Special expression checking for Fortran. */
1109 operator_check_f (struct expression
*exp
, int pos
,
1110 int (*objfile_func
) (struct objfile
*objfile
,
1114 const union exp_element
*const elts
= exp
->elts
;
1116 switch (elts
[pos
].opcode
)
1118 case UNOP_FORTRAN_KIND
:
1119 case UNOP_FORTRAN_FLOOR
:
1120 case UNOP_FORTRAN_CEILING
:
1121 case BINOP_FORTRAN_CMPLX
:
1122 case BINOP_FORTRAN_MODULO
:
1123 /* Any references to objfiles are held in the arguments to this
1124 expression, not within the expression itself, so no additional
1125 checking is required here, the outer expression iteration code
1126 will take care of checking each argument. */
1130 return operator_check_standard (exp
, pos
, objfile_func
, data
);
1136 /* Expression processing for Fortran. */
1137 const struct exp_descriptor
f_language::exp_descriptor_tab
=
1146 /* See language.h. */
1149 f_language::language_arch_info (struct gdbarch
*gdbarch
,
1150 struct language_arch_info
*lai
) const
1152 const struct builtin_f_type
*builtin
= builtin_f_type (gdbarch
);
1154 /* Helper function to allow shorter lines below. */
1155 auto add
= [&] (struct type
* t
)
1157 lai
->add_primitive_type (t
);
1160 add (builtin
->builtin_character
);
1161 add (builtin
->builtin_logical
);
1162 add (builtin
->builtin_logical_s1
);
1163 add (builtin
->builtin_logical_s2
);
1164 add (builtin
->builtin_logical_s8
);
1165 add (builtin
->builtin_real
);
1166 add (builtin
->builtin_real_s8
);
1167 add (builtin
->builtin_real_s16
);
1168 add (builtin
->builtin_complex_s8
);
1169 add (builtin
->builtin_complex_s16
);
1170 add (builtin
->builtin_void
);
1172 lai
->set_string_char_type (builtin
->builtin_character
);
1173 lai
->set_bool_type (builtin
->builtin_logical_s2
, "logical");
1176 /* See language.h. */
1179 f_language::search_name_hash (const char *name
) const
1181 return cp_search_name_hash (name
);
1184 /* See language.h. */
1187 f_language::lookup_symbol_nonlocal (const char *name
,
1188 const struct block
*block
,
1189 const domain_enum domain
) const
1191 return cp_lookup_symbol_nonlocal (this, name
, block
, domain
);
1194 /* See language.h. */
1196 symbol_name_matcher_ftype
*
1197 f_language::get_symbol_name_matcher_inner
1198 (const lookup_name_info
&lookup_name
) const
1200 return cp_get_symbol_name_matcher (lookup_name
);
1203 /* Single instance of the Fortran language class. */
1205 static f_language f_language_defn
;
1208 build_fortran_types (struct gdbarch
*gdbarch
)
1210 struct builtin_f_type
*builtin_f_type
1211 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_f_type
);
1213 builtin_f_type
->builtin_void
1214 = arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
, "void");
1216 builtin_f_type
->builtin_character
1217 = arch_type (gdbarch
, TYPE_CODE_CHAR
, TARGET_CHAR_BIT
, "character");
1219 builtin_f_type
->builtin_logical_s1
1220 = arch_boolean_type (gdbarch
, TARGET_CHAR_BIT
, 1, "logical*1");
1222 builtin_f_type
->builtin_integer_s2
1223 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
), 0,
1226 builtin_f_type
->builtin_integer_s8
1227 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 0,
1230 builtin_f_type
->builtin_logical_s2
1231 = arch_boolean_type (gdbarch
, gdbarch_short_bit (gdbarch
), 1,
1234 builtin_f_type
->builtin_logical_s8
1235 = arch_boolean_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 1,
1238 builtin_f_type
->builtin_integer
1239 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 0,
1242 builtin_f_type
->builtin_logical
1243 = arch_boolean_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1,
1246 builtin_f_type
->builtin_real
1247 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
1248 "real", gdbarch_float_format (gdbarch
));
1249 builtin_f_type
->builtin_real_s8
1250 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
1251 "real*8", gdbarch_double_format (gdbarch
));
1252 auto fmt
= gdbarch_floatformat_for_type (gdbarch
, "real(kind=16)", 128);
1254 builtin_f_type
->builtin_real_s16
1255 = arch_float_type (gdbarch
, 128, "real*16", fmt
);
1256 else if (gdbarch_long_double_bit (gdbarch
) == 128)
1257 builtin_f_type
->builtin_real_s16
1258 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
1259 "real*16", gdbarch_long_double_format (gdbarch
));
1261 builtin_f_type
->builtin_real_s16
1262 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 128, "real*16");
1264 builtin_f_type
->builtin_complex_s8
1265 = init_complex_type ("complex*8", builtin_f_type
->builtin_real
);
1266 builtin_f_type
->builtin_complex_s16
1267 = init_complex_type ("complex*16", builtin_f_type
->builtin_real_s8
);
1269 if (builtin_f_type
->builtin_real_s16
->code () == TYPE_CODE_ERROR
)
1270 builtin_f_type
->builtin_complex_s32
1271 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 256, "complex*32");
1273 builtin_f_type
->builtin_complex_s32
1274 = init_complex_type ("complex*32", builtin_f_type
->builtin_real_s16
);
1276 return builtin_f_type
;
1279 static struct gdbarch_data
*f_type_data
;
1281 const struct builtin_f_type
*
1282 builtin_f_type (struct gdbarch
*gdbarch
)
1284 return (const struct builtin_f_type
*) gdbarch_data (gdbarch
, f_type_data
);
1287 /* Command-list for the "set/show fortran" prefix command. */
1288 static struct cmd_list_element
*set_fortran_list
;
1289 static struct cmd_list_element
*show_fortran_list
;
1291 void _initialize_f_language ();
1293 _initialize_f_language ()
1295 f_type_data
= gdbarch_data_register_post_init (build_fortran_types
);
1297 add_basic_prefix_cmd ("fortran", no_class
,
1298 _("Prefix command for changing Fortran-specific settings."),
1299 &set_fortran_list
, "set fortran ", 0, &setlist
);
1301 add_show_prefix_cmd ("fortran", no_class
,
1302 _("Generic command for showing Fortran-specific settings."),
1303 &show_fortran_list
, "show fortran ", 0, &showlist
);
1305 add_setshow_boolean_cmd ("repack-array-slices", class_vars
,
1306 &repack_array_slices
, _("\
1307 Enable or disable repacking of non-contiguous array slices."), _("\
1308 Show whether non-contiguous array slices are repacked."), _("\
1309 When the user requests a slice of a Fortran array then we can either return\n\
1310 a descriptor that describes the array in place (using the original array data\n\
1311 in its existing location) or the original data can be repacked (copied) to a\n\
1314 When the content of the array slice is contiguous within the original array\n\
1315 then the result will never be repacked, but when the data for the new array\n\
1316 is non-contiguous within the original array repacking will only be performed\n\
1317 when this setting is on."),
1319 show_repack_array_slices
,
1320 &set_fortran_list
, &show_fortran_list
);
1322 /* Debug Fortran's array slicing logic. */
1323 add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance
,
1324 &fortran_array_slicing_debug
, _("\
1325 Set debugging of Fortran array slicing."), _("\
1326 Show debugging of Fortran array slicing."), _("\
1327 When on, debugging of Fortran array slicing is enabled."),
1329 show_fortran_array_slicing_debug
,
1330 &setdebuglist
, &showdebuglist
);
1333 /* Ensures that function argument VALUE is in the appropriate form to
1334 pass to a Fortran function. Returns a possibly new value that should
1335 be used instead of VALUE.
1337 When IS_ARTIFICIAL is true this indicates an artificial argument,
1338 e.g. hidden string lengths which the GNU Fortran argument passing
1339 convention specifies as being passed by value.
1341 When IS_ARTIFICIAL is false, the argument is passed by pointer. If the
1342 value is already in target memory then return a value that is a pointer
1343 to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate
1344 space in the target, copy VALUE in, and return a pointer to the in
1347 static struct value
*
1348 fortran_argument_convert (struct value
*value
, bool is_artificial
)
1352 /* If the value is not in the inferior e.g. registers values,
1353 convenience variables and user input. */
1354 if (VALUE_LVAL (value
) != lval_memory
)
1356 struct type
*type
= value_type (value
);
1357 const int length
= TYPE_LENGTH (type
);
1358 const CORE_ADDR addr
1359 = value_as_long (value_allocate_space_in_inferior (length
));
1360 write_memory (addr
, value_contents (value
), length
);
1362 = value_from_contents_and_address (type
, value_contents (value
),
1364 return value_addr (val
);
1367 return value_addr (value
); /* Program variables, e.g. arrays. */
1375 fortran_preserve_arg_pointer (struct value
*arg
, struct type
*type
)
1377 if (value_type (arg
)->code () == TYPE_CODE_PTR
)
1378 return value_type (arg
);
1385 fortran_adjust_dynamic_array_base_address_hack (struct type
*type
,
1388 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
1390 /* We can't adjust the base address for arrays that have no content. */
1391 if (type_not_allocated (type
) || type_not_associated (type
))
1394 int ndimensions
= calc_f77_array_dims (type
);
1395 LONGEST total_offset
= 0;
1397 /* Walk through each of the dimensions of this array type and figure out
1398 if any of the dimensions are "backwards", that is the base address
1399 for this dimension points to the element at the highest memory
1400 address and the stride is negative. */
1401 struct type
*tmp_type
= type
;
1402 for (int i
= 0 ; i
< ndimensions
; ++i
)
1404 /* Grab the range for this dimension and extract the lower and upper
1406 tmp_type
= check_typedef (tmp_type
);
1407 struct type
*range_type
= tmp_type
->index_type ();
1408 LONGEST lowerbound
, upperbound
, stride
;
1409 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
1410 error ("failed to get range bounds");
1412 /* Figure out the stride for this dimension. */
1413 struct type
*elt_type
= check_typedef (TYPE_TARGET_TYPE (tmp_type
));
1414 stride
= tmp_type
->index_type ()->bounds ()->bit_stride ();
1416 stride
= type_length_units (elt_type
);
1419 struct gdbarch
*arch
= get_type_arch (elt_type
);
1420 int unit_size
= gdbarch_addressable_memory_unit_size (arch
);
1421 stride
/= (unit_size
* 8);
1424 /* If this dimension is "backward" then figure out the offset
1425 adjustment required to point to the element at the lowest memory
1426 address, and add this to the total offset. */
1428 if (stride
< 0 && lowerbound
< upperbound
)
1429 offset
= (upperbound
- lowerbound
) * stride
;
1430 total_offset
+= offset
;
1431 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
1434 /* Adjust the address of this object and return it. */
1435 address
+= total_offset
;