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 /* Implement FORTRAN_ARRAY_SIZE expression, this corresponds to the 'SIZE'
582 keyword. Both GDBARCH and LANG are extracted from the expression being
583 evaluated. ARRAY is the value that should be an array, though this will
584 not have been checked before calling this function. DIM is optional, if
585 present then it should be an integer identifying a dimension of the
586 array to ask about. As with ARRAY the validity of DIM is not checked
587 before calling this function.
589 Return either the total number of elements in ARRAY (when DIM is
590 nullptr), or the number of elements in dimension DIM. */
592 static struct value
*
593 fortran_array_size (struct gdbarch
*gdbarch
, const language_defn
*lang
,
594 struct value
*array
, struct value
*dim_val
= nullptr)
596 /* Check that ARRAY is the correct type. */
597 struct type
*array_type
= check_typedef (value_type (array
));
598 if (array_type
->code () != TYPE_CODE_ARRAY
)
599 error (_("SIZE can only be applied to arrays"));
600 if (type_not_allocated (array_type
) || type_not_associated (array_type
))
601 error (_("SIZE can only be used on allocated/associated arrays"));
603 int ndimensions
= calc_f77_array_dims (array_type
);
607 if (dim_val
!= nullptr)
609 if (check_typedef (value_type (dim_val
))->code () != TYPE_CODE_INT
)
610 error (_("DIM argument to SIZE must be an integer"));
611 dim
= (int) value_as_long (dim_val
);
613 if (dim
< 1 || dim
> ndimensions
)
614 error (_("DIM argument to SIZE must be between 1 and %d"),
618 /* Now walk over all the dimensions of the array totalling up the
619 elements in each dimension. */
620 for (int i
= ndimensions
- 1; i
>= 0; --i
)
622 /* If this is the requested dimension then we're done. Grab the
623 bounds and return. */
624 if (i
== dim
- 1 || dim
== -1)
626 LONGEST lbound
, ubound
;
627 struct type
*range
= array_type
->index_type ();
629 if (!get_discrete_bounds (range
, &lbound
, &ubound
))
630 error (_("failed to find array bounds"));
632 LONGEST dim_size
= (ubound
- lbound
+ 1);
642 /* Peel off another dimension of the array. */
643 array_type
= TYPE_TARGET_TYPE (array_type
);
646 struct type
*result_type
647 = builtin_f_type (gdbarch
)->builtin_integer
;
648 return value_from_longest (result_type
, result
);
654 eval_op_f_array_size (struct type
*expect_type
,
655 struct expression
*exp
,
657 enum exp_opcode opcode
,
660 gdb_assert (opcode
== FORTRAN_ARRAY_SIZE
);
661 return fortran_array_size (exp
->gdbarch
, exp
->language_defn
, arg1
);
667 eval_op_f_array_size (struct type
*expect_type
,
668 struct expression
*exp
,
670 enum exp_opcode opcode
,
674 gdb_assert (opcode
== FORTRAN_ARRAY_SIZE
);
675 return fortran_array_size (exp
->gdbarch
, exp
->language_defn
, arg1
, arg2
);
678 /* A helper function for UNOP_ABS. */
681 eval_op_f_abs (struct type
*expect_type
, struct expression
*exp
,
683 enum exp_opcode opcode
,
686 struct type
*type
= value_type (arg1
);
687 switch (type
->code ())
692 = fabs (target_float_to_host_double (value_contents (arg1
),
694 return value_from_host_double (type
, d
);
698 LONGEST l
= value_as_long (arg1
);
700 return value_from_longest (type
, l
);
703 error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type
));
706 /* A helper function for BINOP_MOD. */
709 eval_op_f_mod (struct type
*expect_type
, struct expression
*exp
,
711 enum exp_opcode opcode
,
712 struct value
*arg1
, struct value
*arg2
)
714 struct type
*type
= value_type (arg1
);
715 if (type
->code () != value_type (arg2
)->code ())
716 error (_("non-matching types for parameters to MOD ()"));
717 switch (type
->code ())
722 = target_float_to_host_double (value_contents (arg1
),
725 = target_float_to_host_double (value_contents (arg2
),
727 double d3
= fmod (d1
, d2
);
728 return value_from_host_double (type
, d3
);
732 LONGEST v1
= value_as_long (arg1
);
733 LONGEST v2
= value_as_long (arg2
);
735 error (_("calling MOD (N, 0) is undefined"));
736 LONGEST v3
= v1
- (v1
/ v2
) * v2
;
737 return value_from_longest (value_type (arg1
), v3
);
740 error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type
));
743 /* A helper function for UNOP_FORTRAN_CEILING. */
746 eval_op_f_ceil (struct type
*expect_type
, struct expression
*exp
,
748 enum exp_opcode opcode
,
751 struct type
*type
= value_type (arg1
);
752 if (type
->code () != TYPE_CODE_FLT
)
753 error (_("argument to CEILING must be of type float"));
755 = target_float_to_host_double (value_contents (arg1
),
758 return value_from_host_double (type
, val
);
761 /* A helper function for UNOP_FORTRAN_FLOOR. */
764 eval_op_f_floor (struct type
*expect_type
, struct expression
*exp
,
766 enum exp_opcode opcode
,
769 struct type
*type
= value_type (arg1
);
770 if (type
->code () != TYPE_CODE_FLT
)
771 error (_("argument to FLOOR must be of type float"));
773 = target_float_to_host_double (value_contents (arg1
),
776 return value_from_host_double (type
, val
);
779 /* A helper function for BINOP_FORTRAN_MODULO. */
782 eval_op_f_modulo (struct type
*expect_type
, struct expression
*exp
,
784 enum exp_opcode opcode
,
785 struct value
*arg1
, struct value
*arg2
)
787 struct type
*type
= value_type (arg1
);
788 if (type
->code () != value_type (arg2
)->code ())
789 error (_("non-matching types for parameters to MODULO ()"));
790 /* MODULO(A, P) = A - FLOOR (A / P) * P */
791 switch (type
->code ())
795 LONGEST a
= value_as_long (arg1
);
796 LONGEST p
= value_as_long (arg2
);
797 LONGEST result
= a
- (a
/ p
) * p
;
798 if (result
!= 0 && (a
< 0) != (p
< 0))
800 return value_from_longest (value_type (arg1
), result
);
805 = target_float_to_host_double (value_contents (arg1
),
808 = target_float_to_host_double (value_contents (arg2
),
810 double result
= fmod (a
, p
);
811 if (result
!= 0 && (a
< 0.0) != (p
< 0.0))
813 return value_from_host_double (type
, result
);
816 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type
));
819 /* A helper function for BINOP_FORTRAN_CMPLX. */
822 eval_op_f_cmplx (struct type
*expect_type
, struct expression
*exp
,
824 enum exp_opcode opcode
,
825 struct value
*arg1
, struct value
*arg2
)
827 struct type
*type
= builtin_f_type(exp
->gdbarch
)->builtin_complex_s16
;
828 return value_literal_complex (arg1
, arg2
, type
);
831 /* A helper function for UNOP_FORTRAN_KIND. */
834 eval_op_f_kind (struct type
*expect_type
, struct expression
*exp
,
836 enum exp_opcode opcode
,
839 struct type
*type
= value_type (arg1
);
841 switch (type
->code ())
843 case TYPE_CODE_STRUCT
:
844 case TYPE_CODE_UNION
:
845 case TYPE_CODE_MODULE
:
847 error (_("argument to kind must be an intrinsic type"));
850 if (!TYPE_TARGET_TYPE (type
))
851 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
853 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
854 TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
857 /* A helper function for UNOP_FORTRAN_ALLOCATED. */
860 eval_op_f_allocated (struct type
*expect_type
, struct expression
*exp
,
861 enum noside noside
, enum exp_opcode op
,
864 struct type
*type
= check_typedef (value_type (arg1
));
865 if (type
->code () != TYPE_CODE_ARRAY
)
866 error (_("ALLOCATED can only be applied to arrays"));
867 struct type
*result_type
868 = builtin_f_type (exp
->gdbarch
)->builtin_logical
;
869 LONGEST result_value
= type_not_allocated (type
) ? 0 : 1;
870 return value_from_longest (result_type
, result_value
);
876 eval_op_f_rank (struct type
*expect_type
,
877 struct expression
*exp
,
882 gdb_assert (op
== UNOP_FORTRAN_RANK
);
884 struct type
*result_type
885 = builtin_f_type (exp
->gdbarch
)->builtin_integer
;
886 struct type
*type
= check_typedef (value_type (arg1
));
887 if (type
->code () != TYPE_CODE_ARRAY
)
888 return value_from_longest (result_type
, 0);
889 LONGEST ndim
= calc_f77_array_dims (type
);
890 return value_from_longest (result_type
, ndim
);
896 /* Called from evaluate to perform array indexing, and sub-range
897 extraction, for Fortran. As well as arrays this function also
898 handles strings as they can be treated like arrays of characters.
899 ARRAY is the array or string being accessed. EXP and NOSIDE are as
903 fortran_undetermined::value_subarray (value
*array
,
904 struct expression
*exp
,
907 type
*original_array_type
= check_typedef (value_type (array
));
908 bool is_string_p
= original_array_type
->code () == TYPE_CODE_STRING
;
909 const std::vector
<operation_up
> &ops
= std::get
<1> (m_storage
);
910 int nargs
= ops
.size ();
912 /* Perform checks for ARRAY not being available. The somewhat overly
913 complex logic here is just to keep backward compatibility with the
914 errors that we used to get before FORTRAN_VALUE_SUBARRAY was
915 rewritten. Maybe a future task would streamline the error messages we
916 get here, and update all the expected test results. */
917 if (ops
[0]->opcode () != OP_RANGE
)
919 if (type_not_associated (original_array_type
))
920 error (_("no such vector element (vector not associated)"));
921 else if (type_not_allocated (original_array_type
))
922 error (_("no such vector element (vector not allocated)"));
926 if (type_not_associated (original_array_type
))
927 error (_("array not associated"));
928 else if (type_not_allocated (original_array_type
))
929 error (_("array not allocated"));
932 /* First check that the number of dimensions in the type we are slicing
933 matches the number of arguments we were passed. */
934 int ndimensions
= calc_f77_array_dims (original_array_type
);
935 if (nargs
!= ndimensions
)
936 error (_("Wrong number of subscripts"));
938 /* This will be initialised below with the type of the elements held in
940 struct type
*inner_element_type
;
942 /* Extract the types of each array dimension from the original array
943 type. We need these available so we can fill in the default upper and
944 lower bounds if the user requested slice doesn't provide that
945 information. Additionally unpacking the dimensions like this gives us
946 the inner element type. */
947 std::vector
<struct type
*> dim_types
;
949 dim_types
.reserve (ndimensions
);
950 struct type
*type
= original_array_type
;
951 for (int i
= 0; i
< ndimensions
; ++i
)
953 dim_types
.push_back (type
);
954 type
= TYPE_TARGET_TYPE (type
);
956 /* TYPE is now the inner element type of the array, we start the new
957 array slice off as this type, then as we process the requested slice
958 (from the user) we wrap new types around this to build up the final
960 inner_element_type
= type
;
963 /* As we analyse the new slice type we need to understand if the data
964 being referenced is contiguous. Do decide this we must track the size
965 of an element at each dimension of the new slice array. Initially the
966 elements of the inner most dimension of the array are the same inner
967 most elements as the original ARRAY. */
968 LONGEST slice_element_size
= TYPE_LENGTH (inner_element_type
);
970 /* Start off assuming all data is contiguous, this will be set to false
971 if access to any dimension results in non-contiguous data. */
972 bool is_all_contiguous
= true;
974 /* The TOTAL_OFFSET is the distance in bytes from the start of the
975 original ARRAY to the start of the new slice. This is calculated as
976 we process the information from the user. */
977 LONGEST total_offset
= 0;
979 /* A structure representing information about each dimension of the
984 slice_dim (LONGEST l
, LONGEST h
, LONGEST s
, struct type
*idx
)
991 /* The low bound for this dimension of the slice. */
994 /* The high bound for this dimension of the slice. */
997 /* The byte stride for this dimension of the slice. */
1003 /* The dimensions of the resulting slice. */
1004 std::vector
<slice_dim
> slice_dims
;
1006 /* Process the incoming arguments. These arguments are in the reverse
1007 order to the array dimensions, that is the first argument refers to
1008 the last array dimension. */
1009 if (fortran_array_slicing_debug
)
1010 debug_printf ("Processing array access:\n");
1011 for (int i
= 0; i
< nargs
; ++i
)
1013 /* For each dimension of the array the user will have either provided
1014 a ranged access with optional lower bound, upper bound, and
1015 stride, or the user will have supplied a single index. */
1016 struct type
*dim_type
= dim_types
[ndimensions
- (i
+ 1)];
1017 fortran_range_operation
*range_op
1018 = dynamic_cast<fortran_range_operation
*> (ops
[i
].get ());
1019 if (range_op
!= nullptr)
1021 enum range_flag range_flag
= range_op
->get_flags ();
1023 LONGEST low
, high
, stride
;
1024 low
= high
= stride
= 0;
1026 if ((range_flag
& RANGE_LOW_BOUND_DEFAULT
) == 0)
1027 low
= value_as_long (range_op
->evaluate0 (exp
, noside
));
1029 low
= f77_get_lowerbound (dim_type
);
1030 if ((range_flag
& RANGE_HIGH_BOUND_DEFAULT
) == 0)
1031 high
= value_as_long (range_op
->evaluate1 (exp
, noside
));
1033 high
= f77_get_upperbound (dim_type
);
1034 if ((range_flag
& RANGE_HAS_STRIDE
) == RANGE_HAS_STRIDE
)
1035 stride
= value_as_long (range_op
->evaluate2 (exp
, noside
));
1040 error (_("stride must not be 0"));
1042 /* Get information about this dimension in the original ARRAY. */
1043 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
1044 struct type
*index_type
= dim_type
->index_type ();
1045 LONGEST lb
= f77_get_lowerbound (dim_type
);
1046 LONGEST ub
= f77_get_upperbound (dim_type
);
1047 LONGEST sd
= index_type
->bit_stride ();
1049 sd
= TYPE_LENGTH (target_type
) * 8;
1051 if (fortran_array_slicing_debug
)
1053 debug_printf ("|-> Range access\n");
1054 std::string str
= type_to_string (dim_type
);
1055 debug_printf ("| |-> Type: %s\n", str
.c_str ());
1056 debug_printf ("| |-> Array:\n");
1057 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
1058 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
1059 debug_printf ("| | |-> Bit stride: %s\n", plongest (sd
));
1060 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
/ 8));
1061 debug_printf ("| | |-> Type size: %s\n",
1062 pulongest (TYPE_LENGTH (dim_type
)));
1063 debug_printf ("| | '-> Target type size: %s\n",
1064 pulongest (TYPE_LENGTH (target_type
)));
1065 debug_printf ("| |-> Accessing:\n");
1066 debug_printf ("| | |-> Low bound: %s\n",
1068 debug_printf ("| | |-> High bound: %s\n",
1070 debug_printf ("| | '-> Element stride: %s\n",
1074 /* Check the user hasn't asked for something invalid. */
1075 if (high
> ub
|| low
< lb
)
1076 error (_("array subscript out of bounds"));
1078 /* Calculate what this dimension of the new slice array will look
1079 like. OFFSET is the byte offset from the start of the
1080 previous (more outer) dimension to the start of this
1081 dimension. E_COUNT is the number of elements in this
1082 dimension. REMAINDER is the number of elements remaining
1083 between the last included element and the upper bound. For
1084 example an access '1:6:2' will include elements 1, 3, 5 and
1085 have a remainder of 1 (element #6). */
1086 LONGEST lowest
= std::min (low
, high
);
1087 LONGEST offset
= (sd
/ 8) * (lowest
- lb
);
1088 LONGEST e_count
= std::abs (high
- low
) + 1;
1089 e_count
= (e_count
+ (std::abs (stride
) - 1)) / std::abs (stride
);
1090 LONGEST new_low
= 1;
1091 LONGEST new_high
= new_low
+ e_count
- 1;
1092 LONGEST new_stride
= (sd
* stride
) / 8;
1093 LONGEST last_elem
= low
+ ((e_count
- 1) * stride
);
1094 LONGEST remainder
= high
- last_elem
;
1097 offset
+= std::abs (remainder
) * TYPE_LENGTH (target_type
);
1099 error (_("incorrect stride and boundary combination"));
1101 else if (stride
< 0)
1102 error (_("incorrect stride and boundary combination"));
1104 /* Is the data within this dimension contiguous? It is if the
1105 newly computed stride is the same size as a single element of
1107 bool is_dim_contiguous
= (new_stride
== slice_element_size
);
1108 is_all_contiguous
&= is_dim_contiguous
;
1110 if (fortran_array_slicing_debug
)
1112 debug_printf ("| '-> Results:\n");
1113 debug_printf ("| |-> Offset = %s\n", plongest (offset
));
1114 debug_printf ("| |-> Elements = %s\n", plongest (e_count
));
1115 debug_printf ("| |-> Low bound = %s\n", plongest (new_low
));
1116 debug_printf ("| |-> High bound = %s\n",
1117 plongest (new_high
));
1118 debug_printf ("| |-> Byte stride = %s\n",
1119 plongest (new_stride
));
1120 debug_printf ("| |-> Last element = %s\n",
1121 plongest (last_elem
));
1122 debug_printf ("| |-> Remainder = %s\n",
1123 plongest (remainder
));
1124 debug_printf ("| '-> Contiguous = %s\n",
1125 (is_dim_contiguous
? "Yes" : "No"));
1128 /* Figure out how big (in bytes) an element of this dimension of
1129 the new array slice will be. */
1130 slice_element_size
= std::abs (new_stride
* e_count
);
1132 slice_dims
.emplace_back (new_low
, new_high
, new_stride
,
1135 /* Update the total offset. */
1136 total_offset
+= offset
;
1140 /* There is a single index for this dimension. */
1142 = value_as_long (ops
[i
]->evaluate_with_coercion (exp
, noside
));
1144 /* Get information about this dimension in the original ARRAY. */
1145 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
1146 struct type
*index_type
= dim_type
->index_type ();
1147 LONGEST lb
= f77_get_lowerbound (dim_type
);
1148 LONGEST ub
= f77_get_upperbound (dim_type
);
1149 LONGEST sd
= index_type
->bit_stride () / 8;
1151 sd
= TYPE_LENGTH (target_type
);
1153 if (fortran_array_slicing_debug
)
1155 debug_printf ("|-> Index access\n");
1156 std::string str
= type_to_string (dim_type
);
1157 debug_printf ("| |-> Type: %s\n", str
.c_str ());
1158 debug_printf ("| |-> Array:\n");
1159 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
1160 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
1161 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
));
1162 debug_printf ("| | |-> Type size: %s\n",
1163 pulongest (TYPE_LENGTH (dim_type
)));
1164 debug_printf ("| | '-> Target type size: %s\n",
1165 pulongest (TYPE_LENGTH (target_type
)));
1166 debug_printf ("| '-> Accessing:\n");
1167 debug_printf ("| '-> Index: %s\n",
1171 /* If the array has actual content then check the index is in
1172 bounds. An array without content (an unbound array) doesn't
1173 have a known upper bound, so don't error check in that
1176 || (dim_type
->index_type ()->bounds ()->high
.kind () != PROP_UNDEFINED
1178 || (VALUE_LVAL (array
) != lval_memory
1179 && dim_type
->index_type ()->bounds ()->high
.kind () == PROP_UNDEFINED
))
1181 if (type_not_associated (dim_type
))
1182 error (_("no such vector element (vector not associated)"));
1183 else if (type_not_allocated (dim_type
))
1184 error (_("no such vector element (vector not allocated)"));
1186 error (_("no such vector element"));
1189 /* Calculate using the type stride, not the target type size. */
1190 LONGEST offset
= sd
* (index
- lb
);
1191 total_offset
+= offset
;
1195 /* Build a type that represents the new array slice in the target memory
1196 of the original ARRAY, this type makes use of strides to correctly
1197 find only those elements that are part of the new slice. */
1198 struct type
*array_slice_type
= inner_element_type
;
1199 for (const auto &d
: slice_dims
)
1201 /* Create the range. */
1202 dynamic_prop p_low
, p_high
, p_stride
;
1204 p_low
.set_const_val (d
.low
);
1205 p_high
.set_const_val (d
.high
);
1206 p_stride
.set_const_val (d
.stride
);
1208 struct type
*new_range
1209 = create_range_type_with_stride ((struct type
*) NULL
,
1210 TYPE_TARGET_TYPE (d
.index
),
1211 &p_low
, &p_high
, 0, &p_stride
,
1214 = create_array_type (nullptr, array_slice_type
, new_range
);
1217 if (fortran_array_slicing_debug
)
1219 debug_printf ("'-> Final result:\n");
1220 debug_printf (" |-> Type: %s\n",
1221 type_to_string (array_slice_type
).c_str ());
1222 debug_printf (" |-> Total offset: %s\n",
1223 plongest (total_offset
));
1224 debug_printf (" |-> Base address: %s\n",
1225 core_addr_to_string (value_address (array
)));
1226 debug_printf (" '-> Contiguous = %s\n",
1227 (is_all_contiguous
? "Yes" : "No"));
1230 /* Should we repack this array slice? */
1231 if (!is_all_contiguous
&& (repack_array_slices
|| is_string_p
))
1233 /* Build a type for the repacked slice. */
1234 struct type
*repacked_array_type
= inner_element_type
;
1235 for (const auto &d
: slice_dims
)
1237 /* Create the range. */
1238 dynamic_prop p_low
, p_high
, p_stride
;
1240 p_low
.set_const_val (d
.low
);
1241 p_high
.set_const_val (d
.high
);
1242 p_stride
.set_const_val (TYPE_LENGTH (repacked_array_type
));
1244 struct type
*new_range
1245 = create_range_type_with_stride ((struct type
*) NULL
,
1246 TYPE_TARGET_TYPE (d
.index
),
1247 &p_low
, &p_high
, 0, &p_stride
,
1250 = create_array_type (nullptr, repacked_array_type
, new_range
);
1253 /* Now copy the elements from the original ARRAY into the packed
1254 array value DEST. */
1255 struct value
*dest
= allocate_value (repacked_array_type
);
1256 if (value_lazy (array
)
1257 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
1258 > TYPE_LENGTH (check_typedef (value_type (array
)))))
1260 fortran_array_walker
<fortran_lazy_array_repacker_impl
> p
1261 (array_slice_type
, value_address (array
) + total_offset
, dest
);
1266 fortran_array_walker
<fortran_array_repacker_impl
> p
1267 (array_slice_type
, value_address (array
) + total_offset
,
1268 total_offset
, array
, dest
);
1275 if (VALUE_LVAL (array
) == lval_memory
)
1277 /* If the value we're taking a slice from is not yet loaded, or
1278 the requested slice is outside the values content range then
1279 just create a new lazy value pointing at the memory where the
1280 contents we're looking for exist. */
1281 if (value_lazy (array
)
1282 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
1283 > TYPE_LENGTH (check_typedef (value_type (array
)))))
1284 array
= value_at_lazy (array_slice_type
,
1285 value_address (array
) + total_offset
);
1287 array
= value_from_contents_and_address (array_slice_type
,
1288 (value_contents (array
)
1290 (value_address (array
)
1293 else if (!value_lazy (array
))
1294 array
= value_from_component (array
, array_slice_type
, total_offset
);
1296 error (_("cannot subscript arrays that are not in memory"));
1303 fortran_undetermined::evaluate (struct type
*expect_type
,
1304 struct expression
*exp
,
1307 value
*callee
= std::get
<0> (m_storage
)->evaluate (nullptr, exp
, noside
);
1308 struct type
*type
= check_typedef (value_type (callee
));
1309 enum type_code code
= type
->code ();
1311 if (code
== TYPE_CODE_PTR
)
1313 /* Fortran always passes variable to subroutines as pointer.
1314 So we need to look into its target type to see if it is
1315 array, string or function. If it is, we need to switch
1316 to the target value the original one points to. */
1317 struct type
*target_type
= check_typedef (TYPE_TARGET_TYPE (type
));
1319 if (target_type
->code () == TYPE_CODE_ARRAY
1320 || target_type
->code () == TYPE_CODE_STRING
1321 || target_type
->code () == TYPE_CODE_FUNC
)
1323 callee
= value_ind (callee
);
1324 type
= check_typedef (value_type (callee
));
1325 code
= type
->code ();
1331 case TYPE_CODE_ARRAY
:
1332 case TYPE_CODE_STRING
:
1333 return value_subarray (callee
, exp
, noside
);
1336 case TYPE_CODE_FUNC
:
1337 case TYPE_CODE_INTERNAL_FUNCTION
:
1339 /* It's a function call. Allocate arg vector, including
1340 space for the function to be called in argvec[0] and a
1341 termination NULL. */
1342 const std::vector
<operation_up
> &actual (std::get
<1> (m_storage
));
1343 std::vector
<value
*> argvec (actual
.size ());
1344 bool is_internal_func
= (code
== TYPE_CODE_INTERNAL_FUNCTION
);
1345 for (int tem
= 0; tem
< argvec
.size (); tem
++)
1346 argvec
[tem
] = fortran_prepare_argument (exp
, actual
[tem
].get (),
1347 tem
, is_internal_func
,
1348 value_type (callee
),
1350 return evaluate_subexp_do_call (exp
, noside
, callee
, argvec
,
1351 nullptr, expect_type
);
1355 error (_("Cannot perform substring on this type"));
1360 fortran_bound_1arg::evaluate (struct type
*expect_type
,
1361 struct expression
*exp
,
1364 bool lbound_p
= std::get
<0> (m_storage
) == FORTRAN_LBOUND
;
1365 value
*arg1
= std::get
<1> (m_storage
)->evaluate (nullptr, exp
, noside
);
1366 fortran_require_array (value_type (arg1
), lbound_p
);
1367 return fortran_bounds_all_dims (lbound_p
, exp
->gdbarch
, arg1
);
1371 fortran_bound_2arg::evaluate (struct type
*expect_type
,
1372 struct expression
*exp
,
1375 bool lbound_p
= std::get
<0> (m_storage
) == FORTRAN_LBOUND
;
1376 value
*arg1
= std::get
<1> (m_storage
)->evaluate (nullptr, exp
, noside
);
1377 fortran_require_array (value_type (arg1
), lbound_p
);
1379 /* User asked for the bounds of a specific dimension of the array. */
1380 value
*arg2
= std::get
<2> (m_storage
)->evaluate (nullptr, exp
, noside
);
1381 struct type
*type
= check_typedef (value_type (arg2
));
1382 if (type
->code () != TYPE_CODE_INT
)
1385 error (_("LBOUND second argument should be an integer"));
1387 error (_("UBOUND second argument should be an integer"));
1390 return fortran_bounds_for_dimension (lbound_p
, exp
->gdbarch
, arg1
, arg2
);
1393 } /* namespace expr */
1395 /* See language.h. */
1398 f_language::language_arch_info (struct gdbarch
*gdbarch
,
1399 struct language_arch_info
*lai
) const
1401 const struct builtin_f_type
*builtin
= builtin_f_type (gdbarch
);
1403 /* Helper function to allow shorter lines below. */
1404 auto add
= [&] (struct type
* t
)
1406 lai
->add_primitive_type (t
);
1409 add (builtin
->builtin_character
);
1410 add (builtin
->builtin_logical
);
1411 add (builtin
->builtin_logical_s1
);
1412 add (builtin
->builtin_logical_s2
);
1413 add (builtin
->builtin_logical_s8
);
1414 add (builtin
->builtin_real
);
1415 add (builtin
->builtin_real_s8
);
1416 add (builtin
->builtin_real_s16
);
1417 add (builtin
->builtin_complex_s8
);
1418 add (builtin
->builtin_complex_s16
);
1419 add (builtin
->builtin_void
);
1421 lai
->set_string_char_type (builtin
->builtin_character
);
1422 lai
->set_bool_type (builtin
->builtin_logical_s2
, "logical");
1425 /* See language.h. */
1428 f_language::search_name_hash (const char *name
) const
1430 return cp_search_name_hash (name
);
1433 /* See language.h. */
1436 f_language::lookup_symbol_nonlocal (const char *name
,
1437 const struct block
*block
,
1438 const domain_enum domain
) const
1440 return cp_lookup_symbol_nonlocal (this, name
, block
, domain
);
1443 /* See language.h. */
1445 symbol_name_matcher_ftype
*
1446 f_language::get_symbol_name_matcher_inner
1447 (const lookup_name_info
&lookup_name
) const
1449 return cp_get_symbol_name_matcher (lookup_name
);
1452 /* Single instance of the Fortran language class. */
1454 static f_language f_language_defn
;
1457 build_fortran_types (struct gdbarch
*gdbarch
)
1459 struct builtin_f_type
*builtin_f_type
1460 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_f_type
);
1462 builtin_f_type
->builtin_void
1463 = arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
, "void");
1465 builtin_f_type
->builtin_character
1466 = arch_type (gdbarch
, TYPE_CODE_CHAR
, TARGET_CHAR_BIT
, "character");
1468 builtin_f_type
->builtin_logical_s1
1469 = arch_boolean_type (gdbarch
, TARGET_CHAR_BIT
, 1, "logical*1");
1471 builtin_f_type
->builtin_integer_s2
1472 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
), 0,
1475 builtin_f_type
->builtin_integer_s8
1476 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 0,
1479 builtin_f_type
->builtin_logical_s2
1480 = arch_boolean_type (gdbarch
, gdbarch_short_bit (gdbarch
), 1,
1483 builtin_f_type
->builtin_logical_s8
1484 = arch_boolean_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 1,
1487 builtin_f_type
->builtin_integer
1488 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 0,
1491 builtin_f_type
->builtin_logical
1492 = arch_boolean_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1,
1495 builtin_f_type
->builtin_real
1496 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
1497 "real", gdbarch_float_format (gdbarch
));
1498 builtin_f_type
->builtin_real_s8
1499 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
1500 "real*8", gdbarch_double_format (gdbarch
));
1501 auto fmt
= gdbarch_floatformat_for_type (gdbarch
, "real(kind=16)", 128);
1503 builtin_f_type
->builtin_real_s16
1504 = arch_float_type (gdbarch
, 128, "real*16", fmt
);
1505 else if (gdbarch_long_double_bit (gdbarch
) == 128)
1506 builtin_f_type
->builtin_real_s16
1507 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
1508 "real*16", gdbarch_long_double_format (gdbarch
));
1510 builtin_f_type
->builtin_real_s16
1511 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 128, "real*16");
1513 builtin_f_type
->builtin_complex_s8
1514 = init_complex_type ("complex*8", builtin_f_type
->builtin_real
);
1515 builtin_f_type
->builtin_complex_s16
1516 = init_complex_type ("complex*16", builtin_f_type
->builtin_real_s8
);
1518 if (builtin_f_type
->builtin_real_s16
->code () == TYPE_CODE_ERROR
)
1519 builtin_f_type
->builtin_complex_s32
1520 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 256, "complex*32");
1522 builtin_f_type
->builtin_complex_s32
1523 = init_complex_type ("complex*32", builtin_f_type
->builtin_real_s16
);
1525 return builtin_f_type
;
1528 static struct gdbarch_data
*f_type_data
;
1530 const struct builtin_f_type
*
1531 builtin_f_type (struct gdbarch
*gdbarch
)
1533 return (const struct builtin_f_type
*) gdbarch_data (gdbarch
, f_type_data
);
1536 /* Command-list for the "set/show fortran" prefix command. */
1537 static struct cmd_list_element
*set_fortran_list
;
1538 static struct cmd_list_element
*show_fortran_list
;
1540 void _initialize_f_language ();
1542 _initialize_f_language ()
1544 f_type_data
= gdbarch_data_register_post_init (build_fortran_types
);
1546 add_basic_prefix_cmd ("fortran", no_class
,
1547 _("Prefix command for changing Fortran-specific settings."),
1548 &set_fortran_list
, "set fortran ", 0, &setlist
);
1550 add_show_prefix_cmd ("fortran", no_class
,
1551 _("Generic command for showing Fortran-specific settings."),
1552 &show_fortran_list
, "show fortran ", 0, &showlist
);
1554 add_setshow_boolean_cmd ("repack-array-slices", class_vars
,
1555 &repack_array_slices
, _("\
1556 Enable or disable repacking of non-contiguous array slices."), _("\
1557 Show whether non-contiguous array slices are repacked."), _("\
1558 When the user requests a slice of a Fortran array then we can either return\n\
1559 a descriptor that describes the array in place (using the original array data\n\
1560 in its existing location) or the original data can be repacked (copied) to a\n\
1563 When the content of the array slice is contiguous within the original array\n\
1564 then the result will never be repacked, but when the data for the new array\n\
1565 is non-contiguous within the original array repacking will only be performed\n\
1566 when this setting is on."),
1568 show_repack_array_slices
,
1569 &set_fortran_list
, &show_fortran_list
);
1571 /* Debug Fortran's array slicing logic. */
1572 add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance
,
1573 &fortran_array_slicing_debug
, _("\
1574 Set debugging of Fortran array slicing."), _("\
1575 Show debugging of Fortran array slicing."), _("\
1576 When on, debugging of Fortran array slicing is enabled."),
1578 show_fortran_array_slicing_debug
,
1579 &setdebuglist
, &showdebuglist
);
1582 /* Ensures that function argument VALUE is in the appropriate form to
1583 pass to a Fortran function. Returns a possibly new value that should
1584 be used instead of VALUE.
1586 When IS_ARTIFICIAL is true this indicates an artificial argument,
1587 e.g. hidden string lengths which the GNU Fortran argument passing
1588 convention specifies as being passed by value.
1590 When IS_ARTIFICIAL is false, the argument is passed by pointer. If the
1591 value is already in target memory then return a value that is a pointer
1592 to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate
1593 space in the target, copy VALUE in, and return a pointer to the in
1596 static struct value
*
1597 fortran_argument_convert (struct value
*value
, bool is_artificial
)
1601 /* If the value is not in the inferior e.g. registers values,
1602 convenience variables and user input. */
1603 if (VALUE_LVAL (value
) != lval_memory
)
1605 struct type
*type
= value_type (value
);
1606 const int length
= TYPE_LENGTH (type
);
1607 const CORE_ADDR addr
1608 = value_as_long (value_allocate_space_in_inferior (length
));
1609 write_memory (addr
, value_contents (value
), length
);
1611 = value_from_contents_and_address (type
, value_contents (value
),
1613 return value_addr (val
);
1616 return value_addr (value
); /* Program variables, e.g. arrays. */
1621 /* Prepare (and return) an argument value ready for an inferior function
1622 call to a Fortran function. EXP and POS are the expressions describing
1623 the argument to prepare. ARG_NUM is the argument number being
1624 prepared, with 0 being the first argument and so on. FUNC_TYPE is the
1625 type of the function being called.
1627 IS_INTERNAL_CALL_P is true if this is a call to a function of type
1628 TYPE_CODE_INTERNAL_FUNCTION, otherwise this parameter is false.
1630 NOSIDE has its usual meaning for expression parsing (see eval.c).
1632 Arguments in Fortran are normally passed by address, we coerce the
1633 arguments here rather than in value_arg_coerce as otherwise the call to
1634 malloc (to place the non-lvalue parameters in target memory) is hit by
1635 this Fortran specific logic. This results in malloc being called with a
1636 pointer to an integer followed by an attempt to malloc the arguments to
1637 malloc in target memory. Infinite recursion ensues. */
1640 fortran_prepare_argument (struct expression
*exp
,
1641 expr::operation
*subexp
,
1642 int arg_num
, bool is_internal_call_p
,
1643 struct type
*func_type
, enum noside noside
)
1645 if (is_internal_call_p
)
1646 return subexp
->evaluate_with_coercion (exp
, noside
);
1648 bool is_artificial
= ((arg_num
>= func_type
->num_fields ())
1650 : TYPE_FIELD_ARTIFICIAL (func_type
, arg_num
));
1652 /* If this is an artificial argument, then either, this is an argument
1653 beyond the end of the known arguments, or possibly, there are no known
1654 arguments (maybe missing debug info).
1656 For these artificial arguments, if the user has prefixed it with '&'
1657 (for address-of), then lets always allow this to succeed, even if the
1658 argument is not actually in inferior memory. This will allow the user
1659 to pass arguments to a Fortran function even when there's no debug
1662 As we already pass the address of non-artificial arguments, all we
1663 need to do if skip the UNOP_ADDR operator in the expression and mark
1664 the argument as non-artificial. */
1667 expr::unop_addr_operation
*addrop
1668 = dynamic_cast<expr::unop_addr_operation
*> (subexp
);
1669 if (addrop
!= nullptr)
1671 subexp
= addrop
->get_expression ().get ();
1672 is_artificial
= false;
1676 struct value
*arg_val
= subexp
->evaluate_with_coercion (exp
, noside
);
1677 return fortran_argument_convert (arg_val
, is_artificial
);
1683 fortran_preserve_arg_pointer (struct value
*arg
, struct type
*type
)
1685 if (value_type (arg
)->code () == TYPE_CODE_PTR
)
1686 return value_type (arg
);
1693 fortran_adjust_dynamic_array_base_address_hack (struct type
*type
,
1696 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
1698 /* We can't adjust the base address for arrays that have no content. */
1699 if (type_not_allocated (type
) || type_not_associated (type
))
1702 int ndimensions
= calc_f77_array_dims (type
);
1703 LONGEST total_offset
= 0;
1705 /* Walk through each of the dimensions of this array type and figure out
1706 if any of the dimensions are "backwards", that is the base address
1707 for this dimension points to the element at the highest memory
1708 address and the stride is negative. */
1709 struct type
*tmp_type
= type
;
1710 for (int i
= 0 ; i
< ndimensions
; ++i
)
1712 /* Grab the range for this dimension and extract the lower and upper
1714 tmp_type
= check_typedef (tmp_type
);
1715 struct type
*range_type
= tmp_type
->index_type ();
1716 LONGEST lowerbound
, upperbound
, stride
;
1717 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
1718 error ("failed to get range bounds");
1720 /* Figure out the stride for this dimension. */
1721 struct type
*elt_type
= check_typedef (TYPE_TARGET_TYPE (tmp_type
));
1722 stride
= tmp_type
->index_type ()->bounds ()->bit_stride ();
1724 stride
= type_length_units (elt_type
);
1728 = gdbarch_addressable_memory_unit_size (elt_type
->arch ());
1729 stride
/= (unit_size
* 8);
1732 /* If this dimension is "backward" then figure out the offset
1733 adjustment required to point to the element at the lowest memory
1734 address, and add this to the total offset. */
1736 if (stride
< 0 && lowerbound
< upperbound
)
1737 offset
= (upperbound
- lowerbound
) * stride
;
1738 total_offset
+= offset
;
1739 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
1742 /* Adjust the address of this object and return it. */
1743 address
+= total_offset
;