1 /* Fortran language support routines for GDB, the GNU debugger.
3 Copyright (C) 1993-2022 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"
45 /* Whether GDB should repack array slices created by the user. */
46 static bool repack_array_slices
= false;
48 /* Implement 'show fortran repack-array-slices'. */
50 show_repack_array_slices (struct ui_file
*file
, int from_tty
,
51 struct cmd_list_element
*c
, const char *value
)
53 gdb_printf (file
, _("Repacking of Fortran array slices is %s.\n"),
57 /* Debugging of Fortran's array slicing. */
58 static bool fortran_array_slicing_debug
= false;
60 /* Implement 'show debug fortran-array-slicing'. */
62 show_fortran_array_slicing_debug (struct ui_file
*file
, int from_tty
,
63 struct cmd_list_element
*c
,
66 gdb_printf (file
, _("Debugging of Fortran array slicing is %s.\n"),
72 static value
*fortran_prepare_argument (struct expression
*exp
,
73 expr::operation
*subexp
,
74 int arg_num
, bool is_internal_call_p
,
75 struct type
*func_type
, enum noside noside
);
77 /* Return the encoding that should be used for the character type
81 f_language::get_encoding (struct type
*type
)
85 switch (TYPE_LENGTH (type
))
88 encoding
= target_charset (type
->arch ());
91 if (type_byte_order (type
) == BFD_ENDIAN_BIG
)
92 encoding
= "UTF-32BE";
94 encoding
= "UTF-32LE";
98 error (_("unrecognized character type"));
104 /* A helper function for the "bound" intrinsics that checks that TYPE
105 is an array. LBOUND_P is true for lower bound; this is used for
106 the error message, if any. */
109 fortran_require_array (struct type
*type
, bool lbound_p
)
111 type
= check_typedef (type
);
112 if (type
->code () != TYPE_CODE_ARRAY
)
115 error (_("LBOUND can only be applied to arrays"));
117 error (_("UBOUND can only be applied to arrays"));
121 /* Create an array containing the lower bounds (when LBOUND_P is true) or
122 the upper bounds (when LBOUND_P is false) of ARRAY (which must be of
123 array type). GDBARCH is the current architecture. */
125 static struct value
*
126 fortran_bounds_all_dims (bool lbound_p
,
127 struct gdbarch
*gdbarch
,
130 type
*array_type
= check_typedef (value_type (array
));
131 int ndimensions
= calc_f77_array_dims (array_type
);
133 /* Allocate a result value of the correct type. */
135 = create_static_range_type (nullptr,
136 builtin_type (gdbarch
)->builtin_int
,
138 struct type
*elm_type
= builtin_type (gdbarch
)->builtin_long_long
;
139 struct type
*result_type
= create_array_type (nullptr, elm_type
, range
);
140 struct value
*result
= allocate_value (result_type
);
142 /* Walk the array dimensions backwards due to the way the array will be
143 laid out in memory, the first dimension will be the most inner. */
144 LONGEST elm_len
= TYPE_LENGTH (elm_type
);
145 for (LONGEST dst_offset
= elm_len
* (ndimensions
- 1);
147 dst_offset
-= elm_len
)
151 /* Grab the required bound. */
153 b
= f77_get_lowerbound (array_type
);
155 b
= f77_get_upperbound (array_type
);
157 /* And copy the value into the result value. */
158 struct value
*v
= value_from_longest (elm_type
, b
);
159 gdb_assert (dst_offset
+ TYPE_LENGTH (value_type (v
))
160 <= TYPE_LENGTH (value_type (result
)));
161 gdb_assert (TYPE_LENGTH (value_type (v
)) == elm_len
);
162 value_contents_copy (result
, dst_offset
, v
, 0, elm_len
);
164 /* Peel another dimension of the array. */
165 array_type
= TYPE_TARGET_TYPE (array_type
);
171 /* Return the lower bound (when LBOUND_P is true) or the upper bound (when
172 LBOUND_P is false) for dimension DIM_VAL (which must be an integer) of
173 ARRAY (which must be an array). GDBARCH is the current architecture. */
175 static struct value
*
176 fortran_bounds_for_dimension (bool lbound_p
,
177 struct gdbarch
*gdbarch
,
179 struct value
*dim_val
)
181 /* Check the requested dimension is valid for this array. */
182 type
*array_type
= check_typedef (value_type (array
));
183 int ndimensions
= calc_f77_array_dims (array_type
);
184 long dim
= value_as_long (dim_val
);
185 if (dim
< 1 || dim
> ndimensions
)
188 error (_("LBOUND dimension must be from 1 to %d"), ndimensions
);
190 error (_("UBOUND dimension must be from 1 to %d"), ndimensions
);
193 /* The type for the result. */
194 struct type
*bound_type
= builtin_type (gdbarch
)->builtin_long_long
;
196 /* Walk the dimensions backwards, due to the ordering in which arrays are
197 laid out the first dimension is the most inner. */
198 for (int i
= ndimensions
- 1; i
>= 0; --i
)
200 /* If this is the requested dimension then we're done. Grab the
201 bounds and return. */
207 b
= f77_get_lowerbound (array_type
);
209 b
= f77_get_upperbound (array_type
);
211 return value_from_longest (bound_type
, b
);
214 /* Peel off another dimension of the array. */
215 array_type
= TYPE_TARGET_TYPE (array_type
);
218 gdb_assert_not_reached ("failed to find matching dimension");
221 /* Return the number of dimensions for a Fortran array or string. */
224 calc_f77_array_dims (struct type
*array_type
)
227 struct type
*tmp_type
;
229 if ((array_type
->code () == TYPE_CODE_STRING
))
232 if ((array_type
->code () != TYPE_CODE_ARRAY
))
233 error (_("Can't get dimensions for a non-array type"));
235 tmp_type
= array_type
;
237 while ((tmp_type
= TYPE_TARGET_TYPE (tmp_type
)))
239 if (tmp_type
->code () == TYPE_CODE_ARRAY
)
245 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
246 slices. This is a base class for two alternative repacking mechanisms,
247 one for when repacking from a lazy value, and one for repacking from a
248 non-lazy (already loaded) value. */
249 class fortran_array_repacker_base_impl
250 : public fortran_array_walker_base_impl
253 /* Constructor, DEST is the value we are repacking into. */
254 fortran_array_repacker_base_impl (struct value
*dest
)
259 /* When we start processing the inner most dimension, this is where we
260 will be creating values for each element as we load them and then copy
261 them into the M_DEST value. Set a value mark so we can free these
263 void start_dimension (struct type
*index_type
, LONGEST nelts
, bool inner_p
)
267 gdb_assert (m_mark
== nullptr);
268 m_mark
= value_mark ();
272 /* When we finish processing the inner most dimension free all temporary
273 value that were created. */
274 void finish_dimension (bool inner_p
, bool last_p
)
278 gdb_assert (m_mark
!= nullptr);
279 value_free_to_mark (m_mark
);
285 /* Copy the contents of array element ELT into M_DEST at the next
287 void copy_element_to_dest (struct value
*elt
)
289 value_contents_copy (m_dest
, m_dest_offset
, elt
, 0,
290 TYPE_LENGTH (value_type (elt
)));
291 m_dest_offset
+= TYPE_LENGTH (value_type (elt
));
294 /* The value being written to. */
295 struct value
*m_dest
;
297 /* The byte offset in M_DEST at which the next element should be
299 LONGEST m_dest_offset
;
301 /* Set with a call to VALUE_MARK, and then reset after calling
302 VALUE_FREE_TO_MARK. */
303 struct value
*m_mark
= nullptr;
306 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
307 slices. This class is specialised for repacking an array slice from a
308 lazy array value, as such it does not require the parent array value to
309 be loaded into GDB's memory; the parent value could be huge, while the
310 slice could be tiny. */
311 class fortran_lazy_array_repacker_impl
312 : public fortran_array_repacker_base_impl
315 /* Constructor. TYPE is the type of the slice being loaded from the
316 parent value, so this type will correctly reflect the strides required
317 to find all of the elements from the parent value. ADDRESS is the
318 address in target memory of value matching TYPE, and DEST is the value
319 we are repacking into. */
320 explicit fortran_lazy_array_repacker_impl (struct type
*type
,
323 : fortran_array_repacker_base_impl (dest
),
327 /* Create a lazy value in target memory representing a single element,
328 then load the element into GDB's memory and copy the contents into the
329 destination value. */
330 void process_element (struct type
*elt_type
, LONGEST elt_off
,
331 LONGEST index
, bool last_p
)
333 copy_element_to_dest (value_at_lazy (elt_type
, m_addr
+ elt_off
));
337 /* The address in target memory where the parent value starts. */
341 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
342 slices. This class is specialised for repacking an array slice from a
343 previously loaded (non-lazy) array value, as such it fetches the
344 element values from the contents of the parent value. */
345 class fortran_array_repacker_impl
346 : public fortran_array_repacker_base_impl
349 /* Constructor. TYPE is the type for the array slice within the parent
350 value, as such it has stride values as required to find the elements
351 within the original parent value. ADDRESS is the address in target
352 memory of the value matching TYPE. BASE_OFFSET is the offset from
353 the start of VAL's content buffer to the start of the object of TYPE,
354 VAL is the parent object from which we are loading the value, and
355 DEST is the value into which we are repacking. */
356 explicit fortran_array_repacker_impl (struct type
*type
, CORE_ADDR address
,
358 struct value
*val
, struct value
*dest
)
359 : fortran_array_repacker_base_impl (dest
),
360 m_base_offset (base_offset
),
363 gdb_assert (!value_lazy (val
));
366 /* Extract an element of ELT_TYPE at offset (M_BASE_OFFSET + ELT_OFF)
367 from the content buffer of M_VAL then copy this extracted value into
368 the repacked destination value. */
369 void process_element (struct type
*elt_type
, LONGEST elt_off
,
370 LONGEST index
, bool last_p
)
373 = value_from_component (m_val
, elt_type
, (elt_off
+ m_base_offset
));
374 copy_element_to_dest (elt
);
378 /* The offset into the content buffer of M_VAL to the start of the slice
380 LONGEST m_base_offset
;
382 /* The parent value from which we are extracting a slice. */
387 /* Evaluate FORTRAN_ASSOCIATED expressions. Both GDBARCH and LANG are
388 extracted from the expression being evaluated. POINTER is the required
389 first argument to the 'associated' keyword, and TARGET is the optional
390 second argument, this will be nullptr if the user only passed one
391 argument to their use of 'associated'. */
393 static struct value
*
394 fortran_associated (struct gdbarch
*gdbarch
, const language_defn
*lang
,
395 struct value
*pointer
, struct value
*target
= nullptr)
397 struct type
*result_type
= language_bool_type (lang
, gdbarch
);
399 /* All Fortran pointers should have the associated property, this is
400 how we know the pointer is pointing at something or not. */
401 struct type
*pointer_type
= check_typedef (value_type (pointer
));
402 if (TYPE_ASSOCIATED_PROP (pointer_type
) == nullptr
403 && pointer_type
->code () != TYPE_CODE_PTR
)
404 error (_("ASSOCIATED can only be applied to pointers"));
406 /* Get an address from POINTER. Fortran (or at least gfortran) models
407 array pointers as arrays with a dynamic data address, so we need to
408 use two approaches here, for real pointers we take the contents of the
409 pointer as an address. For non-pointers we take the address of the
411 CORE_ADDR pointer_addr
;
412 if (pointer_type
->code () == TYPE_CODE_PTR
)
413 pointer_addr
= value_as_address (pointer
);
415 pointer_addr
= value_address (pointer
);
417 /* The single argument case, is POINTER associated with anything? */
418 if (target
== nullptr)
420 bool is_associated
= false;
422 /* If POINTER is an actual pointer and doesn't have an associated
423 property then we need to figure out whether this pointer is
424 associated by looking at the value of the pointer itself. We make
425 the assumption that a non-associated pointer will be set to 0.
426 This is probably true for most targets, but might not be true for
428 if (pointer_type
->code () == TYPE_CODE_PTR
429 && TYPE_ASSOCIATED_PROP (pointer_type
) == nullptr)
430 is_associated
= (pointer_addr
!= 0);
432 is_associated
= !type_not_associated (pointer_type
);
433 return value_from_longest (result_type
, is_associated
? 1 : 0);
436 /* The two argument case, is POINTER associated with TARGET? */
438 struct type
*target_type
= check_typedef (value_type (target
));
440 struct type
*pointer_target_type
;
441 if (pointer_type
->code () == TYPE_CODE_PTR
)
442 pointer_target_type
= TYPE_TARGET_TYPE (pointer_type
);
444 pointer_target_type
= pointer_type
;
446 struct type
*target_target_type
;
447 if (target_type
->code () == TYPE_CODE_PTR
)
448 target_target_type
= TYPE_TARGET_TYPE (target_type
);
450 target_target_type
= target_type
;
452 if (pointer_target_type
->code () != target_target_type
->code ()
453 || (pointer_target_type
->code () != TYPE_CODE_ARRAY
454 && (TYPE_LENGTH (pointer_target_type
)
455 != TYPE_LENGTH (target_target_type
))))
456 error (_("arguments to associated must be of same type and kind"));
458 /* If TARGET is not in memory, or the original pointer is specifically
459 known to be not associated with anything, then the answer is obviously
460 false. Alternatively, if POINTER is an actual pointer and has no
461 associated property, then we have to check if its associated by
462 looking the value of the pointer itself. We make the assumption that
463 a non-associated pointer will be set to 0. This is probably true for
464 most targets, but might not be true for everyone. */
465 if (value_lval_const (target
) != lval_memory
466 || type_not_associated (pointer_type
)
467 || (TYPE_ASSOCIATED_PROP (pointer_type
) == nullptr
468 && pointer_type
->code () == TYPE_CODE_PTR
469 && pointer_addr
== 0))
470 return value_from_longest (result_type
, 0);
472 /* See the comment for POINTER_ADDR above. */
473 CORE_ADDR target_addr
;
474 if (target_type
->code () == TYPE_CODE_PTR
)
475 target_addr
= value_as_address (target
);
477 target_addr
= value_address (target
);
479 /* Wrap the following checks inside a do { ... } while (false) loop so
480 that we can use `break' to jump out of the loop. */
481 bool is_associated
= false;
484 /* If the addresses are different then POINTER is definitely not
485 pointing at TARGET. */
486 if (pointer_addr
!= target_addr
)
489 /* If POINTER is a real pointer (i.e. not an array pointer, which are
490 implemented as arrays with a dynamic content address), then this
491 is all the checking that is needed. */
492 if (pointer_type
->code () == TYPE_CODE_PTR
)
494 is_associated
= true;
498 /* We have an array pointer. Check the number of dimensions. */
499 int pointer_dims
= calc_f77_array_dims (pointer_type
);
500 int target_dims
= calc_f77_array_dims (target_type
);
501 if (pointer_dims
!= target_dims
)
504 /* Now check that every dimension has the same upper bound, lower
505 bound, and stride value. */
507 while (dim
< pointer_dims
)
509 LONGEST pointer_lowerbound
, pointer_upperbound
, pointer_stride
;
510 LONGEST target_lowerbound
, target_upperbound
, target_stride
;
512 pointer_type
= check_typedef (pointer_type
);
513 target_type
= check_typedef (target_type
);
515 struct type
*pointer_range
= pointer_type
->index_type ();
516 struct type
*target_range
= target_type
->index_type ();
518 if (!get_discrete_bounds (pointer_range
, &pointer_lowerbound
,
519 &pointer_upperbound
))
522 if (!get_discrete_bounds (target_range
, &target_lowerbound
,
526 if (pointer_lowerbound
!= target_lowerbound
527 || pointer_upperbound
!= target_upperbound
)
530 /* Figure out the stride (in bits) for both pointer and target.
531 If either doesn't have a stride then we take the element size,
532 but we need to convert to bits (hence the * 8). */
533 pointer_stride
= pointer_range
->bounds ()->bit_stride ();
534 if (pointer_stride
== 0)
536 = type_length_units (check_typedef
537 (TYPE_TARGET_TYPE (pointer_type
))) * 8;
538 target_stride
= target_range
->bounds ()->bit_stride ();
539 if (target_stride
== 0)
541 = type_length_units (check_typedef
542 (TYPE_TARGET_TYPE (target_type
))) * 8;
543 if (pointer_stride
!= target_stride
)
549 if (dim
< pointer_dims
)
552 is_associated
= true;
556 return value_from_longest (result_type
, is_associated
? 1 : 0);
560 eval_op_f_associated (struct type
*expect_type
,
561 struct expression
*exp
,
563 enum exp_opcode opcode
,
566 return fortran_associated (exp
->gdbarch
, exp
->language_defn
, arg1
);
570 eval_op_f_associated (struct type
*expect_type
,
571 struct expression
*exp
,
573 enum exp_opcode opcode
,
577 return fortran_associated (exp
->gdbarch
, exp
->language_defn
, arg1
, arg2
);
580 /* Implement FORTRAN_ARRAY_SIZE expression, this corresponds to the 'SIZE'
581 keyword. Both GDBARCH and LANG are extracted from the expression being
582 evaluated. ARRAY is the value that should be an array, though this will
583 not have been checked before calling this function. DIM is optional, if
584 present then it should be an integer identifying a dimension of the
585 array to ask about. As with ARRAY the validity of DIM is not checked
586 before calling this function.
588 Return either the total number of elements in ARRAY (when DIM is
589 nullptr), or the number of elements in dimension DIM. */
591 static struct value
*
592 fortran_array_size (struct gdbarch
*gdbarch
, const language_defn
*lang
,
593 struct value
*array
, struct value
*dim_val
= nullptr)
595 /* Check that ARRAY is the correct type. */
596 struct type
*array_type
= check_typedef (value_type (array
));
597 if (array_type
->code () != TYPE_CODE_ARRAY
)
598 error (_("SIZE can only be applied to arrays"));
599 if (type_not_allocated (array_type
) || type_not_associated (array_type
))
600 error (_("SIZE can only be used on allocated/associated arrays"));
602 int ndimensions
= calc_f77_array_dims (array_type
);
606 if (dim_val
!= nullptr)
608 if (check_typedef (value_type (dim_val
))->code () != TYPE_CODE_INT
)
609 error (_("DIM argument to SIZE must be an integer"));
610 dim
= (int) value_as_long (dim_val
);
612 if (dim
< 1 || dim
> ndimensions
)
613 error (_("DIM argument to SIZE must be between 1 and %d"),
617 /* Now walk over all the dimensions of the array totalling up the
618 elements in each dimension. */
619 for (int i
= ndimensions
- 1; i
>= 0; --i
)
621 /* If this is the requested dimension then we're done. Grab the
622 bounds and return. */
623 if (i
== dim
- 1 || dim
== -1)
625 LONGEST lbound
, ubound
;
626 struct type
*range
= array_type
->index_type ();
628 if (!get_discrete_bounds (range
, &lbound
, &ubound
))
629 error (_("failed to find array bounds"));
631 LONGEST dim_size
= (ubound
- lbound
+ 1);
641 /* Peel off another dimension of the array. */
642 array_type
= TYPE_TARGET_TYPE (array_type
);
645 struct type
*result_type
646 = builtin_f_type (gdbarch
)->builtin_integer
;
647 return value_from_longest (result_type
, result
);
653 eval_op_f_array_size (struct type
*expect_type
,
654 struct expression
*exp
,
656 enum exp_opcode opcode
,
659 gdb_assert (opcode
== FORTRAN_ARRAY_SIZE
);
660 return fortran_array_size (exp
->gdbarch
, exp
->language_defn
, arg1
);
666 eval_op_f_array_size (struct type
*expect_type
,
667 struct expression
*exp
,
669 enum exp_opcode opcode
,
673 gdb_assert (opcode
== FORTRAN_ARRAY_SIZE
);
674 return fortran_array_size (exp
->gdbarch
, exp
->language_defn
, arg1
, arg2
);
677 /* Implement UNOP_FORTRAN_SHAPE expression. Both GDBARCH and LANG are
678 extracted from the expression being evaluated. VAL is the value on
679 which 'shape' was used, this can be any type.
681 Return an array of integers. If VAL is not an array then the returned
682 array should have zero elements. If VAL is an array then the returned
683 array should have one element per dimension, with the element
684 containing the extent of that dimension from VAL. */
686 static struct value
*
687 fortran_array_shape (struct gdbarch
*gdbarch
, const language_defn
*lang
,
690 struct type
*val_type
= check_typedef (value_type (val
));
692 /* If we are passed an array that is either not allocated, or not
693 associated, then this is explicitly not allowed according to the
694 Fortran specification. */
695 if (val_type
->code () == TYPE_CODE_ARRAY
696 && (type_not_associated (val_type
) || type_not_allocated (val_type
)))
697 error (_("The array passed to SHAPE must be allocated or associated"));
699 /* The Fortran specification allows non-array types to be passed to this
700 function, in which case we get back an empty array.
702 Calculate the number of dimensions for the resulting array. */
704 if (val_type
->code () == TYPE_CODE_ARRAY
)
705 ndimensions
= calc_f77_array_dims (val_type
);
707 /* Allocate a result value of the correct type. */
709 = create_static_range_type (nullptr,
710 builtin_type (gdbarch
)->builtin_int
,
712 struct type
*elm_type
= builtin_f_type (gdbarch
)->builtin_integer
;
713 struct type
*result_type
= create_array_type (nullptr, elm_type
, range
);
714 struct value
*result
= allocate_value (result_type
);
715 LONGEST elm_len
= TYPE_LENGTH (elm_type
);
717 /* Walk the array dimensions backwards due to the way the array will be
718 laid out in memory, the first dimension will be the most inner.
720 If VAL was not an array then ndimensions will be 0, in which case we
721 will never go around this loop. */
722 for (LONGEST dst_offset
= elm_len
* (ndimensions
- 1);
724 dst_offset
-= elm_len
)
726 LONGEST lbound
, ubound
;
728 if (!get_discrete_bounds (val_type
->index_type (), &lbound
, &ubound
))
729 error (_("failed to find array bounds"));
731 LONGEST dim_size
= (ubound
- lbound
+ 1);
733 /* And copy the value into the result value. */
734 struct value
*v
= value_from_longest (elm_type
, dim_size
);
735 gdb_assert (dst_offset
+ TYPE_LENGTH (value_type (v
))
736 <= TYPE_LENGTH (value_type (result
)));
737 gdb_assert (TYPE_LENGTH (value_type (v
)) == elm_len
);
738 value_contents_copy (result
, dst_offset
, v
, 0, elm_len
);
740 /* Peel another dimension of the array. */
741 val_type
= TYPE_TARGET_TYPE (val_type
);
750 eval_op_f_array_shape (struct type
*expect_type
, struct expression
*exp
,
751 enum noside noside
, enum exp_opcode opcode
,
754 gdb_assert (opcode
== UNOP_FORTRAN_SHAPE
);
755 return fortran_array_shape (exp
->gdbarch
, exp
->language_defn
, arg1
);
758 /* A helper function for UNOP_ABS. */
761 eval_op_f_abs (struct type
*expect_type
, struct expression
*exp
,
763 enum exp_opcode opcode
,
766 struct type
*type
= value_type (arg1
);
767 switch (type
->code ())
772 = fabs (target_float_to_host_double (value_contents (arg1
).data (),
774 return value_from_host_double (type
, d
);
778 LONGEST l
= value_as_long (arg1
);
780 return value_from_longest (type
, l
);
783 error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type
));
786 /* A helper function for BINOP_MOD. */
789 eval_op_f_mod (struct type
*expect_type
, struct expression
*exp
,
791 enum exp_opcode opcode
,
792 struct value
*arg1
, struct value
*arg2
)
794 struct type
*type
= value_type (arg1
);
795 if (type
->code () != value_type (arg2
)->code ())
796 error (_("non-matching types for parameters to MOD ()"));
797 switch (type
->code ())
802 = target_float_to_host_double (value_contents (arg1
).data (),
805 = target_float_to_host_double (value_contents (arg2
).data (),
807 double d3
= fmod (d1
, d2
);
808 return value_from_host_double (type
, d3
);
812 LONGEST v1
= value_as_long (arg1
);
813 LONGEST v2
= value_as_long (arg2
);
815 error (_("calling MOD (N, 0) is undefined"));
816 LONGEST v3
= v1
- (v1
/ v2
) * v2
;
817 return value_from_longest (value_type (arg1
), v3
);
820 error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type
));
823 /* A helper function for UNOP_FORTRAN_CEILING. */
826 eval_op_f_ceil (struct type
*expect_type
, struct expression
*exp
,
828 enum exp_opcode opcode
,
831 struct type
*type
= value_type (arg1
);
832 if (type
->code () != TYPE_CODE_FLT
)
833 error (_("argument to CEILING must be of type float"));
835 = target_float_to_host_double (value_contents (arg1
).data (),
838 return value_from_host_double (type
, val
);
841 /* A helper function for UNOP_FORTRAN_FLOOR. */
844 eval_op_f_floor (struct type
*expect_type
, struct expression
*exp
,
846 enum exp_opcode opcode
,
849 struct type
*type
= value_type (arg1
);
850 if (type
->code () != TYPE_CODE_FLT
)
851 error (_("argument to FLOOR must be of type float"));
853 = target_float_to_host_double (value_contents (arg1
).data (),
856 return value_from_host_double (type
, val
);
859 /* A helper function for BINOP_FORTRAN_MODULO. */
862 eval_op_f_modulo (struct type
*expect_type
, struct expression
*exp
,
864 enum exp_opcode opcode
,
865 struct value
*arg1
, struct value
*arg2
)
867 struct type
*type
= value_type (arg1
);
868 if (type
->code () != value_type (arg2
)->code ())
869 error (_("non-matching types for parameters to MODULO ()"));
870 /* MODULO(A, P) = A - FLOOR (A / P) * P */
871 switch (type
->code ())
875 LONGEST a
= value_as_long (arg1
);
876 LONGEST p
= value_as_long (arg2
);
877 LONGEST result
= a
- (a
/ p
) * p
;
878 if (result
!= 0 && (a
< 0) != (p
< 0))
880 return value_from_longest (value_type (arg1
), result
);
885 = target_float_to_host_double (value_contents (arg1
).data (),
888 = target_float_to_host_double (value_contents (arg2
).data (),
890 double result
= fmod (a
, p
);
891 if (result
!= 0 && (a
< 0.0) != (p
< 0.0))
893 return value_from_host_double (type
, result
);
896 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type
));
899 /* A helper function for BINOP_FORTRAN_CMPLX. */
902 eval_op_f_cmplx (struct type
*expect_type
, struct expression
*exp
,
904 enum exp_opcode opcode
,
905 struct value
*arg1
, struct value
*arg2
)
907 struct type
*type
= builtin_f_type(exp
->gdbarch
)->builtin_complex_s16
;
908 return value_literal_complex (arg1
, arg2
, type
);
911 /* A helper function for UNOP_FORTRAN_KIND. */
914 eval_op_f_kind (struct type
*expect_type
, struct expression
*exp
,
916 enum exp_opcode opcode
,
919 struct type
*type
= value_type (arg1
);
921 switch (type
->code ())
923 case TYPE_CODE_STRUCT
:
924 case TYPE_CODE_UNION
:
925 case TYPE_CODE_MODULE
:
927 error (_("argument to kind must be an intrinsic type"));
930 if (!TYPE_TARGET_TYPE (type
))
931 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
933 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
934 TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
937 /* A helper function for UNOP_FORTRAN_ALLOCATED. */
940 eval_op_f_allocated (struct type
*expect_type
, struct expression
*exp
,
941 enum noside noside
, enum exp_opcode op
,
944 struct type
*type
= check_typedef (value_type (arg1
));
945 if (type
->code () != TYPE_CODE_ARRAY
)
946 error (_("ALLOCATED can only be applied to arrays"));
947 struct type
*result_type
948 = builtin_f_type (exp
->gdbarch
)->builtin_logical
;
949 LONGEST result_value
= type_not_allocated (type
) ? 0 : 1;
950 return value_from_longest (result_type
, result_value
);
956 eval_op_f_rank (struct type
*expect_type
,
957 struct expression
*exp
,
962 gdb_assert (op
== UNOP_FORTRAN_RANK
);
964 struct type
*result_type
965 = builtin_f_type (exp
->gdbarch
)->builtin_integer
;
966 struct type
*type
= check_typedef (value_type (arg1
));
967 if (type
->code () != TYPE_CODE_ARRAY
)
968 return value_from_longest (result_type
, 0);
969 LONGEST ndim
= calc_f77_array_dims (type
);
970 return value_from_longest (result_type
, ndim
);
973 /* A helper function for UNOP_FORTRAN_LOC. */
976 eval_op_f_loc (struct type
*expect_type
, struct expression
*exp
,
977 enum noside noside
, enum exp_opcode op
,
980 struct type
*result_type
;
981 if (gdbarch_ptr_bit (exp
->gdbarch
) == 16)
982 result_type
= builtin_f_type (exp
->gdbarch
)->builtin_integer_s2
;
983 else if (gdbarch_ptr_bit (exp
->gdbarch
) == 32)
984 result_type
= builtin_f_type (exp
->gdbarch
)->builtin_integer
;
986 result_type
= builtin_f_type (exp
->gdbarch
)->builtin_integer_s8
;
988 LONGEST result_value
= value_address (arg1
);
989 return value_from_longest (result_type
, result_value
);
995 /* Called from evaluate to perform array indexing, and sub-range
996 extraction, for Fortran. As well as arrays this function also
997 handles strings as they can be treated like arrays of characters.
998 ARRAY is the array or string being accessed. EXP and NOSIDE are as
1002 fortran_undetermined::value_subarray (value
*array
,
1003 struct expression
*exp
,
1006 type
*original_array_type
= check_typedef (value_type (array
));
1007 bool is_string_p
= original_array_type
->code () == TYPE_CODE_STRING
;
1008 const std::vector
<operation_up
> &ops
= std::get
<1> (m_storage
);
1009 int nargs
= ops
.size ();
1011 /* Perform checks for ARRAY not being available. The somewhat overly
1012 complex logic here is just to keep backward compatibility with the
1013 errors that we used to get before FORTRAN_VALUE_SUBARRAY was
1014 rewritten. Maybe a future task would streamline the error messages we
1015 get here, and update all the expected test results. */
1016 if (ops
[0]->opcode () != OP_RANGE
)
1018 if (type_not_associated (original_array_type
))
1019 error (_("no such vector element (vector not associated)"));
1020 else if (type_not_allocated (original_array_type
))
1021 error (_("no such vector element (vector not allocated)"));
1025 if (type_not_associated (original_array_type
))
1026 error (_("array not associated"));
1027 else if (type_not_allocated (original_array_type
))
1028 error (_("array not allocated"));
1031 /* First check that the number of dimensions in the type we are slicing
1032 matches the number of arguments we were passed. */
1033 int ndimensions
= calc_f77_array_dims (original_array_type
);
1034 if (nargs
!= ndimensions
)
1035 error (_("Wrong number of subscripts"));
1037 /* This will be initialised below with the type of the elements held in
1039 struct type
*inner_element_type
;
1041 /* Extract the types of each array dimension from the original array
1042 type. We need these available so we can fill in the default upper and
1043 lower bounds if the user requested slice doesn't provide that
1044 information. Additionally unpacking the dimensions like this gives us
1045 the inner element type. */
1046 std::vector
<struct type
*> dim_types
;
1048 dim_types
.reserve (ndimensions
);
1049 struct type
*type
= original_array_type
;
1050 for (int i
= 0; i
< ndimensions
; ++i
)
1052 dim_types
.push_back (type
);
1053 type
= TYPE_TARGET_TYPE (type
);
1055 /* TYPE is now the inner element type of the array, we start the new
1056 array slice off as this type, then as we process the requested slice
1057 (from the user) we wrap new types around this to build up the final
1059 inner_element_type
= type
;
1062 /* As we analyse the new slice type we need to understand if the data
1063 being referenced is contiguous. Do decide this we must track the size
1064 of an element at each dimension of the new slice array. Initially the
1065 elements of the inner most dimension of the array are the same inner
1066 most elements as the original ARRAY. */
1067 LONGEST slice_element_size
= TYPE_LENGTH (inner_element_type
);
1069 /* Start off assuming all data is contiguous, this will be set to false
1070 if access to any dimension results in non-contiguous data. */
1071 bool is_all_contiguous
= true;
1073 /* The TOTAL_OFFSET is the distance in bytes from the start of the
1074 original ARRAY to the start of the new slice. This is calculated as
1075 we process the information from the user. */
1076 LONGEST total_offset
= 0;
1078 /* A structure representing information about each dimension of the
1083 slice_dim (LONGEST l
, LONGEST h
, LONGEST s
, struct type
*idx
)
1090 /* The low bound for this dimension of the slice. */
1093 /* The high bound for this dimension of the slice. */
1096 /* The byte stride for this dimension of the slice. */
1102 /* The dimensions of the resulting slice. */
1103 std::vector
<slice_dim
> slice_dims
;
1105 /* Process the incoming arguments. These arguments are in the reverse
1106 order to the array dimensions, that is the first argument refers to
1107 the last array dimension. */
1108 if (fortran_array_slicing_debug
)
1109 debug_printf ("Processing array access:\n");
1110 for (int i
= 0; i
< nargs
; ++i
)
1112 /* For each dimension of the array the user will have either provided
1113 a ranged access with optional lower bound, upper bound, and
1114 stride, or the user will have supplied a single index. */
1115 struct type
*dim_type
= dim_types
[ndimensions
- (i
+ 1)];
1116 fortran_range_operation
*range_op
1117 = dynamic_cast<fortran_range_operation
*> (ops
[i
].get ());
1118 if (range_op
!= nullptr)
1120 enum range_flag range_flag
= range_op
->get_flags ();
1122 LONGEST low
, high
, stride
;
1123 low
= high
= stride
= 0;
1125 if ((range_flag
& RANGE_LOW_BOUND_DEFAULT
) == 0)
1126 low
= value_as_long (range_op
->evaluate0 (exp
, noside
));
1128 low
= f77_get_lowerbound (dim_type
);
1129 if ((range_flag
& RANGE_HIGH_BOUND_DEFAULT
) == 0)
1130 high
= value_as_long (range_op
->evaluate1 (exp
, noside
));
1132 high
= f77_get_upperbound (dim_type
);
1133 if ((range_flag
& RANGE_HAS_STRIDE
) == RANGE_HAS_STRIDE
)
1134 stride
= value_as_long (range_op
->evaluate2 (exp
, noside
));
1139 error (_("stride must not be 0"));
1141 /* Get information about this dimension in the original ARRAY. */
1142 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
1143 struct type
*index_type
= dim_type
->index_type ();
1144 LONGEST lb
= f77_get_lowerbound (dim_type
);
1145 LONGEST ub
= f77_get_upperbound (dim_type
);
1146 LONGEST sd
= index_type
->bit_stride ();
1148 sd
= TYPE_LENGTH (target_type
) * 8;
1150 if (fortran_array_slicing_debug
)
1152 debug_printf ("|-> Range access\n");
1153 std::string str
= type_to_string (dim_type
);
1154 debug_printf ("| |-> Type: %s\n", str
.c_str ());
1155 debug_printf ("| |-> Array:\n");
1156 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
1157 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
1158 debug_printf ("| | |-> Bit stride: %s\n", plongest (sd
));
1159 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
/ 8));
1160 debug_printf ("| | |-> Type size: %s\n",
1161 pulongest (TYPE_LENGTH (dim_type
)));
1162 debug_printf ("| | '-> Target type size: %s\n",
1163 pulongest (TYPE_LENGTH (target_type
)));
1164 debug_printf ("| |-> Accessing:\n");
1165 debug_printf ("| | |-> Low bound: %s\n",
1167 debug_printf ("| | |-> High bound: %s\n",
1169 debug_printf ("| | '-> Element stride: %s\n",
1173 /* Check the user hasn't asked for something invalid. */
1174 if (high
> ub
|| low
< lb
)
1175 error (_("array subscript out of bounds"));
1177 /* Calculate what this dimension of the new slice array will look
1178 like. OFFSET is the byte offset from the start of the
1179 previous (more outer) dimension to the start of this
1180 dimension. E_COUNT is the number of elements in this
1181 dimension. REMAINDER is the number of elements remaining
1182 between the last included element and the upper bound. For
1183 example an access '1:6:2' will include elements 1, 3, 5 and
1184 have a remainder of 1 (element #6). */
1185 LONGEST lowest
= std::min (low
, high
);
1186 LONGEST offset
= (sd
/ 8) * (lowest
- lb
);
1187 LONGEST e_count
= std::abs (high
- low
) + 1;
1188 e_count
= (e_count
+ (std::abs (stride
) - 1)) / std::abs (stride
);
1189 LONGEST new_low
= 1;
1190 LONGEST new_high
= new_low
+ e_count
- 1;
1191 LONGEST new_stride
= (sd
* stride
) / 8;
1192 LONGEST last_elem
= low
+ ((e_count
- 1) * stride
);
1193 LONGEST remainder
= high
- last_elem
;
1196 offset
+= std::abs (remainder
) * TYPE_LENGTH (target_type
);
1198 error (_("incorrect stride and boundary combination"));
1200 else if (stride
< 0)
1201 error (_("incorrect stride and boundary combination"));
1203 /* Is the data within this dimension contiguous? It is if the
1204 newly computed stride is the same size as a single element of
1206 bool is_dim_contiguous
= (new_stride
== slice_element_size
);
1207 is_all_contiguous
&= is_dim_contiguous
;
1209 if (fortran_array_slicing_debug
)
1211 debug_printf ("| '-> Results:\n");
1212 debug_printf ("| |-> Offset = %s\n", plongest (offset
));
1213 debug_printf ("| |-> Elements = %s\n", plongest (e_count
));
1214 debug_printf ("| |-> Low bound = %s\n", plongest (new_low
));
1215 debug_printf ("| |-> High bound = %s\n",
1216 plongest (new_high
));
1217 debug_printf ("| |-> Byte stride = %s\n",
1218 plongest (new_stride
));
1219 debug_printf ("| |-> Last element = %s\n",
1220 plongest (last_elem
));
1221 debug_printf ("| |-> Remainder = %s\n",
1222 plongest (remainder
));
1223 debug_printf ("| '-> Contiguous = %s\n",
1224 (is_dim_contiguous
? "Yes" : "No"));
1227 /* Figure out how big (in bytes) an element of this dimension of
1228 the new array slice will be. */
1229 slice_element_size
= std::abs (new_stride
* e_count
);
1231 slice_dims
.emplace_back (new_low
, new_high
, new_stride
,
1234 /* Update the total offset. */
1235 total_offset
+= offset
;
1239 /* There is a single index for this dimension. */
1241 = value_as_long (ops
[i
]->evaluate_with_coercion (exp
, noside
));
1243 /* Get information about this dimension in the original ARRAY. */
1244 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
1245 struct type
*index_type
= dim_type
->index_type ();
1246 LONGEST lb
= f77_get_lowerbound (dim_type
);
1247 LONGEST ub
= f77_get_upperbound (dim_type
);
1248 LONGEST sd
= index_type
->bit_stride () / 8;
1250 sd
= TYPE_LENGTH (target_type
);
1252 if (fortran_array_slicing_debug
)
1254 debug_printf ("|-> Index access\n");
1255 std::string str
= type_to_string (dim_type
);
1256 debug_printf ("| |-> Type: %s\n", str
.c_str ());
1257 debug_printf ("| |-> Array:\n");
1258 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
1259 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
1260 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
));
1261 debug_printf ("| | |-> Type size: %s\n",
1262 pulongest (TYPE_LENGTH (dim_type
)));
1263 debug_printf ("| | '-> Target type size: %s\n",
1264 pulongest (TYPE_LENGTH (target_type
)));
1265 debug_printf ("| '-> Accessing:\n");
1266 debug_printf ("| '-> Index: %s\n",
1270 /* If the array has actual content then check the index is in
1271 bounds. An array without content (an unbound array) doesn't
1272 have a known upper bound, so don't error check in that
1275 || (dim_type
->index_type ()->bounds ()->high
.kind () != PROP_UNDEFINED
1277 || (VALUE_LVAL (array
) != lval_memory
1278 && dim_type
->index_type ()->bounds ()->high
.kind () == PROP_UNDEFINED
))
1280 if (type_not_associated (dim_type
))
1281 error (_("no such vector element (vector not associated)"));
1282 else if (type_not_allocated (dim_type
))
1283 error (_("no such vector element (vector not allocated)"));
1285 error (_("no such vector element"));
1288 /* Calculate using the type stride, not the target type size. */
1289 LONGEST offset
= sd
* (index
- lb
);
1290 total_offset
+= offset
;
1294 /* Build a type that represents the new array slice in the target memory
1295 of the original ARRAY, this type makes use of strides to correctly
1296 find only those elements that are part of the new slice. */
1297 struct type
*array_slice_type
= inner_element_type
;
1298 for (const auto &d
: slice_dims
)
1300 /* Create the range. */
1301 dynamic_prop p_low
, p_high
, p_stride
;
1303 p_low
.set_const_val (d
.low
);
1304 p_high
.set_const_val (d
.high
);
1305 p_stride
.set_const_val (d
.stride
);
1307 struct type
*new_range
1308 = create_range_type_with_stride ((struct type
*) NULL
,
1309 TYPE_TARGET_TYPE (d
.index
),
1310 &p_low
, &p_high
, 0, &p_stride
,
1313 = create_array_type (nullptr, array_slice_type
, new_range
);
1316 if (fortran_array_slicing_debug
)
1318 debug_printf ("'-> Final result:\n");
1319 debug_printf (" |-> Type: %s\n",
1320 type_to_string (array_slice_type
).c_str ());
1321 debug_printf (" |-> Total offset: %s\n",
1322 plongest (total_offset
));
1323 debug_printf (" |-> Base address: %s\n",
1324 core_addr_to_string (value_address (array
)));
1325 debug_printf (" '-> Contiguous = %s\n",
1326 (is_all_contiguous
? "Yes" : "No"));
1329 /* Should we repack this array slice? */
1330 if (!is_all_contiguous
&& (repack_array_slices
|| is_string_p
))
1332 /* Build a type for the repacked slice. */
1333 struct type
*repacked_array_type
= inner_element_type
;
1334 for (const auto &d
: slice_dims
)
1336 /* Create the range. */
1337 dynamic_prop p_low
, p_high
, p_stride
;
1339 p_low
.set_const_val (d
.low
);
1340 p_high
.set_const_val (d
.high
);
1341 p_stride
.set_const_val (TYPE_LENGTH (repacked_array_type
));
1343 struct type
*new_range
1344 = create_range_type_with_stride ((struct type
*) NULL
,
1345 TYPE_TARGET_TYPE (d
.index
),
1346 &p_low
, &p_high
, 0, &p_stride
,
1349 = create_array_type (nullptr, repacked_array_type
, new_range
);
1352 /* Now copy the elements from the original ARRAY into the packed
1353 array value DEST. */
1354 struct value
*dest
= allocate_value (repacked_array_type
);
1355 if (value_lazy (array
)
1356 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
1357 > TYPE_LENGTH (check_typedef (value_type (array
)))))
1359 fortran_array_walker
<fortran_lazy_array_repacker_impl
> p
1360 (array_slice_type
, value_address (array
) + total_offset
, dest
);
1365 fortran_array_walker
<fortran_array_repacker_impl
> p
1366 (array_slice_type
, value_address (array
) + total_offset
,
1367 total_offset
, array
, dest
);
1374 if (VALUE_LVAL (array
) == lval_memory
)
1376 /* If the value we're taking a slice from is not yet loaded, or
1377 the requested slice is outside the values content range then
1378 just create a new lazy value pointing at the memory where the
1379 contents we're looking for exist. */
1380 if (value_lazy (array
)
1381 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
1382 > TYPE_LENGTH (check_typedef (value_type (array
)))))
1383 array
= value_at_lazy (array_slice_type
,
1384 value_address (array
) + total_offset
);
1386 array
= value_from_contents_and_address
1387 (array_slice_type
, value_contents (array
).data () + total_offset
,
1388 value_address (array
) + total_offset
);
1390 else if (!value_lazy (array
))
1391 array
= value_from_component (array
, array_slice_type
, total_offset
);
1393 error (_("cannot subscript arrays that are not in memory"));
1400 fortran_undetermined::evaluate (struct type
*expect_type
,
1401 struct expression
*exp
,
1404 value
*callee
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
, noside
);
1405 if (noside
== EVAL_AVOID_SIDE_EFFECTS
1406 && is_dynamic_type (value_type (callee
)))
1407 callee
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
, EVAL_NORMAL
);
1408 struct type
*type
= check_typedef (value_type (callee
));
1409 enum type_code code
= type
->code ();
1411 if (code
== TYPE_CODE_PTR
)
1413 /* Fortran always passes variable to subroutines as pointer.
1414 So we need to look into its target type to see if it is
1415 array, string or function. If it is, we need to switch
1416 to the target value the original one points to. */
1417 struct type
*target_type
= check_typedef (TYPE_TARGET_TYPE (type
));
1419 if (target_type
->code () == TYPE_CODE_ARRAY
1420 || target_type
->code () == TYPE_CODE_STRING
1421 || target_type
->code () == TYPE_CODE_FUNC
)
1423 callee
= value_ind (callee
);
1424 type
= check_typedef (value_type (callee
));
1425 code
= type
->code ();
1431 case TYPE_CODE_ARRAY
:
1432 case TYPE_CODE_STRING
:
1433 return value_subarray (callee
, exp
, noside
);
1436 case TYPE_CODE_FUNC
:
1437 case TYPE_CODE_INTERNAL_FUNCTION
:
1439 /* It's a function call. Allocate arg vector, including
1440 space for the function to be called in argvec[0] and a
1441 termination NULL. */
1442 const std::vector
<operation_up
> &actual (std::get
<1> (m_storage
));
1443 std::vector
<value
*> argvec (actual
.size ());
1444 bool is_internal_func
= (code
== TYPE_CODE_INTERNAL_FUNCTION
);
1445 for (int tem
= 0; tem
< argvec
.size (); tem
++)
1446 argvec
[tem
] = fortran_prepare_argument (exp
, actual
[tem
].get (),
1447 tem
, is_internal_func
,
1448 value_type (callee
),
1450 return evaluate_subexp_do_call (exp
, noside
, callee
, argvec
,
1451 nullptr, expect_type
);
1455 error (_("Cannot perform substring on this type"));
1460 fortran_bound_1arg::evaluate (struct type
*expect_type
,
1461 struct expression
*exp
,
1464 bool lbound_p
= std::get
<0> (m_storage
) == FORTRAN_LBOUND
;
1465 value
*arg1
= std::get
<1> (m_storage
)->evaluate (nullptr, exp
, noside
);
1466 fortran_require_array (value_type (arg1
), lbound_p
);
1467 return fortran_bounds_all_dims (lbound_p
, exp
->gdbarch
, arg1
);
1471 fortran_bound_2arg::evaluate (struct type
*expect_type
,
1472 struct expression
*exp
,
1475 bool lbound_p
= std::get
<0> (m_storage
) == FORTRAN_LBOUND
;
1476 value
*arg1
= std::get
<1> (m_storage
)->evaluate (nullptr, exp
, noside
);
1477 fortran_require_array (value_type (arg1
), lbound_p
);
1479 /* User asked for the bounds of a specific dimension of the array. */
1480 value
*arg2
= std::get
<2> (m_storage
)->evaluate (nullptr, exp
, noside
);
1481 struct type
*type
= check_typedef (value_type (arg2
));
1482 if (type
->code () != TYPE_CODE_INT
)
1485 error (_("LBOUND second argument should be an integer"));
1487 error (_("UBOUND second argument should be an integer"));
1490 return fortran_bounds_for_dimension (lbound_p
, exp
->gdbarch
, arg1
, arg2
);
1493 /* Implement STRUCTOP_STRUCT for Fortran. See operation::evaluate in
1494 expression.h for argument descriptions. */
1497 fortran_structop_operation::evaluate (struct type
*expect_type
,
1498 struct expression
*exp
,
1501 value
*arg1
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
, noside
);
1502 const char *str
= std::get
<1> (m_storage
).c_str ();
1503 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
1505 struct type
*type
= lookup_struct_elt_type (value_type (arg1
), str
, 1);
1507 if (type
!= nullptr && is_dynamic_type (type
))
1508 arg1
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
, EVAL_NORMAL
);
1511 value
*elt
= value_struct_elt (&arg1
, {}, str
, NULL
, "structure");
1513 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
1515 struct type
*elt_type
= value_type (elt
);
1516 if (is_dynamic_type (elt_type
))
1518 const gdb_byte
*valaddr
= value_contents_for_printing (elt
).data ();
1519 CORE_ADDR address
= value_address (elt
);
1520 gdb::array_view
<const gdb_byte
> view
1521 = gdb::make_array_view (valaddr
, TYPE_LENGTH (elt_type
));
1522 elt_type
= resolve_dynamic_type (elt_type
, view
, address
);
1524 elt
= value_zero (elt_type
, VALUE_LVAL (elt
));
1530 } /* namespace expr */
1532 /* See language.h. */
1535 f_language::print_array_index (struct type
*index_type
, LONGEST index
,
1536 struct ui_file
*stream
,
1537 const value_print_options
*options
) const
1539 struct value
*index_value
= value_from_longest (index_type
, index
);
1541 gdb_printf (stream
, "(");
1542 value_print (index_value
, stream
, options
);
1543 gdb_printf (stream
, ") = ");
1546 /* See language.h. */
1549 f_language::language_arch_info (struct gdbarch
*gdbarch
,
1550 struct language_arch_info
*lai
) const
1552 const struct builtin_f_type
*builtin
= builtin_f_type (gdbarch
);
1554 /* Helper function to allow shorter lines below. */
1555 auto add
= [&] (struct type
* t
)
1557 lai
->add_primitive_type (t
);
1560 add (builtin
->builtin_character
);
1561 add (builtin
->builtin_logical
);
1562 add (builtin
->builtin_logical_s1
);
1563 add (builtin
->builtin_logical_s2
);
1564 add (builtin
->builtin_logical_s8
);
1565 add (builtin
->builtin_real
);
1566 add (builtin
->builtin_real_s8
);
1567 add (builtin
->builtin_real_s16
);
1568 add (builtin
->builtin_complex
);
1569 add (builtin
->builtin_complex_s8
);
1570 add (builtin
->builtin_void
);
1572 lai
->set_string_char_type (builtin
->builtin_character
);
1573 lai
->set_bool_type (builtin
->builtin_logical
, "logical");
1576 /* See language.h. */
1579 f_language::search_name_hash (const char *name
) const
1581 return cp_search_name_hash (name
);
1584 /* See language.h. */
1587 f_language::lookup_symbol_nonlocal (const char *name
,
1588 const struct block
*block
,
1589 const domain_enum domain
) const
1591 return cp_lookup_symbol_nonlocal (this, name
, block
, domain
);
1594 /* See language.h. */
1596 symbol_name_matcher_ftype
*
1597 f_language::get_symbol_name_matcher_inner
1598 (const lookup_name_info
&lookup_name
) const
1600 return cp_get_symbol_name_matcher (lookup_name
);
1603 /* Single instance of the Fortran language class. */
1605 static f_language f_language_defn
;
1608 build_fortran_types (struct gdbarch
*gdbarch
)
1610 struct builtin_f_type
*builtin_f_type
1611 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_f_type
);
1613 builtin_f_type
->builtin_void
1614 = arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
, "void");
1616 builtin_f_type
->builtin_character
1617 = arch_type (gdbarch
, TYPE_CODE_CHAR
, TARGET_CHAR_BIT
, "character");
1619 builtin_f_type
->builtin_logical_s1
1620 = arch_boolean_type (gdbarch
, TARGET_CHAR_BIT
, 1, "logical*1");
1622 builtin_f_type
->builtin_logical_s2
1623 = arch_boolean_type (gdbarch
, gdbarch_short_bit (gdbarch
), 1, "logical*2");
1625 builtin_f_type
->builtin_logical
1626 = arch_boolean_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1, "logical*4");
1628 builtin_f_type
->builtin_logical_s8
1629 = arch_boolean_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 1,
1632 builtin_f_type
->builtin_integer_s1
1633 = arch_integer_type (gdbarch
, TARGET_CHAR_BIT
, 0, "integer*1");
1635 builtin_f_type
->builtin_integer_s2
1636 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
), 0, "integer*2");
1638 builtin_f_type
->builtin_integer
1639 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 0, "integer");
1641 builtin_f_type
->builtin_integer_s8
1642 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 0,
1645 builtin_f_type
->builtin_real
1646 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
1647 "real", gdbarch_float_format (gdbarch
));
1649 builtin_f_type
->builtin_real_s8
1650 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
1651 "real*8", gdbarch_double_format (gdbarch
));
1653 auto fmt
= gdbarch_floatformat_for_type (gdbarch
, "real(kind=16)", 128);
1655 builtin_f_type
->builtin_real_s16
1656 = arch_float_type (gdbarch
, 128, "real*16", fmt
);
1657 else if (gdbarch_long_double_bit (gdbarch
) == 128)
1658 builtin_f_type
->builtin_real_s16
1659 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
1660 "real*16", gdbarch_long_double_format (gdbarch
));
1662 builtin_f_type
->builtin_real_s16
1663 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 128, "real*16");
1665 builtin_f_type
->builtin_complex
1666 = init_complex_type ("complex*4", builtin_f_type
->builtin_real
);
1668 builtin_f_type
->builtin_complex_s8
1669 = init_complex_type ("complex*8", builtin_f_type
->builtin_real_s8
);
1671 if (builtin_f_type
->builtin_real_s16
->code () == TYPE_CODE_ERROR
)
1672 builtin_f_type
->builtin_complex_s16
1673 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 256, "complex*16");
1675 builtin_f_type
->builtin_complex_s16
1676 = init_complex_type ("complex*16", builtin_f_type
->builtin_real_s16
);
1678 return builtin_f_type
;
1681 static struct gdbarch_data
*f_type_data
;
1683 const struct builtin_f_type
*
1684 builtin_f_type (struct gdbarch
*gdbarch
)
1686 return (const struct builtin_f_type
*) gdbarch_data (gdbarch
, f_type_data
);
1689 /* Command-list for the "set/show fortran" prefix command. */
1690 static struct cmd_list_element
*set_fortran_list
;
1691 static struct cmd_list_element
*show_fortran_list
;
1693 void _initialize_f_language ();
1695 _initialize_f_language ()
1697 f_type_data
= gdbarch_data_register_post_init (build_fortran_types
);
1699 add_setshow_prefix_cmd
1700 ("fortran", no_class
,
1701 _("Prefix command for changing Fortran-specific settings."),
1702 _("Generic command for showing Fortran-specific settings."),
1703 &set_fortran_list
, &show_fortran_list
,
1704 &setlist
, &showlist
);
1706 add_setshow_boolean_cmd ("repack-array-slices", class_vars
,
1707 &repack_array_slices
, _("\
1708 Enable or disable repacking of non-contiguous array slices."), _("\
1709 Show whether non-contiguous array slices are repacked."), _("\
1710 When the user requests a slice of a Fortran array then we can either return\n\
1711 a descriptor that describes the array in place (using the original array data\n\
1712 in its existing location) or the original data can be repacked (copied) to a\n\
1715 When the content of the array slice is contiguous within the original array\n\
1716 then the result will never be repacked, but when the data for the new array\n\
1717 is non-contiguous within the original array repacking will only be performed\n\
1718 when this setting is on."),
1720 show_repack_array_slices
,
1721 &set_fortran_list
, &show_fortran_list
);
1723 /* Debug Fortran's array slicing logic. */
1724 add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance
,
1725 &fortran_array_slicing_debug
, _("\
1726 Set debugging of Fortran array slicing."), _("\
1727 Show debugging of Fortran array slicing."), _("\
1728 When on, debugging of Fortran array slicing is enabled."),
1730 show_fortran_array_slicing_debug
,
1731 &setdebuglist
, &showdebuglist
);
1734 /* Ensures that function argument VALUE is in the appropriate form to
1735 pass to a Fortran function. Returns a possibly new value that should
1736 be used instead of VALUE.
1738 When IS_ARTIFICIAL is true this indicates an artificial argument,
1739 e.g. hidden string lengths which the GNU Fortran argument passing
1740 convention specifies as being passed by value.
1742 When IS_ARTIFICIAL is false, the argument is passed by pointer. If the
1743 value is already in target memory then return a value that is a pointer
1744 to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate
1745 space in the target, copy VALUE in, and return a pointer to the in
1748 static struct value
*
1749 fortran_argument_convert (struct value
*value
, bool is_artificial
)
1753 /* If the value is not in the inferior e.g. registers values,
1754 convenience variables and user input. */
1755 if (VALUE_LVAL (value
) != lval_memory
)
1757 struct type
*type
= value_type (value
);
1758 const int length
= TYPE_LENGTH (type
);
1759 const CORE_ADDR addr
1760 = value_as_long (value_allocate_space_in_inferior (length
));
1761 write_memory (addr
, value_contents (value
).data (), length
);
1762 struct value
*val
= value_from_contents_and_address
1763 (type
, value_contents (value
).data (), addr
);
1764 return value_addr (val
);
1767 return value_addr (value
); /* Program variables, e.g. arrays. */
1772 /* Prepare (and return) an argument value ready for an inferior function
1773 call to a Fortran function. EXP and POS are the expressions describing
1774 the argument to prepare. ARG_NUM is the argument number being
1775 prepared, with 0 being the first argument and so on. FUNC_TYPE is the
1776 type of the function being called.
1778 IS_INTERNAL_CALL_P is true if this is a call to a function of type
1779 TYPE_CODE_INTERNAL_FUNCTION, otherwise this parameter is false.
1781 NOSIDE has its usual meaning for expression parsing (see eval.c).
1783 Arguments in Fortran are normally passed by address, we coerce the
1784 arguments here rather than in value_arg_coerce as otherwise the call to
1785 malloc (to place the non-lvalue parameters in target memory) is hit by
1786 this Fortran specific logic. This results in malloc being called with a
1787 pointer to an integer followed by an attempt to malloc the arguments to
1788 malloc in target memory. Infinite recursion ensues. */
1791 fortran_prepare_argument (struct expression
*exp
,
1792 expr::operation
*subexp
,
1793 int arg_num
, bool is_internal_call_p
,
1794 struct type
*func_type
, enum noside noside
)
1796 if (is_internal_call_p
)
1797 return subexp
->evaluate_with_coercion (exp
, noside
);
1799 bool is_artificial
= ((arg_num
>= func_type
->num_fields ())
1801 : TYPE_FIELD_ARTIFICIAL (func_type
, arg_num
));
1803 /* If this is an artificial argument, then either, this is an argument
1804 beyond the end of the known arguments, or possibly, there are no known
1805 arguments (maybe missing debug info).
1807 For these artificial arguments, if the user has prefixed it with '&'
1808 (for address-of), then lets always allow this to succeed, even if the
1809 argument is not actually in inferior memory. This will allow the user
1810 to pass arguments to a Fortran function even when there's no debug
1813 As we already pass the address of non-artificial arguments, all we
1814 need to do if skip the UNOP_ADDR operator in the expression and mark
1815 the argument as non-artificial. */
1818 expr::unop_addr_operation
*addrop
1819 = dynamic_cast<expr::unop_addr_operation
*> (subexp
);
1820 if (addrop
!= nullptr)
1822 subexp
= addrop
->get_expression ().get ();
1823 is_artificial
= false;
1827 struct value
*arg_val
= subexp
->evaluate_with_coercion (exp
, noside
);
1828 return fortran_argument_convert (arg_val
, is_artificial
);
1834 fortran_preserve_arg_pointer (struct value
*arg
, struct type
*type
)
1836 if (value_type (arg
)->code () == TYPE_CODE_PTR
)
1837 return value_type (arg
);
1844 fortran_adjust_dynamic_array_base_address_hack (struct type
*type
,
1847 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
1849 /* We can't adjust the base address for arrays that have no content. */
1850 if (type_not_allocated (type
) || type_not_associated (type
))
1853 int ndimensions
= calc_f77_array_dims (type
);
1854 LONGEST total_offset
= 0;
1856 /* Walk through each of the dimensions of this array type and figure out
1857 if any of the dimensions are "backwards", that is the base address
1858 for this dimension points to the element at the highest memory
1859 address and the stride is negative. */
1860 struct type
*tmp_type
= type
;
1861 for (int i
= 0 ; i
< ndimensions
; ++i
)
1863 /* Grab the range for this dimension and extract the lower and upper
1865 tmp_type
= check_typedef (tmp_type
);
1866 struct type
*range_type
= tmp_type
->index_type ();
1867 LONGEST lowerbound
, upperbound
, stride
;
1868 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
1869 error ("failed to get range bounds");
1871 /* Figure out the stride for this dimension. */
1872 struct type
*elt_type
= check_typedef (TYPE_TARGET_TYPE (tmp_type
));
1873 stride
= tmp_type
->index_type ()->bounds ()->bit_stride ();
1875 stride
= type_length_units (elt_type
);
1879 = gdbarch_addressable_memory_unit_size (elt_type
->arch ());
1880 stride
/= (unit_size
* 8);
1883 /* If this dimension is "backward" then figure out the offset
1884 adjustment required to point to the element at the lowest memory
1885 address, and add this to the total offset. */
1887 if (stride
< 0 && lowerbound
< upperbound
)
1888 offset
= (upperbound
- lowerbound
) * stride
;
1889 total_offset
+= offset
;
1890 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
1893 /* Adjust the address of this object and return it. */
1894 address
+= total_offset
;