1 /* Fortran language support routines for GDB, the GNU debugger.
3 Copyright (C) 1993-2023 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 ())
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 (array
->type ());
131 int ndimensions
= calc_f77_array_dims (array_type
);
133 /* Allocate a result value of the correct type. */
134 type_allocator
alloc (gdbarch
);
136 = create_static_range_type (alloc
,
137 builtin_f_type (gdbarch
)->builtin_integer
,
139 struct type
*elm_type
= builtin_f_type (gdbarch
)->builtin_integer
;
140 struct type
*result_type
= create_array_type (nullptr, elm_type
, range
);
141 struct value
*result
= value::allocate (result_type
);
143 /* Walk the array dimensions backwards due to the way the array will be
144 laid out in memory, the first dimension will be the most inner. */
145 LONGEST elm_len
= elm_type
->length ();
146 for (LONGEST dst_offset
= elm_len
* (ndimensions
- 1);
148 dst_offset
-= elm_len
)
152 /* Grab the required bound. */
154 b
= f77_get_lowerbound (array_type
);
156 b
= f77_get_upperbound (array_type
);
158 /* And copy the value into the result value. */
159 struct value
*v
= value_from_longest (elm_type
, b
);
160 gdb_assert (dst_offset
+ v
->type ()->length ()
161 <= result
->type ()->length ());
162 gdb_assert (v
->type ()->length () == elm_len
);
163 v
->contents_copy (result
, dst_offset
, 0, elm_len
);
165 /* Peel another dimension of the array. */
166 array_type
= array_type
->target_type ();
172 /* Return the lower bound (when LBOUND_P is true) or the upper bound (when
173 LBOUND_P is false) for dimension DIM_VAL (which must be an integer) of
174 ARRAY (which must be an array). RESULT_TYPE corresponds to the type kind
175 the function should be evaluated in. */
178 fortran_bounds_for_dimension (bool lbound_p
, value
*array
, value
*dim_val
,
181 /* Check the requested dimension is valid for this array. */
182 type
*array_type
= check_typedef (array
->type ());
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 /* Walk the dimensions backwards, due to the ordering in which arrays are
194 laid out the first dimension is the most inner. */
195 for (int i
= ndimensions
- 1; i
>= 0; --i
)
197 /* If this is the requested dimension then we're done. Grab the
198 bounds and return. */
204 b
= f77_get_lowerbound (array_type
);
206 b
= f77_get_upperbound (array_type
);
208 return value_from_longest (result_type
, b
);
211 /* Peel off another dimension of the array. */
212 array_type
= array_type
->target_type ();
215 gdb_assert_not_reached ("failed to find matching dimension");
218 /* Return the number of dimensions for a Fortran array or string. */
221 calc_f77_array_dims (struct type
*array_type
)
224 struct type
*tmp_type
;
226 if ((array_type
->code () == TYPE_CODE_STRING
))
229 if ((array_type
->code () != TYPE_CODE_ARRAY
))
230 error (_("Can't get dimensions for a non-array type"));
232 tmp_type
= array_type
;
234 while ((tmp_type
= tmp_type
->target_type ()))
236 if (tmp_type
->code () == TYPE_CODE_ARRAY
)
242 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
243 slices. This is a base class for two alternative repacking mechanisms,
244 one for when repacking from a lazy value, and one for repacking from a
245 non-lazy (already loaded) value. */
246 class fortran_array_repacker_base_impl
247 : public fortran_array_walker_base_impl
250 /* Constructor, DEST is the value we are repacking into. */
251 fortran_array_repacker_base_impl (struct value
*dest
)
256 /* When we start processing the inner most dimension, this is where we
257 will be creating values for each element as we load them and then copy
258 them into the M_DEST value. Set a value mark so we can free these
260 void start_dimension (struct type
*index_type
, LONGEST nelts
, bool inner_p
)
264 gdb_assert (m_mark
== nullptr);
265 m_mark
= value_mark ();
269 /* When we finish processing the inner most dimension free all temporary
270 value that were created. */
271 void finish_dimension (bool inner_p
, bool last_p
)
275 gdb_assert (m_mark
!= nullptr);
276 value_free_to_mark (m_mark
);
282 /* Copy the contents of array element ELT into M_DEST at the next
284 void copy_element_to_dest (struct value
*elt
)
286 elt
->contents_copy (m_dest
, m_dest_offset
, 0,
287 elt
->type ()->length ());
288 m_dest_offset
+= elt
->type ()->length ();
291 /* The value being written to. */
292 struct value
*m_dest
;
294 /* The byte offset in M_DEST at which the next element should be
296 LONGEST m_dest_offset
;
298 /* Set with a call to VALUE_MARK, and then reset after calling
299 VALUE_FREE_TO_MARK. */
300 struct value
*m_mark
= nullptr;
303 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
304 slices. This class is specialised for repacking an array slice from a
305 lazy array value, as such it does not require the parent array value to
306 be loaded into GDB's memory; the parent value could be huge, while the
307 slice could be tiny. */
308 class fortran_lazy_array_repacker_impl
309 : public fortran_array_repacker_base_impl
312 /* Constructor. TYPE is the type of the slice being loaded from the
313 parent value, so this type will correctly reflect the strides required
314 to find all of the elements from the parent value. ADDRESS is the
315 address in target memory of value matching TYPE, and DEST is the value
316 we are repacking into. */
317 explicit fortran_lazy_array_repacker_impl (struct type
*type
,
320 : fortran_array_repacker_base_impl (dest
),
324 /* Create a lazy value in target memory representing a single element,
325 then load the element into GDB's memory and copy the contents into the
326 destination value. */
327 void process_element (struct type
*elt_type
, LONGEST elt_off
,
328 LONGEST index
, bool last_p
)
330 copy_element_to_dest (value_at_lazy (elt_type
, m_addr
+ elt_off
));
334 /* The address in target memory where the parent value starts. */
338 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
339 slices. This class is specialised for repacking an array slice from a
340 previously loaded (non-lazy) array value, as such it fetches the
341 element values from the contents of the parent value. */
342 class fortran_array_repacker_impl
343 : public fortran_array_repacker_base_impl
346 /* Constructor. TYPE is the type for the array slice within the parent
347 value, as such it has stride values as required to find the elements
348 within the original parent value. ADDRESS is the address in target
349 memory of the value matching TYPE. BASE_OFFSET is the offset from
350 the start of VAL's content buffer to the start of the object of TYPE,
351 VAL is the parent object from which we are loading the value, and
352 DEST is the value into which we are repacking. */
353 explicit fortran_array_repacker_impl (struct type
*type
, CORE_ADDR address
,
355 struct value
*val
, struct value
*dest
)
356 : fortran_array_repacker_base_impl (dest
),
357 m_base_offset (base_offset
),
360 gdb_assert (!val
->lazy ());
363 /* Extract an element of ELT_TYPE at offset (M_BASE_OFFSET + ELT_OFF)
364 from the content buffer of M_VAL then copy this extracted value into
365 the repacked destination value. */
366 void process_element (struct type
*elt_type
, LONGEST elt_off
,
367 LONGEST index
, bool last_p
)
370 = value_from_component (m_val
, elt_type
, (elt_off
+ m_base_offset
));
371 copy_element_to_dest (elt
);
375 /* The offset into the content buffer of M_VAL to the start of the slice
377 LONGEST m_base_offset
;
379 /* The parent value from which we are extracting a slice. */
384 /* Evaluate FORTRAN_ASSOCIATED expressions. Both GDBARCH and LANG are
385 extracted from the expression being evaluated. POINTER is the required
386 first argument to the 'associated' keyword, and TARGET is the optional
387 second argument, this will be nullptr if the user only passed one
388 argument to their use of 'associated'. */
390 static struct value
*
391 fortran_associated (struct gdbarch
*gdbarch
, const language_defn
*lang
,
392 struct value
*pointer
, struct value
*target
= nullptr)
394 struct type
*result_type
= language_bool_type (lang
, gdbarch
);
396 /* All Fortran pointers should have the associated property, this is
397 how we know the pointer is pointing at something or not. */
398 struct type
*pointer_type
= check_typedef (pointer
->type ());
399 if (TYPE_ASSOCIATED_PROP (pointer_type
) == nullptr
400 && pointer_type
->code () != TYPE_CODE_PTR
)
401 error (_("ASSOCIATED can only be applied to pointers"));
403 /* Get an address from POINTER. Fortran (or at least gfortran) models
404 array pointers as arrays with a dynamic data address, so we need to
405 use two approaches here, for real pointers we take the contents of the
406 pointer as an address. For non-pointers we take the address of the
408 CORE_ADDR pointer_addr
;
409 if (pointer_type
->code () == TYPE_CODE_PTR
)
410 pointer_addr
= value_as_address (pointer
);
412 pointer_addr
= pointer
->address ();
414 /* The single argument case, is POINTER associated with anything? */
415 if (target
== nullptr)
417 bool is_associated
= false;
419 /* If POINTER is an actual pointer and doesn't have an associated
420 property then we need to figure out whether this pointer is
421 associated by looking at the value of the pointer itself. We make
422 the assumption that a non-associated pointer will be set to 0.
423 This is probably true for most targets, but might not be true for
425 if (pointer_type
->code () == TYPE_CODE_PTR
426 && TYPE_ASSOCIATED_PROP (pointer_type
) == nullptr)
427 is_associated
= (pointer_addr
!= 0);
429 is_associated
= !type_not_associated (pointer_type
);
430 return value_from_longest (result_type
, is_associated
? 1 : 0);
433 /* The two argument case, is POINTER associated with TARGET? */
435 struct type
*target_type
= check_typedef (target
->type ());
437 struct type
*pointer_target_type
;
438 if (pointer_type
->code () == TYPE_CODE_PTR
)
439 pointer_target_type
= pointer_type
->target_type ();
441 pointer_target_type
= pointer_type
;
443 struct type
*target_target_type
;
444 if (target_type
->code () == TYPE_CODE_PTR
)
445 target_target_type
= target_type
->target_type ();
447 target_target_type
= target_type
;
449 if (pointer_target_type
->code () != target_target_type
->code ()
450 || (pointer_target_type
->code () != TYPE_CODE_ARRAY
451 && (pointer_target_type
->length ()
452 != target_target_type
->length ())))
453 error (_("arguments to associated must be of same type and kind"));
455 /* If TARGET is not in memory, or the original pointer is specifically
456 known to be not associated with anything, then the answer is obviously
457 false. Alternatively, if POINTER is an actual pointer and has no
458 associated property, then we have to check if its associated by
459 looking the value of the pointer itself. We make the assumption that
460 a non-associated pointer will be set to 0. This is probably true for
461 most targets, but might not be true for everyone. */
462 if (target
->lval () != lval_memory
463 || type_not_associated (pointer_type
)
464 || (TYPE_ASSOCIATED_PROP (pointer_type
) == nullptr
465 && pointer_type
->code () == TYPE_CODE_PTR
466 && pointer_addr
== 0))
467 return value_from_longest (result_type
, 0);
469 /* See the comment for POINTER_ADDR above. */
470 CORE_ADDR target_addr
;
471 if (target_type
->code () == TYPE_CODE_PTR
)
472 target_addr
= value_as_address (target
);
474 target_addr
= target
->address ();
476 /* Wrap the following checks inside a do { ... } while (false) loop so
477 that we can use `break' to jump out of the loop. */
478 bool is_associated
= false;
481 /* If the addresses are different then POINTER is definitely not
482 pointing at TARGET. */
483 if (pointer_addr
!= target_addr
)
486 /* If POINTER is a real pointer (i.e. not an array pointer, which are
487 implemented as arrays with a dynamic content address), then this
488 is all the checking that is needed. */
489 if (pointer_type
->code () == TYPE_CODE_PTR
)
491 is_associated
= true;
495 /* We have an array pointer. Check the number of dimensions. */
496 int pointer_dims
= calc_f77_array_dims (pointer_type
);
497 int target_dims
= calc_f77_array_dims (target_type
);
498 if (pointer_dims
!= target_dims
)
501 /* Now check that every dimension has the same upper bound, lower
502 bound, and stride value. */
504 while (dim
< pointer_dims
)
506 LONGEST pointer_lowerbound
, pointer_upperbound
, pointer_stride
;
507 LONGEST target_lowerbound
, target_upperbound
, target_stride
;
509 pointer_type
= check_typedef (pointer_type
);
510 target_type
= check_typedef (target_type
);
512 struct type
*pointer_range
= pointer_type
->index_type ();
513 struct type
*target_range
= target_type
->index_type ();
515 if (!get_discrete_bounds (pointer_range
, &pointer_lowerbound
,
516 &pointer_upperbound
))
519 if (!get_discrete_bounds (target_range
, &target_lowerbound
,
523 if (pointer_lowerbound
!= target_lowerbound
524 || pointer_upperbound
!= target_upperbound
)
527 /* Figure out the stride (in bits) for both pointer and target.
528 If either doesn't have a stride then we take the element size,
529 but we need to convert to bits (hence the * 8). */
530 pointer_stride
= pointer_range
->bounds ()->bit_stride ();
531 if (pointer_stride
== 0)
533 = type_length_units (check_typedef
534 (pointer_type
->target_type ())) * 8;
535 target_stride
= target_range
->bounds ()->bit_stride ();
536 if (target_stride
== 0)
538 = type_length_units (check_typedef
539 (target_type
->target_type ())) * 8;
540 if (pointer_stride
!= target_stride
)
546 if (dim
< pointer_dims
)
549 is_associated
= true;
553 return value_from_longest (result_type
, is_associated
? 1 : 0);
557 eval_op_f_associated (struct type
*expect_type
,
558 struct expression
*exp
,
560 enum exp_opcode opcode
,
563 return fortran_associated (exp
->gdbarch
, exp
->language_defn
, arg1
);
567 eval_op_f_associated (struct type
*expect_type
,
568 struct expression
*exp
,
570 enum exp_opcode opcode
,
574 return fortran_associated (exp
->gdbarch
, exp
->language_defn
, arg1
, arg2
);
577 /* Implement FORTRAN_ARRAY_SIZE expression, this corresponds to the 'SIZE'
578 keyword. RESULT_TYPE corresponds to the type kind the function should be
579 evaluated in, ARRAY is the value that should be an array, though this will
580 not have been checked before calling this function. DIM is optional, if
581 present then it should be an integer identifying a dimension of the
582 array to ask about. As with ARRAY the validity of DIM is not checked
583 before calling this function.
585 Return either the total number of elements in ARRAY (when DIM is
586 nullptr), or the number of elements in dimension DIM. */
589 fortran_array_size (value
*array
, value
*dim_val
, type
*result_type
)
591 /* Check that ARRAY is the correct type. */
592 struct type
*array_type
= check_typedef (array
->type ());
593 if (array_type
->code () != TYPE_CODE_ARRAY
)
594 error (_("SIZE can only be applied to arrays"));
595 if (type_not_allocated (array_type
) || type_not_associated (array_type
))
596 error (_("SIZE can only be used on allocated/associated arrays"));
598 int ndimensions
= calc_f77_array_dims (array_type
);
602 if (dim_val
!= nullptr)
604 if (check_typedef (dim_val
->type ())->code () != TYPE_CODE_INT
)
605 error (_("DIM argument to SIZE must be an integer"));
606 dim
= (int) value_as_long (dim_val
);
608 if (dim
< 1 || dim
> ndimensions
)
609 error (_("DIM argument to SIZE must be between 1 and %d"),
613 /* Now walk over all the dimensions of the array totalling up the
614 elements in each dimension. */
615 for (int i
= ndimensions
- 1; i
>= 0; --i
)
617 /* If this is the requested dimension then we're done. Grab the
618 bounds and return. */
619 if (i
== dim
- 1 || dim
== -1)
621 LONGEST lbound
, ubound
;
622 struct type
*range
= array_type
->index_type ();
624 if (!get_discrete_bounds (range
, &lbound
, &ubound
))
625 error (_("failed to find array bounds"));
627 LONGEST dim_size
= (ubound
- lbound
+ 1);
637 /* Peel off another dimension of the array. */
638 array_type
= array_type
->target_type ();
641 return value_from_longest (result_type
, result
);
647 eval_op_f_array_size (struct type
*expect_type
,
648 struct expression
*exp
,
650 enum exp_opcode opcode
,
653 gdb_assert (opcode
== FORTRAN_ARRAY_SIZE
);
655 type
*result_type
= builtin_f_type (exp
->gdbarch
)->builtin_integer
;
656 return fortran_array_size (arg1
, nullptr, result_type
);
662 eval_op_f_array_size (struct type
*expect_type
,
663 struct expression
*exp
,
665 enum exp_opcode opcode
,
669 gdb_assert (opcode
== FORTRAN_ARRAY_SIZE
);
671 type
*result_type
= builtin_f_type (exp
->gdbarch
)->builtin_integer
;
672 return fortran_array_size (arg1
, arg2
, result_type
);
677 value
*eval_op_f_array_size (type
*expect_type
, expression
*exp
, noside noside
,
678 exp_opcode opcode
, value
*arg1
, value
*arg2
,
681 gdb_assert (opcode
== FORTRAN_ARRAY_SIZE
);
682 gdb_assert (kind_arg
->code () == TYPE_CODE_INT
);
684 return fortran_array_size (arg1
, arg2
, kind_arg
);
687 /* Implement UNOP_FORTRAN_SHAPE expression. Both GDBARCH and LANG are
688 extracted from the expression being evaluated. VAL is the value on
689 which 'shape' was used, this can be any type.
691 Return an array of integers. If VAL is not an array then the returned
692 array should have zero elements. If VAL is an array then the returned
693 array should have one element per dimension, with the element
694 containing the extent of that dimension from VAL. */
696 static struct value
*
697 fortran_array_shape (struct gdbarch
*gdbarch
, const language_defn
*lang
,
700 struct type
*val_type
= check_typedef (val
->type ());
702 /* If we are passed an array that is either not allocated, or not
703 associated, then this is explicitly not allowed according to the
704 Fortran specification. */
705 if (val_type
->code () == TYPE_CODE_ARRAY
706 && (type_not_associated (val_type
) || type_not_allocated (val_type
)))
707 error (_("The array passed to SHAPE must be allocated or associated"));
709 /* The Fortran specification allows non-array types to be passed to this
710 function, in which case we get back an empty array.
712 Calculate the number of dimensions for the resulting array. */
714 if (val_type
->code () == TYPE_CODE_ARRAY
)
715 ndimensions
= calc_f77_array_dims (val_type
);
717 /* Allocate a result value of the correct type. */
718 type_allocator
alloc (gdbarch
);
720 = create_static_range_type (alloc
,
721 builtin_type (gdbarch
)->builtin_int
,
723 struct type
*elm_type
= builtin_f_type (gdbarch
)->builtin_integer
;
724 struct type
*result_type
= create_array_type (nullptr, elm_type
, range
);
725 struct value
*result
= value::allocate (result_type
);
726 LONGEST elm_len
= elm_type
->length ();
728 /* Walk the array dimensions backwards due to the way the array will be
729 laid out in memory, the first dimension will be the most inner.
731 If VAL was not an array then ndimensions will be 0, in which case we
732 will never go around this loop. */
733 for (LONGEST dst_offset
= elm_len
* (ndimensions
- 1);
735 dst_offset
-= elm_len
)
737 LONGEST lbound
, ubound
;
739 if (!get_discrete_bounds (val_type
->index_type (), &lbound
, &ubound
))
740 error (_("failed to find array bounds"));
742 LONGEST dim_size
= (ubound
- lbound
+ 1);
744 /* And copy the value into the result value. */
745 struct value
*v
= value_from_longest (elm_type
, dim_size
);
746 gdb_assert (dst_offset
+ v
->type ()->length ()
747 <= result
->type ()->length ());
748 gdb_assert (v
->type ()->length () == elm_len
);
749 v
->contents_copy (result
, dst_offset
, 0, elm_len
);
751 /* Peel another dimension of the array. */
752 val_type
= val_type
->target_type ();
761 eval_op_f_array_shape (struct type
*expect_type
, struct expression
*exp
,
762 enum noside noside
, enum exp_opcode opcode
,
765 gdb_assert (opcode
== UNOP_FORTRAN_SHAPE
);
766 return fortran_array_shape (exp
->gdbarch
, exp
->language_defn
, arg1
);
769 /* A helper function for UNOP_ABS. */
772 eval_op_f_abs (struct type
*expect_type
, struct expression
*exp
,
774 enum exp_opcode opcode
,
777 struct type
*type
= arg1
->type ();
778 switch (type
->code ())
783 = fabs (target_float_to_host_double (arg1
->contents ().data (),
785 return value_from_host_double (type
, d
);
789 LONGEST l
= value_as_long (arg1
);
791 return value_from_longest (type
, l
);
794 error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type
));
797 /* A helper function for BINOP_MOD. */
800 eval_op_f_mod (struct type
*expect_type
, struct expression
*exp
,
802 enum exp_opcode opcode
,
803 struct value
*arg1
, struct value
*arg2
)
805 struct type
*type
= arg1
->type ();
806 if (type
->code () != arg2
->type ()->code ())
807 error (_("non-matching types for parameters to MOD ()"));
808 switch (type
->code ())
813 = target_float_to_host_double (arg1
->contents ().data (),
816 = target_float_to_host_double (arg2
->contents ().data (),
818 double d3
= fmod (d1
, d2
);
819 return value_from_host_double (type
, d3
);
823 LONGEST v1
= value_as_long (arg1
);
824 LONGEST v2
= value_as_long (arg2
);
826 error (_("calling MOD (N, 0) is undefined"));
827 LONGEST v3
= v1
- (v1
/ v2
) * v2
;
828 return value_from_longest (arg1
->type (), v3
);
831 error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type
));
834 /* A helper function for the different FORTRAN_CEILING overloads. Calculates
835 CEILING for ARG1 (a float type) and returns it in the requested kind type
839 fortran_ceil_operation (value
*arg1
, type
*result_type
)
841 if (arg1
->type ()->code () != TYPE_CODE_FLT
)
842 error (_("argument to CEILING must be of type float"));
843 double val
= target_float_to_host_double (arg1
->contents ().data (),
846 return value_from_longest (result_type
, val
);
849 /* A helper function for FORTRAN_CEILING. */
852 eval_op_f_ceil (struct type
*expect_type
, struct expression
*exp
,
854 enum exp_opcode opcode
,
857 gdb_assert (opcode
== FORTRAN_CEILING
);
858 type
*result_type
= builtin_f_type (exp
->gdbarch
)->builtin_integer
;
859 return fortran_ceil_operation (arg1
, result_type
);
862 /* A helper function for FORTRAN_CEILING. */
865 eval_op_f_ceil (type
*expect_type
, expression
*exp
, noside noside
,
866 exp_opcode opcode
, value
*arg1
, type
*kind_arg
)
868 gdb_assert (opcode
== FORTRAN_CEILING
);
869 gdb_assert (kind_arg
->code () == TYPE_CODE_INT
);
870 return fortran_ceil_operation (arg1
, kind_arg
);
873 /* A helper function for the different FORTRAN_FLOOR overloads. Calculates
874 FLOOR for ARG1 (a float type) and returns it in the requested kind type
878 fortran_floor_operation (value
*arg1
, type
*result_type
)
880 if (arg1
->type ()->code () != TYPE_CODE_FLT
)
881 error (_("argument to FLOOR must be of type float"));
882 double val
= target_float_to_host_double (arg1
->contents ().data (),
885 return value_from_longest (result_type
, val
);
888 /* A helper function for FORTRAN_FLOOR. */
891 eval_op_f_floor (struct type
*expect_type
, struct expression
*exp
,
893 enum exp_opcode opcode
,
896 gdb_assert (opcode
== FORTRAN_FLOOR
);
897 type
*result_type
= builtin_f_type (exp
->gdbarch
)->builtin_integer
;
898 return fortran_floor_operation (arg1
, result_type
);
901 /* A helper function for FORTRAN_FLOOR. */
904 eval_op_f_floor (type
*expect_type
, expression
*exp
, noside noside
,
905 exp_opcode opcode
, value
*arg1
, type
*kind_arg
)
907 gdb_assert (opcode
== FORTRAN_FLOOR
);
908 gdb_assert (kind_arg
->code () == TYPE_CODE_INT
);
909 return fortran_floor_operation (arg1
, kind_arg
);
912 /* A helper function for BINOP_FORTRAN_MODULO. */
915 eval_op_f_modulo (struct type
*expect_type
, struct expression
*exp
,
917 enum exp_opcode opcode
,
918 struct value
*arg1
, struct value
*arg2
)
920 struct type
*type
= arg1
->type ();
921 if (type
->code () != arg2
->type ()->code ())
922 error (_("non-matching types for parameters to MODULO ()"));
923 /* MODULO(A, P) = A - FLOOR (A / P) * P */
924 switch (type
->code ())
928 LONGEST a
= value_as_long (arg1
);
929 LONGEST p
= value_as_long (arg2
);
930 LONGEST result
= a
- (a
/ p
) * p
;
931 if (result
!= 0 && (a
< 0) != (p
< 0))
933 return value_from_longest (arg1
->type (), result
);
938 = target_float_to_host_double (arg1
->contents ().data (),
941 = target_float_to_host_double (arg2
->contents ().data (),
943 double result
= fmod (a
, p
);
944 if (result
!= 0 && (a
< 0.0) != (p
< 0.0))
946 return value_from_host_double (type
, result
);
949 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type
));
952 /* A helper function for FORTRAN_CMPLX. */
955 eval_op_f_cmplx (type
*expect_type
, expression
*exp
, noside noside
,
956 exp_opcode opcode
, value
*arg1
)
958 gdb_assert (opcode
== FORTRAN_CMPLX
);
960 type
*result_type
= builtin_f_type (exp
->gdbarch
)->builtin_complex
;
962 if (arg1
->type ()->code () == TYPE_CODE_COMPLEX
)
963 return value_cast (result_type
, arg1
);
965 return value_literal_complex (arg1
,
966 value::zero (arg1
->type (), not_lval
),
970 /* A helper function for FORTRAN_CMPLX. */
973 eval_op_f_cmplx (struct type
*expect_type
, struct expression
*exp
,
975 enum exp_opcode opcode
,
976 struct value
*arg1
, struct value
*arg2
)
978 if (arg1
->type ()->code () == TYPE_CODE_COMPLEX
979 || arg2
->type ()->code () == TYPE_CODE_COMPLEX
)
980 error (_("Types of arguments for CMPLX called with more then one argument "
981 "must be REAL or INTEGER"));
983 type
*result_type
= builtin_f_type (exp
->gdbarch
)->builtin_complex
;
984 return value_literal_complex (arg1
, arg2
, result_type
);
987 /* A helper function for FORTRAN_CMPLX. */
990 eval_op_f_cmplx (type
*expect_type
, expression
*exp
, noside noside
,
991 exp_opcode opcode
, value
*arg1
, value
*arg2
, type
*kind_arg
)
993 gdb_assert (kind_arg
->code () == TYPE_CODE_COMPLEX
);
994 if (arg1
->type ()->code () == TYPE_CODE_COMPLEX
995 || arg2
->type ()->code () == TYPE_CODE_COMPLEX
)
996 error (_("Types of arguments for CMPLX called with more then one argument "
997 "must be REAL or INTEGER"));
999 return value_literal_complex (arg1
, arg2
, kind_arg
);
1002 /* A helper function for UNOP_FORTRAN_KIND. */
1005 eval_op_f_kind (struct type
*expect_type
, struct expression
*exp
,
1007 enum exp_opcode opcode
,
1010 struct type
*type
= arg1
->type ();
1012 switch (type
->code ())
1014 case TYPE_CODE_STRUCT
:
1015 case TYPE_CODE_UNION
:
1016 case TYPE_CODE_MODULE
:
1017 case TYPE_CODE_FUNC
:
1018 error (_("argument to kind must be an intrinsic type"));
1021 if (!type
->target_type ())
1022 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1024 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1025 type
->target_type ()->length ());
1028 /* A helper function for UNOP_FORTRAN_ALLOCATED. */
1031 eval_op_f_allocated (struct type
*expect_type
, struct expression
*exp
,
1032 enum noside noside
, enum exp_opcode op
,
1035 struct type
*type
= check_typedef (arg1
->type ());
1036 if (type
->code () != TYPE_CODE_ARRAY
)
1037 error (_("ALLOCATED can only be applied to arrays"));
1038 struct type
*result_type
1039 = builtin_f_type (exp
->gdbarch
)->builtin_logical
;
1040 LONGEST result_value
= type_not_allocated (type
) ? 0 : 1;
1041 return value_from_longest (result_type
, result_value
);
1047 eval_op_f_rank (struct type
*expect_type
,
1048 struct expression
*exp
,
1053 gdb_assert (op
== UNOP_FORTRAN_RANK
);
1055 struct type
*result_type
1056 = builtin_f_type (exp
->gdbarch
)->builtin_integer
;
1057 struct type
*type
= check_typedef (arg1
->type ());
1058 if (type
->code () != TYPE_CODE_ARRAY
)
1059 return value_from_longest (result_type
, 0);
1060 LONGEST ndim
= calc_f77_array_dims (type
);
1061 return value_from_longest (result_type
, ndim
);
1064 /* A helper function for UNOP_FORTRAN_LOC. */
1067 eval_op_f_loc (struct type
*expect_type
, struct expression
*exp
,
1068 enum noside noside
, enum exp_opcode op
,
1071 struct type
*result_type
;
1072 if (gdbarch_ptr_bit (exp
->gdbarch
) == 16)
1073 result_type
= builtin_f_type (exp
->gdbarch
)->builtin_integer_s2
;
1074 else if (gdbarch_ptr_bit (exp
->gdbarch
) == 32)
1075 result_type
= builtin_f_type (exp
->gdbarch
)->builtin_integer
;
1077 result_type
= builtin_f_type (exp
->gdbarch
)->builtin_integer_s8
;
1079 LONGEST result_value
= arg1
->address ();
1080 return value_from_longest (result_type
, result_value
);
1086 /* Called from evaluate to perform array indexing, and sub-range
1087 extraction, for Fortran. As well as arrays this function also
1088 handles strings as they can be treated like arrays of characters.
1089 ARRAY is the array or string being accessed. EXP and NOSIDE are as
1093 fortran_undetermined::value_subarray (value
*array
,
1094 struct expression
*exp
,
1097 type
*original_array_type
= check_typedef (array
->type ());
1098 bool is_string_p
= original_array_type
->code () == TYPE_CODE_STRING
;
1099 const std::vector
<operation_up
> &ops
= std::get
<1> (m_storage
);
1100 int nargs
= ops
.size ();
1102 /* Perform checks for ARRAY not being available. The somewhat overly
1103 complex logic here is just to keep backward compatibility with the
1104 errors that we used to get before FORTRAN_VALUE_SUBARRAY was
1105 rewritten. Maybe a future task would streamline the error messages we
1106 get here, and update all the expected test results. */
1107 if (ops
[0]->opcode () != OP_RANGE
)
1109 if (type_not_associated (original_array_type
))
1110 error (_("no such vector element (vector not associated)"));
1111 else if (type_not_allocated (original_array_type
))
1112 error (_("no such vector element (vector not allocated)"));
1116 if (type_not_associated (original_array_type
))
1117 error (_("array not associated"));
1118 else if (type_not_allocated (original_array_type
))
1119 error (_("array not allocated"));
1122 /* First check that the number of dimensions in the type we are slicing
1123 matches the number of arguments we were passed. */
1124 int ndimensions
= calc_f77_array_dims (original_array_type
);
1125 if (nargs
!= ndimensions
)
1126 error (_("Wrong number of subscripts"));
1128 /* This will be initialised below with the type of the elements held in
1130 struct type
*inner_element_type
;
1132 /* Extract the types of each array dimension from the original array
1133 type. We need these available so we can fill in the default upper and
1134 lower bounds if the user requested slice doesn't provide that
1135 information. Additionally unpacking the dimensions like this gives us
1136 the inner element type. */
1137 std::vector
<struct type
*> dim_types
;
1139 dim_types
.reserve (ndimensions
);
1140 struct type
*type
= original_array_type
;
1141 for (int i
= 0; i
< ndimensions
; ++i
)
1143 dim_types
.push_back (type
);
1144 type
= type
->target_type ();
1146 /* TYPE is now the inner element type of the array, we start the new
1147 array slice off as this type, then as we process the requested slice
1148 (from the user) we wrap new types around this to build up the final
1150 inner_element_type
= type
;
1153 /* As we analyse the new slice type we need to understand if the data
1154 being referenced is contiguous. Do decide this we must track the size
1155 of an element at each dimension of the new slice array. Initially the
1156 elements of the inner most dimension of the array are the same inner
1157 most elements as the original ARRAY. */
1158 LONGEST slice_element_size
= inner_element_type
->length ();
1160 /* Start off assuming all data is contiguous, this will be set to false
1161 if access to any dimension results in non-contiguous data. */
1162 bool is_all_contiguous
= true;
1164 /* The TOTAL_OFFSET is the distance in bytes from the start of the
1165 original ARRAY to the start of the new slice. This is calculated as
1166 we process the information from the user. */
1167 LONGEST total_offset
= 0;
1169 /* A structure representing information about each dimension of the
1174 slice_dim (LONGEST l
, LONGEST h
, LONGEST s
, struct type
*idx
)
1181 /* The low bound for this dimension of the slice. */
1184 /* The high bound for this dimension of the slice. */
1187 /* The byte stride for this dimension of the slice. */
1193 /* The dimensions of the resulting slice. */
1194 std::vector
<slice_dim
> slice_dims
;
1196 /* Process the incoming arguments. These arguments are in the reverse
1197 order to the array dimensions, that is the first argument refers to
1198 the last array dimension. */
1199 if (fortran_array_slicing_debug
)
1200 debug_printf ("Processing array access:\n");
1201 for (int i
= 0; i
< nargs
; ++i
)
1203 /* For each dimension of the array the user will have either provided
1204 a ranged access with optional lower bound, upper bound, and
1205 stride, or the user will have supplied a single index. */
1206 struct type
*dim_type
= dim_types
[ndimensions
- (i
+ 1)];
1207 fortran_range_operation
*range_op
1208 = dynamic_cast<fortran_range_operation
*> (ops
[i
].get ());
1209 if (range_op
!= nullptr)
1211 enum range_flag range_flag
= range_op
->get_flags ();
1213 LONGEST low
, high
, stride
;
1214 low
= high
= stride
= 0;
1216 if ((range_flag
& RANGE_LOW_BOUND_DEFAULT
) == 0)
1217 low
= value_as_long (range_op
->evaluate0 (exp
, noside
));
1219 low
= f77_get_lowerbound (dim_type
);
1220 if ((range_flag
& RANGE_HIGH_BOUND_DEFAULT
) == 0)
1221 high
= value_as_long (range_op
->evaluate1 (exp
, noside
));
1223 high
= f77_get_upperbound (dim_type
);
1224 if ((range_flag
& RANGE_HAS_STRIDE
) == RANGE_HAS_STRIDE
)
1225 stride
= value_as_long (range_op
->evaluate2 (exp
, noside
));
1230 error (_("stride must not be 0"));
1232 /* Get information about this dimension in the original ARRAY. */
1233 struct type
*target_type
= dim_type
->target_type ();
1234 struct type
*index_type
= dim_type
->index_type ();
1235 LONGEST lb
= f77_get_lowerbound (dim_type
);
1236 LONGEST ub
= f77_get_upperbound (dim_type
);
1237 LONGEST sd
= index_type
->bit_stride ();
1239 sd
= target_type
->length () * 8;
1241 if (fortran_array_slicing_debug
)
1243 debug_printf ("|-> Range access\n");
1244 std::string str
= type_to_string (dim_type
);
1245 debug_printf ("| |-> Type: %s\n", str
.c_str ());
1246 debug_printf ("| |-> Array:\n");
1247 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
1248 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
1249 debug_printf ("| | |-> Bit stride: %s\n", plongest (sd
));
1250 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
/ 8));
1251 debug_printf ("| | |-> Type size: %s\n",
1252 pulongest (dim_type
->length ()));
1253 debug_printf ("| | '-> Target type size: %s\n",
1254 pulongest (target_type
->length ()));
1255 debug_printf ("| |-> Accessing:\n");
1256 debug_printf ("| | |-> Low bound: %s\n",
1258 debug_printf ("| | |-> High bound: %s\n",
1260 debug_printf ("| | '-> Element stride: %s\n",
1264 /* Check the user hasn't asked for something invalid. */
1265 if (high
> ub
|| low
< lb
)
1266 error (_("array subscript out of bounds"));
1268 /* Calculate what this dimension of the new slice array will look
1269 like. OFFSET is the byte offset from the start of the
1270 previous (more outer) dimension to the start of this
1271 dimension. E_COUNT is the number of elements in this
1272 dimension. REMAINDER is the number of elements remaining
1273 between the last included element and the upper bound. For
1274 example an access '1:6:2' will include elements 1, 3, 5 and
1275 have a remainder of 1 (element #6). */
1276 LONGEST lowest
= std::min (low
, high
);
1277 LONGEST offset
= (sd
/ 8) * (lowest
- lb
);
1278 LONGEST e_count
= std::abs (high
- low
) + 1;
1279 e_count
= (e_count
+ (std::abs (stride
) - 1)) / std::abs (stride
);
1280 LONGEST new_low
= 1;
1281 LONGEST new_high
= new_low
+ e_count
- 1;
1282 LONGEST new_stride
= (sd
* stride
) / 8;
1283 LONGEST last_elem
= low
+ ((e_count
- 1) * stride
);
1284 LONGEST remainder
= high
- last_elem
;
1287 offset
+= std::abs (remainder
) * target_type
->length ();
1289 error (_("incorrect stride and boundary combination"));
1291 else if (stride
< 0)
1292 error (_("incorrect stride and boundary combination"));
1294 /* Is the data within this dimension contiguous? It is if the
1295 newly computed stride is the same size as a single element of
1297 bool is_dim_contiguous
= (new_stride
== slice_element_size
);
1298 is_all_contiguous
&= is_dim_contiguous
;
1300 if (fortran_array_slicing_debug
)
1302 debug_printf ("| '-> Results:\n");
1303 debug_printf ("| |-> Offset = %s\n", plongest (offset
));
1304 debug_printf ("| |-> Elements = %s\n", plongest (e_count
));
1305 debug_printf ("| |-> Low bound = %s\n", plongest (new_low
));
1306 debug_printf ("| |-> High bound = %s\n",
1307 plongest (new_high
));
1308 debug_printf ("| |-> Byte stride = %s\n",
1309 plongest (new_stride
));
1310 debug_printf ("| |-> Last element = %s\n",
1311 plongest (last_elem
));
1312 debug_printf ("| |-> Remainder = %s\n",
1313 plongest (remainder
));
1314 debug_printf ("| '-> Contiguous = %s\n",
1315 (is_dim_contiguous
? "Yes" : "No"));
1318 /* Figure out how big (in bytes) an element of this dimension of
1319 the new array slice will be. */
1320 slice_element_size
= std::abs (new_stride
* e_count
);
1322 slice_dims
.emplace_back (new_low
, new_high
, new_stride
,
1325 /* Update the total offset. */
1326 total_offset
+= offset
;
1330 /* There is a single index for this dimension. */
1332 = value_as_long (ops
[i
]->evaluate_with_coercion (exp
, noside
));
1334 /* Get information about this dimension in the original ARRAY. */
1335 struct type
*target_type
= dim_type
->target_type ();
1336 struct type
*index_type
= dim_type
->index_type ();
1337 LONGEST lb
= f77_get_lowerbound (dim_type
);
1338 LONGEST ub
= f77_get_upperbound (dim_type
);
1339 LONGEST sd
= index_type
->bit_stride () / 8;
1341 sd
= target_type
->length ();
1343 if (fortran_array_slicing_debug
)
1345 debug_printf ("|-> Index access\n");
1346 std::string str
= type_to_string (dim_type
);
1347 debug_printf ("| |-> Type: %s\n", str
.c_str ());
1348 debug_printf ("| |-> Array:\n");
1349 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
1350 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
1351 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
));
1352 debug_printf ("| | |-> Type size: %s\n",
1353 pulongest (dim_type
->length ()));
1354 debug_printf ("| | '-> Target type size: %s\n",
1355 pulongest (target_type
->length ()));
1356 debug_printf ("| '-> Accessing:\n");
1357 debug_printf ("| '-> Index: %s\n",
1361 /* If the array has actual content then check the index is in
1362 bounds. An array without content (an unbound array) doesn't
1363 have a known upper bound, so don't error check in that
1366 || (dim_type
->index_type ()->bounds ()->high
.kind () != PROP_UNDEFINED
1368 || (array
->lval () != lval_memory
1369 && dim_type
->index_type ()->bounds ()->high
.kind () == PROP_UNDEFINED
))
1371 if (type_not_associated (dim_type
))
1372 error (_("no such vector element (vector not associated)"));
1373 else if (type_not_allocated (dim_type
))
1374 error (_("no such vector element (vector not allocated)"));
1376 error (_("no such vector element"));
1379 /* Calculate using the type stride, not the target type size. */
1380 LONGEST offset
= sd
* (index
- lb
);
1381 total_offset
+= offset
;
1385 /* Build a type that represents the new array slice in the target memory
1386 of the original ARRAY, this type makes use of strides to correctly
1387 find only those elements that are part of the new slice. */
1388 struct type
*array_slice_type
= inner_element_type
;
1389 for (const auto &d
: slice_dims
)
1391 /* Create the range. */
1392 dynamic_prop p_low
, p_high
, p_stride
;
1394 p_low
.set_const_val (d
.low
);
1395 p_high
.set_const_val (d
.high
);
1396 p_stride
.set_const_val (d
.stride
);
1398 type_allocator
alloc (d
.index
->target_type ());
1399 struct type
*new_range
1400 = create_range_type_with_stride (alloc
,
1401 d
.index
->target_type (),
1402 &p_low
, &p_high
, 0, &p_stride
,
1405 = create_array_type (nullptr, array_slice_type
, new_range
);
1408 if (fortran_array_slicing_debug
)
1410 debug_printf ("'-> Final result:\n");
1411 debug_printf (" |-> Type: %s\n",
1412 type_to_string (array_slice_type
).c_str ());
1413 debug_printf (" |-> Total offset: %s\n",
1414 plongest (total_offset
));
1415 debug_printf (" |-> Base address: %s\n",
1416 core_addr_to_string (array
->address ()));
1417 debug_printf (" '-> Contiguous = %s\n",
1418 (is_all_contiguous
? "Yes" : "No"));
1421 /* Should we repack this array slice? */
1422 if (!is_all_contiguous
&& (repack_array_slices
|| is_string_p
))
1424 /* Build a type for the repacked slice. */
1425 struct type
*repacked_array_type
= inner_element_type
;
1426 for (const auto &d
: slice_dims
)
1428 /* Create the range. */
1429 dynamic_prop p_low
, p_high
, p_stride
;
1431 p_low
.set_const_val (d
.low
);
1432 p_high
.set_const_val (d
.high
);
1433 p_stride
.set_const_val (repacked_array_type
->length ());
1435 type_allocator
alloc (d
.index
->target_type ());
1436 struct type
*new_range
1437 = create_range_type_with_stride (alloc
,
1438 d
.index
->target_type (),
1439 &p_low
, &p_high
, 0, &p_stride
,
1442 = create_array_type (nullptr, repacked_array_type
, new_range
);
1445 /* Now copy the elements from the original ARRAY into the packed
1446 array value DEST. */
1447 struct value
*dest
= value::allocate (repacked_array_type
);
1449 || (total_offset
+ array_slice_type
->length ()
1450 > check_typedef (array
->type ())->length ()))
1452 fortran_array_walker
<fortran_lazy_array_repacker_impl
> p
1453 (array_slice_type
, array
->address () + total_offset
, dest
);
1458 fortran_array_walker
<fortran_array_repacker_impl
> p
1459 (array_slice_type
, array
->address () + total_offset
,
1460 total_offset
, array
, dest
);
1467 if (array
->lval () == lval_memory
)
1469 /* If the value we're taking a slice from is not yet loaded, or
1470 the requested slice is outside the values content range then
1471 just create a new lazy value pointing at the memory where the
1472 contents we're looking for exist. */
1474 || (total_offset
+ array_slice_type
->length ()
1475 > check_typedef (array
->type ())->length ()))
1476 array
= value_at_lazy (array_slice_type
,
1477 array
->address () + total_offset
);
1479 array
= value_from_contents_and_address
1480 (array_slice_type
, array
->contents ().data () + total_offset
,
1481 array
->address () + total_offset
);
1483 else if (!array
->lazy ())
1484 array
= value_from_component (array
, array_slice_type
, total_offset
);
1486 error (_("cannot subscript arrays that are not in memory"));
1493 fortran_undetermined::evaluate (struct type
*expect_type
,
1494 struct expression
*exp
,
1497 value
*callee
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
, noside
);
1498 if (noside
== EVAL_AVOID_SIDE_EFFECTS
1499 && is_dynamic_type (callee
->type ()))
1500 callee
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
, EVAL_NORMAL
);
1501 struct type
*type
= check_typedef (callee
->type ());
1502 enum type_code code
= type
->code ();
1504 if (code
== TYPE_CODE_PTR
)
1506 /* Fortran always passes variable to subroutines as pointer.
1507 So we need to look into its target type to see if it is
1508 array, string or function. If it is, we need to switch
1509 to the target value the original one points to. */
1510 struct type
*target_type
= check_typedef (type
->target_type ());
1512 if (target_type
->code () == TYPE_CODE_ARRAY
1513 || target_type
->code () == TYPE_CODE_STRING
1514 || target_type
->code () == TYPE_CODE_FUNC
)
1516 callee
= value_ind (callee
);
1517 type
= check_typedef (callee
->type ());
1518 code
= type
->code ();
1524 case TYPE_CODE_ARRAY
:
1525 case TYPE_CODE_STRING
:
1526 return value_subarray (callee
, exp
, noside
);
1529 case TYPE_CODE_FUNC
:
1530 case TYPE_CODE_INTERNAL_FUNCTION
:
1532 /* It's a function call. Allocate arg vector, including
1533 space for the function to be called in argvec[0] and a
1534 termination NULL. */
1535 const std::vector
<operation_up
> &actual (std::get
<1> (m_storage
));
1536 std::vector
<value
*> argvec (actual
.size ());
1537 bool is_internal_func
= (code
== TYPE_CODE_INTERNAL_FUNCTION
);
1538 for (int tem
= 0; tem
< argvec
.size (); tem
++)
1539 argvec
[tem
] = fortran_prepare_argument (exp
, actual
[tem
].get (),
1540 tem
, is_internal_func
,
1543 return evaluate_subexp_do_call (exp
, noside
, callee
, argvec
,
1544 nullptr, expect_type
);
1548 error (_("Cannot perform substring on this type"));
1553 fortran_bound_1arg::evaluate (struct type
*expect_type
,
1554 struct expression
*exp
,
1557 bool lbound_p
= std::get
<0> (m_storage
) == FORTRAN_LBOUND
;
1558 value
*arg1
= std::get
<1> (m_storage
)->evaluate (nullptr, exp
, noside
);
1559 fortran_require_array (arg1
->type (), lbound_p
);
1560 return fortran_bounds_all_dims (lbound_p
, exp
->gdbarch
, arg1
);
1564 fortran_bound_2arg::evaluate (struct type
*expect_type
,
1565 struct expression
*exp
,
1568 bool lbound_p
= std::get
<0> (m_storage
) == FORTRAN_LBOUND
;
1569 value
*arg1
= std::get
<1> (m_storage
)->evaluate (nullptr, exp
, noside
);
1570 fortran_require_array (arg1
->type (), lbound_p
);
1572 /* User asked for the bounds of a specific dimension of the array. */
1573 value
*arg2
= std::get
<2> (m_storage
)->evaluate (nullptr, exp
, noside
);
1574 type
*type_arg2
= check_typedef (arg2
->type ());
1575 if (type_arg2
->code () != TYPE_CODE_INT
)
1578 error (_("LBOUND second argument should be an integer"));
1580 error (_("UBOUND second argument should be an integer"));
1583 type
*result_type
= builtin_f_type (exp
->gdbarch
)->builtin_integer
;
1584 return fortran_bounds_for_dimension (lbound_p
, arg1
, arg2
, result_type
);
1588 fortran_bound_3arg::evaluate (type
*expect_type
,
1592 const bool lbound_p
= std::get
<0> (m_storage
) == FORTRAN_LBOUND
;
1593 value
*arg1
= std::get
<1> (m_storage
)->evaluate (nullptr, exp
, noside
);
1594 fortran_require_array (arg1
->type (), lbound_p
);
1596 /* User asked for the bounds of a specific dimension of the array. */
1597 value
*arg2
= std::get
<2> (m_storage
)->evaluate (nullptr, exp
, noside
);
1598 type
*type_arg2
= check_typedef (arg2
->type ());
1599 if (type_arg2
->code () != TYPE_CODE_INT
)
1602 error (_("LBOUND second argument should be an integer"));
1604 error (_("UBOUND second argument should be an integer"));
1607 type
*kind_arg
= std::get
<3> (m_storage
);
1608 gdb_assert (kind_arg
->code () == TYPE_CODE_INT
);
1610 return fortran_bounds_for_dimension (lbound_p
, arg1
, arg2
, kind_arg
);
1613 /* Implement STRUCTOP_STRUCT for Fortran. See operation::evaluate in
1614 expression.h for argument descriptions. */
1617 fortran_structop_operation::evaluate (struct type
*expect_type
,
1618 struct expression
*exp
,
1621 value
*arg1
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
, noside
);
1622 const char *str
= std::get
<1> (m_storage
).c_str ();
1623 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
1625 struct type
*type
= lookup_struct_elt_type (arg1
->type (), str
, 1);
1627 if (type
!= nullptr && is_dynamic_type (type
))
1628 arg1
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
, EVAL_NORMAL
);
1631 value
*elt
= value_struct_elt (&arg1
, {}, str
, NULL
, "structure");
1633 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
1635 struct type
*elt_type
= elt
->type ();
1636 if (is_dynamic_type (elt_type
))
1638 const gdb_byte
*valaddr
= elt
->contents_for_printing ().data ();
1639 CORE_ADDR address
= elt
->address ();
1640 gdb::array_view
<const gdb_byte
> view
1641 = gdb::make_array_view (valaddr
, elt_type
->length ());
1642 elt_type
= resolve_dynamic_type (elt_type
, view
, address
);
1644 elt
= value::zero (elt_type
, elt
->lval ());
1650 } /* namespace expr */
1652 /* See language.h. */
1655 f_language::print_array_index (struct type
*index_type
, LONGEST index
,
1656 struct ui_file
*stream
,
1657 const value_print_options
*options
) const
1659 struct value
*index_value
= value_from_longest (index_type
, index
);
1661 gdb_printf (stream
, "(");
1662 value_print (index_value
, stream
, options
);
1663 gdb_printf (stream
, ") = ");
1666 /* See language.h. */
1669 f_language::language_arch_info (struct gdbarch
*gdbarch
,
1670 struct language_arch_info
*lai
) const
1672 const struct builtin_f_type
*builtin
= builtin_f_type (gdbarch
);
1674 /* Helper function to allow shorter lines below. */
1675 auto add
= [&] (struct type
* t
)
1677 lai
->add_primitive_type (t
);
1680 add (builtin
->builtin_character
);
1681 add (builtin
->builtin_logical
);
1682 add (builtin
->builtin_logical_s1
);
1683 add (builtin
->builtin_logical_s2
);
1684 add (builtin
->builtin_logical_s8
);
1685 add (builtin
->builtin_real
);
1686 add (builtin
->builtin_real_s8
);
1687 add (builtin
->builtin_real_s16
);
1688 add (builtin
->builtin_complex
);
1689 add (builtin
->builtin_complex_s8
);
1690 add (builtin
->builtin_void
);
1692 lai
->set_string_char_type (builtin
->builtin_character
);
1693 lai
->set_bool_type (builtin
->builtin_logical
, "logical");
1696 /* See language.h. */
1699 f_language::search_name_hash (const char *name
) const
1701 return cp_search_name_hash (name
);
1704 /* See language.h. */
1707 f_language::lookup_symbol_nonlocal (const char *name
,
1708 const struct block
*block
,
1709 const domain_enum domain
) const
1711 return cp_lookup_symbol_nonlocal (this, name
, block
, domain
);
1714 /* See language.h. */
1716 symbol_name_matcher_ftype
*
1717 f_language::get_symbol_name_matcher_inner
1718 (const lookup_name_info
&lookup_name
) const
1720 return cp_get_symbol_name_matcher (lookup_name
);
1723 /* Single instance of the Fortran language class. */
1725 static f_language f_language_defn
;
1727 static struct builtin_f_type
*
1728 build_fortran_types (struct gdbarch
*gdbarch
)
1730 struct builtin_f_type
*builtin_f_type
= new struct builtin_f_type
;
1732 builtin_f_type
->builtin_void
= builtin_type (gdbarch
)->builtin_void
;
1734 type_allocator
alloc (gdbarch
);
1736 builtin_f_type
->builtin_character
1737 = alloc
.new_type (TYPE_CODE_CHAR
, TARGET_CHAR_BIT
, "character");
1739 builtin_f_type
->builtin_logical_s1
1740 = init_boolean_type (alloc
, TARGET_CHAR_BIT
, 1, "logical*1");
1742 builtin_f_type
->builtin_logical_s2
1743 = init_boolean_type (alloc
, gdbarch_short_bit (gdbarch
), 1, "logical*2");
1745 builtin_f_type
->builtin_logical
1746 = init_boolean_type (alloc
, gdbarch_int_bit (gdbarch
), 1, "logical*4");
1748 builtin_f_type
->builtin_logical_s8
1749 = init_boolean_type (alloc
, gdbarch_long_long_bit (gdbarch
), 1,
1752 builtin_f_type
->builtin_integer_s1
1753 = init_integer_type (alloc
, TARGET_CHAR_BIT
, 0, "integer*1");
1755 builtin_f_type
->builtin_integer_s2
1756 = init_integer_type (alloc
, gdbarch_short_bit (gdbarch
), 0, "integer*2");
1758 builtin_f_type
->builtin_integer
1759 = init_integer_type (alloc
, gdbarch_int_bit (gdbarch
), 0, "integer*4");
1761 builtin_f_type
->builtin_integer_s8
1762 = init_integer_type (alloc
, gdbarch_long_long_bit (gdbarch
), 0,
1765 builtin_f_type
->builtin_real
1766 = init_float_type (alloc
, gdbarch_float_bit (gdbarch
),
1767 "real*4", gdbarch_float_format (gdbarch
));
1769 builtin_f_type
->builtin_real_s8
1770 = init_float_type (alloc
, gdbarch_double_bit (gdbarch
),
1771 "real*8", gdbarch_double_format (gdbarch
));
1773 auto fmt
= gdbarch_floatformat_for_type (gdbarch
, "real(kind=16)", 128);
1775 builtin_f_type
->builtin_real_s16
1776 = init_float_type (alloc
, 128, "real*16", fmt
);
1777 else if (gdbarch_long_double_bit (gdbarch
) == 128)
1778 builtin_f_type
->builtin_real_s16
1779 = init_float_type (alloc
, gdbarch_long_double_bit (gdbarch
),
1780 "real*16", gdbarch_long_double_format (gdbarch
));
1782 builtin_f_type
->builtin_real_s16
1783 = alloc
.new_type (TYPE_CODE_ERROR
, 128, "real*16");
1785 builtin_f_type
->builtin_complex
1786 = init_complex_type ("complex*4", builtin_f_type
->builtin_real
);
1788 builtin_f_type
->builtin_complex_s8
1789 = init_complex_type ("complex*8", builtin_f_type
->builtin_real_s8
);
1791 if (builtin_f_type
->builtin_real_s16
->code () == TYPE_CODE_ERROR
)
1792 builtin_f_type
->builtin_complex_s16
1793 = alloc
.new_type (TYPE_CODE_ERROR
, 256, "complex*16");
1795 builtin_f_type
->builtin_complex_s16
1796 = init_complex_type ("complex*16", builtin_f_type
->builtin_real_s16
);
1798 return builtin_f_type
;
1801 static const registry
<gdbarch
>::key
<struct builtin_f_type
> f_type_data
;
1803 const struct builtin_f_type
*
1804 builtin_f_type (struct gdbarch
*gdbarch
)
1806 struct builtin_f_type
*result
= f_type_data
.get (gdbarch
);
1807 if (result
== nullptr)
1809 result
= build_fortran_types (gdbarch
);
1810 f_type_data
.set (gdbarch
, result
);
1816 /* Command-list for the "set/show fortran" prefix command. */
1817 static struct cmd_list_element
*set_fortran_list
;
1818 static struct cmd_list_element
*show_fortran_list
;
1820 void _initialize_f_language ();
1822 _initialize_f_language ()
1824 add_setshow_prefix_cmd
1825 ("fortran", no_class
,
1826 _("Prefix command for changing Fortran-specific settings."),
1827 _("Generic command for showing Fortran-specific settings."),
1828 &set_fortran_list
, &show_fortran_list
,
1829 &setlist
, &showlist
);
1831 add_setshow_boolean_cmd ("repack-array-slices", class_vars
,
1832 &repack_array_slices
, _("\
1833 Enable or disable repacking of non-contiguous array slices."), _("\
1834 Show whether non-contiguous array slices are repacked."), _("\
1835 When the user requests a slice of a Fortran array then we can either return\n\
1836 a descriptor that describes the array in place (using the original array data\n\
1837 in its existing location) or the original data can be repacked (copied) to a\n\
1840 When the content of the array slice is contiguous within the original array\n\
1841 then the result will never be repacked, but when the data for the new array\n\
1842 is non-contiguous within the original array repacking will only be performed\n\
1843 when this setting is on."),
1845 show_repack_array_slices
,
1846 &set_fortran_list
, &show_fortran_list
);
1848 /* Debug Fortran's array slicing logic. */
1849 add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance
,
1850 &fortran_array_slicing_debug
, _("\
1851 Set debugging of Fortran array slicing."), _("\
1852 Show debugging of Fortran array slicing."), _("\
1853 When on, debugging of Fortran array slicing is enabled."),
1855 show_fortran_array_slicing_debug
,
1856 &setdebuglist
, &showdebuglist
);
1859 /* Ensures that function argument VALUE is in the appropriate form to
1860 pass to a Fortran function. Returns a possibly new value that should
1861 be used instead of VALUE.
1863 When IS_ARTIFICIAL is true this indicates an artificial argument,
1864 e.g. hidden string lengths which the GNU Fortran argument passing
1865 convention specifies as being passed by value.
1867 When IS_ARTIFICIAL is false, the argument is passed by pointer. If the
1868 value is already in target memory then return a value that is a pointer
1869 to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate
1870 space in the target, copy VALUE in, and return a pointer to the in
1873 static struct value
*
1874 fortran_argument_convert (struct value
*value
, bool is_artificial
)
1878 /* If the value is not in the inferior e.g. registers values,
1879 convenience variables and user input. */
1880 if (value
->lval () != lval_memory
)
1882 struct type
*type
= value
->type ();
1883 const int length
= type
->length ();
1884 const CORE_ADDR addr
1885 = value_as_long (value_allocate_space_in_inferior (length
));
1886 write_memory (addr
, value
->contents ().data (), length
);
1887 struct value
*val
= value_from_contents_and_address
1888 (type
, value
->contents ().data (), addr
);
1889 return value_addr (val
);
1892 return value_addr (value
); /* Program variables, e.g. arrays. */
1897 /* Prepare (and return) an argument value ready for an inferior function
1898 call to a Fortran function. EXP and POS are the expressions describing
1899 the argument to prepare. ARG_NUM is the argument number being
1900 prepared, with 0 being the first argument and so on. FUNC_TYPE is the
1901 type of the function being called.
1903 IS_INTERNAL_CALL_P is true if this is a call to a function of type
1904 TYPE_CODE_INTERNAL_FUNCTION, otherwise this parameter is false.
1906 NOSIDE has its usual meaning for expression parsing (see eval.c).
1908 Arguments in Fortran are normally passed by address, we coerce the
1909 arguments here rather than in value_arg_coerce as otherwise the call to
1910 malloc (to place the non-lvalue parameters in target memory) is hit by
1911 this Fortran specific logic. This results in malloc being called with a
1912 pointer to an integer followed by an attempt to malloc the arguments to
1913 malloc in target memory. Infinite recursion ensues. */
1916 fortran_prepare_argument (struct expression
*exp
,
1917 expr::operation
*subexp
,
1918 int arg_num
, bool is_internal_call_p
,
1919 struct type
*func_type
, enum noside noside
)
1921 if (is_internal_call_p
)
1922 return subexp
->evaluate_with_coercion (exp
, noside
);
1924 bool is_artificial
= ((arg_num
>= func_type
->num_fields ())
1926 : TYPE_FIELD_ARTIFICIAL (func_type
, arg_num
));
1928 /* If this is an artificial argument, then either, this is an argument
1929 beyond the end of the known arguments, or possibly, there are no known
1930 arguments (maybe missing debug info).
1932 For these artificial arguments, if the user has prefixed it with '&'
1933 (for address-of), then lets always allow this to succeed, even if the
1934 argument is not actually in inferior memory. This will allow the user
1935 to pass arguments to a Fortran function even when there's no debug
1938 As we already pass the address of non-artificial arguments, all we
1939 need to do if skip the UNOP_ADDR operator in the expression and mark
1940 the argument as non-artificial. */
1943 expr::unop_addr_operation
*addrop
1944 = dynamic_cast<expr::unop_addr_operation
*> (subexp
);
1945 if (addrop
!= nullptr)
1947 subexp
= addrop
->get_expression ().get ();
1948 is_artificial
= false;
1952 struct value
*arg_val
= subexp
->evaluate_with_coercion (exp
, noside
);
1953 return fortran_argument_convert (arg_val
, is_artificial
);
1959 fortran_preserve_arg_pointer (struct value
*arg
, struct type
*type
)
1961 if (arg
->type ()->code () == TYPE_CODE_PTR
)
1962 return arg
->type ();
1969 fortran_adjust_dynamic_array_base_address_hack (struct type
*type
,
1972 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
1974 /* We can't adjust the base address for arrays that have no content. */
1975 if (type_not_allocated (type
) || type_not_associated (type
))
1978 int ndimensions
= calc_f77_array_dims (type
);
1979 LONGEST total_offset
= 0;
1981 /* Walk through each of the dimensions of this array type and figure out
1982 if any of the dimensions are "backwards", that is the base address
1983 for this dimension points to the element at the highest memory
1984 address and the stride is negative. */
1985 struct type
*tmp_type
= type
;
1986 for (int i
= 0 ; i
< ndimensions
; ++i
)
1988 /* Grab the range for this dimension and extract the lower and upper
1990 tmp_type
= check_typedef (tmp_type
);
1991 struct type
*range_type
= tmp_type
->index_type ();
1992 LONGEST lowerbound
, upperbound
, stride
;
1993 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
1994 error ("failed to get range bounds");
1996 /* Figure out the stride for this dimension. */
1997 struct type
*elt_type
= check_typedef (tmp_type
->target_type ());
1998 stride
= tmp_type
->index_type ()->bounds ()->bit_stride ();
2000 stride
= type_length_units (elt_type
);
2004 = gdbarch_addressable_memory_unit_size (elt_type
->arch ());
2005 stride
/= (unit_size
* 8);
2008 /* If this dimension is "backward" then figure out the offset
2009 adjustment required to point to the element at the lowest memory
2010 address, and add this to the total offset. */
2012 if (stride
< 0 && lowerbound
< upperbound
)
2013 offset
= (upperbound
- lowerbound
) * stride
;
2014 total_offset
+= offset
;
2015 tmp_type
= tmp_type
->target_type ();
2018 /* Adjust the address of this object and return it. */
2019 address
+= total_offset
;