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
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 if (noside == EVAL_SKIP)
590 return eval_skip_value (exp);
591 struct type *type = value_type (arg1);
592 switch (type->code ())
597 = fabs (target_float_to_host_double (value_contents (arg1),
599 return value_from_host_double (type, d);
603 LONGEST l = value_as_long (arg1);
605 return value_from_longest (type, l);
608 error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type));
611 /* A helper function for BINOP_MOD. */
614 eval_op_f_mod (struct type *expect_type, struct expression *exp,
616 enum exp_opcode opcode,
617 struct value *arg1, struct value *arg2)
619 if (noside == EVAL_SKIP)
620 return eval_skip_value (exp);
621 struct type *type = value_type (arg1);
622 if (type->code () != value_type (arg2)->code ())
623 error (_("non-matching types for parameters to MOD ()"));
624 switch (type->code ())
629 = target_float_to_host_double (value_contents (arg1),
632 = target_float_to_host_double (value_contents (arg2),
634 double d3 = fmod (d1, d2);
635 return value_from_host_double (type, d3);
639 LONGEST v1 = value_as_long (arg1);
640 LONGEST v2 = value_as_long (arg2);
642 error (_("calling MOD (N, 0) is undefined"));
643 LONGEST v3 = v1 - (v1 / v2) * v2;
644 return value_from_longest (value_type (arg1), v3);
647 error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type));
650 /* A helper function for UNOP_FORTRAN_CEILING. */
653 eval_op_f_ceil (struct type *expect_type, struct expression *exp,
655 enum exp_opcode opcode,
658 if (noside == EVAL_SKIP)
659 return eval_skip_value (exp);
660 struct type *type = value_type (arg1);
661 if (type->code () != TYPE_CODE_FLT)
662 error (_("argument to CEILING must be of type float"));
664 = target_float_to_host_double (value_contents (arg1),
667 return value_from_host_double (type, val);
670 /* A helper function for UNOP_FORTRAN_FLOOR. */
673 eval_op_f_floor (struct type *expect_type, struct expression *exp,
675 enum exp_opcode opcode,
678 if (noside == EVAL_SKIP)
679 return eval_skip_value (exp);
680 struct type *type = value_type (arg1);
681 if (type->code () != TYPE_CODE_FLT)
682 error (_("argument to FLOOR must be of type float"));
684 = target_float_to_host_double (value_contents (arg1),
687 return value_from_host_double (type, val);
690 /* A helper function for BINOP_FORTRAN_MODULO. */
693 eval_op_f_modulo (struct type *expect_type, struct expression *exp,
695 enum exp_opcode opcode,
696 struct value *arg1, struct value *arg2)
698 if (noside == EVAL_SKIP)
699 return eval_skip_value (exp);
700 struct type *type = value_type (arg1);
701 if (type->code () != value_type (arg2)->code ())
702 error (_("non-matching types for parameters to MODULO ()"));
703 /* MODULO(A, P) = A - FLOOR (A / P) * P */
704 switch (type->code ())
708 LONGEST a = value_as_long (arg1);
709 LONGEST p = value_as_long (arg2);
710 LONGEST result = a - (a / p) * p;
711 if (result != 0 && (a < 0) != (p < 0))
713 return value_from_longest (value_type (arg1), result);
718 = target_float_to_host_double (value_contents (arg1),
721 = target_float_to_host_double (value_contents (arg2),
723 double result = fmod (a, p);
724 if (result != 0 && (a < 0.0) != (p < 0.0))
726 return value_from_host_double (type, result);
729 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type));
732 /* A helper function for BINOP_FORTRAN_CMPLX. */
735 eval_op_f_cmplx (struct type *expect_type, struct expression *exp,
737 enum exp_opcode opcode,
738 struct value *arg1, struct value *arg2)
740 if (noside == EVAL_SKIP)
741 return eval_skip_value (exp);
742 struct type *type = builtin_f_type(exp->gdbarch)->builtin_complex_s16;
743 return value_literal_complex (arg1, arg2, type);
746 /* A helper function for UNOP_FORTRAN_KIND. */
749 eval_op_f_kind (struct type *expect_type, struct expression *exp,
751 enum exp_opcode opcode,
754 struct type *type = value_type (arg1);
756 switch (type->code ())
758 case TYPE_CODE_STRUCT:
759 case TYPE_CODE_UNION:
760 case TYPE_CODE_MODULE:
762 error (_("argument to kind must be an intrinsic type"));
765 if (!TYPE_TARGET_TYPE (type))
766 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
768 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
769 TYPE_LENGTH (TYPE_TARGET_TYPE (type)));
772 /* A helper function for UNOP_FORTRAN_ALLOCATED. */
775 eval_op_f_allocated (struct type *expect_type, struct expression *exp,
776 enum noside noside, enum exp_opcode op,
779 struct type *type = check_typedef (value_type (arg1));
780 if (type->code () != TYPE_CODE_ARRAY)
781 error (_("ALLOCATED can only be applied to arrays"));
782 struct type *result_type
783 = builtin_f_type (exp->gdbarch)->builtin_logical;
784 LONGEST result_value = type_not_allocated (type) ? 0 : 1;
785 return value_from_longest (result_type, result_value);
791 /* Called from evaluate to perform array indexing, and sub-range
792 extraction, for Fortran. As well as arrays this function also
793 handles strings as they can be treated like arrays of characters.
794 ARRAY is the array or string being accessed. EXP and NOSIDE are as
798 fortran_undetermined::value_subarray (value *array,
799 struct expression *exp,
802 type *original_array_type = check_typedef (value_type (array));
803 bool is_string_p = original_array_type->code () == TYPE_CODE_STRING;
804 const std::vector<operation_up> &ops = std::get<1> (m_storage);
805 int nargs = ops.size ();
807 /* Perform checks for ARRAY not being available. The somewhat overly
808 complex logic here is just to keep backward compatibility with the
809 errors that we used to get before FORTRAN_VALUE_SUBARRAY was
810 rewritten. Maybe a future task would streamline the error messages we
811 get here, and update all the expected test results. */
812 if (ops[0]->opcode () != OP_RANGE)
814 if (type_not_associated (original_array_type))
815 error (_("no such vector element (vector not associated)"));
816 else if (type_not_allocated (original_array_type))
817 error (_("no such vector element (vector not allocated)"));
821 if (type_not_associated (original_array_type))
822 error (_("array not associated"));
823 else if (type_not_allocated (original_array_type))
824 error (_("array not allocated"));
827 /* First check that the number of dimensions in the type we are slicing
828 matches the number of arguments we were passed. */
829 int ndimensions = calc_f77_array_dims (original_array_type);
830 if (nargs != ndimensions)
831 error (_("Wrong number of subscripts"));
833 /* This will be initialised below with the type of the elements held in
835 struct type *inner_element_type;
837 /* Extract the types of each array dimension from the original array
838 type. We need these available so we can fill in the default upper and
839 lower bounds if the user requested slice doesn't provide that
840 information. Additionally unpacking the dimensions like this gives us
841 the inner element type. */
842 std::vector<struct type *> dim_types;
844 dim_types.reserve (ndimensions);
845 struct type *type = original_array_type;
846 for (int i = 0; i < ndimensions; ++i)
848 dim_types.push_back (type);
849 type = TYPE_TARGET_TYPE (type);
851 /* TYPE is now the inner element type of the array, we start the new
852 array slice off as this type, then as we process the requested slice
853 (from the user) we wrap new types around this to build up the final
855 inner_element_type = type;
858 /* As we analyse the new slice type we need to understand if the data
859 being referenced is contiguous. Do decide this we must track the size
860 of an element at each dimension of the new slice array. Initially the
861 elements of the inner most dimension of the array are the same inner
862 most elements as the original ARRAY. */
863 LONGEST slice_element_size = TYPE_LENGTH (inner_element_type);
865 /* Start off assuming all data is contiguous, this will be set to false
866 if access to any dimension results in non-contiguous data. */
867 bool is_all_contiguous = true;
869 /* The TOTAL_OFFSET is the distance in bytes from the start of the
870 original ARRAY to the start of the new slice. This is calculated as
871 we process the information from the user. */
872 LONGEST total_offset = 0;
874 /* A structure representing information about each dimension of the
879 slice_dim (LONGEST l, LONGEST h, LONGEST s, struct type *idx)
886 /* The low bound for this dimension of the slice. */
889 /* The high bound for this dimension of the slice. */
892 /* The byte stride for this dimension of the slice. */
898 /* The dimensions of the resulting slice. */
899 std::vector<slice_dim> slice_dims;
901 /* Process the incoming arguments. These arguments are in the reverse
902 order to the array dimensions, that is the first argument refers to
903 the last array dimension. */
904 if (fortran_array_slicing_debug)
905 debug_printf ("Processing array access:\n");
906 for (int i = 0; i < nargs; ++i)
908 /* For each dimension of the array the user will have either provided
909 a ranged access with optional lower bound, upper bound, and
910 stride, or the user will have supplied a single index. */
911 struct type *dim_type = dim_types[ndimensions - (i + 1)];
912 fortran_range_operation *range_op
913 = dynamic_cast<fortran_range_operation *> (ops[i].get ());
914 if (range_op != nullptr)
916 enum range_flag range_flag = range_op->get_flags ();
918 LONGEST low, high, stride;
919 low = high = stride = 0;
921 if ((range_flag & RANGE_LOW_BOUND_DEFAULT) == 0)
922 low = value_as_long (range_op->evaluate0 (exp, noside));
924 low = f77_get_lowerbound (dim_type);
925 if ((range_flag & RANGE_HIGH_BOUND_DEFAULT) == 0)
926 high = value_as_long (range_op->evaluate1 (exp, noside));
928 high = f77_get_upperbound (dim_type);
929 if ((range_flag & RANGE_HAS_STRIDE) == RANGE_HAS_STRIDE)
930 stride = value_as_long (range_op->evaluate2 (exp, noside));
935 error (_("stride must not be 0"));
937 /* Get information about this dimension in the original ARRAY. */
938 struct type *target_type = TYPE_TARGET_TYPE (dim_type);
939 struct type *index_type = dim_type->index_type ();
940 LONGEST lb = f77_get_lowerbound (dim_type);
941 LONGEST ub = f77_get_upperbound (dim_type);
942 LONGEST sd = index_type->bit_stride ();
944 sd = TYPE_LENGTH (target_type) * 8;
946 if (fortran_array_slicing_debug)
948 debug_printf ("|-> Range access\n");
949 std::string str = type_to_string (dim_type);
950 debug_printf ("| |-> Type: %s\n", str.c_str ());
951 debug_printf ("| |-> Array:\n");
952 debug_printf ("| | |-> Low bound: %s\n", plongest (lb));
953 debug_printf ("| | |-> High bound: %s\n", plongest (ub));
954 debug_printf ("| | |-> Bit stride: %s\n", plongest (sd));
955 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd / 8));
956 debug_printf ("| | |-> Type size: %s\n",
957 pulongest (TYPE_LENGTH (dim_type)));
958 debug_printf ("| | '-> Target type size: %s\n",
959 pulongest (TYPE_LENGTH (target_type)));
960 debug_printf ("| |-> Accessing:\n");
961 debug_printf ("| | |-> Low bound: %s\n",
963 debug_printf ("| | |-> High bound: %s\n",
965 debug_printf ("| | '-> Element stride: %s\n",
969 /* Check the user hasn't asked for something invalid. */
970 if (high > ub || low < lb)
971 error (_("array subscript out of bounds"));
973 /* Calculate what this dimension of the new slice array will look
974 like. OFFSET is the byte offset from the start of the
975 previous (more outer) dimension to the start of this
976 dimension. E_COUNT is the number of elements in this
977 dimension. REMAINDER is the number of elements remaining
978 between the last included element and the upper bound. For
979 example an access '1:6:2' will include elements 1, 3, 5 and
980 have a remainder of 1 (element #6). */
981 LONGEST lowest = std::min (low, high);
982 LONGEST offset = (sd / 8) * (lowest - lb);
983 LONGEST e_count = std::abs (high - low) + 1;
984 e_count = (e_count + (std::abs (stride) - 1)) / std::abs (stride);
986 LONGEST new_high = new_low + e_count - 1;
987 LONGEST new_stride = (sd * stride) / 8;
988 LONGEST last_elem = low + ((e_count - 1) * stride);
989 LONGEST remainder = high - last_elem;
992 offset += std::abs (remainder) * TYPE_LENGTH (target_type);
994 error (_("incorrect stride and boundary combination"));
997 error (_("incorrect stride and boundary combination"));
999 /* Is the data within this dimension contiguous? It is if the
1000 newly computed stride is the same size as a single element of
1002 bool is_dim_contiguous = (new_stride == slice_element_size);
1003 is_all_contiguous &= is_dim_contiguous;
1005 if (fortran_array_slicing_debug)
1007 debug_printf ("| '-> Results:\n");
1008 debug_printf ("| |-> Offset = %s\n", plongest (offset));
1009 debug_printf ("| |-> Elements = %s\n", plongest (e_count));
1010 debug_printf ("| |-> Low bound = %s\n", plongest (new_low));
1011 debug_printf ("| |-> High bound = %s\n",
1012 plongest (new_high));
1013 debug_printf ("| |-> Byte stride = %s\n",
1014 plongest (new_stride));
1015 debug_printf ("| |-> Last element = %s\n",
1016 plongest (last_elem));
1017 debug_printf ("| |-> Remainder = %s\n",
1018 plongest (remainder));
1019 debug_printf ("| '-> Contiguous = %s\n",
1020 (is_dim_contiguous ? "Yes" : "No"));
1023 /* Figure out how big (in bytes) an element of this dimension of
1024 the new array slice will be. */
1025 slice_element_size = std::abs (new_stride * e_count);
1027 slice_dims.emplace_back (new_low, new_high, new_stride,
1030 /* Update the total offset. */
1031 total_offset += offset;
1035 /* There is a single index for this dimension. */
1037 = value_as_long (ops[i]->evaluate_with_coercion (exp, noside));
1039 /* Get information about this dimension in the original ARRAY. */
1040 struct type *target_type = TYPE_TARGET_TYPE (dim_type);
1041 struct type *index_type = dim_type->index_type ();
1042 LONGEST lb = f77_get_lowerbound (dim_type);
1043 LONGEST ub = f77_get_upperbound (dim_type);
1044 LONGEST sd = index_type->bit_stride () / 8;
1046 sd = TYPE_LENGTH (target_type);
1048 if (fortran_array_slicing_debug)
1050 debug_printf ("|-> Index access\n");
1051 std::string str = type_to_string (dim_type);
1052 debug_printf ("| |-> Type: %s\n", str.c_str ());
1053 debug_printf ("| |-> Array:\n");
1054 debug_printf ("| | |-> Low bound: %s\n", plongest (lb));
1055 debug_printf ("| | |-> High bound: %s\n", plongest (ub));
1056 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd));
1057 debug_printf ("| | |-> Type size: %s\n",
1058 pulongest (TYPE_LENGTH (dim_type)));
1059 debug_printf ("| | '-> Target type size: %s\n",
1060 pulongest (TYPE_LENGTH (target_type)));
1061 debug_printf ("| '-> Accessing:\n");
1062 debug_printf ("| '-> Index: %s\n",
1066 /* If the array has actual content then check the index is in
1067 bounds. An array without content (an unbound array) doesn't
1068 have a known upper bound, so don't error check in that
1071 || (dim_type->index_type ()->bounds ()->high.kind () != PROP_UNDEFINED
1073 || (VALUE_LVAL (array) != lval_memory
1074 && dim_type->index_type ()->bounds ()->high.kind () == PROP_UNDEFINED))
1076 if (type_not_associated (dim_type))
1077 error (_("no such vector element (vector not associated)"));
1078 else if (type_not_allocated (dim_type))
1079 error (_("no such vector element (vector not allocated)"));
1081 error (_("no such vector element"));
1084 /* Calculate using the type stride, not the target type size. */
1085 LONGEST offset = sd * (index - lb);
1086 total_offset += offset;
1090 /* Build a type that represents the new array slice in the target memory
1091 of the original ARRAY, this type makes use of strides to correctly
1092 find only those elements that are part of the new slice. */
1093 struct type *array_slice_type = inner_element_type;
1094 for (const auto &d : slice_dims)
1096 /* Create the range. */
1097 dynamic_prop p_low, p_high, p_stride;
1099 p_low.set_const_val (d.low);
1100 p_high.set_const_val (d.high);
1101 p_stride.set_const_val (d.stride);
1103 struct type *new_range
1104 = create_range_type_with_stride ((struct type *) NULL,
1105 TYPE_TARGET_TYPE (d.index),
1106 &p_low, &p_high, 0, &p_stride,
1109 = create_array_type (nullptr, array_slice_type, new_range);
1112 if (fortran_array_slicing_debug)
1114 debug_printf ("'-> Final result:\n");
1115 debug_printf (" |-> Type: %s\n",
1116 type_to_string (array_slice_type).c_str ());
1117 debug_printf (" |-> Total offset: %s\n",
1118 plongest (total_offset));
1119 debug_printf (" |-> Base address: %s\n",
1120 core_addr_to_string (value_address (array)));
1121 debug_printf (" '-> Contiguous = %s\n",
1122 (is_all_contiguous ? "Yes" : "No"));
1125 /* Should we repack this array slice? */
1126 if (!is_all_contiguous && (repack_array_slices || is_string_p))
1128 /* Build a type for the repacked slice. */
1129 struct type *repacked_array_type = inner_element_type;
1130 for (const auto &d : slice_dims)
1132 /* Create the range. */
1133 dynamic_prop p_low, p_high, p_stride;
1135 p_low.set_const_val (d.low);
1136 p_high.set_const_val (d.high);
1137 p_stride.set_const_val (TYPE_LENGTH (repacked_array_type));
1139 struct type *new_range
1140 = create_range_type_with_stride ((struct type *) NULL,
1141 TYPE_TARGET_TYPE (d.index),
1142 &p_low, &p_high, 0, &p_stride,
1145 = create_array_type (nullptr, repacked_array_type, new_range);
1148 /* Now copy the elements from the original ARRAY into the packed
1149 array value DEST. */
1150 struct value *dest = allocate_value (repacked_array_type);
1151 if (value_lazy (array)
1152 || (total_offset + TYPE_LENGTH (array_slice_type)
1153 > TYPE_LENGTH (check_typedef (value_type (array)))))
1155 fortran_array_walker<fortran_lazy_array_repacker_impl> p
1156 (array_slice_type, value_address (array) + total_offset, dest);
1161 fortran_array_walker<fortran_array_repacker_impl> p
1162 (array_slice_type, value_address (array) + total_offset,
1163 total_offset, array, dest);
1170 if (VALUE_LVAL (array) == lval_memory)
1172 /* If the value we're taking a slice from is not yet loaded, or
1173 the requested slice is outside the values content range then
1174 just create a new lazy value pointing at the memory where the
1175 contents we're looking for exist. */
1176 if (value_lazy (array)
1177 || (total_offset + TYPE_LENGTH (array_slice_type)
1178 > TYPE_LENGTH (check_typedef (value_type (array)))))
1179 array = value_at_lazy (array_slice_type,
1180 value_address (array) + total_offset);
1182 array = value_from_contents_and_address (array_slice_type,
1183 (value_contents (array)
1185 (value_address (array)
1188 else if (!value_lazy (array))
1189 array = value_from_component (array, array_slice_type, total_offset);
1191 error (_("cannot subscript arrays that are not in memory"));
1198 fortran_undetermined::evaluate (struct type *expect_type,
1199 struct expression *exp,
1202 value *callee = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
1203 struct type *type = check_typedef (value_type (callee));
1204 enum type_code code = type->code ();
1206 if (code == TYPE_CODE_PTR)
1208 /* Fortran always passes variable to subroutines as pointer.
1209 So we need to look into its target type to see if it is
1210 array, string or function. If it is, we need to switch
1211 to the target value the original one points to. */
1212 struct type *target_type = check_typedef (TYPE_TARGET_TYPE (type));
1214 if (target_type->code () == TYPE_CODE_ARRAY
1215 || target_type->code () == TYPE_CODE_STRING
1216 || target_type->code () == TYPE_CODE_FUNC)
1218 callee = value_ind (callee);
1219 type = check_typedef (value_type (callee));
1220 code = type->code ();
1226 case TYPE_CODE_ARRAY:
1227 case TYPE_CODE_STRING:
1228 return value_subarray (callee, exp, noside);
1231 case TYPE_CODE_FUNC:
1232 case TYPE_CODE_INTERNAL_FUNCTION:
1234 /* It's a function call. Allocate arg vector, including
1235 space for the function to be called in argvec[0] and a
1236 termination NULL. */
1237 const std::vector<operation_up> &actual (std::get<1> (m_storage));
1238 std::vector<value *> argvec (actual.size ());
1239 bool is_internal_func = (code == TYPE_CODE_INTERNAL_FUNCTION);
1240 for (int tem = 0; tem < argvec.size (); tem++)
1241 argvec[tem] = fortran_prepare_argument (exp, actual[tem].get (),
1242 tem, is_internal_func,
1243 value_type (callee),
1245 return evaluate_subexp_do_call (exp, noside, callee, argvec,
1246 nullptr, expect_type);
1250 error (_("Cannot perform substring on this type"));
1255 fortran_bound_1arg::evaluate (struct type *expect_type,
1256 struct expression *exp,
1259 bool lbound_p = std::get<0> (m_storage) == FORTRAN_LBOUND;
1260 value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
1261 fortran_require_array (value_type (arg1), lbound_p);
1262 return fortran_bounds_all_dims (lbound_p, exp->gdbarch, arg1);
1266 fortran_bound_2arg::evaluate (struct type *expect_type,
1267 struct expression *exp,
1270 bool lbound_p = std::get<0> (m_storage) == FORTRAN_LBOUND;
1271 value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
1272 fortran_require_array (value_type (arg1), lbound_p);
1274 /* User asked for the bounds of a specific dimension of the array. */
1275 value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
1276 struct type *type = check_typedef (value_type (arg2));
1277 if (type->code () != TYPE_CODE_INT)
1280 error (_("LBOUND second argument should be an integer"));
1282 error (_("UBOUND second argument should be an integer"));
1285 return fortran_bounds_for_dimension (lbound_p, exp->gdbarch, arg1, arg2);
1288 } /* namespace expr */
1290 /* See language.h. */
1293 f_language::language_arch_info (struct gdbarch *gdbarch,
1294 struct language_arch_info *lai) const
1296 const struct builtin_f_type *builtin = builtin_f_type (gdbarch);
1298 /* Helper function to allow shorter lines below. */
1299 auto add = [&] (struct type * t)
1301 lai->add_primitive_type (t);
1304 add (builtin->builtin_character);
1305 add (builtin->builtin_logical);
1306 add (builtin->builtin_logical_s1);
1307 add (builtin->builtin_logical_s2);
1308 add (builtin->builtin_logical_s8);
1309 add (builtin->builtin_real);
1310 add (builtin->builtin_real_s8);
1311 add (builtin->builtin_real_s16);
1312 add (builtin->builtin_complex_s8);
1313 add (builtin->builtin_complex_s16);
1314 add (builtin->builtin_void);
1316 lai->set_string_char_type (builtin->builtin_character);
1317 lai->set_bool_type (builtin->builtin_logical_s2, "logical");
1320 /* See language.h. */
1323 f_language::search_name_hash (const char *name) const
1325 return cp_search_name_hash (name);
1328 /* See language.h. */
1331 f_language::lookup_symbol_nonlocal (const char *name,
1332 const struct block *block,
1333 const domain_enum domain) const
1335 return cp_lookup_symbol_nonlocal (this, name, block, domain);
1338 /* See language.h. */
1340 symbol_name_matcher_ftype *
1341 f_language::get_symbol_name_matcher_inner
1342 (const lookup_name_info &lookup_name) const
1344 return cp_get_symbol_name_matcher (lookup_name);
1347 /* Single instance of the Fortran language class. */
1349 static f_language f_language_defn;
1352 build_fortran_types (struct gdbarch *gdbarch)
1354 struct builtin_f_type *builtin_f_type
1355 = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
1357 builtin_f_type->builtin_void
1358 = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "void");
1360 builtin_f_type->builtin_character
1361 = arch_type (gdbarch, TYPE_CODE_CHAR, TARGET_CHAR_BIT, "character");
1363 builtin_f_type->builtin_logical_s1
1364 = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
1366 builtin_f_type->builtin_integer_s2
1367 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
1370 builtin_f_type->builtin_integer_s8
1371 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
1374 builtin_f_type->builtin_logical_s2
1375 = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
1378 builtin_f_type->builtin_logical_s8
1379 = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
1382 builtin_f_type->builtin_integer
1383 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
1386 builtin_f_type->builtin_logical
1387 = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
1390 builtin_f_type->builtin_real
1391 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
1392 "real", gdbarch_float_format (gdbarch));
1393 builtin_f_type->builtin_real_s8
1394 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
1395 "real*8", gdbarch_double_format (gdbarch));
1396 auto fmt = gdbarch_floatformat_for_type (gdbarch, "real(kind=16)", 128);
1398 builtin_f_type->builtin_real_s16
1399 = arch_float_type (gdbarch, 128, "real*16", fmt);
1400 else if (gdbarch_long_double_bit (gdbarch) == 128)
1401 builtin_f_type->builtin_real_s16
1402 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
1403 "real*16", gdbarch_long_double_format (gdbarch));
1405 builtin_f_type->builtin_real_s16
1406 = arch_type (gdbarch, TYPE_CODE_ERROR, 128, "real*16");
1408 builtin_f_type->builtin_complex_s8
1409 = init_complex_type ("complex*8", builtin_f_type->builtin_real);
1410 builtin_f_type->builtin_complex_s16
1411 = init_complex_type ("complex*16", builtin_f_type->builtin_real_s8);
1413 if (builtin_f_type->builtin_real_s16->code () == TYPE_CODE_ERROR)
1414 builtin_f_type->builtin_complex_s32
1415 = arch_type (gdbarch, TYPE_CODE_ERROR, 256, "complex*32");
1417 builtin_f_type->builtin_complex_s32
1418 = init_complex_type ("complex*32", builtin_f_type->builtin_real_s16);
1420 return builtin_f_type;
1423 static struct gdbarch_data *f_type_data;
1425 const struct builtin_f_type *
1426 builtin_f_type (struct gdbarch *gdbarch)
1428 return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
1431 /* Command-list for the "set/show fortran" prefix command. */
1432 static struct cmd_list_element *set_fortran_list;
1433 static struct cmd_list_element *show_fortran_list;
1435 void _initialize_f_language ();
1437 _initialize_f_language ()
1439 f_type_data = gdbarch_data_register_post_init (build_fortran_types);
1441 add_basic_prefix_cmd ("fortran", no_class,
1442 _("Prefix command for changing Fortran-specific settings."),
1443 &set_fortran_list, "set fortran ", 0, &setlist);
1445 add_show_prefix_cmd ("fortran", no_class,
1446 _("Generic command for showing Fortran-specific settings."),
1447 &show_fortran_list, "show fortran ", 0, &showlist);
1449 add_setshow_boolean_cmd ("repack-array-slices", class_vars,
1450 &repack_array_slices, _("\
1451 Enable or disable repacking of non-contiguous array slices."), _("\
1452 Show whether non-contiguous array slices are repacked."), _("\
1453 When the user requests a slice of a Fortran array then we can either return\n\
1454 a descriptor that describes the array in place (using the original array data\n\
1455 in its existing location) or the original data can be repacked (copied) to a\n\
1458 When the content of the array slice is contiguous within the original array\n\
1459 then the result will never be repacked, but when the data for the new array\n\
1460 is non-contiguous within the original array repacking will only be performed\n\
1461 when this setting is on."),
1463 show_repack_array_slices,
1464 &set_fortran_list, &show_fortran_list);
1466 /* Debug Fortran's array slicing logic. */
1467 add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance,
1468 &fortran_array_slicing_debug, _("\
1469 Set debugging of Fortran array slicing."), _("\
1470 Show debugging of Fortran array slicing."), _("\
1471 When on, debugging of Fortran array slicing is enabled."),
1473 show_fortran_array_slicing_debug,
1474 &setdebuglist, &showdebuglist);
1477 /* Ensures that function argument VALUE is in the appropriate form to
1478 pass to a Fortran function. Returns a possibly new value that should
1479 be used instead of VALUE.
1481 When IS_ARTIFICIAL is true this indicates an artificial argument,
1482 e.g. hidden string lengths which the GNU Fortran argument passing
1483 convention specifies as being passed by value.
1485 When IS_ARTIFICIAL is false, the argument is passed by pointer. If the
1486 value is already in target memory then return a value that is a pointer
1487 to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate
1488 space in the target, copy VALUE in, and return a pointer to the in
1491 static struct value *
1492 fortran_argument_convert (struct value *value, bool is_artificial)
1496 /* If the value is not in the inferior e.g. registers values,
1497 convenience variables and user input. */
1498 if (VALUE_LVAL (value) != lval_memory)
1500 struct type *type = value_type (value);
1501 const int length = TYPE_LENGTH (type);
1502 const CORE_ADDR addr
1503 = value_as_long (value_allocate_space_in_inferior (length));
1504 write_memory (addr, value_contents (value), length);
1506 = value_from_contents_and_address (type, value_contents (value),
1508 return value_addr (val);
1511 return value_addr (value); /* Program variables, e.g. arrays. */
1516 /* Prepare (and return) an argument value ready for an inferior function
1517 call to a Fortran function. EXP and POS are the expressions describing
1518 the argument to prepare. ARG_NUM is the argument number being
1519 prepared, with 0 being the first argument and so on. FUNC_TYPE is the
1520 type of the function being called.
1522 IS_INTERNAL_CALL_P is true if this is a call to a function of type
1523 TYPE_CODE_INTERNAL_FUNCTION, otherwise this parameter is false.
1525 NOSIDE has its usual meaning for expression parsing (see eval.c).
1527 Arguments in Fortran are normally passed by address, we coerce the
1528 arguments here rather than in value_arg_coerce as otherwise the call to
1529 malloc (to place the non-lvalue parameters in target memory) is hit by
1530 this Fortran specific logic. This results in malloc being called with a
1531 pointer to an integer followed by an attempt to malloc the arguments to
1532 malloc in target memory. Infinite recursion ensues. */
1535 fortran_prepare_argument (struct expression *exp,
1536 expr::operation *subexp,
1537 int arg_num, bool is_internal_call_p,
1538 struct type *func_type, enum noside noside)
1540 if (is_internal_call_p)
1541 return subexp->evaluate_with_coercion (exp, noside);
1543 bool is_artificial = ((arg_num >= func_type->num_fields ())
1545 : TYPE_FIELD_ARTIFICIAL (func_type, arg_num));
1547 /* If this is an artificial argument, then either, this is an argument
1548 beyond the end of the known arguments, or possibly, there are no known
1549 arguments (maybe missing debug info).
1551 For these artificial arguments, if the user has prefixed it with '&'
1552 (for address-of), then lets always allow this to succeed, even if the
1553 argument is not actually in inferior memory. This will allow the user
1554 to pass arguments to a Fortran function even when there's no debug
1557 As we already pass the address of non-artificial arguments, all we
1558 need to do if skip the UNOP_ADDR operator in the expression and mark
1559 the argument as non-artificial. */
1562 expr::unop_addr_operation *addrop
1563 = dynamic_cast<expr::unop_addr_operation *> (subexp);
1564 if (addrop != nullptr)
1566 subexp = addrop->get_expression ().get ();
1567 is_artificial = false;
1571 struct value *arg_val = subexp->evaluate_with_coercion (exp, noside);
1572 return fortran_argument_convert (arg_val, is_artificial);
1578 fortran_preserve_arg_pointer (struct value *arg, struct type *type)
1580 if (value_type (arg)->code () == TYPE_CODE_PTR)
1581 return value_type (arg);
1588 fortran_adjust_dynamic_array_base_address_hack (struct type *type,
1591 gdb_assert (type->code () == TYPE_CODE_ARRAY);
1593 /* We can't adjust the base address for arrays that have no content. */
1594 if (type_not_allocated (type) || type_not_associated (type))
1597 int ndimensions = calc_f77_array_dims (type);
1598 LONGEST total_offset = 0;
1600 /* Walk through each of the dimensions of this array type and figure out
1601 if any of the dimensions are "backwards", that is the base address
1602 for this dimension points to the element at the highest memory
1603 address and the stride is negative. */
1604 struct type *tmp_type = type;
1605 for (int i = 0 ; i < ndimensions; ++i)
1607 /* Grab the range for this dimension and extract the lower and upper
1609 tmp_type = check_typedef (tmp_type);
1610 struct type *range_type = tmp_type->index_type ();
1611 LONGEST lowerbound, upperbound, stride;
1612 if (!get_discrete_bounds (range_type, &lowerbound, &upperbound))
1613 error ("failed to get range bounds");
1615 /* Figure out the stride for this dimension. */
1616 struct type *elt_type = check_typedef (TYPE_TARGET_TYPE (tmp_type));
1617 stride = tmp_type->index_type ()->bounds ()->bit_stride ();
1619 stride = type_length_units (elt_type);
1623 = gdbarch_addressable_memory_unit_size (elt_type->arch ());
1624 stride /= (unit_size * 8);
1627 /* If this dimension is "backward" then figure out the offset
1628 adjustment required to point to the element at the lowest memory
1629 address, and add this to the total offset. */
1631 if (stride < 0 && lowerbound < upperbound)
1632 offset = (upperbound - lowerbound) * stride;
1633 total_offset += offset;
1634 tmp_type = TYPE_TARGET_TYPE (tmp_type);
1637 /* Adjust the address of this object and return it. */
1638 address += total_offset;