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"
44 /* Whether GDB should repack array slices created by the user. */
45 static bool repack_array_slices
= false;
47 /* Implement 'show fortran repack-array-slices'. */
49 show_repack_array_slices (struct ui_file
*file
, int from_tty
,
50 struct cmd_list_element
*c
, const char *value
)
52 fprintf_filtered (file
, _("Repacking of Fortran array slices is %s.\n"),
56 /* Debugging of Fortran's array slicing. */
57 static bool fortran_array_slicing_debug
= false;
59 /* Implement 'show debug fortran-array-slicing'. */
61 show_fortran_array_slicing_debug (struct ui_file
*file
, int from_tty
,
62 struct cmd_list_element
*c
,
65 fprintf_filtered (file
, _("Debugging of Fortran array slicing is %s.\n"),
71 static struct value
*fortran_argument_convert (struct value
*value
,
74 /* Return the encoding that should be used for the character type
78 f_language::get_encoding (struct type
*type
)
82 switch (TYPE_LENGTH (type
))
85 encoding
= target_charset (type
->arch ());
88 if (type_byte_order (type
) == BFD_ENDIAN_BIG
)
89 encoding
= "UTF-32BE";
91 encoding
= "UTF-32LE";
95 error (_("unrecognized character type"));
103 /* Table of operators and their precedences for printing expressions. */
105 const struct op_print
f_language::op_print_tab
[] =
107 {"+", BINOP_ADD
, PREC_ADD
, 0},
108 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
109 {"-", BINOP_SUB
, PREC_ADD
, 0},
110 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
111 {"*", BINOP_MUL
, PREC_MUL
, 0},
112 {"/", BINOP_DIV
, PREC_MUL
, 0},
113 {"DIV", BINOP_INTDIV
, PREC_MUL
, 0},
114 {"MOD", BINOP_REM
, PREC_MUL
, 0},
115 {"=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
116 {".OR.", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
117 {".AND.", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
118 {".NOT.", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
119 {".EQ.", BINOP_EQUAL
, PREC_EQUAL
, 0},
120 {".NE.", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
121 {".LE.", BINOP_LEQ
, PREC_ORDER
, 0},
122 {".GE.", BINOP_GEQ
, PREC_ORDER
, 0},
123 {".GT.", BINOP_GTR
, PREC_ORDER
, 0},
124 {".LT.", BINOP_LESS
, PREC_ORDER
, 0},
125 {"**", UNOP_IND
, PREC_PREFIX
, 0},
126 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
127 {NULL
, OP_NULL
, PREC_REPEAT
, 0}
131 /* Create an array containing the lower bounds (when LBOUND_P is true) or
132 the upper bounds (when LBOUND_P is false) of ARRAY (which must be of
133 array type). GDBARCH is the current architecture. */
135 static struct value
*
136 fortran_bounds_all_dims (bool lbound_p
,
137 struct gdbarch
*gdbarch
,
140 type
*array_type
= check_typedef (value_type (array
));
141 int ndimensions
= calc_f77_array_dims (array_type
);
143 /* Allocate a result value of the correct type. */
145 = create_static_range_type (nullptr,
146 builtin_type (gdbarch
)->builtin_int
,
148 struct type
*elm_type
= builtin_type (gdbarch
)->builtin_long_long
;
149 struct type
*result_type
= create_array_type (nullptr, elm_type
, range
);
150 struct value
*result
= allocate_value (result_type
);
152 /* Walk the array dimensions backwards due to the way the array will be
153 laid out in memory, the first dimension will be the most inner. */
154 LONGEST elm_len
= TYPE_LENGTH (elm_type
);
155 for (LONGEST dst_offset
= elm_len
* (ndimensions
- 1);
157 dst_offset
-= elm_len
)
161 /* Grab the required bound. */
163 b
= f77_get_lowerbound (array_type
);
165 b
= f77_get_upperbound (array_type
);
167 /* And copy the value into the result value. */
168 struct value
*v
= value_from_longest (elm_type
, b
);
169 gdb_assert (dst_offset
+ TYPE_LENGTH (value_type (v
))
170 <= TYPE_LENGTH (value_type (result
)));
171 gdb_assert (TYPE_LENGTH (value_type (v
)) == elm_len
);
172 value_contents_copy (result
, dst_offset
, v
, 0, elm_len
);
174 /* Peel another dimension of the array. */
175 array_type
= TYPE_TARGET_TYPE (array_type
);
181 /* Return the lower bound (when LBOUND_P is true) or the upper bound (when
182 LBOUND_P is false) for dimension DIM_VAL (which must be an integer) of
183 ARRAY (which must be an array). GDBARCH is the current architecture. */
185 static struct value
*
186 fortran_bounds_for_dimension (bool lbound_p
,
187 struct gdbarch
*gdbarch
,
189 struct value
*dim_val
)
191 /* Check the requested dimension is valid for this array. */
192 type
*array_type
= check_typedef (value_type (array
));
193 int ndimensions
= calc_f77_array_dims (array_type
);
194 long dim
= value_as_long (dim_val
);
195 if (dim
< 1 || dim
> ndimensions
)
198 error (_("LBOUND dimension must be from 1 to %d"), ndimensions
);
200 error (_("UBOUND dimension must be from 1 to %d"), ndimensions
);
203 /* The type for the result. */
204 struct type
*bound_type
= builtin_type (gdbarch
)->builtin_long_long
;
206 /* Walk the dimensions backwards, due to the ordering in which arrays are
207 laid out the first dimension is the most inner. */
208 for (int i
= ndimensions
- 1; i
>= 0; --i
)
210 /* If this is the requested dimension then we're done. Grab the
211 bounds and return. */
217 b
= f77_get_lowerbound (array_type
);
219 b
= f77_get_upperbound (array_type
);
221 return value_from_longest (bound_type
, b
);
224 /* Peel off another dimension of the array. */
225 array_type
= TYPE_TARGET_TYPE (array_type
);
228 gdb_assert_not_reached ("failed to find matching dimension");
232 /* Return the number of dimensions for a Fortran array or string. */
235 calc_f77_array_dims (struct type
*array_type
)
238 struct type
*tmp_type
;
240 if ((array_type
->code () == TYPE_CODE_STRING
))
243 if ((array_type
->code () != TYPE_CODE_ARRAY
))
244 error (_("Can't get dimensions for a non-array type"));
246 tmp_type
= array_type
;
248 while ((tmp_type
= TYPE_TARGET_TYPE (tmp_type
)))
250 if (tmp_type
->code () == TYPE_CODE_ARRAY
)
256 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
257 slices. This is a base class for two alternative repacking mechanisms,
258 one for when repacking from a lazy value, and one for repacking from a
259 non-lazy (already loaded) value. */
260 class fortran_array_repacker_base_impl
261 : public fortran_array_walker_base_impl
264 /* Constructor, DEST is the value we are repacking into. */
265 fortran_array_repacker_base_impl (struct value
*dest
)
270 /* When we start processing the inner most dimension, this is where we
271 will be creating values for each element as we load them and then copy
272 them into the M_DEST value. Set a value mark so we can free these
274 void start_dimension (bool inner_p
)
278 gdb_assert (m_mark
== nullptr);
279 m_mark
= value_mark ();
283 /* When we finish processing the inner most dimension free all temporary
284 value that were created. */
285 void finish_dimension (bool inner_p
, bool last_p
)
289 gdb_assert (m_mark
!= nullptr);
290 value_free_to_mark (m_mark
);
296 /* Copy the contents of array element ELT into M_DEST at the next
298 void copy_element_to_dest (struct value
*elt
)
300 value_contents_copy (m_dest
, m_dest_offset
, elt
, 0,
301 TYPE_LENGTH (value_type (elt
)));
302 m_dest_offset
+= TYPE_LENGTH (value_type (elt
));
305 /* The value being written to. */
306 struct value
*m_dest
;
308 /* The byte offset in M_DEST at which the next element should be
310 LONGEST m_dest_offset
;
312 /* Set with a call to VALUE_MARK, and then reset after calling
313 VALUE_FREE_TO_MARK. */
314 struct value
*m_mark
= nullptr;
317 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
318 slices. This class is specialised for repacking an array slice from a
319 lazy array value, as such it does not require the parent array value to
320 be loaded into GDB's memory; the parent value could be huge, while the
321 slice could be tiny. */
322 class fortran_lazy_array_repacker_impl
323 : public fortran_array_repacker_base_impl
326 /* Constructor. TYPE is the type of the slice being loaded from the
327 parent value, so this type will correctly reflect the strides required
328 to find all of the elements from the parent value. ADDRESS is the
329 address in target memory of value matching TYPE, and DEST is the value
330 we are repacking into. */
331 explicit fortran_lazy_array_repacker_impl (struct type
*type
,
334 : fortran_array_repacker_base_impl (dest
),
338 /* Create a lazy value in target memory representing a single element,
339 then load the element into GDB's memory and copy the contents into the
340 destination value. */
341 void process_element (struct type
*elt_type
, LONGEST elt_off
, bool last_p
)
343 copy_element_to_dest (value_at_lazy (elt_type
, m_addr
+ elt_off
));
347 /* The address in target memory where the parent value starts. */
351 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
352 slices. This class is specialised for repacking an array slice from a
353 previously loaded (non-lazy) array value, as such it fetches the
354 element values from the contents of the parent value. */
355 class fortran_array_repacker_impl
356 : public fortran_array_repacker_base_impl
359 /* Constructor. TYPE is the type for the array slice within the parent
360 value, as such it has stride values as required to find the elements
361 within the original parent value. ADDRESS is the address in target
362 memory of the value matching TYPE. BASE_OFFSET is the offset from
363 the start of VAL's content buffer to the start of the object of TYPE,
364 VAL is the parent object from which we are loading the value, and
365 DEST is the value into which we are repacking. */
366 explicit fortran_array_repacker_impl (struct type
*type
, CORE_ADDR address
,
368 struct value
*val
, struct value
*dest
)
369 : fortran_array_repacker_base_impl (dest
),
370 m_base_offset (base_offset
),
373 gdb_assert (!value_lazy (val
));
376 /* Extract an element of ELT_TYPE at offset (M_BASE_OFFSET + ELT_OFF)
377 from the content buffer of M_VAL then copy this extracted value into
378 the repacked destination value. */
379 void process_element (struct type
*elt_type
, LONGEST elt_off
, bool last_p
)
382 = value_from_component (m_val
, elt_type
, (elt_off
+ m_base_offset
));
383 copy_element_to_dest (elt
);
387 /* The offset into the content buffer of M_VAL to the start of the slice
389 LONGEST m_base_offset
;
391 /* The parent value from which we are extracting a slice. */
395 /* Called from evaluate_subexp_standard to perform array indexing, and
396 sub-range extraction, for Fortran. As well as arrays this function
397 also handles strings as they can be treated like arrays of characters.
398 ARRAY is the array or string being accessed. EXP, POS, and NOSIDE are
399 as for evaluate_subexp_standard, and NARGS is the number of arguments
400 in this access (e.g. 'array (1,2,3)' would be NARGS 3). */
402 static struct value
*
403 fortran_value_subarray (struct value
*array
, struct expression
*exp
,
404 int *pos
, int nargs
, enum noside noside
)
406 type
*original_array_type
= check_typedef (value_type (array
));
407 bool is_string_p
= original_array_type
->code () == TYPE_CODE_STRING
;
409 /* Perform checks for ARRAY not being available. The somewhat overly
410 complex logic here is just to keep backward compatibility with the
411 errors that we used to get before FORTRAN_VALUE_SUBARRAY was
412 rewritten. Maybe a future task would streamline the error messages we
413 get here, and update all the expected test results. */
414 if (exp
->elts
[*pos
].opcode
!= OP_RANGE
)
416 if (type_not_associated (original_array_type
))
417 error (_("no such vector element (vector not associated)"));
418 else if (type_not_allocated (original_array_type
))
419 error (_("no such vector element (vector not allocated)"));
423 if (type_not_associated (original_array_type
))
424 error (_("array not associated"));
425 else if (type_not_allocated (original_array_type
))
426 error (_("array not allocated"));
429 /* First check that the number of dimensions in the type we are slicing
430 matches the number of arguments we were passed. */
431 int ndimensions
= calc_f77_array_dims (original_array_type
);
432 if (nargs
!= ndimensions
)
433 error (_("Wrong number of subscripts"));
435 /* This will be initialised below with the type of the elements held in
437 struct type
*inner_element_type
;
439 /* Extract the types of each array dimension from the original array
440 type. We need these available so we can fill in the default upper and
441 lower bounds if the user requested slice doesn't provide that
442 information. Additionally unpacking the dimensions like this gives us
443 the inner element type. */
444 std::vector
<struct type
*> dim_types
;
446 dim_types
.reserve (ndimensions
);
447 struct type
*type
= original_array_type
;
448 for (int i
= 0; i
< ndimensions
; ++i
)
450 dim_types
.push_back (type
);
451 type
= TYPE_TARGET_TYPE (type
);
453 /* TYPE is now the inner element type of the array, we start the new
454 array slice off as this type, then as we process the requested slice
455 (from the user) we wrap new types around this to build up the final
457 inner_element_type
= type
;
460 /* As we analyse the new slice type we need to understand if the data
461 being referenced is contiguous. Do decide this we must track the size
462 of an element at each dimension of the new slice array. Initially the
463 elements of the inner most dimension of the array are the same inner
464 most elements as the original ARRAY. */
465 LONGEST slice_element_size
= TYPE_LENGTH (inner_element_type
);
467 /* Start off assuming all data is contiguous, this will be set to false
468 if access to any dimension results in non-contiguous data. */
469 bool is_all_contiguous
= true;
471 /* The TOTAL_OFFSET is the distance in bytes from the start of the
472 original ARRAY to the start of the new slice. This is calculated as
473 we process the information from the user. */
474 LONGEST total_offset
= 0;
476 /* A structure representing information about each dimension of the
481 slice_dim (LONGEST l
, LONGEST h
, LONGEST s
, struct type
*idx
)
488 /* The low bound for this dimension of the slice. */
491 /* The high bound for this dimension of the slice. */
494 /* The byte stride for this dimension of the slice. */
500 /* The dimensions of the resulting slice. */
501 std::vector
<slice_dim
> slice_dims
;
503 /* Process the incoming arguments. These arguments are in the reverse
504 order to the array dimensions, that is the first argument refers to
505 the last array dimension. */
506 if (fortran_array_slicing_debug
)
507 debug_printf ("Processing array access:\n");
508 for (int i
= 0; i
< nargs
; ++i
)
510 /* For each dimension of the array the user will have either provided
511 a ranged access with optional lower bound, upper bound, and
512 stride, or the user will have supplied a single index. */
513 struct type
*dim_type
= dim_types
[ndimensions
- (i
+ 1)];
514 if (exp
->elts
[*pos
].opcode
== OP_RANGE
)
517 enum range_flag range_flag
= (enum range_flag
) exp
->elts
[pc
].longconst
;
520 LONGEST low
, high
, stride
;
521 low
= high
= stride
= 0;
523 if ((range_flag
& RANGE_LOW_BOUND_DEFAULT
) == 0)
524 low
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
526 low
= f77_get_lowerbound (dim_type
);
527 if ((range_flag
& RANGE_HIGH_BOUND_DEFAULT
) == 0)
528 high
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
530 high
= f77_get_upperbound (dim_type
);
531 if ((range_flag
& RANGE_HAS_STRIDE
) == RANGE_HAS_STRIDE
)
532 stride
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
537 error (_("stride must not be 0"));
539 /* Get information about this dimension in the original ARRAY. */
540 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
541 struct type
*index_type
= dim_type
->index_type ();
542 LONGEST lb
= f77_get_lowerbound (dim_type
);
543 LONGEST ub
= f77_get_upperbound (dim_type
);
544 LONGEST sd
= index_type
->bit_stride ();
546 sd
= TYPE_LENGTH (target_type
) * 8;
548 if (fortran_array_slicing_debug
)
550 debug_printf ("|-> Range access\n");
551 std::string str
= type_to_string (dim_type
);
552 debug_printf ("| |-> Type: %s\n", str
.c_str ());
553 debug_printf ("| |-> Array:\n");
554 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
555 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
556 debug_printf ("| | |-> Bit stride: %s\n", plongest (sd
));
557 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
/ 8));
558 debug_printf ("| | |-> Type size: %s\n",
559 pulongest (TYPE_LENGTH (dim_type
)));
560 debug_printf ("| | '-> Target type size: %s\n",
561 pulongest (TYPE_LENGTH (target_type
)));
562 debug_printf ("| |-> Accessing:\n");
563 debug_printf ("| | |-> Low bound: %s\n",
565 debug_printf ("| | |-> High bound: %s\n",
567 debug_printf ("| | '-> Element stride: %s\n",
571 /* Check the user hasn't asked for something invalid. */
572 if (high
> ub
|| low
< lb
)
573 error (_("array subscript out of bounds"));
575 /* Calculate what this dimension of the new slice array will look
576 like. OFFSET is the byte offset from the start of the
577 previous (more outer) dimension to the start of this
578 dimension. E_COUNT is the number of elements in this
579 dimension. REMAINDER is the number of elements remaining
580 between the last included element and the upper bound. For
581 example an access '1:6:2' will include elements 1, 3, 5 and
582 have a remainder of 1 (element #6). */
583 LONGEST lowest
= std::min (low
, high
);
584 LONGEST offset
= (sd
/ 8) * (lowest
- lb
);
585 LONGEST e_count
= std::abs (high
- low
) + 1;
586 e_count
= (e_count
+ (std::abs (stride
) - 1)) / std::abs (stride
);
588 LONGEST new_high
= new_low
+ e_count
- 1;
589 LONGEST new_stride
= (sd
* stride
) / 8;
590 LONGEST last_elem
= low
+ ((e_count
- 1) * stride
);
591 LONGEST remainder
= high
- last_elem
;
594 offset
+= std::abs (remainder
) * TYPE_LENGTH (target_type
);
596 error (_("incorrect stride and boundary combination"));
599 error (_("incorrect stride and boundary combination"));
601 /* Is the data within this dimension contiguous? It is if the
602 newly computed stride is the same size as a single element of
604 bool is_dim_contiguous
= (new_stride
== slice_element_size
);
605 is_all_contiguous
&= is_dim_contiguous
;
607 if (fortran_array_slicing_debug
)
609 debug_printf ("| '-> Results:\n");
610 debug_printf ("| |-> Offset = %s\n", plongest (offset
));
611 debug_printf ("| |-> Elements = %s\n", plongest (e_count
));
612 debug_printf ("| |-> Low bound = %s\n", plongest (new_low
));
613 debug_printf ("| |-> High bound = %s\n",
614 plongest (new_high
));
615 debug_printf ("| |-> Byte stride = %s\n",
616 plongest (new_stride
));
617 debug_printf ("| |-> Last element = %s\n",
618 plongest (last_elem
));
619 debug_printf ("| |-> Remainder = %s\n",
620 plongest (remainder
));
621 debug_printf ("| '-> Contiguous = %s\n",
622 (is_dim_contiguous
? "Yes" : "No"));
625 /* Figure out how big (in bytes) an element of this dimension of
626 the new array slice will be. */
627 slice_element_size
= std::abs (new_stride
* e_count
);
629 slice_dims
.emplace_back (new_low
, new_high
, new_stride
,
632 /* Update the total offset. */
633 total_offset
+= offset
;
637 /* There is a single index for this dimension. */
639 = value_as_long (evaluate_subexp_with_coercion (exp
, pos
, noside
));
641 /* Get information about this dimension in the original ARRAY. */
642 struct type
*target_type
= TYPE_TARGET_TYPE (dim_type
);
643 struct type
*index_type
= dim_type
->index_type ();
644 LONGEST lb
= f77_get_lowerbound (dim_type
);
645 LONGEST ub
= f77_get_upperbound (dim_type
);
646 LONGEST sd
= index_type
->bit_stride () / 8;
648 sd
= TYPE_LENGTH (target_type
);
650 if (fortran_array_slicing_debug
)
652 debug_printf ("|-> Index access\n");
653 std::string str
= type_to_string (dim_type
);
654 debug_printf ("| |-> Type: %s\n", str
.c_str ());
655 debug_printf ("| |-> Array:\n");
656 debug_printf ("| | |-> Low bound: %s\n", plongest (lb
));
657 debug_printf ("| | |-> High bound: %s\n", plongest (ub
));
658 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd
));
659 debug_printf ("| | |-> Type size: %s\n",
660 pulongest (TYPE_LENGTH (dim_type
)));
661 debug_printf ("| | '-> Target type size: %s\n",
662 pulongest (TYPE_LENGTH (target_type
)));
663 debug_printf ("| '-> Accessing:\n");
664 debug_printf ("| '-> Index: %s\n",
668 /* If the array has actual content then check the index is in
669 bounds. An array without content (an unbound array) doesn't
670 have a known upper bound, so don't error check in that
673 || (dim_type
->index_type ()->bounds ()->high
.kind () != PROP_UNDEFINED
675 || (VALUE_LVAL (array
) != lval_memory
676 && dim_type
->index_type ()->bounds ()->high
.kind () == PROP_UNDEFINED
))
678 if (type_not_associated (dim_type
))
679 error (_("no such vector element (vector not associated)"));
680 else if (type_not_allocated (dim_type
))
681 error (_("no such vector element (vector not allocated)"));
683 error (_("no such vector element"));
686 /* Calculate using the type stride, not the target type size. */
687 LONGEST offset
= sd
* (index
- lb
);
688 total_offset
+= offset
;
692 if (noside
== EVAL_SKIP
)
695 /* Build a type that represents the new array slice in the target memory
696 of the original ARRAY, this type makes use of strides to correctly
697 find only those elements that are part of the new slice. */
698 struct type
*array_slice_type
= inner_element_type
;
699 for (const auto &d
: slice_dims
)
701 /* Create the range. */
702 dynamic_prop p_low
, p_high
, p_stride
;
704 p_low
.set_const_val (d
.low
);
705 p_high
.set_const_val (d
.high
);
706 p_stride
.set_const_val (d
.stride
);
708 struct type
*new_range
709 = create_range_type_with_stride ((struct type
*) NULL
,
710 TYPE_TARGET_TYPE (d
.index
),
711 &p_low
, &p_high
, 0, &p_stride
,
714 = create_array_type (nullptr, array_slice_type
, new_range
);
717 if (fortran_array_slicing_debug
)
719 debug_printf ("'-> Final result:\n");
720 debug_printf (" |-> Type: %s\n",
721 type_to_string (array_slice_type
).c_str ());
722 debug_printf (" |-> Total offset: %s\n",
723 plongest (total_offset
));
724 debug_printf (" |-> Base address: %s\n",
725 core_addr_to_string (value_address (array
)));
726 debug_printf (" '-> Contiguous = %s\n",
727 (is_all_contiguous
? "Yes" : "No"));
730 /* Should we repack this array slice? */
731 if (!is_all_contiguous
&& (repack_array_slices
|| is_string_p
))
733 /* Build a type for the repacked slice. */
734 struct type
*repacked_array_type
= inner_element_type
;
735 for (const auto &d
: slice_dims
)
737 /* Create the range. */
738 dynamic_prop p_low
, p_high
, p_stride
;
740 p_low
.set_const_val (d
.low
);
741 p_high
.set_const_val (d
.high
);
742 p_stride
.set_const_val (TYPE_LENGTH (repacked_array_type
));
744 struct type
*new_range
745 = create_range_type_with_stride ((struct type
*) NULL
,
746 TYPE_TARGET_TYPE (d
.index
),
747 &p_low
, &p_high
, 0, &p_stride
,
750 = create_array_type (nullptr, repacked_array_type
, new_range
);
753 /* Now copy the elements from the original ARRAY into the packed
755 struct value
*dest
= allocate_value (repacked_array_type
);
756 if (value_lazy (array
)
757 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
758 > TYPE_LENGTH (check_typedef (value_type (array
)))))
760 fortran_array_walker
<fortran_lazy_array_repacker_impl
> p
761 (array_slice_type
, value_address (array
) + total_offset
, dest
);
766 fortran_array_walker
<fortran_array_repacker_impl
> p
767 (array_slice_type
, value_address (array
) + total_offset
,
768 total_offset
, array
, dest
);
775 if (VALUE_LVAL (array
) == lval_memory
)
777 /* If the value we're taking a slice from is not yet loaded, or
778 the requested slice is outside the values content range then
779 just create a new lazy value pointing at the memory where the
780 contents we're looking for exist. */
781 if (value_lazy (array
)
782 || (total_offset
+ TYPE_LENGTH (array_slice_type
)
783 > TYPE_LENGTH (check_typedef (value_type (array
)))))
784 array
= value_at_lazy (array_slice_type
,
785 value_address (array
) + total_offset
);
787 array
= value_from_contents_and_address (array_slice_type
,
788 (value_contents (array
)
790 (value_address (array
)
793 else if (!value_lazy (array
))
794 array
= value_from_component (array
, array_slice_type
, total_offset
);
796 error (_("cannot subscript arrays that are not in memory"));
802 /* Special expression evaluation cases for Fortran. */
804 static struct value
*
805 evaluate_subexp_f (struct type
*expect_type
, struct expression
*exp
,
806 int *pos
, enum noside noside
)
808 struct value
*arg1
= NULL
, *arg2
= NULL
;
815 op
= exp
->elts
[pc
].opcode
;
821 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
824 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
825 if (noside
== EVAL_SKIP
)
826 return eval_skip_value (exp
);
827 type
= value_type (arg1
);
828 switch (type
->code ())
833 = fabs (target_float_to_host_double (value_contents (arg1
),
835 return value_from_host_double (type
, d
);
839 LONGEST l
= value_as_long (arg1
);
841 return value_from_longest (type
, l
);
844 error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type
));
847 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
848 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
849 if (noside
== EVAL_SKIP
)
850 return eval_skip_value (exp
);
851 type
= value_type (arg1
);
852 if (type
->code () != value_type (arg2
)->code ())
853 error (_("non-matching types for parameters to MOD ()"));
854 switch (type
->code ())
859 = target_float_to_host_double (value_contents (arg1
),
862 = target_float_to_host_double (value_contents (arg2
),
864 double d3
= fmod (d1
, d2
);
865 return value_from_host_double (type
, d3
);
869 LONGEST v1
= value_as_long (arg1
);
870 LONGEST v2
= value_as_long (arg2
);
872 error (_("calling MOD (N, 0) is undefined"));
873 LONGEST v3
= v1
- (v1
/ v2
) * v2
;
874 return value_from_longest (value_type (arg1
), v3
);
877 error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type
));
879 case UNOP_FORTRAN_CEILING
:
881 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
882 if (noside
== EVAL_SKIP
)
883 return eval_skip_value (exp
);
884 type
= value_type (arg1
);
885 if (type
->code () != TYPE_CODE_FLT
)
886 error (_("argument to CEILING must be of type float"));
888 = target_float_to_host_double (value_contents (arg1
),
891 return value_from_host_double (type
, val
);
894 case UNOP_FORTRAN_FLOOR
:
896 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
897 if (noside
== EVAL_SKIP
)
898 return eval_skip_value (exp
);
899 type
= value_type (arg1
);
900 if (type
->code () != TYPE_CODE_FLT
)
901 error (_("argument to FLOOR must be of type float"));
903 = target_float_to_host_double (value_contents (arg1
),
906 return value_from_host_double (type
, val
);
909 case BINOP_FORTRAN_MODULO
:
911 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
912 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
913 if (noside
== EVAL_SKIP
)
914 return eval_skip_value (exp
);
915 type
= value_type (arg1
);
916 if (type
->code () != value_type (arg2
)->code ())
917 error (_("non-matching types for parameters to MODULO ()"));
918 /* MODULO(A, P) = A - FLOOR (A / P) * P */
919 switch (type
->code ())
923 LONGEST a
= value_as_long (arg1
);
924 LONGEST p
= value_as_long (arg2
);
925 LONGEST result
= a
- (a
/ p
) * p
;
926 if (result
!= 0 && (a
< 0) != (p
< 0))
928 return value_from_longest (value_type (arg1
), result
);
933 = target_float_to_host_double (value_contents (arg1
),
936 = target_float_to_host_double (value_contents (arg2
),
938 double result
= fmod (a
, p
);
939 if (result
!= 0 && (a
< 0.0) != (p
< 0.0))
941 return value_from_host_double (type
, result
);
944 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type
));
950 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
953 /* This assertion should be enforced by the expression parser. */
954 gdb_assert (nargs
== 1 || nargs
== 2);
956 bool lbound_p
= op
== FORTRAN_LBOUND
;
958 /* Check that the first argument is array like. */
959 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
960 type
= check_typedef (value_type (arg1
));
961 if (type
->code () != TYPE_CODE_ARRAY
)
964 error (_("LBOUND can only be applied to arrays"));
966 error (_("UBOUND can only be applied to arrays"));
970 return fortran_bounds_all_dims (lbound_p
, exp
->gdbarch
, arg1
);
972 /* User asked for the bounds of a specific dimension of the array. */
973 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
974 type
= check_typedef (value_type (arg2
));
975 if (type
->code () != TYPE_CODE_INT
)
978 error (_("LBOUND second argument should be an integer"));
980 error (_("UBOUND second argument should be an integer"));
983 return fortran_bounds_for_dimension (lbound_p
, exp
->gdbarch
, arg1
,
988 case BINOP_FORTRAN_CMPLX
:
989 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
990 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
991 if (noside
== EVAL_SKIP
)
992 return eval_skip_value (exp
);
993 type
= builtin_f_type(exp
->gdbarch
)->builtin_complex_s16
;
994 return value_literal_complex (arg1
, arg2
, type
);
996 case UNOP_FORTRAN_KIND
:
997 arg1
= evaluate_subexp (NULL
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
998 type
= value_type (arg1
);
1000 switch (type
->code ())
1002 case TYPE_CODE_STRUCT
:
1003 case TYPE_CODE_UNION
:
1004 case TYPE_CODE_MODULE
:
1005 case TYPE_CODE_FUNC
:
1006 error (_("argument to kind must be an intrinsic type"));
1009 if (!TYPE_TARGET_TYPE (type
))
1010 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1011 TYPE_LENGTH (type
));
1012 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1013 TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
1016 case OP_F77_UNDETERMINED_ARGLIST
:
1017 /* Remember that in F77, functions, substring ops and array subscript
1018 operations cannot be disambiguated at parse time. We have made
1019 all array subscript operations, substring operations as well as
1020 function calls come here and we now have to discover what the heck
1021 this thing actually was. If it is a function, we process just as
1022 if we got an OP_FUNCALL. */
1023 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1026 /* First determine the type code we are dealing with. */
1027 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1028 type
= check_typedef (value_type (arg1
));
1029 enum type_code code
= type
->code ();
1031 if (code
== TYPE_CODE_PTR
)
1033 /* Fortran always passes variable to subroutines as pointer.
1034 So we need to look into its target type to see if it is
1035 array, string or function. If it is, we need to switch
1036 to the target value the original one points to. */
1037 struct type
*target_type
= check_typedef (TYPE_TARGET_TYPE (type
));
1039 if (target_type
->code () == TYPE_CODE_ARRAY
1040 || target_type
->code () == TYPE_CODE_STRING
1041 || target_type
->code () == TYPE_CODE_FUNC
)
1043 arg1
= value_ind (arg1
);
1044 type
= check_typedef (value_type (arg1
));
1045 code
= type
->code ();
1051 case TYPE_CODE_ARRAY
:
1052 case TYPE_CODE_STRING
:
1053 return fortran_value_subarray (arg1
, exp
, pos
, nargs
, noside
);
1056 case TYPE_CODE_FUNC
:
1057 case TYPE_CODE_INTERNAL_FUNCTION
:
1059 /* It's a function call. Allocate arg vector, including
1060 space for the function to be called in argvec[0] and a
1061 termination NULL. */
1062 struct value
**argvec
= (struct value
**)
1063 alloca (sizeof (struct value
*) * (nargs
+ 2));
1066 for (; tem
<= nargs
; tem
++)
1068 argvec
[tem
] = evaluate_subexp_with_coercion (exp
, pos
, noside
);
1069 /* Arguments in Fortran are passed by address. Coerce the
1070 arguments here rather than in value_arg_coerce as
1071 otherwise the call to malloc to place the non-lvalue
1072 parameters in target memory is hit by this Fortran
1073 specific logic. This results in malloc being called
1074 with a pointer to an integer followed by an attempt to
1075 malloc the arguments to malloc in target memory.
1076 Infinite recursion ensues. */
1077 if (code
== TYPE_CODE_PTR
|| code
== TYPE_CODE_FUNC
)
1080 = TYPE_FIELD_ARTIFICIAL (value_type (arg1
), tem
- 1);
1081 argvec
[tem
] = fortran_argument_convert (argvec
[tem
],
1085 argvec
[tem
] = 0; /* signal end of arglist */
1086 if (noside
== EVAL_SKIP
)
1087 return eval_skip_value (exp
);
1088 return evaluate_subexp_do_call (exp
, noside
, argvec
[0],
1089 gdb::make_array_view (argvec
+ 1,
1095 error (_("Cannot perform substring on this type"));
1099 /* Should be unreachable. */
1103 /* Special expression lengths for Fortran. */
1106 operator_length_f (const struct expression
*exp
, int pc
, int *oplenp
,
1112 switch (exp
->elts
[pc
- 1].opcode
)
1115 operator_length_standard (exp
, pc
, oplenp
, argsp
);
1118 case UNOP_FORTRAN_KIND
:
1119 case UNOP_FORTRAN_FLOOR
:
1120 case UNOP_FORTRAN_CEILING
:
1125 case BINOP_FORTRAN_CMPLX
:
1126 case BINOP_FORTRAN_MODULO
:
1131 case FORTRAN_LBOUND
:
1132 case FORTRAN_UBOUND
:
1134 args
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
1137 case OP_F77_UNDETERMINED_ARGLIST
:
1139 args
= 1 + longest_to_int (exp
->elts
[pc
- 2].longconst
);
1147 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1148 the extra argument NAME which is the text that should be printed as the
1149 name of this operation. */
1152 print_unop_subexp_f (struct expression
*exp
, int *pos
,
1153 struct ui_file
*stream
, enum precedence prec
,
1157 fprintf_filtered (stream
, "%s(", name
);
1158 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1159 fputs_filtered (")", stream
);
1162 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1163 the extra argument NAME which is the text that should be printed as the
1164 name of this operation. */
1167 print_binop_subexp_f (struct expression
*exp
, int *pos
,
1168 struct ui_file
*stream
, enum precedence prec
,
1172 fprintf_filtered (stream
, "%s(", name
);
1173 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1174 fputs_filtered (",", stream
);
1175 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1176 fputs_filtered (")", stream
);
1179 /* Special expression printing for Fortran. */
1182 print_subexp_f (struct expression
*exp
, int *pos
,
1183 struct ui_file
*stream
, enum precedence prec
)
1186 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
1191 print_subexp_standard (exp
, pos
, stream
, prec
);
1194 case UNOP_FORTRAN_KIND
:
1195 print_unop_subexp_f (exp
, pos
, stream
, prec
, "KIND");
1198 case UNOP_FORTRAN_FLOOR
:
1199 print_unop_subexp_f (exp
, pos
, stream
, prec
, "FLOOR");
1202 case UNOP_FORTRAN_CEILING
:
1203 print_unop_subexp_f (exp
, pos
, stream
, prec
, "CEILING");
1206 case BINOP_FORTRAN_CMPLX
:
1207 print_binop_subexp_f (exp
, pos
, stream
, prec
, "CMPLX");
1210 case BINOP_FORTRAN_MODULO
:
1211 print_binop_subexp_f (exp
, pos
, stream
, prec
, "MODULO");
1214 case FORTRAN_LBOUND
:
1215 case FORTRAN_UBOUND
:
1217 unsigned nargs
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
);
1219 fprintf_filtered (stream
, "%s (",
1220 ((op
== FORTRAN_LBOUND
) ? "LBOUND" : "UBOUND"));
1221 for (unsigned tem
= 0; tem
< nargs
; tem
++)
1224 fputs_filtered (", ", stream
);
1225 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
1227 fputs_filtered (")", stream
);
1231 case OP_F77_UNDETERMINED_ARGLIST
:
1233 print_subexp_funcall (exp
, pos
, stream
);
1238 /* Special expression dumping for Fortran. */
1241 dump_subexp_body_f (struct expression
*exp
,
1242 struct ui_file
*stream
, int elt
)
1244 int opcode
= exp
->elts
[elt
].opcode
;
1245 int oplen
, nargs
, i
;
1250 return dump_subexp_body_standard (exp
, stream
, elt
);
1252 case UNOP_FORTRAN_KIND
:
1253 case UNOP_FORTRAN_FLOOR
:
1254 case UNOP_FORTRAN_CEILING
:
1255 case BINOP_FORTRAN_CMPLX
:
1256 case BINOP_FORTRAN_MODULO
:
1257 operator_length_f (exp
, (elt
+ 1), &oplen
, &nargs
);
1260 case FORTRAN_LBOUND
:
1261 case FORTRAN_UBOUND
:
1262 operator_length_f (exp
, (elt
+ 3), &oplen
, &nargs
);
1265 case OP_F77_UNDETERMINED_ARGLIST
:
1266 return dump_subexp_body_funcall (exp
, stream
, elt
+ 1);
1270 for (i
= 0; i
< nargs
; i
+= 1)
1271 elt
= dump_subexp (exp
, stream
, elt
);
1276 /* Special expression checking for Fortran. */
1279 operator_check_f (struct expression
*exp
, int pos
,
1280 int (*objfile_func
) (struct objfile
*objfile
,
1284 const union exp_element
*const elts
= exp
->elts
;
1286 switch (elts
[pos
].opcode
)
1288 case UNOP_FORTRAN_KIND
:
1289 case UNOP_FORTRAN_FLOOR
:
1290 case UNOP_FORTRAN_CEILING
:
1291 case BINOP_FORTRAN_CMPLX
:
1292 case BINOP_FORTRAN_MODULO
:
1293 case FORTRAN_LBOUND
:
1294 case FORTRAN_UBOUND
:
1295 /* Any references to objfiles are held in the arguments to this
1296 expression, not within the expression itself, so no additional
1297 checking is required here, the outer expression iteration code
1298 will take care of checking each argument. */
1302 return operator_check_standard (exp
, pos
, objfile_func
, data
);
1308 /* Expression processing for Fortran. */
1309 const struct exp_descriptor
f_language::exp_descriptor_tab
=
1318 /* See language.h. */
1321 f_language::language_arch_info (struct gdbarch
*gdbarch
,
1322 struct language_arch_info
*lai
) const
1324 const struct builtin_f_type
*builtin
= builtin_f_type (gdbarch
);
1326 /* Helper function to allow shorter lines below. */
1327 auto add
= [&] (struct type
* t
)
1329 lai
->add_primitive_type (t
);
1332 add (builtin
->builtin_character
);
1333 add (builtin
->builtin_logical
);
1334 add (builtin
->builtin_logical_s1
);
1335 add (builtin
->builtin_logical_s2
);
1336 add (builtin
->builtin_logical_s8
);
1337 add (builtin
->builtin_real
);
1338 add (builtin
->builtin_real_s8
);
1339 add (builtin
->builtin_real_s16
);
1340 add (builtin
->builtin_complex_s8
);
1341 add (builtin
->builtin_complex_s16
);
1342 add (builtin
->builtin_void
);
1344 lai
->set_string_char_type (builtin
->builtin_character
);
1345 lai
->set_bool_type (builtin
->builtin_logical_s2
, "logical");
1348 /* See language.h. */
1351 f_language::search_name_hash (const char *name
) const
1353 return cp_search_name_hash (name
);
1356 /* See language.h. */
1359 f_language::lookup_symbol_nonlocal (const char *name
,
1360 const struct block
*block
,
1361 const domain_enum domain
) const
1363 return cp_lookup_symbol_nonlocal (this, name
, block
, domain
);
1366 /* See language.h. */
1368 symbol_name_matcher_ftype
*
1369 f_language::get_symbol_name_matcher_inner
1370 (const lookup_name_info
&lookup_name
) const
1372 return cp_get_symbol_name_matcher (lookup_name
);
1375 /* Single instance of the Fortran language class. */
1377 static f_language f_language_defn
;
1380 build_fortran_types (struct gdbarch
*gdbarch
)
1382 struct builtin_f_type
*builtin_f_type
1383 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_f_type
);
1385 builtin_f_type
->builtin_void
1386 = arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
, "void");
1388 builtin_f_type
->builtin_character
1389 = arch_type (gdbarch
, TYPE_CODE_CHAR
, TARGET_CHAR_BIT
, "character");
1391 builtin_f_type
->builtin_logical_s1
1392 = arch_boolean_type (gdbarch
, TARGET_CHAR_BIT
, 1, "logical*1");
1394 builtin_f_type
->builtin_integer_s2
1395 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
), 0,
1398 builtin_f_type
->builtin_integer_s8
1399 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 0,
1402 builtin_f_type
->builtin_logical_s2
1403 = arch_boolean_type (gdbarch
, gdbarch_short_bit (gdbarch
), 1,
1406 builtin_f_type
->builtin_logical_s8
1407 = arch_boolean_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 1,
1410 builtin_f_type
->builtin_integer
1411 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 0,
1414 builtin_f_type
->builtin_logical
1415 = arch_boolean_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1,
1418 builtin_f_type
->builtin_real
1419 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
1420 "real", gdbarch_float_format (gdbarch
));
1421 builtin_f_type
->builtin_real_s8
1422 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
1423 "real*8", gdbarch_double_format (gdbarch
));
1424 auto fmt
= gdbarch_floatformat_for_type (gdbarch
, "real(kind=16)", 128);
1426 builtin_f_type
->builtin_real_s16
1427 = arch_float_type (gdbarch
, 128, "real*16", fmt
);
1428 else if (gdbarch_long_double_bit (gdbarch
) == 128)
1429 builtin_f_type
->builtin_real_s16
1430 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
1431 "real*16", gdbarch_long_double_format (gdbarch
));
1433 builtin_f_type
->builtin_real_s16
1434 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 128, "real*16");
1436 builtin_f_type
->builtin_complex_s8
1437 = init_complex_type ("complex*8", builtin_f_type
->builtin_real
);
1438 builtin_f_type
->builtin_complex_s16
1439 = init_complex_type ("complex*16", builtin_f_type
->builtin_real_s8
);
1441 if (builtin_f_type
->builtin_real_s16
->code () == TYPE_CODE_ERROR
)
1442 builtin_f_type
->builtin_complex_s32
1443 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 256, "complex*32");
1445 builtin_f_type
->builtin_complex_s32
1446 = init_complex_type ("complex*32", builtin_f_type
->builtin_real_s16
);
1448 return builtin_f_type
;
1451 static struct gdbarch_data
*f_type_data
;
1453 const struct builtin_f_type
*
1454 builtin_f_type (struct gdbarch
*gdbarch
)
1456 return (const struct builtin_f_type
*) gdbarch_data (gdbarch
, f_type_data
);
1459 /* Command-list for the "set/show fortran" prefix command. */
1460 static struct cmd_list_element
*set_fortran_list
;
1461 static struct cmd_list_element
*show_fortran_list
;
1463 void _initialize_f_language ();
1465 _initialize_f_language ()
1467 f_type_data
= gdbarch_data_register_post_init (build_fortran_types
);
1469 add_basic_prefix_cmd ("fortran", no_class
,
1470 _("Prefix command for changing Fortran-specific settings."),
1471 &set_fortran_list
, "set fortran ", 0, &setlist
);
1473 add_show_prefix_cmd ("fortran", no_class
,
1474 _("Generic command for showing Fortran-specific settings."),
1475 &show_fortran_list
, "show fortran ", 0, &showlist
);
1477 add_setshow_boolean_cmd ("repack-array-slices", class_vars
,
1478 &repack_array_slices
, _("\
1479 Enable or disable repacking of non-contiguous array slices."), _("\
1480 Show whether non-contiguous array slices are repacked."), _("\
1481 When the user requests a slice of a Fortran array then we can either return\n\
1482 a descriptor that describes the array in place (using the original array data\n\
1483 in its existing location) or the original data can be repacked (copied) to a\n\
1486 When the content of the array slice is contiguous within the original array\n\
1487 then the result will never be repacked, but when the data for the new array\n\
1488 is non-contiguous within the original array repacking will only be performed\n\
1489 when this setting is on."),
1491 show_repack_array_slices
,
1492 &set_fortran_list
, &show_fortran_list
);
1494 /* Debug Fortran's array slicing logic. */
1495 add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance
,
1496 &fortran_array_slicing_debug
, _("\
1497 Set debugging of Fortran array slicing."), _("\
1498 Show debugging of Fortran array slicing."), _("\
1499 When on, debugging of Fortran array slicing is enabled."),
1501 show_fortran_array_slicing_debug
,
1502 &setdebuglist
, &showdebuglist
);
1505 /* Ensures that function argument VALUE is in the appropriate form to
1506 pass to a Fortran function. Returns a possibly new value that should
1507 be used instead of VALUE.
1509 When IS_ARTIFICIAL is true this indicates an artificial argument,
1510 e.g. hidden string lengths which the GNU Fortran argument passing
1511 convention specifies as being passed by value.
1513 When IS_ARTIFICIAL is false, the argument is passed by pointer. If the
1514 value is already in target memory then return a value that is a pointer
1515 to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate
1516 space in the target, copy VALUE in, and return a pointer to the in
1519 static struct value
*
1520 fortran_argument_convert (struct value
*value
, bool is_artificial
)
1524 /* If the value is not in the inferior e.g. registers values,
1525 convenience variables and user input. */
1526 if (VALUE_LVAL (value
) != lval_memory
)
1528 struct type
*type
= value_type (value
);
1529 const int length
= TYPE_LENGTH (type
);
1530 const CORE_ADDR addr
1531 = value_as_long (value_allocate_space_in_inferior (length
));
1532 write_memory (addr
, value_contents (value
), length
);
1534 = value_from_contents_and_address (type
, value_contents (value
),
1536 return value_addr (val
);
1539 return value_addr (value
); /* Program variables, e.g. arrays. */
1547 fortran_preserve_arg_pointer (struct value
*arg
, struct type
*type
)
1549 if (value_type (arg
)->code () == TYPE_CODE_PTR
)
1550 return value_type (arg
);
1557 fortran_adjust_dynamic_array_base_address_hack (struct type
*type
,
1560 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
1562 /* We can't adjust the base address for arrays that have no content. */
1563 if (type_not_allocated (type
) || type_not_associated (type
))
1566 int ndimensions
= calc_f77_array_dims (type
);
1567 LONGEST total_offset
= 0;
1569 /* Walk through each of the dimensions of this array type and figure out
1570 if any of the dimensions are "backwards", that is the base address
1571 for this dimension points to the element at the highest memory
1572 address and the stride is negative. */
1573 struct type
*tmp_type
= type
;
1574 for (int i
= 0 ; i
< ndimensions
; ++i
)
1576 /* Grab the range for this dimension and extract the lower and upper
1578 tmp_type
= check_typedef (tmp_type
);
1579 struct type
*range_type
= tmp_type
->index_type ();
1580 LONGEST lowerbound
, upperbound
, stride
;
1581 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
1582 error ("failed to get range bounds");
1584 /* Figure out the stride for this dimension. */
1585 struct type
*elt_type
= check_typedef (TYPE_TARGET_TYPE (tmp_type
));
1586 stride
= tmp_type
->index_type ()->bounds ()->bit_stride ();
1588 stride
= type_length_units (elt_type
);
1592 = gdbarch_addressable_memory_unit_size (elt_type
->arch ());
1593 stride
/= (unit_size
* 8);
1596 /* If this dimension is "backward" then figure out the offset
1597 adjustment required to point to the element at the lowest memory
1598 address, and add this to the total offset. */
1600 if (stride
< 0 && lowerbound
< upperbound
)
1601 offset
= (upperbound
- lowerbound
) * stride
;
1602 total_offset
+= offset
;
1603 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
1606 /* Adjust the address of this object and return it. */
1607 address
+= total_offset
;