1 /* Fortran language support routines for GDB, the GNU debugger. 2 3 Copyright (C) 1993-2023 Free Software Foundation, Inc. 4 5 Contributed by Motorola. Adapted from the C parser by Farooq Butt 6 (fmbutt@engage.sps.mot.com). 7 8 This file is part of GDB. 9 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. 14 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. 19 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/>. */ 22 23 #include "defs.h" 24 #include "symtab.h" 25 #include "gdbtypes.h" 26 #include "expression.h" 27 #include "parser-defs.h" 28 #include "language.h" 29 #include "varobj.h" 30 #include "gdbcore.h" 31 #include "f-lang.h" 32 #include "valprint.h" 33 #include "value.h" 34 #include "cp-support.h" 35 #include "charset.h" 36 #include "c-lang.h" 37 #include "target-float.h" 38 #include "gdbarch.h" 39 #include "gdbcmd.h" 40 #include "f-array-walker.h" 41 #include "f-exp.h" 42 43 #include <math.h> 44 45 /* Whether GDB should repack array slices created by the user. */ 46 static bool repack_array_slices = false; 47 48 /* Implement 'show fortran repack-array-slices'. */ 49 static void 50 show_repack_array_slices (struct ui_file *file, int from_tty, 51 struct cmd_list_element *c, const char *value) 52 { 53 gdb_printf (file, _("Repacking of Fortran array slices is %s.\n"), 54 value); 55 } 56 57 /* Debugging of Fortran's array slicing. */ 58 static bool fortran_array_slicing_debug = false; 59 60 /* Implement 'show debug fortran-array-slicing'. */ 61 static void 62 show_fortran_array_slicing_debug (struct ui_file *file, int from_tty, 63 struct cmd_list_element *c, 64 const char *value) 65 { 66 gdb_printf (file, _("Debugging of Fortran array slicing is %s.\n"), 67 value); 68 } 69 70 /* Local functions */ 71 72 static value *fortran_prepare_argument (struct expression *exp, 73 expr::operation *subexp, 74 int arg_num, bool is_internal_call_p, 75 struct type *func_type, enum noside noside); 76 77 /* Return the encoding that should be used for the character type 78 TYPE. */ 79 80 const char * 81 f_language::get_encoding (struct type *type) 82 { 83 const char *encoding; 84 85 switch (type->length ()) 86 { 87 case 1: 88 encoding = target_charset (type->arch ()); 89 break; 90 case 4: 91 if (type_byte_order (type) == BFD_ENDIAN_BIG) 92 encoding = "UTF-32BE"; 93 else 94 encoding = "UTF-32LE"; 95 break; 96 97 default: 98 error (_("unrecognized character type")); 99 } 100 101 return encoding; 102 } 103 104 /* A helper function for the "bound" intrinsics that checks that TYPE 105 is an array. LBOUND_P is true for lower bound; this is used for 106 the error message, if any. */ 107 108 static void 109 fortran_require_array (struct type *type, bool lbound_p) 110 { 111 type = check_typedef (type); 112 if (type->code () != TYPE_CODE_ARRAY) 113 { 114 if (lbound_p) 115 error (_("LBOUND can only be applied to arrays")); 116 else 117 error (_("UBOUND can only be applied to arrays")); 118 } 119 } 120 121 /* Create an array containing the lower bounds (when LBOUND_P is true) or 122 the upper bounds (when LBOUND_P is false) of ARRAY (which must be of 123 array type). GDBARCH is the current architecture. */ 124 125 static struct value * 126 fortran_bounds_all_dims (bool lbound_p, 127 struct gdbarch *gdbarch, 128 struct value *array) 129 { 130 type *array_type = check_typedef (value_type (array)); 131 int ndimensions = calc_f77_array_dims (array_type); 132 133 /* Allocate a result value of the correct type. */ 134 struct type *range 135 = create_static_range_type (nullptr, 136 builtin_f_type (gdbarch)->builtin_integer, 137 1, ndimensions); 138 struct type *elm_type = builtin_f_type (gdbarch)->builtin_integer; 139 struct type *result_type = create_array_type (nullptr, elm_type, range); 140 struct value *result = allocate_value (result_type); 141 142 /* Walk the array dimensions backwards due to the way the array will be 143 laid out in memory, the first dimension will be the most inner. */ 144 LONGEST elm_len = elm_type->length (); 145 for (LONGEST dst_offset = elm_len * (ndimensions - 1); 146 dst_offset >= 0; 147 dst_offset -= elm_len) 148 { 149 LONGEST b; 150 151 /* Grab the required bound. */ 152 if (lbound_p) 153 b = f77_get_lowerbound (array_type); 154 else 155 b = f77_get_upperbound (array_type); 156 157 /* And copy the value into the result value. */ 158 struct value *v = value_from_longest (elm_type, b); 159 gdb_assert (dst_offset + value_type (v)->length () 160 <= value_type (result)->length ()); 161 gdb_assert (value_type (v)->length () == elm_len); 162 value_contents_copy (result, dst_offset, v, 0, elm_len); 163 164 /* Peel another dimension of the array. */ 165 array_type = array_type->target_type (); 166 } 167 168 return result; 169 } 170 171 /* Return the lower bound (when LBOUND_P is true) or the upper bound (when 172 LBOUND_P is false) for dimension DIM_VAL (which must be an integer) of 173 ARRAY (which must be an array). RESULT_TYPE corresponds to the type kind 174 the function should be evaluated in. */ 175 176 static value * 177 fortran_bounds_for_dimension (bool lbound_p, value *array, value *dim_val, 178 type* result_type) 179 { 180 /* Check the requested dimension is valid for this array. */ 181 type *array_type = check_typedef (value_type (array)); 182 int ndimensions = calc_f77_array_dims (array_type); 183 long dim = value_as_long (dim_val); 184 if (dim < 1 || dim > ndimensions) 185 { 186 if (lbound_p) 187 error (_("LBOUND dimension must be from 1 to %d"), ndimensions); 188 else 189 error (_("UBOUND dimension must be from 1 to %d"), ndimensions); 190 } 191 192 /* Walk the dimensions backwards, due to the ordering in which arrays are 193 laid out the first dimension is the most inner. */ 194 for (int i = ndimensions - 1; i >= 0; --i) 195 { 196 /* If this is the requested dimension then we're done. Grab the 197 bounds and return. */ 198 if (i == dim - 1) 199 { 200 LONGEST b; 201 202 if (lbound_p) 203 b = f77_get_lowerbound (array_type); 204 else 205 b = f77_get_upperbound (array_type); 206 207 return value_from_longest (result_type, b); 208 } 209 210 /* Peel off another dimension of the array. */ 211 array_type = array_type->target_type (); 212 } 213 214 gdb_assert_not_reached ("failed to find matching dimension"); 215 } 216 217 /* Return the number of dimensions for a Fortran array or string. */ 218 219 int 220 calc_f77_array_dims (struct type *array_type) 221 { 222 int ndimen = 1; 223 struct type *tmp_type; 224 225 if ((array_type->code () == TYPE_CODE_STRING)) 226 return 1; 227 228 if ((array_type->code () != TYPE_CODE_ARRAY)) 229 error (_("Can't get dimensions for a non-array type")); 230 231 tmp_type = array_type; 232 233 while ((tmp_type = tmp_type->target_type ())) 234 { 235 if (tmp_type->code () == TYPE_CODE_ARRAY) 236 ++ndimen; 237 } 238 return ndimen; 239 } 240 241 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array 242 slices. This is a base class for two alternative repacking mechanisms, 243 one for when repacking from a lazy value, and one for repacking from a 244 non-lazy (already loaded) value. */ 245 class fortran_array_repacker_base_impl 246 : public fortran_array_walker_base_impl 247 { 248 public: 249 /* Constructor, DEST is the value we are repacking into. */ 250 fortran_array_repacker_base_impl (struct value *dest) 251 : m_dest (dest), 252 m_dest_offset (0) 253 { /* Nothing. */ } 254 255 /* When we start processing the inner most dimension, this is where we 256 will be creating values for each element as we load them and then copy 257 them into the M_DEST value. Set a value mark so we can free these 258 temporary values. */ 259 void start_dimension (struct type *index_type, LONGEST nelts, bool inner_p) 260 { 261 if (inner_p) 262 { 263 gdb_assert (m_mark == nullptr); 264 m_mark = value_mark (); 265 } 266 } 267 268 /* When we finish processing the inner most dimension free all temporary 269 value that were created. */ 270 void finish_dimension (bool inner_p, bool last_p) 271 { 272 if (inner_p) 273 { 274 gdb_assert (m_mark != nullptr); 275 value_free_to_mark (m_mark); 276 m_mark = nullptr; 277 } 278 } 279 280 protected: 281 /* Copy the contents of array element ELT into M_DEST at the next 282 available offset. */ 283 void copy_element_to_dest (struct value *elt) 284 { 285 value_contents_copy (m_dest, m_dest_offset, elt, 0, 286 value_type (elt)->length ()); 287 m_dest_offset += value_type (elt)->length (); 288 } 289 290 /* The value being written to. */ 291 struct value *m_dest; 292 293 /* The byte offset in M_DEST at which the next element should be 294 written. */ 295 LONGEST m_dest_offset; 296 297 /* Set with a call to VALUE_MARK, and then reset after calling 298 VALUE_FREE_TO_MARK. */ 299 struct value *m_mark = nullptr; 300 }; 301 302 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array 303 slices. This class is specialised for repacking an array slice from a 304 lazy array value, as such it does not require the parent array value to 305 be loaded into GDB's memory; the parent value could be huge, while the 306 slice could be tiny. */ 307 class fortran_lazy_array_repacker_impl 308 : public fortran_array_repacker_base_impl 309 { 310 public: 311 /* Constructor. TYPE is the type of the slice being loaded from the 312 parent value, so this type will correctly reflect the strides required 313 to find all of the elements from the parent value. ADDRESS is the 314 address in target memory of value matching TYPE, and DEST is the value 315 we are repacking into. */ 316 explicit fortran_lazy_array_repacker_impl (struct type *type, 317 CORE_ADDR address, 318 struct value *dest) 319 : fortran_array_repacker_base_impl (dest), 320 m_addr (address) 321 { /* Nothing. */ } 322 323 /* Create a lazy value in target memory representing a single element, 324 then load the element into GDB's memory and copy the contents into the 325 destination value. */ 326 void process_element (struct type *elt_type, LONGEST elt_off, 327 LONGEST index, bool last_p) 328 { 329 copy_element_to_dest (value_at_lazy (elt_type, m_addr + elt_off)); 330 } 331 332 private: 333 /* The address in target memory where the parent value starts. */ 334 CORE_ADDR m_addr; 335 }; 336 337 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array 338 slices. This class is specialised for repacking an array slice from a 339 previously loaded (non-lazy) array value, as such it fetches the 340 element values from the contents of the parent value. */ 341 class fortran_array_repacker_impl 342 : public fortran_array_repacker_base_impl 343 { 344 public: 345 /* Constructor. TYPE is the type for the array slice within the parent 346 value, as such it has stride values as required to find the elements 347 within the original parent value. ADDRESS is the address in target 348 memory of the value matching TYPE. BASE_OFFSET is the offset from 349 the start of VAL's content buffer to the start of the object of TYPE, 350 VAL is the parent object from which we are loading the value, and 351 DEST is the value into which we are repacking. */ 352 explicit fortran_array_repacker_impl (struct type *type, CORE_ADDR address, 353 LONGEST base_offset, 354 struct value *val, struct value *dest) 355 : fortran_array_repacker_base_impl (dest), 356 m_base_offset (base_offset), 357 m_val (val) 358 { 359 gdb_assert (!value_lazy (val)); 360 } 361 362 /* Extract an element of ELT_TYPE at offset (M_BASE_OFFSET + ELT_OFF) 363 from the content buffer of M_VAL then copy this extracted value into 364 the repacked destination value. */ 365 void process_element (struct type *elt_type, LONGEST elt_off, 366 LONGEST index, bool last_p) 367 { 368 struct value *elt 369 = value_from_component (m_val, elt_type, (elt_off + m_base_offset)); 370 copy_element_to_dest (elt); 371 } 372 373 private: 374 /* The offset into the content buffer of M_VAL to the start of the slice 375 being extracted. */ 376 LONGEST m_base_offset; 377 378 /* The parent value from which we are extracting a slice. */ 379 struct value *m_val; 380 }; 381 382 383 /* Evaluate FORTRAN_ASSOCIATED expressions. Both GDBARCH and LANG are 384 extracted from the expression being evaluated. POINTER is the required 385 first argument to the 'associated' keyword, and TARGET is the optional 386 second argument, this will be nullptr if the user only passed one 387 argument to their use of 'associated'. */ 388 389 static struct value * 390 fortran_associated (struct gdbarch *gdbarch, const language_defn *lang, 391 struct value *pointer, struct value *target = nullptr) 392 { 393 struct type *result_type = language_bool_type (lang, gdbarch); 394 395 /* All Fortran pointers should have the associated property, this is 396 how we know the pointer is pointing at something or not. */ 397 struct type *pointer_type = check_typedef (value_type (pointer)); 398 if (TYPE_ASSOCIATED_PROP (pointer_type) == nullptr 399 && pointer_type->code () != TYPE_CODE_PTR) 400 error (_("ASSOCIATED can only be applied to pointers")); 401 402 /* Get an address from POINTER. Fortran (or at least gfortran) models 403 array pointers as arrays with a dynamic data address, so we need to 404 use two approaches here, for real pointers we take the contents of the 405 pointer as an address. For non-pointers we take the address of the 406 content. */ 407 CORE_ADDR pointer_addr; 408 if (pointer_type->code () == TYPE_CODE_PTR) 409 pointer_addr = value_as_address (pointer); 410 else 411 pointer_addr = value_address (pointer); 412 413 /* The single argument case, is POINTER associated with anything? */ 414 if (target == nullptr) 415 { 416 bool is_associated = false; 417 418 /* If POINTER is an actual pointer and doesn't have an associated 419 property then we need to figure out whether this pointer is 420 associated by looking at the value of the pointer itself. We make 421 the assumption that a non-associated pointer will be set to 0. 422 This is probably true for most targets, but might not be true for 423 everyone. */ 424 if (pointer_type->code () == TYPE_CODE_PTR 425 && TYPE_ASSOCIATED_PROP (pointer_type) == nullptr) 426 is_associated = (pointer_addr != 0); 427 else 428 is_associated = !type_not_associated (pointer_type); 429 return value_from_longest (result_type, is_associated ? 1 : 0); 430 } 431 432 /* The two argument case, is POINTER associated with TARGET? */ 433 434 struct type *target_type = check_typedef (value_type (target)); 435 436 struct type *pointer_target_type; 437 if (pointer_type->code () == TYPE_CODE_PTR) 438 pointer_target_type = pointer_type->target_type (); 439 else 440 pointer_target_type = pointer_type; 441 442 struct type *target_target_type; 443 if (target_type->code () == TYPE_CODE_PTR) 444 target_target_type = target_type->target_type (); 445 else 446 target_target_type = target_type; 447 448 if (pointer_target_type->code () != target_target_type->code () 449 || (pointer_target_type->code () != TYPE_CODE_ARRAY 450 && (pointer_target_type->length () 451 != target_target_type->length ()))) 452 error (_("arguments to associated must be of same type and kind")); 453 454 /* If TARGET is not in memory, or the original pointer is specifically 455 known to be not associated with anything, then the answer is obviously 456 false. Alternatively, if POINTER is an actual pointer and has no 457 associated property, then we have to check if its associated by 458 looking the value of the pointer itself. We make the assumption that 459 a non-associated pointer will be set to 0. This is probably true for 460 most targets, but might not be true for everyone. */ 461 if (value_lval_const (target) != lval_memory 462 || type_not_associated (pointer_type) 463 || (TYPE_ASSOCIATED_PROP (pointer_type) == nullptr 464 && pointer_type->code () == TYPE_CODE_PTR 465 && pointer_addr == 0)) 466 return value_from_longest (result_type, 0); 467 468 /* See the comment for POINTER_ADDR above. */ 469 CORE_ADDR target_addr; 470 if (target_type->code () == TYPE_CODE_PTR) 471 target_addr = value_as_address (target); 472 else 473 target_addr = value_address (target); 474 475 /* Wrap the following checks inside a do { ... } while (false) loop so 476 that we can use `break' to jump out of the loop. */ 477 bool is_associated = false; 478 do 479 { 480 /* If the addresses are different then POINTER is definitely not 481 pointing at TARGET. */ 482 if (pointer_addr != target_addr) 483 break; 484 485 /* If POINTER is a real pointer (i.e. not an array pointer, which are 486 implemented as arrays with a dynamic content address), then this 487 is all the checking that is needed. */ 488 if (pointer_type->code () == TYPE_CODE_PTR) 489 { 490 is_associated = true; 491 break; 492 } 493 494 /* We have an array pointer. Check the number of dimensions. */ 495 int pointer_dims = calc_f77_array_dims (pointer_type); 496 int target_dims = calc_f77_array_dims (target_type); 497 if (pointer_dims != target_dims) 498 break; 499 500 /* Now check that every dimension has the same upper bound, lower 501 bound, and stride value. */ 502 int dim = 0; 503 while (dim < pointer_dims) 504 { 505 LONGEST pointer_lowerbound, pointer_upperbound, pointer_stride; 506 LONGEST target_lowerbound, target_upperbound, target_stride; 507 508 pointer_type = check_typedef (pointer_type); 509 target_type = check_typedef (target_type); 510 511 struct type *pointer_range = pointer_type->index_type (); 512 struct type *target_range = target_type->index_type (); 513 514 if (!get_discrete_bounds (pointer_range, &pointer_lowerbound, 515 &pointer_upperbound)) 516 break; 517 518 if (!get_discrete_bounds (target_range, &target_lowerbound, 519 &target_upperbound)) 520 break; 521 522 if (pointer_lowerbound != target_lowerbound 523 || pointer_upperbound != target_upperbound) 524 break; 525 526 /* Figure out the stride (in bits) for both pointer and target. 527 If either doesn't have a stride then we take the element size, 528 but we need to convert to bits (hence the * 8). */ 529 pointer_stride = pointer_range->bounds ()->bit_stride (); 530 if (pointer_stride == 0) 531 pointer_stride 532 = type_length_units (check_typedef 533 (pointer_type->target_type ())) * 8; 534 target_stride = target_range->bounds ()->bit_stride (); 535 if (target_stride == 0) 536 target_stride 537 = type_length_units (check_typedef 538 (target_type->target_type ())) * 8; 539 if (pointer_stride != target_stride) 540 break; 541 542 ++dim; 543 } 544 545 if (dim < pointer_dims) 546 break; 547 548 is_associated = true; 549 } 550 while (false); 551 552 return value_from_longest (result_type, is_associated ? 1 : 0); 553 } 554 555 struct value * 556 eval_op_f_associated (struct type *expect_type, 557 struct expression *exp, 558 enum noside noside, 559 enum exp_opcode opcode, 560 struct value *arg1) 561 { 562 return fortran_associated (exp->gdbarch, exp->language_defn, arg1); 563 } 564 565 struct value * 566 eval_op_f_associated (struct type *expect_type, 567 struct expression *exp, 568 enum noside noside, 569 enum exp_opcode opcode, 570 struct value *arg1, 571 struct value *arg2) 572 { 573 return fortran_associated (exp->gdbarch, exp->language_defn, arg1, arg2); 574 } 575 576 /* Implement FORTRAN_ARRAY_SIZE expression, this corresponds to the 'SIZE' 577 keyword. RESULT_TYPE corresponds to the type kind the function should be 578 evaluated in, ARRAY is the value that should be an array, though this will 579 not have been checked before calling this function. DIM is optional, if 580 present then it should be an integer identifying a dimension of the 581 array to ask about. As with ARRAY the validity of DIM is not checked 582 before calling this function. 583 584 Return either the total number of elements in ARRAY (when DIM is 585 nullptr), or the number of elements in dimension DIM. */ 586 587 static value * 588 fortran_array_size (value *array, value *dim_val, type *result_type) 589 { 590 /* Check that ARRAY is the correct type. */ 591 struct type *array_type = check_typedef (value_type (array)); 592 if (array_type->code () != TYPE_CODE_ARRAY) 593 error (_("SIZE can only be applied to arrays")); 594 if (type_not_allocated (array_type) || type_not_associated (array_type)) 595 error (_("SIZE can only be used on allocated/associated arrays")); 596 597 int ndimensions = calc_f77_array_dims (array_type); 598 int dim = -1; 599 LONGEST result = 0; 600 601 if (dim_val != nullptr) 602 { 603 if (check_typedef (value_type (dim_val))->code () != TYPE_CODE_INT) 604 error (_("DIM argument to SIZE must be an integer")); 605 dim = (int) value_as_long (dim_val); 606 607 if (dim < 1 || dim > ndimensions) 608 error (_("DIM argument to SIZE must be between 1 and %d"), 609 ndimensions); 610 } 611 612 /* Now walk over all the dimensions of the array totalling up the 613 elements in each dimension. */ 614 for (int i = ndimensions - 1; i >= 0; --i) 615 { 616 /* If this is the requested dimension then we're done. Grab the 617 bounds and return. */ 618 if (i == dim - 1 || dim == -1) 619 { 620 LONGEST lbound, ubound; 621 struct type *range = array_type->index_type (); 622 623 if (!get_discrete_bounds (range, &lbound, &ubound)) 624 error (_("failed to find array bounds")); 625 626 LONGEST dim_size = (ubound - lbound + 1); 627 if (result == 0) 628 result = dim_size; 629 else 630 result *= dim_size; 631 632 if (dim != -1) 633 break; 634 } 635 636 /* Peel off another dimension of the array. */ 637 array_type = array_type->target_type (); 638 } 639 640 return value_from_longest (result_type, result); 641 } 642 643 /* See f-exp.h. */ 644 645 struct value * 646 eval_op_f_array_size (struct type *expect_type, 647 struct expression *exp, 648 enum noside noside, 649 enum exp_opcode opcode, 650 struct value *arg1) 651 { 652 gdb_assert (opcode == FORTRAN_ARRAY_SIZE); 653 654 type *result_type = builtin_f_type (exp->gdbarch)->builtin_integer; 655 return fortran_array_size (arg1, nullptr, result_type); 656 } 657 658 /* See f-exp.h. */ 659 660 struct value * 661 eval_op_f_array_size (struct type *expect_type, 662 struct expression *exp, 663 enum noside noside, 664 enum exp_opcode opcode, 665 struct value *arg1, 666 struct value *arg2) 667 { 668 gdb_assert (opcode == FORTRAN_ARRAY_SIZE); 669 670 type *result_type = builtin_f_type (exp->gdbarch)->builtin_integer; 671 return fortran_array_size (arg1, arg2, result_type); 672 } 673 674 /* See f-exp.h. */ 675 676 value *eval_op_f_array_size (type *expect_type, expression *exp, noside noside, 677 exp_opcode opcode, value *arg1, value *arg2, 678 type *kind_arg) 679 { 680 gdb_assert (opcode == FORTRAN_ARRAY_SIZE); 681 gdb_assert (kind_arg->code () == TYPE_CODE_INT); 682 683 return fortran_array_size (arg1, arg2, kind_arg); 684 } 685 686 /* Implement UNOP_FORTRAN_SHAPE expression. Both GDBARCH and LANG are 687 extracted from the expression being evaluated. VAL is the value on 688 which 'shape' was used, this can be any type. 689 690 Return an array of integers. If VAL is not an array then the returned 691 array should have zero elements. If VAL is an array then the returned 692 array should have one element per dimension, with the element 693 containing the extent of that dimension from VAL. */ 694 695 static struct value * 696 fortran_array_shape (struct gdbarch *gdbarch, const language_defn *lang, 697 struct value *val) 698 { 699 struct type *val_type = check_typedef (value_type (val)); 700 701 /* If we are passed an array that is either not allocated, or not 702 associated, then this is explicitly not allowed according to the 703 Fortran specification. */ 704 if (val_type->code () == TYPE_CODE_ARRAY 705 && (type_not_associated (val_type) || type_not_allocated (val_type))) 706 error (_("The array passed to SHAPE must be allocated or associated")); 707 708 /* The Fortran specification allows non-array types to be passed to this 709 function, in which case we get back an empty array. 710 711 Calculate the number of dimensions for the resulting array. */ 712 int ndimensions = 0; 713 if (val_type->code () == TYPE_CODE_ARRAY) 714 ndimensions = calc_f77_array_dims (val_type); 715 716 /* Allocate a result value of the correct type. */ 717 struct type *range 718 = create_static_range_type (nullptr, 719 builtin_type (gdbarch)->builtin_int, 720 1, ndimensions); 721 struct type *elm_type = builtin_f_type (gdbarch)->builtin_integer; 722 struct type *result_type = create_array_type (nullptr, elm_type, range); 723 struct value *result = allocate_value (result_type); 724 LONGEST elm_len = elm_type->length (); 725 726 /* Walk the array dimensions backwards due to the way the array will be 727 laid out in memory, the first dimension will be the most inner. 728 729 If VAL was not an array then ndimensions will be 0, in which case we 730 will never go around this loop. */ 731 for (LONGEST dst_offset = elm_len * (ndimensions - 1); 732 dst_offset >= 0; 733 dst_offset -= elm_len) 734 { 735 LONGEST lbound, ubound; 736 737 if (!get_discrete_bounds (val_type->index_type (), &lbound, &ubound)) 738 error (_("failed to find array bounds")); 739 740 LONGEST dim_size = (ubound - lbound + 1); 741 742 /* And copy the value into the result value. */ 743 struct value *v = value_from_longest (elm_type, dim_size); 744 gdb_assert (dst_offset + value_type (v)->length () 745 <= value_type (result)->length ()); 746 gdb_assert (value_type (v)->length () == elm_len); 747 value_contents_copy (result, dst_offset, v, 0, elm_len); 748 749 /* Peel another dimension of the array. */ 750 val_type = val_type->target_type (); 751 } 752 753 return result; 754 } 755 756 /* See f-exp.h. */ 757 758 struct value * 759 eval_op_f_array_shape (struct type *expect_type, struct expression *exp, 760 enum noside noside, enum exp_opcode opcode, 761 struct value *arg1) 762 { 763 gdb_assert (opcode == UNOP_FORTRAN_SHAPE); 764 return fortran_array_shape (exp->gdbarch, exp->language_defn, arg1); 765 } 766 767 /* A helper function for UNOP_ABS. */ 768 769 struct value * 770 eval_op_f_abs (struct type *expect_type, struct expression *exp, 771 enum noside noside, 772 enum exp_opcode opcode, 773 struct value *arg1) 774 { 775 struct type *type = value_type (arg1); 776 switch (type->code ()) 777 { 778 case TYPE_CODE_FLT: 779 { 780 double d 781 = fabs (target_float_to_host_double (value_contents (arg1).data (), 782 value_type (arg1))); 783 return value_from_host_double (type, d); 784 } 785 case TYPE_CODE_INT: 786 { 787 LONGEST l = value_as_long (arg1); 788 l = llabs (l); 789 return value_from_longest (type, l); 790 } 791 } 792 error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type)); 793 } 794 795 /* A helper function for BINOP_MOD. */ 796 797 struct value * 798 eval_op_f_mod (struct type *expect_type, struct expression *exp, 799 enum noside noside, 800 enum exp_opcode opcode, 801 struct value *arg1, struct value *arg2) 802 { 803 struct type *type = value_type (arg1); 804 if (type->code () != value_type (arg2)->code ()) 805 error (_("non-matching types for parameters to MOD ()")); 806 switch (type->code ()) 807 { 808 case TYPE_CODE_FLT: 809 { 810 double d1 811 = target_float_to_host_double (value_contents (arg1).data (), 812 value_type (arg1)); 813 double d2 814 = target_float_to_host_double (value_contents (arg2).data (), 815 value_type (arg2)); 816 double d3 = fmod (d1, d2); 817 return value_from_host_double (type, d3); 818 } 819 case TYPE_CODE_INT: 820 { 821 LONGEST v1 = value_as_long (arg1); 822 LONGEST v2 = value_as_long (arg2); 823 if (v2 == 0) 824 error (_("calling MOD (N, 0) is undefined")); 825 LONGEST v3 = v1 - (v1 / v2) * v2; 826 return value_from_longest (value_type (arg1), v3); 827 } 828 } 829 error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type)); 830 } 831 832 /* A helper function for the different FORTRAN_CEILING overloads. Calculates 833 CEILING for ARG1 (a float type) and returns it in the requested kind type 834 RESULT_TYPE. */ 835 836 static value * 837 fortran_ceil_operation (value *arg1, type *result_type) 838 { 839 if (value_type (arg1)->code () != TYPE_CODE_FLT) 840 error (_("argument to CEILING must be of type float")); 841 double val = target_float_to_host_double (value_contents (arg1).data (), 842 value_type (arg1)); 843 val = ceil (val); 844 return value_from_longest (result_type, val); 845 } 846 847 /* A helper function for FORTRAN_CEILING. */ 848 849 struct value * 850 eval_op_f_ceil (struct type *expect_type, struct expression *exp, 851 enum noside noside, 852 enum exp_opcode opcode, 853 struct value *arg1) 854 { 855 gdb_assert (opcode == FORTRAN_CEILING); 856 type *result_type = builtin_f_type (exp->gdbarch)->builtin_integer; 857 return fortran_ceil_operation (arg1, result_type); 858 } 859 860 /* A helper function for FORTRAN_CEILING. */ 861 862 value * 863 eval_op_f_ceil (type *expect_type, expression *exp, noside noside, 864 exp_opcode opcode, value *arg1, type *kind_arg) 865 { 866 gdb_assert (opcode == FORTRAN_CEILING); 867 gdb_assert (kind_arg->code () == TYPE_CODE_INT); 868 return fortran_ceil_operation (arg1, kind_arg); 869 } 870 871 /* A helper function for the different FORTRAN_FLOOR overloads. Calculates 872 FLOOR for ARG1 (a float type) and returns it in the requested kind type 873 RESULT_TYPE. */ 874 875 static value * 876 fortran_floor_operation (value *arg1, type *result_type) 877 { 878 if (value_type (arg1)->code () != TYPE_CODE_FLT) 879 error (_("argument to FLOOR must be of type float")); 880 double val = target_float_to_host_double (value_contents (arg1).data (), 881 value_type (arg1)); 882 val = floor (val); 883 return value_from_longest (result_type, val); 884 } 885 886 /* A helper function for FORTRAN_FLOOR. */ 887 888 struct value * 889 eval_op_f_floor (struct type *expect_type, struct expression *exp, 890 enum noside noside, 891 enum exp_opcode opcode, 892 struct value *arg1) 893 { 894 gdb_assert (opcode == FORTRAN_FLOOR); 895 type *result_type = builtin_f_type (exp->gdbarch)->builtin_integer; 896 return fortran_floor_operation (arg1, result_type); 897 } 898 899 /* A helper function for FORTRAN_FLOOR. */ 900 901 struct value * 902 eval_op_f_floor (type *expect_type, expression *exp, noside noside, 903 exp_opcode opcode, value *arg1, type *kind_arg) 904 { 905 gdb_assert (opcode == FORTRAN_FLOOR); 906 gdb_assert (kind_arg->code () == TYPE_CODE_INT); 907 return fortran_floor_operation (arg1, kind_arg); 908 } 909 910 /* A helper function for BINOP_FORTRAN_MODULO. */ 911 912 struct value * 913 eval_op_f_modulo (struct type *expect_type, struct expression *exp, 914 enum noside noside, 915 enum exp_opcode opcode, 916 struct value *arg1, struct value *arg2) 917 { 918 struct type *type = value_type (arg1); 919 if (type->code () != value_type (arg2)->code ()) 920 error (_("non-matching types for parameters to MODULO ()")); 921 /* MODULO(A, P) = A - FLOOR (A / P) * P */ 922 switch (type->code ()) 923 { 924 case TYPE_CODE_INT: 925 { 926 LONGEST a = value_as_long (arg1); 927 LONGEST p = value_as_long (arg2); 928 LONGEST result = a - (a / p) * p; 929 if (result != 0 && (a < 0) != (p < 0)) 930 result += p; 931 return value_from_longest (value_type (arg1), result); 932 } 933 case TYPE_CODE_FLT: 934 { 935 double a 936 = target_float_to_host_double (value_contents (arg1).data (), 937 value_type (arg1)); 938 double p 939 = target_float_to_host_double (value_contents (arg2).data (), 940 value_type (arg2)); 941 double result = fmod (a, p); 942 if (result != 0 && (a < 0.0) != (p < 0.0)) 943 result += p; 944 return value_from_host_double (type, result); 945 } 946 } 947 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type)); 948 } 949 950 /* A helper function for FORTRAN_CMPLX. */ 951 952 value * 953 eval_op_f_cmplx (type *expect_type, expression *exp, noside noside, 954 exp_opcode opcode, value *arg1) 955 { 956 gdb_assert (opcode == FORTRAN_CMPLX); 957 958 type *result_type = builtin_f_type (exp->gdbarch)->builtin_complex; 959 960 if (value_type (arg1)->code () == TYPE_CODE_COMPLEX) 961 return value_cast (result_type, arg1); 962 else 963 return value_literal_complex (arg1, 964 value_zero (value_type (arg1), not_lval), 965 result_type); 966 } 967 968 /* A helper function for FORTRAN_CMPLX. */ 969 970 struct value * 971 eval_op_f_cmplx (struct type *expect_type, struct expression *exp, 972 enum noside noside, 973 enum exp_opcode opcode, 974 struct value *arg1, struct value *arg2) 975 { 976 if (value_type (arg1)->code () == TYPE_CODE_COMPLEX 977 || value_type (arg2)->code () == TYPE_CODE_COMPLEX) 978 error (_("Types of arguments for CMPLX called with more then one argument " 979 "must be REAL or INTEGER")); 980 981 type *result_type = builtin_f_type (exp->gdbarch)->builtin_complex; 982 return value_literal_complex (arg1, arg2, result_type); 983 } 984 985 /* A helper function for FORTRAN_CMPLX. */ 986 987 value * 988 eval_op_f_cmplx (type *expect_type, expression *exp, noside noside, 989 exp_opcode opcode, value *arg1, value *arg2, type *kind_arg) 990 { 991 gdb_assert (kind_arg->code () == TYPE_CODE_COMPLEX); 992 if (value_type (arg1)->code () == TYPE_CODE_COMPLEX 993 || value_type (arg2)->code () == TYPE_CODE_COMPLEX) 994 error (_("Types of arguments for CMPLX called with more then one argument " 995 "must be REAL or INTEGER")); 996 997 return value_literal_complex (arg1, arg2, kind_arg); 998 } 999 1000 /* A helper function for UNOP_FORTRAN_KIND. */ 1001 1002 struct value * 1003 eval_op_f_kind (struct type *expect_type, struct expression *exp, 1004 enum noside noside, 1005 enum exp_opcode opcode, 1006 struct value *arg1) 1007 { 1008 struct type *type = value_type (arg1); 1009 1010 switch (type->code ()) 1011 { 1012 case TYPE_CODE_STRUCT: 1013 case TYPE_CODE_UNION: 1014 case TYPE_CODE_MODULE: 1015 case TYPE_CODE_FUNC: 1016 error (_("argument to kind must be an intrinsic type")); 1017 } 1018 1019 if (!type->target_type ()) 1020 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1021 type->length ()); 1022 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1023 type->target_type ()->length ()); 1024 } 1025 1026 /* A helper function for UNOP_FORTRAN_ALLOCATED. */ 1027 1028 struct value * 1029 eval_op_f_allocated (struct type *expect_type, struct expression *exp, 1030 enum noside noside, enum exp_opcode op, 1031 struct value *arg1) 1032 { 1033 struct type *type = check_typedef (value_type (arg1)); 1034 if (type->code () != TYPE_CODE_ARRAY) 1035 error (_("ALLOCATED can only be applied to arrays")); 1036 struct type *result_type 1037 = builtin_f_type (exp->gdbarch)->builtin_logical; 1038 LONGEST result_value = type_not_allocated (type) ? 0 : 1; 1039 return value_from_longest (result_type, result_value); 1040 } 1041 1042 /* See f-exp.h. */ 1043 1044 struct value * 1045 eval_op_f_rank (struct type *expect_type, 1046 struct expression *exp, 1047 enum noside noside, 1048 enum exp_opcode op, 1049 struct value *arg1) 1050 { 1051 gdb_assert (op == UNOP_FORTRAN_RANK); 1052 1053 struct type *result_type 1054 = builtin_f_type (exp->gdbarch)->builtin_integer; 1055 struct type *type = check_typedef (value_type (arg1)); 1056 if (type->code () != TYPE_CODE_ARRAY) 1057 return value_from_longest (result_type, 0); 1058 LONGEST ndim = calc_f77_array_dims (type); 1059 return value_from_longest (result_type, ndim); 1060 } 1061 1062 /* A helper function for UNOP_FORTRAN_LOC. */ 1063 1064 struct value * 1065 eval_op_f_loc (struct type *expect_type, struct expression *exp, 1066 enum noside noside, enum exp_opcode op, 1067 struct value *arg1) 1068 { 1069 struct type *result_type; 1070 if (gdbarch_ptr_bit (exp->gdbarch) == 16) 1071 result_type = builtin_f_type (exp->gdbarch)->builtin_integer_s2; 1072 else if (gdbarch_ptr_bit (exp->gdbarch) == 32) 1073 result_type = builtin_f_type (exp->gdbarch)->builtin_integer; 1074 else 1075 result_type = builtin_f_type (exp->gdbarch)->builtin_integer_s8; 1076 1077 LONGEST result_value = value_address (arg1); 1078 return value_from_longest (result_type, result_value); 1079 } 1080 1081 namespace expr 1082 { 1083 1084 /* Called from evaluate to perform array indexing, and sub-range 1085 extraction, for Fortran. As well as arrays this function also 1086 handles strings as they can be treated like arrays of characters. 1087 ARRAY is the array or string being accessed. EXP and NOSIDE are as 1088 for evaluate. */ 1089 1090 value * 1091 fortran_undetermined::value_subarray (value *array, 1092 struct expression *exp, 1093 enum noside noside) 1094 { 1095 type *original_array_type = check_typedef (value_type (array)); 1096 bool is_string_p = original_array_type->code () == TYPE_CODE_STRING; 1097 const std::vector<operation_up> &ops = std::get<1> (m_storage); 1098 int nargs = ops.size (); 1099 1100 /* Perform checks for ARRAY not being available. The somewhat overly 1101 complex logic here is just to keep backward compatibility with the 1102 errors that we used to get before FORTRAN_VALUE_SUBARRAY was 1103 rewritten. Maybe a future task would streamline the error messages we 1104 get here, and update all the expected test results. */ 1105 if (ops[0]->opcode () != OP_RANGE) 1106 { 1107 if (type_not_associated (original_array_type)) 1108 error (_("no such vector element (vector not associated)")); 1109 else if (type_not_allocated (original_array_type)) 1110 error (_("no such vector element (vector not allocated)")); 1111 } 1112 else 1113 { 1114 if (type_not_associated (original_array_type)) 1115 error (_("array not associated")); 1116 else if (type_not_allocated (original_array_type)) 1117 error (_("array not allocated")); 1118 } 1119 1120 /* First check that the number of dimensions in the type we are slicing 1121 matches the number of arguments we were passed. */ 1122 int ndimensions = calc_f77_array_dims (original_array_type); 1123 if (nargs != ndimensions) 1124 error (_("Wrong number of subscripts")); 1125 1126 /* This will be initialised below with the type of the elements held in 1127 ARRAY. */ 1128 struct type *inner_element_type; 1129 1130 /* Extract the types of each array dimension from the original array 1131 type. We need these available so we can fill in the default upper and 1132 lower bounds if the user requested slice doesn't provide that 1133 information. Additionally unpacking the dimensions like this gives us 1134 the inner element type. */ 1135 std::vector<struct type *> dim_types; 1136 { 1137 dim_types.reserve (ndimensions); 1138 struct type *type = original_array_type; 1139 for (int i = 0; i < ndimensions; ++i) 1140 { 1141 dim_types.push_back (type); 1142 type = type->target_type (); 1143 } 1144 /* TYPE is now the inner element type of the array, we start the new 1145 array slice off as this type, then as we process the requested slice 1146 (from the user) we wrap new types around this to build up the final 1147 slice type. */ 1148 inner_element_type = type; 1149 } 1150 1151 /* As we analyse the new slice type we need to understand if the data 1152 being referenced is contiguous. Do decide this we must track the size 1153 of an element at each dimension of the new slice array. Initially the 1154 elements of the inner most dimension of the array are the same inner 1155 most elements as the original ARRAY. */ 1156 LONGEST slice_element_size = inner_element_type->length (); 1157 1158 /* Start off assuming all data is contiguous, this will be set to false 1159 if access to any dimension results in non-contiguous data. */ 1160 bool is_all_contiguous = true; 1161 1162 /* The TOTAL_OFFSET is the distance in bytes from the start of the 1163 original ARRAY to the start of the new slice. This is calculated as 1164 we process the information from the user. */ 1165 LONGEST total_offset = 0; 1166 1167 /* A structure representing information about each dimension of the 1168 resulting slice. */ 1169 struct slice_dim 1170 { 1171 /* Constructor. */ 1172 slice_dim (LONGEST l, LONGEST h, LONGEST s, struct type *idx) 1173 : low (l), 1174 high (h), 1175 stride (s), 1176 index (idx) 1177 { /* Nothing. */ } 1178 1179 /* The low bound for this dimension of the slice. */ 1180 LONGEST low; 1181 1182 /* The high bound for this dimension of the slice. */ 1183 LONGEST high; 1184 1185 /* The byte stride for this dimension of the slice. */ 1186 LONGEST stride; 1187 1188 struct type *index; 1189 }; 1190 1191 /* The dimensions of the resulting slice. */ 1192 std::vector<slice_dim> slice_dims; 1193 1194 /* Process the incoming arguments. These arguments are in the reverse 1195 order to the array dimensions, that is the first argument refers to 1196 the last array dimension. */ 1197 if (fortran_array_slicing_debug) 1198 debug_printf ("Processing array access:\n"); 1199 for (int i = 0; i < nargs; ++i) 1200 { 1201 /* For each dimension of the array the user will have either provided 1202 a ranged access with optional lower bound, upper bound, and 1203 stride, or the user will have supplied a single index. */ 1204 struct type *dim_type = dim_types[ndimensions - (i + 1)]; 1205 fortran_range_operation *range_op 1206 = dynamic_cast<fortran_range_operation *> (ops[i].get ()); 1207 if (range_op != nullptr) 1208 { 1209 enum range_flag range_flag = range_op->get_flags (); 1210 1211 LONGEST low, high, stride; 1212 low = high = stride = 0; 1213 1214 if ((range_flag & RANGE_LOW_BOUND_DEFAULT) == 0) 1215 low = value_as_long (range_op->evaluate0 (exp, noside)); 1216 else 1217 low = f77_get_lowerbound (dim_type); 1218 if ((range_flag & RANGE_HIGH_BOUND_DEFAULT) == 0) 1219 high = value_as_long (range_op->evaluate1 (exp, noside)); 1220 else 1221 high = f77_get_upperbound (dim_type); 1222 if ((range_flag & RANGE_HAS_STRIDE) == RANGE_HAS_STRIDE) 1223 stride = value_as_long (range_op->evaluate2 (exp, noside)); 1224 else 1225 stride = 1; 1226 1227 if (stride == 0) 1228 error (_("stride must not be 0")); 1229 1230 /* Get information about this dimension in the original ARRAY. */ 1231 struct type *target_type = dim_type->target_type (); 1232 struct type *index_type = dim_type->index_type (); 1233 LONGEST lb = f77_get_lowerbound (dim_type); 1234 LONGEST ub = f77_get_upperbound (dim_type); 1235 LONGEST sd = index_type->bit_stride (); 1236 if (sd == 0) 1237 sd = target_type->length () * 8; 1238 1239 if (fortran_array_slicing_debug) 1240 { 1241 debug_printf ("|-> Range access\n"); 1242 std::string str = type_to_string (dim_type); 1243 debug_printf ("| |-> Type: %s\n", str.c_str ()); 1244 debug_printf ("| |-> Array:\n"); 1245 debug_printf ("| | |-> Low bound: %s\n", plongest (lb)); 1246 debug_printf ("| | |-> High bound: %s\n", plongest (ub)); 1247 debug_printf ("| | |-> Bit stride: %s\n", plongest (sd)); 1248 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd / 8)); 1249 debug_printf ("| | |-> Type size: %s\n", 1250 pulongest (dim_type->length ())); 1251 debug_printf ("| | '-> Target type size: %s\n", 1252 pulongest (target_type->length ())); 1253 debug_printf ("| |-> Accessing:\n"); 1254 debug_printf ("| | |-> Low bound: %s\n", 1255 plongest (low)); 1256 debug_printf ("| | |-> High bound: %s\n", 1257 plongest (high)); 1258 debug_printf ("| | '-> Element stride: %s\n", 1259 plongest (stride)); 1260 } 1261 1262 /* Check the user hasn't asked for something invalid. */ 1263 if (high > ub || low < lb) 1264 error (_("array subscript out of bounds")); 1265 1266 /* Calculate what this dimension of the new slice array will look 1267 like. OFFSET is the byte offset from the start of the 1268 previous (more outer) dimension to the start of this 1269 dimension. E_COUNT is the number of elements in this 1270 dimension. REMAINDER is the number of elements remaining 1271 between the last included element and the upper bound. For 1272 example an access '1:6:2' will include elements 1, 3, 5 and 1273 have a remainder of 1 (element #6). */ 1274 LONGEST lowest = std::min (low, high); 1275 LONGEST offset = (sd / 8) * (lowest - lb); 1276 LONGEST e_count = std::abs (high - low) + 1; 1277 e_count = (e_count + (std::abs (stride) - 1)) / std::abs (stride); 1278 LONGEST new_low = 1; 1279 LONGEST new_high = new_low + e_count - 1; 1280 LONGEST new_stride = (sd * stride) / 8; 1281 LONGEST last_elem = low + ((e_count - 1) * stride); 1282 LONGEST remainder = high - last_elem; 1283 if (low > high) 1284 { 1285 offset += std::abs (remainder) * target_type->length (); 1286 if (stride > 0) 1287 error (_("incorrect stride and boundary combination")); 1288 } 1289 else if (stride < 0) 1290 error (_("incorrect stride and boundary combination")); 1291 1292 /* Is the data within this dimension contiguous? It is if the 1293 newly computed stride is the same size as a single element of 1294 this dimension. */ 1295 bool is_dim_contiguous = (new_stride == slice_element_size); 1296 is_all_contiguous &= is_dim_contiguous; 1297 1298 if (fortran_array_slicing_debug) 1299 { 1300 debug_printf ("| '-> Results:\n"); 1301 debug_printf ("| |-> Offset = %s\n", plongest (offset)); 1302 debug_printf ("| |-> Elements = %s\n", plongest (e_count)); 1303 debug_printf ("| |-> Low bound = %s\n", plongest (new_low)); 1304 debug_printf ("| |-> High bound = %s\n", 1305 plongest (new_high)); 1306 debug_printf ("| |-> Byte stride = %s\n", 1307 plongest (new_stride)); 1308 debug_printf ("| |-> Last element = %s\n", 1309 plongest (last_elem)); 1310 debug_printf ("| |-> Remainder = %s\n", 1311 plongest (remainder)); 1312 debug_printf ("| '-> Contiguous = %s\n", 1313 (is_dim_contiguous ? "Yes" : "No")); 1314 } 1315 1316 /* Figure out how big (in bytes) an element of this dimension of 1317 the new array slice will be. */ 1318 slice_element_size = std::abs (new_stride * e_count); 1319 1320 slice_dims.emplace_back (new_low, new_high, new_stride, 1321 index_type); 1322 1323 /* Update the total offset. */ 1324 total_offset += offset; 1325 } 1326 else 1327 { 1328 /* There is a single index for this dimension. */ 1329 LONGEST index 1330 = value_as_long (ops[i]->evaluate_with_coercion (exp, noside)); 1331 1332 /* Get information about this dimension in the original ARRAY. */ 1333 struct type *target_type = dim_type->target_type (); 1334 struct type *index_type = dim_type->index_type (); 1335 LONGEST lb = f77_get_lowerbound (dim_type); 1336 LONGEST ub = f77_get_upperbound (dim_type); 1337 LONGEST sd = index_type->bit_stride () / 8; 1338 if (sd == 0) 1339 sd = target_type->length (); 1340 1341 if (fortran_array_slicing_debug) 1342 { 1343 debug_printf ("|-> Index access\n"); 1344 std::string str = type_to_string (dim_type); 1345 debug_printf ("| |-> Type: %s\n", str.c_str ()); 1346 debug_printf ("| |-> Array:\n"); 1347 debug_printf ("| | |-> Low bound: %s\n", plongest (lb)); 1348 debug_printf ("| | |-> High bound: %s\n", plongest (ub)); 1349 debug_printf ("| | |-> Byte stride: %s\n", plongest (sd)); 1350 debug_printf ("| | |-> Type size: %s\n", 1351 pulongest (dim_type->length ())); 1352 debug_printf ("| | '-> Target type size: %s\n", 1353 pulongest (target_type->length ())); 1354 debug_printf ("| '-> Accessing:\n"); 1355 debug_printf ("| '-> Index: %s\n", 1356 plongest (index)); 1357 } 1358 1359 /* If the array has actual content then check the index is in 1360 bounds. An array without content (an unbound array) doesn't 1361 have a known upper bound, so don't error check in that 1362 situation. */ 1363 if (index < lb 1364 || (dim_type->index_type ()->bounds ()->high.kind () != PROP_UNDEFINED 1365 && index > ub) 1366 || (VALUE_LVAL (array) != lval_memory 1367 && dim_type->index_type ()->bounds ()->high.kind () == PROP_UNDEFINED)) 1368 { 1369 if (type_not_associated (dim_type)) 1370 error (_("no such vector element (vector not associated)")); 1371 else if (type_not_allocated (dim_type)) 1372 error (_("no such vector element (vector not allocated)")); 1373 else 1374 error (_("no such vector element")); 1375 } 1376 1377 /* Calculate using the type stride, not the target type size. */ 1378 LONGEST offset = sd * (index - lb); 1379 total_offset += offset; 1380 } 1381 } 1382 1383 /* Build a type that represents the new array slice in the target memory 1384 of the original ARRAY, this type makes use of strides to correctly 1385 find only those elements that are part of the new slice. */ 1386 struct type *array_slice_type = inner_element_type; 1387 for (const auto &d : slice_dims) 1388 { 1389 /* Create the range. */ 1390 dynamic_prop p_low, p_high, p_stride; 1391 1392 p_low.set_const_val (d.low); 1393 p_high.set_const_val (d.high); 1394 p_stride.set_const_val (d.stride); 1395 1396 struct type *new_range 1397 = create_range_type_with_stride ((struct type *) NULL, 1398 d.index->target_type (), 1399 &p_low, &p_high, 0, &p_stride, 1400 true); 1401 array_slice_type 1402 = create_array_type (nullptr, array_slice_type, new_range); 1403 } 1404 1405 if (fortran_array_slicing_debug) 1406 { 1407 debug_printf ("'-> Final result:\n"); 1408 debug_printf (" |-> Type: %s\n", 1409 type_to_string (array_slice_type).c_str ()); 1410 debug_printf (" |-> Total offset: %s\n", 1411 plongest (total_offset)); 1412 debug_printf (" |-> Base address: %s\n", 1413 core_addr_to_string (value_address (array))); 1414 debug_printf (" '-> Contiguous = %s\n", 1415 (is_all_contiguous ? "Yes" : "No")); 1416 } 1417 1418 /* Should we repack this array slice? */ 1419 if (!is_all_contiguous && (repack_array_slices || is_string_p)) 1420 { 1421 /* Build a type for the repacked slice. */ 1422 struct type *repacked_array_type = inner_element_type; 1423 for (const auto &d : slice_dims) 1424 { 1425 /* Create the range. */ 1426 dynamic_prop p_low, p_high, p_stride; 1427 1428 p_low.set_const_val (d.low); 1429 p_high.set_const_val (d.high); 1430 p_stride.set_const_val (repacked_array_type->length ()); 1431 1432 struct type *new_range 1433 = create_range_type_with_stride ((struct type *) NULL, 1434 d.index->target_type (), 1435 &p_low, &p_high, 0, &p_stride, 1436 true); 1437 repacked_array_type 1438 = create_array_type (nullptr, repacked_array_type, new_range); 1439 } 1440 1441 /* Now copy the elements from the original ARRAY into the packed 1442 array value DEST. */ 1443 struct value *dest = allocate_value (repacked_array_type); 1444 if (value_lazy (array) 1445 || (total_offset + array_slice_type->length () 1446 > check_typedef (value_type (array))->length ())) 1447 { 1448 fortran_array_walker<fortran_lazy_array_repacker_impl> p 1449 (array_slice_type, value_address (array) + total_offset, dest); 1450 p.walk (); 1451 } 1452 else 1453 { 1454 fortran_array_walker<fortran_array_repacker_impl> p 1455 (array_slice_type, value_address (array) + total_offset, 1456 total_offset, array, dest); 1457 p.walk (); 1458 } 1459 array = dest; 1460 } 1461 else 1462 { 1463 if (VALUE_LVAL (array) == lval_memory) 1464 { 1465 /* If the value we're taking a slice from is not yet loaded, or 1466 the requested slice is outside the values content range then 1467 just create a new lazy value pointing at the memory where the 1468 contents we're looking for exist. */ 1469 if (value_lazy (array) 1470 || (total_offset + array_slice_type->length () 1471 > check_typedef (value_type (array))->length ())) 1472 array = value_at_lazy (array_slice_type, 1473 value_address (array) + total_offset); 1474 else 1475 array = value_from_contents_and_address 1476 (array_slice_type, value_contents (array).data () + total_offset, 1477 value_address (array) + total_offset); 1478 } 1479 else if (!value_lazy (array)) 1480 array = value_from_component (array, array_slice_type, total_offset); 1481 else 1482 error (_("cannot subscript arrays that are not in memory")); 1483 } 1484 1485 return array; 1486 } 1487 1488 value * 1489 fortran_undetermined::evaluate (struct type *expect_type, 1490 struct expression *exp, 1491 enum noside noside) 1492 { 1493 value *callee = std::get<0> (m_storage)->evaluate (nullptr, exp, noside); 1494 if (noside == EVAL_AVOID_SIDE_EFFECTS 1495 && is_dynamic_type (value_type (callee))) 1496 callee = std::get<0> (m_storage)->evaluate (nullptr, exp, EVAL_NORMAL); 1497 struct type *type = check_typedef (value_type (callee)); 1498 enum type_code code = type->code (); 1499 1500 if (code == TYPE_CODE_PTR) 1501 { 1502 /* Fortran always passes variable to subroutines as pointer. 1503 So we need to look into its target type to see if it is 1504 array, string or function. If it is, we need to switch 1505 to the target value the original one points to. */ 1506 struct type *target_type = check_typedef (type->target_type ()); 1507 1508 if (target_type->code () == TYPE_CODE_ARRAY 1509 || target_type->code () == TYPE_CODE_STRING 1510 || target_type->code () == TYPE_CODE_FUNC) 1511 { 1512 callee = value_ind (callee); 1513 type = check_typedef (value_type (callee)); 1514 code = type->code (); 1515 } 1516 } 1517 1518 switch (code) 1519 { 1520 case TYPE_CODE_ARRAY: 1521 case TYPE_CODE_STRING: 1522 return value_subarray (callee, exp, noside); 1523 1524 case TYPE_CODE_PTR: 1525 case TYPE_CODE_FUNC: 1526 case TYPE_CODE_INTERNAL_FUNCTION: 1527 { 1528 /* It's a function call. Allocate arg vector, including 1529 space for the function to be called in argvec[0] and a 1530 termination NULL. */ 1531 const std::vector<operation_up> &actual (std::get<1> (m_storage)); 1532 std::vector<value *> argvec (actual.size ()); 1533 bool is_internal_func = (code == TYPE_CODE_INTERNAL_FUNCTION); 1534 for (int tem = 0; tem < argvec.size (); tem++) 1535 argvec[tem] = fortran_prepare_argument (exp, actual[tem].get (), 1536 tem, is_internal_func, 1537 value_type (callee), 1538 noside); 1539 return evaluate_subexp_do_call (exp, noside, callee, argvec, 1540 nullptr, expect_type); 1541 } 1542 1543 default: 1544 error (_("Cannot perform substring on this type")); 1545 } 1546 } 1547 1548 value * 1549 fortran_bound_1arg::evaluate (struct type *expect_type, 1550 struct expression *exp, 1551 enum noside noside) 1552 { 1553 bool lbound_p = std::get<0> (m_storage) == FORTRAN_LBOUND; 1554 value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside); 1555 fortran_require_array (value_type (arg1), lbound_p); 1556 return fortran_bounds_all_dims (lbound_p, exp->gdbarch, arg1); 1557 } 1558 1559 value * 1560 fortran_bound_2arg::evaluate (struct type *expect_type, 1561 struct expression *exp, 1562 enum noside noside) 1563 { 1564 bool lbound_p = std::get<0> (m_storage) == FORTRAN_LBOUND; 1565 value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside); 1566 fortran_require_array (value_type (arg1), lbound_p); 1567 1568 /* User asked for the bounds of a specific dimension of the array. */ 1569 value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside); 1570 type *type_arg2 = check_typedef (value_type (arg2)); 1571 if (type_arg2->code () != TYPE_CODE_INT) 1572 { 1573 if (lbound_p) 1574 error (_("LBOUND second argument should be an integer")); 1575 else 1576 error (_("UBOUND second argument should be an integer")); 1577 } 1578 1579 type *result_type = builtin_f_type (exp->gdbarch)->builtin_integer; 1580 return fortran_bounds_for_dimension (lbound_p, arg1, arg2, result_type); 1581 } 1582 1583 value * 1584 fortran_bound_3arg::evaluate (type *expect_type, 1585 expression *exp, 1586 noside noside) 1587 { 1588 const bool lbound_p = std::get<0> (m_storage) == FORTRAN_LBOUND; 1589 value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside); 1590 fortran_require_array (value_type (arg1), lbound_p); 1591 1592 /* User asked for the bounds of a specific dimension of the array. */ 1593 value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside); 1594 type *type_arg2 = check_typedef (value_type (arg2)); 1595 if (type_arg2->code () != TYPE_CODE_INT) 1596 { 1597 if (lbound_p) 1598 error (_("LBOUND second argument should be an integer")); 1599 else 1600 error (_("UBOUND second argument should be an integer")); 1601 } 1602 1603 type *kind_arg = std::get<3> (m_storage); 1604 gdb_assert (kind_arg->code () == TYPE_CODE_INT); 1605 1606 return fortran_bounds_for_dimension (lbound_p, arg1, arg2, kind_arg); 1607 } 1608 1609 /* Implement STRUCTOP_STRUCT for Fortran. See operation::evaluate in 1610 expression.h for argument descriptions. */ 1611 1612 value * 1613 fortran_structop_operation::evaluate (struct type *expect_type, 1614 struct expression *exp, 1615 enum noside noside) 1616 { 1617 value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside); 1618 const char *str = std::get<1> (m_storage).c_str (); 1619 if (noside == EVAL_AVOID_SIDE_EFFECTS) 1620 { 1621 struct type *type = lookup_struct_elt_type (value_type (arg1), str, 1); 1622 1623 if (type != nullptr && is_dynamic_type (type)) 1624 arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, EVAL_NORMAL); 1625 } 1626 1627 value *elt = value_struct_elt (&arg1, {}, str, NULL, "structure"); 1628 1629 if (noside == EVAL_AVOID_SIDE_EFFECTS) 1630 { 1631 struct type *elt_type = value_type (elt); 1632 if (is_dynamic_type (elt_type)) 1633 { 1634 const gdb_byte *valaddr = value_contents_for_printing (elt).data (); 1635 CORE_ADDR address = value_address (elt); 1636 gdb::array_view<const gdb_byte> view 1637 = gdb::make_array_view (valaddr, elt_type->length ()); 1638 elt_type = resolve_dynamic_type (elt_type, view, address); 1639 } 1640 elt = value_zero (elt_type, VALUE_LVAL (elt)); 1641 } 1642 1643 return elt; 1644 } 1645 1646 } /* namespace expr */ 1647 1648 /* See language.h. */ 1649 1650 void 1651 f_language::print_array_index (struct type *index_type, LONGEST index, 1652 struct ui_file *stream, 1653 const value_print_options *options) const 1654 { 1655 struct value *index_value = value_from_longest (index_type, index); 1656 1657 gdb_printf (stream, "("); 1658 value_print (index_value, stream, options); 1659 gdb_printf (stream, ") = "); 1660 } 1661 1662 /* See language.h. */ 1663 1664 void 1665 f_language::language_arch_info (struct gdbarch *gdbarch, 1666 struct language_arch_info *lai) const 1667 { 1668 const struct builtin_f_type *builtin = builtin_f_type (gdbarch); 1669 1670 /* Helper function to allow shorter lines below. */ 1671 auto add = [&] (struct type * t) 1672 { 1673 lai->add_primitive_type (t); 1674 }; 1675 1676 add (builtin->builtin_character); 1677 add (builtin->builtin_logical); 1678 add (builtin->builtin_logical_s1); 1679 add (builtin->builtin_logical_s2); 1680 add (builtin->builtin_logical_s8); 1681 add (builtin->builtin_real); 1682 add (builtin->builtin_real_s8); 1683 add (builtin->builtin_real_s16); 1684 add (builtin->builtin_complex); 1685 add (builtin->builtin_complex_s8); 1686 add (builtin->builtin_void); 1687 1688 lai->set_string_char_type (builtin->builtin_character); 1689 lai->set_bool_type (builtin->builtin_logical, "logical"); 1690 } 1691 1692 /* See language.h. */ 1693 1694 unsigned int 1695 f_language::search_name_hash (const char *name) const 1696 { 1697 return cp_search_name_hash (name); 1698 } 1699 1700 /* See language.h. */ 1701 1702 struct block_symbol 1703 f_language::lookup_symbol_nonlocal (const char *name, 1704 const struct block *block, 1705 const domain_enum domain) const 1706 { 1707 return cp_lookup_symbol_nonlocal (this, name, block, domain); 1708 } 1709 1710 /* See language.h. */ 1711 1712 symbol_name_matcher_ftype * 1713 f_language::get_symbol_name_matcher_inner 1714 (const lookup_name_info &lookup_name) const 1715 { 1716 return cp_get_symbol_name_matcher (lookup_name); 1717 } 1718 1719 /* Single instance of the Fortran language class. */ 1720 1721 static f_language f_language_defn; 1722 1723 static struct builtin_f_type * 1724 build_fortran_types (struct gdbarch *gdbarch) 1725 { 1726 struct builtin_f_type *builtin_f_type = new struct builtin_f_type; 1727 1728 builtin_f_type->builtin_void 1729 = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "void"); 1730 1731 builtin_f_type->builtin_character 1732 = arch_type (gdbarch, TYPE_CODE_CHAR, TARGET_CHAR_BIT, "character"); 1733 1734 builtin_f_type->builtin_logical_s1 1735 = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1"); 1736 1737 builtin_f_type->builtin_logical_s2 1738 = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1, "logical*2"); 1739 1740 builtin_f_type->builtin_logical 1741 = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "logical*4"); 1742 1743 builtin_f_type->builtin_logical_s8 1744 = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1, 1745 "logical*8"); 1746 1747 builtin_f_type->builtin_integer_s1 1748 = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "integer*1"); 1749 1750 builtin_f_type->builtin_integer_s2 1751 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0, "integer*2"); 1752 1753 builtin_f_type->builtin_integer 1754 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0, "integer*4"); 1755 1756 builtin_f_type->builtin_integer_s8 1757 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0, 1758 "integer*8"); 1759 1760 builtin_f_type->builtin_real 1761 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch), 1762 "real*4", gdbarch_float_format (gdbarch)); 1763 1764 builtin_f_type->builtin_real_s8 1765 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch), 1766 "real*8", gdbarch_double_format (gdbarch)); 1767 1768 auto fmt = gdbarch_floatformat_for_type (gdbarch, "real(kind=16)", 128); 1769 if (fmt != nullptr) 1770 builtin_f_type->builtin_real_s16 1771 = arch_float_type (gdbarch, 128, "real*16", fmt); 1772 else if (gdbarch_long_double_bit (gdbarch) == 128) 1773 builtin_f_type->builtin_real_s16 1774 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch), 1775 "real*16", gdbarch_long_double_format (gdbarch)); 1776 else 1777 builtin_f_type->builtin_real_s16 1778 = arch_type (gdbarch, TYPE_CODE_ERROR, 128, "real*16"); 1779 1780 builtin_f_type->builtin_complex 1781 = init_complex_type ("complex*4", builtin_f_type->builtin_real); 1782 1783 builtin_f_type->builtin_complex_s8 1784 = init_complex_type ("complex*8", builtin_f_type->builtin_real_s8); 1785 1786 if (builtin_f_type->builtin_real_s16->code () == TYPE_CODE_ERROR) 1787 builtin_f_type->builtin_complex_s16 1788 = arch_type (gdbarch, TYPE_CODE_ERROR, 256, "complex*16"); 1789 else 1790 builtin_f_type->builtin_complex_s16 1791 = init_complex_type ("complex*16", builtin_f_type->builtin_real_s16); 1792 1793 return builtin_f_type; 1794 } 1795 1796 static const registry<gdbarch>::key<struct builtin_f_type> f_type_data; 1797 1798 const struct builtin_f_type * 1799 builtin_f_type (struct gdbarch *gdbarch) 1800 { 1801 struct builtin_f_type *result = f_type_data.get (gdbarch); 1802 if (result == nullptr) 1803 { 1804 result = build_fortran_types (gdbarch); 1805 f_type_data.set (gdbarch, result); 1806 } 1807 1808 return result; 1809 } 1810 1811 /* Command-list for the "set/show fortran" prefix command. */ 1812 static struct cmd_list_element *set_fortran_list; 1813 static struct cmd_list_element *show_fortran_list; 1814 1815 void _initialize_f_language (); 1816 void 1817 _initialize_f_language () 1818 { 1819 add_setshow_prefix_cmd 1820 ("fortran", no_class, 1821 _("Prefix command for changing Fortran-specific settings."), 1822 _("Generic command for showing Fortran-specific settings."), 1823 &set_fortran_list, &show_fortran_list, 1824 &setlist, &showlist); 1825 1826 add_setshow_boolean_cmd ("repack-array-slices", class_vars, 1827 &repack_array_slices, _("\ 1828 Enable or disable repacking of non-contiguous array slices."), _("\ 1829 Show whether non-contiguous array slices are repacked."), _("\ 1830 When the user requests a slice of a Fortran array then we can either return\n\ 1831 a descriptor that describes the array in place (using the original array data\n\ 1832 in its existing location) or the original data can be repacked (copied) to a\n\ 1833 new location.\n\ 1834 \n\ 1835 When the content of the array slice is contiguous within the original array\n\ 1836 then the result will never be repacked, but when the data for the new array\n\ 1837 is non-contiguous within the original array repacking will only be performed\n\ 1838 when this setting is on."), 1839 NULL, 1840 show_repack_array_slices, 1841 &set_fortran_list, &show_fortran_list); 1842 1843 /* Debug Fortran's array slicing logic. */ 1844 add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance, 1845 &fortran_array_slicing_debug, _("\ 1846 Set debugging of Fortran array slicing."), _("\ 1847 Show debugging of Fortran array slicing."), _("\ 1848 When on, debugging of Fortran array slicing is enabled."), 1849 NULL, 1850 show_fortran_array_slicing_debug, 1851 &setdebuglist, &showdebuglist); 1852 } 1853 1854 /* Ensures that function argument VALUE is in the appropriate form to 1855 pass to a Fortran function. Returns a possibly new value that should 1856 be used instead of VALUE. 1857 1858 When IS_ARTIFICIAL is true this indicates an artificial argument, 1859 e.g. hidden string lengths which the GNU Fortran argument passing 1860 convention specifies as being passed by value. 1861 1862 When IS_ARTIFICIAL is false, the argument is passed by pointer. If the 1863 value is already in target memory then return a value that is a pointer 1864 to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate 1865 space in the target, copy VALUE in, and return a pointer to the in 1866 memory copy. */ 1867 1868 static struct value * 1869 fortran_argument_convert (struct value *value, bool is_artificial) 1870 { 1871 if (!is_artificial) 1872 { 1873 /* If the value is not in the inferior e.g. registers values, 1874 convenience variables and user input. */ 1875 if (VALUE_LVAL (value) != lval_memory) 1876 { 1877 struct type *type = value_type (value); 1878 const int length = type->length (); 1879 const CORE_ADDR addr 1880 = value_as_long (value_allocate_space_in_inferior (length)); 1881 write_memory (addr, value_contents (value).data (), length); 1882 struct value *val = value_from_contents_and_address 1883 (type, value_contents (value).data (), addr); 1884 return value_addr (val); 1885 } 1886 else 1887 return value_addr (value); /* Program variables, e.g. arrays. */ 1888 } 1889 return value; 1890 } 1891 1892 /* Prepare (and return) an argument value ready for an inferior function 1893 call to a Fortran function. EXP and POS are the expressions describing 1894 the argument to prepare. ARG_NUM is the argument number being 1895 prepared, with 0 being the first argument and so on. FUNC_TYPE is the 1896 type of the function being called. 1897 1898 IS_INTERNAL_CALL_P is true if this is a call to a function of type 1899 TYPE_CODE_INTERNAL_FUNCTION, otherwise this parameter is false. 1900 1901 NOSIDE has its usual meaning for expression parsing (see eval.c). 1902 1903 Arguments in Fortran are normally passed by address, we coerce the 1904 arguments here rather than in value_arg_coerce as otherwise the call to 1905 malloc (to place the non-lvalue parameters in target memory) is hit by 1906 this Fortran specific logic. This results in malloc being called with a 1907 pointer to an integer followed by an attempt to malloc the arguments to 1908 malloc in target memory. Infinite recursion ensues. */ 1909 1910 static value * 1911 fortran_prepare_argument (struct expression *exp, 1912 expr::operation *subexp, 1913 int arg_num, bool is_internal_call_p, 1914 struct type *func_type, enum noside noside) 1915 { 1916 if (is_internal_call_p) 1917 return subexp->evaluate_with_coercion (exp, noside); 1918 1919 bool is_artificial = ((arg_num >= func_type->num_fields ()) 1920 ? true 1921 : TYPE_FIELD_ARTIFICIAL (func_type, arg_num)); 1922 1923 /* If this is an artificial argument, then either, this is an argument 1924 beyond the end of the known arguments, or possibly, there are no known 1925 arguments (maybe missing debug info). 1926 1927 For these artificial arguments, if the user has prefixed it with '&' 1928 (for address-of), then lets always allow this to succeed, even if the 1929 argument is not actually in inferior memory. This will allow the user 1930 to pass arguments to a Fortran function even when there's no debug 1931 information. 1932 1933 As we already pass the address of non-artificial arguments, all we 1934 need to do if skip the UNOP_ADDR operator in the expression and mark 1935 the argument as non-artificial. */ 1936 if (is_artificial) 1937 { 1938 expr::unop_addr_operation *addrop 1939 = dynamic_cast<expr::unop_addr_operation *> (subexp); 1940 if (addrop != nullptr) 1941 { 1942 subexp = addrop->get_expression ().get (); 1943 is_artificial = false; 1944 } 1945 } 1946 1947 struct value *arg_val = subexp->evaluate_with_coercion (exp, noside); 1948 return fortran_argument_convert (arg_val, is_artificial); 1949 } 1950 1951 /* See f-lang.h. */ 1952 1953 struct type * 1954 fortran_preserve_arg_pointer (struct value *arg, struct type *type) 1955 { 1956 if (value_type (arg)->code () == TYPE_CODE_PTR) 1957 return value_type (arg); 1958 return type; 1959 } 1960 1961 /* See f-lang.h. */ 1962 1963 CORE_ADDR 1964 fortran_adjust_dynamic_array_base_address_hack (struct type *type, 1965 CORE_ADDR address) 1966 { 1967 gdb_assert (type->code () == TYPE_CODE_ARRAY); 1968 1969 /* We can't adjust the base address for arrays that have no content. */ 1970 if (type_not_allocated (type) || type_not_associated (type)) 1971 return address; 1972 1973 int ndimensions = calc_f77_array_dims (type); 1974 LONGEST total_offset = 0; 1975 1976 /* Walk through each of the dimensions of this array type and figure out 1977 if any of the dimensions are "backwards", that is the base address 1978 for this dimension points to the element at the highest memory 1979 address and the stride is negative. */ 1980 struct type *tmp_type = type; 1981 for (int i = 0 ; i < ndimensions; ++i) 1982 { 1983 /* Grab the range for this dimension and extract the lower and upper 1984 bounds. */ 1985 tmp_type = check_typedef (tmp_type); 1986 struct type *range_type = tmp_type->index_type (); 1987 LONGEST lowerbound, upperbound, stride; 1988 if (!get_discrete_bounds (range_type, &lowerbound, &upperbound)) 1989 error ("failed to get range bounds"); 1990 1991 /* Figure out the stride for this dimension. */ 1992 struct type *elt_type = check_typedef (tmp_type->target_type ()); 1993 stride = tmp_type->index_type ()->bounds ()->bit_stride (); 1994 if (stride == 0) 1995 stride = type_length_units (elt_type); 1996 else 1997 { 1998 int unit_size 1999 = gdbarch_addressable_memory_unit_size (elt_type->arch ()); 2000 stride /= (unit_size * 8); 2001 } 2002 2003 /* If this dimension is "backward" then figure out the offset 2004 adjustment required to point to the element at the lowest memory 2005 address, and add this to the total offset. */ 2006 LONGEST offset = 0; 2007 if (stride < 0 && lowerbound < upperbound) 2008 offset = (upperbound - lowerbound) * stride; 2009 total_offset += offset; 2010 tmp_type = tmp_type->target_type (); 2011 } 2012 2013 /* Adjust the address of this object and return it. */ 2014 address += total_offset; 2015 return address; 2016 } 2017