1 /* Ada language support routines for GDB, the GNU debugger. 2 3 Copyright (C) 1992-1994, 1997-2000, 2003-2005, 2007-2012 Free 4 Software Foundation, Inc. 5 6 This file is part of GDB. 7 8 This program is free software; you can redistribute it and/or modify 9 it under the terms of the GNU General Public License as published by 10 the Free Software Foundation; either version 3 of the License, or 11 (at your option) any later version. 12 13 This program is distributed in the hope that it will be useful, 14 but WITHOUT ANY WARRANTY; without even the implied warranty of 15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 GNU General Public License for more details. 17 18 You should have received a copy of the GNU General Public License 19 along with this program. If not, see <http://www.gnu.org/licenses/>. */ 20 21 22 #include "defs.h" 23 #include <stdio.h> 24 #include "gdb_string.h" 25 #include <ctype.h> 26 #include <stdarg.h> 27 #include "demangle.h" 28 #include "gdb_regex.h" 29 #include "frame.h" 30 #include "symtab.h" 31 #include "gdbtypes.h" 32 #include "gdbcmd.h" 33 #include "expression.h" 34 #include "parser-defs.h" 35 #include "language.h" 36 #include "c-lang.h" 37 #include "inferior.h" 38 #include "symfile.h" 39 #include "objfiles.h" 40 #include "breakpoint.h" 41 #include "gdbcore.h" 42 #include "hashtab.h" 43 #include "gdb_obstack.h" 44 #include "ada-lang.h" 45 #include "completer.h" 46 #include "gdb_stat.h" 47 #ifdef UI_OUT 48 #include "ui-out.h" 49 #endif 50 #include "block.h" 51 #include "infcall.h" 52 #include "dictionary.h" 53 #include "exceptions.h" 54 #include "annotate.h" 55 #include "valprint.h" 56 #include "source.h" 57 #include "observer.h" 58 #include "vec.h" 59 #include "stack.h" 60 61 #include "psymtab.h" 62 #include "value.h" 63 #include "mi/mi-common.h" 64 #include "arch-utils.h" 65 #include "exceptions.h" 66 67 /* Define whether or not the C operator '/' truncates towards zero for 68 differently signed operands (truncation direction is undefined in C). 69 Copied from valarith.c. */ 70 71 #ifndef TRUNCATION_TOWARDS_ZERO 72 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2) 73 #endif 74 75 static struct type *desc_base_type (struct type *); 76 77 static struct type *desc_bounds_type (struct type *); 78 79 static struct value *desc_bounds (struct value *); 80 81 static int fat_pntr_bounds_bitpos (struct type *); 82 83 static int fat_pntr_bounds_bitsize (struct type *); 84 85 static struct type *desc_data_target_type (struct type *); 86 87 static struct value *desc_data (struct value *); 88 89 static int fat_pntr_data_bitpos (struct type *); 90 91 static int fat_pntr_data_bitsize (struct type *); 92 93 static struct value *desc_one_bound (struct value *, int, int); 94 95 static int desc_bound_bitpos (struct type *, int, int); 96 97 static int desc_bound_bitsize (struct type *, int, int); 98 99 static struct type *desc_index_type (struct type *, int); 100 101 static int desc_arity (struct type *); 102 103 static int ada_type_match (struct type *, struct type *, int); 104 105 static int ada_args_match (struct symbol *, struct value **, int); 106 107 static int full_match (const char *, const char *); 108 109 static struct value *make_array_descriptor (struct type *, struct value *); 110 111 static void ada_add_block_symbols (struct obstack *, 112 struct block *, const char *, 113 domain_enum, struct objfile *, int); 114 115 static int is_nonfunction (struct ada_symbol_info *, int); 116 117 static void add_defn_to_vec (struct obstack *, struct symbol *, 118 struct block *); 119 120 static int num_defns_collected (struct obstack *); 121 122 static struct ada_symbol_info *defns_collected (struct obstack *, int); 123 124 static struct value *resolve_subexp (struct expression **, int *, int, 125 struct type *); 126 127 static void replace_operator_with_call (struct expression **, int, int, int, 128 struct symbol *, struct block *); 129 130 static int possible_user_operator_p (enum exp_opcode, struct value **); 131 132 static char *ada_op_name (enum exp_opcode); 133 134 static const char *ada_decoded_op_name (enum exp_opcode); 135 136 static int numeric_type_p (struct type *); 137 138 static int integer_type_p (struct type *); 139 140 static int scalar_type_p (struct type *); 141 142 static int discrete_type_p (struct type *); 143 144 static enum ada_renaming_category parse_old_style_renaming (struct type *, 145 const char **, 146 int *, 147 const char **); 148 149 static struct symbol *find_old_style_renaming_symbol (const char *, 150 struct block *); 151 152 static struct type *ada_lookup_struct_elt_type (struct type *, char *, 153 int, int, int *); 154 155 static struct value *evaluate_subexp_type (struct expression *, int *); 156 157 static struct type *ada_find_parallel_type_with_name (struct type *, 158 const char *); 159 160 static int is_dynamic_field (struct type *, int); 161 162 static struct type *to_fixed_variant_branch_type (struct type *, 163 const gdb_byte *, 164 CORE_ADDR, struct value *); 165 166 static struct type *to_fixed_array_type (struct type *, struct value *, int); 167 168 static struct type *to_fixed_range_type (struct type *, struct value *); 169 170 static struct type *to_static_fixed_type (struct type *); 171 static struct type *static_unwrap_type (struct type *type); 172 173 static struct value *unwrap_value (struct value *); 174 175 static struct type *constrained_packed_array_type (struct type *, long *); 176 177 static struct type *decode_constrained_packed_array_type (struct type *); 178 179 static long decode_packed_array_bitsize (struct type *); 180 181 static struct value *decode_constrained_packed_array (struct value *); 182 183 static int ada_is_packed_array_type (struct type *); 184 185 static int ada_is_unconstrained_packed_array_type (struct type *); 186 187 static struct value *value_subscript_packed (struct value *, int, 188 struct value **); 189 190 static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int); 191 192 static struct value *coerce_unspec_val_to_type (struct value *, 193 struct type *); 194 195 static struct value *get_var_value (char *, char *); 196 197 static int lesseq_defined_than (struct symbol *, struct symbol *); 198 199 static int equiv_types (struct type *, struct type *); 200 201 static int is_name_suffix (const char *); 202 203 static int advance_wild_match (const char **, const char *, int); 204 205 static int wild_match (const char *, const char *); 206 207 static struct value *ada_coerce_ref (struct value *); 208 209 static LONGEST pos_atr (struct value *); 210 211 static struct value *value_pos_atr (struct type *, struct value *); 212 213 static struct value *value_val_atr (struct type *, struct value *); 214 215 static struct symbol *standard_lookup (const char *, const struct block *, 216 domain_enum); 217 218 static struct value *ada_search_struct_field (char *, struct value *, int, 219 struct type *); 220 221 static struct value *ada_value_primitive_field (struct value *, int, int, 222 struct type *); 223 224 static int find_struct_field (char *, struct type *, int, 225 struct type **, int *, int *, int *, int *); 226 227 static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR, 228 struct value *); 229 230 static int ada_resolve_function (struct ada_symbol_info *, int, 231 struct value **, int, const char *, 232 struct type *); 233 234 static int ada_is_direct_array_type (struct type *); 235 236 static void ada_language_arch_info (struct gdbarch *, 237 struct language_arch_info *); 238 239 static void check_size (const struct type *); 240 241 static struct value *ada_index_struct_field (int, struct value *, int, 242 struct type *); 243 244 static struct value *assign_aggregate (struct value *, struct value *, 245 struct expression *, 246 int *, enum noside); 247 248 static void aggregate_assign_from_choices (struct value *, struct value *, 249 struct expression *, 250 int *, LONGEST *, int *, 251 int, LONGEST, LONGEST); 252 253 static void aggregate_assign_positional (struct value *, struct value *, 254 struct expression *, 255 int *, LONGEST *, int *, int, 256 LONGEST, LONGEST); 257 258 259 static void aggregate_assign_others (struct value *, struct value *, 260 struct expression *, 261 int *, LONGEST *, int, LONGEST, LONGEST); 262 263 264 static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int); 265 266 267 static struct value *ada_evaluate_subexp (struct type *, struct expression *, 268 int *, enum noside); 269 270 static void ada_forward_operator_length (struct expression *, int, int *, 271 int *); 272 273 274 275 /* Maximum-sized dynamic type. */ 276 static unsigned int varsize_limit; 277 278 /* FIXME: brobecker/2003-09-17: No longer a const because it is 279 returned by a function that does not return a const char *. */ 280 static char *ada_completer_word_break_characters = 281 #ifdef VMS 282 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-"; 283 #else 284 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-"; 285 #endif 286 287 /* The name of the symbol to use to get the name of the main subprogram. */ 288 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[] 289 = "__gnat_ada_main_program_name"; 290 291 /* Limit on the number of warnings to raise per expression evaluation. */ 292 static int warning_limit = 2; 293 294 /* Number of warning messages issued; reset to 0 by cleanups after 295 expression evaluation. */ 296 static int warnings_issued = 0; 297 298 static const char *known_runtime_file_name_patterns[] = { 299 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL 300 }; 301 302 static const char *known_auxiliary_function_name_patterns[] = { 303 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL 304 }; 305 306 /* Space for allocating results of ada_lookup_symbol_list. */ 307 static struct obstack symbol_list_obstack; 308 309 /* Inferior-specific data. */ 310 311 /* Per-inferior data for this module. */ 312 313 struct ada_inferior_data 314 { 315 /* The ada__tags__type_specific_data type, which is used when decoding 316 tagged types. With older versions of GNAT, this type was directly 317 accessible through a component ("tsd") in the object tag. But this 318 is no longer the case, so we cache it for each inferior. */ 319 struct type *tsd_type; 320 321 /* The exception_support_info data. This data is used to determine 322 how to implement support for Ada exception catchpoints in a given 323 inferior. */ 324 const struct exception_support_info *exception_info; 325 }; 326 327 /* Our key to this module's inferior data. */ 328 static const struct inferior_data *ada_inferior_data; 329 330 /* A cleanup routine for our inferior data. */ 331 static void 332 ada_inferior_data_cleanup (struct inferior *inf, void *arg) 333 { 334 struct ada_inferior_data *data; 335 336 data = inferior_data (inf, ada_inferior_data); 337 if (data != NULL) 338 xfree (data); 339 } 340 341 /* Return our inferior data for the given inferior (INF). 342 343 This function always returns a valid pointer to an allocated 344 ada_inferior_data structure. If INF's inferior data has not 345 been previously set, this functions creates a new one with all 346 fields set to zero, sets INF's inferior to it, and then returns 347 a pointer to that newly allocated ada_inferior_data. */ 348 349 static struct ada_inferior_data * 350 get_ada_inferior_data (struct inferior *inf) 351 { 352 struct ada_inferior_data *data; 353 354 data = inferior_data (inf, ada_inferior_data); 355 if (data == NULL) 356 { 357 data = XZALLOC (struct ada_inferior_data); 358 set_inferior_data (inf, ada_inferior_data, data); 359 } 360 361 return data; 362 } 363 364 /* Perform all necessary cleanups regarding our module's inferior data 365 that is required after the inferior INF just exited. */ 366 367 static void 368 ada_inferior_exit (struct inferior *inf) 369 { 370 ada_inferior_data_cleanup (inf, NULL); 371 set_inferior_data (inf, ada_inferior_data, NULL); 372 } 373 374 /* Utilities */ 375 376 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after 377 all typedef layers have been peeled. Otherwise, return TYPE. 378 379 Normally, we really expect a typedef type to only have 1 typedef layer. 380 In other words, we really expect the target type of a typedef type to be 381 a non-typedef type. This is particularly true for Ada units, because 382 the language does not have a typedef vs not-typedef distinction. 383 In that respect, the Ada compiler has been trying to eliminate as many 384 typedef definitions in the debugging information, since they generally 385 do not bring any extra information (we still use typedef under certain 386 circumstances related mostly to the GNAT encoding). 387 388 Unfortunately, we have seen situations where the debugging information 389 generated by the compiler leads to such multiple typedef layers. For 390 instance, consider the following example with stabs: 391 392 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...] 393 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0 394 395 This is an error in the debugging information which causes type 396 pck__float_array___XUP to be defined twice, and the second time, 397 it is defined as a typedef of a typedef. 398 399 This is on the fringe of legality as far as debugging information is 400 concerned, and certainly unexpected. But it is easy to handle these 401 situations correctly, so we can afford to be lenient in this case. */ 402 403 static struct type * 404 ada_typedef_target_type (struct type *type) 405 { 406 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) 407 type = TYPE_TARGET_TYPE (type); 408 return type; 409 } 410 411 /* Given DECODED_NAME a string holding a symbol name in its 412 decoded form (ie using the Ada dotted notation), returns 413 its unqualified name. */ 414 415 static const char * 416 ada_unqualified_name (const char *decoded_name) 417 { 418 const char *result = strrchr (decoded_name, '.'); 419 420 if (result != NULL) 421 result++; /* Skip the dot... */ 422 else 423 result = decoded_name; 424 425 return result; 426 } 427 428 /* Return a string starting with '<', followed by STR, and '>'. 429 The result is good until the next call. */ 430 431 static char * 432 add_angle_brackets (const char *str) 433 { 434 static char *result = NULL; 435 436 xfree (result); 437 result = xstrprintf ("<%s>", str); 438 return result; 439 } 440 441 static char * 442 ada_get_gdb_completer_word_break_characters (void) 443 { 444 return ada_completer_word_break_characters; 445 } 446 447 /* Print an array element index using the Ada syntax. */ 448 449 static void 450 ada_print_array_index (struct value *index_value, struct ui_file *stream, 451 const struct value_print_options *options) 452 { 453 LA_VALUE_PRINT (index_value, stream, options); 454 fprintf_filtered (stream, " => "); 455 } 456 457 /* Assuming VECT points to an array of *SIZE objects of size 458 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects, 459 updating *SIZE as necessary and returning the (new) array. */ 460 461 void * 462 grow_vect (void *vect, size_t *size, size_t min_size, int element_size) 463 { 464 if (*size < min_size) 465 { 466 *size *= 2; 467 if (*size < min_size) 468 *size = min_size; 469 vect = xrealloc (vect, *size * element_size); 470 } 471 return vect; 472 } 473 474 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing 475 suffix of FIELD_NAME beginning "___". */ 476 477 static int 478 field_name_match (const char *field_name, const char *target) 479 { 480 int len = strlen (target); 481 482 return 483 (strncmp (field_name, target, len) == 0 484 && (field_name[len] == '\0' 485 || (strncmp (field_name + len, "___", 3) == 0 486 && strcmp (field_name + strlen (field_name) - 6, 487 "___XVN") != 0))); 488 } 489 490 491 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to 492 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME, 493 and return its index. This function also handles fields whose name 494 have ___ suffixes because the compiler sometimes alters their name 495 by adding such a suffix to represent fields with certain constraints. 496 If the field could not be found, return a negative number if 497 MAYBE_MISSING is set. Otherwise raise an error. */ 498 499 int 500 ada_get_field_index (const struct type *type, const char *field_name, 501 int maybe_missing) 502 { 503 int fieldno; 504 struct type *struct_type = check_typedef ((struct type *) type); 505 506 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++) 507 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name)) 508 return fieldno; 509 510 if (!maybe_missing) 511 error (_("Unable to find field %s in struct %s. Aborting"), 512 field_name, TYPE_NAME (struct_type)); 513 514 return -1; 515 } 516 517 /* The length of the prefix of NAME prior to any "___" suffix. */ 518 519 int 520 ada_name_prefix_len (const char *name) 521 { 522 if (name == NULL) 523 return 0; 524 else 525 { 526 const char *p = strstr (name, "___"); 527 528 if (p == NULL) 529 return strlen (name); 530 else 531 return p - name; 532 } 533 } 534 535 /* Return non-zero if SUFFIX is a suffix of STR. 536 Return zero if STR is null. */ 537 538 static int 539 is_suffix (const char *str, const char *suffix) 540 { 541 int len1, len2; 542 543 if (str == NULL) 544 return 0; 545 len1 = strlen (str); 546 len2 = strlen (suffix); 547 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0); 548 } 549 550 /* The contents of value VAL, treated as a value of type TYPE. The 551 result is an lval in memory if VAL is. */ 552 553 static struct value * 554 coerce_unspec_val_to_type (struct value *val, struct type *type) 555 { 556 type = ada_check_typedef (type); 557 if (value_type (val) == type) 558 return val; 559 else 560 { 561 struct value *result; 562 563 /* Make sure that the object size is not unreasonable before 564 trying to allocate some memory for it. */ 565 check_size (type); 566 567 if (value_lazy (val) 568 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val))) 569 result = allocate_value_lazy (type); 570 else 571 { 572 result = allocate_value (type); 573 memcpy (value_contents_raw (result), value_contents (val), 574 TYPE_LENGTH (type)); 575 } 576 set_value_component_location (result, val); 577 set_value_bitsize (result, value_bitsize (val)); 578 set_value_bitpos (result, value_bitpos (val)); 579 set_value_address (result, value_address (val)); 580 return result; 581 } 582 } 583 584 static const gdb_byte * 585 cond_offset_host (const gdb_byte *valaddr, long offset) 586 { 587 if (valaddr == NULL) 588 return NULL; 589 else 590 return valaddr + offset; 591 } 592 593 static CORE_ADDR 594 cond_offset_target (CORE_ADDR address, long offset) 595 { 596 if (address == 0) 597 return 0; 598 else 599 return address + offset; 600 } 601 602 /* Issue a warning (as for the definition of warning in utils.c, but 603 with exactly one argument rather than ...), unless the limit on the 604 number of warnings has passed during the evaluation of the current 605 expression. */ 606 607 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior 608 provided by "complaint". */ 609 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2); 610 611 static void 612 lim_warning (const char *format, ...) 613 { 614 va_list args; 615 616 va_start (args, format); 617 warnings_issued += 1; 618 if (warnings_issued <= warning_limit) 619 vwarning (format, args); 620 621 va_end (args); 622 } 623 624 /* Issue an error if the size of an object of type T is unreasonable, 625 i.e. if it would be a bad idea to allocate a value of this type in 626 GDB. */ 627 628 static void 629 check_size (const struct type *type) 630 { 631 if (TYPE_LENGTH (type) > varsize_limit) 632 error (_("object size is larger than varsize-limit")); 633 } 634 635 /* Maximum value of a SIZE-byte signed integer type. */ 636 static LONGEST 637 max_of_size (int size) 638 { 639 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2); 640 641 return top_bit | (top_bit - 1); 642 } 643 644 /* Minimum value of a SIZE-byte signed integer type. */ 645 static LONGEST 646 min_of_size (int size) 647 { 648 return -max_of_size (size) - 1; 649 } 650 651 /* Maximum value of a SIZE-byte unsigned integer type. */ 652 static ULONGEST 653 umax_of_size (int size) 654 { 655 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1); 656 657 return top_bit | (top_bit - 1); 658 } 659 660 /* Maximum value of integral type T, as a signed quantity. */ 661 static LONGEST 662 max_of_type (struct type *t) 663 { 664 if (TYPE_UNSIGNED (t)) 665 return (LONGEST) umax_of_size (TYPE_LENGTH (t)); 666 else 667 return max_of_size (TYPE_LENGTH (t)); 668 } 669 670 /* Minimum value of integral type T, as a signed quantity. */ 671 static LONGEST 672 min_of_type (struct type *t) 673 { 674 if (TYPE_UNSIGNED (t)) 675 return 0; 676 else 677 return min_of_size (TYPE_LENGTH (t)); 678 } 679 680 /* The largest value in the domain of TYPE, a discrete type, as an integer. */ 681 LONGEST 682 ada_discrete_type_high_bound (struct type *type) 683 { 684 switch (TYPE_CODE (type)) 685 { 686 case TYPE_CODE_RANGE: 687 return TYPE_HIGH_BOUND (type); 688 case TYPE_CODE_ENUM: 689 return TYPE_FIELD_BITPOS (type, TYPE_NFIELDS (type) - 1); 690 case TYPE_CODE_BOOL: 691 return 1; 692 case TYPE_CODE_CHAR: 693 case TYPE_CODE_INT: 694 return max_of_type (type); 695 default: 696 error (_("Unexpected type in ada_discrete_type_high_bound.")); 697 } 698 } 699 700 /* The largest value in the domain of TYPE, a discrete type, as an integer. */ 701 LONGEST 702 ada_discrete_type_low_bound (struct type *type) 703 { 704 switch (TYPE_CODE (type)) 705 { 706 case TYPE_CODE_RANGE: 707 return TYPE_LOW_BOUND (type); 708 case TYPE_CODE_ENUM: 709 return TYPE_FIELD_BITPOS (type, 0); 710 case TYPE_CODE_BOOL: 711 return 0; 712 case TYPE_CODE_CHAR: 713 case TYPE_CODE_INT: 714 return min_of_type (type); 715 default: 716 error (_("Unexpected type in ada_discrete_type_low_bound.")); 717 } 718 } 719 720 /* The identity on non-range types. For range types, the underlying 721 non-range scalar type. */ 722 723 static struct type * 724 get_base_type (struct type *type) 725 { 726 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE) 727 { 728 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL) 729 return type; 730 type = TYPE_TARGET_TYPE (type); 731 } 732 return type; 733 } 734 735 736 /* Language Selection */ 737 738 /* If the main program is in Ada, return language_ada, otherwise return LANG 739 (the main program is in Ada iif the adainit symbol is found). */ 740 741 enum language 742 ada_update_initial_language (enum language lang) 743 { 744 if (lookup_minimal_symbol ("adainit", (const char *) NULL, 745 (struct objfile *) NULL) != NULL) 746 return language_ada; 747 748 return lang; 749 } 750 751 /* If the main procedure is written in Ada, then return its name. 752 The result is good until the next call. Return NULL if the main 753 procedure doesn't appear to be in Ada. */ 754 755 char * 756 ada_main_name (void) 757 { 758 struct minimal_symbol *msym; 759 static char *main_program_name = NULL; 760 761 /* For Ada, the name of the main procedure is stored in a specific 762 string constant, generated by the binder. Look for that symbol, 763 extract its address, and then read that string. If we didn't find 764 that string, then most probably the main procedure is not written 765 in Ada. */ 766 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL); 767 768 if (msym != NULL) 769 { 770 CORE_ADDR main_program_name_addr; 771 int err_code; 772 773 main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym); 774 if (main_program_name_addr == 0) 775 error (_("Invalid address for Ada main program name.")); 776 777 xfree (main_program_name); 778 target_read_string (main_program_name_addr, &main_program_name, 779 1024, &err_code); 780 781 if (err_code != 0) 782 return NULL; 783 return main_program_name; 784 } 785 786 /* The main procedure doesn't seem to be in Ada. */ 787 return NULL; 788 } 789 790 /* Symbols */ 791 792 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair 793 of NULLs. */ 794 795 const struct ada_opname_map ada_opname_table[] = { 796 {"Oadd", "\"+\"", BINOP_ADD}, 797 {"Osubtract", "\"-\"", BINOP_SUB}, 798 {"Omultiply", "\"*\"", BINOP_MUL}, 799 {"Odivide", "\"/\"", BINOP_DIV}, 800 {"Omod", "\"mod\"", BINOP_MOD}, 801 {"Orem", "\"rem\"", BINOP_REM}, 802 {"Oexpon", "\"**\"", BINOP_EXP}, 803 {"Olt", "\"<\"", BINOP_LESS}, 804 {"Ole", "\"<=\"", BINOP_LEQ}, 805 {"Ogt", "\">\"", BINOP_GTR}, 806 {"Oge", "\">=\"", BINOP_GEQ}, 807 {"Oeq", "\"=\"", BINOP_EQUAL}, 808 {"One", "\"/=\"", BINOP_NOTEQUAL}, 809 {"Oand", "\"and\"", BINOP_BITWISE_AND}, 810 {"Oor", "\"or\"", BINOP_BITWISE_IOR}, 811 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR}, 812 {"Oconcat", "\"&\"", BINOP_CONCAT}, 813 {"Oabs", "\"abs\"", UNOP_ABS}, 814 {"Onot", "\"not\"", UNOP_LOGICAL_NOT}, 815 {"Oadd", "\"+\"", UNOP_PLUS}, 816 {"Osubtract", "\"-\"", UNOP_NEG}, 817 {NULL, NULL} 818 }; 819 820 /* The "encoded" form of DECODED, according to GNAT conventions. 821 The result is valid until the next call to ada_encode. */ 822 823 char * 824 ada_encode (const char *decoded) 825 { 826 static char *encoding_buffer = NULL; 827 static size_t encoding_buffer_size = 0; 828 const char *p; 829 int k; 830 831 if (decoded == NULL) 832 return NULL; 833 834 GROW_VECT (encoding_buffer, encoding_buffer_size, 835 2 * strlen (decoded) + 10); 836 837 k = 0; 838 for (p = decoded; *p != '\0'; p += 1) 839 { 840 if (*p == '.') 841 { 842 encoding_buffer[k] = encoding_buffer[k + 1] = '_'; 843 k += 2; 844 } 845 else if (*p == '"') 846 { 847 const struct ada_opname_map *mapping; 848 849 for (mapping = ada_opname_table; 850 mapping->encoded != NULL 851 && strncmp (mapping->decoded, p, 852 strlen (mapping->decoded)) != 0; mapping += 1) 853 ; 854 if (mapping->encoded == NULL) 855 error (_("invalid Ada operator name: %s"), p); 856 strcpy (encoding_buffer + k, mapping->encoded); 857 k += strlen (mapping->encoded); 858 break; 859 } 860 else 861 { 862 encoding_buffer[k] = *p; 863 k += 1; 864 } 865 } 866 867 encoding_buffer[k] = '\0'; 868 return encoding_buffer; 869 } 870 871 /* Return NAME folded to lower case, or, if surrounded by single 872 quotes, unfolded, but with the quotes stripped away. Result good 873 to next call. */ 874 875 char * 876 ada_fold_name (const char *name) 877 { 878 static char *fold_buffer = NULL; 879 static size_t fold_buffer_size = 0; 880 881 int len = strlen (name); 882 GROW_VECT (fold_buffer, fold_buffer_size, len + 1); 883 884 if (name[0] == '\'') 885 { 886 strncpy (fold_buffer, name + 1, len - 2); 887 fold_buffer[len - 2] = '\000'; 888 } 889 else 890 { 891 int i; 892 893 for (i = 0; i <= len; i += 1) 894 fold_buffer[i] = tolower (name[i]); 895 } 896 897 return fold_buffer; 898 } 899 900 /* Return nonzero if C is either a digit or a lowercase alphabet character. */ 901 902 static int 903 is_lower_alphanum (const char c) 904 { 905 return (isdigit (c) || (isalpha (c) && islower (c))); 906 } 907 908 /* ENCODED is the linkage name of a symbol and LEN contains its length. 909 This function saves in LEN the length of that same symbol name but 910 without either of these suffixes: 911 . .{DIGIT}+ 912 . ${DIGIT}+ 913 . ___{DIGIT}+ 914 . __{DIGIT}+. 915 916 These are suffixes introduced by the compiler for entities such as 917 nested subprogram for instance, in order to avoid name clashes. 918 They do not serve any purpose for the debugger. */ 919 920 static void 921 ada_remove_trailing_digits (const char *encoded, int *len) 922 { 923 if (*len > 1 && isdigit (encoded[*len - 1])) 924 { 925 int i = *len - 2; 926 927 while (i > 0 && isdigit (encoded[i])) 928 i--; 929 if (i >= 0 && encoded[i] == '.') 930 *len = i; 931 else if (i >= 0 && encoded[i] == '$') 932 *len = i; 933 else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0) 934 *len = i - 2; 935 else if (i >= 1 && strncmp (encoded + i - 1, "__", 2) == 0) 936 *len = i - 1; 937 } 938 } 939 940 /* Remove the suffix introduced by the compiler for protected object 941 subprograms. */ 942 943 static void 944 ada_remove_po_subprogram_suffix (const char *encoded, int *len) 945 { 946 /* Remove trailing N. */ 947 948 /* Protected entry subprograms are broken into two 949 separate subprograms: The first one is unprotected, and has 950 a 'N' suffix; the second is the protected version, and has 951 the 'P' suffix. The second calls the first one after handling 952 the protection. Since the P subprograms are internally generated, 953 we leave these names undecoded, giving the user a clue that this 954 entity is internal. */ 955 956 if (*len > 1 957 && encoded[*len - 1] == 'N' 958 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2]))) 959 *len = *len - 1; 960 } 961 962 /* Remove trailing X[bn]* suffixes (indicating names in package bodies). */ 963 964 static void 965 ada_remove_Xbn_suffix (const char *encoded, int *len) 966 { 967 int i = *len - 1; 968 969 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n')) 970 i--; 971 972 if (encoded[i] != 'X') 973 return; 974 975 if (i == 0) 976 return; 977 978 if (isalnum (encoded[i-1])) 979 *len = i; 980 } 981 982 /* If ENCODED follows the GNAT entity encoding conventions, then return 983 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is 984 replaced by ENCODED. 985 986 The resulting string is valid until the next call of ada_decode. 987 If the string is unchanged by decoding, the original string pointer 988 is returned. */ 989 990 const char * 991 ada_decode (const char *encoded) 992 { 993 int i, j; 994 int len0; 995 const char *p; 996 char *decoded; 997 int at_start_name; 998 static char *decoding_buffer = NULL; 999 static size_t decoding_buffer_size = 0; 1000 1001 /* The name of the Ada main procedure starts with "_ada_". 1002 This prefix is not part of the decoded name, so skip this part 1003 if we see this prefix. */ 1004 if (strncmp (encoded, "_ada_", 5) == 0) 1005 encoded += 5; 1006 1007 /* If the name starts with '_', then it is not a properly encoded 1008 name, so do not attempt to decode it. Similarly, if the name 1009 starts with '<', the name should not be decoded. */ 1010 if (encoded[0] == '_' || encoded[0] == '<') 1011 goto Suppress; 1012 1013 len0 = strlen (encoded); 1014 1015 ada_remove_trailing_digits (encoded, &len0); 1016 ada_remove_po_subprogram_suffix (encoded, &len0); 1017 1018 /* Remove the ___X.* suffix if present. Do not forget to verify that 1019 the suffix is located before the current "end" of ENCODED. We want 1020 to avoid re-matching parts of ENCODED that have previously been 1021 marked as discarded (by decrementing LEN0). */ 1022 p = strstr (encoded, "___"); 1023 if (p != NULL && p - encoded < len0 - 3) 1024 { 1025 if (p[3] == 'X') 1026 len0 = p - encoded; 1027 else 1028 goto Suppress; 1029 } 1030 1031 /* Remove any trailing TKB suffix. It tells us that this symbol 1032 is for the body of a task, but that information does not actually 1033 appear in the decoded name. */ 1034 1035 if (len0 > 3 && strncmp (encoded + len0 - 3, "TKB", 3) == 0) 1036 len0 -= 3; 1037 1038 /* Remove any trailing TB suffix. The TB suffix is slightly different 1039 from the TKB suffix because it is used for non-anonymous task 1040 bodies. */ 1041 1042 if (len0 > 2 && strncmp (encoded + len0 - 2, "TB", 2) == 0) 1043 len0 -= 2; 1044 1045 /* Remove trailing "B" suffixes. */ 1046 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */ 1047 1048 if (len0 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0) 1049 len0 -= 1; 1050 1051 /* Make decoded big enough for possible expansion by operator name. */ 1052 1053 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1); 1054 decoded = decoding_buffer; 1055 1056 /* Remove trailing __{digit}+ or trailing ${digit}+. */ 1057 1058 if (len0 > 1 && isdigit (encoded[len0 - 1])) 1059 { 1060 i = len0 - 2; 1061 while ((i >= 0 && isdigit (encoded[i])) 1062 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1]))) 1063 i -= 1; 1064 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_') 1065 len0 = i - 1; 1066 else if (encoded[i] == '$') 1067 len0 = i; 1068 } 1069 1070 /* The first few characters that are not alphabetic are not part 1071 of any encoding we use, so we can copy them over verbatim. */ 1072 1073 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1) 1074 decoded[j] = encoded[i]; 1075 1076 at_start_name = 1; 1077 while (i < len0) 1078 { 1079 /* Is this a symbol function? */ 1080 if (at_start_name && encoded[i] == 'O') 1081 { 1082 int k; 1083 1084 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1) 1085 { 1086 int op_len = strlen (ada_opname_table[k].encoded); 1087 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1, 1088 op_len - 1) == 0) 1089 && !isalnum (encoded[i + op_len])) 1090 { 1091 strcpy (decoded + j, ada_opname_table[k].decoded); 1092 at_start_name = 0; 1093 i += op_len; 1094 j += strlen (ada_opname_table[k].decoded); 1095 break; 1096 } 1097 } 1098 if (ada_opname_table[k].encoded != NULL) 1099 continue; 1100 } 1101 at_start_name = 0; 1102 1103 /* Replace "TK__" with "__", which will eventually be translated 1104 into "." (just below). */ 1105 1106 if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0) 1107 i += 2; 1108 1109 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually 1110 be translated into "." (just below). These are internal names 1111 generated for anonymous blocks inside which our symbol is nested. */ 1112 1113 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_' 1114 && encoded [i+2] == 'B' && encoded [i+3] == '_' 1115 && isdigit (encoded [i+4])) 1116 { 1117 int k = i + 5; 1118 1119 while (k < len0 && isdigit (encoded[k])) 1120 k++; /* Skip any extra digit. */ 1121 1122 /* Double-check that the "__B_{DIGITS}+" sequence we found 1123 is indeed followed by "__". */ 1124 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_') 1125 i = k; 1126 } 1127 1128 /* Remove _E{DIGITS}+[sb] */ 1129 1130 /* Just as for protected object subprograms, there are 2 categories 1131 of subprograms created by the compiler for each entry. The first 1132 one implements the actual entry code, and has a suffix following 1133 the convention above; the second one implements the barrier and 1134 uses the same convention as above, except that the 'E' is replaced 1135 by a 'B'. 1136 1137 Just as above, we do not decode the name of barrier functions 1138 to give the user a clue that the code he is debugging has been 1139 internally generated. */ 1140 1141 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E' 1142 && isdigit (encoded[i+2])) 1143 { 1144 int k = i + 3; 1145 1146 while (k < len0 && isdigit (encoded[k])) 1147 k++; 1148 1149 if (k < len0 1150 && (encoded[k] == 'b' || encoded[k] == 's')) 1151 { 1152 k++; 1153 /* Just as an extra precaution, make sure that if this 1154 suffix is followed by anything else, it is a '_'. 1155 Otherwise, we matched this sequence by accident. */ 1156 if (k == len0 1157 || (k < len0 && encoded[k] == '_')) 1158 i = k; 1159 } 1160 } 1161 1162 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by 1163 the GNAT front-end in protected object subprograms. */ 1164 1165 if (i < len0 + 3 1166 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_') 1167 { 1168 /* Backtrack a bit up until we reach either the begining of 1169 the encoded name, or "__". Make sure that we only find 1170 digits or lowercase characters. */ 1171 const char *ptr = encoded + i - 1; 1172 1173 while (ptr >= encoded && is_lower_alphanum (ptr[0])) 1174 ptr--; 1175 if (ptr < encoded 1176 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_')) 1177 i++; 1178 } 1179 1180 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1])) 1181 { 1182 /* This is a X[bn]* sequence not separated from the previous 1183 part of the name with a non-alpha-numeric character (in other 1184 words, immediately following an alpha-numeric character), then 1185 verify that it is placed at the end of the encoded name. If 1186 not, then the encoding is not valid and we should abort the 1187 decoding. Otherwise, just skip it, it is used in body-nested 1188 package names. */ 1189 do 1190 i += 1; 1191 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n')); 1192 if (i < len0) 1193 goto Suppress; 1194 } 1195 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_') 1196 { 1197 /* Replace '__' by '.'. */ 1198 decoded[j] = '.'; 1199 at_start_name = 1; 1200 i += 2; 1201 j += 1; 1202 } 1203 else 1204 { 1205 /* It's a character part of the decoded name, so just copy it 1206 over. */ 1207 decoded[j] = encoded[i]; 1208 i += 1; 1209 j += 1; 1210 } 1211 } 1212 decoded[j] = '\000'; 1213 1214 /* Decoded names should never contain any uppercase character. 1215 Double-check this, and abort the decoding if we find one. */ 1216 1217 for (i = 0; decoded[i] != '\0'; i += 1) 1218 if (isupper (decoded[i]) || decoded[i] == ' ') 1219 goto Suppress; 1220 1221 if (strcmp (decoded, encoded) == 0) 1222 return encoded; 1223 else 1224 return decoded; 1225 1226 Suppress: 1227 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3); 1228 decoded = decoding_buffer; 1229 if (encoded[0] == '<') 1230 strcpy (decoded, encoded); 1231 else 1232 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded); 1233 return decoded; 1234 1235 } 1236 1237 /* Table for keeping permanent unique copies of decoded names. Once 1238 allocated, names in this table are never released. While this is a 1239 storage leak, it should not be significant unless there are massive 1240 changes in the set of decoded names in successive versions of a 1241 symbol table loaded during a single session. */ 1242 static struct htab *decoded_names_store; 1243 1244 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it 1245 in the language-specific part of GSYMBOL, if it has not been 1246 previously computed. Tries to save the decoded name in the same 1247 obstack as GSYMBOL, if possible, and otherwise on the heap (so that, 1248 in any case, the decoded symbol has a lifetime at least that of 1249 GSYMBOL). 1250 The GSYMBOL parameter is "mutable" in the C++ sense: logically 1251 const, but nevertheless modified to a semantically equivalent form 1252 when a decoded name is cached in it. */ 1253 1254 char * 1255 ada_decode_symbol (const struct general_symbol_info *gsymbol) 1256 { 1257 char **resultp = 1258 (char **) &gsymbol->language_specific.mangled_lang.demangled_name; 1259 1260 if (*resultp == NULL) 1261 { 1262 const char *decoded = ada_decode (gsymbol->name); 1263 1264 if (gsymbol->obj_section != NULL) 1265 { 1266 struct objfile *objf = gsymbol->obj_section->objfile; 1267 1268 *resultp = obsavestring (decoded, strlen (decoded), 1269 &objf->objfile_obstack); 1270 } 1271 /* Sometimes, we can't find a corresponding objfile, in which 1272 case, we put the result on the heap. Since we only decode 1273 when needed, we hope this usually does not cause a 1274 significant memory leak (FIXME). */ 1275 if (*resultp == NULL) 1276 { 1277 char **slot = (char **) htab_find_slot (decoded_names_store, 1278 decoded, INSERT); 1279 1280 if (*slot == NULL) 1281 *slot = xstrdup (decoded); 1282 *resultp = *slot; 1283 } 1284 } 1285 1286 return *resultp; 1287 } 1288 1289 static char * 1290 ada_la_decode (const char *encoded, int options) 1291 { 1292 return xstrdup (ada_decode (encoded)); 1293 } 1294 1295 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing 1296 suffixes that encode debugging information or leading _ada_ on 1297 SYM_NAME (see is_name_suffix commentary for the debugging 1298 information that is ignored). If WILD, then NAME need only match a 1299 suffix of SYM_NAME minus the same suffixes. Also returns 0 if 1300 either argument is NULL. */ 1301 1302 static int 1303 match_name (const char *sym_name, const char *name, int wild) 1304 { 1305 if (sym_name == NULL || name == NULL) 1306 return 0; 1307 else if (wild) 1308 return wild_match (sym_name, name) == 0; 1309 else 1310 { 1311 int len_name = strlen (name); 1312 1313 return (strncmp (sym_name, name, len_name) == 0 1314 && is_name_suffix (sym_name + len_name)) 1315 || (strncmp (sym_name, "_ada_", 5) == 0 1316 && strncmp (sym_name + 5, name, len_name) == 0 1317 && is_name_suffix (sym_name + len_name + 5)); 1318 } 1319 } 1320 1321 1322 /* Arrays */ 1323 1324 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure 1325 generated by the GNAT compiler to describe the index type used 1326 for each dimension of an array, check whether it follows the latest 1327 known encoding. If not, fix it up to conform to the latest encoding. 1328 Otherwise, do nothing. This function also does nothing if 1329 INDEX_DESC_TYPE is NULL. 1330 1331 The GNAT encoding used to describle the array index type evolved a bit. 1332 Initially, the information would be provided through the name of each 1333 field of the structure type only, while the type of these fields was 1334 described as unspecified and irrelevant. The debugger was then expected 1335 to perform a global type lookup using the name of that field in order 1336 to get access to the full index type description. Because these global 1337 lookups can be very expensive, the encoding was later enhanced to make 1338 the global lookup unnecessary by defining the field type as being 1339 the full index type description. 1340 1341 The purpose of this routine is to allow us to support older versions 1342 of the compiler by detecting the use of the older encoding, and by 1343 fixing up the INDEX_DESC_TYPE to follow the new one (at this point, 1344 we essentially replace each field's meaningless type by the associated 1345 index subtype). */ 1346 1347 void 1348 ada_fixup_array_indexes_type (struct type *index_desc_type) 1349 { 1350 int i; 1351 1352 if (index_desc_type == NULL) 1353 return; 1354 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0); 1355 1356 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient 1357 to check one field only, no need to check them all). If not, return 1358 now. 1359 1360 If our INDEX_DESC_TYPE was generated using the older encoding, 1361 the field type should be a meaningless integer type whose name 1362 is not equal to the field name. */ 1363 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL 1364 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)), 1365 TYPE_FIELD_NAME (index_desc_type, 0)) == 0) 1366 return; 1367 1368 /* Fixup each field of INDEX_DESC_TYPE. */ 1369 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++) 1370 { 1371 char *name = TYPE_FIELD_NAME (index_desc_type, i); 1372 struct type *raw_type = ada_check_typedef (ada_find_any_type (name)); 1373 1374 if (raw_type) 1375 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type; 1376 } 1377 } 1378 1379 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */ 1380 1381 static char *bound_name[] = { 1382 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3", 1383 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7" 1384 }; 1385 1386 /* Maximum number of array dimensions we are prepared to handle. */ 1387 1388 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *))) 1389 1390 1391 /* The desc_* routines return primitive portions of array descriptors 1392 (fat pointers). */ 1393 1394 /* The descriptor or array type, if any, indicated by TYPE; removes 1395 level of indirection, if needed. */ 1396 1397 static struct type * 1398 desc_base_type (struct type *type) 1399 { 1400 if (type == NULL) 1401 return NULL; 1402 type = ada_check_typedef (type); 1403 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) 1404 type = ada_typedef_target_type (type); 1405 1406 if (type != NULL 1407 && (TYPE_CODE (type) == TYPE_CODE_PTR 1408 || TYPE_CODE (type) == TYPE_CODE_REF)) 1409 return ada_check_typedef (TYPE_TARGET_TYPE (type)); 1410 else 1411 return type; 1412 } 1413 1414 /* True iff TYPE indicates a "thin" array pointer type. */ 1415 1416 static int 1417 is_thin_pntr (struct type *type) 1418 { 1419 return 1420 is_suffix (ada_type_name (desc_base_type (type)), "___XUT") 1421 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE"); 1422 } 1423 1424 /* The descriptor type for thin pointer type TYPE. */ 1425 1426 static struct type * 1427 thin_descriptor_type (struct type *type) 1428 { 1429 struct type *base_type = desc_base_type (type); 1430 1431 if (base_type == NULL) 1432 return NULL; 1433 if (is_suffix (ada_type_name (base_type), "___XVE")) 1434 return base_type; 1435 else 1436 { 1437 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE"); 1438 1439 if (alt_type == NULL) 1440 return base_type; 1441 else 1442 return alt_type; 1443 } 1444 } 1445 1446 /* A pointer to the array data for thin-pointer value VAL. */ 1447 1448 static struct value * 1449 thin_data_pntr (struct value *val) 1450 { 1451 struct type *type = ada_check_typedef (value_type (val)); 1452 struct type *data_type = desc_data_target_type (thin_descriptor_type (type)); 1453 1454 data_type = lookup_pointer_type (data_type); 1455 1456 if (TYPE_CODE (type) == TYPE_CODE_PTR) 1457 return value_cast (data_type, value_copy (val)); 1458 else 1459 return value_from_longest (data_type, value_address (val)); 1460 } 1461 1462 /* True iff TYPE indicates a "thick" array pointer type. */ 1463 1464 static int 1465 is_thick_pntr (struct type *type) 1466 { 1467 type = desc_base_type (type); 1468 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT 1469 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL); 1470 } 1471 1472 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a 1473 pointer to one, the type of its bounds data; otherwise, NULL. */ 1474 1475 static struct type * 1476 desc_bounds_type (struct type *type) 1477 { 1478 struct type *r; 1479 1480 type = desc_base_type (type); 1481 1482 if (type == NULL) 1483 return NULL; 1484 else if (is_thin_pntr (type)) 1485 { 1486 type = thin_descriptor_type (type); 1487 if (type == NULL) 1488 return NULL; 1489 r = lookup_struct_elt_type (type, "BOUNDS", 1); 1490 if (r != NULL) 1491 return ada_check_typedef (r); 1492 } 1493 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT) 1494 { 1495 r = lookup_struct_elt_type (type, "P_BOUNDS", 1); 1496 if (r != NULL) 1497 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r))); 1498 } 1499 return NULL; 1500 } 1501 1502 /* If ARR is an array descriptor (fat or thin pointer), or pointer to 1503 one, a pointer to its bounds data. Otherwise NULL. */ 1504 1505 static struct value * 1506 desc_bounds (struct value *arr) 1507 { 1508 struct type *type = ada_check_typedef (value_type (arr)); 1509 1510 if (is_thin_pntr (type)) 1511 { 1512 struct type *bounds_type = 1513 desc_bounds_type (thin_descriptor_type (type)); 1514 LONGEST addr; 1515 1516 if (bounds_type == NULL) 1517 error (_("Bad GNAT array descriptor")); 1518 1519 /* NOTE: The following calculation is not really kosher, but 1520 since desc_type is an XVE-encoded type (and shouldn't be), 1521 the correct calculation is a real pain. FIXME (and fix GCC). */ 1522 if (TYPE_CODE (type) == TYPE_CODE_PTR) 1523 addr = value_as_long (arr); 1524 else 1525 addr = value_address (arr); 1526 1527 return 1528 value_from_longest (lookup_pointer_type (bounds_type), 1529 addr - TYPE_LENGTH (bounds_type)); 1530 } 1531 1532 else if (is_thick_pntr (type)) 1533 { 1534 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL, 1535 _("Bad GNAT array descriptor")); 1536 struct type *p_bounds_type = value_type (p_bounds); 1537 1538 if (p_bounds_type 1539 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR) 1540 { 1541 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type); 1542 1543 if (TYPE_STUB (target_type)) 1544 p_bounds = value_cast (lookup_pointer_type 1545 (ada_check_typedef (target_type)), 1546 p_bounds); 1547 } 1548 else 1549 error (_("Bad GNAT array descriptor")); 1550 1551 return p_bounds; 1552 } 1553 else 1554 return NULL; 1555 } 1556 1557 /* If TYPE is the type of an array-descriptor (fat pointer), the bit 1558 position of the field containing the address of the bounds data. */ 1559 1560 static int 1561 fat_pntr_bounds_bitpos (struct type *type) 1562 { 1563 return TYPE_FIELD_BITPOS (desc_base_type (type), 1); 1564 } 1565 1566 /* If TYPE is the type of an array-descriptor (fat pointer), the bit 1567 size of the field containing the address of the bounds data. */ 1568 1569 static int 1570 fat_pntr_bounds_bitsize (struct type *type) 1571 { 1572 type = desc_base_type (type); 1573 1574 if (TYPE_FIELD_BITSIZE (type, 1) > 0) 1575 return TYPE_FIELD_BITSIZE (type, 1); 1576 else 1577 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1))); 1578 } 1579 1580 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a 1581 pointer to one, the type of its array data (a array-with-no-bounds type); 1582 otherwise, NULL. Use ada_type_of_array to get an array type with bounds 1583 data. */ 1584 1585 static struct type * 1586 desc_data_target_type (struct type *type) 1587 { 1588 type = desc_base_type (type); 1589 1590 /* NOTE: The following is bogus; see comment in desc_bounds. */ 1591 if (is_thin_pntr (type)) 1592 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1)); 1593 else if (is_thick_pntr (type)) 1594 { 1595 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1); 1596 1597 if (data_type 1598 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR) 1599 return ada_check_typedef (TYPE_TARGET_TYPE (data_type)); 1600 } 1601 1602 return NULL; 1603 } 1604 1605 /* If ARR is an array descriptor (fat or thin pointer), a pointer to 1606 its array data. */ 1607 1608 static struct value * 1609 desc_data (struct value *arr) 1610 { 1611 struct type *type = value_type (arr); 1612 1613 if (is_thin_pntr (type)) 1614 return thin_data_pntr (arr); 1615 else if (is_thick_pntr (type)) 1616 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL, 1617 _("Bad GNAT array descriptor")); 1618 else 1619 return NULL; 1620 } 1621 1622 1623 /* If TYPE is the type of an array-descriptor (fat pointer), the bit 1624 position of the field containing the address of the data. */ 1625 1626 static int 1627 fat_pntr_data_bitpos (struct type *type) 1628 { 1629 return TYPE_FIELD_BITPOS (desc_base_type (type), 0); 1630 } 1631 1632 /* If TYPE is the type of an array-descriptor (fat pointer), the bit 1633 size of the field containing the address of the data. */ 1634 1635 static int 1636 fat_pntr_data_bitsize (struct type *type) 1637 { 1638 type = desc_base_type (type); 1639 1640 if (TYPE_FIELD_BITSIZE (type, 0) > 0) 1641 return TYPE_FIELD_BITSIZE (type, 0); 1642 else 1643 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0)); 1644 } 1645 1646 /* If BOUNDS is an array-bounds structure (or pointer to one), return 1647 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper 1648 bound, if WHICH is 1. The first bound is I=1. */ 1649 1650 static struct value * 1651 desc_one_bound (struct value *bounds, int i, int which) 1652 { 1653 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL, 1654 _("Bad GNAT array descriptor bounds")); 1655 } 1656 1657 /* If BOUNDS is an array-bounds structure type, return the bit position 1658 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper 1659 bound, if WHICH is 1. The first bound is I=1. */ 1660 1661 static int 1662 desc_bound_bitpos (struct type *type, int i, int which) 1663 { 1664 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2); 1665 } 1666 1667 /* If BOUNDS is an array-bounds structure type, return the bit field size 1668 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper 1669 bound, if WHICH is 1. The first bound is I=1. */ 1670 1671 static int 1672 desc_bound_bitsize (struct type *type, int i, int which) 1673 { 1674 type = desc_base_type (type); 1675 1676 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0) 1677 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2); 1678 else 1679 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2)); 1680 } 1681 1682 /* If TYPE is the type of an array-bounds structure, the type of its 1683 Ith bound (numbering from 1). Otherwise, NULL. */ 1684 1685 static struct type * 1686 desc_index_type (struct type *type, int i) 1687 { 1688 type = desc_base_type (type); 1689 1690 if (TYPE_CODE (type) == TYPE_CODE_STRUCT) 1691 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1); 1692 else 1693 return NULL; 1694 } 1695 1696 /* The number of index positions in the array-bounds type TYPE. 1697 Return 0 if TYPE is NULL. */ 1698 1699 static int 1700 desc_arity (struct type *type) 1701 { 1702 type = desc_base_type (type); 1703 1704 if (type != NULL) 1705 return TYPE_NFIELDS (type) / 2; 1706 return 0; 1707 } 1708 1709 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or 1710 an array descriptor type (representing an unconstrained array 1711 type). */ 1712 1713 static int 1714 ada_is_direct_array_type (struct type *type) 1715 { 1716 if (type == NULL) 1717 return 0; 1718 type = ada_check_typedef (type); 1719 return (TYPE_CODE (type) == TYPE_CODE_ARRAY 1720 || ada_is_array_descriptor_type (type)); 1721 } 1722 1723 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer 1724 * to one. */ 1725 1726 static int 1727 ada_is_array_type (struct type *type) 1728 { 1729 while (type != NULL 1730 && (TYPE_CODE (type) == TYPE_CODE_PTR 1731 || TYPE_CODE (type) == TYPE_CODE_REF)) 1732 type = TYPE_TARGET_TYPE (type); 1733 return ada_is_direct_array_type (type); 1734 } 1735 1736 /* Non-zero iff TYPE is a simple array type or pointer to one. */ 1737 1738 int 1739 ada_is_simple_array_type (struct type *type) 1740 { 1741 if (type == NULL) 1742 return 0; 1743 type = ada_check_typedef (type); 1744 return (TYPE_CODE (type) == TYPE_CODE_ARRAY 1745 || (TYPE_CODE (type) == TYPE_CODE_PTR 1746 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))) 1747 == TYPE_CODE_ARRAY)); 1748 } 1749 1750 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */ 1751 1752 int 1753 ada_is_array_descriptor_type (struct type *type) 1754 { 1755 struct type *data_type = desc_data_target_type (type); 1756 1757 if (type == NULL) 1758 return 0; 1759 type = ada_check_typedef (type); 1760 return (data_type != NULL 1761 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY 1762 && desc_arity (desc_bounds_type (type)) > 0); 1763 } 1764 1765 /* Non-zero iff type is a partially mal-formed GNAT array 1766 descriptor. FIXME: This is to compensate for some problems with 1767 debugging output from GNAT. Re-examine periodically to see if it 1768 is still needed. */ 1769 1770 int 1771 ada_is_bogus_array_descriptor (struct type *type) 1772 { 1773 return 1774 type != NULL 1775 && TYPE_CODE (type) == TYPE_CODE_STRUCT 1776 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL 1777 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL) 1778 && !ada_is_array_descriptor_type (type); 1779 } 1780 1781 1782 /* If ARR has a record type in the form of a standard GNAT array descriptor, 1783 (fat pointer) returns the type of the array data described---specifically, 1784 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled 1785 in from the descriptor; otherwise, they are left unspecified. If 1786 the ARR denotes a null array descriptor and BOUNDS is non-zero, 1787 returns NULL. The result is simply the type of ARR if ARR is not 1788 a descriptor. */ 1789 struct type * 1790 ada_type_of_array (struct value *arr, int bounds) 1791 { 1792 if (ada_is_constrained_packed_array_type (value_type (arr))) 1793 return decode_constrained_packed_array_type (value_type (arr)); 1794 1795 if (!ada_is_array_descriptor_type (value_type (arr))) 1796 return value_type (arr); 1797 1798 if (!bounds) 1799 { 1800 struct type *array_type = 1801 ada_check_typedef (desc_data_target_type (value_type (arr))); 1802 1803 if (ada_is_unconstrained_packed_array_type (value_type (arr))) 1804 TYPE_FIELD_BITSIZE (array_type, 0) = 1805 decode_packed_array_bitsize (value_type (arr)); 1806 1807 return array_type; 1808 } 1809 else 1810 { 1811 struct type *elt_type; 1812 int arity; 1813 struct value *descriptor; 1814 1815 elt_type = ada_array_element_type (value_type (arr), -1); 1816 arity = ada_array_arity (value_type (arr)); 1817 1818 if (elt_type == NULL || arity == 0) 1819 return ada_check_typedef (value_type (arr)); 1820 1821 descriptor = desc_bounds (arr); 1822 if (value_as_long (descriptor) == 0) 1823 return NULL; 1824 while (arity > 0) 1825 { 1826 struct type *range_type = alloc_type_copy (value_type (arr)); 1827 struct type *array_type = alloc_type_copy (value_type (arr)); 1828 struct value *low = desc_one_bound (descriptor, arity, 0); 1829 struct value *high = desc_one_bound (descriptor, arity, 1); 1830 1831 arity -= 1; 1832 create_range_type (range_type, value_type (low), 1833 longest_to_int (value_as_long (low)), 1834 longest_to_int (value_as_long (high))); 1835 elt_type = create_array_type (array_type, elt_type, range_type); 1836 1837 if (ada_is_unconstrained_packed_array_type (value_type (arr))) 1838 { 1839 /* We need to store the element packed bitsize, as well as 1840 recompute the array size, because it was previously 1841 computed based on the unpacked element size. */ 1842 LONGEST lo = value_as_long (low); 1843 LONGEST hi = value_as_long (high); 1844 1845 TYPE_FIELD_BITSIZE (elt_type, 0) = 1846 decode_packed_array_bitsize (value_type (arr)); 1847 /* If the array has no element, then the size is already 1848 zero, and does not need to be recomputed. */ 1849 if (lo < hi) 1850 { 1851 int array_bitsize = 1852 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0); 1853 1854 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8; 1855 } 1856 } 1857 } 1858 1859 return lookup_pointer_type (elt_type); 1860 } 1861 } 1862 1863 /* If ARR does not represent an array, returns ARR unchanged. 1864 Otherwise, returns either a standard GDB array with bounds set 1865 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard 1866 GDB array. Returns NULL if ARR is a null fat pointer. */ 1867 1868 struct value * 1869 ada_coerce_to_simple_array_ptr (struct value *arr) 1870 { 1871 if (ada_is_array_descriptor_type (value_type (arr))) 1872 { 1873 struct type *arrType = ada_type_of_array (arr, 1); 1874 1875 if (arrType == NULL) 1876 return NULL; 1877 return value_cast (arrType, value_copy (desc_data (arr))); 1878 } 1879 else if (ada_is_constrained_packed_array_type (value_type (arr))) 1880 return decode_constrained_packed_array (arr); 1881 else 1882 return arr; 1883 } 1884 1885 /* If ARR does not represent an array, returns ARR unchanged. 1886 Otherwise, returns a standard GDB array describing ARR (which may 1887 be ARR itself if it already is in the proper form). */ 1888 1889 struct value * 1890 ada_coerce_to_simple_array (struct value *arr) 1891 { 1892 if (ada_is_array_descriptor_type (value_type (arr))) 1893 { 1894 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr); 1895 1896 if (arrVal == NULL) 1897 error (_("Bounds unavailable for null array pointer.")); 1898 check_size (TYPE_TARGET_TYPE (value_type (arrVal))); 1899 return value_ind (arrVal); 1900 } 1901 else if (ada_is_constrained_packed_array_type (value_type (arr))) 1902 return decode_constrained_packed_array (arr); 1903 else 1904 return arr; 1905 } 1906 1907 /* If TYPE represents a GNAT array type, return it translated to an 1908 ordinary GDB array type (possibly with BITSIZE fields indicating 1909 packing). For other types, is the identity. */ 1910 1911 struct type * 1912 ada_coerce_to_simple_array_type (struct type *type) 1913 { 1914 if (ada_is_constrained_packed_array_type (type)) 1915 return decode_constrained_packed_array_type (type); 1916 1917 if (ada_is_array_descriptor_type (type)) 1918 return ada_check_typedef (desc_data_target_type (type)); 1919 1920 return type; 1921 } 1922 1923 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */ 1924 1925 static int 1926 ada_is_packed_array_type (struct type *type) 1927 { 1928 if (type == NULL) 1929 return 0; 1930 type = desc_base_type (type); 1931 type = ada_check_typedef (type); 1932 return 1933 ada_type_name (type) != NULL 1934 && strstr (ada_type_name (type), "___XP") != NULL; 1935 } 1936 1937 /* Non-zero iff TYPE represents a standard GNAT constrained 1938 packed-array type. */ 1939 1940 int 1941 ada_is_constrained_packed_array_type (struct type *type) 1942 { 1943 return ada_is_packed_array_type (type) 1944 && !ada_is_array_descriptor_type (type); 1945 } 1946 1947 /* Non-zero iff TYPE represents an array descriptor for a 1948 unconstrained packed-array type. */ 1949 1950 static int 1951 ada_is_unconstrained_packed_array_type (struct type *type) 1952 { 1953 return ada_is_packed_array_type (type) 1954 && ada_is_array_descriptor_type (type); 1955 } 1956 1957 /* Given that TYPE encodes a packed array type (constrained or unconstrained), 1958 return the size of its elements in bits. */ 1959 1960 static long 1961 decode_packed_array_bitsize (struct type *type) 1962 { 1963 char *raw_name; 1964 char *tail; 1965 long bits; 1966 1967 /* Access to arrays implemented as fat pointers are encoded as a typedef 1968 of the fat pointer type. We need the name of the fat pointer type 1969 to do the decoding, so strip the typedef layer. */ 1970 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) 1971 type = ada_typedef_target_type (type); 1972 1973 raw_name = ada_type_name (ada_check_typedef (type)); 1974 if (!raw_name) 1975 raw_name = ada_type_name (desc_base_type (type)); 1976 1977 if (!raw_name) 1978 return 0; 1979 1980 tail = strstr (raw_name, "___XP"); 1981 gdb_assert (tail != NULL); 1982 1983 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1) 1984 { 1985 lim_warning 1986 (_("could not understand bit size information on packed array")); 1987 return 0; 1988 } 1989 1990 return bits; 1991 } 1992 1993 /* Given that TYPE is a standard GDB array type with all bounds filled 1994 in, and that the element size of its ultimate scalar constituents 1995 (that is, either its elements, or, if it is an array of arrays, its 1996 elements' elements, etc.) is *ELT_BITS, return an identical type, 1997 but with the bit sizes of its elements (and those of any 1998 constituent arrays) recorded in the BITSIZE components of its 1999 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size 2000 in bits. */ 2001 2002 static struct type * 2003 constrained_packed_array_type (struct type *type, long *elt_bits) 2004 { 2005 struct type *new_elt_type; 2006 struct type *new_type; 2007 LONGEST low_bound, high_bound; 2008 2009 type = ada_check_typedef (type); 2010 if (TYPE_CODE (type) != TYPE_CODE_ARRAY) 2011 return type; 2012 2013 new_type = alloc_type_copy (type); 2014 new_elt_type = 2015 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)), 2016 elt_bits); 2017 create_array_type (new_type, new_elt_type, TYPE_INDEX_TYPE (type)); 2018 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits; 2019 TYPE_NAME (new_type) = ada_type_name (type); 2020 2021 if (get_discrete_bounds (TYPE_INDEX_TYPE (type), 2022 &low_bound, &high_bound) < 0) 2023 low_bound = high_bound = 0; 2024 if (high_bound < low_bound) 2025 *elt_bits = TYPE_LENGTH (new_type) = 0; 2026 else 2027 { 2028 *elt_bits *= (high_bound - low_bound + 1); 2029 TYPE_LENGTH (new_type) = 2030 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT; 2031 } 2032 2033 TYPE_FIXED_INSTANCE (new_type) = 1; 2034 return new_type; 2035 } 2036 2037 /* The array type encoded by TYPE, where 2038 ada_is_constrained_packed_array_type (TYPE). */ 2039 2040 static struct type * 2041 decode_constrained_packed_array_type (struct type *type) 2042 { 2043 char *raw_name = ada_type_name (ada_check_typedef (type)); 2044 char *name; 2045 char *tail; 2046 struct type *shadow_type; 2047 long bits; 2048 2049 if (!raw_name) 2050 raw_name = ada_type_name (desc_base_type (type)); 2051 2052 if (!raw_name) 2053 return NULL; 2054 2055 name = (char *) alloca (strlen (raw_name) + 1); 2056 tail = strstr (raw_name, "___XP"); 2057 type = desc_base_type (type); 2058 2059 memcpy (name, raw_name, tail - raw_name); 2060 name[tail - raw_name] = '\000'; 2061 2062 shadow_type = ada_find_parallel_type_with_name (type, name); 2063 2064 if (shadow_type == NULL) 2065 { 2066 lim_warning (_("could not find bounds information on packed array")); 2067 return NULL; 2068 } 2069 CHECK_TYPEDEF (shadow_type); 2070 2071 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY) 2072 { 2073 lim_warning (_("could not understand bounds " 2074 "information on packed array")); 2075 return NULL; 2076 } 2077 2078 bits = decode_packed_array_bitsize (type); 2079 return constrained_packed_array_type (shadow_type, &bits); 2080 } 2081 2082 /* Given that ARR is a struct value *indicating a GNAT constrained packed 2083 array, returns a simple array that denotes that array. Its type is a 2084 standard GDB array type except that the BITSIZEs of the array 2085 target types are set to the number of bits in each element, and the 2086 type length is set appropriately. */ 2087 2088 static struct value * 2089 decode_constrained_packed_array (struct value *arr) 2090 { 2091 struct type *type; 2092 2093 arr = ada_coerce_ref (arr); 2094 2095 /* If our value is a pointer, then dererence it. Make sure that 2096 this operation does not cause the target type to be fixed, as 2097 this would indirectly cause this array to be decoded. The rest 2098 of the routine assumes that the array hasn't been decoded yet, 2099 so we use the basic "value_ind" routine to perform the dereferencing, 2100 as opposed to using "ada_value_ind". */ 2101 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR) 2102 arr = value_ind (arr); 2103 2104 type = decode_constrained_packed_array_type (value_type (arr)); 2105 if (type == NULL) 2106 { 2107 error (_("can't unpack array")); 2108 return NULL; 2109 } 2110 2111 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr))) 2112 && ada_is_modular_type (value_type (arr))) 2113 { 2114 /* This is a (right-justified) modular type representing a packed 2115 array with no wrapper. In order to interpret the value through 2116 the (left-justified) packed array type we just built, we must 2117 first left-justify it. */ 2118 int bit_size, bit_pos; 2119 ULONGEST mod; 2120 2121 mod = ada_modulus (value_type (arr)) - 1; 2122 bit_size = 0; 2123 while (mod > 0) 2124 { 2125 bit_size += 1; 2126 mod >>= 1; 2127 } 2128 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size; 2129 arr = ada_value_primitive_packed_val (arr, NULL, 2130 bit_pos / HOST_CHAR_BIT, 2131 bit_pos % HOST_CHAR_BIT, 2132 bit_size, 2133 type); 2134 } 2135 2136 return coerce_unspec_val_to_type (arr, type); 2137 } 2138 2139 2140 /* The value of the element of packed array ARR at the ARITY indices 2141 given in IND. ARR must be a simple array. */ 2142 2143 static struct value * 2144 value_subscript_packed (struct value *arr, int arity, struct value **ind) 2145 { 2146 int i; 2147 int bits, elt_off, bit_off; 2148 long elt_total_bit_offset; 2149 struct type *elt_type; 2150 struct value *v; 2151 2152 bits = 0; 2153 elt_total_bit_offset = 0; 2154 elt_type = ada_check_typedef (value_type (arr)); 2155 for (i = 0; i < arity; i += 1) 2156 { 2157 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY 2158 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0) 2159 error 2160 (_("attempt to do packed indexing of " 2161 "something other than a packed array")); 2162 else 2163 { 2164 struct type *range_type = TYPE_INDEX_TYPE (elt_type); 2165 LONGEST lowerbound, upperbound; 2166 LONGEST idx; 2167 2168 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0) 2169 { 2170 lim_warning (_("don't know bounds of array")); 2171 lowerbound = upperbound = 0; 2172 } 2173 2174 idx = pos_atr (ind[i]); 2175 if (idx < lowerbound || idx > upperbound) 2176 lim_warning (_("packed array index %ld out of bounds"), 2177 (long) idx); 2178 bits = TYPE_FIELD_BITSIZE (elt_type, 0); 2179 elt_total_bit_offset += (idx - lowerbound) * bits; 2180 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type)); 2181 } 2182 } 2183 elt_off = elt_total_bit_offset / HOST_CHAR_BIT; 2184 bit_off = elt_total_bit_offset % HOST_CHAR_BIT; 2185 2186 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off, 2187 bits, elt_type); 2188 return v; 2189 } 2190 2191 /* Non-zero iff TYPE includes negative integer values. */ 2192 2193 static int 2194 has_negatives (struct type *type) 2195 { 2196 switch (TYPE_CODE (type)) 2197 { 2198 default: 2199 return 0; 2200 case TYPE_CODE_INT: 2201 return !TYPE_UNSIGNED (type); 2202 case TYPE_CODE_RANGE: 2203 return TYPE_LOW_BOUND (type) < 0; 2204 } 2205 } 2206 2207 2208 /* Create a new value of type TYPE from the contents of OBJ starting 2209 at byte OFFSET, and bit offset BIT_OFFSET within that byte, 2210 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then 2211 assigning through the result will set the field fetched from. 2212 VALADDR is ignored unless OBJ is NULL, in which case, 2213 VALADDR+OFFSET must address the start of storage containing the 2214 packed value. The value returned in this case is never an lval. 2215 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */ 2216 2217 struct value * 2218 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr, 2219 long offset, int bit_offset, int bit_size, 2220 struct type *type) 2221 { 2222 struct value *v; 2223 int src, /* Index into the source area */ 2224 targ, /* Index into the target area */ 2225 srcBitsLeft, /* Number of source bits left to move */ 2226 nsrc, ntarg, /* Number of source and target bytes */ 2227 unusedLS, /* Number of bits in next significant 2228 byte of source that are unused */ 2229 accumSize; /* Number of meaningful bits in accum */ 2230 unsigned char *bytes; /* First byte containing data to unpack */ 2231 unsigned char *unpacked; 2232 unsigned long accum; /* Staging area for bits being transferred */ 2233 unsigned char sign; 2234 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8; 2235 /* Transmit bytes from least to most significant; delta is the direction 2236 the indices move. */ 2237 int delta = gdbarch_bits_big_endian (get_type_arch (type)) ? -1 : 1; 2238 2239 type = ada_check_typedef (type); 2240 2241 if (obj == NULL) 2242 { 2243 v = allocate_value (type); 2244 bytes = (unsigned char *) (valaddr + offset); 2245 } 2246 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj)) 2247 { 2248 v = value_at (type, 2249 value_address (obj) + offset); 2250 bytes = (unsigned char *) alloca (len); 2251 read_memory (value_address (v), bytes, len); 2252 } 2253 else 2254 { 2255 v = allocate_value (type); 2256 bytes = (unsigned char *) value_contents (obj) + offset; 2257 } 2258 2259 if (obj != NULL) 2260 { 2261 CORE_ADDR new_addr; 2262 2263 set_value_component_location (v, obj); 2264 new_addr = value_address (obj) + offset; 2265 set_value_bitpos (v, bit_offset + value_bitpos (obj)); 2266 set_value_bitsize (v, bit_size); 2267 if (value_bitpos (v) >= HOST_CHAR_BIT) 2268 { 2269 ++new_addr; 2270 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT); 2271 } 2272 set_value_address (v, new_addr); 2273 } 2274 else 2275 set_value_bitsize (v, bit_size); 2276 unpacked = (unsigned char *) value_contents (v); 2277 2278 srcBitsLeft = bit_size; 2279 nsrc = len; 2280 ntarg = TYPE_LENGTH (type); 2281 sign = 0; 2282 if (bit_size == 0) 2283 { 2284 memset (unpacked, 0, TYPE_LENGTH (type)); 2285 return v; 2286 } 2287 else if (gdbarch_bits_big_endian (get_type_arch (type))) 2288 { 2289 src = len - 1; 2290 if (has_negatives (type) 2291 && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1)))) 2292 sign = ~0; 2293 2294 unusedLS = 2295 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT) 2296 % HOST_CHAR_BIT; 2297 2298 switch (TYPE_CODE (type)) 2299 { 2300 case TYPE_CODE_ARRAY: 2301 case TYPE_CODE_UNION: 2302 case TYPE_CODE_STRUCT: 2303 /* Non-scalar values must be aligned at a byte boundary... */ 2304 accumSize = 2305 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT; 2306 /* ... And are placed at the beginning (most-significant) bytes 2307 of the target. */ 2308 targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1; 2309 ntarg = targ + 1; 2310 break; 2311 default: 2312 accumSize = 0; 2313 targ = TYPE_LENGTH (type) - 1; 2314 break; 2315 } 2316 } 2317 else 2318 { 2319 int sign_bit_offset = (bit_size + bit_offset - 1) % 8; 2320 2321 src = targ = 0; 2322 unusedLS = bit_offset; 2323 accumSize = 0; 2324 2325 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset))) 2326 sign = ~0; 2327 } 2328 2329 accum = 0; 2330 while (nsrc > 0) 2331 { 2332 /* Mask for removing bits of the next source byte that are not 2333 part of the value. */ 2334 unsigned int unusedMSMask = 2335 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) - 2336 1; 2337 /* Sign-extend bits for this byte. */ 2338 unsigned int signMask = sign & ~unusedMSMask; 2339 2340 accum |= 2341 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize; 2342 accumSize += HOST_CHAR_BIT - unusedLS; 2343 if (accumSize >= HOST_CHAR_BIT) 2344 { 2345 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT); 2346 accumSize -= HOST_CHAR_BIT; 2347 accum >>= HOST_CHAR_BIT; 2348 ntarg -= 1; 2349 targ += delta; 2350 } 2351 srcBitsLeft -= HOST_CHAR_BIT - unusedLS; 2352 unusedLS = 0; 2353 nsrc -= 1; 2354 src += delta; 2355 } 2356 while (ntarg > 0) 2357 { 2358 accum |= sign << accumSize; 2359 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT); 2360 accumSize -= HOST_CHAR_BIT; 2361 accum >>= HOST_CHAR_BIT; 2362 ntarg -= 1; 2363 targ += delta; 2364 } 2365 2366 return v; 2367 } 2368 2369 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to 2370 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must 2371 not overlap. */ 2372 static void 2373 move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source, 2374 int src_offset, int n, int bits_big_endian_p) 2375 { 2376 unsigned int accum, mask; 2377 int accum_bits, chunk_size; 2378 2379 target += targ_offset / HOST_CHAR_BIT; 2380 targ_offset %= HOST_CHAR_BIT; 2381 source += src_offset / HOST_CHAR_BIT; 2382 src_offset %= HOST_CHAR_BIT; 2383 if (bits_big_endian_p) 2384 { 2385 accum = (unsigned char) *source; 2386 source += 1; 2387 accum_bits = HOST_CHAR_BIT - src_offset; 2388 2389 while (n > 0) 2390 { 2391 int unused_right; 2392 2393 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source; 2394 accum_bits += HOST_CHAR_BIT; 2395 source += 1; 2396 chunk_size = HOST_CHAR_BIT - targ_offset; 2397 if (chunk_size > n) 2398 chunk_size = n; 2399 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset); 2400 mask = ((1 << chunk_size) - 1) << unused_right; 2401 *target = 2402 (*target & ~mask) 2403 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask); 2404 n -= chunk_size; 2405 accum_bits -= chunk_size; 2406 target += 1; 2407 targ_offset = 0; 2408 } 2409 } 2410 else 2411 { 2412 accum = (unsigned char) *source >> src_offset; 2413 source += 1; 2414 accum_bits = HOST_CHAR_BIT - src_offset; 2415 2416 while (n > 0) 2417 { 2418 accum = accum + ((unsigned char) *source << accum_bits); 2419 accum_bits += HOST_CHAR_BIT; 2420 source += 1; 2421 chunk_size = HOST_CHAR_BIT - targ_offset; 2422 if (chunk_size > n) 2423 chunk_size = n; 2424 mask = ((1 << chunk_size) - 1) << targ_offset; 2425 *target = (*target & ~mask) | ((accum << targ_offset) & mask); 2426 n -= chunk_size; 2427 accum_bits -= chunk_size; 2428 accum >>= chunk_size; 2429 target += 1; 2430 targ_offset = 0; 2431 } 2432 } 2433 } 2434 2435 /* Store the contents of FROMVAL into the location of TOVAL. 2436 Return a new value with the location of TOVAL and contents of 2437 FROMVAL. Handles assignment into packed fields that have 2438 floating-point or non-scalar types. */ 2439 2440 static struct value * 2441 ada_value_assign (struct value *toval, struct value *fromval) 2442 { 2443 struct type *type = value_type (toval); 2444 int bits = value_bitsize (toval); 2445 2446 toval = ada_coerce_ref (toval); 2447 fromval = ada_coerce_ref (fromval); 2448 2449 if (ada_is_direct_array_type (value_type (toval))) 2450 toval = ada_coerce_to_simple_array (toval); 2451 if (ada_is_direct_array_type (value_type (fromval))) 2452 fromval = ada_coerce_to_simple_array (fromval); 2453 2454 if (!deprecated_value_modifiable (toval)) 2455 error (_("Left operand of assignment is not a modifiable lvalue.")); 2456 2457 if (VALUE_LVAL (toval) == lval_memory 2458 && bits > 0 2459 && (TYPE_CODE (type) == TYPE_CODE_FLT 2460 || TYPE_CODE (type) == TYPE_CODE_STRUCT)) 2461 { 2462 int len = (value_bitpos (toval) 2463 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT; 2464 int from_size; 2465 char *buffer = (char *) alloca (len); 2466 struct value *val; 2467 CORE_ADDR to_addr = value_address (toval); 2468 2469 if (TYPE_CODE (type) == TYPE_CODE_FLT) 2470 fromval = value_cast (type, fromval); 2471 2472 read_memory (to_addr, buffer, len); 2473 from_size = value_bitsize (fromval); 2474 if (from_size == 0) 2475 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT; 2476 if (gdbarch_bits_big_endian (get_type_arch (type))) 2477 move_bits (buffer, value_bitpos (toval), 2478 value_contents (fromval), from_size - bits, bits, 1); 2479 else 2480 move_bits (buffer, value_bitpos (toval), 2481 value_contents (fromval), 0, bits, 0); 2482 write_memory (to_addr, buffer, len); 2483 observer_notify_memory_changed (to_addr, len, buffer); 2484 2485 val = value_copy (toval); 2486 memcpy (value_contents_raw (val), value_contents (fromval), 2487 TYPE_LENGTH (type)); 2488 deprecated_set_value_type (val, type); 2489 2490 return val; 2491 } 2492 2493 return value_assign (toval, fromval); 2494 } 2495 2496 2497 /* Given that COMPONENT is a memory lvalue that is part of the lvalue 2498 * CONTAINER, assign the contents of VAL to COMPONENTS's place in 2499 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not 2500 * COMPONENT, and not the inferior's memory. The current contents 2501 * of COMPONENT are ignored. */ 2502 static void 2503 value_assign_to_component (struct value *container, struct value *component, 2504 struct value *val) 2505 { 2506 LONGEST offset_in_container = 2507 (LONGEST) (value_address (component) - value_address (container)); 2508 int bit_offset_in_container = 2509 value_bitpos (component) - value_bitpos (container); 2510 int bits; 2511 2512 val = value_cast (value_type (component), val); 2513 2514 if (value_bitsize (component) == 0) 2515 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component)); 2516 else 2517 bits = value_bitsize (component); 2518 2519 if (gdbarch_bits_big_endian (get_type_arch (value_type (container)))) 2520 move_bits (value_contents_writeable (container) + offset_in_container, 2521 value_bitpos (container) + bit_offset_in_container, 2522 value_contents (val), 2523 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits, 2524 bits, 1); 2525 else 2526 move_bits (value_contents_writeable (container) + offset_in_container, 2527 value_bitpos (container) + bit_offset_in_container, 2528 value_contents (val), 0, bits, 0); 2529 } 2530 2531 /* The value of the element of array ARR at the ARITY indices given in IND. 2532 ARR may be either a simple array, GNAT array descriptor, or pointer 2533 thereto. */ 2534 2535 struct value * 2536 ada_value_subscript (struct value *arr, int arity, struct value **ind) 2537 { 2538 int k; 2539 struct value *elt; 2540 struct type *elt_type; 2541 2542 elt = ada_coerce_to_simple_array (arr); 2543 2544 elt_type = ada_check_typedef (value_type (elt)); 2545 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY 2546 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0) 2547 return value_subscript_packed (elt, arity, ind); 2548 2549 for (k = 0; k < arity; k += 1) 2550 { 2551 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY) 2552 error (_("too many subscripts (%d expected)"), k); 2553 elt = value_subscript (elt, pos_atr (ind[k])); 2554 } 2555 return elt; 2556 } 2557 2558 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the 2559 value of the element of *ARR at the ARITY indices given in 2560 IND. Does not read the entire array into memory. */ 2561 2562 static struct value * 2563 ada_value_ptr_subscript (struct value *arr, struct type *type, int arity, 2564 struct value **ind) 2565 { 2566 int k; 2567 2568 for (k = 0; k < arity; k += 1) 2569 { 2570 LONGEST lwb, upb; 2571 2572 if (TYPE_CODE (type) != TYPE_CODE_ARRAY) 2573 error (_("too many subscripts (%d expected)"), k); 2574 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)), 2575 value_copy (arr)); 2576 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb); 2577 arr = value_ptradd (arr, pos_atr (ind[k]) - lwb); 2578 type = TYPE_TARGET_TYPE (type); 2579 } 2580 2581 return value_ind (arr); 2582 } 2583 2584 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the 2585 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1 2586 elements starting at index LOW. The lower bound of this array is LOW, as 2587 per Ada rules. */ 2588 static struct value * 2589 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type, 2590 int low, int high) 2591 { 2592 struct type *type0 = ada_check_typedef (type); 2593 CORE_ADDR base = value_as_address (array_ptr) 2594 + ((low - ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0))) 2595 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0))); 2596 struct type *index_type = 2597 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0)), 2598 low, high); 2599 struct type *slice_type = 2600 create_array_type (NULL, TYPE_TARGET_TYPE (type0), index_type); 2601 2602 return value_at_lazy (slice_type, base); 2603 } 2604 2605 2606 static struct value * 2607 ada_value_slice (struct value *array, int low, int high) 2608 { 2609 struct type *type = ada_check_typedef (value_type (array)); 2610 struct type *index_type = 2611 create_range_type (NULL, TYPE_INDEX_TYPE (type), low, high); 2612 struct type *slice_type = 2613 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type); 2614 2615 return value_cast (slice_type, value_slice (array, low, high - low + 1)); 2616 } 2617 2618 /* If type is a record type in the form of a standard GNAT array 2619 descriptor, returns the number of dimensions for type. If arr is a 2620 simple array, returns the number of "array of"s that prefix its 2621 type designation. Otherwise, returns 0. */ 2622 2623 int 2624 ada_array_arity (struct type *type) 2625 { 2626 int arity; 2627 2628 if (type == NULL) 2629 return 0; 2630 2631 type = desc_base_type (type); 2632 2633 arity = 0; 2634 if (TYPE_CODE (type) == TYPE_CODE_STRUCT) 2635 return desc_arity (desc_bounds_type (type)); 2636 else 2637 while (TYPE_CODE (type) == TYPE_CODE_ARRAY) 2638 { 2639 arity += 1; 2640 type = ada_check_typedef (TYPE_TARGET_TYPE (type)); 2641 } 2642 2643 return arity; 2644 } 2645 2646 /* If TYPE is a record type in the form of a standard GNAT array 2647 descriptor or a simple array type, returns the element type for 2648 TYPE after indexing by NINDICES indices, or by all indices if 2649 NINDICES is -1. Otherwise, returns NULL. */ 2650 2651 struct type * 2652 ada_array_element_type (struct type *type, int nindices) 2653 { 2654 type = desc_base_type (type); 2655 2656 if (TYPE_CODE (type) == TYPE_CODE_STRUCT) 2657 { 2658 int k; 2659 struct type *p_array_type; 2660 2661 p_array_type = desc_data_target_type (type); 2662 2663 k = ada_array_arity (type); 2664 if (k == 0) 2665 return NULL; 2666 2667 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */ 2668 if (nindices >= 0 && k > nindices) 2669 k = nindices; 2670 while (k > 0 && p_array_type != NULL) 2671 { 2672 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type)); 2673 k -= 1; 2674 } 2675 return p_array_type; 2676 } 2677 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY) 2678 { 2679 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY) 2680 { 2681 type = TYPE_TARGET_TYPE (type); 2682 nindices -= 1; 2683 } 2684 return type; 2685 } 2686 2687 return NULL; 2688 } 2689 2690 /* The type of nth index in arrays of given type (n numbering from 1). 2691 Does not examine memory. Throws an error if N is invalid or TYPE 2692 is not an array type. NAME is the name of the Ada attribute being 2693 evaluated ('range, 'first, 'last, or 'length); it is used in building 2694 the error message. */ 2695 2696 static struct type * 2697 ada_index_type (struct type *type, int n, const char *name) 2698 { 2699 struct type *result_type; 2700 2701 type = desc_base_type (type); 2702 2703 if (n < 0 || n > ada_array_arity (type)) 2704 error (_("invalid dimension number to '%s"), name); 2705 2706 if (ada_is_simple_array_type (type)) 2707 { 2708 int i; 2709 2710 for (i = 1; i < n; i += 1) 2711 type = TYPE_TARGET_TYPE (type); 2712 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type)); 2713 /* FIXME: The stabs type r(0,0);bound;bound in an array type 2714 has a target type of TYPE_CODE_UNDEF. We compensate here, but 2715 perhaps stabsread.c would make more sense. */ 2716 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF) 2717 result_type = NULL; 2718 } 2719 else 2720 { 2721 result_type = desc_index_type (desc_bounds_type (type), n); 2722 if (result_type == NULL) 2723 error (_("attempt to take bound of something that is not an array")); 2724 } 2725 2726 return result_type; 2727 } 2728 2729 /* Given that arr is an array type, returns the lower bound of the 2730 Nth index (numbering from 1) if WHICH is 0, and the upper bound if 2731 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an 2732 array-descriptor type. It works for other arrays with bounds supplied 2733 by run-time quantities other than discriminants. */ 2734 2735 static LONGEST 2736 ada_array_bound_from_type (struct type * arr_type, int n, int which) 2737 { 2738 struct type *type, *elt_type, *index_type_desc, *index_type; 2739 int i; 2740 2741 gdb_assert (which == 0 || which == 1); 2742 2743 if (ada_is_constrained_packed_array_type (arr_type)) 2744 arr_type = decode_constrained_packed_array_type (arr_type); 2745 2746 if (arr_type == NULL || !ada_is_simple_array_type (arr_type)) 2747 return (LONGEST) - which; 2748 2749 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR) 2750 type = TYPE_TARGET_TYPE (arr_type); 2751 else 2752 type = arr_type; 2753 2754 elt_type = type; 2755 for (i = n; i > 1; i--) 2756 elt_type = TYPE_TARGET_TYPE (type); 2757 2758 index_type_desc = ada_find_parallel_type (type, "___XA"); 2759 ada_fixup_array_indexes_type (index_type_desc); 2760 if (index_type_desc != NULL) 2761 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1), 2762 NULL); 2763 else 2764 index_type = TYPE_INDEX_TYPE (elt_type); 2765 2766 return 2767 (LONGEST) (which == 0 2768 ? ada_discrete_type_low_bound (index_type) 2769 : ada_discrete_type_high_bound (index_type)); 2770 } 2771 2772 /* Given that arr is an array value, returns the lower bound of the 2773 nth index (numbering from 1) if WHICH is 0, and the upper bound if 2774 WHICH is 1. This routine will also work for arrays with bounds 2775 supplied by run-time quantities other than discriminants. */ 2776 2777 static LONGEST 2778 ada_array_bound (struct value *arr, int n, int which) 2779 { 2780 struct type *arr_type = value_type (arr); 2781 2782 if (ada_is_constrained_packed_array_type (arr_type)) 2783 return ada_array_bound (decode_constrained_packed_array (arr), n, which); 2784 else if (ada_is_simple_array_type (arr_type)) 2785 return ada_array_bound_from_type (arr_type, n, which); 2786 else 2787 return value_as_long (desc_one_bound (desc_bounds (arr), n, which)); 2788 } 2789 2790 /* Given that arr is an array value, returns the length of the 2791 nth index. This routine will also work for arrays with bounds 2792 supplied by run-time quantities other than discriminants. 2793 Does not work for arrays indexed by enumeration types with representation 2794 clauses at the moment. */ 2795 2796 static LONGEST 2797 ada_array_length (struct value *arr, int n) 2798 { 2799 struct type *arr_type = ada_check_typedef (value_type (arr)); 2800 2801 if (ada_is_constrained_packed_array_type (arr_type)) 2802 return ada_array_length (decode_constrained_packed_array (arr), n); 2803 2804 if (ada_is_simple_array_type (arr_type)) 2805 return (ada_array_bound_from_type (arr_type, n, 1) 2806 - ada_array_bound_from_type (arr_type, n, 0) + 1); 2807 else 2808 return (value_as_long (desc_one_bound (desc_bounds (arr), n, 1)) 2809 - value_as_long (desc_one_bound (desc_bounds (arr), n, 0)) + 1); 2810 } 2811 2812 /* An empty array whose type is that of ARR_TYPE (an array type), 2813 with bounds LOW to LOW-1. */ 2814 2815 static struct value * 2816 empty_array (struct type *arr_type, int low) 2817 { 2818 struct type *arr_type0 = ada_check_typedef (arr_type); 2819 struct type *index_type = 2820 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), 2821 low, low - 1); 2822 struct type *elt_type = ada_array_element_type (arr_type0, 1); 2823 2824 return allocate_value (create_array_type (NULL, elt_type, index_type)); 2825 } 2826 2827 2828 /* Name resolution */ 2829 2830 /* The "decoded" name for the user-definable Ada operator corresponding 2831 to OP. */ 2832 2833 static const char * 2834 ada_decoded_op_name (enum exp_opcode op) 2835 { 2836 int i; 2837 2838 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1) 2839 { 2840 if (ada_opname_table[i].op == op) 2841 return ada_opname_table[i].decoded; 2842 } 2843 error (_("Could not find operator name for opcode")); 2844 } 2845 2846 2847 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol 2848 references (marked by OP_VAR_VALUE nodes in which the symbol has an 2849 undefined namespace) and converts operators that are 2850 user-defined into appropriate function calls. If CONTEXT_TYPE is 2851 non-null, it provides a preferred result type [at the moment, only 2852 type void has any effect---causing procedures to be preferred over 2853 functions in calls]. A null CONTEXT_TYPE indicates that a non-void 2854 return type is preferred. May change (expand) *EXP. */ 2855 2856 static void 2857 resolve (struct expression **expp, int void_context_p) 2858 { 2859 struct type *context_type = NULL; 2860 int pc = 0; 2861 2862 if (void_context_p) 2863 context_type = builtin_type ((*expp)->gdbarch)->builtin_void; 2864 2865 resolve_subexp (expp, &pc, 1, context_type); 2866 } 2867 2868 /* Resolve the operator of the subexpression beginning at 2869 position *POS of *EXPP. "Resolving" consists of replacing 2870 the symbols that have undefined namespaces in OP_VAR_VALUE nodes 2871 with their resolutions, replacing built-in operators with 2872 function calls to user-defined operators, where appropriate, and, 2873 when DEPROCEDURE_P is non-zero, converting function-valued variables 2874 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions 2875 are as in ada_resolve, above. */ 2876 2877 static struct value * 2878 resolve_subexp (struct expression **expp, int *pos, int deprocedure_p, 2879 struct type *context_type) 2880 { 2881 int pc = *pos; 2882 int i; 2883 struct expression *exp; /* Convenience: == *expp. */ 2884 enum exp_opcode op = (*expp)->elts[pc].opcode; 2885 struct value **argvec; /* Vector of operand types (alloca'ed). */ 2886 int nargs; /* Number of operands. */ 2887 int oplen; 2888 2889 argvec = NULL; 2890 nargs = 0; 2891 exp = *expp; 2892 2893 /* Pass one: resolve operands, saving their types and updating *pos, 2894 if needed. */ 2895 switch (op) 2896 { 2897 case OP_FUNCALL: 2898 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE 2899 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN) 2900 *pos += 7; 2901 else 2902 { 2903 *pos += 3; 2904 resolve_subexp (expp, pos, 0, NULL); 2905 } 2906 nargs = longest_to_int (exp->elts[pc + 1].longconst); 2907 break; 2908 2909 case UNOP_ADDR: 2910 *pos += 1; 2911 resolve_subexp (expp, pos, 0, NULL); 2912 break; 2913 2914 case UNOP_QUAL: 2915 *pos += 3; 2916 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type)); 2917 break; 2918 2919 case OP_ATR_MODULUS: 2920 case OP_ATR_SIZE: 2921 case OP_ATR_TAG: 2922 case OP_ATR_FIRST: 2923 case OP_ATR_LAST: 2924 case OP_ATR_LENGTH: 2925 case OP_ATR_POS: 2926 case OP_ATR_VAL: 2927 case OP_ATR_MIN: 2928 case OP_ATR_MAX: 2929 case TERNOP_IN_RANGE: 2930 case BINOP_IN_BOUNDS: 2931 case UNOP_IN_RANGE: 2932 case OP_AGGREGATE: 2933 case OP_OTHERS: 2934 case OP_CHOICES: 2935 case OP_POSITIONAL: 2936 case OP_DISCRETE_RANGE: 2937 case OP_NAME: 2938 ada_forward_operator_length (exp, pc, &oplen, &nargs); 2939 *pos += oplen; 2940 break; 2941 2942 case BINOP_ASSIGN: 2943 { 2944 struct value *arg1; 2945 2946 *pos += 1; 2947 arg1 = resolve_subexp (expp, pos, 0, NULL); 2948 if (arg1 == NULL) 2949 resolve_subexp (expp, pos, 1, NULL); 2950 else 2951 resolve_subexp (expp, pos, 1, value_type (arg1)); 2952 break; 2953 } 2954 2955 case UNOP_CAST: 2956 *pos += 3; 2957 nargs = 1; 2958 break; 2959 2960 case BINOP_ADD: 2961 case BINOP_SUB: 2962 case BINOP_MUL: 2963 case BINOP_DIV: 2964 case BINOP_REM: 2965 case BINOP_MOD: 2966 case BINOP_EXP: 2967 case BINOP_CONCAT: 2968 case BINOP_LOGICAL_AND: 2969 case BINOP_LOGICAL_OR: 2970 case BINOP_BITWISE_AND: 2971 case BINOP_BITWISE_IOR: 2972 case BINOP_BITWISE_XOR: 2973 2974 case BINOP_EQUAL: 2975 case BINOP_NOTEQUAL: 2976 case BINOP_LESS: 2977 case BINOP_GTR: 2978 case BINOP_LEQ: 2979 case BINOP_GEQ: 2980 2981 case BINOP_REPEAT: 2982 case BINOP_SUBSCRIPT: 2983 case BINOP_COMMA: 2984 *pos += 1; 2985 nargs = 2; 2986 break; 2987 2988 case UNOP_NEG: 2989 case UNOP_PLUS: 2990 case UNOP_LOGICAL_NOT: 2991 case UNOP_ABS: 2992 case UNOP_IND: 2993 *pos += 1; 2994 nargs = 1; 2995 break; 2996 2997 case OP_LONG: 2998 case OP_DOUBLE: 2999 case OP_VAR_VALUE: 3000 *pos += 4; 3001 break; 3002 3003 case OP_TYPE: 3004 case OP_BOOL: 3005 case OP_LAST: 3006 case OP_INTERNALVAR: 3007 *pos += 3; 3008 break; 3009 3010 case UNOP_MEMVAL: 3011 *pos += 3; 3012 nargs = 1; 3013 break; 3014 3015 case OP_REGISTER: 3016 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1); 3017 break; 3018 3019 case STRUCTOP_STRUCT: 3020 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1); 3021 nargs = 1; 3022 break; 3023 3024 case TERNOP_SLICE: 3025 *pos += 1; 3026 nargs = 3; 3027 break; 3028 3029 case OP_STRING: 3030 break; 3031 3032 default: 3033 error (_("Unexpected operator during name resolution")); 3034 } 3035 3036 argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1)); 3037 for (i = 0; i < nargs; i += 1) 3038 argvec[i] = resolve_subexp (expp, pos, 1, NULL); 3039 argvec[i] = NULL; 3040 exp = *expp; 3041 3042 /* Pass two: perform any resolution on principal operator. */ 3043 switch (op) 3044 { 3045 default: 3046 break; 3047 3048 case OP_VAR_VALUE: 3049 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN) 3050 { 3051 struct ada_symbol_info *candidates; 3052 int n_candidates; 3053 3054 n_candidates = 3055 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME 3056 (exp->elts[pc + 2].symbol), 3057 exp->elts[pc + 1].block, VAR_DOMAIN, 3058 &candidates); 3059 3060 if (n_candidates > 1) 3061 { 3062 /* Types tend to get re-introduced locally, so if there 3063 are any local symbols that are not types, first filter 3064 out all types. */ 3065 int j; 3066 for (j = 0; j < n_candidates; j += 1) 3067 switch (SYMBOL_CLASS (candidates[j].sym)) 3068 { 3069 case LOC_REGISTER: 3070 case LOC_ARG: 3071 case LOC_REF_ARG: 3072 case LOC_REGPARM_ADDR: 3073 case LOC_LOCAL: 3074 case LOC_COMPUTED: 3075 goto FoundNonType; 3076 default: 3077 break; 3078 } 3079 FoundNonType: 3080 if (j < n_candidates) 3081 { 3082 j = 0; 3083 while (j < n_candidates) 3084 { 3085 if (SYMBOL_CLASS (candidates[j].sym) == LOC_TYPEDEF) 3086 { 3087 candidates[j] = candidates[n_candidates - 1]; 3088 n_candidates -= 1; 3089 } 3090 else 3091 j += 1; 3092 } 3093 } 3094 } 3095 3096 if (n_candidates == 0) 3097 error (_("No definition found for %s"), 3098 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol)); 3099 else if (n_candidates == 1) 3100 i = 0; 3101 else if (deprocedure_p 3102 && !is_nonfunction (candidates, n_candidates)) 3103 { 3104 i = ada_resolve_function 3105 (candidates, n_candidates, NULL, 0, 3106 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol), 3107 context_type); 3108 if (i < 0) 3109 error (_("Could not find a match for %s"), 3110 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol)); 3111 } 3112 else 3113 { 3114 printf_filtered (_("Multiple matches for %s\n"), 3115 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol)); 3116 user_select_syms (candidates, n_candidates, 1); 3117 i = 0; 3118 } 3119 3120 exp->elts[pc + 1].block = candidates[i].block; 3121 exp->elts[pc + 2].symbol = candidates[i].sym; 3122 if (innermost_block == NULL 3123 || contained_in (candidates[i].block, innermost_block)) 3124 innermost_block = candidates[i].block; 3125 } 3126 3127 if (deprocedure_p 3128 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol)) 3129 == TYPE_CODE_FUNC)) 3130 { 3131 replace_operator_with_call (expp, pc, 0, 0, 3132 exp->elts[pc + 2].symbol, 3133 exp->elts[pc + 1].block); 3134 exp = *expp; 3135 } 3136 break; 3137 3138 case OP_FUNCALL: 3139 { 3140 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE 3141 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN) 3142 { 3143 struct ada_symbol_info *candidates; 3144 int n_candidates; 3145 3146 n_candidates = 3147 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME 3148 (exp->elts[pc + 5].symbol), 3149 exp->elts[pc + 4].block, VAR_DOMAIN, 3150 &candidates); 3151 if (n_candidates == 1) 3152 i = 0; 3153 else 3154 { 3155 i = ada_resolve_function 3156 (candidates, n_candidates, 3157 argvec, nargs, 3158 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol), 3159 context_type); 3160 if (i < 0) 3161 error (_("Could not find a match for %s"), 3162 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol)); 3163 } 3164 3165 exp->elts[pc + 4].block = candidates[i].block; 3166 exp->elts[pc + 5].symbol = candidates[i].sym; 3167 if (innermost_block == NULL 3168 || contained_in (candidates[i].block, innermost_block)) 3169 innermost_block = candidates[i].block; 3170 } 3171 } 3172 break; 3173 case BINOP_ADD: 3174 case BINOP_SUB: 3175 case BINOP_MUL: 3176 case BINOP_DIV: 3177 case BINOP_REM: 3178 case BINOP_MOD: 3179 case BINOP_CONCAT: 3180 case BINOP_BITWISE_AND: 3181 case BINOP_BITWISE_IOR: 3182 case BINOP_BITWISE_XOR: 3183 case BINOP_EQUAL: 3184 case BINOP_NOTEQUAL: 3185 case BINOP_LESS: 3186 case BINOP_GTR: 3187 case BINOP_LEQ: 3188 case BINOP_GEQ: 3189 case BINOP_EXP: 3190 case UNOP_NEG: 3191 case UNOP_PLUS: 3192 case UNOP_LOGICAL_NOT: 3193 case UNOP_ABS: 3194 if (possible_user_operator_p (op, argvec)) 3195 { 3196 struct ada_symbol_info *candidates; 3197 int n_candidates; 3198 3199 n_candidates = 3200 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)), 3201 (struct block *) NULL, VAR_DOMAIN, 3202 &candidates); 3203 i = ada_resolve_function (candidates, n_candidates, argvec, nargs, 3204 ada_decoded_op_name (op), NULL); 3205 if (i < 0) 3206 break; 3207 3208 replace_operator_with_call (expp, pc, nargs, 1, 3209 candidates[i].sym, candidates[i].block); 3210 exp = *expp; 3211 } 3212 break; 3213 3214 case OP_TYPE: 3215 case OP_REGISTER: 3216 return NULL; 3217 } 3218 3219 *pos = pc; 3220 return evaluate_subexp_type (exp, pos); 3221 } 3222 3223 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If 3224 MAY_DEREF is non-zero, the formal may be a pointer and the actual 3225 a non-pointer. */ 3226 /* The term "match" here is rather loose. The match is heuristic and 3227 liberal. */ 3228 3229 static int 3230 ada_type_match (struct type *ftype, struct type *atype, int may_deref) 3231 { 3232 ftype = ada_check_typedef (ftype); 3233 atype = ada_check_typedef (atype); 3234 3235 if (TYPE_CODE (ftype) == TYPE_CODE_REF) 3236 ftype = TYPE_TARGET_TYPE (ftype); 3237 if (TYPE_CODE (atype) == TYPE_CODE_REF) 3238 atype = TYPE_TARGET_TYPE (atype); 3239 3240 switch (TYPE_CODE (ftype)) 3241 { 3242 default: 3243 return TYPE_CODE (ftype) == TYPE_CODE (atype); 3244 case TYPE_CODE_PTR: 3245 if (TYPE_CODE (atype) == TYPE_CODE_PTR) 3246 return ada_type_match (TYPE_TARGET_TYPE (ftype), 3247 TYPE_TARGET_TYPE (atype), 0); 3248 else 3249 return (may_deref 3250 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0)); 3251 case TYPE_CODE_INT: 3252 case TYPE_CODE_ENUM: 3253 case TYPE_CODE_RANGE: 3254 switch (TYPE_CODE (atype)) 3255 { 3256 case TYPE_CODE_INT: 3257 case TYPE_CODE_ENUM: 3258 case TYPE_CODE_RANGE: 3259 return 1; 3260 default: 3261 return 0; 3262 } 3263 3264 case TYPE_CODE_ARRAY: 3265 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY 3266 || ada_is_array_descriptor_type (atype)); 3267 3268 case TYPE_CODE_STRUCT: 3269 if (ada_is_array_descriptor_type (ftype)) 3270 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY 3271 || ada_is_array_descriptor_type (atype)); 3272 else 3273 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT 3274 && !ada_is_array_descriptor_type (atype)); 3275 3276 case TYPE_CODE_UNION: 3277 case TYPE_CODE_FLT: 3278 return (TYPE_CODE (atype) == TYPE_CODE (ftype)); 3279 } 3280 } 3281 3282 /* Return non-zero if the formals of FUNC "sufficiently match" the 3283 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC 3284 may also be an enumeral, in which case it is treated as a 0- 3285 argument function. */ 3286 3287 static int 3288 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals) 3289 { 3290 int i; 3291 struct type *func_type = SYMBOL_TYPE (func); 3292 3293 if (SYMBOL_CLASS (func) == LOC_CONST 3294 && TYPE_CODE (func_type) == TYPE_CODE_ENUM) 3295 return (n_actuals == 0); 3296 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC) 3297 return 0; 3298 3299 if (TYPE_NFIELDS (func_type) != n_actuals) 3300 return 0; 3301 3302 for (i = 0; i < n_actuals; i += 1) 3303 { 3304 if (actuals[i] == NULL) 3305 return 0; 3306 else 3307 { 3308 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type, 3309 i)); 3310 struct type *atype = ada_check_typedef (value_type (actuals[i])); 3311 3312 if (!ada_type_match (ftype, atype, 1)) 3313 return 0; 3314 } 3315 } 3316 return 1; 3317 } 3318 3319 /* False iff function type FUNC_TYPE definitely does not produce a value 3320 compatible with type CONTEXT_TYPE. Conservatively returns 1 if 3321 FUNC_TYPE is not a valid function type with a non-null return type 3322 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */ 3323 3324 static int 3325 return_match (struct type *func_type, struct type *context_type) 3326 { 3327 struct type *return_type; 3328 3329 if (func_type == NULL) 3330 return 1; 3331 3332 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC) 3333 return_type = get_base_type (TYPE_TARGET_TYPE (func_type)); 3334 else 3335 return_type = get_base_type (func_type); 3336 if (return_type == NULL) 3337 return 1; 3338 3339 context_type = get_base_type (context_type); 3340 3341 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM) 3342 return context_type == NULL || return_type == context_type; 3343 else if (context_type == NULL) 3344 return TYPE_CODE (return_type) != TYPE_CODE_VOID; 3345 else 3346 return TYPE_CODE (return_type) == TYPE_CODE (context_type); 3347 } 3348 3349 3350 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the 3351 function (if any) that matches the types of the NARGS arguments in 3352 ARGS. If CONTEXT_TYPE is non-null and there is at least one match 3353 that returns that type, then eliminate matches that don't. If 3354 CONTEXT_TYPE is void and there is at least one match that does not 3355 return void, eliminate all matches that do. 3356 3357 Asks the user if there is more than one match remaining. Returns -1 3358 if there is no such symbol or none is selected. NAME is used 3359 solely for messages. May re-arrange and modify SYMS in 3360 the process; the index returned is for the modified vector. */ 3361 3362 static int 3363 ada_resolve_function (struct ada_symbol_info syms[], 3364 int nsyms, struct value **args, int nargs, 3365 const char *name, struct type *context_type) 3366 { 3367 int fallback; 3368 int k; 3369 int m; /* Number of hits */ 3370 3371 m = 0; 3372 /* In the first pass of the loop, we only accept functions matching 3373 context_type. If none are found, we add a second pass of the loop 3374 where every function is accepted. */ 3375 for (fallback = 0; m == 0 && fallback < 2; fallback++) 3376 { 3377 for (k = 0; k < nsyms; k += 1) 3378 { 3379 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].sym)); 3380 3381 if (ada_args_match (syms[k].sym, args, nargs) 3382 && (fallback || return_match (type, context_type))) 3383 { 3384 syms[m] = syms[k]; 3385 m += 1; 3386 } 3387 } 3388 } 3389 3390 if (m == 0) 3391 return -1; 3392 else if (m > 1) 3393 { 3394 printf_filtered (_("Multiple matches for %s\n"), name); 3395 user_select_syms (syms, m, 1); 3396 return 0; 3397 } 3398 return 0; 3399 } 3400 3401 /* Returns true (non-zero) iff decoded name N0 should appear before N1 3402 in a listing of choices during disambiguation (see sort_choices, below). 3403 The idea is that overloadings of a subprogram name from the 3404 same package should sort in their source order. We settle for ordering 3405 such symbols by their trailing number (__N or $N). */ 3406 3407 static int 3408 encoded_ordered_before (char *N0, char *N1) 3409 { 3410 if (N1 == NULL) 3411 return 0; 3412 else if (N0 == NULL) 3413 return 1; 3414 else 3415 { 3416 int k0, k1; 3417 3418 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1) 3419 ; 3420 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1) 3421 ; 3422 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000' 3423 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000') 3424 { 3425 int n0, n1; 3426 3427 n0 = k0; 3428 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_') 3429 n0 -= 1; 3430 n1 = k1; 3431 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_') 3432 n1 -= 1; 3433 if (n0 == n1 && strncmp (N0, N1, n0) == 0) 3434 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1)); 3435 } 3436 return (strcmp (N0, N1) < 0); 3437 } 3438 } 3439 3440 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the 3441 encoded names. */ 3442 3443 static void 3444 sort_choices (struct ada_symbol_info syms[], int nsyms) 3445 { 3446 int i; 3447 3448 for (i = 1; i < nsyms; i += 1) 3449 { 3450 struct ada_symbol_info sym = syms[i]; 3451 int j; 3452 3453 for (j = i - 1; j >= 0; j -= 1) 3454 { 3455 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym), 3456 SYMBOL_LINKAGE_NAME (sym.sym))) 3457 break; 3458 syms[j + 1] = syms[j]; 3459 } 3460 syms[j + 1] = sym; 3461 } 3462 } 3463 3464 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0 3465 by asking the user (if necessary), returning the number selected, 3466 and setting the first elements of SYMS items. Error if no symbols 3467 selected. */ 3468 3469 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought 3470 to be re-integrated one of these days. */ 3471 3472 int 3473 user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results) 3474 { 3475 int i; 3476 int *chosen = (int *) alloca (sizeof (int) * nsyms); 3477 int n_chosen; 3478 int first_choice = (max_results == 1) ? 1 : 2; 3479 const char *select_mode = multiple_symbols_select_mode (); 3480 3481 if (max_results < 1) 3482 error (_("Request to select 0 symbols!")); 3483 if (nsyms <= 1) 3484 return nsyms; 3485 3486 if (select_mode == multiple_symbols_cancel) 3487 error (_("\ 3488 canceled because the command is ambiguous\n\ 3489 See set/show multiple-symbol.")); 3490 3491 /* If select_mode is "all", then return all possible symbols. 3492 Only do that if more than one symbol can be selected, of course. 3493 Otherwise, display the menu as usual. */ 3494 if (select_mode == multiple_symbols_all && max_results > 1) 3495 return nsyms; 3496 3497 printf_unfiltered (_("[0] cancel\n")); 3498 if (max_results > 1) 3499 printf_unfiltered (_("[1] all\n")); 3500 3501 sort_choices (syms, nsyms); 3502 3503 for (i = 0; i < nsyms; i += 1) 3504 { 3505 if (syms[i].sym == NULL) 3506 continue; 3507 3508 if (SYMBOL_CLASS (syms[i].sym) == LOC_BLOCK) 3509 { 3510 struct symtab_and_line sal = 3511 find_function_start_sal (syms[i].sym, 1); 3512 3513 if (sal.symtab == NULL) 3514 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"), 3515 i + first_choice, 3516 SYMBOL_PRINT_NAME (syms[i].sym), 3517 sal.line); 3518 else 3519 printf_unfiltered (_("[%d] %s at %s:%d\n"), i + first_choice, 3520 SYMBOL_PRINT_NAME (syms[i].sym), 3521 sal.symtab->filename, sal.line); 3522 continue; 3523 } 3524 else 3525 { 3526 int is_enumeral = 3527 (SYMBOL_CLASS (syms[i].sym) == LOC_CONST 3528 && SYMBOL_TYPE (syms[i].sym) != NULL 3529 && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM); 3530 struct symtab *symtab = syms[i].sym->symtab; 3531 3532 if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL) 3533 printf_unfiltered (_("[%d] %s at %s:%d\n"), 3534 i + first_choice, 3535 SYMBOL_PRINT_NAME (syms[i].sym), 3536 symtab->filename, SYMBOL_LINE (syms[i].sym)); 3537 else if (is_enumeral 3538 && TYPE_NAME (SYMBOL_TYPE (syms[i].sym)) != NULL) 3539 { 3540 printf_unfiltered (("[%d] "), i + first_choice); 3541 ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL, 3542 gdb_stdout, -1, 0); 3543 printf_unfiltered (_("'(%s) (enumeral)\n"), 3544 SYMBOL_PRINT_NAME (syms[i].sym)); 3545 } 3546 else if (symtab != NULL) 3547 printf_unfiltered (is_enumeral 3548 ? _("[%d] %s in %s (enumeral)\n") 3549 : _("[%d] %s at %s:?\n"), 3550 i + first_choice, 3551 SYMBOL_PRINT_NAME (syms[i].sym), 3552 symtab->filename); 3553 else 3554 printf_unfiltered (is_enumeral 3555 ? _("[%d] %s (enumeral)\n") 3556 : _("[%d] %s at ?\n"), 3557 i + first_choice, 3558 SYMBOL_PRINT_NAME (syms[i].sym)); 3559 } 3560 } 3561 3562 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1, 3563 "overload-choice"); 3564 3565 for (i = 0; i < n_chosen; i += 1) 3566 syms[i] = syms[chosen[i]]; 3567 3568 return n_chosen; 3569 } 3570 3571 /* Read and validate a set of numeric choices from the user in the 3572 range 0 .. N_CHOICES-1. Place the results in increasing 3573 order in CHOICES[0 .. N-1], and return N. 3574 3575 The user types choices as a sequence of numbers on one line 3576 separated by blanks, encoding them as follows: 3577 3578 + A choice of 0 means to cancel the selection, throwing an error. 3579 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1. 3580 + The user chooses k by typing k+IS_ALL_CHOICE+1. 3581 3582 The user is not allowed to choose more than MAX_RESULTS values. 3583 3584 ANNOTATION_SUFFIX, if present, is used to annotate the input 3585 prompts (for use with the -f switch). */ 3586 3587 int 3588 get_selections (int *choices, int n_choices, int max_results, 3589 int is_all_choice, char *annotation_suffix) 3590 { 3591 char *args; 3592 char *prompt; 3593 int n_chosen; 3594 int first_choice = is_all_choice ? 2 : 1; 3595 3596 prompt = getenv ("PS2"); 3597 if (prompt == NULL) 3598 prompt = "> "; 3599 3600 args = command_line_input (prompt, 0, annotation_suffix); 3601 3602 if (args == NULL) 3603 error_no_arg (_("one or more choice numbers")); 3604 3605 n_chosen = 0; 3606 3607 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending 3608 order, as given in args. Choices are validated. */ 3609 while (1) 3610 { 3611 char *args2; 3612 int choice, j; 3613 3614 while (isspace (*args)) 3615 args += 1; 3616 if (*args == '\0' && n_chosen == 0) 3617 error_no_arg (_("one or more choice numbers")); 3618 else if (*args == '\0') 3619 break; 3620 3621 choice = strtol (args, &args2, 10); 3622 if (args == args2 || choice < 0 3623 || choice > n_choices + first_choice - 1) 3624 error (_("Argument must be choice number")); 3625 args = args2; 3626 3627 if (choice == 0) 3628 error (_("cancelled")); 3629 3630 if (choice < first_choice) 3631 { 3632 n_chosen = n_choices; 3633 for (j = 0; j < n_choices; j += 1) 3634 choices[j] = j; 3635 break; 3636 } 3637 choice -= first_choice; 3638 3639 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1) 3640 { 3641 } 3642 3643 if (j < 0 || choice != choices[j]) 3644 { 3645 int k; 3646 3647 for (k = n_chosen - 1; k > j; k -= 1) 3648 choices[k + 1] = choices[k]; 3649 choices[j + 1] = choice; 3650 n_chosen += 1; 3651 } 3652 } 3653 3654 if (n_chosen > max_results) 3655 error (_("Select no more than %d of the above"), max_results); 3656 3657 return n_chosen; 3658 } 3659 3660 /* Replace the operator of length OPLEN at position PC in *EXPP with a call 3661 on the function identified by SYM and BLOCK, and taking NARGS 3662 arguments. Update *EXPP as needed to hold more space. */ 3663 3664 static void 3665 replace_operator_with_call (struct expression **expp, int pc, int nargs, 3666 int oplen, struct symbol *sym, 3667 struct block *block) 3668 { 3669 /* A new expression, with 6 more elements (3 for funcall, 4 for function 3670 symbol, -oplen for operator being replaced). */ 3671 struct expression *newexp = (struct expression *) 3672 xzalloc (sizeof (struct expression) 3673 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen)); 3674 struct expression *exp = *expp; 3675 3676 newexp->nelts = exp->nelts + 7 - oplen; 3677 newexp->language_defn = exp->language_defn; 3678 newexp->gdbarch = exp->gdbarch; 3679 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc)); 3680 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen, 3681 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen)); 3682 3683 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL; 3684 newexp->elts[pc + 1].longconst = (LONGEST) nargs; 3685 3686 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE; 3687 newexp->elts[pc + 4].block = block; 3688 newexp->elts[pc + 5].symbol = sym; 3689 3690 *expp = newexp; 3691 xfree (exp); 3692 } 3693 3694 /* Type-class predicates */ 3695 3696 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type), 3697 or FLOAT). */ 3698 3699 static int 3700 numeric_type_p (struct type *type) 3701 { 3702 if (type == NULL) 3703 return 0; 3704 else 3705 { 3706 switch (TYPE_CODE (type)) 3707 { 3708 case TYPE_CODE_INT: 3709 case TYPE_CODE_FLT: 3710 return 1; 3711 case TYPE_CODE_RANGE: 3712 return (type == TYPE_TARGET_TYPE (type) 3713 || numeric_type_p (TYPE_TARGET_TYPE (type))); 3714 default: 3715 return 0; 3716 } 3717 } 3718 } 3719 3720 /* True iff TYPE is integral (an INT or RANGE of INTs). */ 3721 3722 static int 3723 integer_type_p (struct type *type) 3724 { 3725 if (type == NULL) 3726 return 0; 3727 else 3728 { 3729 switch (TYPE_CODE (type)) 3730 { 3731 case TYPE_CODE_INT: 3732 return 1; 3733 case TYPE_CODE_RANGE: 3734 return (type == TYPE_TARGET_TYPE (type) 3735 || integer_type_p (TYPE_TARGET_TYPE (type))); 3736 default: 3737 return 0; 3738 } 3739 } 3740 } 3741 3742 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */ 3743 3744 static int 3745 scalar_type_p (struct type *type) 3746 { 3747 if (type == NULL) 3748 return 0; 3749 else 3750 { 3751 switch (TYPE_CODE (type)) 3752 { 3753 case TYPE_CODE_INT: 3754 case TYPE_CODE_RANGE: 3755 case TYPE_CODE_ENUM: 3756 case TYPE_CODE_FLT: 3757 return 1; 3758 default: 3759 return 0; 3760 } 3761 } 3762 } 3763 3764 /* True iff TYPE is discrete (INT, RANGE, ENUM). */ 3765 3766 static int 3767 discrete_type_p (struct type *type) 3768 { 3769 if (type == NULL) 3770 return 0; 3771 else 3772 { 3773 switch (TYPE_CODE (type)) 3774 { 3775 case TYPE_CODE_INT: 3776 case TYPE_CODE_RANGE: 3777 case TYPE_CODE_ENUM: 3778 case TYPE_CODE_BOOL: 3779 return 1; 3780 default: 3781 return 0; 3782 } 3783 } 3784 } 3785 3786 /* Returns non-zero if OP with operands in the vector ARGS could be 3787 a user-defined function. Errs on the side of pre-defined operators 3788 (i.e., result 0). */ 3789 3790 static int 3791 possible_user_operator_p (enum exp_opcode op, struct value *args[]) 3792 { 3793 struct type *type0 = 3794 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0])); 3795 struct type *type1 = 3796 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1])); 3797 3798 if (type0 == NULL) 3799 return 0; 3800 3801 switch (op) 3802 { 3803 default: 3804 return 0; 3805 3806 case BINOP_ADD: 3807 case BINOP_SUB: 3808 case BINOP_MUL: 3809 case BINOP_DIV: 3810 return (!(numeric_type_p (type0) && numeric_type_p (type1))); 3811 3812 case BINOP_REM: 3813 case BINOP_MOD: 3814 case BINOP_BITWISE_AND: 3815 case BINOP_BITWISE_IOR: 3816 case BINOP_BITWISE_XOR: 3817 return (!(integer_type_p (type0) && integer_type_p (type1))); 3818 3819 case BINOP_EQUAL: 3820 case BINOP_NOTEQUAL: 3821 case BINOP_LESS: 3822 case BINOP_GTR: 3823 case BINOP_LEQ: 3824 case BINOP_GEQ: 3825 return (!(scalar_type_p (type0) && scalar_type_p (type1))); 3826 3827 case BINOP_CONCAT: 3828 return !ada_is_array_type (type0) || !ada_is_array_type (type1); 3829 3830 case BINOP_EXP: 3831 return (!(numeric_type_p (type0) && integer_type_p (type1))); 3832 3833 case UNOP_NEG: 3834 case UNOP_PLUS: 3835 case UNOP_LOGICAL_NOT: 3836 case UNOP_ABS: 3837 return (!numeric_type_p (type0)); 3838 3839 } 3840 } 3841 3842 /* Renaming */ 3843 3844 /* NOTES: 3845 3846 1. In the following, we assume that a renaming type's name may 3847 have an ___XD suffix. It would be nice if this went away at some 3848 point. 3849 2. We handle both the (old) purely type-based representation of 3850 renamings and the (new) variable-based encoding. At some point, 3851 it is devoutly to be hoped that the former goes away 3852 (FIXME: hilfinger-2007-07-09). 3853 3. Subprogram renamings are not implemented, although the XRS 3854 suffix is recognized (FIXME: hilfinger-2007-07-09). */ 3855 3856 /* If SYM encodes a renaming, 3857 3858 <renaming> renames <renamed entity>, 3859 3860 sets *LEN to the length of the renamed entity's name, 3861 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to 3862 the string describing the subcomponent selected from the renamed 3863 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming 3864 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR 3865 are undefined). Otherwise, returns a value indicating the category 3866 of entity renamed: an object (ADA_OBJECT_RENAMING), exception 3867 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or 3868 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the 3869 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be 3870 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR 3871 may be NULL, in which case they are not assigned. 3872 3873 [Currently, however, GCC does not generate subprogram renamings.] */ 3874 3875 enum ada_renaming_category 3876 ada_parse_renaming (struct symbol *sym, 3877 const char **renamed_entity, int *len, 3878 const char **renaming_expr) 3879 { 3880 enum ada_renaming_category kind; 3881 const char *info; 3882 const char *suffix; 3883 3884 if (sym == NULL) 3885 return ADA_NOT_RENAMING; 3886 switch (SYMBOL_CLASS (sym)) 3887 { 3888 default: 3889 return ADA_NOT_RENAMING; 3890 case LOC_TYPEDEF: 3891 return parse_old_style_renaming (SYMBOL_TYPE (sym), 3892 renamed_entity, len, renaming_expr); 3893 case LOC_LOCAL: 3894 case LOC_STATIC: 3895 case LOC_COMPUTED: 3896 case LOC_OPTIMIZED_OUT: 3897 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR"); 3898 if (info == NULL) 3899 return ADA_NOT_RENAMING; 3900 switch (info[5]) 3901 { 3902 case '_': 3903 kind = ADA_OBJECT_RENAMING; 3904 info += 6; 3905 break; 3906 case 'E': 3907 kind = ADA_EXCEPTION_RENAMING; 3908 info += 7; 3909 break; 3910 case 'P': 3911 kind = ADA_PACKAGE_RENAMING; 3912 info += 7; 3913 break; 3914 case 'S': 3915 kind = ADA_SUBPROGRAM_RENAMING; 3916 info += 7; 3917 break; 3918 default: 3919 return ADA_NOT_RENAMING; 3920 } 3921 } 3922 3923 if (renamed_entity != NULL) 3924 *renamed_entity = info; 3925 suffix = strstr (info, "___XE"); 3926 if (suffix == NULL || suffix == info) 3927 return ADA_NOT_RENAMING; 3928 if (len != NULL) 3929 *len = strlen (info) - strlen (suffix); 3930 suffix += 5; 3931 if (renaming_expr != NULL) 3932 *renaming_expr = suffix; 3933 return kind; 3934 } 3935 3936 /* Assuming TYPE encodes a renaming according to the old encoding in 3937 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY, 3938 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns 3939 ADA_NOT_RENAMING otherwise. */ 3940 static enum ada_renaming_category 3941 parse_old_style_renaming (struct type *type, 3942 const char **renamed_entity, int *len, 3943 const char **renaming_expr) 3944 { 3945 enum ada_renaming_category kind; 3946 const char *name; 3947 const char *info; 3948 const char *suffix; 3949 3950 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM 3951 || TYPE_NFIELDS (type) != 1) 3952 return ADA_NOT_RENAMING; 3953 3954 name = type_name_no_tag (type); 3955 if (name == NULL) 3956 return ADA_NOT_RENAMING; 3957 3958 name = strstr (name, "___XR"); 3959 if (name == NULL) 3960 return ADA_NOT_RENAMING; 3961 switch (name[5]) 3962 { 3963 case '\0': 3964 case '_': 3965 kind = ADA_OBJECT_RENAMING; 3966 break; 3967 case 'E': 3968 kind = ADA_EXCEPTION_RENAMING; 3969 break; 3970 case 'P': 3971 kind = ADA_PACKAGE_RENAMING; 3972 break; 3973 case 'S': 3974 kind = ADA_SUBPROGRAM_RENAMING; 3975 break; 3976 default: 3977 return ADA_NOT_RENAMING; 3978 } 3979 3980 info = TYPE_FIELD_NAME (type, 0); 3981 if (info == NULL) 3982 return ADA_NOT_RENAMING; 3983 if (renamed_entity != NULL) 3984 *renamed_entity = info; 3985 suffix = strstr (info, "___XE"); 3986 if (renaming_expr != NULL) 3987 *renaming_expr = suffix + 5; 3988 if (suffix == NULL || suffix == info) 3989 return ADA_NOT_RENAMING; 3990 if (len != NULL) 3991 *len = suffix - info; 3992 return kind; 3993 } 3994 3995 3996 3997 /* Evaluation: Function Calls */ 3998 3999 /* Return an lvalue containing the value VAL. This is the identity on 4000 lvalues, and otherwise has the side-effect of allocating memory 4001 in the inferior where a copy of the value contents is copied. */ 4002 4003 static struct value * 4004 ensure_lval (struct value *val) 4005 { 4006 if (VALUE_LVAL (val) == not_lval 4007 || VALUE_LVAL (val) == lval_internalvar) 4008 { 4009 int len = TYPE_LENGTH (ada_check_typedef (value_type (val))); 4010 const CORE_ADDR addr = 4011 value_as_long (value_allocate_space_in_inferior (len)); 4012 4013 set_value_address (val, addr); 4014 VALUE_LVAL (val) = lval_memory; 4015 write_memory (addr, value_contents (val), len); 4016 } 4017 4018 return val; 4019 } 4020 4021 /* Return the value ACTUAL, converted to be an appropriate value for a 4022 formal of type FORMAL_TYPE. Use *SP as a stack pointer for 4023 allocating any necessary descriptors (fat pointers), or copies of 4024 values not residing in memory, updating it as needed. */ 4025 4026 struct value * 4027 ada_convert_actual (struct value *actual, struct type *formal_type0) 4028 { 4029 struct type *actual_type = ada_check_typedef (value_type (actual)); 4030 struct type *formal_type = ada_check_typedef (formal_type0); 4031 struct type *formal_target = 4032 TYPE_CODE (formal_type) == TYPE_CODE_PTR 4033 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type; 4034 struct type *actual_target = 4035 TYPE_CODE (actual_type) == TYPE_CODE_PTR 4036 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type; 4037 4038 if (ada_is_array_descriptor_type (formal_target) 4039 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY) 4040 return make_array_descriptor (formal_type, actual); 4041 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR 4042 || TYPE_CODE (formal_type) == TYPE_CODE_REF) 4043 { 4044 struct value *result; 4045 4046 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY 4047 && ada_is_array_descriptor_type (actual_target)) 4048 result = desc_data (actual); 4049 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR) 4050 { 4051 if (VALUE_LVAL (actual) != lval_memory) 4052 { 4053 struct value *val; 4054 4055 actual_type = ada_check_typedef (value_type (actual)); 4056 val = allocate_value (actual_type); 4057 memcpy ((char *) value_contents_raw (val), 4058 (char *) value_contents (actual), 4059 TYPE_LENGTH (actual_type)); 4060 actual = ensure_lval (val); 4061 } 4062 result = value_addr (actual); 4063 } 4064 else 4065 return actual; 4066 return value_cast_pointers (formal_type, result); 4067 } 4068 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR) 4069 return ada_value_ind (actual); 4070 4071 return actual; 4072 } 4073 4074 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of 4075 type TYPE. This is usually an inefficient no-op except on some targets 4076 (such as AVR) where the representation of a pointer and an address 4077 differs. */ 4078 4079 static CORE_ADDR 4080 value_pointer (struct value *value, struct type *type) 4081 { 4082 struct gdbarch *gdbarch = get_type_arch (type); 4083 unsigned len = TYPE_LENGTH (type); 4084 gdb_byte *buf = alloca (len); 4085 CORE_ADDR addr; 4086 4087 addr = value_address (value); 4088 gdbarch_address_to_pointer (gdbarch, type, buf, addr); 4089 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch)); 4090 return addr; 4091 } 4092 4093 4094 /* Push a descriptor of type TYPE for array value ARR on the stack at 4095 *SP, updating *SP to reflect the new descriptor. Return either 4096 an lvalue representing the new descriptor, or (if TYPE is a pointer- 4097 to-descriptor type rather than a descriptor type), a struct value * 4098 representing a pointer to this descriptor. */ 4099 4100 static struct value * 4101 make_array_descriptor (struct type *type, struct value *arr) 4102 { 4103 struct type *bounds_type = desc_bounds_type (type); 4104 struct type *desc_type = desc_base_type (type); 4105 struct value *descriptor = allocate_value (desc_type); 4106 struct value *bounds = allocate_value (bounds_type); 4107 int i; 4108 4109 for (i = ada_array_arity (ada_check_typedef (value_type (arr))); 4110 i > 0; i -= 1) 4111 { 4112 modify_field (value_type (bounds), value_contents_writeable (bounds), 4113 ada_array_bound (arr, i, 0), 4114 desc_bound_bitpos (bounds_type, i, 0), 4115 desc_bound_bitsize (bounds_type, i, 0)); 4116 modify_field (value_type (bounds), value_contents_writeable (bounds), 4117 ada_array_bound (arr, i, 1), 4118 desc_bound_bitpos (bounds_type, i, 1), 4119 desc_bound_bitsize (bounds_type, i, 1)); 4120 } 4121 4122 bounds = ensure_lval (bounds); 4123 4124 modify_field (value_type (descriptor), 4125 value_contents_writeable (descriptor), 4126 value_pointer (ensure_lval (arr), 4127 TYPE_FIELD_TYPE (desc_type, 0)), 4128 fat_pntr_data_bitpos (desc_type), 4129 fat_pntr_data_bitsize (desc_type)); 4130 4131 modify_field (value_type (descriptor), 4132 value_contents_writeable (descriptor), 4133 value_pointer (bounds, 4134 TYPE_FIELD_TYPE (desc_type, 1)), 4135 fat_pntr_bounds_bitpos (desc_type), 4136 fat_pntr_bounds_bitsize (desc_type)); 4137 4138 descriptor = ensure_lval (descriptor); 4139 4140 if (TYPE_CODE (type) == TYPE_CODE_PTR) 4141 return value_addr (descriptor); 4142 else 4143 return descriptor; 4144 } 4145 4146 /* Dummy definitions for an experimental caching module that is not 4147 * used in the public sources. */ 4148 4149 static int 4150 lookup_cached_symbol (const char *name, domain_enum namespace, 4151 struct symbol **sym, struct block **block) 4152 { 4153 return 0; 4154 } 4155 4156 static void 4157 cache_symbol (const char *name, domain_enum namespace, struct symbol *sym, 4158 struct block *block) 4159 { 4160 } 4161 4162 /* Symbol Lookup */ 4163 4164 /* Return the result of a standard (literal, C-like) lookup of NAME in 4165 given DOMAIN, visible from lexical block BLOCK. */ 4166 4167 static struct symbol * 4168 standard_lookup (const char *name, const struct block *block, 4169 domain_enum domain) 4170 { 4171 struct symbol *sym; 4172 4173 if (lookup_cached_symbol (name, domain, &sym, NULL)) 4174 return sym; 4175 sym = lookup_symbol_in_language (name, block, domain, language_c, 0); 4176 cache_symbol (name, domain, sym, block_found); 4177 return sym; 4178 } 4179 4180 4181 /* Non-zero iff there is at least one non-function/non-enumeral symbol 4182 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions, 4183 since they contend in overloading in the same way. */ 4184 static int 4185 is_nonfunction (struct ada_symbol_info syms[], int n) 4186 { 4187 int i; 4188 4189 for (i = 0; i < n; i += 1) 4190 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_FUNC 4191 && (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM 4192 || SYMBOL_CLASS (syms[i].sym) != LOC_CONST)) 4193 return 1; 4194 4195 return 0; 4196 } 4197 4198 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent 4199 struct types. Otherwise, they may not. */ 4200 4201 static int 4202 equiv_types (struct type *type0, struct type *type1) 4203 { 4204 if (type0 == type1) 4205 return 1; 4206 if (type0 == NULL || type1 == NULL 4207 || TYPE_CODE (type0) != TYPE_CODE (type1)) 4208 return 0; 4209 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT 4210 || TYPE_CODE (type0) == TYPE_CODE_ENUM) 4211 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL 4212 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0) 4213 return 1; 4214 4215 return 0; 4216 } 4217 4218 /* True iff SYM0 represents the same entity as SYM1, or one that is 4219 no more defined than that of SYM1. */ 4220 4221 static int 4222 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1) 4223 { 4224 if (sym0 == sym1) 4225 return 1; 4226 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1) 4227 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1)) 4228 return 0; 4229 4230 switch (SYMBOL_CLASS (sym0)) 4231 { 4232 case LOC_UNDEF: 4233 return 1; 4234 case LOC_TYPEDEF: 4235 { 4236 struct type *type0 = SYMBOL_TYPE (sym0); 4237 struct type *type1 = SYMBOL_TYPE (sym1); 4238 char *name0 = SYMBOL_LINKAGE_NAME (sym0); 4239 char *name1 = SYMBOL_LINKAGE_NAME (sym1); 4240 int len0 = strlen (name0); 4241 4242 return 4243 TYPE_CODE (type0) == TYPE_CODE (type1) 4244 && (equiv_types (type0, type1) 4245 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0 4246 && strncmp (name1 + len0, "___XV", 5) == 0)); 4247 } 4248 case LOC_CONST: 4249 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1) 4250 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1)); 4251 default: 4252 return 0; 4253 } 4254 } 4255 4256 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info 4257 records in OBSTACKP. Do nothing if SYM is a duplicate. */ 4258 4259 static void 4260 add_defn_to_vec (struct obstack *obstackp, 4261 struct symbol *sym, 4262 struct block *block) 4263 { 4264 int i; 4265 struct ada_symbol_info *prevDefns = defns_collected (obstackp, 0); 4266 4267 /* Do not try to complete stub types, as the debugger is probably 4268 already scanning all symbols matching a certain name at the 4269 time when this function is called. Trying to replace the stub 4270 type by its associated full type will cause us to restart a scan 4271 which may lead to an infinite recursion. Instead, the client 4272 collecting the matching symbols will end up collecting several 4273 matches, with at least one of them complete. It can then filter 4274 out the stub ones if needed. */ 4275 4276 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1) 4277 { 4278 if (lesseq_defined_than (sym, prevDefns[i].sym)) 4279 return; 4280 else if (lesseq_defined_than (prevDefns[i].sym, sym)) 4281 { 4282 prevDefns[i].sym = sym; 4283 prevDefns[i].block = block; 4284 return; 4285 } 4286 } 4287 4288 { 4289 struct ada_symbol_info info; 4290 4291 info.sym = sym; 4292 info.block = block; 4293 obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info)); 4294 } 4295 } 4296 4297 /* Number of ada_symbol_info structures currently collected in 4298 current vector in *OBSTACKP. */ 4299 4300 static int 4301 num_defns_collected (struct obstack *obstackp) 4302 { 4303 return obstack_object_size (obstackp) / sizeof (struct ada_symbol_info); 4304 } 4305 4306 /* Vector of ada_symbol_info structures currently collected in current 4307 vector in *OBSTACKP. If FINISH, close off the vector and return 4308 its final address. */ 4309 4310 static struct ada_symbol_info * 4311 defns_collected (struct obstack *obstackp, int finish) 4312 { 4313 if (finish) 4314 return obstack_finish (obstackp); 4315 else 4316 return (struct ada_symbol_info *) obstack_base (obstackp); 4317 } 4318 4319 /* Return a minimal symbol matching NAME according to Ada decoding 4320 rules. Returns NULL if there is no such minimal symbol. Names 4321 prefixed with "standard__" are handled specially: "standard__" is 4322 first stripped off, and only static and global symbols are searched. */ 4323 4324 struct minimal_symbol * 4325 ada_lookup_simple_minsym (const char *name) 4326 { 4327 struct objfile *objfile; 4328 struct minimal_symbol *msymbol; 4329 int wild_match; 4330 4331 if (strncmp (name, "standard__", sizeof ("standard__") - 1) == 0) 4332 { 4333 name += sizeof ("standard__") - 1; 4334 wild_match = 0; 4335 } 4336 else 4337 wild_match = (strstr (name, "__") == NULL); 4338 4339 ALL_MSYMBOLS (objfile, msymbol) 4340 { 4341 if (match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match) 4342 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline) 4343 return msymbol; 4344 } 4345 4346 return NULL; 4347 } 4348 4349 /* For all subprograms that statically enclose the subprogram of the 4350 selected frame, add symbols matching identifier NAME in DOMAIN 4351 and their blocks to the list of data in OBSTACKP, as for 4352 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a 4353 wildcard prefix. */ 4354 4355 static void 4356 add_symbols_from_enclosing_procs (struct obstack *obstackp, 4357 const char *name, domain_enum namespace, 4358 int wild_match) 4359 { 4360 } 4361 4362 /* True if TYPE is definitely an artificial type supplied to a symbol 4363 for which no debugging information was given in the symbol file. */ 4364 4365 static int 4366 is_nondebugging_type (struct type *type) 4367 { 4368 char *name = ada_type_name (type); 4369 4370 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0); 4371 } 4372 4373 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types 4374 that are deemed "identical" for practical purposes. 4375 4376 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM 4377 types and that their number of enumerals is identical (in other 4378 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */ 4379 4380 static int 4381 ada_identical_enum_types_p (struct type *type1, struct type *type2) 4382 { 4383 int i; 4384 4385 /* The heuristic we use here is fairly conservative. We consider 4386 that 2 enumerate types are identical if they have the same 4387 number of enumerals and that all enumerals have the same 4388 underlying value and name. */ 4389 4390 /* All enums in the type should have an identical underlying value. */ 4391 for (i = 0; i < TYPE_NFIELDS (type1); i++) 4392 if (TYPE_FIELD_BITPOS (type1, i) != TYPE_FIELD_BITPOS (type2, i)) 4393 return 0; 4394 4395 /* All enumerals should also have the same name (modulo any numerical 4396 suffix). */ 4397 for (i = 0; i < TYPE_NFIELDS (type1); i++) 4398 { 4399 char *name_1 = TYPE_FIELD_NAME (type1, i); 4400 char *name_2 = TYPE_FIELD_NAME (type2, i); 4401 int len_1 = strlen (name_1); 4402 int len_2 = strlen (name_2); 4403 4404 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1); 4405 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2); 4406 if (len_1 != len_2 4407 || strncmp (TYPE_FIELD_NAME (type1, i), 4408 TYPE_FIELD_NAME (type2, i), 4409 len_1) != 0) 4410 return 0; 4411 } 4412 4413 return 1; 4414 } 4415 4416 /* Return nonzero if all the symbols in SYMS are all enumeral symbols 4417 that are deemed "identical" for practical purposes. Sometimes, 4418 enumerals are not strictly identical, but their types are so similar 4419 that they can be considered identical. 4420 4421 For instance, consider the following code: 4422 4423 type Color is (Black, Red, Green, Blue, White); 4424 type RGB_Color is new Color range Red .. Blue; 4425 4426 Type RGB_Color is a subrange of an implicit type which is a copy 4427 of type Color. If we call that implicit type RGB_ColorB ("B" is 4428 for "Base Type"), then type RGB_ColorB is a copy of type Color. 4429 As a result, when an expression references any of the enumeral 4430 by name (Eg. "print green"), the expression is technically 4431 ambiguous and the user should be asked to disambiguate. But 4432 doing so would only hinder the user, since it wouldn't matter 4433 what choice he makes, the outcome would always be the same. 4434 So, for practical purposes, we consider them as the same. */ 4435 4436 static int 4437 symbols_are_identical_enums (struct ada_symbol_info *syms, int nsyms) 4438 { 4439 int i; 4440 4441 /* Before performing a thorough comparison check of each type, 4442 we perform a series of inexpensive checks. We expect that these 4443 checks will quickly fail in the vast majority of cases, and thus 4444 help prevent the unnecessary use of a more expensive comparison. 4445 Said comparison also expects us to make some of these checks 4446 (see ada_identical_enum_types_p). */ 4447 4448 /* Quick check: All symbols should have an enum type. */ 4449 for (i = 0; i < nsyms; i++) 4450 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM) 4451 return 0; 4452 4453 /* Quick check: They should all have the same value. */ 4454 for (i = 1; i < nsyms; i++) 4455 if (SYMBOL_VALUE (syms[i].sym) != SYMBOL_VALUE (syms[0].sym)) 4456 return 0; 4457 4458 /* Quick check: They should all have the same number of enumerals. */ 4459 for (i = 1; i < nsyms; i++) 4460 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].sym)) 4461 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].sym))) 4462 return 0; 4463 4464 /* All the sanity checks passed, so we might have a set of 4465 identical enumeration types. Perform a more complete 4466 comparison of the type of each symbol. */ 4467 for (i = 1; i < nsyms; i++) 4468 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].sym), 4469 SYMBOL_TYPE (syms[0].sym))) 4470 return 0; 4471 4472 return 1; 4473 } 4474 4475 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely 4476 duplicate other symbols in the list (The only case I know of where 4477 this happens is when object files containing stabs-in-ecoff are 4478 linked with files containing ordinary ecoff debugging symbols (or no 4479 debugging symbols)). Modifies SYMS to squeeze out deleted entries. 4480 Returns the number of items in the modified list. */ 4481 4482 static int 4483 remove_extra_symbols (struct ada_symbol_info *syms, int nsyms) 4484 { 4485 int i, j; 4486 4487 /* We should never be called with less than 2 symbols, as there 4488 cannot be any extra symbol in that case. But it's easy to 4489 handle, since we have nothing to do in that case. */ 4490 if (nsyms < 2) 4491 return nsyms; 4492 4493 i = 0; 4494 while (i < nsyms) 4495 { 4496 int remove_p = 0; 4497 4498 /* If two symbols have the same name and one of them is a stub type, 4499 the get rid of the stub. */ 4500 4501 if (TYPE_STUB (SYMBOL_TYPE (syms[i].sym)) 4502 && SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL) 4503 { 4504 for (j = 0; j < nsyms; j++) 4505 { 4506 if (j != i 4507 && !TYPE_STUB (SYMBOL_TYPE (syms[j].sym)) 4508 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL 4509 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym), 4510 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0) 4511 remove_p = 1; 4512 } 4513 } 4514 4515 /* Two symbols with the same name, same class and same address 4516 should be identical. */ 4517 4518 else if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL 4519 && SYMBOL_CLASS (syms[i].sym) == LOC_STATIC 4520 && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym))) 4521 { 4522 for (j = 0; j < nsyms; j += 1) 4523 { 4524 if (i != j 4525 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL 4526 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym), 4527 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0 4528 && SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym) 4529 && SYMBOL_VALUE_ADDRESS (syms[i].sym) 4530 == SYMBOL_VALUE_ADDRESS (syms[j].sym)) 4531 remove_p = 1; 4532 } 4533 } 4534 4535 if (remove_p) 4536 { 4537 for (j = i + 1; j < nsyms; j += 1) 4538 syms[j - 1] = syms[j]; 4539 nsyms -= 1; 4540 } 4541 4542 i += 1; 4543 } 4544 4545 /* If all the remaining symbols are identical enumerals, then 4546 just keep the first one and discard the rest. 4547 4548 Unlike what we did previously, we do not discard any entry 4549 unless they are ALL identical. This is because the symbol 4550 comparison is not a strict comparison, but rather a practical 4551 comparison. If all symbols are considered identical, then 4552 we can just go ahead and use the first one and discard the rest. 4553 But if we cannot reduce the list to a single element, we have 4554 to ask the user to disambiguate anyways. And if we have to 4555 present a multiple-choice menu, it's less confusing if the list 4556 isn't missing some choices that were identical and yet distinct. */ 4557 if (symbols_are_identical_enums (syms, nsyms)) 4558 nsyms = 1; 4559 4560 return nsyms; 4561 } 4562 4563 /* Given a type that corresponds to a renaming entity, use the type name 4564 to extract the scope (package name or function name, fully qualified, 4565 and following the GNAT encoding convention) where this renaming has been 4566 defined. The string returned needs to be deallocated after use. */ 4567 4568 static char * 4569 xget_renaming_scope (struct type *renaming_type) 4570 { 4571 /* The renaming types adhere to the following convention: 4572 <scope>__<rename>___<XR extension>. 4573 So, to extract the scope, we search for the "___XR" extension, 4574 and then backtrack until we find the first "__". */ 4575 4576 const char *name = type_name_no_tag (renaming_type); 4577 char *suffix = strstr (name, "___XR"); 4578 char *last; 4579 int scope_len; 4580 char *scope; 4581 4582 /* Now, backtrack a bit until we find the first "__". Start looking 4583 at suffix - 3, as the <rename> part is at least one character long. */ 4584 4585 for (last = suffix - 3; last > name; last--) 4586 if (last[0] == '_' && last[1] == '_') 4587 break; 4588 4589 /* Make a copy of scope and return it. */ 4590 4591 scope_len = last - name; 4592 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char)); 4593 4594 strncpy (scope, name, scope_len); 4595 scope[scope_len] = '\0'; 4596 4597 return scope; 4598 } 4599 4600 /* Return nonzero if NAME corresponds to a package name. */ 4601 4602 static int 4603 is_package_name (const char *name) 4604 { 4605 /* Here, We take advantage of the fact that no symbols are generated 4606 for packages, while symbols are generated for each function. 4607 So the condition for NAME represent a package becomes equivalent 4608 to NAME not existing in our list of symbols. There is only one 4609 small complication with library-level functions (see below). */ 4610 4611 char *fun_name; 4612 4613 /* If it is a function that has not been defined at library level, 4614 then we should be able to look it up in the symbols. */ 4615 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL) 4616 return 0; 4617 4618 /* Library-level function names start with "_ada_". See if function 4619 "_ada_" followed by NAME can be found. */ 4620 4621 /* Do a quick check that NAME does not contain "__", since library-level 4622 functions names cannot contain "__" in them. */ 4623 if (strstr (name, "__") != NULL) 4624 return 0; 4625 4626 fun_name = xstrprintf ("_ada_%s", name); 4627 4628 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL); 4629 } 4630 4631 /* Return nonzero if SYM corresponds to a renaming entity that is 4632 not visible from FUNCTION_NAME. */ 4633 4634 static int 4635 old_renaming_is_invisible (const struct symbol *sym, char *function_name) 4636 { 4637 char *scope; 4638 4639 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF) 4640 return 0; 4641 4642 scope = xget_renaming_scope (SYMBOL_TYPE (sym)); 4643 4644 make_cleanup (xfree, scope); 4645 4646 /* If the rename has been defined in a package, then it is visible. */ 4647 if (is_package_name (scope)) 4648 return 0; 4649 4650 /* Check that the rename is in the current function scope by checking 4651 that its name starts with SCOPE. */ 4652 4653 /* If the function name starts with "_ada_", it means that it is 4654 a library-level function. Strip this prefix before doing the 4655 comparison, as the encoding for the renaming does not contain 4656 this prefix. */ 4657 if (strncmp (function_name, "_ada_", 5) == 0) 4658 function_name += 5; 4659 4660 return (strncmp (function_name, scope, strlen (scope)) != 0); 4661 } 4662 4663 /* Remove entries from SYMS that corresponds to a renaming entity that 4664 is not visible from the function associated with CURRENT_BLOCK or 4665 that is superfluous due to the presence of more specific renaming 4666 information. Places surviving symbols in the initial entries of 4667 SYMS and returns the number of surviving symbols. 4668 4669 Rationale: 4670 First, in cases where an object renaming is implemented as a 4671 reference variable, GNAT may produce both the actual reference 4672 variable and the renaming encoding. In this case, we discard the 4673 latter. 4674 4675 Second, GNAT emits a type following a specified encoding for each renaming 4676 entity. Unfortunately, STABS currently does not support the definition 4677 of types that are local to a given lexical block, so all renamings types 4678 are emitted at library level. As a consequence, if an application 4679 contains two renaming entities using the same name, and a user tries to 4680 print the value of one of these entities, the result of the ada symbol 4681 lookup will also contain the wrong renaming type. 4682 4683 This function partially covers for this limitation by attempting to 4684 remove from the SYMS list renaming symbols that should be visible 4685 from CURRENT_BLOCK. However, there does not seem be a 100% reliable 4686 method with the current information available. The implementation 4687 below has a couple of limitations (FIXME: brobecker-2003-05-12): 4688 4689 - When the user tries to print a rename in a function while there 4690 is another rename entity defined in a package: Normally, the 4691 rename in the function has precedence over the rename in the 4692 package, so the latter should be removed from the list. This is 4693 currently not the case. 4694 4695 - This function will incorrectly remove valid renames if 4696 the CURRENT_BLOCK corresponds to a function which symbol name 4697 has been changed by an "Export" pragma. As a consequence, 4698 the user will be unable to print such rename entities. */ 4699 4700 static int 4701 remove_irrelevant_renamings (struct ada_symbol_info *syms, 4702 int nsyms, const struct block *current_block) 4703 { 4704 struct symbol *current_function; 4705 char *current_function_name; 4706 int i; 4707 int is_new_style_renaming; 4708 4709 /* If there is both a renaming foo___XR... encoded as a variable and 4710 a simple variable foo in the same block, discard the latter. 4711 First, zero out such symbols, then compress. */ 4712 is_new_style_renaming = 0; 4713 for (i = 0; i < nsyms; i += 1) 4714 { 4715 struct symbol *sym = syms[i].sym; 4716 struct block *block = syms[i].block; 4717 const char *name; 4718 const char *suffix; 4719 4720 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF) 4721 continue; 4722 name = SYMBOL_LINKAGE_NAME (sym); 4723 suffix = strstr (name, "___XR"); 4724 4725 if (suffix != NULL) 4726 { 4727 int name_len = suffix - name; 4728 int j; 4729 4730 is_new_style_renaming = 1; 4731 for (j = 0; j < nsyms; j += 1) 4732 if (i != j && syms[j].sym != NULL 4733 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].sym), 4734 name_len) == 0 4735 && block == syms[j].block) 4736 syms[j].sym = NULL; 4737 } 4738 } 4739 if (is_new_style_renaming) 4740 { 4741 int j, k; 4742 4743 for (j = k = 0; j < nsyms; j += 1) 4744 if (syms[j].sym != NULL) 4745 { 4746 syms[k] = syms[j]; 4747 k += 1; 4748 } 4749 return k; 4750 } 4751 4752 /* Extract the function name associated to CURRENT_BLOCK. 4753 Abort if unable to do so. */ 4754 4755 if (current_block == NULL) 4756 return nsyms; 4757 4758 current_function = block_linkage_function (current_block); 4759 if (current_function == NULL) 4760 return nsyms; 4761 4762 current_function_name = SYMBOL_LINKAGE_NAME (current_function); 4763 if (current_function_name == NULL) 4764 return nsyms; 4765 4766 /* Check each of the symbols, and remove it from the list if it is 4767 a type corresponding to a renaming that is out of the scope of 4768 the current block. */ 4769 4770 i = 0; 4771 while (i < nsyms) 4772 { 4773 if (ada_parse_renaming (syms[i].sym, NULL, NULL, NULL) 4774 == ADA_OBJECT_RENAMING 4775 && old_renaming_is_invisible (syms[i].sym, current_function_name)) 4776 { 4777 int j; 4778 4779 for (j = i + 1; j < nsyms; j += 1) 4780 syms[j - 1] = syms[j]; 4781 nsyms -= 1; 4782 } 4783 else 4784 i += 1; 4785 } 4786 4787 return nsyms; 4788 } 4789 4790 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks) 4791 whose name and domain match NAME and DOMAIN respectively. 4792 If no match was found, then extend the search to "enclosing" 4793 routines (in other words, if we're inside a nested function, 4794 search the symbols defined inside the enclosing functions). 4795 4796 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */ 4797 4798 static void 4799 ada_add_local_symbols (struct obstack *obstackp, const char *name, 4800 struct block *block, domain_enum domain, 4801 int wild_match) 4802 { 4803 int block_depth = 0; 4804 4805 while (block != NULL) 4806 { 4807 block_depth += 1; 4808 ada_add_block_symbols (obstackp, block, name, domain, NULL, wild_match); 4809 4810 /* If we found a non-function match, assume that's the one. */ 4811 if (is_nonfunction (defns_collected (obstackp, 0), 4812 num_defns_collected (obstackp))) 4813 return; 4814 4815 block = BLOCK_SUPERBLOCK (block); 4816 } 4817 4818 /* If no luck so far, try to find NAME as a local symbol in some lexically 4819 enclosing subprogram. */ 4820 if (num_defns_collected (obstackp) == 0 && block_depth > 2) 4821 add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match); 4822 } 4823 4824 /* An object of this type is used as the user_data argument when 4825 calling the map_matching_symbols method. */ 4826 4827 struct match_data 4828 { 4829 struct objfile *objfile; 4830 struct obstack *obstackp; 4831 struct symbol *arg_sym; 4832 int found_sym; 4833 }; 4834 4835 /* A callback for add_matching_symbols that adds SYM, found in BLOCK, 4836 to a list of symbols. DATA0 is a pointer to a struct match_data * 4837 containing the obstack that collects the symbol list, the file that SYM 4838 must come from, a flag indicating whether a non-argument symbol has 4839 been found in the current block, and the last argument symbol 4840 passed in SYM within the current block (if any). When SYM is null, 4841 marking the end of a block, the argument symbol is added if no 4842 other has been found. */ 4843 4844 static int 4845 aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0) 4846 { 4847 struct match_data *data = (struct match_data *) data0; 4848 4849 if (sym == NULL) 4850 { 4851 if (!data->found_sym && data->arg_sym != NULL) 4852 add_defn_to_vec (data->obstackp, 4853 fixup_symbol_section (data->arg_sym, data->objfile), 4854 block); 4855 data->found_sym = 0; 4856 data->arg_sym = NULL; 4857 } 4858 else 4859 { 4860 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED) 4861 return 0; 4862 else if (SYMBOL_IS_ARGUMENT (sym)) 4863 data->arg_sym = sym; 4864 else 4865 { 4866 data->found_sym = 1; 4867 add_defn_to_vec (data->obstackp, 4868 fixup_symbol_section (sym, data->objfile), 4869 block); 4870 } 4871 } 4872 return 0; 4873 } 4874 4875 /* Compare STRING1 to STRING2, with results as for strcmp. 4876 Compatible with strcmp_iw in that strcmp_iw (STRING1, STRING2) <= 0 4877 implies compare_names (STRING1, STRING2) (they may differ as to 4878 what symbols compare equal). */ 4879 4880 static int 4881 compare_names (const char *string1, const char *string2) 4882 { 4883 while (*string1 != '\0' && *string2 != '\0') 4884 { 4885 if (isspace (*string1) || isspace (*string2)) 4886 return strcmp_iw_ordered (string1, string2); 4887 if (*string1 != *string2) 4888 break; 4889 string1 += 1; 4890 string2 += 1; 4891 } 4892 switch (*string1) 4893 { 4894 case '(': 4895 return strcmp_iw_ordered (string1, string2); 4896 case '_': 4897 if (*string2 == '\0') 4898 { 4899 if (is_name_suffix (string1)) 4900 return 0; 4901 else 4902 return 1; 4903 } 4904 /* FALLTHROUGH */ 4905 default: 4906 if (*string2 == '(') 4907 return strcmp_iw_ordered (string1, string2); 4908 else 4909 return *string1 - *string2; 4910 } 4911 } 4912 4913 /* Add to OBSTACKP all non-local symbols whose name and domain match 4914 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK 4915 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */ 4916 4917 static void 4918 add_nonlocal_symbols (struct obstack *obstackp, const char *name, 4919 domain_enum domain, int global, 4920 int is_wild_match) 4921 { 4922 struct objfile *objfile; 4923 struct match_data data; 4924 4925 data.obstackp = obstackp; 4926 data.arg_sym = NULL; 4927 4928 ALL_OBJFILES (objfile) 4929 { 4930 data.objfile = objfile; 4931 4932 if (is_wild_match) 4933 objfile->sf->qf->map_matching_symbols (name, domain, objfile, global, 4934 aux_add_nonlocal_symbols, &data, 4935 wild_match, NULL); 4936 else 4937 objfile->sf->qf->map_matching_symbols (name, domain, objfile, global, 4938 aux_add_nonlocal_symbols, &data, 4939 full_match, compare_names); 4940 } 4941 4942 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match) 4943 { 4944 ALL_OBJFILES (objfile) 4945 { 4946 char *name1 = alloca (strlen (name) + sizeof ("_ada_")); 4947 strcpy (name1, "_ada_"); 4948 strcpy (name1 + sizeof ("_ada_") - 1, name); 4949 data.objfile = objfile; 4950 objfile->sf->qf->map_matching_symbols (name1, domain, 4951 objfile, global, 4952 aux_add_nonlocal_symbols, 4953 &data, 4954 full_match, compare_names); 4955 } 4956 } 4957 } 4958 4959 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing 4960 scope and in global scopes, returning the number of matches. Sets 4961 *RESULTS to point to a vector of (SYM,BLOCK) tuples, 4962 indicating the symbols found and the blocks and symbol tables (if 4963 any) in which they were found. This vector are transient---good only to 4964 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral 4965 symbol match within the nest of blocks whose innermost member is BLOCK0, 4966 is the one match returned (no other matches in that or 4967 enclosing blocks is returned). If there are any matches in or 4968 surrounding BLOCK0, then these alone are returned. Otherwise, the 4969 search extends to global and file-scope (static) symbol tables. 4970 Names prefixed with "standard__" are handled specially: "standard__" 4971 is first stripped off, and only static and global symbols are searched. */ 4972 4973 int 4974 ada_lookup_symbol_list (const char *name0, const struct block *block0, 4975 domain_enum namespace, 4976 struct ada_symbol_info **results) 4977 { 4978 struct symbol *sym; 4979 struct block *block; 4980 const char *name; 4981 int wild_match; 4982 int cacheIfUnique; 4983 int ndefns; 4984 4985 obstack_free (&symbol_list_obstack, NULL); 4986 obstack_init (&symbol_list_obstack); 4987 4988 cacheIfUnique = 0; 4989 4990 /* Search specified block and its superiors. */ 4991 4992 wild_match = (strstr (name0, "__") == NULL); 4993 name = name0; 4994 block = (struct block *) block0; /* FIXME: No cast ought to be 4995 needed, but adding const will 4996 have a cascade effect. */ 4997 4998 /* Special case: If the user specifies a symbol name inside package 4999 Standard, do a non-wild matching of the symbol name without 5000 the "standard__" prefix. This was primarily introduced in order 5001 to allow the user to specifically access the standard exceptions 5002 using, for instance, Standard.Constraint_Error when Constraint_Error 5003 is ambiguous (due to the user defining its own Constraint_Error 5004 entity inside its program). */ 5005 if (strncmp (name0, "standard__", sizeof ("standard__") - 1) == 0) 5006 { 5007 wild_match = 0; 5008 block = NULL; 5009 name = name0 + sizeof ("standard__") - 1; 5010 } 5011 5012 /* Check the non-global symbols. If we have ANY match, then we're done. */ 5013 5014 ada_add_local_symbols (&symbol_list_obstack, name, block, namespace, 5015 wild_match); 5016 if (num_defns_collected (&symbol_list_obstack) > 0) 5017 goto done; 5018 5019 /* No non-global symbols found. Check our cache to see if we have 5020 already performed this search before. If we have, then return 5021 the same result. */ 5022 5023 cacheIfUnique = 1; 5024 if (lookup_cached_symbol (name0, namespace, &sym, &block)) 5025 { 5026 if (sym != NULL) 5027 add_defn_to_vec (&symbol_list_obstack, sym, block); 5028 goto done; 5029 } 5030 5031 /* Search symbols from all global blocks. */ 5032 5033 add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 1, 5034 wild_match); 5035 5036 /* Now add symbols from all per-file blocks if we've gotten no hits 5037 (not strictly correct, but perhaps better than an error). */ 5038 5039 if (num_defns_collected (&symbol_list_obstack) == 0) 5040 add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 0, 5041 wild_match); 5042 5043 done: 5044 ndefns = num_defns_collected (&symbol_list_obstack); 5045 *results = defns_collected (&symbol_list_obstack, 1); 5046 5047 ndefns = remove_extra_symbols (*results, ndefns); 5048 5049 if (ndefns == 0) 5050 cache_symbol (name0, namespace, NULL, NULL); 5051 5052 if (ndefns == 1 && cacheIfUnique) 5053 cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block); 5054 5055 ndefns = remove_irrelevant_renamings (*results, ndefns, block0); 5056 5057 return ndefns; 5058 } 5059 5060 /* If NAME is the name of an entity, return a string that should 5061 be used to look that entity up in Ada units. This string should 5062 be deallocated after use using xfree. 5063 5064 NAME can have any form that the "break" or "print" commands might 5065 recognize. In other words, it does not have to be the "natural" 5066 name, or the "encoded" name. */ 5067 5068 char * 5069 ada_name_for_lookup (const char *name) 5070 { 5071 char *canon; 5072 int nlen = strlen (name); 5073 5074 if (name[0] == '<' && name[nlen - 1] == '>') 5075 { 5076 canon = xmalloc (nlen - 1); 5077 memcpy (canon, name + 1, nlen - 2); 5078 canon[nlen - 2] = '\0'; 5079 } 5080 else 5081 canon = xstrdup (ada_encode (ada_fold_name (name))); 5082 return canon; 5083 } 5084 5085 /* Implementation of the la_iterate_over_symbols method. */ 5086 5087 static void 5088 ada_iterate_over_symbols (const struct block *block, 5089 const char *name, domain_enum domain, 5090 int (*callback) (struct symbol *, void *), 5091 void *data) 5092 { 5093 int ndefs, i; 5094 struct ada_symbol_info *results; 5095 5096 ndefs = ada_lookup_symbol_list (name, block, domain, &results); 5097 for (i = 0; i < ndefs; ++i) 5098 { 5099 if (! (*callback) (results[i].sym, data)) 5100 break; 5101 } 5102 } 5103 5104 struct symbol * 5105 ada_lookup_encoded_symbol (const char *name, const struct block *block0, 5106 domain_enum namespace, struct block **block_found) 5107 { 5108 struct ada_symbol_info *candidates; 5109 int n_candidates; 5110 5111 n_candidates = ada_lookup_symbol_list (name, block0, namespace, &candidates); 5112 5113 if (n_candidates == 0) 5114 return NULL; 5115 5116 if (block_found != NULL) 5117 *block_found = candidates[0].block; 5118 5119 return fixup_symbol_section (candidates[0].sym, NULL); 5120 } 5121 5122 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing 5123 scope and in global scopes, or NULL if none. NAME is folded and 5124 encoded first. Otherwise, the result is as for ada_lookup_symbol_list, 5125 choosing the first symbol if there are multiple choices. 5126 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol 5127 table in which the symbol was found (in both cases, these 5128 assignments occur only if the pointers are non-null). */ 5129 struct symbol * 5130 ada_lookup_symbol (const char *name, const struct block *block0, 5131 domain_enum namespace, int *is_a_field_of_this) 5132 { 5133 if (is_a_field_of_this != NULL) 5134 *is_a_field_of_this = 0; 5135 5136 return 5137 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)), 5138 block0, namespace, NULL); 5139 } 5140 5141 static struct symbol * 5142 ada_lookup_symbol_nonlocal (const char *name, 5143 const struct block *block, 5144 const domain_enum domain) 5145 { 5146 return ada_lookup_symbol (name, block_static_block (block), domain, NULL); 5147 } 5148 5149 5150 /* True iff STR is a possible encoded suffix of a normal Ada name 5151 that is to be ignored for matching purposes. Suffixes of parallel 5152 names (e.g., XVE) are not included here. Currently, the possible suffixes 5153 are given by any of the regular expressions: 5154 5155 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux] 5156 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX] 5157 _E[0-9]+[bs]$ [protected object entry suffixes] 5158 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$ 5159 5160 Also, any leading "__[0-9]+" sequence is skipped before the suffix 5161 match is performed. This sequence is used to differentiate homonyms, 5162 is an optional part of a valid name suffix. */ 5163 5164 static int 5165 is_name_suffix (const char *str) 5166 { 5167 int k; 5168 const char *matching; 5169 const int len = strlen (str); 5170 5171 /* Skip optional leading __[0-9]+. */ 5172 5173 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2])) 5174 { 5175 str += 3; 5176 while (isdigit (str[0])) 5177 str += 1; 5178 } 5179 5180 /* [.$][0-9]+ */ 5181 5182 if (str[0] == '.' || str[0] == '$') 5183 { 5184 matching = str + 1; 5185 while (isdigit (matching[0])) 5186 matching += 1; 5187 if (matching[0] == '\0') 5188 return 1; 5189 } 5190 5191 /* ___[0-9]+ */ 5192 5193 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_') 5194 { 5195 matching = str + 3; 5196 while (isdigit (matching[0])) 5197 matching += 1; 5198 if (matching[0] == '\0') 5199 return 1; 5200 } 5201 5202 #if 0 5203 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end 5204 with a N at the end. Unfortunately, the compiler uses the same 5205 convention for other internal types it creates. So treating 5206 all entity names that end with an "N" as a name suffix causes 5207 some regressions. For instance, consider the case of an enumerated 5208 type. To support the 'Image attribute, it creates an array whose 5209 name ends with N. 5210 Having a single character like this as a suffix carrying some 5211 information is a bit risky. Perhaps we should change the encoding 5212 to be something like "_N" instead. In the meantime, do not do 5213 the following check. */ 5214 /* Protected Object Subprograms */ 5215 if (len == 1 && str [0] == 'N') 5216 return 1; 5217 #endif 5218 5219 /* _E[0-9]+[bs]$ */ 5220 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2])) 5221 { 5222 matching = str + 3; 5223 while (isdigit (matching[0])) 5224 matching += 1; 5225 if ((matching[0] == 'b' || matching[0] == 's') 5226 && matching [1] == '\0') 5227 return 1; 5228 } 5229 5230 /* ??? We should not modify STR directly, as we are doing below. This 5231 is fine in this case, but may become problematic later if we find 5232 that this alternative did not work, and want to try matching 5233 another one from the begining of STR. Since we modified it, we 5234 won't be able to find the begining of the string anymore! */ 5235 if (str[0] == 'X') 5236 { 5237 str += 1; 5238 while (str[0] != '_' && str[0] != '\0') 5239 { 5240 if (str[0] != 'n' && str[0] != 'b') 5241 return 0; 5242 str += 1; 5243 } 5244 } 5245 5246 if (str[0] == '\000') 5247 return 1; 5248 5249 if (str[0] == '_') 5250 { 5251 if (str[1] != '_' || str[2] == '\000') 5252 return 0; 5253 if (str[2] == '_') 5254 { 5255 if (strcmp (str + 3, "JM") == 0) 5256 return 1; 5257 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using 5258 the LJM suffix in favor of the JM one. But we will 5259 still accept LJM as a valid suffix for a reasonable 5260 amount of time, just to allow ourselves to debug programs 5261 compiled using an older version of GNAT. */ 5262 if (strcmp (str + 3, "LJM") == 0) 5263 return 1; 5264 if (str[3] != 'X') 5265 return 0; 5266 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B' 5267 || str[4] == 'U' || str[4] == 'P') 5268 return 1; 5269 if (str[4] == 'R' && str[5] != 'T') 5270 return 1; 5271 return 0; 5272 } 5273 if (!isdigit (str[2])) 5274 return 0; 5275 for (k = 3; str[k] != '\0'; k += 1) 5276 if (!isdigit (str[k]) && str[k] != '_') 5277 return 0; 5278 return 1; 5279 } 5280 if (str[0] == '$' && isdigit (str[1])) 5281 { 5282 for (k = 2; str[k] != '\0'; k += 1) 5283 if (!isdigit (str[k]) && str[k] != '_') 5284 return 0; 5285 return 1; 5286 } 5287 return 0; 5288 } 5289 5290 /* Return non-zero if the string starting at NAME and ending before 5291 NAME_END contains no capital letters. */ 5292 5293 static int 5294 is_valid_name_for_wild_match (const char *name0) 5295 { 5296 const char *decoded_name = ada_decode (name0); 5297 int i; 5298 5299 /* If the decoded name starts with an angle bracket, it means that 5300 NAME0 does not follow the GNAT encoding format. It should then 5301 not be allowed as a possible wild match. */ 5302 if (decoded_name[0] == '<') 5303 return 0; 5304 5305 for (i=0; decoded_name[i] != '\0'; i++) 5306 if (isalpha (decoded_name[i]) && !islower (decoded_name[i])) 5307 return 0; 5308 5309 return 1; 5310 } 5311 5312 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0 5313 that could start a simple name. Assumes that *NAMEP points into 5314 the string beginning at NAME0. */ 5315 5316 static int 5317 advance_wild_match (const char **namep, const char *name0, int target0) 5318 { 5319 const char *name = *namep; 5320 5321 while (1) 5322 { 5323 int t0, t1; 5324 5325 t0 = *name; 5326 if (t0 == '_') 5327 { 5328 t1 = name[1]; 5329 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9')) 5330 { 5331 name += 1; 5332 if (name == name0 + 5 && strncmp (name0, "_ada", 4) == 0) 5333 break; 5334 else 5335 name += 1; 5336 } 5337 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z') 5338 || name[2] == target0)) 5339 { 5340 name += 2; 5341 break; 5342 } 5343 else 5344 return 0; 5345 } 5346 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9')) 5347 name += 1; 5348 else 5349 return 0; 5350 } 5351 5352 *namep = name; 5353 return 1; 5354 } 5355 5356 /* Return 0 iff NAME encodes a name of the form prefix.PATN. Ignores any 5357 informational suffixes of NAME (i.e., for which is_name_suffix is 5358 true). Assumes that PATN is a lower-cased Ada simple name. */ 5359 5360 static int 5361 wild_match (const char *name, const char *patn) 5362 { 5363 const char *p, *n; 5364 const char *name0 = name; 5365 5366 while (1) 5367 { 5368 const char *match = name; 5369 5370 if (*name == *patn) 5371 { 5372 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1) 5373 if (*p != *name) 5374 break; 5375 if (*p == '\0' && is_name_suffix (name)) 5376 return match != name0 && !is_valid_name_for_wild_match (name0); 5377 5378 if (name[-1] == '_') 5379 name -= 1; 5380 } 5381 if (!advance_wild_match (&name, name0, *patn)) 5382 return 1; 5383 } 5384 } 5385 5386 /* Returns 0 iff symbol name SYM_NAME matches SEARCH_NAME, apart from 5387 informational suffix. */ 5388 5389 static int 5390 full_match (const char *sym_name, const char *search_name) 5391 { 5392 return !match_name (sym_name, search_name, 0); 5393 } 5394 5395 5396 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to 5397 vector *defn_symbols, updating the list of symbols in OBSTACKP 5398 (if necessary). If WILD, treat as NAME with a wildcard prefix. 5399 OBJFILE is the section containing BLOCK. 5400 SYMTAB is recorded with each symbol added. */ 5401 5402 static void 5403 ada_add_block_symbols (struct obstack *obstackp, 5404 struct block *block, const char *name, 5405 domain_enum domain, struct objfile *objfile, 5406 int wild) 5407 { 5408 struct dict_iterator iter; 5409 int name_len = strlen (name); 5410 /* A matching argument symbol, if any. */ 5411 struct symbol *arg_sym; 5412 /* Set true when we find a matching non-argument symbol. */ 5413 int found_sym; 5414 struct symbol *sym; 5415 5416 arg_sym = NULL; 5417 found_sym = 0; 5418 if (wild) 5419 { 5420 for (sym = dict_iter_match_first (BLOCK_DICT (block), name, 5421 wild_match, &iter); 5422 sym != NULL; sym = dict_iter_match_next (name, wild_match, &iter)) 5423 { 5424 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym), 5425 SYMBOL_DOMAIN (sym), domain) 5426 && wild_match (SYMBOL_LINKAGE_NAME (sym), name) == 0) 5427 { 5428 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED) 5429 continue; 5430 else if (SYMBOL_IS_ARGUMENT (sym)) 5431 arg_sym = sym; 5432 else 5433 { 5434 found_sym = 1; 5435 add_defn_to_vec (obstackp, 5436 fixup_symbol_section (sym, objfile), 5437 block); 5438 } 5439 } 5440 } 5441 } 5442 else 5443 { 5444 for (sym = dict_iter_match_first (BLOCK_DICT (block), name, 5445 full_match, &iter); 5446 sym != NULL; sym = dict_iter_match_next (name, full_match, &iter)) 5447 { 5448 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym), 5449 SYMBOL_DOMAIN (sym), domain)) 5450 { 5451 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED) 5452 { 5453 if (SYMBOL_IS_ARGUMENT (sym)) 5454 arg_sym = sym; 5455 else 5456 { 5457 found_sym = 1; 5458 add_defn_to_vec (obstackp, 5459 fixup_symbol_section (sym, objfile), 5460 block); 5461 } 5462 } 5463 } 5464 } 5465 } 5466 5467 if (!found_sym && arg_sym != NULL) 5468 { 5469 add_defn_to_vec (obstackp, 5470 fixup_symbol_section (arg_sym, objfile), 5471 block); 5472 } 5473 5474 if (!wild) 5475 { 5476 arg_sym = NULL; 5477 found_sym = 0; 5478 5479 ALL_BLOCK_SYMBOLS (block, iter, sym) 5480 { 5481 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym), 5482 SYMBOL_DOMAIN (sym), domain)) 5483 { 5484 int cmp; 5485 5486 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0]; 5487 if (cmp == 0) 5488 { 5489 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym), 5); 5490 if (cmp == 0) 5491 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5, 5492 name_len); 5493 } 5494 5495 if (cmp == 0 5496 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5)) 5497 { 5498 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED) 5499 { 5500 if (SYMBOL_IS_ARGUMENT (sym)) 5501 arg_sym = sym; 5502 else 5503 { 5504 found_sym = 1; 5505 add_defn_to_vec (obstackp, 5506 fixup_symbol_section (sym, objfile), 5507 block); 5508 } 5509 } 5510 } 5511 } 5512 } 5513 5514 /* NOTE: This really shouldn't be needed for _ada_ symbols. 5515 They aren't parameters, right? */ 5516 if (!found_sym && arg_sym != NULL) 5517 { 5518 add_defn_to_vec (obstackp, 5519 fixup_symbol_section (arg_sym, objfile), 5520 block); 5521 } 5522 } 5523 } 5524 5525 5526 /* Symbol Completion */ 5527 5528 /* If SYM_NAME is a completion candidate for TEXT, return this symbol 5529 name in a form that's appropriate for the completion. The result 5530 does not need to be deallocated, but is only good until the next call. 5531 5532 TEXT_LEN is equal to the length of TEXT. 5533 Perform a wild match if WILD_MATCH is set. 5534 ENCODED should be set if TEXT represents the start of a symbol name 5535 in its encoded form. */ 5536 5537 static const char * 5538 symbol_completion_match (const char *sym_name, 5539 const char *text, int text_len, 5540 int wild_match, int encoded) 5541 { 5542 const int verbatim_match = (text[0] == '<'); 5543 int match = 0; 5544 5545 if (verbatim_match) 5546 { 5547 /* Strip the leading angle bracket. */ 5548 text = text + 1; 5549 text_len--; 5550 } 5551 5552 /* First, test against the fully qualified name of the symbol. */ 5553 5554 if (strncmp (sym_name, text, text_len) == 0) 5555 match = 1; 5556 5557 if (match && !encoded) 5558 { 5559 /* One needed check before declaring a positive match is to verify 5560 that iff we are doing a verbatim match, the decoded version 5561 of the symbol name starts with '<'. Otherwise, this symbol name 5562 is not a suitable completion. */ 5563 const char *sym_name_copy = sym_name; 5564 int has_angle_bracket; 5565 5566 sym_name = ada_decode (sym_name); 5567 has_angle_bracket = (sym_name[0] == '<'); 5568 match = (has_angle_bracket == verbatim_match); 5569 sym_name = sym_name_copy; 5570 } 5571 5572 if (match && !verbatim_match) 5573 { 5574 /* When doing non-verbatim match, another check that needs to 5575 be done is to verify that the potentially matching symbol name 5576 does not include capital letters, because the ada-mode would 5577 not be able to understand these symbol names without the 5578 angle bracket notation. */ 5579 const char *tmp; 5580 5581 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++); 5582 if (*tmp != '\0') 5583 match = 0; 5584 } 5585 5586 /* Second: Try wild matching... */ 5587 5588 if (!match && wild_match) 5589 { 5590 /* Since we are doing wild matching, this means that TEXT 5591 may represent an unqualified symbol name. We therefore must 5592 also compare TEXT against the unqualified name of the symbol. */ 5593 sym_name = ada_unqualified_name (ada_decode (sym_name)); 5594 5595 if (strncmp (sym_name, text, text_len) == 0) 5596 match = 1; 5597 } 5598 5599 /* Finally: If we found a mach, prepare the result to return. */ 5600 5601 if (!match) 5602 return NULL; 5603 5604 if (verbatim_match) 5605 sym_name = add_angle_brackets (sym_name); 5606 5607 if (!encoded) 5608 sym_name = ada_decode (sym_name); 5609 5610 return sym_name; 5611 } 5612 5613 DEF_VEC_P (char_ptr); 5614 5615 /* A companion function to ada_make_symbol_completion_list(). 5616 Check if SYM_NAME represents a symbol which name would be suitable 5617 to complete TEXT (TEXT_LEN is the length of TEXT), in which case 5618 it is appended at the end of the given string vector SV. 5619 5620 ORIG_TEXT is the string original string from the user command 5621 that needs to be completed. WORD is the entire command on which 5622 completion should be performed. These two parameters are used to 5623 determine which part of the symbol name should be added to the 5624 completion vector. 5625 if WILD_MATCH is set, then wild matching is performed. 5626 ENCODED should be set if TEXT represents a symbol name in its 5627 encoded formed (in which case the completion should also be 5628 encoded). */ 5629 5630 static void 5631 symbol_completion_add (VEC(char_ptr) **sv, 5632 const char *sym_name, 5633 const char *text, int text_len, 5634 const char *orig_text, const char *word, 5635 int wild_match, int encoded) 5636 { 5637 const char *match = symbol_completion_match (sym_name, text, text_len, 5638 wild_match, encoded); 5639 char *completion; 5640 5641 if (match == NULL) 5642 return; 5643 5644 /* We found a match, so add the appropriate completion to the given 5645 string vector. */ 5646 5647 if (word == orig_text) 5648 { 5649 completion = xmalloc (strlen (match) + 5); 5650 strcpy (completion, match); 5651 } 5652 else if (word > orig_text) 5653 { 5654 /* Return some portion of sym_name. */ 5655 completion = xmalloc (strlen (match) + 5); 5656 strcpy (completion, match + (word - orig_text)); 5657 } 5658 else 5659 { 5660 /* Return some of ORIG_TEXT plus sym_name. */ 5661 completion = xmalloc (strlen (match) + (orig_text - word) + 5); 5662 strncpy (completion, word, orig_text - word); 5663 completion[orig_text - word] = '\0'; 5664 strcat (completion, match); 5665 } 5666 5667 VEC_safe_push (char_ptr, *sv, completion); 5668 } 5669 5670 /* An object of this type is passed as the user_data argument to the 5671 expand_partial_symbol_names method. */ 5672 struct add_partial_datum 5673 { 5674 VEC(char_ptr) **completions; 5675 char *text; 5676 int text_len; 5677 char *text0; 5678 char *word; 5679 int wild_match; 5680 int encoded; 5681 }; 5682 5683 /* A callback for expand_partial_symbol_names. */ 5684 static int 5685 ada_expand_partial_symbol_name (const struct language_defn *language, 5686 const char *name, void *user_data) 5687 { 5688 struct add_partial_datum *data = user_data; 5689 5690 return symbol_completion_match (name, data->text, data->text_len, 5691 data->wild_match, data->encoded) != NULL; 5692 } 5693 5694 /* Return a list of possible symbol names completing TEXT0. The list 5695 is NULL terminated. WORD is the entire command on which completion 5696 is made. */ 5697 5698 static char ** 5699 ada_make_symbol_completion_list (char *text0, char *word) 5700 { 5701 char *text; 5702 int text_len; 5703 int wild_match; 5704 int encoded; 5705 VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128); 5706 struct symbol *sym; 5707 struct symtab *s; 5708 struct minimal_symbol *msymbol; 5709 struct objfile *objfile; 5710 struct block *b, *surrounding_static_block = 0; 5711 int i; 5712 struct dict_iterator iter; 5713 5714 if (text0[0] == '<') 5715 { 5716 text = xstrdup (text0); 5717 make_cleanup (xfree, text); 5718 text_len = strlen (text); 5719 wild_match = 0; 5720 encoded = 1; 5721 } 5722 else 5723 { 5724 text = xstrdup (ada_encode (text0)); 5725 make_cleanup (xfree, text); 5726 text_len = strlen (text); 5727 for (i = 0; i < text_len; i++) 5728 text[i] = tolower (text[i]); 5729 5730 encoded = (strstr (text0, "__") != NULL); 5731 /* If the name contains a ".", then the user is entering a fully 5732 qualified entity name, and the match must not be done in wild 5733 mode. Similarly, if the user wants to complete what looks like 5734 an encoded name, the match must not be done in wild mode. */ 5735 wild_match = (strchr (text0, '.') == NULL && !encoded); 5736 } 5737 5738 /* First, look at the partial symtab symbols. */ 5739 { 5740 struct add_partial_datum data; 5741 5742 data.completions = &completions; 5743 data.text = text; 5744 data.text_len = text_len; 5745 data.text0 = text0; 5746 data.word = word; 5747 data.wild_match = wild_match; 5748 data.encoded = encoded; 5749 expand_partial_symbol_names (ada_expand_partial_symbol_name, &data); 5750 } 5751 5752 /* At this point scan through the misc symbol vectors and add each 5753 symbol you find to the list. Eventually we want to ignore 5754 anything that isn't a text symbol (everything else will be 5755 handled by the psymtab code above). */ 5756 5757 ALL_MSYMBOLS (objfile, msymbol) 5758 { 5759 QUIT; 5760 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (msymbol), 5761 text, text_len, text0, word, wild_match, encoded); 5762 } 5763 5764 /* Search upwards from currently selected frame (so that we can 5765 complete on local vars. */ 5766 5767 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b)) 5768 { 5769 if (!BLOCK_SUPERBLOCK (b)) 5770 surrounding_static_block = b; /* For elmin of dups */ 5771 5772 ALL_BLOCK_SYMBOLS (b, iter, sym) 5773 { 5774 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym), 5775 text, text_len, text0, word, 5776 wild_match, encoded); 5777 } 5778 } 5779 5780 /* Go through the symtabs and check the externs and statics for 5781 symbols which match. */ 5782 5783 ALL_SYMTABS (objfile, s) 5784 { 5785 QUIT; 5786 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK); 5787 ALL_BLOCK_SYMBOLS (b, iter, sym) 5788 { 5789 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym), 5790 text, text_len, text0, word, 5791 wild_match, encoded); 5792 } 5793 } 5794 5795 ALL_SYMTABS (objfile, s) 5796 { 5797 QUIT; 5798 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK); 5799 /* Don't do this block twice. */ 5800 if (b == surrounding_static_block) 5801 continue; 5802 ALL_BLOCK_SYMBOLS (b, iter, sym) 5803 { 5804 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym), 5805 text, text_len, text0, word, 5806 wild_match, encoded); 5807 } 5808 } 5809 5810 /* Append the closing NULL entry. */ 5811 VEC_safe_push (char_ptr, completions, NULL); 5812 5813 /* Make a copy of the COMPLETIONS VEC before we free it, and then 5814 return the copy. It's unfortunate that we have to make a copy 5815 of an array that we're about to destroy, but there is nothing much 5816 we can do about it. Fortunately, it's typically not a very large 5817 array. */ 5818 { 5819 const size_t completions_size = 5820 VEC_length (char_ptr, completions) * sizeof (char *); 5821 char **result = xmalloc (completions_size); 5822 5823 memcpy (result, VEC_address (char_ptr, completions), completions_size); 5824 5825 VEC_free (char_ptr, completions); 5826 return result; 5827 } 5828 } 5829 5830 /* Field Access */ 5831 5832 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used 5833 for tagged types. */ 5834 5835 static int 5836 ada_is_dispatch_table_ptr_type (struct type *type) 5837 { 5838 char *name; 5839 5840 if (TYPE_CODE (type) != TYPE_CODE_PTR) 5841 return 0; 5842 5843 name = TYPE_NAME (TYPE_TARGET_TYPE (type)); 5844 if (name == NULL) 5845 return 0; 5846 5847 return (strcmp (name, "ada__tags__dispatch_table") == 0); 5848 } 5849 5850 /* True if field number FIELD_NUM in struct or union type TYPE is supposed 5851 to be invisible to users. */ 5852 5853 int 5854 ada_is_ignored_field (struct type *type, int field_num) 5855 { 5856 if (field_num < 0 || field_num > TYPE_NFIELDS (type)) 5857 return 1; 5858 5859 /* Check the name of that field. */ 5860 { 5861 const char *name = TYPE_FIELD_NAME (type, field_num); 5862 5863 /* Anonymous field names should not be printed. 5864 brobecker/2007-02-20: I don't think this can actually happen 5865 but we don't want to print the value of annonymous fields anyway. */ 5866 if (name == NULL) 5867 return 1; 5868 5869 /* A field named "_parent" is internally generated by GNAT for 5870 tagged types, and should not be printed either. */ 5871 if (name[0] == '_' && strncmp (name, "_parent", 7) != 0) 5872 return 1; 5873 } 5874 5875 /* If this is the dispatch table of a tagged type, then ignore. */ 5876 if (ada_is_tagged_type (type, 1) 5877 && ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))) 5878 return 1; 5879 5880 /* Not a special field, so it should not be ignored. */ 5881 return 0; 5882 } 5883 5884 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a 5885 pointer or reference type whose ultimate target has a tag field. */ 5886 5887 int 5888 ada_is_tagged_type (struct type *type, int refok) 5889 { 5890 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL); 5891 } 5892 5893 /* True iff TYPE represents the type of X'Tag */ 5894 5895 int 5896 ada_is_tag_type (struct type *type) 5897 { 5898 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR) 5899 return 0; 5900 else 5901 { 5902 const char *name = ada_type_name (TYPE_TARGET_TYPE (type)); 5903 5904 return (name != NULL 5905 && strcmp (name, "ada__tags__dispatch_table") == 0); 5906 } 5907 } 5908 5909 /* The type of the tag on VAL. */ 5910 5911 struct type * 5912 ada_tag_type (struct value *val) 5913 { 5914 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL); 5915 } 5916 5917 /* The value of the tag on VAL. */ 5918 5919 struct value * 5920 ada_value_tag (struct value *val) 5921 { 5922 return ada_value_struct_elt (val, "_tag", 0); 5923 } 5924 5925 /* The value of the tag on the object of type TYPE whose contents are 5926 saved at VALADDR, if it is non-null, or is at memory address 5927 ADDRESS. */ 5928 5929 static struct value * 5930 value_tag_from_contents_and_address (struct type *type, 5931 const gdb_byte *valaddr, 5932 CORE_ADDR address) 5933 { 5934 int tag_byte_offset; 5935 struct type *tag_type; 5936 5937 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset, 5938 NULL, NULL, NULL)) 5939 { 5940 const gdb_byte *valaddr1 = ((valaddr == NULL) 5941 ? NULL 5942 : valaddr + tag_byte_offset); 5943 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset; 5944 5945 return value_from_contents_and_address (tag_type, valaddr1, address1); 5946 } 5947 return NULL; 5948 } 5949 5950 static struct type * 5951 type_from_tag (struct value *tag) 5952 { 5953 const char *type_name = ada_tag_name (tag); 5954 5955 if (type_name != NULL) 5956 return ada_find_any_type (ada_encode (type_name)); 5957 return NULL; 5958 } 5959 5960 struct tag_args 5961 { 5962 struct value *tag; 5963 char *name; 5964 }; 5965 5966 5967 static int ada_tag_name_1 (void *); 5968 static int ada_tag_name_2 (struct tag_args *); 5969 5970 /* Wrapper function used by ada_tag_name. Given a struct tag_args* 5971 value ARGS, sets ARGS->name to the tag name of ARGS->tag. 5972 The value stored in ARGS->name is valid until the next call to 5973 ada_tag_name_1. */ 5974 5975 static int 5976 ada_tag_name_1 (void *args0) 5977 { 5978 struct tag_args *args = (struct tag_args *) args0; 5979 static char name[1024]; 5980 char *p; 5981 struct value *val; 5982 5983 args->name = NULL; 5984 val = ada_value_struct_elt (args->tag, "tsd", 1); 5985 if (val == NULL) 5986 return ada_tag_name_2 (args); 5987 val = ada_value_struct_elt (val, "expanded_name", 1); 5988 if (val == NULL) 5989 return 0; 5990 read_memory_string (value_as_address (val), name, sizeof (name) - 1); 5991 for (p = name; *p != '\0'; p += 1) 5992 if (isalpha (*p)) 5993 *p = tolower (*p); 5994 args->name = name; 5995 return 0; 5996 } 5997 5998 /* Return the "ada__tags__type_specific_data" type. */ 5999 6000 static struct type * 6001 ada_get_tsd_type (struct inferior *inf) 6002 { 6003 struct ada_inferior_data *data = get_ada_inferior_data (inf); 6004 6005 if (data->tsd_type == 0) 6006 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data"); 6007 return data->tsd_type; 6008 } 6009 6010 /* Utility function for ada_tag_name_1 that tries the second 6011 representation for the dispatch table (in which there is no 6012 explicit 'tsd' field in the referent of the tag pointer, and instead 6013 the tsd pointer is stored just before the dispatch table. */ 6014 6015 static int 6016 ada_tag_name_2 (struct tag_args *args) 6017 { 6018 struct type *info_type; 6019 static char name[1024]; 6020 char *p; 6021 struct value *val, *valp; 6022 6023 args->name = NULL; 6024 info_type = ada_get_tsd_type (current_inferior()); 6025 if (info_type == NULL) 6026 return 0; 6027 info_type = lookup_pointer_type (lookup_pointer_type (info_type)); 6028 valp = value_cast (info_type, args->tag); 6029 if (valp == NULL) 6030 return 0; 6031 val = value_ind (value_ptradd (valp, -1)); 6032 if (val == NULL) 6033 return 0; 6034 val = ada_value_struct_elt (val, "expanded_name", 1); 6035 if (val == NULL) 6036 return 0; 6037 read_memory_string (value_as_address (val), name, sizeof (name) - 1); 6038 for (p = name; *p != '\0'; p += 1) 6039 if (isalpha (*p)) 6040 *p = tolower (*p); 6041 args->name = name; 6042 return 0; 6043 } 6044 6045 /* The type name of the dynamic type denoted by the 'tag value TAG, as 6046 a C string. */ 6047 6048 const char * 6049 ada_tag_name (struct value *tag) 6050 { 6051 struct tag_args args; 6052 6053 if (!ada_is_tag_type (value_type (tag))) 6054 return NULL; 6055 args.tag = tag; 6056 args.name = NULL; 6057 catch_errors (ada_tag_name_1, &args, NULL, RETURN_MASK_ALL); 6058 return args.name; 6059 } 6060 6061 /* The parent type of TYPE, or NULL if none. */ 6062 6063 struct type * 6064 ada_parent_type (struct type *type) 6065 { 6066 int i; 6067 6068 type = ada_check_typedef (type); 6069 6070 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT) 6071 return NULL; 6072 6073 for (i = 0; i < TYPE_NFIELDS (type); i += 1) 6074 if (ada_is_parent_field (type, i)) 6075 { 6076 struct type *parent_type = TYPE_FIELD_TYPE (type, i); 6077 6078 /* If the _parent field is a pointer, then dereference it. */ 6079 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR) 6080 parent_type = TYPE_TARGET_TYPE (parent_type); 6081 /* If there is a parallel XVS type, get the actual base type. */ 6082 parent_type = ada_get_base_type (parent_type); 6083 6084 return ada_check_typedef (parent_type); 6085 } 6086 6087 return NULL; 6088 } 6089 6090 /* True iff field number FIELD_NUM of structure type TYPE contains the 6091 parent-type (inherited) fields of a derived type. Assumes TYPE is 6092 a structure type with at least FIELD_NUM+1 fields. */ 6093 6094 int 6095 ada_is_parent_field (struct type *type, int field_num) 6096 { 6097 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num); 6098 6099 return (name != NULL 6100 && (strncmp (name, "PARENT", 6) == 0 6101 || strncmp (name, "_parent", 7) == 0)); 6102 } 6103 6104 /* True iff field number FIELD_NUM of structure type TYPE is a 6105 transparent wrapper field (which should be silently traversed when doing 6106 field selection and flattened when printing). Assumes TYPE is a 6107 structure type with at least FIELD_NUM+1 fields. Such fields are always 6108 structures. */ 6109 6110 int 6111 ada_is_wrapper_field (struct type *type, int field_num) 6112 { 6113 const char *name = TYPE_FIELD_NAME (type, field_num); 6114 6115 return (name != NULL 6116 && (strncmp (name, "PARENT", 6) == 0 6117 || strcmp (name, "REP") == 0 6118 || strncmp (name, "_parent", 7) == 0 6119 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O')); 6120 } 6121 6122 /* True iff field number FIELD_NUM of structure or union type TYPE 6123 is a variant wrapper. Assumes TYPE is a structure type with at least 6124 FIELD_NUM+1 fields. */ 6125 6126 int 6127 ada_is_variant_part (struct type *type, int field_num) 6128 { 6129 struct type *field_type = TYPE_FIELD_TYPE (type, field_num); 6130 6131 return (TYPE_CODE (field_type) == TYPE_CODE_UNION 6132 || (is_dynamic_field (type, field_num) 6133 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type)) 6134 == TYPE_CODE_UNION))); 6135 } 6136 6137 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part) 6138 whose discriminants are contained in the record type OUTER_TYPE, 6139 returns the type of the controlling discriminant for the variant. 6140 May return NULL if the type could not be found. */ 6141 6142 struct type * 6143 ada_variant_discrim_type (struct type *var_type, struct type *outer_type) 6144 { 6145 char *name = ada_variant_discrim_name (var_type); 6146 6147 return ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL); 6148 } 6149 6150 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a 6151 valid field number within it, returns 1 iff field FIELD_NUM of TYPE 6152 represents a 'when others' clause; otherwise 0. */ 6153 6154 int 6155 ada_is_others_clause (struct type *type, int field_num) 6156 { 6157 const char *name = TYPE_FIELD_NAME (type, field_num); 6158 6159 return (name != NULL && name[0] == 'O'); 6160 } 6161 6162 /* Assuming that TYPE0 is the type of the variant part of a record, 6163 returns the name of the discriminant controlling the variant. 6164 The value is valid until the next call to ada_variant_discrim_name. */ 6165 6166 char * 6167 ada_variant_discrim_name (struct type *type0) 6168 { 6169 static char *result = NULL; 6170 static size_t result_len = 0; 6171 struct type *type; 6172 const char *name; 6173 const char *discrim_end; 6174 const char *discrim_start; 6175 6176 if (TYPE_CODE (type0) == TYPE_CODE_PTR) 6177 type = TYPE_TARGET_TYPE (type0); 6178 else 6179 type = type0; 6180 6181 name = ada_type_name (type); 6182 6183 if (name == NULL || name[0] == '\000') 6184 return ""; 6185 6186 for (discrim_end = name + strlen (name) - 6; discrim_end != name; 6187 discrim_end -= 1) 6188 { 6189 if (strncmp (discrim_end, "___XVN", 6) == 0) 6190 break; 6191 } 6192 if (discrim_end == name) 6193 return ""; 6194 6195 for (discrim_start = discrim_end; discrim_start != name + 3; 6196 discrim_start -= 1) 6197 { 6198 if (discrim_start == name + 1) 6199 return ""; 6200 if ((discrim_start > name + 3 6201 && strncmp (discrim_start - 3, "___", 3) == 0) 6202 || discrim_start[-1] == '.') 6203 break; 6204 } 6205 6206 GROW_VECT (result, result_len, discrim_end - discrim_start + 1); 6207 strncpy (result, discrim_start, discrim_end - discrim_start); 6208 result[discrim_end - discrim_start] = '\0'; 6209 return result; 6210 } 6211 6212 /* Scan STR for a subtype-encoded number, beginning at position K. 6213 Put the position of the character just past the number scanned in 6214 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL. 6215 Return 1 if there was a valid number at the given position, and 0 6216 otherwise. A "subtype-encoded" number consists of the absolute value 6217 in decimal, followed by the letter 'm' to indicate a negative number. 6218 Assumes 0m does not occur. */ 6219 6220 int 6221 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k) 6222 { 6223 ULONGEST RU; 6224 6225 if (!isdigit (str[k])) 6226 return 0; 6227 6228 /* Do it the hard way so as not to make any assumption about 6229 the relationship of unsigned long (%lu scan format code) and 6230 LONGEST. */ 6231 RU = 0; 6232 while (isdigit (str[k])) 6233 { 6234 RU = RU * 10 + (str[k] - '0'); 6235 k += 1; 6236 } 6237 6238 if (str[k] == 'm') 6239 { 6240 if (R != NULL) 6241 *R = (-(LONGEST) (RU - 1)) - 1; 6242 k += 1; 6243 } 6244 else if (R != NULL) 6245 *R = (LONGEST) RU; 6246 6247 /* NOTE on the above: Technically, C does not say what the results of 6248 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive 6249 number representable as a LONGEST (although either would probably work 6250 in most implementations). When RU>0, the locution in the then branch 6251 above is always equivalent to the negative of RU. */ 6252 6253 if (new_k != NULL) 6254 *new_k = k; 6255 return 1; 6256 } 6257 6258 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field), 6259 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is 6260 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */ 6261 6262 int 6263 ada_in_variant (LONGEST val, struct type *type, int field_num) 6264 { 6265 const char *name = TYPE_FIELD_NAME (type, field_num); 6266 int p; 6267 6268 p = 0; 6269 while (1) 6270 { 6271 switch (name[p]) 6272 { 6273 case '\0': 6274 return 0; 6275 case 'S': 6276 { 6277 LONGEST W; 6278 6279 if (!ada_scan_number (name, p + 1, &W, &p)) 6280 return 0; 6281 if (val == W) 6282 return 1; 6283 break; 6284 } 6285 case 'R': 6286 { 6287 LONGEST L, U; 6288 6289 if (!ada_scan_number (name, p + 1, &L, &p) 6290 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p)) 6291 return 0; 6292 if (val >= L && val <= U) 6293 return 1; 6294 break; 6295 } 6296 case 'O': 6297 return 1; 6298 default: 6299 return 0; 6300 } 6301 } 6302 } 6303 6304 /* FIXME: Lots of redundancy below. Try to consolidate. */ 6305 6306 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type 6307 ARG_TYPE, extract and return the value of one of its (non-static) 6308 fields. FIELDNO says which field. Differs from value_primitive_field 6309 only in that it can handle packed values of arbitrary type. */ 6310 6311 static struct value * 6312 ada_value_primitive_field (struct value *arg1, int offset, int fieldno, 6313 struct type *arg_type) 6314 { 6315 struct type *type; 6316 6317 arg_type = ada_check_typedef (arg_type); 6318 type = TYPE_FIELD_TYPE (arg_type, fieldno); 6319 6320 /* Handle packed fields. */ 6321 6322 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0) 6323 { 6324 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno); 6325 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno); 6326 6327 return ada_value_primitive_packed_val (arg1, value_contents (arg1), 6328 offset + bit_pos / 8, 6329 bit_pos % 8, bit_size, type); 6330 } 6331 else 6332 return value_primitive_field (arg1, offset, fieldno, arg_type); 6333 } 6334 6335 /* Find field with name NAME in object of type TYPE. If found, 6336 set the following for each argument that is non-null: 6337 - *FIELD_TYPE_P to the field's type; 6338 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within 6339 an object of that type; 6340 - *BIT_OFFSET_P to the bit offset modulo byte size of the field; 6341 - *BIT_SIZE_P to its size in bits if the field is packed, and 6342 0 otherwise; 6343 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible 6344 fields up to but not including the desired field, or by the total 6345 number of fields if not found. A NULL value of NAME never 6346 matches; the function just counts visible fields in this case. 6347 6348 Returns 1 if found, 0 otherwise. */ 6349 6350 static int 6351 find_struct_field (char *name, struct type *type, int offset, 6352 struct type **field_type_p, 6353 int *byte_offset_p, int *bit_offset_p, int *bit_size_p, 6354 int *index_p) 6355 { 6356 int i; 6357 6358 type = ada_check_typedef (type); 6359 6360 if (field_type_p != NULL) 6361 *field_type_p = NULL; 6362 if (byte_offset_p != NULL) 6363 *byte_offset_p = 0; 6364 if (bit_offset_p != NULL) 6365 *bit_offset_p = 0; 6366 if (bit_size_p != NULL) 6367 *bit_size_p = 0; 6368 6369 for (i = 0; i < TYPE_NFIELDS (type); i += 1) 6370 { 6371 int bit_pos = TYPE_FIELD_BITPOS (type, i); 6372 int fld_offset = offset + bit_pos / 8; 6373 char *t_field_name = TYPE_FIELD_NAME (type, i); 6374 6375 if (t_field_name == NULL) 6376 continue; 6377 6378 else if (name != NULL && field_name_match (t_field_name, name)) 6379 { 6380 int bit_size = TYPE_FIELD_BITSIZE (type, i); 6381 6382 if (field_type_p != NULL) 6383 *field_type_p = TYPE_FIELD_TYPE (type, i); 6384 if (byte_offset_p != NULL) 6385 *byte_offset_p = fld_offset; 6386 if (bit_offset_p != NULL) 6387 *bit_offset_p = bit_pos % 8; 6388 if (bit_size_p != NULL) 6389 *bit_size_p = bit_size; 6390 return 1; 6391 } 6392 else if (ada_is_wrapper_field (type, i)) 6393 { 6394 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset, 6395 field_type_p, byte_offset_p, bit_offset_p, 6396 bit_size_p, index_p)) 6397 return 1; 6398 } 6399 else if (ada_is_variant_part (type, i)) 6400 { 6401 /* PNH: Wait. Do we ever execute this section, or is ARG always of 6402 fixed type?? */ 6403 int j; 6404 struct type *field_type 6405 = ada_check_typedef (TYPE_FIELD_TYPE (type, i)); 6406 6407 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1) 6408 { 6409 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j), 6410 fld_offset 6411 + TYPE_FIELD_BITPOS (field_type, j) / 8, 6412 field_type_p, byte_offset_p, 6413 bit_offset_p, bit_size_p, index_p)) 6414 return 1; 6415 } 6416 } 6417 else if (index_p != NULL) 6418 *index_p += 1; 6419 } 6420 return 0; 6421 } 6422 6423 /* Number of user-visible fields in record type TYPE. */ 6424 6425 static int 6426 num_visible_fields (struct type *type) 6427 { 6428 int n; 6429 6430 n = 0; 6431 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n); 6432 return n; 6433 } 6434 6435 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes, 6436 and search in it assuming it has (class) type TYPE. 6437 If found, return value, else return NULL. 6438 6439 Searches recursively through wrapper fields (e.g., '_parent'). */ 6440 6441 static struct value * 6442 ada_search_struct_field (char *name, struct value *arg, int offset, 6443 struct type *type) 6444 { 6445 int i; 6446 6447 type = ada_check_typedef (type); 6448 for (i = 0; i < TYPE_NFIELDS (type); i += 1) 6449 { 6450 char *t_field_name = TYPE_FIELD_NAME (type, i); 6451 6452 if (t_field_name == NULL) 6453 continue; 6454 6455 else if (field_name_match (t_field_name, name)) 6456 return ada_value_primitive_field (arg, offset, i, type); 6457 6458 else if (ada_is_wrapper_field (type, i)) 6459 { 6460 struct value *v = /* Do not let indent join lines here. */ 6461 ada_search_struct_field (name, arg, 6462 offset + TYPE_FIELD_BITPOS (type, i) / 8, 6463 TYPE_FIELD_TYPE (type, i)); 6464 6465 if (v != NULL) 6466 return v; 6467 } 6468 6469 else if (ada_is_variant_part (type, i)) 6470 { 6471 /* PNH: Do we ever get here? See find_struct_field. */ 6472 int j; 6473 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, 6474 i)); 6475 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8; 6476 6477 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1) 6478 { 6479 struct value *v = ada_search_struct_field /* Force line 6480 break. */ 6481 (name, arg, 6482 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8, 6483 TYPE_FIELD_TYPE (field_type, j)); 6484 6485 if (v != NULL) 6486 return v; 6487 } 6488 } 6489 } 6490 return NULL; 6491 } 6492 6493 static struct value *ada_index_struct_field_1 (int *, struct value *, 6494 int, struct type *); 6495 6496 6497 /* Return field #INDEX in ARG, where the index is that returned by 6498 * find_struct_field through its INDEX_P argument. Adjust the address 6499 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE. 6500 * If found, return value, else return NULL. */ 6501 6502 static struct value * 6503 ada_index_struct_field (int index, struct value *arg, int offset, 6504 struct type *type) 6505 { 6506 return ada_index_struct_field_1 (&index, arg, offset, type); 6507 } 6508 6509 6510 /* Auxiliary function for ada_index_struct_field. Like 6511 * ada_index_struct_field, but takes index from *INDEX_P and modifies 6512 * *INDEX_P. */ 6513 6514 static struct value * 6515 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset, 6516 struct type *type) 6517 { 6518 int i; 6519 type = ada_check_typedef (type); 6520 6521 for (i = 0; i < TYPE_NFIELDS (type); i += 1) 6522 { 6523 if (TYPE_FIELD_NAME (type, i) == NULL) 6524 continue; 6525 else if (ada_is_wrapper_field (type, i)) 6526 { 6527 struct value *v = /* Do not let indent join lines here. */ 6528 ada_index_struct_field_1 (index_p, arg, 6529 offset + TYPE_FIELD_BITPOS (type, i) / 8, 6530 TYPE_FIELD_TYPE (type, i)); 6531 6532 if (v != NULL) 6533 return v; 6534 } 6535 6536 else if (ada_is_variant_part (type, i)) 6537 { 6538 /* PNH: Do we ever get here? See ada_search_struct_field, 6539 find_struct_field. */ 6540 error (_("Cannot assign this kind of variant record")); 6541 } 6542 else if (*index_p == 0) 6543 return ada_value_primitive_field (arg, offset, i, type); 6544 else 6545 *index_p -= 1; 6546 } 6547 return NULL; 6548 } 6549 6550 /* Given ARG, a value of type (pointer or reference to a)* 6551 structure/union, extract the component named NAME from the ultimate 6552 target structure/union and return it as a value with its 6553 appropriate type. 6554 6555 The routine searches for NAME among all members of the structure itself 6556 and (recursively) among all members of any wrapper members 6557 (e.g., '_parent'). 6558 6559 If NO_ERR, then simply return NULL in case of error, rather than 6560 calling error. */ 6561 6562 struct value * 6563 ada_value_struct_elt (struct value *arg, char *name, int no_err) 6564 { 6565 struct type *t, *t1; 6566 struct value *v; 6567 6568 v = NULL; 6569 t1 = t = ada_check_typedef (value_type (arg)); 6570 if (TYPE_CODE (t) == TYPE_CODE_REF) 6571 { 6572 t1 = TYPE_TARGET_TYPE (t); 6573 if (t1 == NULL) 6574 goto BadValue; 6575 t1 = ada_check_typedef (t1); 6576 if (TYPE_CODE (t1) == TYPE_CODE_PTR) 6577 { 6578 arg = coerce_ref (arg); 6579 t = t1; 6580 } 6581 } 6582 6583 while (TYPE_CODE (t) == TYPE_CODE_PTR) 6584 { 6585 t1 = TYPE_TARGET_TYPE (t); 6586 if (t1 == NULL) 6587 goto BadValue; 6588 t1 = ada_check_typedef (t1); 6589 if (TYPE_CODE (t1) == TYPE_CODE_PTR) 6590 { 6591 arg = value_ind (arg); 6592 t = t1; 6593 } 6594 else 6595 break; 6596 } 6597 6598 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION) 6599 goto BadValue; 6600 6601 if (t1 == t) 6602 v = ada_search_struct_field (name, arg, 0, t); 6603 else 6604 { 6605 int bit_offset, bit_size, byte_offset; 6606 struct type *field_type; 6607 CORE_ADDR address; 6608 6609 if (TYPE_CODE (t) == TYPE_CODE_PTR) 6610 address = value_as_address (arg); 6611 else 6612 address = unpack_pointer (t, value_contents (arg)); 6613 6614 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1); 6615 if (find_struct_field (name, t1, 0, 6616 &field_type, &byte_offset, &bit_offset, 6617 &bit_size, NULL)) 6618 { 6619 if (bit_size != 0) 6620 { 6621 if (TYPE_CODE (t) == TYPE_CODE_REF) 6622 arg = ada_coerce_ref (arg); 6623 else 6624 arg = ada_value_ind (arg); 6625 v = ada_value_primitive_packed_val (arg, NULL, byte_offset, 6626 bit_offset, bit_size, 6627 field_type); 6628 } 6629 else 6630 v = value_at_lazy (field_type, address + byte_offset); 6631 } 6632 } 6633 6634 if (v != NULL || no_err) 6635 return v; 6636 else 6637 error (_("There is no member named %s."), name); 6638 6639 BadValue: 6640 if (no_err) 6641 return NULL; 6642 else 6643 error (_("Attempt to extract a component of " 6644 "a value that is not a record.")); 6645 } 6646 6647 /* Given a type TYPE, look up the type of the component of type named NAME. 6648 If DISPP is non-null, add its byte displacement from the beginning of a 6649 structure (pointed to by a value) of type TYPE to *DISPP (does not 6650 work for packed fields). 6651 6652 Matches any field whose name has NAME as a prefix, possibly 6653 followed by "___". 6654 6655 TYPE can be either a struct or union. If REFOK, TYPE may also 6656 be a (pointer or reference)+ to a struct or union, and the 6657 ultimate target type will be searched. 6658 6659 Looks recursively into variant clauses and parent types. 6660 6661 If NOERR is nonzero, return NULL if NAME is not suitably defined or 6662 TYPE is not a type of the right kind. */ 6663 6664 static struct type * 6665 ada_lookup_struct_elt_type (struct type *type, char *name, int refok, 6666 int noerr, int *dispp) 6667 { 6668 int i; 6669 6670 if (name == NULL) 6671 goto BadName; 6672 6673 if (refok && type != NULL) 6674 while (1) 6675 { 6676 type = ada_check_typedef (type); 6677 if (TYPE_CODE (type) != TYPE_CODE_PTR 6678 && TYPE_CODE (type) != TYPE_CODE_REF) 6679 break; 6680 type = TYPE_TARGET_TYPE (type); 6681 } 6682 6683 if (type == NULL 6684 || (TYPE_CODE (type) != TYPE_CODE_STRUCT 6685 && TYPE_CODE (type) != TYPE_CODE_UNION)) 6686 { 6687 if (noerr) 6688 return NULL; 6689 else 6690 { 6691 target_terminal_ours (); 6692 gdb_flush (gdb_stdout); 6693 if (type == NULL) 6694 error (_("Type (null) is not a structure or union type")); 6695 else 6696 { 6697 /* XXX: type_sprint */ 6698 fprintf_unfiltered (gdb_stderr, _("Type ")); 6699 type_print (type, "", gdb_stderr, -1); 6700 error (_(" is not a structure or union type")); 6701 } 6702 } 6703 } 6704 6705 type = to_static_fixed_type (type); 6706 6707 for (i = 0; i < TYPE_NFIELDS (type); i += 1) 6708 { 6709 char *t_field_name = TYPE_FIELD_NAME (type, i); 6710 struct type *t; 6711 int disp; 6712 6713 if (t_field_name == NULL) 6714 continue; 6715 6716 else if (field_name_match (t_field_name, name)) 6717 { 6718 if (dispp != NULL) 6719 *dispp += TYPE_FIELD_BITPOS (type, i) / 8; 6720 return ada_check_typedef (TYPE_FIELD_TYPE (type, i)); 6721 } 6722 6723 else if (ada_is_wrapper_field (type, i)) 6724 { 6725 disp = 0; 6726 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name, 6727 0, 1, &disp); 6728 if (t != NULL) 6729 { 6730 if (dispp != NULL) 6731 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8; 6732 return t; 6733 } 6734 } 6735 6736 else if (ada_is_variant_part (type, i)) 6737 { 6738 int j; 6739 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, 6740 i)); 6741 6742 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1) 6743 { 6744 /* FIXME pnh 2008/01/26: We check for a field that is 6745 NOT wrapped in a struct, since the compiler sometimes 6746 generates these for unchecked variant types. Revisit 6747 if the compiler changes this practice. */ 6748 char *v_field_name = TYPE_FIELD_NAME (field_type, j); 6749 disp = 0; 6750 if (v_field_name != NULL 6751 && field_name_match (v_field_name, name)) 6752 t = ada_check_typedef (TYPE_FIELD_TYPE (field_type, j)); 6753 else 6754 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type, 6755 j), 6756 name, 0, 1, &disp); 6757 6758 if (t != NULL) 6759 { 6760 if (dispp != NULL) 6761 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8; 6762 return t; 6763 } 6764 } 6765 } 6766 6767 } 6768 6769 BadName: 6770 if (!noerr) 6771 { 6772 target_terminal_ours (); 6773 gdb_flush (gdb_stdout); 6774 if (name == NULL) 6775 { 6776 /* XXX: type_sprint */ 6777 fprintf_unfiltered (gdb_stderr, _("Type ")); 6778 type_print (type, "", gdb_stderr, -1); 6779 error (_(" has no component named <null>")); 6780 } 6781 else 6782 { 6783 /* XXX: type_sprint */ 6784 fprintf_unfiltered (gdb_stderr, _("Type ")); 6785 type_print (type, "", gdb_stderr, -1); 6786 error (_(" has no component named %s"), name); 6787 } 6788 } 6789 6790 return NULL; 6791 } 6792 6793 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union), 6794 within a value of type OUTER_TYPE, return true iff VAR_TYPE 6795 represents an unchecked union (that is, the variant part of a 6796 record that is named in an Unchecked_Union pragma). */ 6797 6798 static int 6799 is_unchecked_variant (struct type *var_type, struct type *outer_type) 6800 { 6801 char *discrim_name = ada_variant_discrim_name (var_type); 6802 6803 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL) 6804 == NULL); 6805 } 6806 6807 6808 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union), 6809 within a value of type OUTER_TYPE that is stored in GDB at 6810 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE, 6811 numbering from 0) is applicable. Returns -1 if none are. */ 6812 6813 int 6814 ada_which_variant_applies (struct type *var_type, struct type *outer_type, 6815 const gdb_byte *outer_valaddr) 6816 { 6817 int others_clause; 6818 int i; 6819 char *discrim_name = ada_variant_discrim_name (var_type); 6820 struct value *outer; 6821 struct value *discrim; 6822 LONGEST discrim_val; 6823 6824 outer = value_from_contents_and_address (outer_type, outer_valaddr, 0); 6825 discrim = ada_value_struct_elt (outer, discrim_name, 1); 6826 if (discrim == NULL) 6827 return -1; 6828 discrim_val = value_as_long (discrim); 6829 6830 others_clause = -1; 6831 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1) 6832 { 6833 if (ada_is_others_clause (var_type, i)) 6834 others_clause = i; 6835 else if (ada_in_variant (discrim_val, var_type, i)) 6836 return i; 6837 } 6838 6839 return others_clause; 6840 } 6841 6842 6843 6844 /* Dynamic-Sized Records */ 6845 6846 /* Strategy: The type ostensibly attached to a value with dynamic size 6847 (i.e., a size that is not statically recorded in the debugging 6848 data) does not accurately reflect the size or layout of the value. 6849 Our strategy is to convert these values to values with accurate, 6850 conventional types that are constructed on the fly. */ 6851 6852 /* There is a subtle and tricky problem here. In general, we cannot 6853 determine the size of dynamic records without its data. However, 6854 the 'struct value' data structure, which GDB uses to represent 6855 quantities in the inferior process (the target), requires the size 6856 of the type at the time of its allocation in order to reserve space 6857 for GDB's internal copy of the data. That's why the 6858 'to_fixed_xxx_type' routines take (target) addresses as parameters, 6859 rather than struct value*s. 6860 6861 However, GDB's internal history variables ($1, $2, etc.) are 6862 struct value*s containing internal copies of the data that are not, in 6863 general, the same as the data at their corresponding addresses in 6864 the target. Fortunately, the types we give to these values are all 6865 conventional, fixed-size types (as per the strategy described 6866 above), so that we don't usually have to perform the 6867 'to_fixed_xxx_type' conversions to look at their values. 6868 Unfortunately, there is one exception: if one of the internal 6869 history variables is an array whose elements are unconstrained 6870 records, then we will need to create distinct fixed types for each 6871 element selected. */ 6872 6873 /* The upshot of all of this is that many routines take a (type, host 6874 address, target address) triple as arguments to represent a value. 6875 The host address, if non-null, is supposed to contain an internal 6876 copy of the relevant data; otherwise, the program is to consult the 6877 target at the target address. */ 6878 6879 /* Assuming that VAL0 represents a pointer value, the result of 6880 dereferencing it. Differs from value_ind in its treatment of 6881 dynamic-sized types. */ 6882 6883 struct value * 6884 ada_value_ind (struct value *val0) 6885 { 6886 struct value *val = unwrap_value (value_ind (val0)); 6887 6888 return ada_to_fixed_value (val); 6889 } 6890 6891 /* The value resulting from dereferencing any "reference to" 6892 qualifiers on VAL0. */ 6893 6894 static struct value * 6895 ada_coerce_ref (struct value *val0) 6896 { 6897 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF) 6898 { 6899 struct value *val = val0; 6900 6901 val = coerce_ref (val); 6902 val = unwrap_value (val); 6903 return ada_to_fixed_value (val); 6904 } 6905 else 6906 return val0; 6907 } 6908 6909 /* Return OFF rounded upward if necessary to a multiple of 6910 ALIGNMENT (a power of 2). */ 6911 6912 static unsigned int 6913 align_value (unsigned int off, unsigned int alignment) 6914 { 6915 return (off + alignment - 1) & ~(alignment - 1); 6916 } 6917 6918 /* Return the bit alignment required for field #F of template type TYPE. */ 6919 6920 static unsigned int 6921 field_alignment (struct type *type, int f) 6922 { 6923 const char *name = TYPE_FIELD_NAME (type, f); 6924 int len; 6925 int align_offset; 6926 6927 /* The field name should never be null, unless the debugging information 6928 is somehow malformed. In this case, we assume the field does not 6929 require any alignment. */ 6930 if (name == NULL) 6931 return 1; 6932 6933 len = strlen (name); 6934 6935 if (!isdigit (name[len - 1])) 6936 return 1; 6937 6938 if (isdigit (name[len - 2])) 6939 align_offset = len - 2; 6940 else 6941 align_offset = len - 1; 6942 6943 if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0) 6944 return TARGET_CHAR_BIT; 6945 6946 return atoi (name + align_offset) * TARGET_CHAR_BIT; 6947 } 6948 6949 /* Find a symbol named NAME. Ignores ambiguity. */ 6950 6951 struct symbol * 6952 ada_find_any_symbol (const char *name) 6953 { 6954 struct symbol *sym; 6955 6956 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN); 6957 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF) 6958 return sym; 6959 6960 sym = standard_lookup (name, NULL, STRUCT_DOMAIN); 6961 return sym; 6962 } 6963 6964 /* Find a type named NAME. Ignores ambiguity. This routine will look 6965 solely for types defined by debug info, it will not search the GDB 6966 primitive types. */ 6967 6968 struct type * 6969 ada_find_any_type (const char *name) 6970 { 6971 struct symbol *sym = ada_find_any_symbol (name); 6972 6973 if (sym != NULL) 6974 return SYMBOL_TYPE (sym); 6975 6976 return NULL; 6977 } 6978 6979 /* Given NAME and an associated BLOCK, search all symbols for 6980 NAME suffixed with "___XR", which is the ``renaming'' symbol 6981 associated to NAME. Return this symbol if found, return 6982 NULL otherwise. */ 6983 6984 struct symbol * 6985 ada_find_renaming_symbol (const char *name, struct block *block) 6986 { 6987 struct symbol *sym; 6988 6989 sym = find_old_style_renaming_symbol (name, block); 6990 6991 if (sym != NULL) 6992 return sym; 6993 6994 /* Not right yet. FIXME pnh 7/20/2007. */ 6995 sym = ada_find_any_symbol (name); 6996 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL) 6997 return sym; 6998 else 6999 return NULL; 7000 } 7001 7002 static struct symbol * 7003 find_old_style_renaming_symbol (const char *name, struct block *block) 7004 { 7005 const struct symbol *function_sym = block_linkage_function (block); 7006 char *rename; 7007 7008 if (function_sym != NULL) 7009 { 7010 /* If the symbol is defined inside a function, NAME is not fully 7011 qualified. This means we need to prepend the function name 7012 as well as adding the ``___XR'' suffix to build the name of 7013 the associated renaming symbol. */ 7014 char *function_name = SYMBOL_LINKAGE_NAME (function_sym); 7015 /* Function names sometimes contain suffixes used 7016 for instance to qualify nested subprograms. When building 7017 the XR type name, we need to make sure that this suffix is 7018 not included. So do not include any suffix in the function 7019 name length below. */ 7020 int function_name_len = ada_name_prefix_len (function_name); 7021 const int rename_len = function_name_len + 2 /* "__" */ 7022 + strlen (name) + 6 /* "___XR\0" */ ; 7023 7024 /* Strip the suffix if necessary. */ 7025 ada_remove_trailing_digits (function_name, &function_name_len); 7026 ada_remove_po_subprogram_suffix (function_name, &function_name_len); 7027 ada_remove_Xbn_suffix (function_name, &function_name_len); 7028 7029 /* Library-level functions are a special case, as GNAT adds 7030 a ``_ada_'' prefix to the function name to avoid namespace 7031 pollution. However, the renaming symbols themselves do not 7032 have this prefix, so we need to skip this prefix if present. */ 7033 if (function_name_len > 5 /* "_ada_" */ 7034 && strstr (function_name, "_ada_") == function_name) 7035 { 7036 function_name += 5; 7037 function_name_len -= 5; 7038 } 7039 7040 rename = (char *) alloca (rename_len * sizeof (char)); 7041 strncpy (rename, function_name, function_name_len); 7042 xsnprintf (rename + function_name_len, rename_len - function_name_len, 7043 "__%s___XR", name); 7044 } 7045 else 7046 { 7047 const int rename_len = strlen (name) + 6; 7048 7049 rename = (char *) alloca (rename_len * sizeof (char)); 7050 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name); 7051 } 7052 7053 return ada_find_any_symbol (rename); 7054 } 7055 7056 /* Because of GNAT encoding conventions, several GDB symbols may match a 7057 given type name. If the type denoted by TYPE0 is to be preferred to 7058 that of TYPE1 for purposes of type printing, return non-zero; 7059 otherwise return 0. */ 7060 7061 int 7062 ada_prefer_type (struct type *type0, struct type *type1) 7063 { 7064 if (type1 == NULL) 7065 return 1; 7066 else if (type0 == NULL) 7067 return 0; 7068 else if (TYPE_CODE (type1) == TYPE_CODE_VOID) 7069 return 1; 7070 else if (TYPE_CODE (type0) == TYPE_CODE_VOID) 7071 return 0; 7072 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL) 7073 return 1; 7074 else if (ada_is_constrained_packed_array_type (type0)) 7075 return 1; 7076 else if (ada_is_array_descriptor_type (type0) 7077 && !ada_is_array_descriptor_type (type1)) 7078 return 1; 7079 else 7080 { 7081 const char *type0_name = type_name_no_tag (type0); 7082 const char *type1_name = type_name_no_tag (type1); 7083 7084 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL 7085 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL)) 7086 return 1; 7087 } 7088 return 0; 7089 } 7090 7091 /* The name of TYPE, which is either its TYPE_NAME, or, if that is 7092 null, its TYPE_TAG_NAME. Null if TYPE is null. */ 7093 7094 char * 7095 ada_type_name (struct type *type) 7096 { 7097 if (type == NULL) 7098 return NULL; 7099 else if (TYPE_NAME (type) != NULL) 7100 return TYPE_NAME (type); 7101 else 7102 return TYPE_TAG_NAME (type); 7103 } 7104 7105 /* Search the list of "descriptive" types associated to TYPE for a type 7106 whose name is NAME. */ 7107 7108 static struct type * 7109 find_parallel_type_by_descriptive_type (struct type *type, const char *name) 7110 { 7111 struct type *result; 7112 7113 /* If there no descriptive-type info, then there is no parallel type 7114 to be found. */ 7115 if (!HAVE_GNAT_AUX_INFO (type)) 7116 return NULL; 7117 7118 result = TYPE_DESCRIPTIVE_TYPE (type); 7119 while (result != NULL) 7120 { 7121 char *result_name = ada_type_name (result); 7122 7123 if (result_name == NULL) 7124 { 7125 warning (_("unexpected null name on descriptive type")); 7126 return NULL; 7127 } 7128 7129 /* If the names match, stop. */ 7130 if (strcmp (result_name, name) == 0) 7131 break; 7132 7133 /* Otherwise, look at the next item on the list, if any. */ 7134 if (HAVE_GNAT_AUX_INFO (result)) 7135 result = TYPE_DESCRIPTIVE_TYPE (result); 7136 else 7137 result = NULL; 7138 } 7139 7140 /* If we didn't find a match, see whether this is a packed array. With 7141 older compilers, the descriptive type information is either absent or 7142 irrelevant when it comes to packed arrays so the above lookup fails. 7143 Fall back to using a parallel lookup by name in this case. */ 7144 if (result == NULL && ada_is_constrained_packed_array_type (type)) 7145 return ada_find_any_type (name); 7146 7147 return result; 7148 } 7149 7150 /* Find a parallel type to TYPE with the specified NAME, using the 7151 descriptive type taken from the debugging information, if available, 7152 and otherwise using the (slower) name-based method. */ 7153 7154 static struct type * 7155 ada_find_parallel_type_with_name (struct type *type, const char *name) 7156 { 7157 struct type *result = NULL; 7158 7159 if (HAVE_GNAT_AUX_INFO (type)) 7160 result = find_parallel_type_by_descriptive_type (type, name); 7161 else 7162 result = ada_find_any_type (name); 7163 7164 return result; 7165 } 7166 7167 /* Same as above, but specify the name of the parallel type by appending 7168 SUFFIX to the name of TYPE. */ 7169 7170 struct type * 7171 ada_find_parallel_type (struct type *type, const char *suffix) 7172 { 7173 char *name, *typename = ada_type_name (type); 7174 int len; 7175 7176 if (typename == NULL) 7177 return NULL; 7178 7179 len = strlen (typename); 7180 7181 name = (char *) alloca (len + strlen (suffix) + 1); 7182 7183 strcpy (name, typename); 7184 strcpy (name + len, suffix); 7185 7186 return ada_find_parallel_type_with_name (type, name); 7187 } 7188 7189 /* If TYPE is a variable-size record type, return the corresponding template 7190 type describing its fields. Otherwise, return NULL. */ 7191 7192 static struct type * 7193 dynamic_template_type (struct type *type) 7194 { 7195 type = ada_check_typedef (type); 7196 7197 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT 7198 || ada_type_name (type) == NULL) 7199 return NULL; 7200 else 7201 { 7202 int len = strlen (ada_type_name (type)); 7203 7204 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0) 7205 return type; 7206 else 7207 return ada_find_parallel_type (type, "___XVE"); 7208 } 7209 } 7210 7211 /* Assuming that TEMPL_TYPE is a union or struct type, returns 7212 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */ 7213 7214 static int 7215 is_dynamic_field (struct type *templ_type, int field_num) 7216 { 7217 const char *name = TYPE_FIELD_NAME (templ_type, field_num); 7218 7219 return name != NULL 7220 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR 7221 && strstr (name, "___XVL") != NULL; 7222 } 7223 7224 /* The index of the variant field of TYPE, or -1 if TYPE does not 7225 represent a variant record type. */ 7226 7227 static int 7228 variant_field_index (struct type *type) 7229 { 7230 int f; 7231 7232 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT) 7233 return -1; 7234 7235 for (f = 0; f < TYPE_NFIELDS (type); f += 1) 7236 { 7237 if (ada_is_variant_part (type, f)) 7238 return f; 7239 } 7240 return -1; 7241 } 7242 7243 /* A record type with no fields. */ 7244 7245 static struct type * 7246 empty_record (struct type *template) 7247 { 7248 struct type *type = alloc_type_copy (template); 7249 7250 TYPE_CODE (type) = TYPE_CODE_STRUCT; 7251 TYPE_NFIELDS (type) = 0; 7252 TYPE_FIELDS (type) = NULL; 7253 INIT_CPLUS_SPECIFIC (type); 7254 TYPE_NAME (type) = "<empty>"; 7255 TYPE_TAG_NAME (type) = NULL; 7256 TYPE_LENGTH (type) = 0; 7257 return type; 7258 } 7259 7260 /* An ordinary record type (with fixed-length fields) that describes 7261 the value of type TYPE at VALADDR or ADDRESS (see comments at 7262 the beginning of this section) VAL according to GNAT conventions. 7263 DVAL0 should describe the (portion of a) record that contains any 7264 necessary discriminants. It should be NULL if value_type (VAL) is 7265 an outer-level type (i.e., as opposed to a branch of a variant.) A 7266 variant field (unless unchecked) is replaced by a particular branch 7267 of the variant. 7268 7269 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or 7270 length are not statically known are discarded. As a consequence, 7271 VALADDR, ADDRESS and DVAL0 are ignored. 7272 7273 NOTE: Limitations: For now, we assume that dynamic fields and 7274 variants occupy whole numbers of bytes. However, they need not be 7275 byte-aligned. */ 7276 7277 struct type * 7278 ada_template_to_fixed_record_type_1 (struct type *type, 7279 const gdb_byte *valaddr, 7280 CORE_ADDR address, struct value *dval0, 7281 int keep_dynamic_fields) 7282 { 7283 struct value *mark = value_mark (); 7284 struct value *dval; 7285 struct type *rtype; 7286 int nfields, bit_len; 7287 int variant_field; 7288 long off; 7289 int fld_bit_len; 7290 int f; 7291 7292 /* Compute the number of fields in this record type that are going 7293 to be processed: unless keep_dynamic_fields, this includes only 7294 fields whose position and length are static will be processed. */ 7295 if (keep_dynamic_fields) 7296 nfields = TYPE_NFIELDS (type); 7297 else 7298 { 7299 nfields = 0; 7300 while (nfields < TYPE_NFIELDS (type) 7301 && !ada_is_variant_part (type, nfields) 7302 && !is_dynamic_field (type, nfields)) 7303 nfields++; 7304 } 7305 7306 rtype = alloc_type_copy (type); 7307 TYPE_CODE (rtype) = TYPE_CODE_STRUCT; 7308 INIT_CPLUS_SPECIFIC (rtype); 7309 TYPE_NFIELDS (rtype) = nfields; 7310 TYPE_FIELDS (rtype) = (struct field *) 7311 TYPE_ALLOC (rtype, nfields * sizeof (struct field)); 7312 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields); 7313 TYPE_NAME (rtype) = ada_type_name (type); 7314 TYPE_TAG_NAME (rtype) = NULL; 7315 TYPE_FIXED_INSTANCE (rtype) = 1; 7316 7317 off = 0; 7318 bit_len = 0; 7319 variant_field = -1; 7320 7321 for (f = 0; f < nfields; f += 1) 7322 { 7323 off = align_value (off, field_alignment (type, f)) 7324 + TYPE_FIELD_BITPOS (type, f); 7325 TYPE_FIELD_BITPOS (rtype, f) = off; 7326 TYPE_FIELD_BITSIZE (rtype, f) = 0; 7327 7328 if (ada_is_variant_part (type, f)) 7329 { 7330 variant_field = f; 7331 fld_bit_len = 0; 7332 } 7333 else if (is_dynamic_field (type, f)) 7334 { 7335 const gdb_byte *field_valaddr = valaddr; 7336 CORE_ADDR field_address = address; 7337 struct type *field_type = 7338 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f)); 7339 7340 if (dval0 == NULL) 7341 { 7342 /* rtype's length is computed based on the run-time 7343 value of discriminants. If the discriminants are not 7344 initialized, the type size may be completely bogus and 7345 GDB may fail to allocate a value for it. So check the 7346 size first before creating the value. */ 7347 check_size (rtype); 7348 dval = value_from_contents_and_address (rtype, valaddr, address); 7349 } 7350 else 7351 dval = dval0; 7352 7353 /* If the type referenced by this field is an aligner type, we need 7354 to unwrap that aligner type, because its size might not be set. 7355 Keeping the aligner type would cause us to compute the wrong 7356 size for this field, impacting the offset of the all the fields 7357 that follow this one. */ 7358 if (ada_is_aligner_type (field_type)) 7359 { 7360 long field_offset = TYPE_FIELD_BITPOS (field_type, f); 7361 7362 field_valaddr = cond_offset_host (field_valaddr, field_offset); 7363 field_address = cond_offset_target (field_address, field_offset); 7364 field_type = ada_aligned_type (field_type); 7365 } 7366 7367 field_valaddr = cond_offset_host (field_valaddr, 7368 off / TARGET_CHAR_BIT); 7369 field_address = cond_offset_target (field_address, 7370 off / TARGET_CHAR_BIT); 7371 7372 /* Get the fixed type of the field. Note that, in this case, 7373 we do not want to get the real type out of the tag: if 7374 the current field is the parent part of a tagged record, 7375 we will get the tag of the object. Clearly wrong: the real 7376 type of the parent is not the real type of the child. We 7377 would end up in an infinite loop. */ 7378 field_type = ada_get_base_type (field_type); 7379 field_type = ada_to_fixed_type (field_type, field_valaddr, 7380 field_address, dval, 0); 7381 /* If the field size is already larger than the maximum 7382 object size, then the record itself will necessarily 7383 be larger than the maximum object size. We need to make 7384 this check now, because the size might be so ridiculously 7385 large (due to an uninitialized variable in the inferior) 7386 that it would cause an overflow when adding it to the 7387 record size. */ 7388 check_size (field_type); 7389 7390 TYPE_FIELD_TYPE (rtype, f) = field_type; 7391 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f); 7392 /* The multiplication can potentially overflow. But because 7393 the field length has been size-checked just above, and 7394 assuming that the maximum size is a reasonable value, 7395 an overflow should not happen in practice. So rather than 7396 adding overflow recovery code to this already complex code, 7397 we just assume that it's not going to happen. */ 7398 fld_bit_len = 7399 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT; 7400 } 7401 else 7402 { 7403 struct type *field_type = TYPE_FIELD_TYPE (type, f); 7404 7405 /* If our field is a typedef type (most likely a typedef of 7406 a fat pointer, encoding an array access), then we need to 7407 look at its target type to determine its characteristics. 7408 In particular, we would miscompute the field size if we took 7409 the size of the typedef (zero), instead of the size of 7410 the target type. */ 7411 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF) 7412 field_type = ada_typedef_target_type (field_type); 7413 7414 TYPE_FIELD_TYPE (rtype, f) = field_type; 7415 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f); 7416 if (TYPE_FIELD_BITSIZE (type, f) > 0) 7417 fld_bit_len = 7418 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f); 7419 else 7420 fld_bit_len = 7421 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT; 7422 } 7423 if (off + fld_bit_len > bit_len) 7424 bit_len = off + fld_bit_len; 7425 off += fld_bit_len; 7426 TYPE_LENGTH (rtype) = 7427 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT; 7428 } 7429 7430 /* We handle the variant part, if any, at the end because of certain 7431 odd cases in which it is re-ordered so as NOT to be the last field of 7432 the record. This can happen in the presence of representation 7433 clauses. */ 7434 if (variant_field >= 0) 7435 { 7436 struct type *branch_type; 7437 7438 off = TYPE_FIELD_BITPOS (rtype, variant_field); 7439 7440 if (dval0 == NULL) 7441 dval = value_from_contents_and_address (rtype, valaddr, address); 7442 else 7443 dval = dval0; 7444 7445 branch_type = 7446 to_fixed_variant_branch_type 7447 (TYPE_FIELD_TYPE (type, variant_field), 7448 cond_offset_host (valaddr, off / TARGET_CHAR_BIT), 7449 cond_offset_target (address, off / TARGET_CHAR_BIT), dval); 7450 if (branch_type == NULL) 7451 { 7452 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1) 7453 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f]; 7454 TYPE_NFIELDS (rtype) -= 1; 7455 } 7456 else 7457 { 7458 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type; 7459 TYPE_FIELD_NAME (rtype, variant_field) = "S"; 7460 fld_bit_len = 7461 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) * 7462 TARGET_CHAR_BIT; 7463 if (off + fld_bit_len > bit_len) 7464 bit_len = off + fld_bit_len; 7465 TYPE_LENGTH (rtype) = 7466 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT; 7467 } 7468 } 7469 7470 /* According to exp_dbug.ads, the size of TYPE for variable-size records 7471 should contain the alignment of that record, which should be a strictly 7472 positive value. If null or negative, then something is wrong, most 7473 probably in the debug info. In that case, we don't round up the size 7474 of the resulting type. If this record is not part of another structure, 7475 the current RTYPE length might be good enough for our purposes. */ 7476 if (TYPE_LENGTH (type) <= 0) 7477 { 7478 if (TYPE_NAME (rtype)) 7479 warning (_("Invalid type size for `%s' detected: %d."), 7480 TYPE_NAME (rtype), TYPE_LENGTH (type)); 7481 else 7482 warning (_("Invalid type size for <unnamed> detected: %d."), 7483 TYPE_LENGTH (type)); 7484 } 7485 else 7486 { 7487 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype), 7488 TYPE_LENGTH (type)); 7489 } 7490 7491 value_free_to_mark (mark); 7492 if (TYPE_LENGTH (rtype) > varsize_limit) 7493 error (_("record type with dynamic size is larger than varsize-limit")); 7494 return rtype; 7495 } 7496 7497 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS 7498 of 1. */ 7499 7500 static struct type * 7501 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr, 7502 CORE_ADDR address, struct value *dval0) 7503 { 7504 return ada_template_to_fixed_record_type_1 (type, valaddr, 7505 address, dval0, 1); 7506 } 7507 7508 /* An ordinary record type in which ___XVL-convention fields and 7509 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with 7510 static approximations, containing all possible fields. Uses 7511 no runtime values. Useless for use in values, but that's OK, 7512 since the results are used only for type determinations. Works on both 7513 structs and unions. Representation note: to save space, we memorize 7514 the result of this function in the TYPE_TARGET_TYPE of the 7515 template type. */ 7516 7517 static struct type * 7518 template_to_static_fixed_type (struct type *type0) 7519 { 7520 struct type *type; 7521 int nfields; 7522 int f; 7523 7524 if (TYPE_TARGET_TYPE (type0) != NULL) 7525 return TYPE_TARGET_TYPE (type0); 7526 7527 nfields = TYPE_NFIELDS (type0); 7528 type = type0; 7529 7530 for (f = 0; f < nfields; f += 1) 7531 { 7532 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type0, f)); 7533 struct type *new_type; 7534 7535 if (is_dynamic_field (type0, f)) 7536 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type)); 7537 else 7538 new_type = static_unwrap_type (field_type); 7539 if (type == type0 && new_type != field_type) 7540 { 7541 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0); 7542 TYPE_CODE (type) = TYPE_CODE (type0); 7543 INIT_CPLUS_SPECIFIC (type); 7544 TYPE_NFIELDS (type) = nfields; 7545 TYPE_FIELDS (type) = (struct field *) 7546 TYPE_ALLOC (type, nfields * sizeof (struct field)); 7547 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0), 7548 sizeof (struct field) * nfields); 7549 TYPE_NAME (type) = ada_type_name (type0); 7550 TYPE_TAG_NAME (type) = NULL; 7551 TYPE_FIXED_INSTANCE (type) = 1; 7552 TYPE_LENGTH (type) = 0; 7553 } 7554 TYPE_FIELD_TYPE (type, f) = new_type; 7555 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f); 7556 } 7557 return type; 7558 } 7559 7560 /* Given an object of type TYPE whose contents are at VALADDR and 7561 whose address in memory is ADDRESS, returns a revision of TYPE, 7562 which should be a non-dynamic-sized record, in which the variant 7563 part, if any, is replaced with the appropriate branch. Looks 7564 for discriminant values in DVAL0, which can be NULL if the record 7565 contains the necessary discriminant values. */ 7566 7567 static struct type * 7568 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr, 7569 CORE_ADDR address, struct value *dval0) 7570 { 7571 struct value *mark = value_mark (); 7572 struct value *dval; 7573 struct type *rtype; 7574 struct type *branch_type; 7575 int nfields = TYPE_NFIELDS (type); 7576 int variant_field = variant_field_index (type); 7577 7578 if (variant_field == -1) 7579 return type; 7580 7581 if (dval0 == NULL) 7582 dval = value_from_contents_and_address (type, valaddr, address); 7583 else 7584 dval = dval0; 7585 7586 rtype = alloc_type_copy (type); 7587 TYPE_CODE (rtype) = TYPE_CODE_STRUCT; 7588 INIT_CPLUS_SPECIFIC (rtype); 7589 TYPE_NFIELDS (rtype) = nfields; 7590 TYPE_FIELDS (rtype) = 7591 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field)); 7592 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type), 7593 sizeof (struct field) * nfields); 7594 TYPE_NAME (rtype) = ada_type_name (type); 7595 TYPE_TAG_NAME (rtype) = NULL; 7596 TYPE_FIXED_INSTANCE (rtype) = 1; 7597 TYPE_LENGTH (rtype) = TYPE_LENGTH (type); 7598 7599 branch_type = to_fixed_variant_branch_type 7600 (TYPE_FIELD_TYPE (type, variant_field), 7601 cond_offset_host (valaddr, 7602 TYPE_FIELD_BITPOS (type, variant_field) 7603 / TARGET_CHAR_BIT), 7604 cond_offset_target (address, 7605 TYPE_FIELD_BITPOS (type, variant_field) 7606 / TARGET_CHAR_BIT), dval); 7607 if (branch_type == NULL) 7608 { 7609 int f; 7610 7611 for (f = variant_field + 1; f < nfields; f += 1) 7612 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f]; 7613 TYPE_NFIELDS (rtype) -= 1; 7614 } 7615 else 7616 { 7617 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type; 7618 TYPE_FIELD_NAME (rtype, variant_field) = "S"; 7619 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0; 7620 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type); 7621 } 7622 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field)); 7623 7624 value_free_to_mark (mark); 7625 return rtype; 7626 } 7627 7628 /* An ordinary record type (with fixed-length fields) that describes 7629 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at 7630 beginning of this section]. Any necessary discriminants' values 7631 should be in DVAL, a record value; it may be NULL if the object 7632 at ADDR itself contains any necessary discriminant values. 7633 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant 7634 values from the record are needed. Except in the case that DVAL, 7635 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless 7636 unchecked) is replaced by a particular branch of the variant. 7637 7638 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0 7639 is questionable and may be removed. It can arise during the 7640 processing of an unconstrained-array-of-record type where all the 7641 variant branches have exactly the same size. This is because in 7642 such cases, the compiler does not bother to use the XVS convention 7643 when encoding the record. I am currently dubious of this 7644 shortcut and suspect the compiler should be altered. FIXME. */ 7645 7646 static struct type * 7647 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr, 7648 CORE_ADDR address, struct value *dval) 7649 { 7650 struct type *templ_type; 7651 7652 if (TYPE_FIXED_INSTANCE (type0)) 7653 return type0; 7654 7655 templ_type = dynamic_template_type (type0); 7656 7657 if (templ_type != NULL) 7658 return template_to_fixed_record_type (templ_type, valaddr, address, dval); 7659 else if (variant_field_index (type0) >= 0) 7660 { 7661 if (dval == NULL && valaddr == NULL && address == 0) 7662 return type0; 7663 return to_record_with_fixed_variant_part (type0, valaddr, address, 7664 dval); 7665 } 7666 else 7667 { 7668 TYPE_FIXED_INSTANCE (type0) = 1; 7669 return type0; 7670 } 7671 7672 } 7673 7674 /* An ordinary record type (with fixed-length fields) that describes 7675 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a 7676 union type. Any necessary discriminants' values should be in DVAL, 7677 a record value. That is, this routine selects the appropriate 7678 branch of the union at ADDR according to the discriminant value 7679 indicated in the union's type name. Returns VAR_TYPE0 itself if 7680 it represents a variant subject to a pragma Unchecked_Union. */ 7681 7682 static struct type * 7683 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr, 7684 CORE_ADDR address, struct value *dval) 7685 { 7686 int which; 7687 struct type *templ_type; 7688 struct type *var_type; 7689 7690 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR) 7691 var_type = TYPE_TARGET_TYPE (var_type0); 7692 else 7693 var_type = var_type0; 7694 7695 templ_type = ada_find_parallel_type (var_type, "___XVU"); 7696 7697 if (templ_type != NULL) 7698 var_type = templ_type; 7699 7700 if (is_unchecked_variant (var_type, value_type (dval))) 7701 return var_type0; 7702 which = 7703 ada_which_variant_applies (var_type, 7704 value_type (dval), value_contents (dval)); 7705 7706 if (which < 0) 7707 return empty_record (var_type); 7708 else if (is_dynamic_field (var_type, which)) 7709 return to_fixed_record_type 7710 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)), 7711 valaddr, address, dval); 7712 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0) 7713 return 7714 to_fixed_record_type 7715 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval); 7716 else 7717 return TYPE_FIELD_TYPE (var_type, which); 7718 } 7719 7720 /* Assuming that TYPE0 is an array type describing the type of a value 7721 at ADDR, and that DVAL describes a record containing any 7722 discriminants used in TYPE0, returns a type for the value that 7723 contains no dynamic components (that is, no components whose sizes 7724 are determined by run-time quantities). Unless IGNORE_TOO_BIG is 7725 true, gives an error message if the resulting type's size is over 7726 varsize_limit. */ 7727 7728 static struct type * 7729 to_fixed_array_type (struct type *type0, struct value *dval, 7730 int ignore_too_big) 7731 { 7732 struct type *index_type_desc; 7733 struct type *result; 7734 int constrained_packed_array_p; 7735 7736 type0 = ada_check_typedef (type0); 7737 if (TYPE_FIXED_INSTANCE (type0)) 7738 return type0; 7739 7740 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0); 7741 if (constrained_packed_array_p) 7742 type0 = decode_constrained_packed_array_type (type0); 7743 7744 index_type_desc = ada_find_parallel_type (type0, "___XA"); 7745 ada_fixup_array_indexes_type (index_type_desc); 7746 if (index_type_desc == NULL) 7747 { 7748 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0)); 7749 7750 /* NOTE: elt_type---the fixed version of elt_type0---should never 7751 depend on the contents of the array in properly constructed 7752 debugging data. */ 7753 /* Create a fixed version of the array element type. 7754 We're not providing the address of an element here, 7755 and thus the actual object value cannot be inspected to do 7756 the conversion. This should not be a problem, since arrays of 7757 unconstrained objects are not allowed. In particular, all 7758 the elements of an array of a tagged type should all be of 7759 the same type specified in the debugging info. No need to 7760 consult the object tag. */ 7761 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1); 7762 7763 /* Make sure we always create a new array type when dealing with 7764 packed array types, since we're going to fix-up the array 7765 type length and element bitsize a little further down. */ 7766 if (elt_type0 == elt_type && !constrained_packed_array_p) 7767 result = type0; 7768 else 7769 result = create_array_type (alloc_type_copy (type0), 7770 elt_type, TYPE_INDEX_TYPE (type0)); 7771 } 7772 else 7773 { 7774 int i; 7775 struct type *elt_type0; 7776 7777 elt_type0 = type0; 7778 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1) 7779 elt_type0 = TYPE_TARGET_TYPE (elt_type0); 7780 7781 /* NOTE: result---the fixed version of elt_type0---should never 7782 depend on the contents of the array in properly constructed 7783 debugging data. */ 7784 /* Create a fixed version of the array element type. 7785 We're not providing the address of an element here, 7786 and thus the actual object value cannot be inspected to do 7787 the conversion. This should not be a problem, since arrays of 7788 unconstrained objects are not allowed. In particular, all 7789 the elements of an array of a tagged type should all be of 7790 the same type specified in the debugging info. No need to 7791 consult the object tag. */ 7792 result = 7793 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1); 7794 7795 elt_type0 = type0; 7796 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1) 7797 { 7798 struct type *range_type = 7799 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval); 7800 7801 result = create_array_type (alloc_type_copy (elt_type0), 7802 result, range_type); 7803 elt_type0 = TYPE_TARGET_TYPE (elt_type0); 7804 } 7805 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit) 7806 error (_("array type with dynamic size is larger than varsize-limit")); 7807 } 7808 7809 if (constrained_packed_array_p) 7810 { 7811 /* So far, the resulting type has been created as if the original 7812 type was a regular (non-packed) array type. As a result, the 7813 bitsize of the array elements needs to be set again, and the array 7814 length needs to be recomputed based on that bitsize. */ 7815 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result)); 7816 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0); 7817 7818 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0); 7819 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT; 7820 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize) 7821 TYPE_LENGTH (result)++; 7822 } 7823 7824 TYPE_FIXED_INSTANCE (result) = 1; 7825 return result; 7826 } 7827 7828 7829 /* A standard type (containing no dynamically sized components) 7830 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS) 7831 DVAL describes a record containing any discriminants used in TYPE0, 7832 and may be NULL if there are none, or if the object of type TYPE at 7833 ADDRESS or in VALADDR contains these discriminants. 7834 7835 If CHECK_TAG is not null, in the case of tagged types, this function 7836 attempts to locate the object's tag and use it to compute the actual 7837 type. However, when ADDRESS is null, we cannot use it to determine the 7838 location of the tag, and therefore compute the tagged type's actual type. 7839 So we return the tagged type without consulting the tag. */ 7840 7841 static struct type * 7842 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr, 7843 CORE_ADDR address, struct value *dval, int check_tag) 7844 { 7845 type = ada_check_typedef (type); 7846 switch (TYPE_CODE (type)) 7847 { 7848 default: 7849 return type; 7850 case TYPE_CODE_STRUCT: 7851 { 7852 struct type *static_type = to_static_fixed_type (type); 7853 struct type *fixed_record_type = 7854 to_fixed_record_type (type, valaddr, address, NULL); 7855 7856 /* If STATIC_TYPE is a tagged type and we know the object's address, 7857 then we can determine its tag, and compute the object's actual 7858 type from there. Note that we have to use the fixed record 7859 type (the parent part of the record may have dynamic fields 7860 and the way the location of _tag is expressed may depend on 7861 them). */ 7862 7863 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0)) 7864 { 7865 struct type *real_type = 7866 type_from_tag (value_tag_from_contents_and_address 7867 (fixed_record_type, 7868 valaddr, 7869 address)); 7870 7871 if (real_type != NULL) 7872 return to_fixed_record_type (real_type, valaddr, address, NULL); 7873 } 7874 7875 /* Check to see if there is a parallel ___XVZ variable. 7876 If there is, then it provides the actual size of our type. */ 7877 else if (ada_type_name (fixed_record_type) != NULL) 7878 { 7879 char *name = ada_type_name (fixed_record_type); 7880 char *xvz_name = alloca (strlen (name) + 7 /* "___XVZ\0" */); 7881 int xvz_found = 0; 7882 LONGEST size; 7883 7884 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name); 7885 size = get_int_var_value (xvz_name, &xvz_found); 7886 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size) 7887 { 7888 fixed_record_type = copy_type (fixed_record_type); 7889 TYPE_LENGTH (fixed_record_type) = size; 7890 7891 /* The FIXED_RECORD_TYPE may have be a stub. We have 7892 observed this when the debugging info is STABS, and 7893 apparently it is something that is hard to fix. 7894 7895 In practice, we don't need the actual type definition 7896 at all, because the presence of the XVZ variable allows us 7897 to assume that there must be a XVS type as well, which we 7898 should be able to use later, when we need the actual type 7899 definition. 7900 7901 In the meantime, pretend that the "fixed" type we are 7902 returning is NOT a stub, because this can cause trouble 7903 when using this type to create new types targeting it. 7904 Indeed, the associated creation routines often check 7905 whether the target type is a stub and will try to replace 7906 it, thus using a type with the wrong size. This, in turn, 7907 might cause the new type to have the wrong size too. 7908 Consider the case of an array, for instance, where the size 7909 of the array is computed from the number of elements in 7910 our array multiplied by the size of its element. */ 7911 TYPE_STUB (fixed_record_type) = 0; 7912 } 7913 } 7914 return fixed_record_type; 7915 } 7916 case TYPE_CODE_ARRAY: 7917 return to_fixed_array_type (type, dval, 1); 7918 case TYPE_CODE_UNION: 7919 if (dval == NULL) 7920 return type; 7921 else 7922 return to_fixed_variant_branch_type (type, valaddr, address, dval); 7923 } 7924 } 7925 7926 /* The same as ada_to_fixed_type_1, except that it preserves the type 7927 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed. 7928 7929 The typedef layer needs be preserved in order to differentiate between 7930 arrays and array pointers when both types are implemented using the same 7931 fat pointer. In the array pointer case, the pointer is encoded as 7932 a typedef of the pointer type. For instance, considering: 7933 7934 type String_Access is access String; 7935 S1 : String_Access := null; 7936 7937 To the debugger, S1 is defined as a typedef of type String. But 7938 to the user, it is a pointer. So if the user tries to print S1, 7939 we should not dereference the array, but print the array address 7940 instead. 7941 7942 If we didn't preserve the typedef layer, we would lose the fact that 7943 the type is to be presented as a pointer (needs de-reference before 7944 being printed). And we would also use the source-level type name. */ 7945 7946 struct type * 7947 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr, 7948 CORE_ADDR address, struct value *dval, int check_tag) 7949 7950 { 7951 struct type *fixed_type = 7952 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag); 7953 7954 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE, 7955 then preserve the typedef layer. 7956 7957 Implementation note: We can only check the main-type portion of 7958 the TYPE and FIXED_TYPE, because eliminating the typedef layer 7959 from TYPE now returns a type that has the same instance flags 7960 as TYPE. For instance, if TYPE is a "typedef const", and its 7961 target type is a "struct", then the typedef elimination will return 7962 a "const" version of the target type. See check_typedef for more 7963 details about how the typedef layer elimination is done. 7964 7965 brobecker/2010-11-19: It seems to me that the only case where it is 7966 useful to preserve the typedef layer is when dealing with fat pointers. 7967 Perhaps, we could add a check for that and preserve the typedef layer 7968 only in that situation. But this seems unecessary so far, probably 7969 because we call check_typedef/ada_check_typedef pretty much everywhere. 7970 */ 7971 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF 7972 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type)) 7973 == TYPE_MAIN_TYPE (fixed_type))) 7974 return type; 7975 7976 return fixed_type; 7977 } 7978 7979 /* A standard (static-sized) type corresponding as well as possible to 7980 TYPE0, but based on no runtime data. */ 7981 7982 static struct type * 7983 to_static_fixed_type (struct type *type0) 7984 { 7985 struct type *type; 7986 7987 if (type0 == NULL) 7988 return NULL; 7989 7990 if (TYPE_FIXED_INSTANCE (type0)) 7991 return type0; 7992 7993 type0 = ada_check_typedef (type0); 7994 7995 switch (TYPE_CODE (type0)) 7996 { 7997 default: 7998 return type0; 7999 case TYPE_CODE_STRUCT: 8000 type = dynamic_template_type (type0); 8001 if (type != NULL) 8002 return template_to_static_fixed_type (type); 8003 else 8004 return template_to_static_fixed_type (type0); 8005 case TYPE_CODE_UNION: 8006 type = ada_find_parallel_type (type0, "___XVU"); 8007 if (type != NULL) 8008 return template_to_static_fixed_type (type); 8009 else 8010 return template_to_static_fixed_type (type0); 8011 } 8012 } 8013 8014 /* A static approximation of TYPE with all type wrappers removed. */ 8015 8016 static struct type * 8017 static_unwrap_type (struct type *type) 8018 { 8019 if (ada_is_aligner_type (type)) 8020 { 8021 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0); 8022 if (ada_type_name (type1) == NULL) 8023 TYPE_NAME (type1) = ada_type_name (type); 8024 8025 return static_unwrap_type (type1); 8026 } 8027 else 8028 { 8029 struct type *raw_real_type = ada_get_base_type (type); 8030 8031 if (raw_real_type == type) 8032 return type; 8033 else 8034 return to_static_fixed_type (raw_real_type); 8035 } 8036 } 8037 8038 /* In some cases, incomplete and private types require 8039 cross-references that are not resolved as records (for example, 8040 type Foo; 8041 type FooP is access Foo; 8042 V: FooP; 8043 type Foo is array ...; 8044 ). In these cases, since there is no mechanism for producing 8045 cross-references to such types, we instead substitute for FooP a 8046 stub enumeration type that is nowhere resolved, and whose tag is 8047 the name of the actual type. Call these types "non-record stubs". */ 8048 8049 /* A type equivalent to TYPE that is not a non-record stub, if one 8050 exists, otherwise TYPE. */ 8051 8052 struct type * 8053 ada_check_typedef (struct type *type) 8054 { 8055 if (type == NULL) 8056 return NULL; 8057 8058 /* If our type is a typedef type of a fat pointer, then we're done. 8059 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is 8060 what allows us to distinguish between fat pointers that represent 8061 array types, and fat pointers that represent array access types 8062 (in both cases, the compiler implements them as fat pointers). */ 8063 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF 8064 && is_thick_pntr (ada_typedef_target_type (type))) 8065 return type; 8066 8067 CHECK_TYPEDEF (type); 8068 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM 8069 || !TYPE_STUB (type) 8070 || TYPE_TAG_NAME (type) == NULL) 8071 return type; 8072 else 8073 { 8074 char *name = TYPE_TAG_NAME (type); 8075 struct type *type1 = ada_find_any_type (name); 8076 8077 if (type1 == NULL) 8078 return type; 8079 8080 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with 8081 stubs pointing to arrays, as we don't create symbols for array 8082 types, only for the typedef-to-array types). If that's the case, 8083 strip the typedef layer. */ 8084 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF) 8085 type1 = ada_check_typedef (type1); 8086 8087 return type1; 8088 } 8089 } 8090 8091 /* A value representing the data at VALADDR/ADDRESS as described by 8092 type TYPE0, but with a standard (static-sized) type that correctly 8093 describes it. If VAL0 is not NULL and TYPE0 already is a standard 8094 type, then return VAL0 [this feature is simply to avoid redundant 8095 creation of struct values]. */ 8096 8097 static struct value * 8098 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address, 8099 struct value *val0) 8100 { 8101 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1); 8102 8103 if (type == type0 && val0 != NULL) 8104 return val0; 8105 else 8106 return value_from_contents_and_address (type, 0, address); 8107 } 8108 8109 /* A value representing VAL, but with a standard (static-sized) type 8110 that correctly describes it. Does not necessarily create a new 8111 value. */ 8112 8113 struct value * 8114 ada_to_fixed_value (struct value *val) 8115 { 8116 return ada_to_fixed_value_create (value_type (val), 8117 value_address (val), 8118 val); 8119 } 8120 8121 8122 /* Attributes */ 8123 8124 /* Table mapping attribute numbers to names. 8125 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */ 8126 8127 static const char *attribute_names[] = { 8128 "<?>", 8129 8130 "first", 8131 "last", 8132 "length", 8133 "image", 8134 "max", 8135 "min", 8136 "modulus", 8137 "pos", 8138 "size", 8139 "tag", 8140 "val", 8141 0 8142 }; 8143 8144 const char * 8145 ada_attribute_name (enum exp_opcode n) 8146 { 8147 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL) 8148 return attribute_names[n - OP_ATR_FIRST + 1]; 8149 else 8150 return attribute_names[0]; 8151 } 8152 8153 /* Evaluate the 'POS attribute applied to ARG. */ 8154 8155 static LONGEST 8156 pos_atr (struct value *arg) 8157 { 8158 struct value *val = coerce_ref (arg); 8159 struct type *type = value_type (val); 8160 8161 if (!discrete_type_p (type)) 8162 error (_("'POS only defined on discrete types")); 8163 8164 if (TYPE_CODE (type) == TYPE_CODE_ENUM) 8165 { 8166 int i; 8167 LONGEST v = value_as_long (val); 8168 8169 for (i = 0; i < TYPE_NFIELDS (type); i += 1) 8170 { 8171 if (v == TYPE_FIELD_BITPOS (type, i)) 8172 return i; 8173 } 8174 error (_("enumeration value is invalid: can't find 'POS")); 8175 } 8176 else 8177 return value_as_long (val); 8178 } 8179 8180 static struct value * 8181 value_pos_atr (struct type *type, struct value *arg) 8182 { 8183 return value_from_longest (type, pos_atr (arg)); 8184 } 8185 8186 /* Evaluate the TYPE'VAL attribute applied to ARG. */ 8187 8188 static struct value * 8189 value_val_atr (struct type *type, struct value *arg) 8190 { 8191 if (!discrete_type_p (type)) 8192 error (_("'VAL only defined on discrete types")); 8193 if (!integer_type_p (value_type (arg))) 8194 error (_("'VAL requires integral argument")); 8195 8196 if (TYPE_CODE (type) == TYPE_CODE_ENUM) 8197 { 8198 long pos = value_as_long (arg); 8199 8200 if (pos < 0 || pos >= TYPE_NFIELDS (type)) 8201 error (_("argument to 'VAL out of range")); 8202 return value_from_longest (type, TYPE_FIELD_BITPOS (type, pos)); 8203 } 8204 else 8205 return value_from_longest (type, value_as_long (arg)); 8206 } 8207 8208 8209 /* Evaluation */ 8210 8211 /* True if TYPE appears to be an Ada character type. 8212 [At the moment, this is true only for Character and Wide_Character; 8213 It is a heuristic test that could stand improvement]. */ 8214 8215 int 8216 ada_is_character_type (struct type *type) 8217 { 8218 const char *name; 8219 8220 /* If the type code says it's a character, then assume it really is, 8221 and don't check any further. */ 8222 if (TYPE_CODE (type) == TYPE_CODE_CHAR) 8223 return 1; 8224 8225 /* Otherwise, assume it's a character type iff it is a discrete type 8226 with a known character type name. */ 8227 name = ada_type_name (type); 8228 return (name != NULL 8229 && (TYPE_CODE (type) == TYPE_CODE_INT 8230 || TYPE_CODE (type) == TYPE_CODE_RANGE) 8231 && (strcmp (name, "character") == 0 8232 || strcmp (name, "wide_character") == 0 8233 || strcmp (name, "wide_wide_character") == 0 8234 || strcmp (name, "unsigned char") == 0)); 8235 } 8236 8237 /* True if TYPE appears to be an Ada string type. */ 8238 8239 int 8240 ada_is_string_type (struct type *type) 8241 { 8242 type = ada_check_typedef (type); 8243 if (type != NULL 8244 && TYPE_CODE (type) != TYPE_CODE_PTR 8245 && (ada_is_simple_array_type (type) 8246 || ada_is_array_descriptor_type (type)) 8247 && ada_array_arity (type) == 1) 8248 { 8249 struct type *elttype = ada_array_element_type (type, 1); 8250 8251 return ada_is_character_type (elttype); 8252 } 8253 else 8254 return 0; 8255 } 8256 8257 /* The compiler sometimes provides a parallel XVS type for a given 8258 PAD type. Normally, it is safe to follow the PAD type directly, 8259 but older versions of the compiler have a bug that causes the offset 8260 of its "F" field to be wrong. Following that field in that case 8261 would lead to incorrect results, but this can be worked around 8262 by ignoring the PAD type and using the associated XVS type instead. 8263 8264 Set to True if the debugger should trust the contents of PAD types. 8265 Otherwise, ignore the PAD type if there is a parallel XVS type. */ 8266 static int trust_pad_over_xvs = 1; 8267 8268 /* True if TYPE is a struct type introduced by the compiler to force the 8269 alignment of a value. Such types have a single field with a 8270 distinctive name. */ 8271 8272 int 8273 ada_is_aligner_type (struct type *type) 8274 { 8275 type = ada_check_typedef (type); 8276 8277 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL) 8278 return 0; 8279 8280 return (TYPE_CODE (type) == TYPE_CODE_STRUCT 8281 && TYPE_NFIELDS (type) == 1 8282 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0); 8283 } 8284 8285 /* If there is an ___XVS-convention type parallel to SUBTYPE, return 8286 the parallel type. */ 8287 8288 struct type * 8289 ada_get_base_type (struct type *raw_type) 8290 { 8291 struct type *real_type_namer; 8292 struct type *raw_real_type; 8293 8294 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT) 8295 return raw_type; 8296 8297 if (ada_is_aligner_type (raw_type)) 8298 /* The encoding specifies that we should always use the aligner type. 8299 So, even if this aligner type has an associated XVS type, we should 8300 simply ignore it. 8301 8302 According to the compiler gurus, an XVS type parallel to an aligner 8303 type may exist because of a stabs limitation. In stabs, aligner 8304 types are empty because the field has a variable-sized type, and 8305 thus cannot actually be used as an aligner type. As a result, 8306 we need the associated parallel XVS type to decode the type. 8307 Since the policy in the compiler is to not change the internal 8308 representation based on the debugging info format, we sometimes 8309 end up having a redundant XVS type parallel to the aligner type. */ 8310 return raw_type; 8311 8312 real_type_namer = ada_find_parallel_type (raw_type, "___XVS"); 8313 if (real_type_namer == NULL 8314 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT 8315 || TYPE_NFIELDS (real_type_namer) != 1) 8316 return raw_type; 8317 8318 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF) 8319 { 8320 /* This is an older encoding form where the base type needs to be 8321 looked up by name. We prefer the newer enconding because it is 8322 more efficient. */ 8323 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0)); 8324 if (raw_real_type == NULL) 8325 return raw_type; 8326 else 8327 return raw_real_type; 8328 } 8329 8330 /* The field in our XVS type is a reference to the base type. */ 8331 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0)); 8332 } 8333 8334 /* The type of value designated by TYPE, with all aligners removed. */ 8335 8336 struct type * 8337 ada_aligned_type (struct type *type) 8338 { 8339 if (ada_is_aligner_type (type)) 8340 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0)); 8341 else 8342 return ada_get_base_type (type); 8343 } 8344 8345 8346 /* The address of the aligned value in an object at address VALADDR 8347 having type TYPE. Assumes ada_is_aligner_type (TYPE). */ 8348 8349 const gdb_byte * 8350 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr) 8351 { 8352 if (ada_is_aligner_type (type)) 8353 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0), 8354 valaddr + 8355 TYPE_FIELD_BITPOS (type, 8356 0) / TARGET_CHAR_BIT); 8357 else 8358 return valaddr; 8359 } 8360 8361 8362 8363 /* The printed representation of an enumeration literal with encoded 8364 name NAME. The value is good to the next call of ada_enum_name. */ 8365 const char * 8366 ada_enum_name (const char *name) 8367 { 8368 static char *result; 8369 static size_t result_len = 0; 8370 char *tmp; 8371 8372 /* First, unqualify the enumeration name: 8373 1. Search for the last '.' character. If we find one, then skip 8374 all the preceding characters, the unqualified name starts 8375 right after that dot. 8376 2. Otherwise, we may be debugging on a target where the compiler 8377 translates dots into "__". Search forward for double underscores, 8378 but stop searching when we hit an overloading suffix, which is 8379 of the form "__" followed by digits. */ 8380 8381 tmp = strrchr (name, '.'); 8382 if (tmp != NULL) 8383 name = tmp + 1; 8384 else 8385 { 8386 while ((tmp = strstr (name, "__")) != NULL) 8387 { 8388 if (isdigit (tmp[2])) 8389 break; 8390 else 8391 name = tmp + 2; 8392 } 8393 } 8394 8395 if (name[0] == 'Q') 8396 { 8397 int v; 8398 8399 if (name[1] == 'U' || name[1] == 'W') 8400 { 8401 if (sscanf (name + 2, "%x", &v) != 1) 8402 return name; 8403 } 8404 else 8405 return name; 8406 8407 GROW_VECT (result, result_len, 16); 8408 if (isascii (v) && isprint (v)) 8409 xsnprintf (result, result_len, "'%c'", v); 8410 else if (name[1] == 'U') 8411 xsnprintf (result, result_len, "[\"%02x\"]", v); 8412 else 8413 xsnprintf (result, result_len, "[\"%04x\"]", v); 8414 8415 return result; 8416 } 8417 else 8418 { 8419 tmp = strstr (name, "__"); 8420 if (tmp == NULL) 8421 tmp = strstr (name, "$"); 8422 if (tmp != NULL) 8423 { 8424 GROW_VECT (result, result_len, tmp - name + 1); 8425 strncpy (result, name, tmp - name); 8426 result[tmp - name] = '\0'; 8427 return result; 8428 } 8429 8430 return name; 8431 } 8432 } 8433 8434 /* Evaluate the subexpression of EXP starting at *POS as for 8435 evaluate_type, updating *POS to point just past the evaluated 8436 expression. */ 8437 8438 static struct value * 8439 evaluate_subexp_type (struct expression *exp, int *pos) 8440 { 8441 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS); 8442 } 8443 8444 /* If VAL is wrapped in an aligner or subtype wrapper, return the 8445 value it wraps. */ 8446 8447 static struct value * 8448 unwrap_value (struct value *val) 8449 { 8450 struct type *type = ada_check_typedef (value_type (val)); 8451 8452 if (ada_is_aligner_type (type)) 8453 { 8454 struct value *v = ada_value_struct_elt (val, "F", 0); 8455 struct type *val_type = ada_check_typedef (value_type (v)); 8456 8457 if (ada_type_name (val_type) == NULL) 8458 TYPE_NAME (val_type) = ada_type_name (type); 8459 8460 return unwrap_value (v); 8461 } 8462 else 8463 { 8464 struct type *raw_real_type = 8465 ada_check_typedef (ada_get_base_type (type)); 8466 8467 /* If there is no parallel XVS or XVE type, then the value is 8468 already unwrapped. Return it without further modification. */ 8469 if ((type == raw_real_type) 8470 && ada_find_parallel_type (type, "___XVE") == NULL) 8471 return val; 8472 8473 return 8474 coerce_unspec_val_to_type 8475 (val, ada_to_fixed_type (raw_real_type, 0, 8476 value_address (val), 8477 NULL, 1)); 8478 } 8479 } 8480 8481 static struct value * 8482 cast_to_fixed (struct type *type, struct value *arg) 8483 { 8484 LONGEST val; 8485 8486 if (type == value_type (arg)) 8487 return arg; 8488 else if (ada_is_fixed_point_type (value_type (arg))) 8489 val = ada_float_to_fixed (type, 8490 ada_fixed_to_float (value_type (arg), 8491 value_as_long (arg))); 8492 else 8493 { 8494 DOUBLEST argd = value_as_double (arg); 8495 8496 val = ada_float_to_fixed (type, argd); 8497 } 8498 8499 return value_from_longest (type, val); 8500 } 8501 8502 static struct value * 8503 cast_from_fixed (struct type *type, struct value *arg) 8504 { 8505 DOUBLEST val = ada_fixed_to_float (value_type (arg), 8506 value_as_long (arg)); 8507 8508 return value_from_double (type, val); 8509 } 8510 8511 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and 8512 return the converted value. */ 8513 8514 static struct value * 8515 coerce_for_assign (struct type *type, struct value *val) 8516 { 8517 struct type *type2 = value_type (val); 8518 8519 if (type == type2) 8520 return val; 8521 8522 type2 = ada_check_typedef (type2); 8523 type = ada_check_typedef (type); 8524 8525 if (TYPE_CODE (type2) == TYPE_CODE_PTR 8526 && TYPE_CODE (type) == TYPE_CODE_ARRAY) 8527 { 8528 val = ada_value_ind (val); 8529 type2 = value_type (val); 8530 } 8531 8532 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY 8533 && TYPE_CODE (type) == TYPE_CODE_ARRAY) 8534 { 8535 if (TYPE_LENGTH (type2) != TYPE_LENGTH (type) 8536 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2)) 8537 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2))) 8538 error (_("Incompatible types in assignment")); 8539 deprecated_set_value_type (val, type); 8540 } 8541 return val; 8542 } 8543 8544 static struct value * 8545 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op) 8546 { 8547 struct value *val; 8548 struct type *type1, *type2; 8549 LONGEST v, v1, v2; 8550 8551 arg1 = coerce_ref (arg1); 8552 arg2 = coerce_ref (arg2); 8553 type1 = get_base_type (ada_check_typedef (value_type (arg1))); 8554 type2 = get_base_type (ada_check_typedef (value_type (arg2))); 8555 8556 if (TYPE_CODE (type1) != TYPE_CODE_INT 8557 || TYPE_CODE (type2) != TYPE_CODE_INT) 8558 return value_binop (arg1, arg2, op); 8559 8560 switch (op) 8561 { 8562 case BINOP_MOD: 8563 case BINOP_DIV: 8564 case BINOP_REM: 8565 break; 8566 default: 8567 return value_binop (arg1, arg2, op); 8568 } 8569 8570 v2 = value_as_long (arg2); 8571 if (v2 == 0) 8572 error (_("second operand of %s must not be zero."), op_string (op)); 8573 8574 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD) 8575 return value_binop (arg1, arg2, op); 8576 8577 v1 = value_as_long (arg1); 8578 switch (op) 8579 { 8580 case BINOP_DIV: 8581 v = v1 / v2; 8582 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0) 8583 v += v > 0 ? -1 : 1; 8584 break; 8585 case BINOP_REM: 8586 v = v1 % v2; 8587 if (v * v1 < 0) 8588 v -= v2; 8589 break; 8590 default: 8591 /* Should not reach this point. */ 8592 v = 0; 8593 } 8594 8595 val = allocate_value (type1); 8596 store_unsigned_integer (value_contents_raw (val), 8597 TYPE_LENGTH (value_type (val)), 8598 gdbarch_byte_order (get_type_arch (type1)), v); 8599 return val; 8600 } 8601 8602 static int 8603 ada_value_equal (struct value *arg1, struct value *arg2) 8604 { 8605 if (ada_is_direct_array_type (value_type (arg1)) 8606 || ada_is_direct_array_type (value_type (arg2))) 8607 { 8608 /* Automatically dereference any array reference before 8609 we attempt to perform the comparison. */ 8610 arg1 = ada_coerce_ref (arg1); 8611 arg2 = ada_coerce_ref (arg2); 8612 8613 arg1 = ada_coerce_to_simple_array (arg1); 8614 arg2 = ada_coerce_to_simple_array (arg2); 8615 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY 8616 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY) 8617 error (_("Attempt to compare array with non-array")); 8618 /* FIXME: The following works only for types whose 8619 representations use all bits (no padding or undefined bits) 8620 and do not have user-defined equality. */ 8621 return 8622 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2)) 8623 && memcmp (value_contents (arg1), value_contents (arg2), 8624 TYPE_LENGTH (value_type (arg1))) == 0; 8625 } 8626 return value_equal (arg1, arg2); 8627 } 8628 8629 /* Total number of component associations in the aggregate starting at 8630 index PC in EXP. Assumes that index PC is the start of an 8631 OP_AGGREGATE. */ 8632 8633 static int 8634 num_component_specs (struct expression *exp, int pc) 8635 { 8636 int n, m, i; 8637 8638 m = exp->elts[pc + 1].longconst; 8639 pc += 3; 8640 n = 0; 8641 for (i = 0; i < m; i += 1) 8642 { 8643 switch (exp->elts[pc].opcode) 8644 { 8645 default: 8646 n += 1; 8647 break; 8648 case OP_CHOICES: 8649 n += exp->elts[pc + 1].longconst; 8650 break; 8651 } 8652 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP); 8653 } 8654 return n; 8655 } 8656 8657 /* Assign the result of evaluating EXP starting at *POS to the INDEXth 8658 component of LHS (a simple array or a record), updating *POS past 8659 the expression, assuming that LHS is contained in CONTAINER. Does 8660 not modify the inferior's memory, nor does it modify LHS (unless 8661 LHS == CONTAINER). */ 8662 8663 static void 8664 assign_component (struct value *container, struct value *lhs, LONGEST index, 8665 struct expression *exp, int *pos) 8666 { 8667 struct value *mark = value_mark (); 8668 struct value *elt; 8669 8670 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY) 8671 { 8672 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int; 8673 struct value *index_val = value_from_longest (index_type, index); 8674 8675 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val)); 8676 } 8677 else 8678 { 8679 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs)); 8680 elt = ada_to_fixed_value (unwrap_value (elt)); 8681 } 8682 8683 if (exp->elts[*pos].opcode == OP_AGGREGATE) 8684 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL); 8685 else 8686 value_assign_to_component (container, elt, 8687 ada_evaluate_subexp (NULL, exp, pos, 8688 EVAL_NORMAL)); 8689 8690 value_free_to_mark (mark); 8691 } 8692 8693 /* Assuming that LHS represents an lvalue having a record or array 8694 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment 8695 of that aggregate's value to LHS, advancing *POS past the 8696 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an 8697 lvalue containing LHS (possibly LHS itself). Does not modify 8698 the inferior's memory, nor does it modify the contents of 8699 LHS (unless == CONTAINER). Returns the modified CONTAINER. */ 8700 8701 static struct value * 8702 assign_aggregate (struct value *container, 8703 struct value *lhs, struct expression *exp, 8704 int *pos, enum noside noside) 8705 { 8706 struct type *lhs_type; 8707 int n = exp->elts[*pos+1].longconst; 8708 LONGEST low_index, high_index; 8709 int num_specs; 8710 LONGEST *indices; 8711 int max_indices, num_indices; 8712 int is_array_aggregate; 8713 int i; 8714 8715 *pos += 3; 8716 if (noside != EVAL_NORMAL) 8717 { 8718 for (i = 0; i < n; i += 1) 8719 ada_evaluate_subexp (NULL, exp, pos, noside); 8720 return container; 8721 } 8722 8723 container = ada_coerce_ref (container); 8724 if (ada_is_direct_array_type (value_type (container))) 8725 container = ada_coerce_to_simple_array (container); 8726 lhs = ada_coerce_ref (lhs); 8727 if (!deprecated_value_modifiable (lhs)) 8728 error (_("Left operand of assignment is not a modifiable lvalue.")); 8729 8730 lhs_type = value_type (lhs); 8731 if (ada_is_direct_array_type (lhs_type)) 8732 { 8733 lhs = ada_coerce_to_simple_array (lhs); 8734 lhs_type = value_type (lhs); 8735 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type); 8736 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type); 8737 is_array_aggregate = 1; 8738 } 8739 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT) 8740 { 8741 low_index = 0; 8742 high_index = num_visible_fields (lhs_type) - 1; 8743 is_array_aggregate = 0; 8744 } 8745 else 8746 error (_("Left-hand side must be array or record.")); 8747 8748 num_specs = num_component_specs (exp, *pos - 3); 8749 max_indices = 4 * num_specs + 4; 8750 indices = alloca (max_indices * sizeof (indices[0])); 8751 indices[0] = indices[1] = low_index - 1; 8752 indices[2] = indices[3] = high_index + 1; 8753 num_indices = 4; 8754 8755 for (i = 0; i < n; i += 1) 8756 { 8757 switch (exp->elts[*pos].opcode) 8758 { 8759 case OP_CHOICES: 8760 aggregate_assign_from_choices (container, lhs, exp, pos, indices, 8761 &num_indices, max_indices, 8762 low_index, high_index); 8763 break; 8764 case OP_POSITIONAL: 8765 aggregate_assign_positional (container, lhs, exp, pos, indices, 8766 &num_indices, max_indices, 8767 low_index, high_index); 8768 break; 8769 case OP_OTHERS: 8770 if (i != n-1) 8771 error (_("Misplaced 'others' clause")); 8772 aggregate_assign_others (container, lhs, exp, pos, indices, 8773 num_indices, low_index, high_index); 8774 break; 8775 default: 8776 error (_("Internal error: bad aggregate clause")); 8777 } 8778 } 8779 8780 return container; 8781 } 8782 8783 /* Assign into the component of LHS indexed by the OP_POSITIONAL 8784 construct at *POS, updating *POS past the construct, given that 8785 the positions are relative to lower bound LOW, where HIGH is the 8786 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1] 8787 updating *NUM_INDICES as needed. CONTAINER is as for 8788 assign_aggregate. */ 8789 static void 8790 aggregate_assign_positional (struct value *container, 8791 struct value *lhs, struct expression *exp, 8792 int *pos, LONGEST *indices, int *num_indices, 8793 int max_indices, LONGEST low, LONGEST high) 8794 { 8795 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low; 8796 8797 if (ind - 1 == high) 8798 warning (_("Extra components in aggregate ignored.")); 8799 if (ind <= high) 8800 { 8801 add_component_interval (ind, ind, indices, num_indices, max_indices); 8802 *pos += 3; 8803 assign_component (container, lhs, ind, exp, pos); 8804 } 8805 else 8806 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP); 8807 } 8808 8809 /* Assign into the components of LHS indexed by the OP_CHOICES 8810 construct at *POS, updating *POS past the construct, given that 8811 the allowable indices are LOW..HIGH. Record the indices assigned 8812 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as 8813 needed. CONTAINER is as for assign_aggregate. */ 8814 static void 8815 aggregate_assign_from_choices (struct value *container, 8816 struct value *lhs, struct expression *exp, 8817 int *pos, LONGEST *indices, int *num_indices, 8818 int max_indices, LONGEST low, LONGEST high) 8819 { 8820 int j; 8821 int n_choices = longest_to_int (exp->elts[*pos+1].longconst); 8822 int choice_pos, expr_pc; 8823 int is_array = ada_is_direct_array_type (value_type (lhs)); 8824 8825 choice_pos = *pos += 3; 8826 8827 for (j = 0; j < n_choices; j += 1) 8828 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP); 8829 expr_pc = *pos; 8830 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP); 8831 8832 for (j = 0; j < n_choices; j += 1) 8833 { 8834 LONGEST lower, upper; 8835 enum exp_opcode op = exp->elts[choice_pos].opcode; 8836 8837 if (op == OP_DISCRETE_RANGE) 8838 { 8839 choice_pos += 1; 8840 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos, 8841 EVAL_NORMAL)); 8842 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos, 8843 EVAL_NORMAL)); 8844 } 8845 else if (is_array) 8846 { 8847 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos, 8848 EVAL_NORMAL)); 8849 upper = lower; 8850 } 8851 else 8852 { 8853 int ind; 8854 char *name; 8855 8856 switch (op) 8857 { 8858 case OP_NAME: 8859 name = &exp->elts[choice_pos + 2].string; 8860 break; 8861 case OP_VAR_VALUE: 8862 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol); 8863 break; 8864 default: 8865 error (_("Invalid record component association.")); 8866 } 8867 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP); 8868 ind = 0; 8869 if (! find_struct_field (name, value_type (lhs), 0, 8870 NULL, NULL, NULL, NULL, &ind)) 8871 error (_("Unknown component name: %s."), name); 8872 lower = upper = ind; 8873 } 8874 8875 if (lower <= upper && (lower < low || upper > high)) 8876 error (_("Index in component association out of bounds.")); 8877 8878 add_component_interval (lower, upper, indices, num_indices, 8879 max_indices); 8880 while (lower <= upper) 8881 { 8882 int pos1; 8883 8884 pos1 = expr_pc; 8885 assign_component (container, lhs, lower, exp, &pos1); 8886 lower += 1; 8887 } 8888 } 8889 } 8890 8891 /* Assign the value of the expression in the OP_OTHERS construct in 8892 EXP at *POS into the components of LHS indexed from LOW .. HIGH that 8893 have not been previously assigned. The index intervals already assigned 8894 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the 8895 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */ 8896 static void 8897 aggregate_assign_others (struct value *container, 8898 struct value *lhs, struct expression *exp, 8899 int *pos, LONGEST *indices, int num_indices, 8900 LONGEST low, LONGEST high) 8901 { 8902 int i; 8903 int expr_pc = *pos + 1; 8904 8905 for (i = 0; i < num_indices - 2; i += 2) 8906 { 8907 LONGEST ind; 8908 8909 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1) 8910 { 8911 int localpos; 8912 8913 localpos = expr_pc; 8914 assign_component (container, lhs, ind, exp, &localpos); 8915 } 8916 } 8917 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP); 8918 } 8919 8920 /* Add the interval [LOW .. HIGH] to the sorted set of intervals 8921 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ], 8922 modifying *SIZE as needed. It is an error if *SIZE exceeds 8923 MAX_SIZE. The resulting intervals do not overlap. */ 8924 static void 8925 add_component_interval (LONGEST low, LONGEST high, 8926 LONGEST* indices, int *size, int max_size) 8927 { 8928 int i, j; 8929 8930 for (i = 0; i < *size; i += 2) { 8931 if (high >= indices[i] && low <= indices[i + 1]) 8932 { 8933 int kh; 8934 8935 for (kh = i + 2; kh < *size; kh += 2) 8936 if (high < indices[kh]) 8937 break; 8938 if (low < indices[i]) 8939 indices[i] = low; 8940 indices[i + 1] = indices[kh - 1]; 8941 if (high > indices[i + 1]) 8942 indices[i + 1] = high; 8943 memcpy (indices + i + 2, indices + kh, *size - kh); 8944 *size -= kh - i - 2; 8945 return; 8946 } 8947 else if (high < indices[i]) 8948 break; 8949 } 8950 8951 if (*size == max_size) 8952 error (_("Internal error: miscounted aggregate components.")); 8953 *size += 2; 8954 for (j = *size-1; j >= i+2; j -= 1) 8955 indices[j] = indices[j - 2]; 8956 indices[i] = low; 8957 indices[i + 1] = high; 8958 } 8959 8960 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2 8961 is different. */ 8962 8963 static struct value * 8964 ada_value_cast (struct type *type, struct value *arg2, enum noside noside) 8965 { 8966 if (type == ada_check_typedef (value_type (arg2))) 8967 return arg2; 8968 8969 if (ada_is_fixed_point_type (type)) 8970 return (cast_to_fixed (type, arg2)); 8971 8972 if (ada_is_fixed_point_type (value_type (arg2))) 8973 return cast_from_fixed (type, arg2); 8974 8975 return value_cast (type, arg2); 8976 } 8977 8978 /* Evaluating Ada expressions, and printing their result. 8979 ------------------------------------------------------ 8980 8981 1. Introduction: 8982 ---------------- 8983 8984 We usually evaluate an Ada expression in order to print its value. 8985 We also evaluate an expression in order to print its type, which 8986 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation, 8987 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the 8988 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of 8989 the evaluation compared to the EVAL_NORMAL, but is otherwise very 8990 similar. 8991 8992 Evaluating expressions is a little more complicated for Ada entities 8993 than it is for entities in languages such as C. The main reason for 8994 this is that Ada provides types whose definition might be dynamic. 8995 One example of such types is variant records. Or another example 8996 would be an array whose bounds can only be known at run time. 8997 8998 The following description is a general guide as to what should be 8999 done (and what should NOT be done) in order to evaluate an expression 9000 involving such types, and when. This does not cover how the semantic 9001 information is encoded by GNAT as this is covered separatly. For the 9002 document used as the reference for the GNAT encoding, see exp_dbug.ads 9003 in the GNAT sources. 9004 9005 Ideally, we should embed each part of this description next to its 9006 associated code. Unfortunately, the amount of code is so vast right 9007 now that it's hard to see whether the code handling a particular 9008 situation might be duplicated or not. One day, when the code is 9009 cleaned up, this guide might become redundant with the comments 9010 inserted in the code, and we might want to remove it. 9011 9012 2. ``Fixing'' an Entity, the Simple Case: 9013 ----------------------------------------- 9014 9015 When evaluating Ada expressions, the tricky issue is that they may 9016 reference entities whose type contents and size are not statically 9017 known. Consider for instance a variant record: 9018 9019 type Rec (Empty : Boolean := True) is record 9020 case Empty is 9021 when True => null; 9022 when False => Value : Integer; 9023 end case; 9024 end record; 9025 Yes : Rec := (Empty => False, Value => 1); 9026 No : Rec := (empty => True); 9027 9028 The size and contents of that record depends on the value of the 9029 descriminant (Rec.Empty). At this point, neither the debugging 9030 information nor the associated type structure in GDB are able to 9031 express such dynamic types. So what the debugger does is to create 9032 "fixed" versions of the type that applies to the specific object. 9033 We also informally refer to this opperation as "fixing" an object, 9034 which means creating its associated fixed type. 9035 9036 Example: when printing the value of variable "Yes" above, its fixed 9037 type would look like this: 9038 9039 type Rec is record 9040 Empty : Boolean; 9041 Value : Integer; 9042 end record; 9043 9044 On the other hand, if we printed the value of "No", its fixed type 9045 would become: 9046 9047 type Rec is record 9048 Empty : Boolean; 9049 end record; 9050 9051 Things become a little more complicated when trying to fix an entity 9052 with a dynamic type that directly contains another dynamic type, 9053 such as an array of variant records, for instance. There are 9054 two possible cases: Arrays, and records. 9055 9056 3. ``Fixing'' Arrays: 9057 --------------------- 9058 9059 The type structure in GDB describes an array in terms of its bounds, 9060 and the type of its elements. By design, all elements in the array 9061 have the same type and we cannot represent an array of variant elements 9062 using the current type structure in GDB. When fixing an array, 9063 we cannot fix the array element, as we would potentially need one 9064 fixed type per element of the array. As a result, the best we can do 9065 when fixing an array is to produce an array whose bounds and size 9066 are correct (allowing us to read it from memory), but without having 9067 touched its element type. Fixing each element will be done later, 9068 when (if) necessary. 9069 9070 Arrays are a little simpler to handle than records, because the same 9071 amount of memory is allocated for each element of the array, even if 9072 the amount of space actually used by each element differs from element 9073 to element. Consider for instance the following array of type Rec: 9074 9075 type Rec_Array is array (1 .. 2) of Rec; 9076 9077 The actual amount of memory occupied by each element might be different 9078 from element to element, depending on the value of their discriminant. 9079 But the amount of space reserved for each element in the array remains 9080 fixed regardless. So we simply need to compute that size using 9081 the debugging information available, from which we can then determine 9082 the array size (we multiply the number of elements of the array by 9083 the size of each element). 9084 9085 The simplest case is when we have an array of a constrained element 9086 type. For instance, consider the following type declarations: 9087 9088 type Bounded_String (Max_Size : Integer) is 9089 Length : Integer; 9090 Buffer : String (1 .. Max_Size); 9091 end record; 9092 type Bounded_String_Array is array (1 ..2) of Bounded_String (80); 9093 9094 In this case, the compiler describes the array as an array of 9095 variable-size elements (identified by its XVS suffix) for which 9096 the size can be read in the parallel XVZ variable. 9097 9098 In the case of an array of an unconstrained element type, the compiler 9099 wraps the array element inside a private PAD type. This type should not 9100 be shown to the user, and must be "unwrap"'ed before printing. Note 9101 that we also use the adjective "aligner" in our code to designate 9102 these wrapper types. 9103 9104 In some cases, the size allocated for each element is statically 9105 known. In that case, the PAD type already has the correct size, 9106 and the array element should remain unfixed. 9107 9108 But there are cases when this size is not statically known. 9109 For instance, assuming that "Five" is an integer variable: 9110 9111 type Dynamic is array (1 .. Five) of Integer; 9112 type Wrapper (Has_Length : Boolean := False) is record 9113 Data : Dynamic; 9114 case Has_Length is 9115 when True => Length : Integer; 9116 when False => null; 9117 end case; 9118 end record; 9119 type Wrapper_Array is array (1 .. 2) of Wrapper; 9120 9121 Hello : Wrapper_Array := (others => (Has_Length => True, 9122 Data => (others => 17), 9123 Length => 1)); 9124 9125 9126 The debugging info would describe variable Hello as being an 9127 array of a PAD type. The size of that PAD type is not statically 9128 known, but can be determined using a parallel XVZ variable. 9129 In that case, a copy of the PAD type with the correct size should 9130 be used for the fixed array. 9131 9132 3. ``Fixing'' record type objects: 9133 ---------------------------------- 9134 9135 Things are slightly different from arrays in the case of dynamic 9136 record types. In this case, in order to compute the associated 9137 fixed type, we need to determine the size and offset of each of 9138 its components. This, in turn, requires us to compute the fixed 9139 type of each of these components. 9140 9141 Consider for instance the example: 9142 9143 type Bounded_String (Max_Size : Natural) is record 9144 Str : String (1 .. Max_Size); 9145 Length : Natural; 9146 end record; 9147 My_String : Bounded_String (Max_Size => 10); 9148 9149 In that case, the position of field "Length" depends on the size 9150 of field Str, which itself depends on the value of the Max_Size 9151 discriminant. In order to fix the type of variable My_String, 9152 we need to fix the type of field Str. Therefore, fixing a variant 9153 record requires us to fix each of its components. 9154 9155 However, if a component does not have a dynamic size, the component 9156 should not be fixed. In particular, fields that use a PAD type 9157 should not fixed. Here is an example where this might happen 9158 (assuming type Rec above): 9159 9160 type Container (Big : Boolean) is record 9161 First : Rec; 9162 After : Integer; 9163 case Big is 9164 when True => Another : Integer; 9165 when False => null; 9166 end case; 9167 end record; 9168 My_Container : Container := (Big => False, 9169 First => (Empty => True), 9170 After => 42); 9171 9172 In that example, the compiler creates a PAD type for component First, 9173 whose size is constant, and then positions the component After just 9174 right after it. The offset of component After is therefore constant 9175 in this case. 9176 9177 The debugger computes the position of each field based on an algorithm 9178 that uses, among other things, the actual position and size of the field 9179 preceding it. Let's now imagine that the user is trying to print 9180 the value of My_Container. If the type fixing was recursive, we would 9181 end up computing the offset of field After based on the size of the 9182 fixed version of field First. And since in our example First has 9183 only one actual field, the size of the fixed type is actually smaller 9184 than the amount of space allocated to that field, and thus we would 9185 compute the wrong offset of field After. 9186 9187 To make things more complicated, we need to watch out for dynamic 9188 components of variant records (identified by the ___XVL suffix in 9189 the component name). Even if the target type is a PAD type, the size 9190 of that type might not be statically known. So the PAD type needs 9191 to be unwrapped and the resulting type needs to be fixed. Otherwise, 9192 we might end up with the wrong size for our component. This can be 9193 observed with the following type declarations: 9194 9195 type Octal is new Integer range 0 .. 7; 9196 type Octal_Array is array (Positive range <>) of Octal; 9197 pragma Pack (Octal_Array); 9198 9199 type Octal_Buffer (Size : Positive) is record 9200 Buffer : Octal_Array (1 .. Size); 9201 Length : Integer; 9202 end record; 9203 9204 In that case, Buffer is a PAD type whose size is unset and needs 9205 to be computed by fixing the unwrapped type. 9206 9207 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity: 9208 ---------------------------------------------------------- 9209 9210 Lastly, when should the sub-elements of an entity that remained unfixed 9211 thus far, be actually fixed? 9212 9213 The answer is: Only when referencing that element. For instance 9214 when selecting one component of a record, this specific component 9215 should be fixed at that point in time. Or when printing the value 9216 of a record, each component should be fixed before its value gets 9217 printed. Similarly for arrays, the element of the array should be 9218 fixed when printing each element of the array, or when extracting 9219 one element out of that array. On the other hand, fixing should 9220 not be performed on the elements when taking a slice of an array! 9221 9222 Note that one of the side-effects of miscomputing the offset and 9223 size of each field is that we end up also miscomputing the size 9224 of the containing type. This can have adverse results when computing 9225 the value of an entity. GDB fetches the value of an entity based 9226 on the size of its type, and thus a wrong size causes GDB to fetch 9227 the wrong amount of memory. In the case where the computed size is 9228 too small, GDB fetches too little data to print the value of our 9229 entiry. Results in this case as unpredicatble, as we usually read 9230 past the buffer containing the data =:-o. */ 9231 9232 /* Implement the evaluate_exp routine in the exp_descriptor structure 9233 for the Ada language. */ 9234 9235 static struct value * 9236 ada_evaluate_subexp (struct type *expect_type, struct expression *exp, 9237 int *pos, enum noside noside) 9238 { 9239 enum exp_opcode op; 9240 int tem; 9241 int pc; 9242 struct value *arg1 = NULL, *arg2 = NULL, *arg3; 9243 struct type *type; 9244 int nargs, oplen; 9245 struct value **argvec; 9246 9247 pc = *pos; 9248 *pos += 1; 9249 op = exp->elts[pc].opcode; 9250 9251 switch (op) 9252 { 9253 default: 9254 *pos -= 1; 9255 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside); 9256 arg1 = unwrap_value (arg1); 9257 9258 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided, 9259 then we need to perform the conversion manually, because 9260 evaluate_subexp_standard doesn't do it. This conversion is 9261 necessary in Ada because the different kinds of float/fixed 9262 types in Ada have different representations. 9263 9264 Similarly, we need to perform the conversion from OP_LONG 9265 ourselves. */ 9266 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL) 9267 arg1 = ada_value_cast (expect_type, arg1, noside); 9268 9269 return arg1; 9270 9271 case OP_STRING: 9272 { 9273 struct value *result; 9274 9275 *pos -= 1; 9276 result = evaluate_subexp_standard (expect_type, exp, pos, noside); 9277 /* The result type will have code OP_STRING, bashed there from 9278 OP_ARRAY. Bash it back. */ 9279 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING) 9280 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY; 9281 return result; 9282 } 9283 9284 case UNOP_CAST: 9285 (*pos) += 2; 9286 type = exp->elts[pc + 1].type; 9287 arg1 = evaluate_subexp (type, exp, pos, noside); 9288 if (noside == EVAL_SKIP) 9289 goto nosideret; 9290 arg1 = ada_value_cast (type, arg1, noside); 9291 return arg1; 9292 9293 case UNOP_QUAL: 9294 (*pos) += 2; 9295 type = exp->elts[pc + 1].type; 9296 return ada_evaluate_subexp (type, exp, pos, noside); 9297 9298 case BINOP_ASSIGN: 9299 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9300 if (exp->elts[*pos].opcode == OP_AGGREGATE) 9301 { 9302 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside); 9303 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS) 9304 return arg1; 9305 return ada_value_assign (arg1, arg1); 9306 } 9307 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1, 9308 except if the lhs of our assignment is a convenience variable. 9309 In the case of assigning to a convenience variable, the lhs 9310 should be exactly the result of the evaluation of the rhs. */ 9311 type = value_type (arg1); 9312 if (VALUE_LVAL (arg1) == lval_internalvar) 9313 type = NULL; 9314 arg2 = evaluate_subexp (type, exp, pos, noside); 9315 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS) 9316 return arg1; 9317 if (ada_is_fixed_point_type (value_type (arg1))) 9318 arg2 = cast_to_fixed (value_type (arg1), arg2); 9319 else if (ada_is_fixed_point_type (value_type (arg2))) 9320 error 9321 (_("Fixed-point values must be assigned to fixed-point variables")); 9322 else 9323 arg2 = coerce_for_assign (value_type (arg1), arg2); 9324 return ada_value_assign (arg1, arg2); 9325 9326 case BINOP_ADD: 9327 arg1 = evaluate_subexp_with_coercion (exp, pos, noside); 9328 arg2 = evaluate_subexp_with_coercion (exp, pos, noside); 9329 if (noside == EVAL_SKIP) 9330 goto nosideret; 9331 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR) 9332 return (value_from_longest 9333 (value_type (arg1), 9334 value_as_long (arg1) + value_as_long (arg2))); 9335 if ((ada_is_fixed_point_type (value_type (arg1)) 9336 || ada_is_fixed_point_type (value_type (arg2))) 9337 && value_type (arg1) != value_type (arg2)) 9338 error (_("Operands of fixed-point addition must have the same type")); 9339 /* Do the addition, and cast the result to the type of the first 9340 argument. We cannot cast the result to a reference type, so if 9341 ARG1 is a reference type, find its underlying type. */ 9342 type = value_type (arg1); 9343 while (TYPE_CODE (type) == TYPE_CODE_REF) 9344 type = TYPE_TARGET_TYPE (type); 9345 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 9346 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD)); 9347 9348 case BINOP_SUB: 9349 arg1 = evaluate_subexp_with_coercion (exp, pos, noside); 9350 arg2 = evaluate_subexp_with_coercion (exp, pos, noside); 9351 if (noside == EVAL_SKIP) 9352 goto nosideret; 9353 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR) 9354 return (value_from_longest 9355 (value_type (arg1), 9356 value_as_long (arg1) - value_as_long (arg2))); 9357 if ((ada_is_fixed_point_type (value_type (arg1)) 9358 || ada_is_fixed_point_type (value_type (arg2))) 9359 && value_type (arg1) != value_type (arg2)) 9360 error (_("Operands of fixed-point subtraction " 9361 "must have the same type")); 9362 /* Do the substraction, and cast the result to the type of the first 9363 argument. We cannot cast the result to a reference type, so if 9364 ARG1 is a reference type, find its underlying type. */ 9365 type = value_type (arg1); 9366 while (TYPE_CODE (type) == TYPE_CODE_REF) 9367 type = TYPE_TARGET_TYPE (type); 9368 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 9369 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB)); 9370 9371 case BINOP_MUL: 9372 case BINOP_DIV: 9373 case BINOP_REM: 9374 case BINOP_MOD: 9375 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9376 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9377 if (noside == EVAL_SKIP) 9378 goto nosideret; 9379 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 9380 { 9381 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 9382 return value_zero (value_type (arg1), not_lval); 9383 } 9384 else 9385 { 9386 type = builtin_type (exp->gdbarch)->builtin_double; 9387 if (ada_is_fixed_point_type (value_type (arg1))) 9388 arg1 = cast_from_fixed (type, arg1); 9389 if (ada_is_fixed_point_type (value_type (arg2))) 9390 arg2 = cast_from_fixed (type, arg2); 9391 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 9392 return ada_value_binop (arg1, arg2, op); 9393 } 9394 9395 case BINOP_EQUAL: 9396 case BINOP_NOTEQUAL: 9397 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9398 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside); 9399 if (noside == EVAL_SKIP) 9400 goto nosideret; 9401 if (noside == EVAL_AVOID_SIDE_EFFECTS) 9402 tem = 0; 9403 else 9404 { 9405 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 9406 tem = ada_value_equal (arg1, arg2); 9407 } 9408 if (op == BINOP_NOTEQUAL) 9409 tem = !tem; 9410 type = language_bool_type (exp->language_defn, exp->gdbarch); 9411 return value_from_longest (type, (LONGEST) tem); 9412 9413 case UNOP_NEG: 9414 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9415 if (noside == EVAL_SKIP) 9416 goto nosideret; 9417 else if (ada_is_fixed_point_type (value_type (arg1))) 9418 return value_cast (value_type (arg1), value_neg (arg1)); 9419 else 9420 { 9421 unop_promote (exp->language_defn, exp->gdbarch, &arg1); 9422 return value_neg (arg1); 9423 } 9424 9425 case BINOP_LOGICAL_AND: 9426 case BINOP_LOGICAL_OR: 9427 case UNOP_LOGICAL_NOT: 9428 { 9429 struct value *val; 9430 9431 *pos -= 1; 9432 val = evaluate_subexp_standard (expect_type, exp, pos, noside); 9433 type = language_bool_type (exp->language_defn, exp->gdbarch); 9434 return value_cast (type, val); 9435 } 9436 9437 case BINOP_BITWISE_AND: 9438 case BINOP_BITWISE_IOR: 9439 case BINOP_BITWISE_XOR: 9440 { 9441 struct value *val; 9442 9443 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS); 9444 *pos = pc; 9445 val = evaluate_subexp_standard (expect_type, exp, pos, noside); 9446 9447 return value_cast (value_type (arg1), val); 9448 } 9449 9450 case OP_VAR_VALUE: 9451 *pos -= 1; 9452 9453 if (noside == EVAL_SKIP) 9454 { 9455 *pos += 4; 9456 goto nosideret; 9457 } 9458 else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN) 9459 /* Only encountered when an unresolved symbol occurs in a 9460 context other than a function call, in which case, it is 9461 invalid. */ 9462 error (_("Unexpected unresolved symbol, %s, during evaluation"), 9463 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol)); 9464 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 9465 { 9466 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol)); 9467 /* Check to see if this is a tagged type. We also need to handle 9468 the case where the type is a reference to a tagged type, but 9469 we have to be careful to exclude pointers to tagged types. 9470 The latter should be shown as usual (as a pointer), whereas 9471 a reference should mostly be transparent to the user. */ 9472 if (ada_is_tagged_type (type, 0) 9473 || (TYPE_CODE(type) == TYPE_CODE_REF 9474 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))) 9475 { 9476 /* Tagged types are a little special in the fact that the real 9477 type is dynamic and can only be determined by inspecting the 9478 object's tag. This means that we need to get the object's 9479 value first (EVAL_NORMAL) and then extract the actual object 9480 type from its tag. 9481 9482 Note that we cannot skip the final step where we extract 9483 the object type from its tag, because the EVAL_NORMAL phase 9484 results in dynamic components being resolved into fixed ones. 9485 This can cause problems when trying to print the type 9486 description of tagged types whose parent has a dynamic size: 9487 We use the type name of the "_parent" component in order 9488 to print the name of the ancestor type in the type description. 9489 If that component had a dynamic size, the resolution into 9490 a fixed type would result in the loss of that type name, 9491 thus preventing us from printing the name of the ancestor 9492 type in the type description. */ 9493 struct type *actual_type; 9494 9495 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL); 9496 actual_type = type_from_tag (ada_value_tag (arg1)); 9497 if (actual_type == NULL) 9498 /* If, for some reason, we were unable to determine 9499 the actual type from the tag, then use the static 9500 approximation that we just computed as a fallback. 9501 This can happen if the debugging information is 9502 incomplete, for instance. */ 9503 actual_type = type; 9504 9505 return value_zero (actual_type, not_lval); 9506 } 9507 9508 *pos += 4; 9509 return value_zero 9510 (to_static_fixed_type 9511 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))), 9512 not_lval); 9513 } 9514 else 9515 { 9516 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside); 9517 arg1 = unwrap_value (arg1); 9518 return ada_to_fixed_value (arg1); 9519 } 9520 9521 case OP_FUNCALL: 9522 (*pos) += 2; 9523 9524 /* Allocate arg vector, including space for the function to be 9525 called in argvec[0] and a terminating NULL. */ 9526 nargs = longest_to_int (exp->elts[pc + 1].longconst); 9527 argvec = 9528 (struct value **) alloca (sizeof (struct value *) * (nargs + 2)); 9529 9530 if (exp->elts[*pos].opcode == OP_VAR_VALUE 9531 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN) 9532 error (_("Unexpected unresolved symbol, %s, during evaluation"), 9533 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol)); 9534 else 9535 { 9536 for (tem = 0; tem <= nargs; tem += 1) 9537 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9538 argvec[tem] = 0; 9539 9540 if (noside == EVAL_SKIP) 9541 goto nosideret; 9542 } 9543 9544 if (ada_is_constrained_packed_array_type 9545 (desc_base_type (value_type (argvec[0])))) 9546 argvec[0] = ada_coerce_to_simple_array (argvec[0]); 9547 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY 9548 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0) 9549 /* This is a packed array that has already been fixed, and 9550 therefore already coerced to a simple array. Nothing further 9551 to do. */ 9552 ; 9553 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF 9554 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY 9555 && VALUE_LVAL (argvec[0]) == lval_memory)) 9556 argvec[0] = value_addr (argvec[0]); 9557 9558 type = ada_check_typedef (value_type (argvec[0])); 9559 9560 /* Ada allows us to implicitly dereference arrays when subscripting 9561 them. So, if this is an array typedef (encoding use for array 9562 access types encoded as fat pointers), strip it now. */ 9563 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) 9564 type = ada_typedef_target_type (type); 9565 9566 if (TYPE_CODE (type) == TYPE_CODE_PTR) 9567 { 9568 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))) 9569 { 9570 case TYPE_CODE_FUNC: 9571 type = ada_check_typedef (TYPE_TARGET_TYPE (type)); 9572 break; 9573 case TYPE_CODE_ARRAY: 9574 break; 9575 case TYPE_CODE_STRUCT: 9576 if (noside != EVAL_AVOID_SIDE_EFFECTS) 9577 argvec[0] = ada_value_ind (argvec[0]); 9578 type = ada_check_typedef (TYPE_TARGET_TYPE (type)); 9579 break; 9580 default: 9581 error (_("cannot subscript or call something of type `%s'"), 9582 ada_type_name (value_type (argvec[0]))); 9583 break; 9584 } 9585 } 9586 9587 switch (TYPE_CODE (type)) 9588 { 9589 case TYPE_CODE_FUNC: 9590 if (noside == EVAL_AVOID_SIDE_EFFECTS) 9591 return allocate_value (TYPE_TARGET_TYPE (type)); 9592 return call_function_by_hand (argvec[0], nargs, argvec + 1); 9593 case TYPE_CODE_STRUCT: 9594 { 9595 int arity; 9596 9597 arity = ada_array_arity (type); 9598 type = ada_array_element_type (type, nargs); 9599 if (type == NULL) 9600 error (_("cannot subscript or call a record")); 9601 if (arity != nargs) 9602 error (_("wrong number of subscripts; expecting %d"), arity); 9603 if (noside == EVAL_AVOID_SIDE_EFFECTS) 9604 return value_zero (ada_aligned_type (type), lval_memory); 9605 return 9606 unwrap_value (ada_value_subscript 9607 (argvec[0], nargs, argvec + 1)); 9608 } 9609 case TYPE_CODE_ARRAY: 9610 if (noside == EVAL_AVOID_SIDE_EFFECTS) 9611 { 9612 type = ada_array_element_type (type, nargs); 9613 if (type == NULL) 9614 error (_("element type of array unknown")); 9615 else 9616 return value_zero (ada_aligned_type (type), lval_memory); 9617 } 9618 return 9619 unwrap_value (ada_value_subscript 9620 (ada_coerce_to_simple_array (argvec[0]), 9621 nargs, argvec + 1)); 9622 case TYPE_CODE_PTR: /* Pointer to array */ 9623 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1); 9624 if (noside == EVAL_AVOID_SIDE_EFFECTS) 9625 { 9626 type = ada_array_element_type (type, nargs); 9627 if (type == NULL) 9628 error (_("element type of array unknown")); 9629 else 9630 return value_zero (ada_aligned_type (type), lval_memory); 9631 } 9632 return 9633 unwrap_value (ada_value_ptr_subscript (argvec[0], type, 9634 nargs, argvec + 1)); 9635 9636 default: 9637 error (_("Attempt to index or call something other than an " 9638 "array or function")); 9639 } 9640 9641 case TERNOP_SLICE: 9642 { 9643 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9644 struct value *low_bound_val = 9645 evaluate_subexp (NULL_TYPE, exp, pos, noside); 9646 struct value *high_bound_val = 9647 evaluate_subexp (NULL_TYPE, exp, pos, noside); 9648 LONGEST low_bound; 9649 LONGEST high_bound; 9650 9651 low_bound_val = coerce_ref (low_bound_val); 9652 high_bound_val = coerce_ref (high_bound_val); 9653 low_bound = pos_atr (low_bound_val); 9654 high_bound = pos_atr (high_bound_val); 9655 9656 if (noside == EVAL_SKIP) 9657 goto nosideret; 9658 9659 /* If this is a reference to an aligner type, then remove all 9660 the aligners. */ 9661 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF 9662 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array)))) 9663 TYPE_TARGET_TYPE (value_type (array)) = 9664 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array))); 9665 9666 if (ada_is_constrained_packed_array_type (value_type (array))) 9667 error (_("cannot slice a packed array")); 9668 9669 /* If this is a reference to an array or an array lvalue, 9670 convert to a pointer. */ 9671 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF 9672 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY 9673 && VALUE_LVAL (array) == lval_memory)) 9674 array = value_addr (array); 9675 9676 if (noside == EVAL_AVOID_SIDE_EFFECTS 9677 && ada_is_array_descriptor_type (ada_check_typedef 9678 (value_type (array)))) 9679 return empty_array (ada_type_of_array (array, 0), low_bound); 9680 9681 array = ada_coerce_to_simple_array_ptr (array); 9682 9683 /* If we have more than one level of pointer indirection, 9684 dereference the value until we get only one level. */ 9685 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR 9686 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array))) 9687 == TYPE_CODE_PTR)) 9688 array = value_ind (array); 9689 9690 /* Make sure we really do have an array type before going further, 9691 to avoid a SEGV when trying to get the index type or the target 9692 type later down the road if the debug info generated by 9693 the compiler is incorrect or incomplete. */ 9694 if (!ada_is_simple_array_type (value_type (array))) 9695 error (_("cannot take slice of non-array")); 9696 9697 if (TYPE_CODE (ada_check_typedef (value_type (array))) 9698 == TYPE_CODE_PTR) 9699 { 9700 struct type *type0 = ada_check_typedef (value_type (array)); 9701 9702 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS) 9703 return empty_array (TYPE_TARGET_TYPE (type0), low_bound); 9704 else 9705 { 9706 struct type *arr_type0 = 9707 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1); 9708 9709 return ada_value_slice_from_ptr (array, arr_type0, 9710 longest_to_int (low_bound), 9711 longest_to_int (high_bound)); 9712 } 9713 } 9714 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 9715 return array; 9716 else if (high_bound < low_bound) 9717 return empty_array (value_type (array), low_bound); 9718 else 9719 return ada_value_slice (array, longest_to_int (low_bound), 9720 longest_to_int (high_bound)); 9721 } 9722 9723 case UNOP_IN_RANGE: 9724 (*pos) += 2; 9725 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9726 type = check_typedef (exp->elts[pc + 1].type); 9727 9728 if (noside == EVAL_SKIP) 9729 goto nosideret; 9730 9731 switch (TYPE_CODE (type)) 9732 { 9733 default: 9734 lim_warning (_("Membership test incompletely implemented; " 9735 "always returns true")); 9736 type = language_bool_type (exp->language_defn, exp->gdbarch); 9737 return value_from_longest (type, (LONGEST) 1); 9738 9739 case TYPE_CODE_RANGE: 9740 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type)); 9741 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type)); 9742 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 9743 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3); 9744 type = language_bool_type (exp->language_defn, exp->gdbarch); 9745 return 9746 value_from_longest (type, 9747 (value_less (arg1, arg3) 9748 || value_equal (arg1, arg3)) 9749 && (value_less (arg2, arg1) 9750 || value_equal (arg2, arg1))); 9751 } 9752 9753 case BINOP_IN_BOUNDS: 9754 (*pos) += 2; 9755 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9756 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9757 9758 if (noside == EVAL_SKIP) 9759 goto nosideret; 9760 9761 if (noside == EVAL_AVOID_SIDE_EFFECTS) 9762 { 9763 type = language_bool_type (exp->language_defn, exp->gdbarch); 9764 return value_zero (type, not_lval); 9765 } 9766 9767 tem = longest_to_int (exp->elts[pc + 1].longconst); 9768 9769 type = ada_index_type (value_type (arg2), tem, "range"); 9770 if (!type) 9771 type = value_type (arg1); 9772 9773 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1)); 9774 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0)); 9775 9776 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 9777 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3); 9778 type = language_bool_type (exp->language_defn, exp->gdbarch); 9779 return 9780 value_from_longest (type, 9781 (value_less (arg1, arg3) 9782 || value_equal (arg1, arg3)) 9783 && (value_less (arg2, arg1) 9784 || value_equal (arg2, arg1))); 9785 9786 case TERNOP_IN_RANGE: 9787 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9788 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9789 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9790 9791 if (noside == EVAL_SKIP) 9792 goto nosideret; 9793 9794 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 9795 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3); 9796 type = language_bool_type (exp->language_defn, exp->gdbarch); 9797 return 9798 value_from_longest (type, 9799 (value_less (arg1, arg3) 9800 || value_equal (arg1, arg3)) 9801 && (value_less (arg2, arg1) 9802 || value_equal (arg2, arg1))); 9803 9804 case OP_ATR_FIRST: 9805 case OP_ATR_LAST: 9806 case OP_ATR_LENGTH: 9807 { 9808 struct type *type_arg; 9809 9810 if (exp->elts[*pos].opcode == OP_TYPE) 9811 { 9812 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP); 9813 arg1 = NULL; 9814 type_arg = check_typedef (exp->elts[pc + 2].type); 9815 } 9816 else 9817 { 9818 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9819 type_arg = NULL; 9820 } 9821 9822 if (exp->elts[*pos].opcode != OP_LONG) 9823 error (_("Invalid operand to '%s"), ada_attribute_name (op)); 9824 tem = longest_to_int (exp->elts[*pos + 2].longconst); 9825 *pos += 4; 9826 9827 if (noside == EVAL_SKIP) 9828 goto nosideret; 9829 9830 if (type_arg == NULL) 9831 { 9832 arg1 = ada_coerce_ref (arg1); 9833 9834 if (ada_is_constrained_packed_array_type (value_type (arg1))) 9835 arg1 = ada_coerce_to_simple_array (arg1); 9836 9837 type = ada_index_type (value_type (arg1), tem, 9838 ada_attribute_name (op)); 9839 if (type == NULL) 9840 type = builtin_type (exp->gdbarch)->builtin_int; 9841 9842 if (noside == EVAL_AVOID_SIDE_EFFECTS) 9843 return allocate_value (type); 9844 9845 switch (op) 9846 { 9847 default: /* Should never happen. */ 9848 error (_("unexpected attribute encountered")); 9849 case OP_ATR_FIRST: 9850 return value_from_longest 9851 (type, ada_array_bound (arg1, tem, 0)); 9852 case OP_ATR_LAST: 9853 return value_from_longest 9854 (type, ada_array_bound (arg1, tem, 1)); 9855 case OP_ATR_LENGTH: 9856 return value_from_longest 9857 (type, ada_array_length (arg1, tem)); 9858 } 9859 } 9860 else if (discrete_type_p (type_arg)) 9861 { 9862 struct type *range_type; 9863 char *name = ada_type_name (type_arg); 9864 9865 range_type = NULL; 9866 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM) 9867 range_type = to_fixed_range_type (type_arg, NULL); 9868 if (range_type == NULL) 9869 range_type = type_arg; 9870 switch (op) 9871 { 9872 default: 9873 error (_("unexpected attribute encountered")); 9874 case OP_ATR_FIRST: 9875 return value_from_longest 9876 (range_type, ada_discrete_type_low_bound (range_type)); 9877 case OP_ATR_LAST: 9878 return value_from_longest 9879 (range_type, ada_discrete_type_high_bound (range_type)); 9880 case OP_ATR_LENGTH: 9881 error (_("the 'length attribute applies only to array types")); 9882 } 9883 } 9884 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT) 9885 error (_("unimplemented type attribute")); 9886 else 9887 { 9888 LONGEST low, high; 9889 9890 if (ada_is_constrained_packed_array_type (type_arg)) 9891 type_arg = decode_constrained_packed_array_type (type_arg); 9892 9893 type = ada_index_type (type_arg, tem, ada_attribute_name (op)); 9894 if (type == NULL) 9895 type = builtin_type (exp->gdbarch)->builtin_int; 9896 9897 if (noside == EVAL_AVOID_SIDE_EFFECTS) 9898 return allocate_value (type); 9899 9900 switch (op) 9901 { 9902 default: 9903 error (_("unexpected attribute encountered")); 9904 case OP_ATR_FIRST: 9905 low = ada_array_bound_from_type (type_arg, tem, 0); 9906 return value_from_longest (type, low); 9907 case OP_ATR_LAST: 9908 high = ada_array_bound_from_type (type_arg, tem, 1); 9909 return value_from_longest (type, high); 9910 case OP_ATR_LENGTH: 9911 low = ada_array_bound_from_type (type_arg, tem, 0); 9912 high = ada_array_bound_from_type (type_arg, tem, 1); 9913 return value_from_longest (type, high - low + 1); 9914 } 9915 } 9916 } 9917 9918 case OP_ATR_TAG: 9919 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9920 if (noside == EVAL_SKIP) 9921 goto nosideret; 9922 9923 if (noside == EVAL_AVOID_SIDE_EFFECTS) 9924 return value_zero (ada_tag_type (arg1), not_lval); 9925 9926 return ada_value_tag (arg1); 9927 9928 case OP_ATR_MIN: 9929 case OP_ATR_MAX: 9930 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP); 9931 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9932 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9933 if (noside == EVAL_SKIP) 9934 goto nosideret; 9935 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 9936 return value_zero (value_type (arg1), not_lval); 9937 else 9938 { 9939 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 9940 return value_binop (arg1, arg2, 9941 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX); 9942 } 9943 9944 case OP_ATR_MODULUS: 9945 { 9946 struct type *type_arg = check_typedef (exp->elts[pc + 2].type); 9947 9948 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP); 9949 if (noside == EVAL_SKIP) 9950 goto nosideret; 9951 9952 if (!ada_is_modular_type (type_arg)) 9953 error (_("'modulus must be applied to modular type")); 9954 9955 return value_from_longest (TYPE_TARGET_TYPE (type_arg), 9956 ada_modulus (type_arg)); 9957 } 9958 9959 9960 case OP_ATR_POS: 9961 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP); 9962 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9963 if (noside == EVAL_SKIP) 9964 goto nosideret; 9965 type = builtin_type (exp->gdbarch)->builtin_int; 9966 if (noside == EVAL_AVOID_SIDE_EFFECTS) 9967 return value_zero (type, not_lval); 9968 else 9969 return value_pos_atr (type, arg1); 9970 9971 case OP_ATR_SIZE: 9972 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9973 type = value_type (arg1); 9974 9975 /* If the argument is a reference, then dereference its type, since 9976 the user is really asking for the size of the actual object, 9977 not the size of the pointer. */ 9978 if (TYPE_CODE (type) == TYPE_CODE_REF) 9979 type = TYPE_TARGET_TYPE (type); 9980 9981 if (noside == EVAL_SKIP) 9982 goto nosideret; 9983 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 9984 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval); 9985 else 9986 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 9987 TARGET_CHAR_BIT * TYPE_LENGTH (type)); 9988 9989 case OP_ATR_VAL: 9990 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP); 9991 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 9992 type = exp->elts[pc + 2].type; 9993 if (noside == EVAL_SKIP) 9994 goto nosideret; 9995 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 9996 return value_zero (type, not_lval); 9997 else 9998 return value_val_atr (type, arg1); 9999 10000 case BINOP_EXP: 10001 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10002 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10003 if (noside == EVAL_SKIP) 10004 goto nosideret; 10005 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 10006 return value_zero (value_type (arg1), not_lval); 10007 else 10008 { 10009 /* For integer exponentiation operations, 10010 only promote the first argument. */ 10011 if (is_integral_type (value_type (arg2))) 10012 unop_promote (exp->language_defn, exp->gdbarch, &arg1); 10013 else 10014 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 10015 10016 return value_binop (arg1, arg2, op); 10017 } 10018 10019 case UNOP_PLUS: 10020 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10021 if (noside == EVAL_SKIP) 10022 goto nosideret; 10023 else 10024 return arg1; 10025 10026 case UNOP_ABS: 10027 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10028 if (noside == EVAL_SKIP) 10029 goto nosideret; 10030 unop_promote (exp->language_defn, exp->gdbarch, &arg1); 10031 if (value_less (arg1, value_zero (value_type (arg1), not_lval))) 10032 return value_neg (arg1); 10033 else 10034 return arg1; 10035 10036 case UNOP_IND: 10037 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10038 if (noside == EVAL_SKIP) 10039 goto nosideret; 10040 type = ada_check_typedef (value_type (arg1)); 10041 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10042 { 10043 if (ada_is_array_descriptor_type (type)) 10044 /* GDB allows dereferencing GNAT array descriptors. */ 10045 { 10046 struct type *arrType = ada_type_of_array (arg1, 0); 10047 10048 if (arrType == NULL) 10049 error (_("Attempt to dereference null array pointer.")); 10050 return value_at_lazy (arrType, 0); 10051 } 10052 else if (TYPE_CODE (type) == TYPE_CODE_PTR 10053 || TYPE_CODE (type) == TYPE_CODE_REF 10054 /* In C you can dereference an array to get the 1st elt. */ 10055 || TYPE_CODE (type) == TYPE_CODE_ARRAY) 10056 { 10057 type = to_static_fixed_type 10058 (ada_aligned_type 10059 (ada_check_typedef (TYPE_TARGET_TYPE (type)))); 10060 check_size (type); 10061 return value_zero (type, lval_memory); 10062 } 10063 else if (TYPE_CODE (type) == TYPE_CODE_INT) 10064 { 10065 /* GDB allows dereferencing an int. */ 10066 if (expect_type == NULL) 10067 return value_zero (builtin_type (exp->gdbarch)->builtin_int, 10068 lval_memory); 10069 else 10070 { 10071 expect_type = 10072 to_static_fixed_type (ada_aligned_type (expect_type)); 10073 return value_zero (expect_type, lval_memory); 10074 } 10075 } 10076 else 10077 error (_("Attempt to take contents of a non-pointer value.")); 10078 } 10079 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */ 10080 type = ada_check_typedef (value_type (arg1)); 10081 10082 if (TYPE_CODE (type) == TYPE_CODE_INT) 10083 /* GDB allows dereferencing an int. If we were given 10084 the expect_type, then use that as the target type. 10085 Otherwise, assume that the target type is an int. */ 10086 { 10087 if (expect_type != NULL) 10088 return ada_value_ind (value_cast (lookup_pointer_type (expect_type), 10089 arg1)); 10090 else 10091 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int, 10092 (CORE_ADDR) value_as_address (arg1)); 10093 } 10094 10095 if (ada_is_array_descriptor_type (type)) 10096 /* GDB allows dereferencing GNAT array descriptors. */ 10097 return ada_coerce_to_simple_array (arg1); 10098 else 10099 return ada_value_ind (arg1); 10100 10101 case STRUCTOP_STRUCT: 10102 tem = longest_to_int (exp->elts[pc + 1].longconst); 10103 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1); 10104 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10105 if (noside == EVAL_SKIP) 10106 goto nosideret; 10107 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10108 { 10109 struct type *type1 = value_type (arg1); 10110 10111 if (ada_is_tagged_type (type1, 1)) 10112 { 10113 type = ada_lookup_struct_elt_type (type1, 10114 &exp->elts[pc + 2].string, 10115 1, 1, NULL); 10116 if (type == NULL) 10117 /* In this case, we assume that the field COULD exist 10118 in some extension of the type. Return an object of 10119 "type" void, which will match any formal 10120 (see ada_type_match). */ 10121 return value_zero (builtin_type (exp->gdbarch)->builtin_void, 10122 lval_memory); 10123 } 10124 else 10125 type = 10126 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1, 10127 0, NULL); 10128 10129 return value_zero (ada_aligned_type (type), lval_memory); 10130 } 10131 else 10132 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0); 10133 arg1 = unwrap_value (arg1); 10134 return ada_to_fixed_value (arg1); 10135 10136 case OP_TYPE: 10137 /* The value is not supposed to be used. This is here to make it 10138 easier to accommodate expressions that contain types. */ 10139 (*pos) += 2; 10140 if (noside == EVAL_SKIP) 10141 goto nosideret; 10142 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 10143 return allocate_value (exp->elts[pc + 1].type); 10144 else 10145 error (_("Attempt to use a type name as an expression")); 10146 10147 case OP_AGGREGATE: 10148 case OP_CHOICES: 10149 case OP_OTHERS: 10150 case OP_DISCRETE_RANGE: 10151 case OP_POSITIONAL: 10152 case OP_NAME: 10153 if (noside == EVAL_NORMAL) 10154 switch (op) 10155 { 10156 case OP_NAME: 10157 error (_("Undefined name, ambiguous name, or renaming used in " 10158 "component association: %s."), &exp->elts[pc+2].string); 10159 case OP_AGGREGATE: 10160 error (_("Aggregates only allowed on the right of an assignment")); 10161 default: 10162 internal_error (__FILE__, __LINE__, 10163 _("aggregate apparently mangled")); 10164 } 10165 10166 ada_forward_operator_length (exp, pc, &oplen, &nargs); 10167 *pos += oplen - 1; 10168 for (tem = 0; tem < nargs; tem += 1) 10169 ada_evaluate_subexp (NULL, exp, pos, noside); 10170 goto nosideret; 10171 } 10172 10173 nosideret: 10174 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1); 10175 } 10176 10177 10178 /* Fixed point */ 10179 10180 /* If TYPE encodes an Ada fixed-point type, return the suffix of the 10181 type name that encodes the 'small and 'delta information. 10182 Otherwise, return NULL. */ 10183 10184 static const char * 10185 fixed_type_info (struct type *type) 10186 { 10187 const char *name = ada_type_name (type); 10188 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type); 10189 10190 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL) 10191 { 10192 const char *tail = strstr (name, "___XF_"); 10193 10194 if (tail == NULL) 10195 return NULL; 10196 else 10197 return tail + 5; 10198 } 10199 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type) 10200 return fixed_type_info (TYPE_TARGET_TYPE (type)); 10201 else 10202 return NULL; 10203 } 10204 10205 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */ 10206 10207 int 10208 ada_is_fixed_point_type (struct type *type) 10209 { 10210 return fixed_type_info (type) != NULL; 10211 } 10212 10213 /* Return non-zero iff TYPE represents a System.Address type. */ 10214 10215 int 10216 ada_is_system_address_type (struct type *type) 10217 { 10218 return (TYPE_NAME (type) 10219 && strcmp (TYPE_NAME (type), "system__address") == 0); 10220 } 10221 10222 /* Assuming that TYPE is the representation of an Ada fixed-point 10223 type, return its delta, or -1 if the type is malformed and the 10224 delta cannot be determined. */ 10225 10226 DOUBLEST 10227 ada_delta (struct type *type) 10228 { 10229 const char *encoding = fixed_type_info (type); 10230 DOUBLEST num, den; 10231 10232 /* Strictly speaking, num and den are encoded as integer. However, 10233 they may not fit into a long, and they will have to be converted 10234 to DOUBLEST anyway. So scan them as DOUBLEST. */ 10235 if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT, 10236 &num, &den) < 2) 10237 return -1.0; 10238 else 10239 return num / den; 10240 } 10241 10242 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling 10243 factor ('SMALL value) associated with the type. */ 10244 10245 static DOUBLEST 10246 scaling_factor (struct type *type) 10247 { 10248 const char *encoding = fixed_type_info (type); 10249 DOUBLEST num0, den0, num1, den1; 10250 int n; 10251 10252 /* Strictly speaking, num's and den's are encoded as integer. However, 10253 they may not fit into a long, and they will have to be converted 10254 to DOUBLEST anyway. So scan them as DOUBLEST. */ 10255 n = sscanf (encoding, 10256 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT 10257 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT, 10258 &num0, &den0, &num1, &den1); 10259 10260 if (n < 2) 10261 return 1.0; 10262 else if (n == 4) 10263 return num1 / den1; 10264 else 10265 return num0 / den0; 10266 } 10267 10268 10269 /* Assuming that X is the representation of a value of fixed-point 10270 type TYPE, return its floating-point equivalent. */ 10271 10272 DOUBLEST 10273 ada_fixed_to_float (struct type *type, LONGEST x) 10274 { 10275 return (DOUBLEST) x *scaling_factor (type); 10276 } 10277 10278 /* The representation of a fixed-point value of type TYPE 10279 corresponding to the value X. */ 10280 10281 LONGEST 10282 ada_float_to_fixed (struct type *type, DOUBLEST x) 10283 { 10284 return (LONGEST) (x / scaling_factor (type) + 0.5); 10285 } 10286 10287 10288 10289 /* Range types */ 10290 10291 /* Scan STR beginning at position K for a discriminant name, and 10292 return the value of that discriminant field of DVAL in *PX. If 10293 PNEW_K is not null, put the position of the character beyond the 10294 name scanned in *PNEW_K. Return 1 if successful; return 0 and do 10295 not alter *PX and *PNEW_K if unsuccessful. */ 10296 10297 static int 10298 scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px, 10299 int *pnew_k) 10300 { 10301 static char *bound_buffer = NULL; 10302 static size_t bound_buffer_len = 0; 10303 char *bound; 10304 char *pend; 10305 struct value *bound_val; 10306 10307 if (dval == NULL || str == NULL || str[k] == '\0') 10308 return 0; 10309 10310 pend = strstr (str + k, "__"); 10311 if (pend == NULL) 10312 { 10313 bound = str + k; 10314 k += strlen (bound); 10315 } 10316 else 10317 { 10318 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1); 10319 bound = bound_buffer; 10320 strncpy (bound_buffer, str + k, pend - (str + k)); 10321 bound[pend - (str + k)] = '\0'; 10322 k = pend - str; 10323 } 10324 10325 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval)); 10326 if (bound_val == NULL) 10327 return 0; 10328 10329 *px = value_as_long (bound_val); 10330 if (pnew_k != NULL) 10331 *pnew_k = k; 10332 return 1; 10333 } 10334 10335 /* Value of variable named NAME in the current environment. If 10336 no such variable found, then if ERR_MSG is null, returns 0, and 10337 otherwise causes an error with message ERR_MSG. */ 10338 10339 static struct value * 10340 get_var_value (char *name, char *err_msg) 10341 { 10342 struct ada_symbol_info *syms; 10343 int nsyms; 10344 10345 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN, 10346 &syms); 10347 10348 if (nsyms != 1) 10349 { 10350 if (err_msg == NULL) 10351 return 0; 10352 else 10353 error (("%s"), err_msg); 10354 } 10355 10356 return value_of_variable (syms[0].sym, syms[0].block); 10357 } 10358 10359 /* Value of integer variable named NAME in the current environment. If 10360 no such variable found, returns 0, and sets *FLAG to 0. If 10361 successful, sets *FLAG to 1. */ 10362 10363 LONGEST 10364 get_int_var_value (char *name, int *flag) 10365 { 10366 struct value *var_val = get_var_value (name, 0); 10367 10368 if (var_val == 0) 10369 { 10370 if (flag != NULL) 10371 *flag = 0; 10372 return 0; 10373 } 10374 else 10375 { 10376 if (flag != NULL) 10377 *flag = 1; 10378 return value_as_long (var_val); 10379 } 10380 } 10381 10382 10383 /* Return a range type whose base type is that of the range type named 10384 NAME in the current environment, and whose bounds are calculated 10385 from NAME according to the GNAT range encoding conventions. 10386 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the 10387 corresponding range type from debug information; fall back to using it 10388 if symbol lookup fails. If a new type must be created, allocate it 10389 like ORIG_TYPE was. The bounds information, in general, is encoded 10390 in NAME, the base type given in the named range type. */ 10391 10392 static struct type * 10393 to_fixed_range_type (struct type *raw_type, struct value *dval) 10394 { 10395 char *name; 10396 struct type *base_type; 10397 char *subtype_info; 10398 10399 gdb_assert (raw_type != NULL); 10400 gdb_assert (TYPE_NAME (raw_type) != NULL); 10401 10402 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE) 10403 base_type = TYPE_TARGET_TYPE (raw_type); 10404 else 10405 base_type = raw_type; 10406 10407 name = TYPE_NAME (raw_type); 10408 subtype_info = strstr (name, "___XD"); 10409 if (subtype_info == NULL) 10410 { 10411 LONGEST L = ada_discrete_type_low_bound (raw_type); 10412 LONGEST U = ada_discrete_type_high_bound (raw_type); 10413 10414 if (L < INT_MIN || U > INT_MAX) 10415 return raw_type; 10416 else 10417 return create_range_type (alloc_type_copy (raw_type), raw_type, 10418 ada_discrete_type_low_bound (raw_type), 10419 ada_discrete_type_high_bound (raw_type)); 10420 } 10421 else 10422 { 10423 static char *name_buf = NULL; 10424 static size_t name_len = 0; 10425 int prefix_len = subtype_info - name; 10426 LONGEST L, U; 10427 struct type *type; 10428 char *bounds_str; 10429 int n; 10430 10431 GROW_VECT (name_buf, name_len, prefix_len + 5); 10432 strncpy (name_buf, name, prefix_len); 10433 name_buf[prefix_len] = '\0'; 10434 10435 subtype_info += 5; 10436 bounds_str = strchr (subtype_info, '_'); 10437 n = 1; 10438 10439 if (*subtype_info == 'L') 10440 { 10441 if (!ada_scan_number (bounds_str, n, &L, &n) 10442 && !scan_discrim_bound (bounds_str, n, dval, &L, &n)) 10443 return raw_type; 10444 if (bounds_str[n] == '_') 10445 n += 2; 10446 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */ 10447 n += 1; 10448 subtype_info += 1; 10449 } 10450 else 10451 { 10452 int ok; 10453 10454 strcpy (name_buf + prefix_len, "___L"); 10455 L = get_int_var_value (name_buf, &ok); 10456 if (!ok) 10457 { 10458 lim_warning (_("Unknown lower bound, using 1.")); 10459 L = 1; 10460 } 10461 } 10462 10463 if (*subtype_info == 'U') 10464 { 10465 if (!ada_scan_number (bounds_str, n, &U, &n) 10466 && !scan_discrim_bound (bounds_str, n, dval, &U, &n)) 10467 return raw_type; 10468 } 10469 else 10470 { 10471 int ok; 10472 10473 strcpy (name_buf + prefix_len, "___U"); 10474 U = get_int_var_value (name_buf, &ok); 10475 if (!ok) 10476 { 10477 lim_warning (_("Unknown upper bound, using %ld."), (long) L); 10478 U = L; 10479 } 10480 } 10481 10482 type = create_range_type (alloc_type_copy (raw_type), base_type, L, U); 10483 TYPE_NAME (type) = name; 10484 return type; 10485 } 10486 } 10487 10488 /* True iff NAME is the name of a range type. */ 10489 10490 int 10491 ada_is_range_type_name (const char *name) 10492 { 10493 return (name != NULL && strstr (name, "___XD")); 10494 } 10495 10496 10497 /* Modular types */ 10498 10499 /* True iff TYPE is an Ada modular type. */ 10500 10501 int 10502 ada_is_modular_type (struct type *type) 10503 { 10504 struct type *subranged_type = get_base_type (type); 10505 10506 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE 10507 && TYPE_CODE (subranged_type) == TYPE_CODE_INT 10508 && TYPE_UNSIGNED (subranged_type)); 10509 } 10510 10511 /* Try to determine the lower and upper bounds of the given modular type 10512 using the type name only. Return non-zero and set L and U as the lower 10513 and upper bounds (respectively) if successful. */ 10514 10515 int 10516 ada_modulus_from_name (struct type *type, ULONGEST *modulus) 10517 { 10518 char *name = ada_type_name (type); 10519 char *suffix; 10520 int k; 10521 LONGEST U; 10522 10523 if (name == NULL) 10524 return 0; 10525 10526 /* Discrete type bounds are encoded using an __XD suffix. In our case, 10527 we are looking for static bounds, which means an __XDLU suffix. 10528 Moreover, we know that the lower bound of modular types is always 10529 zero, so the actual suffix should start with "__XDLU_0__", and 10530 then be followed by the upper bound value. */ 10531 suffix = strstr (name, "__XDLU_0__"); 10532 if (suffix == NULL) 10533 return 0; 10534 k = 10; 10535 if (!ada_scan_number (suffix, k, &U, NULL)) 10536 return 0; 10537 10538 *modulus = (ULONGEST) U + 1; 10539 return 1; 10540 } 10541 10542 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */ 10543 10544 ULONGEST 10545 ada_modulus (struct type *type) 10546 { 10547 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1; 10548 } 10549 10550 10551 /* Ada exception catchpoint support: 10552 --------------------------------- 10553 10554 We support 3 kinds of exception catchpoints: 10555 . catchpoints on Ada exceptions 10556 . catchpoints on unhandled Ada exceptions 10557 . catchpoints on failed assertions 10558 10559 Exceptions raised during failed assertions, or unhandled exceptions 10560 could perfectly be caught with the general catchpoint on Ada exceptions. 10561 However, we can easily differentiate these two special cases, and having 10562 the option to distinguish these two cases from the rest can be useful 10563 to zero-in on certain situations. 10564 10565 Exception catchpoints are a specialized form of breakpoint, 10566 since they rely on inserting breakpoints inside known routines 10567 of the GNAT runtime. The implementation therefore uses a standard 10568 breakpoint structure of the BP_BREAKPOINT type, but with its own set 10569 of breakpoint_ops. 10570 10571 Support in the runtime for exception catchpoints have been changed 10572 a few times already, and these changes affect the implementation 10573 of these catchpoints. In order to be able to support several 10574 variants of the runtime, we use a sniffer that will determine 10575 the runtime variant used by the program being debugged. */ 10576 10577 /* The different types of catchpoints that we introduced for catching 10578 Ada exceptions. */ 10579 10580 enum exception_catchpoint_kind 10581 { 10582 ex_catch_exception, 10583 ex_catch_exception_unhandled, 10584 ex_catch_assert 10585 }; 10586 10587 /* Ada's standard exceptions. */ 10588 10589 static char *standard_exc[] = { 10590 "constraint_error", 10591 "program_error", 10592 "storage_error", 10593 "tasking_error" 10594 }; 10595 10596 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void); 10597 10598 /* A structure that describes how to support exception catchpoints 10599 for a given executable. */ 10600 10601 struct exception_support_info 10602 { 10603 /* The name of the symbol to break on in order to insert 10604 a catchpoint on exceptions. */ 10605 const char *catch_exception_sym; 10606 10607 /* The name of the symbol to break on in order to insert 10608 a catchpoint on unhandled exceptions. */ 10609 const char *catch_exception_unhandled_sym; 10610 10611 /* The name of the symbol to break on in order to insert 10612 a catchpoint on failed assertions. */ 10613 const char *catch_assert_sym; 10614 10615 /* Assuming that the inferior just triggered an unhandled exception 10616 catchpoint, this function is responsible for returning the address 10617 in inferior memory where the name of that exception is stored. 10618 Return zero if the address could not be computed. */ 10619 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr; 10620 }; 10621 10622 static CORE_ADDR ada_unhandled_exception_name_addr (void); 10623 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void); 10624 10625 /* The following exception support info structure describes how to 10626 implement exception catchpoints with the latest version of the 10627 Ada runtime (as of 2007-03-06). */ 10628 10629 static const struct exception_support_info default_exception_support_info = 10630 { 10631 "__gnat_debug_raise_exception", /* catch_exception_sym */ 10632 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */ 10633 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */ 10634 ada_unhandled_exception_name_addr 10635 }; 10636 10637 /* The following exception support info structure describes how to 10638 implement exception catchpoints with a slightly older version 10639 of the Ada runtime. */ 10640 10641 static const struct exception_support_info exception_support_info_fallback = 10642 { 10643 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */ 10644 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */ 10645 "system__assertions__raise_assert_failure", /* catch_assert_sym */ 10646 ada_unhandled_exception_name_addr_from_raise 10647 }; 10648 10649 /* Return nonzero if we can detect the exception support routines 10650 described in EINFO. 10651 10652 This function errors out if an abnormal situation is detected 10653 (for instance, if we find the exception support routines, but 10654 that support is found to be incomplete). */ 10655 10656 static int 10657 ada_has_this_exception_support (const struct exception_support_info *einfo) 10658 { 10659 struct symbol *sym; 10660 10661 /* The symbol we're looking up is provided by a unit in the GNAT runtime 10662 that should be compiled with debugging information. As a result, we 10663 expect to find that symbol in the symtabs. */ 10664 10665 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN); 10666 if (sym == NULL) 10667 { 10668 /* Perhaps we did not find our symbol because the Ada runtime was 10669 compiled without debugging info, or simply stripped of it. 10670 It happens on some GNU/Linux distributions for instance, where 10671 users have to install a separate debug package in order to get 10672 the runtime's debugging info. In that situation, let the user 10673 know why we cannot insert an Ada exception catchpoint. 10674 10675 Note: Just for the purpose of inserting our Ada exception 10676 catchpoint, we could rely purely on the associated minimal symbol. 10677 But we would be operating in degraded mode anyway, since we are 10678 still lacking the debugging info needed later on to extract 10679 the name of the exception being raised (this name is printed in 10680 the catchpoint message, and is also used when trying to catch 10681 a specific exception). We do not handle this case for now. */ 10682 if (lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL)) 10683 error (_("Your Ada runtime appears to be missing some debugging " 10684 "information.\nCannot insert Ada exception catchpoint " 10685 "in this configuration.")); 10686 10687 return 0; 10688 } 10689 10690 /* Make sure that the symbol we found corresponds to a function. */ 10691 10692 if (SYMBOL_CLASS (sym) != LOC_BLOCK) 10693 error (_("Symbol \"%s\" is not a function (class = %d)"), 10694 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym)); 10695 10696 return 1; 10697 } 10698 10699 /* Inspect the Ada runtime and determine which exception info structure 10700 should be used to provide support for exception catchpoints. 10701 10702 This function will always set the per-inferior exception_info, 10703 or raise an error. */ 10704 10705 static void 10706 ada_exception_support_info_sniffer (void) 10707 { 10708 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ()); 10709 struct symbol *sym; 10710 10711 /* If the exception info is already known, then no need to recompute it. */ 10712 if (data->exception_info != NULL) 10713 return; 10714 10715 /* Check the latest (default) exception support info. */ 10716 if (ada_has_this_exception_support (&default_exception_support_info)) 10717 { 10718 data->exception_info = &default_exception_support_info; 10719 return; 10720 } 10721 10722 /* Try our fallback exception suport info. */ 10723 if (ada_has_this_exception_support (&exception_support_info_fallback)) 10724 { 10725 data->exception_info = &exception_support_info_fallback; 10726 return; 10727 } 10728 10729 /* Sometimes, it is normal for us to not be able to find the routine 10730 we are looking for. This happens when the program is linked with 10731 the shared version of the GNAT runtime, and the program has not been 10732 started yet. Inform the user of these two possible causes if 10733 applicable. */ 10734 10735 if (ada_update_initial_language (language_unknown) != language_ada) 10736 error (_("Unable to insert catchpoint. Is this an Ada main program?")); 10737 10738 /* If the symbol does not exist, then check that the program is 10739 already started, to make sure that shared libraries have been 10740 loaded. If it is not started, this may mean that the symbol is 10741 in a shared library. */ 10742 10743 if (ptid_get_pid (inferior_ptid) == 0) 10744 error (_("Unable to insert catchpoint. Try to start the program first.")); 10745 10746 /* At this point, we know that we are debugging an Ada program and 10747 that the inferior has been started, but we still are not able to 10748 find the run-time symbols. That can mean that we are in 10749 configurable run time mode, or that a-except as been optimized 10750 out by the linker... In any case, at this point it is not worth 10751 supporting this feature. */ 10752 10753 error (_("Cannot insert Ada exception catchpoints in this configuration.")); 10754 } 10755 10756 /* True iff FRAME is very likely to be that of a function that is 10757 part of the runtime system. This is all very heuristic, but is 10758 intended to be used as advice as to what frames are uninteresting 10759 to most users. */ 10760 10761 static int 10762 is_known_support_routine (struct frame_info *frame) 10763 { 10764 struct symtab_and_line sal; 10765 char *func_name; 10766 enum language func_lang; 10767 int i; 10768 10769 /* If this code does not have any debugging information (no symtab), 10770 This cannot be any user code. */ 10771 10772 find_frame_sal (frame, &sal); 10773 if (sal.symtab == NULL) 10774 return 1; 10775 10776 /* If there is a symtab, but the associated source file cannot be 10777 located, then assume this is not user code: Selecting a frame 10778 for which we cannot display the code would not be very helpful 10779 for the user. This should also take care of case such as VxWorks 10780 where the kernel has some debugging info provided for a few units. */ 10781 10782 if (symtab_to_fullname (sal.symtab) == NULL) 10783 return 1; 10784 10785 /* Check the unit filename againt the Ada runtime file naming. 10786 We also check the name of the objfile against the name of some 10787 known system libraries that sometimes come with debugging info 10788 too. */ 10789 10790 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1) 10791 { 10792 re_comp (known_runtime_file_name_patterns[i]); 10793 if (re_exec (sal.symtab->filename)) 10794 return 1; 10795 if (sal.symtab->objfile != NULL 10796 && re_exec (sal.symtab->objfile->name)) 10797 return 1; 10798 } 10799 10800 /* Check whether the function is a GNAT-generated entity. */ 10801 10802 find_frame_funname (frame, &func_name, &func_lang, NULL); 10803 if (func_name == NULL) 10804 return 1; 10805 10806 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1) 10807 { 10808 re_comp (known_auxiliary_function_name_patterns[i]); 10809 if (re_exec (func_name)) 10810 return 1; 10811 } 10812 10813 return 0; 10814 } 10815 10816 /* Find the first frame that contains debugging information and that is not 10817 part of the Ada run-time, starting from FI and moving upward. */ 10818 10819 void 10820 ada_find_printable_frame (struct frame_info *fi) 10821 { 10822 for (; fi != NULL; fi = get_prev_frame (fi)) 10823 { 10824 if (!is_known_support_routine (fi)) 10825 { 10826 select_frame (fi); 10827 break; 10828 } 10829 } 10830 10831 } 10832 10833 /* Assuming that the inferior just triggered an unhandled exception 10834 catchpoint, return the address in inferior memory where the name 10835 of the exception is stored. 10836 10837 Return zero if the address could not be computed. */ 10838 10839 static CORE_ADDR 10840 ada_unhandled_exception_name_addr (void) 10841 { 10842 return parse_and_eval_address ("e.full_name"); 10843 } 10844 10845 /* Same as ada_unhandled_exception_name_addr, except that this function 10846 should be used when the inferior uses an older version of the runtime, 10847 where the exception name needs to be extracted from a specific frame 10848 several frames up in the callstack. */ 10849 10850 static CORE_ADDR 10851 ada_unhandled_exception_name_addr_from_raise (void) 10852 { 10853 int frame_level; 10854 struct frame_info *fi; 10855 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ()); 10856 10857 /* To determine the name of this exception, we need to select 10858 the frame corresponding to RAISE_SYM_NAME. This frame is 10859 at least 3 levels up, so we simply skip the first 3 frames 10860 without checking the name of their associated function. */ 10861 fi = get_current_frame (); 10862 for (frame_level = 0; frame_level < 3; frame_level += 1) 10863 if (fi != NULL) 10864 fi = get_prev_frame (fi); 10865 10866 while (fi != NULL) 10867 { 10868 char *func_name; 10869 enum language func_lang; 10870 10871 find_frame_funname (fi, &func_name, &func_lang, NULL); 10872 if (func_name != NULL 10873 && strcmp (func_name, data->exception_info->catch_exception_sym) == 0) 10874 break; /* We found the frame we were looking for... */ 10875 fi = get_prev_frame (fi); 10876 } 10877 10878 if (fi == NULL) 10879 return 0; 10880 10881 select_frame (fi); 10882 return parse_and_eval_address ("id.full_name"); 10883 } 10884 10885 /* Assuming the inferior just triggered an Ada exception catchpoint 10886 (of any type), return the address in inferior memory where the name 10887 of the exception is stored, if applicable. 10888 10889 Return zero if the address could not be computed, or if not relevant. */ 10890 10891 static CORE_ADDR 10892 ada_exception_name_addr_1 (enum exception_catchpoint_kind ex, 10893 struct breakpoint *b) 10894 { 10895 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ()); 10896 10897 switch (ex) 10898 { 10899 case ex_catch_exception: 10900 return (parse_and_eval_address ("e.full_name")); 10901 break; 10902 10903 case ex_catch_exception_unhandled: 10904 return data->exception_info->unhandled_exception_name_addr (); 10905 break; 10906 10907 case ex_catch_assert: 10908 return 0; /* Exception name is not relevant in this case. */ 10909 break; 10910 10911 default: 10912 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type")); 10913 break; 10914 } 10915 10916 return 0; /* Should never be reached. */ 10917 } 10918 10919 /* Same as ada_exception_name_addr_1, except that it intercepts and contains 10920 any error that ada_exception_name_addr_1 might cause to be thrown. 10921 When an error is intercepted, a warning with the error message is printed, 10922 and zero is returned. */ 10923 10924 static CORE_ADDR 10925 ada_exception_name_addr (enum exception_catchpoint_kind ex, 10926 struct breakpoint *b) 10927 { 10928 struct gdb_exception e; 10929 CORE_ADDR result = 0; 10930 10931 TRY_CATCH (e, RETURN_MASK_ERROR) 10932 { 10933 result = ada_exception_name_addr_1 (ex, b); 10934 } 10935 10936 if (e.reason < 0) 10937 { 10938 warning (_("failed to get exception name: %s"), e.message); 10939 return 0; 10940 } 10941 10942 return result; 10943 } 10944 10945 static struct symtab_and_line ada_exception_sal (enum exception_catchpoint_kind, 10946 char *, char **, 10947 const struct breakpoint_ops **); 10948 static char *ada_exception_catchpoint_cond_string (const char *excep_string); 10949 10950 /* Ada catchpoints. 10951 10952 In the case of catchpoints on Ada exceptions, the catchpoint will 10953 stop the target on every exception the program throws. When a user 10954 specifies the name of a specific exception, we translate this 10955 request into a condition expression (in text form), and then parse 10956 it into an expression stored in each of the catchpoint's locations. 10957 We then use this condition to check whether the exception that was 10958 raised is the one the user is interested in. If not, then the 10959 target is resumed again. We store the name of the requested 10960 exception, in order to be able to re-set the condition expression 10961 when symbols change. */ 10962 10963 /* An instance of this type is used to represent an Ada catchpoint 10964 breakpoint location. It includes a "struct bp_location" as a kind 10965 of base class; users downcast to "struct bp_location *" when 10966 needed. */ 10967 10968 struct ada_catchpoint_location 10969 { 10970 /* The base class. */ 10971 struct bp_location base; 10972 10973 /* The condition that checks whether the exception that was raised 10974 is the specific exception the user specified on catchpoint 10975 creation. */ 10976 struct expression *excep_cond_expr; 10977 }; 10978 10979 /* Implement the DTOR method in the bp_location_ops structure for all 10980 Ada exception catchpoint kinds. */ 10981 10982 static void 10983 ada_catchpoint_location_dtor (struct bp_location *bl) 10984 { 10985 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl; 10986 10987 xfree (al->excep_cond_expr); 10988 } 10989 10990 /* The vtable to be used in Ada catchpoint locations. */ 10991 10992 static const struct bp_location_ops ada_catchpoint_location_ops = 10993 { 10994 ada_catchpoint_location_dtor 10995 }; 10996 10997 /* An instance of this type is used to represent an Ada catchpoint. 10998 It includes a "struct breakpoint" as a kind of base class; users 10999 downcast to "struct breakpoint *" when needed. */ 11000 11001 struct ada_catchpoint 11002 { 11003 /* The base class. */ 11004 struct breakpoint base; 11005 11006 /* The name of the specific exception the user specified. */ 11007 char *excep_string; 11008 }; 11009 11010 /* Parse the exception condition string in the context of each of the 11011 catchpoint's locations, and store them for later evaluation. */ 11012 11013 static void 11014 create_excep_cond_exprs (struct ada_catchpoint *c) 11015 { 11016 struct cleanup *old_chain; 11017 struct bp_location *bl; 11018 char *cond_string; 11019 11020 /* Nothing to do if there's no specific exception to catch. */ 11021 if (c->excep_string == NULL) 11022 return; 11023 11024 /* Same if there are no locations... */ 11025 if (c->base.loc == NULL) 11026 return; 11027 11028 /* Compute the condition expression in text form, from the specific 11029 expection we want to catch. */ 11030 cond_string = ada_exception_catchpoint_cond_string (c->excep_string); 11031 old_chain = make_cleanup (xfree, cond_string); 11032 11033 /* Iterate over all the catchpoint's locations, and parse an 11034 expression for each. */ 11035 for (bl = c->base.loc; bl != NULL; bl = bl->next) 11036 { 11037 struct ada_catchpoint_location *ada_loc 11038 = (struct ada_catchpoint_location *) bl; 11039 struct expression *exp = NULL; 11040 11041 if (!bl->shlib_disabled) 11042 { 11043 volatile struct gdb_exception e; 11044 char *s; 11045 11046 s = cond_string; 11047 TRY_CATCH (e, RETURN_MASK_ERROR) 11048 { 11049 exp = parse_exp_1 (&s, block_for_pc (bl->address), 0); 11050 } 11051 if (e.reason < 0) 11052 warning (_("failed to reevaluate internal exception condition " 11053 "for catchpoint %d: %s"), 11054 c->base.number, e.message); 11055 } 11056 11057 ada_loc->excep_cond_expr = exp; 11058 } 11059 11060 do_cleanups (old_chain); 11061 } 11062 11063 /* Implement the DTOR method in the breakpoint_ops structure for all 11064 exception catchpoint kinds. */ 11065 11066 static void 11067 dtor_exception (enum exception_catchpoint_kind ex, struct breakpoint *b) 11068 { 11069 struct ada_catchpoint *c = (struct ada_catchpoint *) b; 11070 11071 xfree (c->excep_string); 11072 11073 bkpt_breakpoint_ops.dtor (b); 11074 } 11075 11076 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops 11077 structure for all exception catchpoint kinds. */ 11078 11079 static struct bp_location * 11080 allocate_location_exception (enum exception_catchpoint_kind ex, 11081 struct breakpoint *self) 11082 { 11083 struct ada_catchpoint_location *loc; 11084 11085 loc = XNEW (struct ada_catchpoint_location); 11086 init_bp_location (&loc->base, &ada_catchpoint_location_ops, self); 11087 loc->excep_cond_expr = NULL; 11088 return &loc->base; 11089 } 11090 11091 /* Implement the RE_SET method in the breakpoint_ops structure for all 11092 exception catchpoint kinds. */ 11093 11094 static void 11095 re_set_exception (enum exception_catchpoint_kind ex, struct breakpoint *b) 11096 { 11097 struct ada_catchpoint *c = (struct ada_catchpoint *) b; 11098 11099 /* Call the base class's method. This updates the catchpoint's 11100 locations. */ 11101 bkpt_breakpoint_ops.re_set (b); 11102 11103 /* Reparse the exception conditional expressions. One for each 11104 location. */ 11105 create_excep_cond_exprs (c); 11106 } 11107 11108 /* Returns true if we should stop for this breakpoint hit. If the 11109 user specified a specific exception, we only want to cause a stop 11110 if the program thrown that exception. */ 11111 11112 static int 11113 should_stop_exception (const struct bp_location *bl) 11114 { 11115 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner; 11116 const struct ada_catchpoint_location *ada_loc 11117 = (const struct ada_catchpoint_location *) bl; 11118 volatile struct gdb_exception ex; 11119 int stop; 11120 11121 /* With no specific exception, should always stop. */ 11122 if (c->excep_string == NULL) 11123 return 1; 11124 11125 if (ada_loc->excep_cond_expr == NULL) 11126 { 11127 /* We will have a NULL expression if back when we were creating 11128 the expressions, this location's had failed to parse. */ 11129 return 1; 11130 } 11131 11132 stop = 1; 11133 TRY_CATCH (ex, RETURN_MASK_ALL) 11134 { 11135 struct value *mark; 11136 11137 mark = value_mark (); 11138 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr)); 11139 value_free_to_mark (mark); 11140 } 11141 if (ex.reason < 0) 11142 exception_fprintf (gdb_stderr, ex, 11143 _("Error in testing exception condition:\n")); 11144 return stop; 11145 } 11146 11147 /* Implement the CHECK_STATUS method in the breakpoint_ops structure 11148 for all exception catchpoint kinds. */ 11149 11150 static void 11151 check_status_exception (enum exception_catchpoint_kind ex, bpstat bs) 11152 { 11153 bs->stop = should_stop_exception (bs->bp_location_at); 11154 } 11155 11156 /* Implement the PRINT_IT method in the breakpoint_ops structure 11157 for all exception catchpoint kinds. */ 11158 11159 static enum print_stop_action 11160 print_it_exception (enum exception_catchpoint_kind ex, bpstat bs) 11161 { 11162 struct ui_out *uiout = current_uiout; 11163 struct breakpoint *b = bs->breakpoint_at; 11164 11165 annotate_catchpoint (b->number); 11166 11167 if (ui_out_is_mi_like_p (uiout)) 11168 { 11169 ui_out_field_string (uiout, "reason", 11170 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT)); 11171 ui_out_field_string (uiout, "disp", bpdisp_text (b->disposition)); 11172 } 11173 11174 ui_out_text (uiout, 11175 b->disposition == disp_del ? "\nTemporary catchpoint " 11176 : "\nCatchpoint "); 11177 ui_out_field_int (uiout, "bkptno", b->number); 11178 ui_out_text (uiout, ", "); 11179 11180 switch (ex) 11181 { 11182 case ex_catch_exception: 11183 case ex_catch_exception_unhandled: 11184 { 11185 const CORE_ADDR addr = ada_exception_name_addr (ex, b); 11186 char exception_name[256]; 11187 11188 if (addr != 0) 11189 { 11190 read_memory (addr, exception_name, sizeof (exception_name) - 1); 11191 exception_name [sizeof (exception_name) - 1] = '\0'; 11192 } 11193 else 11194 { 11195 /* For some reason, we were unable to read the exception 11196 name. This could happen if the Runtime was compiled 11197 without debugging info, for instance. In that case, 11198 just replace the exception name by the generic string 11199 "exception" - it will read as "an exception" in the 11200 notification we are about to print. */ 11201 memcpy (exception_name, "exception", sizeof ("exception")); 11202 } 11203 /* In the case of unhandled exception breakpoints, we print 11204 the exception name as "unhandled EXCEPTION_NAME", to make 11205 it clearer to the user which kind of catchpoint just got 11206 hit. We used ui_out_text to make sure that this extra 11207 info does not pollute the exception name in the MI case. */ 11208 if (ex == ex_catch_exception_unhandled) 11209 ui_out_text (uiout, "unhandled "); 11210 ui_out_field_string (uiout, "exception-name", exception_name); 11211 } 11212 break; 11213 case ex_catch_assert: 11214 /* In this case, the name of the exception is not really 11215 important. Just print "failed assertion" to make it clearer 11216 that his program just hit an assertion-failure catchpoint. 11217 We used ui_out_text because this info does not belong in 11218 the MI output. */ 11219 ui_out_text (uiout, "failed assertion"); 11220 break; 11221 } 11222 ui_out_text (uiout, " at "); 11223 ada_find_printable_frame (get_current_frame ()); 11224 11225 return PRINT_SRC_AND_LOC; 11226 } 11227 11228 /* Implement the PRINT_ONE method in the breakpoint_ops structure 11229 for all exception catchpoint kinds. */ 11230 11231 static void 11232 print_one_exception (enum exception_catchpoint_kind ex, 11233 struct breakpoint *b, struct bp_location **last_loc) 11234 { 11235 struct ui_out *uiout = current_uiout; 11236 struct ada_catchpoint *c = (struct ada_catchpoint *) b; 11237 struct value_print_options opts; 11238 11239 get_user_print_options (&opts); 11240 if (opts.addressprint) 11241 { 11242 annotate_field (4); 11243 ui_out_field_core_addr (uiout, "addr", b->loc->gdbarch, b->loc->address); 11244 } 11245 11246 annotate_field (5); 11247 *last_loc = b->loc; 11248 switch (ex) 11249 { 11250 case ex_catch_exception: 11251 if (c->excep_string != NULL) 11252 { 11253 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string); 11254 11255 ui_out_field_string (uiout, "what", msg); 11256 xfree (msg); 11257 } 11258 else 11259 ui_out_field_string (uiout, "what", "all Ada exceptions"); 11260 11261 break; 11262 11263 case ex_catch_exception_unhandled: 11264 ui_out_field_string (uiout, "what", "unhandled Ada exceptions"); 11265 break; 11266 11267 case ex_catch_assert: 11268 ui_out_field_string (uiout, "what", "failed Ada assertions"); 11269 break; 11270 11271 default: 11272 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type")); 11273 break; 11274 } 11275 } 11276 11277 /* Implement the PRINT_MENTION method in the breakpoint_ops structure 11278 for all exception catchpoint kinds. */ 11279 11280 static void 11281 print_mention_exception (enum exception_catchpoint_kind ex, 11282 struct breakpoint *b) 11283 { 11284 struct ada_catchpoint *c = (struct ada_catchpoint *) b; 11285 struct ui_out *uiout = current_uiout; 11286 11287 ui_out_text (uiout, b->disposition == disp_del ? _("Temporary catchpoint ") 11288 : _("Catchpoint ")); 11289 ui_out_field_int (uiout, "bkptno", b->number); 11290 ui_out_text (uiout, ": "); 11291 11292 switch (ex) 11293 { 11294 case ex_catch_exception: 11295 if (c->excep_string != NULL) 11296 { 11297 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string); 11298 struct cleanup *old_chain = make_cleanup (xfree, info); 11299 11300 ui_out_text (uiout, info); 11301 do_cleanups (old_chain); 11302 } 11303 else 11304 ui_out_text (uiout, _("all Ada exceptions")); 11305 break; 11306 11307 case ex_catch_exception_unhandled: 11308 ui_out_text (uiout, _("unhandled Ada exceptions")); 11309 break; 11310 11311 case ex_catch_assert: 11312 ui_out_text (uiout, _("failed Ada assertions")); 11313 break; 11314 11315 default: 11316 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type")); 11317 break; 11318 } 11319 } 11320 11321 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure 11322 for all exception catchpoint kinds. */ 11323 11324 static void 11325 print_recreate_exception (enum exception_catchpoint_kind ex, 11326 struct breakpoint *b, struct ui_file *fp) 11327 { 11328 struct ada_catchpoint *c = (struct ada_catchpoint *) b; 11329 11330 switch (ex) 11331 { 11332 case ex_catch_exception: 11333 fprintf_filtered (fp, "catch exception"); 11334 if (c->excep_string != NULL) 11335 fprintf_filtered (fp, " %s", c->excep_string); 11336 break; 11337 11338 case ex_catch_exception_unhandled: 11339 fprintf_filtered (fp, "catch exception unhandled"); 11340 break; 11341 11342 case ex_catch_assert: 11343 fprintf_filtered (fp, "catch assert"); 11344 break; 11345 11346 default: 11347 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type")); 11348 } 11349 print_recreate_thread (b, fp); 11350 } 11351 11352 /* Virtual table for "catch exception" breakpoints. */ 11353 11354 static void 11355 dtor_catch_exception (struct breakpoint *b) 11356 { 11357 dtor_exception (ex_catch_exception, b); 11358 } 11359 11360 static struct bp_location * 11361 allocate_location_catch_exception (struct breakpoint *self) 11362 { 11363 return allocate_location_exception (ex_catch_exception, self); 11364 } 11365 11366 static void 11367 re_set_catch_exception (struct breakpoint *b) 11368 { 11369 re_set_exception (ex_catch_exception, b); 11370 } 11371 11372 static void 11373 check_status_catch_exception (bpstat bs) 11374 { 11375 check_status_exception (ex_catch_exception, bs); 11376 } 11377 11378 static enum print_stop_action 11379 print_it_catch_exception (bpstat bs) 11380 { 11381 return print_it_exception (ex_catch_exception, bs); 11382 } 11383 11384 static void 11385 print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc) 11386 { 11387 print_one_exception (ex_catch_exception, b, last_loc); 11388 } 11389 11390 static void 11391 print_mention_catch_exception (struct breakpoint *b) 11392 { 11393 print_mention_exception (ex_catch_exception, b); 11394 } 11395 11396 static void 11397 print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp) 11398 { 11399 print_recreate_exception (ex_catch_exception, b, fp); 11400 } 11401 11402 static struct breakpoint_ops catch_exception_breakpoint_ops; 11403 11404 /* Virtual table for "catch exception unhandled" breakpoints. */ 11405 11406 static void 11407 dtor_catch_exception_unhandled (struct breakpoint *b) 11408 { 11409 dtor_exception (ex_catch_exception_unhandled, b); 11410 } 11411 11412 static struct bp_location * 11413 allocate_location_catch_exception_unhandled (struct breakpoint *self) 11414 { 11415 return allocate_location_exception (ex_catch_exception_unhandled, self); 11416 } 11417 11418 static void 11419 re_set_catch_exception_unhandled (struct breakpoint *b) 11420 { 11421 re_set_exception (ex_catch_exception_unhandled, b); 11422 } 11423 11424 static void 11425 check_status_catch_exception_unhandled (bpstat bs) 11426 { 11427 check_status_exception (ex_catch_exception_unhandled, bs); 11428 } 11429 11430 static enum print_stop_action 11431 print_it_catch_exception_unhandled (bpstat bs) 11432 { 11433 return print_it_exception (ex_catch_exception_unhandled, bs); 11434 } 11435 11436 static void 11437 print_one_catch_exception_unhandled (struct breakpoint *b, 11438 struct bp_location **last_loc) 11439 { 11440 print_one_exception (ex_catch_exception_unhandled, b, last_loc); 11441 } 11442 11443 static void 11444 print_mention_catch_exception_unhandled (struct breakpoint *b) 11445 { 11446 print_mention_exception (ex_catch_exception_unhandled, b); 11447 } 11448 11449 static void 11450 print_recreate_catch_exception_unhandled (struct breakpoint *b, 11451 struct ui_file *fp) 11452 { 11453 print_recreate_exception (ex_catch_exception_unhandled, b, fp); 11454 } 11455 11456 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops; 11457 11458 /* Virtual table for "catch assert" breakpoints. */ 11459 11460 static void 11461 dtor_catch_assert (struct breakpoint *b) 11462 { 11463 dtor_exception (ex_catch_assert, b); 11464 } 11465 11466 static struct bp_location * 11467 allocate_location_catch_assert (struct breakpoint *self) 11468 { 11469 return allocate_location_exception (ex_catch_assert, self); 11470 } 11471 11472 static void 11473 re_set_catch_assert (struct breakpoint *b) 11474 { 11475 return re_set_exception (ex_catch_assert, b); 11476 } 11477 11478 static void 11479 check_status_catch_assert (bpstat bs) 11480 { 11481 check_status_exception (ex_catch_assert, bs); 11482 } 11483 11484 static enum print_stop_action 11485 print_it_catch_assert (bpstat bs) 11486 { 11487 return print_it_exception (ex_catch_assert, bs); 11488 } 11489 11490 static void 11491 print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc) 11492 { 11493 print_one_exception (ex_catch_assert, b, last_loc); 11494 } 11495 11496 static void 11497 print_mention_catch_assert (struct breakpoint *b) 11498 { 11499 print_mention_exception (ex_catch_assert, b); 11500 } 11501 11502 static void 11503 print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp) 11504 { 11505 print_recreate_exception (ex_catch_assert, b, fp); 11506 } 11507 11508 static struct breakpoint_ops catch_assert_breakpoint_ops; 11509 11510 /* Return a newly allocated copy of the first space-separated token 11511 in ARGSP, and then adjust ARGSP to point immediately after that 11512 token. 11513 11514 Return NULL if ARGPS does not contain any more tokens. */ 11515 11516 static char * 11517 ada_get_next_arg (char **argsp) 11518 { 11519 char *args = *argsp; 11520 char *end; 11521 char *result; 11522 11523 /* Skip any leading white space. */ 11524 11525 while (isspace (*args)) 11526 args++; 11527 11528 if (args[0] == '\0') 11529 return NULL; /* No more arguments. */ 11530 11531 /* Find the end of the current argument. */ 11532 11533 end = args; 11534 while (*end != '\0' && !isspace (*end)) 11535 end++; 11536 11537 /* Adjust ARGSP to point to the start of the next argument. */ 11538 11539 *argsp = end; 11540 11541 /* Make a copy of the current argument and return it. */ 11542 11543 result = xmalloc (end - args + 1); 11544 strncpy (result, args, end - args); 11545 result[end - args] = '\0'; 11546 11547 return result; 11548 } 11549 11550 /* Split the arguments specified in a "catch exception" command. 11551 Set EX to the appropriate catchpoint type. 11552 Set EXCEP_STRING to the name of the specific exception if 11553 specified by the user. */ 11554 11555 static void 11556 catch_ada_exception_command_split (char *args, 11557 enum exception_catchpoint_kind *ex, 11558 char **excep_string) 11559 { 11560 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL); 11561 char *exception_name; 11562 11563 exception_name = ada_get_next_arg (&args); 11564 make_cleanup (xfree, exception_name); 11565 11566 /* Check that we do not have any more arguments. Anything else 11567 is unexpected. */ 11568 11569 while (isspace (*args)) 11570 args++; 11571 11572 if (args[0] != '\0') 11573 error (_("Junk at end of expression")); 11574 11575 discard_cleanups (old_chain); 11576 11577 if (exception_name == NULL) 11578 { 11579 /* Catch all exceptions. */ 11580 *ex = ex_catch_exception; 11581 *excep_string = NULL; 11582 } 11583 else if (strcmp (exception_name, "unhandled") == 0) 11584 { 11585 /* Catch unhandled exceptions. */ 11586 *ex = ex_catch_exception_unhandled; 11587 *excep_string = NULL; 11588 } 11589 else 11590 { 11591 /* Catch a specific exception. */ 11592 *ex = ex_catch_exception; 11593 *excep_string = exception_name; 11594 } 11595 } 11596 11597 /* Return the name of the symbol on which we should break in order to 11598 implement a catchpoint of the EX kind. */ 11599 11600 static const char * 11601 ada_exception_sym_name (enum exception_catchpoint_kind ex) 11602 { 11603 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ()); 11604 11605 gdb_assert (data->exception_info != NULL); 11606 11607 switch (ex) 11608 { 11609 case ex_catch_exception: 11610 return (data->exception_info->catch_exception_sym); 11611 break; 11612 case ex_catch_exception_unhandled: 11613 return (data->exception_info->catch_exception_unhandled_sym); 11614 break; 11615 case ex_catch_assert: 11616 return (data->exception_info->catch_assert_sym); 11617 break; 11618 default: 11619 internal_error (__FILE__, __LINE__, 11620 _("unexpected catchpoint kind (%d)"), ex); 11621 } 11622 } 11623 11624 /* Return the breakpoint ops "virtual table" used for catchpoints 11625 of the EX kind. */ 11626 11627 static const struct breakpoint_ops * 11628 ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex) 11629 { 11630 switch (ex) 11631 { 11632 case ex_catch_exception: 11633 return (&catch_exception_breakpoint_ops); 11634 break; 11635 case ex_catch_exception_unhandled: 11636 return (&catch_exception_unhandled_breakpoint_ops); 11637 break; 11638 case ex_catch_assert: 11639 return (&catch_assert_breakpoint_ops); 11640 break; 11641 default: 11642 internal_error (__FILE__, __LINE__, 11643 _("unexpected catchpoint kind (%d)"), ex); 11644 } 11645 } 11646 11647 /* Return the condition that will be used to match the current exception 11648 being raised with the exception that the user wants to catch. This 11649 assumes that this condition is used when the inferior just triggered 11650 an exception catchpoint. 11651 11652 The string returned is a newly allocated string that needs to be 11653 deallocated later. */ 11654 11655 static char * 11656 ada_exception_catchpoint_cond_string (const char *excep_string) 11657 { 11658 int i; 11659 11660 /* The standard exceptions are a special case. They are defined in 11661 runtime units that have been compiled without debugging info; if 11662 EXCEP_STRING is the not-fully-qualified name of a standard 11663 exception (e.g. "constraint_error") then, during the evaluation 11664 of the condition expression, the symbol lookup on this name would 11665 *not* return this standard exception. The catchpoint condition 11666 may then be set only on user-defined exceptions which have the 11667 same not-fully-qualified name (e.g. my_package.constraint_error). 11668 11669 To avoid this unexcepted behavior, these standard exceptions are 11670 systematically prefixed by "standard". This means that "catch 11671 exception constraint_error" is rewritten into "catch exception 11672 standard.constraint_error". 11673 11674 If an exception named contraint_error is defined in another package of 11675 the inferior program, then the only way to specify this exception as a 11676 breakpoint condition is to use its fully-qualified named: 11677 e.g. my_package.constraint_error. */ 11678 11679 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++) 11680 { 11681 if (strcmp (standard_exc [i], excep_string) == 0) 11682 { 11683 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)", 11684 excep_string); 11685 } 11686 } 11687 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string); 11688 } 11689 11690 /* Return the symtab_and_line that should be used to insert an exception 11691 catchpoint of the TYPE kind. 11692 11693 EXCEP_STRING should contain the name of a specific exception that 11694 the catchpoint should catch, or NULL otherwise. 11695 11696 ADDR_STRING returns the name of the function where the real 11697 breakpoint that implements the catchpoints is set, depending on the 11698 type of catchpoint we need to create. */ 11699 11700 static struct symtab_and_line 11701 ada_exception_sal (enum exception_catchpoint_kind ex, char *excep_string, 11702 char **addr_string, const struct breakpoint_ops **ops) 11703 { 11704 const char *sym_name; 11705 struct symbol *sym; 11706 11707 /* First, find out which exception support info to use. */ 11708 ada_exception_support_info_sniffer (); 11709 11710 /* Then lookup the function on which we will break in order to catch 11711 the Ada exceptions requested by the user. */ 11712 sym_name = ada_exception_sym_name (ex); 11713 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN); 11714 11715 /* We can assume that SYM is not NULL at this stage. If the symbol 11716 did not exist, ada_exception_support_info_sniffer would have 11717 raised an exception. 11718 11719 Also, ada_exception_support_info_sniffer should have already 11720 verified that SYM is a function symbol. */ 11721 gdb_assert (sym != NULL); 11722 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK); 11723 11724 /* Set ADDR_STRING. */ 11725 *addr_string = xstrdup (sym_name); 11726 11727 /* Set OPS. */ 11728 *ops = ada_exception_breakpoint_ops (ex); 11729 11730 return find_function_start_sal (sym, 1); 11731 } 11732 11733 /* Parse the arguments (ARGS) of the "catch exception" command. 11734 11735 If the user asked the catchpoint to catch only a specific 11736 exception, then save the exception name in ADDR_STRING. 11737 11738 See ada_exception_sal for a description of all the remaining 11739 function arguments of this function. */ 11740 11741 static struct symtab_and_line 11742 ada_decode_exception_location (char *args, char **addr_string, 11743 char **excep_string, 11744 const struct breakpoint_ops **ops) 11745 { 11746 enum exception_catchpoint_kind ex; 11747 11748 catch_ada_exception_command_split (args, &ex, excep_string); 11749 return ada_exception_sal (ex, *excep_string, addr_string, ops); 11750 } 11751 11752 /* Create an Ada exception catchpoint. */ 11753 11754 static void 11755 create_ada_exception_catchpoint (struct gdbarch *gdbarch, 11756 struct symtab_and_line sal, 11757 char *addr_string, 11758 char *excep_string, 11759 const struct breakpoint_ops *ops, 11760 int tempflag, 11761 int from_tty) 11762 { 11763 struct ada_catchpoint *c; 11764 11765 c = XNEW (struct ada_catchpoint); 11766 init_ada_exception_breakpoint (&c->base, gdbarch, sal, addr_string, 11767 ops, tempflag, from_tty); 11768 c->excep_string = excep_string; 11769 create_excep_cond_exprs (c); 11770 install_breakpoint (0, &c->base, 1); 11771 } 11772 11773 /* Implement the "catch exception" command. */ 11774 11775 static void 11776 catch_ada_exception_command (char *arg, int from_tty, 11777 struct cmd_list_element *command) 11778 { 11779 struct gdbarch *gdbarch = get_current_arch (); 11780 int tempflag; 11781 struct symtab_and_line sal; 11782 char *addr_string = NULL; 11783 char *excep_string = NULL; 11784 const struct breakpoint_ops *ops = NULL; 11785 11786 tempflag = get_cmd_context (command) == CATCH_TEMPORARY; 11787 11788 if (!arg) 11789 arg = ""; 11790 sal = ada_decode_exception_location (arg, &addr_string, &excep_string, &ops); 11791 create_ada_exception_catchpoint (gdbarch, sal, addr_string, 11792 excep_string, ops, tempflag, from_tty); 11793 } 11794 11795 static struct symtab_and_line 11796 ada_decode_assert_location (char *args, char **addr_string, 11797 const struct breakpoint_ops **ops) 11798 { 11799 /* Check that no argument where provided at the end of the command. */ 11800 11801 if (args != NULL) 11802 { 11803 while (isspace (*args)) 11804 args++; 11805 if (*args != '\0') 11806 error (_("Junk at end of arguments.")); 11807 } 11808 11809 return ada_exception_sal (ex_catch_assert, NULL, addr_string, ops); 11810 } 11811 11812 /* Implement the "catch assert" command. */ 11813 11814 static void 11815 catch_assert_command (char *arg, int from_tty, 11816 struct cmd_list_element *command) 11817 { 11818 struct gdbarch *gdbarch = get_current_arch (); 11819 int tempflag; 11820 struct symtab_and_line sal; 11821 char *addr_string = NULL; 11822 const struct breakpoint_ops *ops = NULL; 11823 11824 tempflag = get_cmd_context (command) == CATCH_TEMPORARY; 11825 11826 if (!arg) 11827 arg = ""; 11828 sal = ada_decode_assert_location (arg, &addr_string, &ops); 11829 create_ada_exception_catchpoint (gdbarch, sal, addr_string, 11830 NULL, ops, tempflag, from_tty); 11831 } 11832 /* Operators */ 11833 /* Information about operators given special treatment in functions 11834 below. */ 11835 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */ 11836 11837 #define ADA_OPERATORS \ 11838 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \ 11839 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \ 11840 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \ 11841 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \ 11842 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \ 11843 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \ 11844 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \ 11845 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \ 11846 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \ 11847 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \ 11848 OP_DEFN (OP_ATR_POS, 1, 2, 0) \ 11849 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \ 11850 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \ 11851 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \ 11852 OP_DEFN (UNOP_QUAL, 3, 1, 0) \ 11853 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \ 11854 OP_DEFN (OP_OTHERS, 1, 1, 0) \ 11855 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \ 11856 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0) 11857 11858 static void 11859 ada_operator_length (const struct expression *exp, int pc, int *oplenp, 11860 int *argsp) 11861 { 11862 switch (exp->elts[pc - 1].opcode) 11863 { 11864 default: 11865 operator_length_standard (exp, pc, oplenp, argsp); 11866 break; 11867 11868 #define OP_DEFN(op, len, args, binop) \ 11869 case op: *oplenp = len; *argsp = args; break; 11870 ADA_OPERATORS; 11871 #undef OP_DEFN 11872 11873 case OP_AGGREGATE: 11874 *oplenp = 3; 11875 *argsp = longest_to_int (exp->elts[pc - 2].longconst); 11876 break; 11877 11878 case OP_CHOICES: 11879 *oplenp = 3; 11880 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1; 11881 break; 11882 } 11883 } 11884 11885 /* Implementation of the exp_descriptor method operator_check. */ 11886 11887 static int 11888 ada_operator_check (struct expression *exp, int pos, 11889 int (*objfile_func) (struct objfile *objfile, void *data), 11890 void *data) 11891 { 11892 const union exp_element *const elts = exp->elts; 11893 struct type *type = NULL; 11894 11895 switch (elts[pos].opcode) 11896 { 11897 case UNOP_IN_RANGE: 11898 case UNOP_QUAL: 11899 type = elts[pos + 1].type; 11900 break; 11901 11902 default: 11903 return operator_check_standard (exp, pos, objfile_func, data); 11904 } 11905 11906 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */ 11907 11908 if (type && TYPE_OBJFILE (type) 11909 && (*objfile_func) (TYPE_OBJFILE (type), data)) 11910 return 1; 11911 11912 return 0; 11913 } 11914 11915 static char * 11916 ada_op_name (enum exp_opcode opcode) 11917 { 11918 switch (opcode) 11919 { 11920 default: 11921 return op_name_standard (opcode); 11922 11923 #define OP_DEFN(op, len, args, binop) case op: return #op; 11924 ADA_OPERATORS; 11925 #undef OP_DEFN 11926 11927 case OP_AGGREGATE: 11928 return "OP_AGGREGATE"; 11929 case OP_CHOICES: 11930 return "OP_CHOICES"; 11931 case OP_NAME: 11932 return "OP_NAME"; 11933 } 11934 } 11935 11936 /* As for operator_length, but assumes PC is pointing at the first 11937 element of the operator, and gives meaningful results only for the 11938 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */ 11939 11940 static void 11941 ada_forward_operator_length (struct expression *exp, int pc, 11942 int *oplenp, int *argsp) 11943 { 11944 switch (exp->elts[pc].opcode) 11945 { 11946 default: 11947 *oplenp = *argsp = 0; 11948 break; 11949 11950 #define OP_DEFN(op, len, args, binop) \ 11951 case op: *oplenp = len; *argsp = args; break; 11952 ADA_OPERATORS; 11953 #undef OP_DEFN 11954 11955 case OP_AGGREGATE: 11956 *oplenp = 3; 11957 *argsp = longest_to_int (exp->elts[pc + 1].longconst); 11958 break; 11959 11960 case OP_CHOICES: 11961 *oplenp = 3; 11962 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1; 11963 break; 11964 11965 case OP_STRING: 11966 case OP_NAME: 11967 { 11968 int len = longest_to_int (exp->elts[pc + 1].longconst); 11969 11970 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1); 11971 *argsp = 0; 11972 break; 11973 } 11974 } 11975 } 11976 11977 static int 11978 ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt) 11979 { 11980 enum exp_opcode op = exp->elts[elt].opcode; 11981 int oplen, nargs; 11982 int pc = elt; 11983 int i; 11984 11985 ada_forward_operator_length (exp, elt, &oplen, &nargs); 11986 11987 switch (op) 11988 { 11989 /* Ada attributes ('Foo). */ 11990 case OP_ATR_FIRST: 11991 case OP_ATR_LAST: 11992 case OP_ATR_LENGTH: 11993 case OP_ATR_IMAGE: 11994 case OP_ATR_MAX: 11995 case OP_ATR_MIN: 11996 case OP_ATR_MODULUS: 11997 case OP_ATR_POS: 11998 case OP_ATR_SIZE: 11999 case OP_ATR_TAG: 12000 case OP_ATR_VAL: 12001 break; 12002 12003 case UNOP_IN_RANGE: 12004 case UNOP_QUAL: 12005 /* XXX: gdb_sprint_host_address, type_sprint */ 12006 fprintf_filtered (stream, _("Type @")); 12007 gdb_print_host_address (exp->elts[pc + 1].type, stream); 12008 fprintf_filtered (stream, " ("); 12009 type_print (exp->elts[pc + 1].type, NULL, stream, 0); 12010 fprintf_filtered (stream, ")"); 12011 break; 12012 case BINOP_IN_BOUNDS: 12013 fprintf_filtered (stream, " (%d)", 12014 longest_to_int (exp->elts[pc + 2].longconst)); 12015 break; 12016 case TERNOP_IN_RANGE: 12017 break; 12018 12019 case OP_AGGREGATE: 12020 case OP_OTHERS: 12021 case OP_DISCRETE_RANGE: 12022 case OP_POSITIONAL: 12023 case OP_CHOICES: 12024 break; 12025 12026 case OP_NAME: 12027 case OP_STRING: 12028 { 12029 char *name = &exp->elts[elt + 2].string; 12030 int len = longest_to_int (exp->elts[elt + 1].longconst); 12031 12032 fprintf_filtered (stream, "Text: `%.*s'", len, name); 12033 break; 12034 } 12035 12036 default: 12037 return dump_subexp_body_standard (exp, stream, elt); 12038 } 12039 12040 elt += oplen; 12041 for (i = 0; i < nargs; i += 1) 12042 elt = dump_subexp (exp, stream, elt); 12043 12044 return elt; 12045 } 12046 12047 /* The Ada extension of print_subexp (q.v.). */ 12048 12049 static void 12050 ada_print_subexp (struct expression *exp, int *pos, 12051 struct ui_file *stream, enum precedence prec) 12052 { 12053 int oplen, nargs, i; 12054 int pc = *pos; 12055 enum exp_opcode op = exp->elts[pc].opcode; 12056 12057 ada_forward_operator_length (exp, pc, &oplen, &nargs); 12058 12059 *pos += oplen; 12060 switch (op) 12061 { 12062 default: 12063 *pos -= oplen; 12064 print_subexp_standard (exp, pos, stream, prec); 12065 return; 12066 12067 case OP_VAR_VALUE: 12068 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream); 12069 return; 12070 12071 case BINOP_IN_BOUNDS: 12072 /* XXX: sprint_subexp */ 12073 print_subexp (exp, pos, stream, PREC_SUFFIX); 12074 fputs_filtered (" in ", stream); 12075 print_subexp (exp, pos, stream, PREC_SUFFIX); 12076 fputs_filtered ("'range", stream); 12077 if (exp->elts[pc + 1].longconst > 1) 12078 fprintf_filtered (stream, "(%ld)", 12079 (long) exp->elts[pc + 1].longconst); 12080 return; 12081 12082 case TERNOP_IN_RANGE: 12083 if (prec >= PREC_EQUAL) 12084 fputs_filtered ("(", stream); 12085 /* XXX: sprint_subexp */ 12086 print_subexp (exp, pos, stream, PREC_SUFFIX); 12087 fputs_filtered (" in ", stream); 12088 print_subexp (exp, pos, stream, PREC_EQUAL); 12089 fputs_filtered (" .. ", stream); 12090 print_subexp (exp, pos, stream, PREC_EQUAL); 12091 if (prec >= PREC_EQUAL) 12092 fputs_filtered (")", stream); 12093 return; 12094 12095 case OP_ATR_FIRST: 12096 case OP_ATR_LAST: 12097 case OP_ATR_LENGTH: 12098 case OP_ATR_IMAGE: 12099 case OP_ATR_MAX: 12100 case OP_ATR_MIN: 12101 case OP_ATR_MODULUS: 12102 case OP_ATR_POS: 12103 case OP_ATR_SIZE: 12104 case OP_ATR_TAG: 12105 case OP_ATR_VAL: 12106 if (exp->elts[*pos].opcode == OP_TYPE) 12107 { 12108 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID) 12109 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0); 12110 *pos += 3; 12111 } 12112 else 12113 print_subexp (exp, pos, stream, PREC_SUFFIX); 12114 fprintf_filtered (stream, "'%s", ada_attribute_name (op)); 12115 if (nargs > 1) 12116 { 12117 int tem; 12118 12119 for (tem = 1; tem < nargs; tem += 1) 12120 { 12121 fputs_filtered ((tem == 1) ? " (" : ", ", stream); 12122 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA); 12123 } 12124 fputs_filtered (")", stream); 12125 } 12126 return; 12127 12128 case UNOP_QUAL: 12129 type_print (exp->elts[pc + 1].type, "", stream, 0); 12130 fputs_filtered ("'(", stream); 12131 print_subexp (exp, pos, stream, PREC_PREFIX); 12132 fputs_filtered (")", stream); 12133 return; 12134 12135 case UNOP_IN_RANGE: 12136 /* XXX: sprint_subexp */ 12137 print_subexp (exp, pos, stream, PREC_SUFFIX); 12138 fputs_filtered (" in ", stream); 12139 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0); 12140 return; 12141 12142 case OP_DISCRETE_RANGE: 12143 print_subexp (exp, pos, stream, PREC_SUFFIX); 12144 fputs_filtered ("..", stream); 12145 print_subexp (exp, pos, stream, PREC_SUFFIX); 12146 return; 12147 12148 case OP_OTHERS: 12149 fputs_filtered ("others => ", stream); 12150 print_subexp (exp, pos, stream, PREC_SUFFIX); 12151 return; 12152 12153 case OP_CHOICES: 12154 for (i = 0; i < nargs-1; i += 1) 12155 { 12156 if (i > 0) 12157 fputs_filtered ("|", stream); 12158 print_subexp (exp, pos, stream, PREC_SUFFIX); 12159 } 12160 fputs_filtered (" => ", stream); 12161 print_subexp (exp, pos, stream, PREC_SUFFIX); 12162 return; 12163 12164 case OP_POSITIONAL: 12165 print_subexp (exp, pos, stream, PREC_SUFFIX); 12166 return; 12167 12168 case OP_AGGREGATE: 12169 fputs_filtered ("(", stream); 12170 for (i = 0; i < nargs; i += 1) 12171 { 12172 if (i > 0) 12173 fputs_filtered (", ", stream); 12174 print_subexp (exp, pos, stream, PREC_SUFFIX); 12175 } 12176 fputs_filtered (")", stream); 12177 return; 12178 } 12179 } 12180 12181 /* Table mapping opcodes into strings for printing operators 12182 and precedences of the operators. */ 12183 12184 static const struct op_print ada_op_print_tab[] = { 12185 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1}, 12186 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0}, 12187 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0}, 12188 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0}, 12189 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0}, 12190 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0}, 12191 {"=", BINOP_EQUAL, PREC_EQUAL, 0}, 12192 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0}, 12193 {"<=", BINOP_LEQ, PREC_ORDER, 0}, 12194 {">=", BINOP_GEQ, PREC_ORDER, 0}, 12195 {">", BINOP_GTR, PREC_ORDER, 0}, 12196 {"<", BINOP_LESS, PREC_ORDER, 0}, 12197 {">>", BINOP_RSH, PREC_SHIFT, 0}, 12198 {"<<", BINOP_LSH, PREC_SHIFT, 0}, 12199 {"+", BINOP_ADD, PREC_ADD, 0}, 12200 {"-", BINOP_SUB, PREC_ADD, 0}, 12201 {"&", BINOP_CONCAT, PREC_ADD, 0}, 12202 {"*", BINOP_MUL, PREC_MUL, 0}, 12203 {"/", BINOP_DIV, PREC_MUL, 0}, 12204 {"rem", BINOP_REM, PREC_MUL, 0}, 12205 {"mod", BINOP_MOD, PREC_MUL, 0}, 12206 {"**", BINOP_EXP, PREC_REPEAT, 0}, 12207 {"@", BINOP_REPEAT, PREC_REPEAT, 0}, 12208 {"-", UNOP_NEG, PREC_PREFIX, 0}, 12209 {"+", UNOP_PLUS, PREC_PREFIX, 0}, 12210 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0}, 12211 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0}, 12212 {"abs ", UNOP_ABS, PREC_PREFIX, 0}, 12213 {".all", UNOP_IND, PREC_SUFFIX, 1}, 12214 {"'access", UNOP_ADDR, PREC_SUFFIX, 1}, 12215 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1}, 12216 {NULL, 0, 0, 0} 12217 }; 12218 12219 enum ada_primitive_types { 12220 ada_primitive_type_int, 12221 ada_primitive_type_long, 12222 ada_primitive_type_short, 12223 ada_primitive_type_char, 12224 ada_primitive_type_float, 12225 ada_primitive_type_double, 12226 ada_primitive_type_void, 12227 ada_primitive_type_long_long, 12228 ada_primitive_type_long_double, 12229 ada_primitive_type_natural, 12230 ada_primitive_type_positive, 12231 ada_primitive_type_system_address, 12232 nr_ada_primitive_types 12233 }; 12234 12235 static void 12236 ada_language_arch_info (struct gdbarch *gdbarch, 12237 struct language_arch_info *lai) 12238 { 12239 const struct builtin_type *builtin = builtin_type (gdbarch); 12240 12241 lai->primitive_type_vector 12242 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1, 12243 struct type *); 12244 12245 lai->primitive_type_vector [ada_primitive_type_int] 12246 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 12247 0, "integer"); 12248 lai->primitive_type_vector [ada_primitive_type_long] 12249 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch), 12250 0, "long_integer"); 12251 lai->primitive_type_vector [ada_primitive_type_short] 12252 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 12253 0, "short_integer"); 12254 lai->string_char_type 12255 = lai->primitive_type_vector [ada_primitive_type_char] 12256 = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character"); 12257 lai->primitive_type_vector [ada_primitive_type_float] 12258 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch), 12259 "float", NULL); 12260 lai->primitive_type_vector [ada_primitive_type_double] 12261 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch), 12262 "long_float", NULL); 12263 lai->primitive_type_vector [ada_primitive_type_long_long] 12264 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 12265 0, "long_long_integer"); 12266 lai->primitive_type_vector [ada_primitive_type_long_double] 12267 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch), 12268 "long_long_float", NULL); 12269 lai->primitive_type_vector [ada_primitive_type_natural] 12270 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 12271 0, "natural"); 12272 lai->primitive_type_vector [ada_primitive_type_positive] 12273 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 12274 0, "positive"); 12275 lai->primitive_type_vector [ada_primitive_type_void] 12276 = builtin->builtin_void; 12277 12278 lai->primitive_type_vector [ada_primitive_type_system_address] 12279 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, 1, "void")); 12280 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address]) 12281 = "system__address"; 12282 12283 lai->bool_type_symbol = NULL; 12284 lai->bool_type_default = builtin->builtin_bool; 12285 } 12286 12287 /* Language vector */ 12288 12289 /* Not really used, but needed in the ada_language_defn. */ 12290 12291 static void 12292 emit_char (int c, struct type *type, struct ui_file *stream, int quoter) 12293 { 12294 ada_emit_char (c, type, stream, quoter, 1); 12295 } 12296 12297 static int 12298 parse (void) 12299 { 12300 warnings_issued = 0; 12301 return ada_parse (); 12302 } 12303 12304 static const struct exp_descriptor ada_exp_descriptor = { 12305 ada_print_subexp, 12306 ada_operator_length, 12307 ada_operator_check, 12308 ada_op_name, 12309 ada_dump_subexp_body, 12310 ada_evaluate_subexp 12311 }; 12312 12313 const struct language_defn ada_language_defn = { 12314 "ada", /* Language name */ 12315 language_ada, 12316 range_check_off, 12317 type_check_off, 12318 case_sensitive_on, /* Yes, Ada is case-insensitive, but 12319 that's not quite what this means. */ 12320 array_row_major, 12321 macro_expansion_no, 12322 &ada_exp_descriptor, 12323 parse, 12324 ada_error, 12325 resolve, 12326 ada_printchar, /* Print a character constant */ 12327 ada_printstr, /* Function to print string constant */ 12328 emit_char, /* Function to print single char (not used) */ 12329 ada_print_type, /* Print a type using appropriate syntax */ 12330 ada_print_typedef, /* Print a typedef using appropriate syntax */ 12331 ada_val_print, /* Print a value using appropriate syntax */ 12332 ada_value_print, /* Print a top-level value */ 12333 NULL, /* Language specific skip_trampoline */ 12334 NULL, /* name_of_this */ 12335 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */ 12336 basic_lookup_transparent_type, /* lookup_transparent_type */ 12337 ada_la_decode, /* Language specific symbol demangler */ 12338 NULL, /* Language specific 12339 class_name_from_physname */ 12340 ada_op_print_tab, /* expression operators for printing */ 12341 0, /* c-style arrays */ 12342 1, /* String lower bound */ 12343 ada_get_gdb_completer_word_break_characters, 12344 ada_make_symbol_completion_list, 12345 ada_language_arch_info, 12346 ada_print_array_index, 12347 default_pass_by_reference, 12348 c_get_string, 12349 compare_names, 12350 ada_iterate_over_symbols, 12351 LANG_MAGIC 12352 }; 12353 12354 /* Provide a prototype to silence -Wmissing-prototypes. */ 12355 extern initialize_file_ftype _initialize_ada_language; 12356 12357 /* Command-list for the "set/show ada" prefix command. */ 12358 static struct cmd_list_element *set_ada_list; 12359 static struct cmd_list_element *show_ada_list; 12360 12361 /* Implement the "set ada" prefix command. */ 12362 12363 static void 12364 set_ada_command (char *arg, int from_tty) 12365 { 12366 printf_unfiltered (_(\ 12367 "\"set ada\" must be followed by the name of a setting.\n")); 12368 help_list (set_ada_list, "set ada ", -1, gdb_stdout); 12369 } 12370 12371 /* Implement the "show ada" prefix command. */ 12372 12373 static void 12374 show_ada_command (char *args, int from_tty) 12375 { 12376 cmd_show_list (show_ada_list, from_tty, ""); 12377 } 12378 12379 static void 12380 initialize_ada_catchpoint_ops (void) 12381 { 12382 struct breakpoint_ops *ops; 12383 12384 initialize_breakpoint_ops (); 12385 12386 ops = &catch_exception_breakpoint_ops; 12387 *ops = bkpt_breakpoint_ops; 12388 ops->dtor = dtor_catch_exception; 12389 ops->allocate_location = allocate_location_catch_exception; 12390 ops->re_set = re_set_catch_exception; 12391 ops->check_status = check_status_catch_exception; 12392 ops->print_it = print_it_catch_exception; 12393 ops->print_one = print_one_catch_exception; 12394 ops->print_mention = print_mention_catch_exception; 12395 ops->print_recreate = print_recreate_catch_exception; 12396 12397 ops = &catch_exception_unhandled_breakpoint_ops; 12398 *ops = bkpt_breakpoint_ops; 12399 ops->dtor = dtor_catch_exception_unhandled; 12400 ops->allocate_location = allocate_location_catch_exception_unhandled; 12401 ops->re_set = re_set_catch_exception_unhandled; 12402 ops->check_status = check_status_catch_exception_unhandled; 12403 ops->print_it = print_it_catch_exception_unhandled; 12404 ops->print_one = print_one_catch_exception_unhandled; 12405 ops->print_mention = print_mention_catch_exception_unhandled; 12406 ops->print_recreate = print_recreate_catch_exception_unhandled; 12407 12408 ops = &catch_assert_breakpoint_ops; 12409 *ops = bkpt_breakpoint_ops; 12410 ops->dtor = dtor_catch_assert; 12411 ops->allocate_location = allocate_location_catch_assert; 12412 ops->re_set = re_set_catch_assert; 12413 ops->check_status = check_status_catch_assert; 12414 ops->print_it = print_it_catch_assert; 12415 ops->print_one = print_one_catch_assert; 12416 ops->print_mention = print_mention_catch_assert; 12417 ops->print_recreate = print_recreate_catch_assert; 12418 } 12419 12420 void 12421 _initialize_ada_language (void) 12422 { 12423 add_language (&ada_language_defn); 12424 12425 initialize_ada_catchpoint_ops (); 12426 12427 add_prefix_cmd ("ada", no_class, set_ada_command, 12428 _("Prefix command for changing Ada-specfic settings"), 12429 &set_ada_list, "set ada ", 0, &setlist); 12430 12431 add_prefix_cmd ("ada", no_class, show_ada_command, 12432 _("Generic command for showing Ada-specific settings."), 12433 &show_ada_list, "show ada ", 0, &showlist); 12434 12435 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure, 12436 &trust_pad_over_xvs, _("\ 12437 Enable or disable an optimization trusting PAD types over XVS types"), _("\ 12438 Show whether an optimization trusting PAD types over XVS types is activated"), 12439 _("\ 12440 This is related to the encoding used by the GNAT compiler. The debugger\n\ 12441 should normally trust the contents of PAD types, but certain older versions\n\ 12442 of GNAT have a bug that sometimes causes the information in the PAD type\n\ 12443 to be incorrect. Turning this setting \"off\" allows the debugger to\n\ 12444 work around this bug. It is always safe to turn this option \"off\", but\n\ 12445 this incurs a slight performance penalty, so it is recommended to NOT change\n\ 12446 this option to \"off\" unless necessary."), 12447 NULL, NULL, &set_ada_list, &show_ada_list); 12448 12449 add_catch_command ("exception", _("\ 12450 Catch Ada exceptions, when raised.\n\ 12451 With an argument, catch only exceptions with the given name."), 12452 catch_ada_exception_command, 12453 NULL, 12454 CATCH_PERMANENT, 12455 CATCH_TEMPORARY); 12456 add_catch_command ("assert", _("\ 12457 Catch failed Ada assertions, when raised.\n\ 12458 With an argument, catch only exceptions with the given name."), 12459 catch_assert_command, 12460 NULL, 12461 CATCH_PERMANENT, 12462 CATCH_TEMPORARY); 12463 12464 varsize_limit = 65536; 12465 12466 obstack_init (&symbol_list_obstack); 12467 12468 decoded_names_store = htab_create_alloc 12469 (256, htab_hash_string, (int (*)(const void *, const void *)) streq, 12470 NULL, xcalloc, xfree); 12471 12472 /* Setup per-inferior data. */ 12473 observer_attach_inferior_exit (ada_inferior_exit); 12474 ada_inferior_data 12475 = register_inferior_data_with_cleanup (ada_inferior_data_cleanup); 12476 } 12477