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 UNOP_FORTRAN_ALLOCATED
:
911 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
912 if (noside
== EVAL_SKIP
)
913 return eval_skip_value (exp
);
914 type
= check_typedef (value_type (arg1
));
915 if (type
->code () != TYPE_CODE_ARRAY
)
916 error (_("ALLOCATED can only be applied to arrays"));
917 struct type
*result_type
918 = builtin_f_type (exp
->gdbarch
)->builtin_logical
;
919 LONGEST result_value
= type_not_allocated (type
) ? 0 : 1;
920 return value_from_longest (result_type
, result_value
);
923 case BINOP_FORTRAN_MODULO
:
925 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
926 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
927 if (noside
== EVAL_SKIP
)
928 return eval_skip_value (exp
);
929 type
= value_type (arg1
);
930 if (type
->code () != value_type (arg2
)->code ())
931 error (_("non-matching types for parameters to MODULO ()"));
932 /* MODULO(A, P) = A - FLOOR (A / P) * P */
933 switch (type
->code ())
937 LONGEST a
= value_as_long (arg1
);
938 LONGEST p
= value_as_long (arg2
);
939 LONGEST result
= a
- (a
/ p
) * p
;
940 if (result
!= 0 && (a
< 0) != (p
< 0))
942 return value_from_longest (value_type (arg1
), result
);
947 = target_float_to_host_double (value_contents (arg1
),
950 = target_float_to_host_double (value_contents (arg2
),
952 double result
= fmod (a
, p
);
953 if (result
!= 0 && (a
< 0.0) != (p
< 0.0))
955 return value_from_host_double (type
, result
);
958 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type
));
964 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
967 /* This assertion should be enforced by the expression parser. */
968 gdb_assert (nargs
== 1 || nargs
== 2);
970 bool lbound_p
= op
== FORTRAN_LBOUND
;
972 /* Check that the first argument is array like. */
973 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
974 type
= check_typedef (value_type (arg1
));
975 if (type
->code () != TYPE_CODE_ARRAY
)
978 error (_("LBOUND can only be applied to arrays"));
980 error (_("UBOUND can only be applied to arrays"));
984 return fortran_bounds_all_dims (lbound_p
, exp
->gdbarch
, arg1
);
986 /* User asked for the bounds of a specific dimension of the array. */
987 arg2
= evaluate_subexp (nullptr, exp
, pos
, noside
);
988 type
= check_typedef (value_type (arg2
));
989 if (type
->code () != TYPE_CODE_INT
)
992 error (_("LBOUND second argument should be an integer"));
994 error (_("UBOUND second argument should be an integer"));
997 return fortran_bounds_for_dimension (lbound_p
, exp
->gdbarch
, arg1
,
1002 case BINOP_FORTRAN_CMPLX
:
1003 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1004 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
1005 if (noside
== EVAL_SKIP
)
1006 return eval_skip_value (exp
);
1007 type
= builtin_f_type(exp
->gdbarch
)->builtin_complex_s16
;
1008 return value_literal_complex (arg1
, arg2
, type
);
1010 case UNOP_FORTRAN_KIND
:
1011 arg1
= evaluate_subexp (NULL
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
1012 type
= value_type (arg1
);
1014 switch (type
->code ())
1016 case TYPE_CODE_STRUCT
:
1017 case TYPE_CODE_UNION
:
1018 case TYPE_CODE_MODULE
:
1019 case TYPE_CODE_FUNC
:
1020 error (_("argument to kind must be an intrinsic type"));
1023 if (!TYPE_TARGET_TYPE (type
))
1024 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1025 TYPE_LENGTH (type
));
1026 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
1027 TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
1030 case OP_F77_UNDETERMINED_ARGLIST
:
1031 /* Remember that in F77, functions, substring ops and array subscript
1032 operations cannot be disambiguated at parse time. We have made
1033 all array subscript operations, substring operations as well as
1034 function calls come here and we now have to discover what the heck
1035 this thing actually was. If it is a function, we process just as
1036 if we got an OP_FUNCALL. */
1037 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
1040 /* First determine the type code we are dealing with. */
1041 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
1042 type
= check_typedef (value_type (arg1
));
1043 enum type_code code
= type
->code ();
1045 if (code
== TYPE_CODE_PTR
)
1047 /* Fortran always passes variable to subroutines as pointer.
1048 So we need to look into its target type to see if it is
1049 array, string or function. If it is, we need to switch
1050 to the target value the original one points to. */
1051 struct type
*target_type
= check_typedef (TYPE_TARGET_TYPE (type
));
1053 if (target_type
->code () == TYPE_CODE_ARRAY
1054 || target_type
->code () == TYPE_CODE_STRING
1055 || target_type
->code () == TYPE_CODE_FUNC
)
1057 arg1
= value_ind (arg1
);
1058 type
= check_typedef (value_type (arg1
));
1059 code
= type
->code ();
1065 case TYPE_CODE_ARRAY
:
1066 case TYPE_CODE_STRING
:
1067 return fortran_value_subarray (arg1
, exp
, pos
, nargs
, noside
);
1070 case TYPE_CODE_FUNC
:
1071 case TYPE_CODE_INTERNAL_FUNCTION
:
1073 /* It's a function call. Allocate arg vector, including
1074 space for the function to be called in argvec[0] and a
1075 termination NULL. */
1076 struct value
**argvec
= (struct value
**)
1077 alloca (sizeof (struct value
*) * (nargs
+ 2));
1080 for (; tem
<= nargs
; tem
++)
1082 argvec
[tem
] = evaluate_subexp_with_coercion (exp
, pos
, noside
);
1083 /* Arguments in Fortran are passed by address. Coerce the
1084 arguments here rather than in value_arg_coerce as
1085 otherwise the call to malloc to place the non-lvalue
1086 parameters in target memory is hit by this Fortran
1087 specific logic. This results in malloc being called
1088 with a pointer to an integer followed by an attempt to
1089 malloc the arguments to malloc in target memory.
1090 Infinite recursion ensues. */
1091 if (code
== TYPE_CODE_PTR
|| code
== TYPE_CODE_FUNC
)
1094 = TYPE_FIELD_ARTIFICIAL (value_type (arg1
), tem
- 1);
1095 argvec
[tem
] = fortran_argument_convert (argvec
[tem
],
1099 argvec
[tem
] = 0; /* signal end of arglist */
1100 if (noside
== EVAL_SKIP
)
1101 return eval_skip_value (exp
);
1102 return evaluate_subexp_do_call (exp
, noside
, argvec
[0],
1103 gdb::make_array_view (argvec
+ 1,
1109 error (_("Cannot perform substring on this type"));
1113 /* Should be unreachable. */
1117 /* Special expression lengths for Fortran. */
1120 operator_length_f (const struct expression
*exp
, int pc
, int *oplenp
,
1126 switch (exp
->elts
[pc
- 1].opcode
)
1129 operator_length_standard (exp
, pc
, oplenp
, argsp
);
1132 case UNOP_FORTRAN_KIND
:
1133 case UNOP_FORTRAN_FLOOR
:
1134 case UNOP_FORTRAN_CEILING
:
1135 case UNOP_FORTRAN_ALLOCATED
:
1140 case BINOP_FORTRAN_CMPLX
:
1141 case BINOP_FORTRAN_MODULO
:
1146 case FORTRAN_LBOUND
:
1147 case FORTRAN_UBOUND
:
1149 args
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
1152 case OP_F77_UNDETERMINED_ARGLIST
:
1154 args
= 1 + longest_to_int (exp
->elts
[pc
- 2].longconst
);
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_unop_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
);
1177 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
1178 the extra argument NAME which is the text that should be printed as the
1179 name of this operation. */
1182 print_binop_subexp_f (struct expression
*exp
, int *pos
,
1183 struct ui_file
*stream
, enum precedence prec
,
1187 fprintf_filtered (stream
, "%s(", name
);
1188 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1189 fputs_filtered (",", stream
);
1190 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
1191 fputs_filtered (")", stream
);
1194 /* Special expression printing for Fortran. */
1197 print_subexp_f (struct expression
*exp
, int *pos
,
1198 struct ui_file
*stream
, enum precedence prec
)
1201 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
1206 print_subexp_standard (exp
, pos
, stream
, prec
);
1209 case UNOP_FORTRAN_KIND
:
1210 print_unop_subexp_f (exp
, pos
, stream
, prec
, "KIND");
1213 case UNOP_FORTRAN_FLOOR
:
1214 print_unop_subexp_f (exp
, pos
, stream
, prec
, "FLOOR");
1217 case UNOP_FORTRAN_CEILING
:
1218 print_unop_subexp_f (exp
, pos
, stream
, prec
, "CEILING");
1221 case UNOP_FORTRAN_ALLOCATED
:
1222 print_unop_subexp_f (exp
, pos
, stream
, prec
, "ALLOCATED");
1225 case BINOP_FORTRAN_CMPLX
:
1226 print_binop_subexp_f (exp
, pos
, stream
, prec
, "CMPLX");
1229 case BINOP_FORTRAN_MODULO
:
1230 print_binop_subexp_f (exp
, pos
, stream
, prec
, "MODULO");
1233 case FORTRAN_LBOUND
:
1234 case FORTRAN_UBOUND
:
1236 unsigned nargs
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
);
1238 fprintf_filtered (stream
, "%s (",
1239 ((op
== FORTRAN_LBOUND
) ? "LBOUND" : "UBOUND"));
1240 for (unsigned tem
= 0; tem
< nargs
; tem
++)
1243 fputs_filtered (", ", stream
);
1244 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
1246 fputs_filtered (")", stream
);
1250 case OP_F77_UNDETERMINED_ARGLIST
:
1252 print_subexp_funcall (exp
, pos
, stream
);
1257 /* Special expression dumping for Fortran. */
1260 dump_subexp_body_f (struct expression
*exp
,
1261 struct ui_file
*stream
, int elt
)
1263 int opcode
= exp
->elts
[elt
].opcode
;
1264 int oplen
, nargs
, i
;
1269 return dump_subexp_body_standard (exp
, stream
, elt
);
1271 case UNOP_FORTRAN_KIND
:
1272 case UNOP_FORTRAN_FLOOR
:
1273 case UNOP_FORTRAN_CEILING
:
1274 case UNOP_FORTRAN_ALLOCATED
:
1275 case BINOP_FORTRAN_CMPLX
:
1276 case BINOP_FORTRAN_MODULO
:
1277 operator_length_f (exp
, (elt
+ 1), &oplen
, &nargs
);
1280 case FORTRAN_LBOUND
:
1281 case FORTRAN_UBOUND
:
1282 operator_length_f (exp
, (elt
+ 3), &oplen
, &nargs
);
1285 case OP_F77_UNDETERMINED_ARGLIST
:
1286 return dump_subexp_body_funcall (exp
, stream
, elt
+ 1);
1290 for (i
= 0; i
< nargs
; i
+= 1)
1291 elt
= dump_subexp (exp
, stream
, elt
);
1296 /* Special expression checking for Fortran. */
1299 operator_check_f (struct expression
*exp
, int pos
,
1300 int (*objfile_func
) (struct objfile
*objfile
,
1304 const union exp_element
*const elts
= exp
->elts
;
1306 switch (elts
[pos
].opcode
)
1308 case UNOP_FORTRAN_KIND
:
1309 case UNOP_FORTRAN_FLOOR
:
1310 case UNOP_FORTRAN_CEILING
:
1311 case UNOP_FORTRAN_ALLOCATED
:
1312 case BINOP_FORTRAN_CMPLX
:
1313 case BINOP_FORTRAN_MODULO
:
1314 case FORTRAN_LBOUND
:
1315 case FORTRAN_UBOUND
:
1316 /* Any references to objfiles are held in the arguments to this
1317 expression, not within the expression itself, so no additional
1318 checking is required here, the outer expression iteration code
1319 will take care of checking each argument. */
1323 return operator_check_standard (exp
, pos
, objfile_func
, data
);
1329 /* Expression processing for Fortran. */
1330 const struct exp_descriptor
f_language::exp_descriptor_tab
=
1339 /* See language.h. */
1342 f_language::language_arch_info (struct gdbarch
*gdbarch
,
1343 struct language_arch_info
*lai
) const
1345 const struct builtin_f_type
*builtin
= builtin_f_type (gdbarch
);
1347 /* Helper function to allow shorter lines below. */
1348 auto add
= [&] (struct type
* t
)
1350 lai
->add_primitive_type (t
);
1353 add (builtin
->builtin_character
);
1354 add (builtin
->builtin_logical
);
1355 add (builtin
->builtin_logical_s1
);
1356 add (builtin
->builtin_logical_s2
);
1357 add (builtin
->builtin_logical_s8
);
1358 add (builtin
->builtin_real
);
1359 add (builtin
->builtin_real_s8
);
1360 add (builtin
->builtin_real_s16
);
1361 add (builtin
->builtin_complex_s8
);
1362 add (builtin
->builtin_complex_s16
);
1363 add (builtin
->builtin_void
);
1365 lai
->set_string_char_type (builtin
->builtin_character
);
1366 lai
->set_bool_type (builtin
->builtin_logical_s2
, "logical");
1369 /* See language.h. */
1372 f_language::search_name_hash (const char *name
) const
1374 return cp_search_name_hash (name
);
1377 /* See language.h. */
1380 f_language::lookup_symbol_nonlocal (const char *name
,
1381 const struct block
*block
,
1382 const domain_enum domain
) const
1384 return cp_lookup_symbol_nonlocal (this, name
, block
, domain
);
1387 /* See language.h. */
1389 symbol_name_matcher_ftype
*
1390 f_language::get_symbol_name_matcher_inner
1391 (const lookup_name_info
&lookup_name
) const
1393 return cp_get_symbol_name_matcher (lookup_name
);
1396 /* Single instance of the Fortran language class. */
1398 static f_language f_language_defn
;
1401 build_fortran_types (struct gdbarch
*gdbarch
)
1403 struct builtin_f_type
*builtin_f_type
1404 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_f_type
);
1406 builtin_f_type
->builtin_void
1407 = arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
, "void");
1409 builtin_f_type
->builtin_character
1410 = arch_type (gdbarch
, TYPE_CODE_CHAR
, TARGET_CHAR_BIT
, "character");
1412 builtin_f_type
->builtin_logical_s1
1413 = arch_boolean_type (gdbarch
, TARGET_CHAR_BIT
, 1, "logical*1");
1415 builtin_f_type
->builtin_integer_s2
1416 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
), 0,
1419 builtin_f_type
->builtin_integer_s8
1420 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 0,
1423 builtin_f_type
->builtin_logical_s2
1424 = arch_boolean_type (gdbarch
, gdbarch_short_bit (gdbarch
), 1,
1427 builtin_f_type
->builtin_logical_s8
1428 = arch_boolean_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 1,
1431 builtin_f_type
->builtin_integer
1432 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 0,
1435 builtin_f_type
->builtin_logical
1436 = arch_boolean_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1,
1439 builtin_f_type
->builtin_real
1440 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
1441 "real", gdbarch_float_format (gdbarch
));
1442 builtin_f_type
->builtin_real_s8
1443 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
1444 "real*8", gdbarch_double_format (gdbarch
));
1445 auto fmt
= gdbarch_floatformat_for_type (gdbarch
, "real(kind=16)", 128);
1447 builtin_f_type
->builtin_real_s16
1448 = arch_float_type (gdbarch
, 128, "real*16", fmt
);
1449 else if (gdbarch_long_double_bit (gdbarch
) == 128)
1450 builtin_f_type
->builtin_real_s16
1451 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
1452 "real*16", gdbarch_long_double_format (gdbarch
));
1454 builtin_f_type
->builtin_real_s16
1455 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 128, "real*16");
1457 builtin_f_type
->builtin_complex_s8
1458 = init_complex_type ("complex*8", builtin_f_type
->builtin_real
);
1459 builtin_f_type
->builtin_complex_s16
1460 = init_complex_type ("complex*16", builtin_f_type
->builtin_real_s8
);
1462 if (builtin_f_type
->builtin_real_s16
->code () == TYPE_CODE_ERROR
)
1463 builtin_f_type
->builtin_complex_s32
1464 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 256, "complex*32");
1466 builtin_f_type
->builtin_complex_s32
1467 = init_complex_type ("complex*32", builtin_f_type
->builtin_real_s16
);
1469 return builtin_f_type
;
1472 static struct gdbarch_data
*f_type_data
;
1474 const struct builtin_f_type
*
1475 builtin_f_type (struct gdbarch
*gdbarch
)
1477 return (const struct builtin_f_type
*) gdbarch_data (gdbarch
, f_type_data
);
1480 /* Command-list for the "set/show fortran" prefix command. */
1481 static struct cmd_list_element
*set_fortran_list
;
1482 static struct cmd_list_element
*show_fortran_list
;
1484 void _initialize_f_language ();
1486 _initialize_f_language ()
1488 f_type_data
= gdbarch_data_register_post_init (build_fortran_types
);
1490 add_basic_prefix_cmd ("fortran", no_class
,
1491 _("Prefix command for changing Fortran-specific settings."),
1492 &set_fortran_list
, "set fortran ", 0, &setlist
);
1494 add_show_prefix_cmd ("fortran", no_class
,
1495 _("Generic command for showing Fortran-specific settings."),
1496 &show_fortran_list
, "show fortran ", 0, &showlist
);
1498 add_setshow_boolean_cmd ("repack-array-slices", class_vars
,
1499 &repack_array_slices
, _("\
1500 Enable or disable repacking of non-contiguous array slices."), _("\
1501 Show whether non-contiguous array slices are repacked."), _("\
1502 When the user requests a slice of a Fortran array then we can either return\n\
1503 a descriptor that describes the array in place (using the original array data\n\
1504 in its existing location) or the original data can be repacked (copied) to a\n\
1507 When the content of the array slice is contiguous within the original array\n\
1508 then the result will never be repacked, but when the data for the new array\n\
1509 is non-contiguous within the original array repacking will only be performed\n\
1510 when this setting is on."),
1512 show_repack_array_slices
,
1513 &set_fortran_list
, &show_fortran_list
);
1515 /* Debug Fortran's array slicing logic. */
1516 add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance
,
1517 &fortran_array_slicing_debug
, _("\
1518 Set debugging of Fortran array slicing."), _("\
1519 Show debugging of Fortran array slicing."), _("\
1520 When on, debugging of Fortran array slicing is enabled."),
1522 show_fortran_array_slicing_debug
,
1523 &setdebuglist
, &showdebuglist
);
1526 /* Ensures that function argument VALUE is in the appropriate form to
1527 pass to a Fortran function. Returns a possibly new value that should
1528 be used instead of VALUE.
1530 When IS_ARTIFICIAL is true this indicates an artificial argument,
1531 e.g. hidden string lengths which the GNU Fortran argument passing
1532 convention specifies as being passed by value.
1534 When IS_ARTIFICIAL is false, the argument is passed by pointer. If the
1535 value is already in target memory then return a value that is a pointer
1536 to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate
1537 space in the target, copy VALUE in, and return a pointer to the in
1540 static struct value
*
1541 fortran_argument_convert (struct value
*value
, bool is_artificial
)
1545 /* If the value is not in the inferior e.g. registers values,
1546 convenience variables and user input. */
1547 if (VALUE_LVAL (value
) != lval_memory
)
1549 struct type
*type
= value_type (value
);
1550 const int length
= TYPE_LENGTH (type
);
1551 const CORE_ADDR addr
1552 = value_as_long (value_allocate_space_in_inferior (length
));
1553 write_memory (addr
, value_contents (value
), length
);
1555 = value_from_contents_and_address (type
, value_contents (value
),
1557 return value_addr (val
);
1560 return value_addr (value
); /* Program variables, e.g. arrays. */
1568 fortran_preserve_arg_pointer (struct value
*arg
, struct type
*type
)
1570 if (value_type (arg
)->code () == TYPE_CODE_PTR
)
1571 return value_type (arg
);
1578 fortran_adjust_dynamic_array_base_address_hack (struct type
*type
,
1581 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
1583 /* We can't adjust the base address for arrays that have no content. */
1584 if (type_not_allocated (type
) || type_not_associated (type
))
1587 int ndimensions
= calc_f77_array_dims (type
);
1588 LONGEST total_offset
= 0;
1590 /* Walk through each of the dimensions of this array type and figure out
1591 if any of the dimensions are "backwards", that is the base address
1592 for this dimension points to the element at the highest memory
1593 address and the stride is negative. */
1594 struct type
*tmp_type
= type
;
1595 for (int i
= 0 ; i
< ndimensions
; ++i
)
1597 /* Grab the range for this dimension and extract the lower and upper
1599 tmp_type
= check_typedef (tmp_type
);
1600 struct type
*range_type
= tmp_type
->index_type ();
1601 LONGEST lowerbound
, upperbound
, stride
;
1602 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
1603 error ("failed to get range bounds");
1605 /* Figure out the stride for this dimension. */
1606 struct type
*elt_type
= check_typedef (TYPE_TARGET_TYPE (tmp_type
));
1607 stride
= tmp_type
->index_type ()->bounds ()->bit_stride ();
1609 stride
= type_length_units (elt_type
);
1613 = gdbarch_addressable_memory_unit_size (elt_type
->arch ());
1614 stride
/= (unit_size
* 8);
1617 /* If this dimension is "backward" then figure out the offset
1618 adjustment required to point to the element at the lowest memory
1619 address, and add this to the total offset. */
1621 if (stride
< 0 && lowerbound
< upperbound
)
1622 offset
= (upperbound
- lowerbound
) * stride
;
1623 total_offset
+= offset
;
1624 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
1627 /* Adjust the address of this object and return it. */
1628 address
+= total_offset
;