1 /* Fortran language support routines for GDB, the GNU debugger.
3 Copyright (C) 1993-2021 Free Software Foundation, Inc.
5 Contributed by Motorola. Adapted from the C parser by Farooq Butt
6 (fmbutt@engage.sps.mot.com).
8 This file is part of GDB.
10 This program is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 3 of the License, or
13 (at your option) any later version.
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 You should have received a copy of the GNU General Public License
21 along with this program. If not, see <http://www.gnu.org/licenses/>. */
26 #include "expression.h"
27 #include "parser-defs.h"
34 #include "cp-support.h"
37 #include "target-float.h"
40 #include "f-array-walker.h"
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 fprintf_filtered (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 fprintf_filtered (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"));
106 /* A helper function for the "bound" intrinsics that checks that TYPE
107 is an array. LBOUND_P is true for lower bound; this is used for
108 the error message, if any. */
111 fortran_require_array (struct type
*type
, bool lbound_p
)
113 type
= check_typedef (type
);
114 if (type
->code () != TYPE_CODE_ARRAY
)
117 error (_("LBOUND can only be applied to arrays"));
119 error (_("UBOUND can only be applied to arrays"));
123 /* Create an array containing the lower bounds (when LBOUND_P is true) or
124 the upper bounds (when LBOUND_P is false) of ARRAY (which must be of
125 array type). GDBARCH is the current architecture. */
127 static struct value
*
128 fortran_bounds_all_dims (bool lbound_p
,
129 struct gdbarch
*gdbarch
,
132 type
*array_type
= check_typedef (value_type (array
));
133 int ndimensions
= calc_f77_array_dims (array_type
);
135 /* Allocate a result value of the correct type. */
137 = create_static_range_type (nullptr,
138 builtin_type (gdbarch
)->builtin_int
,
140 struct type
*elm_type
= builtin_type (gdbarch
)->builtin_long_long
;
141 struct type
*result_type
= create_array_type (nullptr, elm_type
, range
);
142 struct value
*result
= allocate_value (result_type
);
144 /* Walk the array dimensions backwards due to the way the array will be
145 laid out in memory, the first dimension will be the most inner. */
146 LONGEST elm_len
= TYPE_LENGTH (elm_type
);
147 for (LONGEST dst_offset
= elm_len
* (ndimensions
- 1);
149 dst_offset
-= elm_len
)
153 /* Grab the required bound. */
155 b
= f77_get_lowerbound (array_type
);
157 b
= f77_get_upperbound (array_type
);
159 /* And copy the value into the result value. */
160 struct value
*v
= value_from_longest (elm_type
, b
);
161 gdb_assert (dst_offset
+ TYPE_LENGTH (value_type (v
))
162 <= TYPE_LENGTH (value_type (result
)));
163 gdb_assert (TYPE_LENGTH (value_type (v
)) == elm_len
);
164 value_contents_copy (result
, dst_offset
, v
, 0, elm_len
);
166 /* Peel another dimension of the array. */
167 array_type
= TYPE_TARGET_TYPE (array_type
);
173 /* Return the lower bound (when LBOUND_P is true) or the upper bound (when
174 LBOUND_P is false) for dimension DIM_VAL (which must be an integer) of
175 ARRAY (which must be an array). GDBARCH is the current architecture. */
177 static struct value
*
178 fortran_bounds_for_dimension (bool lbound_p
,
179 struct gdbarch
*gdbarch
,
181 struct value
*dim_val
)
183 /* Check the requested dimension is valid for this array. */
184 type
*array_type
= check_typedef (value_type (array
));
185 int ndimensions
= calc_f77_array_dims (array_type
);
186 long dim
= value_as_long (dim_val
);
187 if (dim
< 1 || dim
> ndimensions
)
190 error (_("LBOUND dimension must be from 1 to %d"), ndimensions
);
192 error (_("UBOUND dimension must be from 1 to %d"), ndimensions
);
195 /* The type for the result. */
196 struct type
*bound_type
= builtin_type (gdbarch
)->builtin_long_long
;
198 /* Walk the dimensions backwards, due to the ordering in which arrays are
199 laid out the first dimension is the most inner. */
200 for (int i
= ndimensions
- 1; i
>= 0; --i
)
202 /* If this is the requested dimension then we're done. Grab the
203 bounds and return. */
209 b
= f77_get_lowerbound (array_type
);
211 b
= f77_get_upperbound (array_type
);
213 return value_from_longest (bound_type
, b
);
216 /* Peel off another dimension of the array. */
217 array_type
= TYPE_TARGET_TYPE (array_type
);
220 gdb_assert_not_reached ("failed to find matching dimension");
224 /* Return the number of dimensions for a Fortran array or string. */
227 calc_f77_array_dims (struct type
*array_type
)
230 struct type
*tmp_type
;
232 if ((array_type
->code () == TYPE_CODE_STRING
))
235 if ((array_type
->code () != TYPE_CODE_ARRAY
))
236 error (_("Can't get dimensions for a non-array type"));
238 tmp_type
= array_type
;
240 while ((tmp_type
= TYPE_TARGET_TYPE (tmp_type
)))
242 if (tmp_type
->code () == TYPE_CODE_ARRAY
)
248 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
249 slices. This is a base class for two alternative repacking mechanisms,
250 one for when repacking from a lazy value, and one for repacking from a
251 non-lazy (already loaded) value. */
252 class fortran_array_repacker_base_impl
253 : public fortran_array_walker_base_impl
256 /* Constructor, DEST is the value we are repacking into. */
257 fortran_array_repacker_base_impl (struct value
*dest
)
262 /* When we start processing the inner most dimension, this is where we
263 will be creating values for each element as we load them and then copy
264 them into the M_DEST value. Set a value mark so we can free these
266 void start_dimension (bool inner_p
)
270 gdb_assert (m_mark
== nullptr);
271 m_mark
= value_mark ();
275 /* When we finish processing the inner most dimension free all temporary
276 value that were created. */
277 void finish_dimension (bool inner_p
, bool last_p
)
281 gdb_assert (m_mark
!= nullptr);
282 value_free_to_mark (m_mark
);
288 /* Copy the contents of array element ELT into M_DEST at the next
290 void copy_element_to_dest (struct value
*elt
)
292 value_contents_copy (m_dest
, m_dest_offset
, elt
, 0,
293 TYPE_LENGTH (value_type (elt
)));
294 m_dest_offset
+= TYPE_LENGTH (value_type (elt
));
297 /* The value being written to. */
298 struct value
*m_dest
;
300 /* The byte offset in M_DEST at which the next element should be
302 LONGEST m_dest_offset
;
304 /* Set with a call to VALUE_MARK, and then reset after calling
305 VALUE_FREE_TO_MARK. */
306 struct value
*m_mark
= nullptr;
309 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
310 slices. This class is specialised for repacking an array slice from a
311 lazy array value, as such it does not require the parent array value to
312 be loaded into GDB's memory; the parent value could be huge, while the
313 slice could be tiny. */
314 class fortran_lazy_array_repacker_impl
315 : public fortran_array_repacker_base_impl
318 /* Constructor. TYPE is the type of the slice being loaded from the
319 parent value, so this type will correctly reflect the strides required
320 to find all of the elements from the parent value. ADDRESS is the
321 address in target memory of value matching TYPE, and DEST is the value
322 we are repacking into. */
323 explicit fortran_lazy_array_repacker_impl (struct type
*type
,
326 : fortran_array_repacker_base_impl (dest
),
330 /* Create a lazy value in target memory representing a single element,
331 then load the element into GDB's memory and copy the contents into the
332 destination value. */
333 void process_element (struct type
*elt_type
, LONGEST elt_off
, bool last_p
)
335 copy_element_to_dest (value_at_lazy (elt_type
, m_addr
+ elt_off
));
339 /* The address in target memory where the parent value starts. */
343 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
344 slices. This class is specialised for repacking an array slice from a
345 previously loaded (non-lazy) array value, as such it fetches the
346 element values from the contents of the parent value. */
347 class fortran_array_repacker_impl
348 : public fortran_array_repacker_base_impl
351 /* Constructor. TYPE is the type for the array slice within the parent
352 value, as such it has stride values as required to find the elements
353 within the original parent value. ADDRESS is the address in target
354 memory of the value matching TYPE. BASE_OFFSET is the offset from
355 the start of VAL's content buffer to the start of the object of TYPE,
356 VAL is the parent object from which we are loading the value, and
357 DEST is the value into which we are repacking. */
358 explicit fortran_array_repacker_impl (struct type
*type
, CORE_ADDR address
,
360 struct value
*val
, struct value
*dest
)
361 : fortran_array_repacker_base_impl (dest
),
362 m_base_offset (base_offset
),
365 gdb_assert (!value_lazy (val
));
368 /* Extract an element of ELT_TYPE at offset (M_BASE_OFFSET + ELT_OFF)
369 from the content buffer of M_VAL then copy this extracted value into
370 the repacked destination value. */
371 void process_element (struct type
*elt_type
, LONGEST elt_off
, bool last_p
)
374 = value_from_component (m_val
, elt_type
, (elt_off
+ m_base_offset
));
375 copy_element_to_dest (elt
);
379 /* The offset into the content buffer of M_VAL to the start of the slice
381 LONGEST m_base_offset
;
383 /* The parent value from which we are extracting a slice. */
388 /* Evaluate FORTRAN_ASSOCIATED expressions. Both GDBARCH and LANG are
389 extracted from the expression being evaluated. POINTER is the required
390 first argument to the 'associated' keyword, and TARGET is the optional
391 second argument, this will be nullptr if the user only passed one
392 argument to their use of 'associated'. */
394 static struct value
*
395 fortran_associated (struct gdbarch
*gdbarch
, const language_defn
*lang
,
396 struct value
*pointer
, struct value
*target
= nullptr)
398 struct type
*result_type
= language_bool_type (lang
, gdbarch
);
400 /* All Fortran pointers should have the associated property, this is
401 how we know the pointer is pointing at something or not. */
402 struct type
*pointer_type
= check_typedef (value_type (pointer
));
403 if (TYPE_ASSOCIATED_PROP (pointer_type
) == nullptr
404 && pointer_type
->code () != TYPE_CODE_PTR
)
405 error (_("ASSOCIATED can only be applied to pointers"));
407 /* Get an address from POINTER. Fortran (or at least gfortran) models
408 array pointers as arrays with a dynamic data address, so we need to
409 use two approaches here, for real pointers we take the contents of the
410 pointer as an address. For non-pointers we take the address of the
412 CORE_ADDR pointer_addr
;
413 if (pointer_type
->code () == TYPE_CODE_PTR
)
414 pointer_addr
= value_as_address (pointer
);
416 pointer_addr
= value_address (pointer
);
418 /* The single argument case, is POINTER associated with anything? */
419 if (target
== nullptr)
421 bool is_associated
= false;
423 /* If POINTER is an actual pointer and doesn't have an associated
424 property then we need to figure out whether this pointer is
425 associated by looking at the value of the pointer itself. We make
426 the assumption that a non-associated pointer will be set to 0.
427 This is probably true for most targets, but might not be true for
429 if (pointer_type
->code () == TYPE_CODE_PTR
430 && TYPE_ASSOCIATED_PROP (pointer_type
) == nullptr)
431 is_associated
= (pointer_addr
!= 0);
433 is_associated
= !type_not_associated (pointer_type
);
434 return value_from_longest (result_type
, is_associated
? 1 : 0);
437 /* The two argument case, is POINTER associated with TARGET? */
439 struct type
*target_type
= check_typedef (value_type (target
));
441 struct type
*pointer_target_type
;
442 if (pointer_type
->code () == TYPE_CODE_PTR
)
443 pointer_target_type
= TYPE_TARGET_TYPE (pointer_type
);
445 pointer_target_type
= pointer_type
;
447 struct type
*target_target_type
;
448 if (target_type
->code () == TYPE_CODE_PTR
)
449 target_target_type
= TYPE_TARGET_TYPE (target_type
);
451 target_target_type
= target_type
;
453 if (pointer_target_type
->code () != target_target_type
->code ()
454 || (pointer_target_type
->code () != TYPE_CODE_ARRAY
455 && (TYPE_LENGTH (pointer_target_type
)
456 != TYPE_LENGTH (target_target_type
))))
457 error (_("arguments to associated must be of same type and kind"));
459 /* If TARGET is not in memory, or the original pointer is specifically
460 known to be not associated with anything, then the answer is obviously
461 false. Alternatively, if POINTER is an actual pointer and has no
462 associated property, then we have to check if its associated by
463 looking the value of the pointer itself. We make the assumption that
464 a non-associated pointer will be set to 0. This is probably true for
465 most targets, but might not be true for everyone. */
466 if (value_lval_const (target
) != lval_memory
467 || type_not_associated (pointer_type
)
468 || (TYPE_ASSOCIATED_PROP (pointer_type
) == nullptr
469 && pointer_type
->code () == TYPE_CODE_PTR
470 && pointer_addr
== 0))
471 return value_from_longest (result_type
, 0);
473 /* See the comment for POINTER_ADDR above. */
474 CORE_ADDR target_addr
;
475 if (target_type
->code () == TYPE_CODE_PTR
)
476 target_addr
= value_as_address (target
);
478 target_addr
= value_address (target
);
480 /* Wrap the following checks inside a do { ... } while (false) loop so
481 that we can use `break' to jump out of the loop. */
482 bool is_associated
= false;
485 /* If the addresses are different then POINTER is definitely not
486 pointing at TARGET. */
487 if (pointer_addr
!= target_addr
)
490 /* If POINTER is a real pointer (i.e. not an array pointer, which are
491 implemented as arrays with a dynamic content address), then this
492 is all the checking that is needed. */
493 if (pointer_type
->code () == TYPE_CODE_PTR
)
495 is_associated
= true;
499 /* We have an array pointer. Check the number of dimensions. */
500 int pointer_dims
= calc_f77_array_dims (pointer_type
);
501 int target_dims
= calc_f77_array_dims (target_type
);
502 if (pointer_dims
!= target_dims
)
505 /* Now check that every dimension has the same upper bound, lower
506 bound, and stride value. */
508 while (dim
< pointer_dims
)
510 LONGEST pointer_lowerbound
, pointer_upperbound
, pointer_stride
;
511 LONGEST target_lowerbound
, target_upperbound
, target_stride
;
513 pointer_type
= check_typedef (pointer_type
);
514 target_type
= check_typedef (target_type
);
516 struct type
*pointer_range
= pointer_type
->index_type ();
517 struct type
*target_range
= target_type
->index_type ();
519 if (!get_discrete_bounds (pointer_range
, &pointer_lowerbound
,
520 &pointer_upperbound
))
523 if (!get_discrete_bounds (target_range
, &target_lowerbound
,
527 if (pointer_lowerbound
!= target_lowerbound
528 || pointer_upperbound
!= target_upperbound
)
531 /* Figure out the stride (in bits) for both pointer and target.
532 If either doesn't have a stride then we take the element size,
533 but we need to convert to bits (hence the * 8). */
534 pointer_stride
= pointer_range
->bounds ()->bit_stride ();
535 if (pointer_stride
== 0)
537 = type_length_units (check_typedef
538 (TYPE_TARGET_TYPE (pointer_type
))) * 8;
539 target_stride
= target_range
->bounds ()->bit_stride ();
540 if (target_stride
== 0)
542 = type_length_units (check_typedef
543 (TYPE_TARGET_TYPE (target_type
))) * 8;
544 if (pointer_stride
!= target_stride
)
550 if (dim
< pointer_dims
)
553 is_associated
= true;
557 return value_from_longest (result_type
, is_associated
? 1 : 0);
561 eval_op_f_associated (struct type
*expect_type
,
562 struct expression
*exp
,
564 enum exp_opcode opcode
,
567 return fortran_associated (exp
->gdbarch
, exp
->language_defn
, arg1
);
571 eval_op_f_associated (struct type
*expect_type
,
572 struct expression
*exp
,
574 enum exp_opcode opcode
,
578 return fortran_associated (exp
->gdbarch
, exp
->language_defn
, arg1
, arg2
);
581 /* A helper function for UNOP_ABS. */
584 eval_op_f_abs (struct type
*expect_type
, struct expression
*exp
,
586 enum exp_opcode opcode
,
589 struct type
*type
= value_type (arg1
);
590 switch (type
->code ())
595 = fabs (target_float_to_host_double (value_contents (arg1
),
597 return value_from_host_double (type
, d
);
601 LONGEST l
= value_as_long (arg1
);
603 return value_from_longest (type
, l
);
606 error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type
));
609 /* A helper function for BINOP_MOD. */
612 eval_op_f_mod (struct type
*expect_type
, struct expression
*exp
,
614 enum exp_opcode opcode
,
615 struct value
*arg1
, struct value
*arg2
)
617 struct type
*type
= value_type (arg1
);
618 if (type
->code () != value_type (arg2
)->code ())
619 error (_("non-matching types for parameters to MOD ()"));
620 switch (type
->code ())
625 = target_float_to_host_double (value_contents (arg1
),
628 = target_float_to_host_double (value_contents (arg2
),
630 double d3
= fmod (d1
, d2
);
631 return value_from_host_double (type
, d3
);
635 LONGEST v1
= value_as_long (arg1
);
636 LONGEST v2
= value_as_long (arg2
);
638 error (_("calling MOD (N, 0) is undefined"));
639 LONGEST v3
= v1
- (v1
/ v2
) * v2
;
640 return value_from_longest (value_type (arg1
), v3
);
643 error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type
));
646 /* A helper function for UNOP_FORTRAN_CEILING. */
649 eval_op_f_ceil (struct type
*expect_type
, struct expression
*exp
,
651 enum exp_opcode opcode
,
654 struct type
*type
= value_type (arg1
);
655 if (type
->code () != TYPE_CODE_FLT
)
656 error (_("argument to CEILING must be of type float"));
658 = target_float_to_host_double (value_contents (arg1
),
661 return value_from_host_double (type
, val
);
664 /* A helper function for UNOP_FORTRAN_FLOOR. */
667 eval_op_f_floor (struct type
*expect_type
, struct expression
*exp
,
669 enum exp_opcode opcode
,
672 struct type
*type
= value_type (arg1
);
673 if (type
->code () != TYPE_CODE_FLT
)
674 error (_("argument to FLOOR must be of type float"));
676 = target_float_to_host_double (value_contents (arg1
),
679 return value_from_host_double (type
, val
);
682 /* A helper function for BINOP_FORTRAN_MODULO. */
685 eval_op_f_modulo (struct type
*expect_type
, struct expression
*exp
,
687 enum exp_opcode opcode
,
688 struct value
*arg1
, struct value
*arg2
)
690 struct type
*type
= value_type (arg1
);
691 if (type
->code () != value_type (arg2
)->code ())
692 error (_("non-matching types for parameters to MODULO ()"));
693 /* MODULO(A, P) = A - FLOOR (A / P) * P */
694 switch (type
->code ())
698 LONGEST a
= value_as_long (arg1
);
699 LONGEST p
= value_as_long (arg2
);
700 LONGEST result
= a
- (a
/ p
) * p
;
701 if (result
!= 0 && (a
< 0) != (p
< 0))
703 return value_from_longest (value_type (arg1
), result
);
708 = target_float_to_host_double (value_contents (arg1
),
711 = target_float_to_host_double (value_contents (arg2
),
713 double result
= fmod (a
, p
);
714 if (result
!= 0 && (a
< 0.0) != (p
< 0.0))
716 return value_from_host_double (type
, result
);
719 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type
));
722 /* A helper function for BINOP_FORTRAN_CMPLX. */
725 eval_op_f_cmplx (struct type
*expect_type
, struct expression
*exp
,
727 enum exp_opcode opcode
,
728 struct value
*arg1
, struct value
*arg2
)
730 struct type
*type
= builtin_f_type(exp
->gdbarch
)->builtin_complex_s16
;
731 return value_literal_complex (arg1
, arg2
, type
);
734 /* A helper function for UNOP_FORTRAN_KIND. */
737 eval_op_f_kind (struct type
*expect_type
, struct expression
*exp
,
739 enum exp_opcode opcode
,
742 struct type
*type
= value_type (arg1
);
744 switch (type
->code ())
746 case TYPE_CODE_STRUCT
:
747 case TYPE_CODE_UNION
:
748 case TYPE_CODE_MODULE
:
750 error (_("argument to kind must be an intrinsic type"));
753 if (!TYPE_TARGET_TYPE (type
))
754 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
756 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
757 TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
760 /* A helper function for UNOP_FORTRAN_ALLOCATED. */
763 eval_op_f_allocated (struct type
*expect_type
, struct expression
*exp
,
764 enum noside noside
, enum exp_opcode op
,
767 struct type
*type
= check_typedef (value_type (arg1
));
768 if (type
->code () != TYPE_CODE_ARRAY
)
769 error (_("ALLOCATED can only be applied to arrays"));
770 struct type
*result_type
771 = builtin_f_type (exp
->gdbarch
)->builtin_logical
;
772 LONGEST result_value
= type_not_allocated (type
) ? 0 : 1;
773 return value_from_longest (result_type
, result_value
);
779 eval_op_f_rank (struct type
*expect_type
,
780 struct expression
*exp
,
785 gdb_assert (op
== UNOP_FORTRAN_RANK
);
787 struct type
*result_type
788 = builtin_f_type (exp
->gdbarch
)->builtin_integer
;
789 struct type
*type
= check_typedef (value_type (arg1
));
790 if (type
->code () != TYPE_CODE_ARRAY
)
791 return value_from_longest (result_type
, 0);
792 LONGEST ndim
= calc_f77_array_dims (type
);
793 return value_from_longest (result_type
, ndim
);
799 /* Called from evaluate to perform array indexing, and sub-range
800 extraction, for Fortran. As well as arrays this function also
801 handles strings as they can be treated like arrays of characters.
802 ARRAY is the array or string being accessed. EXP and NOSIDE are as
806 fortran_undetermined::value_subarray (value
*array
,
807 struct expression
*exp
,
810 type
*original_array_type
= check_typedef (value_type (array
));
811 bool is_string_p
= original_array_type
->code () == TYPE_CODE_STRING
;
812 const std::vector
<operation_up
> &ops
= std::get
<1> (m_storage
);
813 int nargs
= ops
.size ();
815 /* Perform checks for ARRAY not being available. The somewhat overly
816 complex logic here is just to keep backward compatibility with the
817 errors that we used to get before FORTRAN_VALUE_SUBARRAY was
818 rewritten. Maybe a future task would streamline the error messages we
819 get here, and update all the expected test results. */
820 if (ops
[0]->opcode () != OP_RANGE
)
822 if (type_not_associated (original_array_type
))
823 error (_("no such vector element (vector not associated)"));
824 else if (type_not_allocated (original_array_type
))
825 error (_("no such vector element (vector not allocated)"));
829 if (type_not_associated (original_array_type
))
830 error (_("array not associated"));
831 else if (type_not_allocated (original_array_type
))
832 error (_("array not allocated"));
835 /* First check that the number of dimensions in the type we are slicing
836 matches the number of arguments we were passed. */
837 int ndimensions
= calc_f77_array_dims (original_array_type
);
838 if (nargs
!= ndimensions
)
839 error (_("Wrong number of subscripts"));
841 /* This will be initialised below with the type of the elements held in
843 struct type
*inner_element_type
;
845 /* Extract the types of each array dimension from the original array
846 type. We need these available so we can fill in the default upper and
847 lower bounds if the user requested slice doesn't provide that
848 information. Additionally unpacking the dimensions like this gives us
849 the inner element type. */
850 std::vector
<struct type
*> dim_types
;
852 dim_types
.reserve (ndimensions
);
853 struct type
*type
= original_array_type
;
854 for (int i
= 0; i
< ndimensions
; ++i
)
856 dim_types
.push_back (type
);
857 type
= TYPE_TARGET_TYPE (type
);
859 /* TYPE is now the inner element type of the array, we start the new
860 array slice off as this type, then as we process the requested slice
861 (from the user) we wrap new types around this to build up the final
863 inner_element_type
= type
;
866 /* As we analyse the new slice type we need to understand if the data
867 being referenced is contiguous. Do decide this we must track the size
868 of an element at each dimension of the new slice array. Initially the
869 elements of the inner most dimension of the array are the same inner
870 most elements as the original ARRAY. */
871 LONGEST slice_element_size
= TYPE_LENGTH (inner_element_type
);
873 /* Start off assuming all data is contiguous, this will be set to false
874 if access to any dimension results in non-contiguous data. */
875 bool is_all_contiguous
= true;
877 /* The TOTAL_OFFSET is the distance in bytes from the start of the
878 original ARRAY to the start of the new slice. This is calculated as
879 we process the information from the user. */
880 LONGEST total_offset
= 0;
882 /* A structure representing information about each dimension of the
887 slice_dim (LONGEST l
, LONGEST h
, LONGEST s
, struct type
*idx
)
894 /* The low bound for this dimension of the slice. */
897 /* The high bound for this dimension of the slice. */
900 /* The byte stride for this dimension of the slice. */
906 /* The dimensions of the resulting slice. */
907 std::vector
<slice_dim
> slice_dims
;
909 /* Process the incoming arguments. These arguments are in the reverse
910 order to the array dimensions, that is the first argument refers to
911 the last array dimension. */
912 if (fortran_array_slicing_debug
)
913 debug_printf ("Processing array access:\n");
914 for (int i
= 0; i
< nargs
; ++i
)
916 /* For each dimension of the array the user will have either provided
917 a ranged access with optional lower bound, upper bound, and
918 stride, or the user will have supplied a single index. */
919 struct type
*dim_type
= dim_types
[ndimensions
- (i
+ 1)];
920 fortran_range_operation
*range_op
921 = dynamic_cast<fortran_range_operation
*> (ops
[i
].get ());
922 if (range_op
!= nullptr)
924 enum range_flag range_flag
= range_op
->get_flags ();
926 LONGEST low
, high
, stride
;
927 low
= high
= stride
= 0;
929 if ((range_flag
& RANGE_LOW_BOUND_DEFAULT
) == 0)
930 low
= value_as_long (range_op
->evaluate0 (exp
, noside
));
932 low
= f77_get_lowerbound (dim_type
);
933 if ((range_flag
& RANGE_HIGH_BOUND_DEFAULT
) == 0)
934 high
= value_as_long (range_op
->evaluate1 (exp
, noside
));
936 high
= f77_get_upperbound (dim_type
);
937 if ((range_flag
& RANGE_HAS_STRIDE
) == RANGE_HAS_STRIDE
)
938 stride
= value_as_long (range_op
->evaluate2 (exp
, noside
));
943 error (_("stride must not be 0"));
945 /* Get information about this dimension in the original ARRAY. */
946 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
947 struct type
*index_type
= dim_type
->index_type ();
948 LONGEST lb
= f77_get_lowerbound (dim_type
);
949 LONGEST ub
= f77_get_upperbound (dim_type
);
950 LONGEST sd
= index_type
->bit_stride ();
952 sd
= TYPE_LENGTH (target_type
) * 8;
954 if (fortran_array_slicing_debug
)
956 debug_printf ("|-> Range access\n");
957 std::string str
= type_to_string (dim_type
);
958 debug_printf ("| |-> Type: %s\n", str
.c_str ());
959 debug_printf ("| |-> Array:\n");
960 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
961 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
962 debug_printf ("| | |-> Bit stride: %s\n", plongest (sd
));
963 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
/ 8));
964 debug_printf ("| | |-> Type size: %s\n",
965 pulongest (TYPE_LENGTH (dim_type
)));
966 debug_printf ("| | '-> Target type size: %s\n",
967 pulongest (TYPE_LENGTH (target_type
)));
968 debug_printf ("| |-> Accessing:\n");
969 debug_printf ("| | |-> Low bound: %s\n",
971 debug_printf ("| | |-> High bound: %s\n",
973 debug_printf ("| | '-> Element stride: %s\n",
977 /* Check the user hasn't asked for something invalid. */
978 if (high
> ub
|| low
< lb
)
979 error (_("array subscript out of bounds"));
981 /* Calculate what this dimension of the new slice array will look
982 like. OFFSET is the byte offset from the start of the
983 previous (more outer) dimension to the start of this
984 dimension. E_COUNT is the number of elements in this
985 dimension. REMAINDER is the number of elements remaining
986 between the last included element and the upper bound. For
987 example an access '1:6:2' will include elements 1, 3, 5 and
988 have a remainder of 1 (element #6). */
989 LONGEST lowest
= std::min (low
, high
);
990 LONGEST offset
= (sd
/ 8) * (lowest
- lb
);
991 LONGEST e_count
= std::abs (high
- low
) + 1;
992 e_count
= (e_count
+ (std::abs (stride
) - 1)) / std::abs (stride
);
994 LONGEST new_high
= new_low
+ e_count
- 1;
995 LONGEST new_stride
= (sd
* stride
) / 8;
996 LONGEST last_elem
= low
+ ((e_count
- 1) * stride
);
997 LONGEST remainder
= high
- last_elem
;
1000 offset
+= std::abs (remainder
) * TYPE_LENGTH (target_type
);
1002 error (_("incorrect stride and boundary combination"));
1004 else if (stride
< 0)
1005 error (_("incorrect stride and boundary combination"));
1007 /* Is the data within this dimension contiguous? It is if the
1008 newly computed stride is the same size as a single element of
1010 bool is_dim_contiguous
= (new_stride
== slice_element_size
);
1011 is_all_contiguous
&= is_dim_contiguous
;
1013 if (fortran_array_slicing_debug
)
1015 debug_printf ("| '-> Results:\n");
1016 debug_printf ("| |-> Offset = %s\n", plongest (offset
));
1017 debug_printf ("| |-> Elements = %s\n", plongest (e_count
));
1018 debug_printf ("| |-> Low bound = %s\n", plongest (new_low
));
1019 debug_printf ("| |-> High bound = %s\n",
1020 plongest (new_high
));
1021 debug_printf ("| |-> Byte stride = %s\n",
1022 plongest (new_stride
));
1023 debug_printf ("| |-> Last element = %s\n",
1024 plongest (last_elem
));
1025 debug_printf ("| |-> Remainder = %s\n",
1026 plongest (remainder
));
1027 debug_printf ("| '-> Contiguous = %s\n",
1028 (is_dim_contiguous
? "Yes" : "No"));
1031 /* Figure out how big (in bytes) an element of this dimension of
1032 the new array slice will be. */
1033 slice_element_size
= std::abs (new_stride
* e_count
);
1035 slice_dims
.emplace_back (new_low
, new_high
, new_stride
,
1038 /* Update the total offset. */
1039 total_offset
+= offset
;
1043 /* There is a single index for this dimension. */
1045 = value_as_long (ops
[i
]->evaluate_with_coercion (exp
, noside
));
1047 /* Get information about this dimension in the original ARRAY. */
1048 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
1049 struct type
*index_type
= dim_type
->index_type ();
1050 LONGEST lb
= f77_get_lowerbound (dim_type
);
1051 LONGEST ub
= f77_get_upperbound (dim_type
);
1052 LONGEST sd
= index_type
->bit_stride () / 8;
1054 sd
= TYPE_LENGTH (target_type
);
1056 if (fortran_array_slicing_debug
)
1058 debug_printf ("|-> Index access\n");
1059 std::string str
= type_to_string (dim_type
);
1060 debug_printf ("| |-> Type: %s\n", str
.c_str ());
1061 debug_printf ("| |-> Array:\n");
1062 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
1063 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
1064 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
));
1065 debug_printf ("| | |-> Type size: %s\n",
1066 pulongest (TYPE_LENGTH (dim_type
)));
1067 debug_printf ("| | '-> Target type size: %s\n",
1068 pulongest (TYPE_LENGTH (target_type
)));
1069 debug_printf ("| '-> Accessing:\n");
1070 debug_printf ("| '-> Index: %s\n",
1074 /* If the array has actual content then check the index is in
1075 bounds. An array without content (an unbound array) doesn't
1076 have a known upper bound, so don't error check in that
1079 || (dim_type
->index_type ()->bounds ()->high
.kind () != PROP_UNDEFINED
1081 || (VALUE_LVAL (array
) != lval_memory
1082 && dim_type
->index_type ()->bounds ()->high
.kind () == PROP_UNDEFINED
))
1084 if (type_not_associated (dim_type
))
1085 error (_("no such vector element (vector not associated)"));
1086 else if (type_not_allocated (dim_type
))
1087 error (_("no such vector element (vector not allocated)"));
1089 error (_("no such vector element"));
1092 /* Calculate using the type stride, not the target type size. */
1093 LONGEST offset
= sd
* (index
- lb
);
1094 total_offset
+= offset
;
1098 /* Build a type that represents the new array slice in the target memory
1099 of the original ARRAY, this type makes use of strides to correctly
1100 find only those elements that are part of the new slice. */
1101 struct type
*array_slice_type
= inner_element_type
;
1102 for (const auto &d
: slice_dims
)
1104 /* Create the range. */
1105 dynamic_prop p_low
, p_high
, p_stride
;
1107 p_low
.set_const_val (d
.low
);
1108 p_high
.set_const_val (d
.high
);
1109 p_stride
.set_const_val (d
.stride
);
1111 struct type
*new_range
1112 = create_range_type_with_stride ((struct type
*) NULL
,
1113 TYPE_TARGET_TYPE (d
.index
),
1114 &p_low
, &p_high
, 0, &p_stride
,
1117 = create_array_type (nullptr, array_slice_type
, new_range
);
1120 if (fortran_array_slicing_debug
)
1122 debug_printf ("'-> Final result:\n");
1123 debug_printf (" |-> Type: %s\n",
1124 type_to_string (array_slice_type
).c_str ());
1125 debug_printf (" |-> Total offset: %s\n",
1126 plongest (total_offset
));
1127 debug_printf (" |-> Base address: %s\n",
1128 core_addr_to_string (value_address (array
)));
1129 debug_printf (" '-> Contiguous = %s\n",
1130 (is_all_contiguous
? "Yes" : "No"));
1133 /* Should we repack this array slice? */
1134 if (!is_all_contiguous
&& (repack_array_slices
|| is_string_p
))
1136 /* Build a type for the repacked slice. */
1137 struct type
*repacked_array_type
= inner_element_type
;
1138 for (const auto &d
: slice_dims
)
1140 /* Create the range. */
1141 dynamic_prop p_low
, p_high
, p_stride
;
1143 p_low
.set_const_val (d
.low
);
1144 p_high
.set_const_val (d
.high
);
1145 p_stride
.set_const_val (TYPE_LENGTH (repacked_array_type
));
1147 struct type
*new_range
1148 = create_range_type_with_stride ((struct type
*) NULL
,
1149 TYPE_TARGET_TYPE (d
.index
),
1150 &p_low
, &p_high
, 0, &p_stride
,
1153 = create_array_type (nullptr, repacked_array_type
, new_range
);
1156 /* Now copy the elements from the original ARRAY into the packed
1157 array value DEST. */
1158 struct value
*dest
= allocate_value (repacked_array_type
);
1159 if (value_lazy (array
)
1160 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
1161 > TYPE_LENGTH (check_typedef (value_type (array
)))))
1163 fortran_array_walker
<fortran_lazy_array_repacker_impl
> p
1164 (array_slice_type
, value_address (array
) + total_offset
, dest
);
1169 fortran_array_walker
<fortran_array_repacker_impl
> p
1170 (array_slice_type
, value_address (array
) + total_offset
,
1171 total_offset
, array
, dest
);
1178 if (VALUE_LVAL (array
) == lval_memory
)
1180 /* If the value we're taking a slice from is not yet loaded, or
1181 the requested slice is outside the values content range then
1182 just create a new lazy value pointing at the memory where the
1183 contents we're looking for exist. */
1184 if (value_lazy (array
)
1185 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
1186 > TYPE_LENGTH (check_typedef (value_type (array
)))))
1187 array
= value_at_lazy (array_slice_type
,
1188 value_address (array
) + total_offset
);
1190 array
= value_from_contents_and_address (array_slice_type
,
1191 (value_contents (array
)
1193 (value_address (array
)
1196 else if (!value_lazy (array
))
1197 array
= value_from_component (array
, array_slice_type
, total_offset
);
1199 error (_("cannot subscript arrays that are not in memory"));
1206 fortran_undetermined::evaluate (struct type
*expect_type
,
1207 struct expression
*exp
,
1210 value
*callee
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
, noside
);
1211 struct type
*type
= check_typedef (value_type (callee
));
1212 enum type_code code
= type
->code ();
1214 if (code
== TYPE_CODE_PTR
)
1216 /* Fortran always passes variable to subroutines as pointer.
1217 So we need to look into its target type to see if it is
1218 array, string or function. If it is, we need to switch
1219 to the target value the original one points to. */
1220 struct type
*target_type
= check_typedef (TYPE_TARGET_TYPE (type
));
1222 if (target_type
->code () == TYPE_CODE_ARRAY
1223 || target_type
->code () == TYPE_CODE_STRING
1224 || target_type
->code () == TYPE_CODE_FUNC
)
1226 callee
= value_ind (callee
);
1227 type
= check_typedef (value_type (callee
));
1228 code
= type
->code ();
1234 case TYPE_CODE_ARRAY
:
1235 case TYPE_CODE_STRING
:
1236 return value_subarray (callee
, exp
, noside
);
1239 case TYPE_CODE_FUNC
:
1240 case TYPE_CODE_INTERNAL_FUNCTION
:
1242 /* It's a function call. Allocate arg vector, including
1243 space for the function to be called in argvec[0] and a
1244 termination NULL. */
1245 const std::vector
<operation_up
> &actual (std::get
<1> (m_storage
));
1246 std::vector
<value
*> argvec (actual
.size ());
1247 bool is_internal_func
= (code
== TYPE_CODE_INTERNAL_FUNCTION
);
1248 for (int tem
= 0; tem
< argvec
.size (); tem
++)
1249 argvec
[tem
] = fortran_prepare_argument (exp
, actual
[tem
].get (),
1250 tem
, is_internal_func
,
1251 value_type (callee
),
1253 return evaluate_subexp_do_call (exp
, noside
, callee
, argvec
,
1254 nullptr, expect_type
);
1258 error (_("Cannot perform substring on this type"));
1263 fortran_bound_1arg::evaluate (struct type
*expect_type
,
1264 struct expression
*exp
,
1267 bool lbound_p
= std::get
<0> (m_storage
) == FORTRAN_LBOUND
;
1268 value
*arg1
= std::get
<1> (m_storage
)->evaluate (nullptr, exp
, noside
);
1269 fortran_require_array (value_type (arg1
), lbound_p
);
1270 return fortran_bounds_all_dims (lbound_p
, exp
->gdbarch
, arg1
);
1274 fortran_bound_2arg::evaluate (struct type
*expect_type
,
1275 struct expression
*exp
,
1278 bool lbound_p
= std::get
<0> (m_storage
) == FORTRAN_LBOUND
;
1279 value
*arg1
= std::get
<1> (m_storage
)->evaluate (nullptr, exp
, noside
);
1280 fortran_require_array (value_type (arg1
), lbound_p
);
1282 /* User asked for the bounds of a specific dimension of the array. */
1283 value
*arg2
= std::get
<2> (m_storage
)->evaluate (nullptr, exp
, noside
);
1284 struct type
*type
= check_typedef (value_type (arg2
));
1285 if (type
->code () != TYPE_CODE_INT
)
1288 error (_("LBOUND second argument should be an integer"));
1290 error (_("UBOUND second argument should be an integer"));
1293 return fortran_bounds_for_dimension (lbound_p
, exp
->gdbarch
, arg1
, arg2
);
1296 } /* namespace expr */
1298 /* See language.h. */
1301 f_language::language_arch_info (struct gdbarch
*gdbarch
,
1302 struct language_arch_info
*lai
) const
1304 const struct builtin_f_type
*builtin
= builtin_f_type (gdbarch
);
1306 /* Helper function to allow shorter lines below. */
1307 auto add
= [&] (struct type
* t
)
1309 lai
->add_primitive_type (t
);
1312 add (builtin
->builtin_character
);
1313 add (builtin
->builtin_logical
);
1314 add (builtin
->builtin_logical_s1
);
1315 add (builtin
->builtin_logical_s2
);
1316 add (builtin
->builtin_logical_s8
);
1317 add (builtin
->builtin_real
);
1318 add (builtin
->builtin_real_s8
);
1319 add (builtin
->builtin_real_s16
);
1320 add (builtin
->builtin_complex_s8
);
1321 add (builtin
->builtin_complex_s16
);
1322 add (builtin
->builtin_void
);
1324 lai
->set_string_char_type (builtin
->builtin_character
);
1325 lai
->set_bool_type (builtin
->builtin_logical_s2
, "logical");
1328 /* See language.h. */
1331 f_language::search_name_hash (const char *name
) const
1333 return cp_search_name_hash (name
);
1336 /* See language.h. */
1339 f_language::lookup_symbol_nonlocal (const char *name
,
1340 const struct block
*block
,
1341 const domain_enum domain
) const
1343 return cp_lookup_symbol_nonlocal (this, name
, block
, domain
);
1346 /* See language.h. */
1348 symbol_name_matcher_ftype
*
1349 f_language::get_symbol_name_matcher_inner
1350 (const lookup_name_info
&lookup_name
) const
1352 return cp_get_symbol_name_matcher (lookup_name
);
1355 /* Single instance of the Fortran language class. */
1357 static f_language f_language_defn
;
1360 build_fortran_types (struct gdbarch
*gdbarch
)
1362 struct builtin_f_type
*builtin_f_type
1363 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_f_type
);
1365 builtin_f_type
->builtin_void
1366 = arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
, "void");
1368 builtin_f_type
->builtin_character
1369 = arch_type (gdbarch
, TYPE_CODE_CHAR
, TARGET_CHAR_BIT
, "character");
1371 builtin_f_type
->builtin_logical_s1
1372 = arch_boolean_type (gdbarch
, TARGET_CHAR_BIT
, 1, "logical*1");
1374 builtin_f_type
->builtin_integer_s2
1375 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
), 0,
1378 builtin_f_type
->builtin_integer_s8
1379 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 0,
1382 builtin_f_type
->builtin_logical_s2
1383 = arch_boolean_type (gdbarch
, gdbarch_short_bit (gdbarch
), 1,
1386 builtin_f_type
->builtin_logical_s8
1387 = arch_boolean_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 1,
1390 builtin_f_type
->builtin_integer
1391 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 0,
1394 builtin_f_type
->builtin_logical
1395 = arch_boolean_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1,
1398 builtin_f_type
->builtin_real
1399 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
1400 "real", gdbarch_float_format (gdbarch
));
1401 builtin_f_type
->builtin_real_s8
1402 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
1403 "real*8", gdbarch_double_format (gdbarch
));
1404 auto fmt
= gdbarch_floatformat_for_type (gdbarch
, "real(kind=16)", 128);
1406 builtin_f_type
->builtin_real_s16
1407 = arch_float_type (gdbarch
, 128, "real*16", fmt
);
1408 else if (gdbarch_long_double_bit (gdbarch
) == 128)
1409 builtin_f_type
->builtin_real_s16
1410 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
1411 "real*16", gdbarch_long_double_format (gdbarch
));
1413 builtin_f_type
->builtin_real_s16
1414 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 128, "real*16");
1416 builtin_f_type
->builtin_complex_s8
1417 = init_complex_type ("complex*8", builtin_f_type
->builtin_real
);
1418 builtin_f_type
->builtin_complex_s16
1419 = init_complex_type ("complex*16", builtin_f_type
->builtin_real_s8
);
1421 if (builtin_f_type
->builtin_real_s16
->code () == TYPE_CODE_ERROR
)
1422 builtin_f_type
->builtin_complex_s32
1423 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 256, "complex*32");
1425 builtin_f_type
->builtin_complex_s32
1426 = init_complex_type ("complex*32", builtin_f_type
->builtin_real_s16
);
1428 return builtin_f_type
;
1431 static struct gdbarch_data
*f_type_data
;
1433 const struct builtin_f_type
*
1434 builtin_f_type (struct gdbarch
*gdbarch
)
1436 return (const struct builtin_f_type
*) gdbarch_data (gdbarch
, f_type_data
);
1439 /* Command-list for the "set/show fortran" prefix command. */
1440 static struct cmd_list_element
*set_fortran_list
;
1441 static struct cmd_list_element
*show_fortran_list
;
1443 void _initialize_f_language ();
1445 _initialize_f_language ()
1447 f_type_data
= gdbarch_data_register_post_init (build_fortran_types
);
1449 add_basic_prefix_cmd ("fortran", no_class
,
1450 _("Prefix command for changing Fortran-specific settings."),
1451 &set_fortran_list
, "set fortran ", 0, &setlist
);
1453 add_show_prefix_cmd ("fortran", no_class
,
1454 _("Generic command for showing Fortran-specific settings."),
1455 &show_fortran_list
, "show fortran ", 0, &showlist
);
1457 add_setshow_boolean_cmd ("repack-array-slices", class_vars
,
1458 &repack_array_slices
, _("\
1459 Enable or disable repacking of non-contiguous array slices."), _("\
1460 Show whether non-contiguous array slices are repacked."), _("\
1461 When the user requests a slice of a Fortran array then we can either return\n\
1462 a descriptor that describes the array in place (using the original array data\n\
1463 in its existing location) or the original data can be repacked (copied) to a\n\
1466 When the content of the array slice is contiguous within the original array\n\
1467 then the result will never be repacked, but when the data for the new array\n\
1468 is non-contiguous within the original array repacking will only be performed\n\
1469 when this setting is on."),
1471 show_repack_array_slices
,
1472 &set_fortran_list
, &show_fortran_list
);
1474 /* Debug Fortran's array slicing logic. */
1475 add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance
,
1476 &fortran_array_slicing_debug
, _("\
1477 Set debugging of Fortran array slicing."), _("\
1478 Show debugging of Fortran array slicing."), _("\
1479 When on, debugging of Fortran array slicing is enabled."),
1481 show_fortran_array_slicing_debug
,
1482 &setdebuglist
, &showdebuglist
);
1485 /* Ensures that function argument VALUE is in the appropriate form to
1486 pass to a Fortran function. Returns a possibly new value that should
1487 be used instead of VALUE.
1489 When IS_ARTIFICIAL is true this indicates an artificial argument,
1490 e.g. hidden string lengths which the GNU Fortran argument passing
1491 convention specifies as being passed by value.
1493 When IS_ARTIFICIAL is false, the argument is passed by pointer. If the
1494 value is already in target memory then return a value that is a pointer
1495 to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate
1496 space in the target, copy VALUE in, and return a pointer to the in
1499 static struct value
*
1500 fortran_argument_convert (struct value
*value
, bool is_artificial
)
1504 /* If the value is not in the inferior e.g. registers values,
1505 convenience variables and user input. */
1506 if (VALUE_LVAL (value
) != lval_memory
)
1508 struct type
*type
= value_type (value
);
1509 const int length
= TYPE_LENGTH (type
);
1510 const CORE_ADDR addr
1511 = value_as_long (value_allocate_space_in_inferior (length
));
1512 write_memory (addr
, value_contents (value
), length
);
1514 = value_from_contents_and_address (type
, value_contents (value
),
1516 return value_addr (val
);
1519 return value_addr (value
); /* Program variables, e.g. arrays. */
1524 /* Prepare (and return) an argument value ready for an inferior function
1525 call to a Fortran function. EXP and POS are the expressions describing
1526 the argument to prepare. ARG_NUM is the argument number being
1527 prepared, with 0 being the first argument and so on. FUNC_TYPE is the
1528 type of the function being called.
1530 IS_INTERNAL_CALL_P is true if this is a call to a function of type
1531 TYPE_CODE_INTERNAL_FUNCTION, otherwise this parameter is false.
1533 NOSIDE has its usual meaning for expression parsing (see eval.c).
1535 Arguments in Fortran are normally passed by address, we coerce the
1536 arguments here rather than in value_arg_coerce as otherwise the call to
1537 malloc (to place the non-lvalue parameters in target memory) is hit by
1538 this Fortran specific logic. This results in malloc being called with a
1539 pointer to an integer followed by an attempt to malloc the arguments to
1540 malloc in target memory. Infinite recursion ensues. */
1543 fortran_prepare_argument (struct expression
*exp
,
1544 expr::operation
*subexp
,
1545 int arg_num
, bool is_internal_call_p
,
1546 struct type
*func_type
, enum noside noside
)
1548 if (is_internal_call_p
)
1549 return subexp
->evaluate_with_coercion (exp
, noside
);
1551 bool is_artificial
= ((arg_num
>= func_type
->num_fields ())
1553 : TYPE_FIELD_ARTIFICIAL (func_type
, arg_num
));
1555 /* If this is an artificial argument, then either, this is an argument
1556 beyond the end of the known arguments, or possibly, there are no known
1557 arguments (maybe missing debug info).
1559 For these artificial arguments, if the user has prefixed it with '&'
1560 (for address-of), then lets always allow this to succeed, even if the
1561 argument is not actually in inferior memory. This will allow the user
1562 to pass arguments to a Fortran function even when there's no debug
1565 As we already pass the address of non-artificial arguments, all we
1566 need to do if skip the UNOP_ADDR operator in the expression and mark
1567 the argument as non-artificial. */
1570 expr::unop_addr_operation
*addrop
1571 = dynamic_cast<expr::unop_addr_operation
*> (subexp
);
1572 if (addrop
!= nullptr)
1574 subexp
= addrop
->get_expression ().get ();
1575 is_artificial
= false;
1579 struct value
*arg_val
= subexp
->evaluate_with_coercion (exp
, noside
);
1580 return fortran_argument_convert (arg_val
, is_artificial
);
1586 fortran_preserve_arg_pointer (struct value
*arg
, struct type
*type
)
1588 if (value_type (arg
)->code () == TYPE_CODE_PTR
)
1589 return value_type (arg
);
1596 fortran_adjust_dynamic_array_base_address_hack (struct type
*type
,
1599 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
1601 /* We can't adjust the base address for arrays that have no content. */
1602 if (type_not_allocated (type
) || type_not_associated (type
))
1605 int ndimensions
= calc_f77_array_dims (type
);
1606 LONGEST total_offset
= 0;
1608 /* Walk through each of the dimensions of this array type and figure out
1609 if any of the dimensions are "backwards", that is the base address
1610 for this dimension points to the element at the highest memory
1611 address and the stride is negative. */
1612 struct type
*tmp_type
= type
;
1613 for (int i
= 0 ; i
< ndimensions
; ++i
)
1615 /* Grab the range for this dimension and extract the lower and upper
1617 tmp_type
= check_typedef (tmp_type
);
1618 struct type
*range_type
= tmp_type
->index_type ();
1619 LONGEST lowerbound
, upperbound
, stride
;
1620 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
1621 error ("failed to get range bounds");
1623 /* Figure out the stride for this dimension. */
1624 struct type
*elt_type
= check_typedef (TYPE_TARGET_TYPE (tmp_type
));
1625 stride
= tmp_type
->index_type ()->bounds ()->bit_stride ();
1627 stride
= type_length_units (elt_type
);
1631 = gdbarch_addressable_memory_unit_size (elt_type
->arch ());
1632 stride
/= (unit_size
* 8);
1635 /* If this dimension is "backward" then figure out the offset
1636 adjustment required to point to the element at the lowest memory
1637 address, and add this to the total offset. */
1639 if (stride
< 0 && lowerbound
< upperbound
)
1640 offset
= (upperbound
- lowerbound
) * stride
;
1641 total_offset
+= offset
;
1642 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
1645 /* Adjust the address of this object and return it. */
1646 address
+= total_offset
;